/[irc-logger]/trunk/bin/irc-logger.pl
This is repository of my old source code which isn't updated any more. Go to git.rot13.org for current projects!
ViewVC logotype

Annotation of /trunk/bin/irc-logger.pl

Parent Directory Parent Directory | Revision Log Revision Log


Revision 91 - (hide annotations)
Fri Mar 7 10:13:45 2008 UTC (16 years ago) by dpavlin
File MIME type: text/plain
File size: 30113 byte(s)
added rss-list and fixed rss-(stop|start) to actually work
1 dpavlin 4 #!/usr/bin/perl -w
2     use strict;
3     $|++;
4    
5 dpavlin 5 =head1 NAME
6    
7     irc-logger.pl
8    
9     =head1 SYNOPSIS
10    
11     ./irc-logger.pl
12    
13 dpavlin 37 =head2 Options
14    
15     =over 4
16    
17     =item --import-dircproxy=filename
18    
19     Import log from C<dircproxy> to C<irc-logger> database
20    
21 dpavlin 45 =item --log=irc-logger.log
22    
23     =back
24    
25 dpavlin 5 =head1 DESCRIPTION
26    
27     log all conversation on irc channel
28    
29     =cut
30    
31 dpavlin 4 ## CONFIG
32    
33 dpavlin 73 my $HOSTNAME = `hostname -f`;
34     chomp($HOSTNAME);
35 dpavlin 33
36 dpavlin 29 my $NICK = 'irc-logger';
37 dpavlin 33 $NICK .= '-dev' if ($HOSTNAME =~ m/llin/);
38 dpavlin 4 my $CONNECT =
39     {Server => 'irc.freenode.net',
40     Nick => $NICK,
41 dpavlin 8 Ircname => "try /msg $NICK help",
42 dpavlin 4 };
43     my $CHANNEL = '#razmjenavjestina';
44 dpavlin 33 $CHANNEL = '#irc-logger' if ($HOSTNAME =~ m/llin/);
45 dpavlin 4 my $IRC_ALIAS = "log";
46    
47 dpavlin 19 my $DSN = 'DBI:Pg:dbname=' . $NICK;
48 dpavlin 5
49 dpavlin 34 my $TIMESTAMP = '%Y-%m-%d %H:%M:%S';
50 dpavlin 14
51 dpavlin 41 my $sleep_on_error = 5;
52    
53 dpavlin 79 # number of last tags to keep in circular buffer
54     my $last_x_tags = 50;
55    
56 dpavlin 85 # don't pull rss feeds more often than this
57     my $rss_min_delay = 60;
58     $rss_min_delay = 15;
59    
60 dpavlin 70 my $http_port = $NICK =~ m/-dev/ ? 8001 : 8000;
61    
62 dpavlin 73 my $url = "http://$HOSTNAME:$http_port";
63    
64 dpavlin 4 ## END CONFIG
65    
66 dpavlin 90 use POE qw(Component::IRC Component::Server::HTTP);
67 dpavlin 13 use HTTP::Status;
68 dpavlin 5 use DBI;
69 dpavlin 15 use Regexp::Common qw /URI/;
70 dpavlin 16 use CGI::Simple;
71 dpavlin 28 use HTML::TagCloud;
72 dpavlin 34 use POSIX qw/strftime/;
73 dpavlin 35 use HTML::CalendarMonthSimple;
74 dpavlin 37 use Getopt::Long;
75     use DateTime;
76 dpavlin 61 use URI::Escape;
77 dpavlin 43 use Data::Dump qw/dump/;
78 dpavlin 63 use DateTime::Format::ISO8601;
79 dpavlin 68 use Carp qw/confess/;
80 dpavlin 70 use XML::Feed;
81     use DateTime::Format::Flexible;
82 dpavlin 5
83 dpavlin 54 my $use_twitter = 1;
84     eval { require Net::Twitter; };
85     $use_twitter = 0 if ($@);
86    
87 dpavlin 37 my $import_dircproxy;
88 dpavlin 45 my $log_path;
89 dpavlin 37 GetOptions(
90     'import-dircproxy:s' => \$import_dircproxy,
91 dpavlin 45 'log:s' => \$log_path,
92 dpavlin 37 );
93    
94 dpavlin 87 #$SIG{__DIE__} = sub {
95     # confess "fatal error";
96     #};
97 dpavlin 68
98 dpavlin 45 open(STDOUT, '>', $log_path) || warn "can't redirect log to $log_path: $!";
99    
100     sub _log {
101 dpavlin 88 print strftime($TIMESTAMP,localtime()) . ' ' . join(" ",@_) . $/;
102 dpavlin 45 }
103    
104 dpavlin 70 # HTML formatters
105    
106     my %escape = ('<'=>'&lt;', '>'=>'&gt;', '&'=>'&amp;', '"'=>'&quot;');
107     my $escape_re = join '|' => keys %escape;
108    
109     my $tag_regex = '\b([\w-_]+)//';
110    
111     my %nick_enumerator;
112     my $max_color = 0;
113    
114     my $filter = {
115     message => sub {
116     my $m = shift || return;
117    
118     # protect HTML from wiki modifications
119     sub e {
120     my $t = shift;
121     return 'uri_unescape{' . uri_escape($t) . '}';
122     }
123    
124     $m =~ s/($escape_re)/$escape{$1}/gs;
125     $m =~ s#($RE{URI}{HTTP})#e(qq{<a href="$1">$1</a>})#egs ||
126     $m =~ s#\/(\w+)\/#<i>$1</i>#gs;
127 dpavlin 73 $m =~ s#$tag_regex#e(qq{<a href="$url?tag=$1" class="tag">$1</a>})#egs;
128 dpavlin 70 $m =~ s#\*(\w+)\*#<b>$1</b>#gs;
129     $m =~ s#_(\w+)_#<u>$1</u>#gs;
130    
131     $m =~ s#uri_unescape{([^}]+)}#uri_unescape($1)#egs;
132     return $m;
133     },
134     nick => sub {
135     my $n = shift || return;
136     if (! $nick_enumerator{$n}) {
137     my $max = scalar keys %nick_enumerator;
138     $nick_enumerator{$n} = $max + 1;
139     }
140     return '<span class="nick col-' .
141     ( $nick_enumerator{$n} % $max_color ) .
142     '">' . $n . '</span>';
143     },
144     };
145    
146 dpavlin 5 my $dbh = DBI->connect($DSN,"","", { RaiseError => 1, AutoCommit => 1 }) || die $DBI::errstr;
147 dpavlin 88 $dbh->do( qq{ set client_encoding = 'UTF-8' } );
148 dpavlin 5
149 dpavlin 50 my $sql_schema = {
150 dpavlin 85 log => qq{
151 dpavlin 5 create table log (
152     id serial,
153     time timestamp default now(),
154     channel text not null,
155 dpavlin 19 me boolean default false,
156 dpavlin 5 nick text not null,
157     message text not null,
158     primary key(id)
159     );
160    
161     create index log_time on log(time);
162     create index log_channel on log(channel);
163     create index log_nick on log(nick);
164 dpavlin 85 },
165     meta => q{
166 dpavlin 50 create table meta (
167     nick text not null,
168     channel text not null,
169     name text not null,
170     value text,
171 dpavlin 85 changed timestamp default 'now()',
172 dpavlin 50 primary key(nick,channel,name)
173     );
174 dpavlin 85 },
175     feeds => qq{
176     create table feeds (
177     id serial,
178     url text not null,
179     name text,
180 dpavlin 86 delay interval not null default '5 min',
181 dpavlin 85 active boolean default true,
182     last_update timestamp default 'now()',
183     polls int default 0,
184     updates int default 0
185     );
186     create unique index feeds_url on feeds(url);
187     insert into feeds (url,name) values ('http://wiki.razmjenavjestina.org/feed/workspace/razmjenavjestina?category=Recent%20Changes','wiki');
188     },
189 dpavlin 50 };
190 dpavlin 5
191 dpavlin 50 foreach my $table ( keys %$sql_schema ) {
192    
193     eval {
194     $dbh->do(qq{ select count(*) from $table });
195     };
196    
197     if ($@) {
198     warn "creating database table $table in $DSN\n";
199     $dbh->do( $sql_schema->{ $table } );
200     }
201 dpavlin 19 }
202 dpavlin 5
203 dpavlin 50
204     =head2 meta
205    
206     Set or get some meta data into database
207    
208     meta('nick','channel','var_name', $var_value );
209    
210     $var_value = meta('nick','channel','var_name');
211     ( $var_value, $changed ) = meta('nick','channel','var_name');
212    
213     =cut
214    
215     sub meta {
216     my ($nick,$channel,$name,$value) = @_;
217    
218     # normalize channel name
219     $channel =~ s/^#//;
220    
221     if (defined($value)) {
222    
223     my $sth = $dbh->prepare(qq{ update meta set value = ?, changed = now() where nick = ? and channel = ? and name = ? });
224    
225     eval { $sth->execute( $value, $nick, $channel, $name ) };
226    
227     # error or no result
228     if ( $@ || ! $sth->rows ) {
229     $sth = $dbh->prepare(qq{ insert into meta (value,nick,channel,name,changed) values (?,?,?,?,now()) });
230     $sth->execute( $value, $nick, $channel, $name );
231     _log "created $nick/$channel/$name = $value";
232     } else {
233     _log "updated $nick/$channel/$name = $value ";
234     }
235    
236     return $value;
237    
238     } else {
239    
240     my $sth = $dbh->prepare(qq{ select value,changed from meta where nick = ? and channel = ? and name = ? });
241     $sth->execute( $nick, $channel, $name );
242     my ($v,$c) = $sth->fetchrow_array;
243     _log "fetched $nick/$channel/$name = $v [$c]";
244     return ($v,$c) if wantarray;
245     return $v;
246    
247     }
248     }
249    
250    
251    
252 dpavlin 87 my $sth_insert_log = $dbh->prepare(qq{
253 dpavlin 5 insert into log
254 dpavlin 37 (channel, me, nick, message, time)
255     values (?,?,?,?,?)
256 dpavlin 5 });
257    
258 dpavlin 50
259 dpavlin 28 my $tags;
260    
261 dpavlin 11 =head2 get_from_log
262 dpavlin 5
263 dpavlin 11 my @messages = get_from_log(
264     limit => 42,
265     search => '%what to stuff in ilike%',
266 dpavlin 13 fmt => {
267     time => '{%s} ',
268     time_channel => '{%s %s} ',
269     nick => '%s: ',
270 dpavlin 20 me_nick => '***%s ',
271 dpavlin 13 message => '%s',
272     },
273 dpavlin 20 filter => {
274     message => sub {
275     # modify message content
276     return shift;
277     }
278 dpavlin 21 },
279     context => 5,
280 dpavlin 42 full_rows => 1,
281 dpavlin 11 );
282    
283 dpavlin 20 Order is important. Fields are first passed through C<filter> (if available) and
284     then throgh C<< sprintf($fmt->{message}, $message >> if available.
285    
286 dpavlin 21 C<context> defines number of messages around each search hit for display.
287    
288 dpavlin 42 C<full_rows> will return database rows for each result with C<date>, C<time>, C<channel>,
289     C<me>, C<nick> and C<message> keys.
290    
291 dpavlin 11 =cut
292    
293     sub get_from_log {
294     my $args = {@_};
295    
296 dpavlin 68 if ( ! $args->{fmt} ) {
297     $args->{fmt} = {
298     date => '[%s] ',
299     time => '{%s} ',
300     time_channel => '{%s %s} ',
301     nick => '%s: ',
302     me_nick => '***%s ',
303     message => '%s',
304     };
305     }
306 dpavlin 13
307 dpavlin 21 my $sql_message = qq{
308 dpavlin 11 select
309     time::date as date,
310     time::time as time,
311     channel,
312 dpavlin 20 me,
313 dpavlin 11 nick,
314     message
315     from log
316     };
317 dpavlin 21
318     my $sql_context = qq{
319     select
320     id
321     from log
322     };
323    
324     my $context = $1 if ($args->{search} && $args->{search} =~ s/\s*\+(\d+)\s*/ /);
325    
326     my $sql = $context ? $sql_context : $sql_message;
327    
328 dpavlin 67 sub check_date {
329 dpavlin 68 my $date = shift || return;
330     my $new_date = eval { DateTime::Format::ISO8601->parse_datetime( $date )->ymd; };
331 dpavlin 64 if ( $@ ) {
332 dpavlin 68 warn "invalid date $date\n";
333     $new_date = DateTime->now->ymd;
334 dpavlin 64 }
335 dpavlin 68 return $new_date;
336 dpavlin 67 }
337    
338 dpavlin 68 my @where;
339     my @args;
340    
341     if (my $search = $args->{search}) {
342     $search =~ s/^\s+//;
343     $search =~ s/\s+$//;
344     push @where, 'message ilike ? or nick ilike ?';
345     push @args, ( ( '%' . $search . '%' ) x 2 );
346     _log "search for '$search'";
347 dpavlin 63 }
348 dpavlin 68
349     if ($args->{tag} && $tags->{ $args->{tag} }) {
350     push @where, 'id in (' . join(',', @{ $tags->{ $args->{tag} } }) . ')';
351     _log "search for tags $args->{tag}";
352     }
353    
354     if (my $date = $args->{date} ) {
355     $date = check_date( $date );
356     push @where, 'date(time) = ?';
357     push @args, $date;
358     _log "search for date $date";
359     }
360    
361     $sql .= " where " . join(" and ", @where) if @where;
362    
363 dpavlin 11 $sql .= " order by log.time desc";
364 dpavlin 35 $sql .= " limit " . $args->{limit} if ($args->{limit});
365 dpavlin 11
366 dpavlin 68 #warn "### sql: $sql ", dump( @args );
367    
368 dpavlin 11 my $sth = $dbh->prepare( $sql );
369 dpavlin 69 eval { $sth->execute( @args ) };
370     return if $@;
371 dpavlin 68
372 dpavlin 11 my $last_row = {
373     date => '',
374     time => '',
375     channel => '',
376     nick => '',
377     };
378    
379     my @rows;
380    
381     while (my $row = $sth->fetchrow_hashref) {
382     unshift @rows, $row;
383     }
384    
385 dpavlin 42 # normalize nick names
386     map {
387     $_->{nick} =~ s/^_*(.*?)_*$/$1/
388     } @rows;
389    
390     return @rows if ($args->{full_rows});
391    
392 dpavlin 16 my @msgs = (
393     "Showing " . ($#rows + 1) . " messages..."
394     );
395 dpavlin 11
396 dpavlin 21 if ($context) {
397     my @ids = @rows;
398     @rows = ();
399    
400     my $last_to = 0;
401    
402     my $sth = $dbh->prepare( $sql_message . qq{ where id >= ? and id < ? } );
403     foreach my $row_id (sort { $a->{id} <=> $b->{id} } @ids) {
404     my $id = $row_id->{id} || die "can't find id in row";
405    
406     my ($from, $to) = ($id - $context, $id + $context);
407     $from = $last_to if ($from < $last_to);
408     $last_to = $to;
409     $sth->execute( $from, $to );
410    
411     #warn "## id: $id from: $from to: $to returned: ", $sth->rows, "\n";
412    
413     while (my $row = $sth->fetchrow_hashref) {
414     push @rows, $row;
415     }
416    
417     }
418     }
419    
420 dpavlin 35 # sprintf which can take coderef as first parametar
421     sub cr_sprintf {
422     my $fmt = shift || return;
423     if (ref($fmt) eq 'CODE') {
424     $fmt->(@_);
425     } else {
426     sprintf($fmt, @_);
427     }
428     }
429    
430 dpavlin 11 foreach my $row (@rows) {
431    
432     $row->{time} =~ s#\.\d+##;
433    
434     my $msg = '';
435    
436 dpavlin 35 $msg = cr_sprintf($args->{fmt}->{date}, $row->{date}) . ' ' if ($last_row->{date} ne $row->{date});
437 dpavlin 26 my $t = $row->{time};
438    
439 dpavlin 13 if ($last_row->{channel} ne $row->{channel}) {
440 dpavlin 35 $msg .= cr_sprintf($args->{fmt}->{time_channel}, $t, $row->{channel});
441 dpavlin 13 } else {
442 dpavlin 35 $msg .= cr_sprintf($args->{fmt}->{time}, $t);
443 dpavlin 13 }
444 dpavlin 11
445 dpavlin 12 my $append = 1;
446 dpavlin 11
447 dpavlin 22 my $nick = $row->{nick};
448 dpavlin 42 # if ($nick =~ s/^_*(.*?)_*$/$1/) {
449     # $row->{nick} = $nick;
450     # }
451 dpavlin 24
452 dpavlin 22 if ($last_row->{nick} ne $nick) {
453 dpavlin 20 # obfu way to find format for me_nick if needed or fallback to default
454     my $fmt = $row->{me} ? ( $args->{fmt}->{me_nick} || $args->{fmt}->{nick} ) : $args->{fmt}->{nick};
455     $fmt ||= '%s';
456    
457     $nick = $args->{filter}->{nick}->($nick) if (ref($args->{filter}->{nick}) eq 'CODE');
458    
459 dpavlin 35 $msg .= cr_sprintf( $fmt, $nick );
460 dpavlin 12 $append = 0;
461     }
462    
463 dpavlin 20 $args->{fmt}->{message} ||= '%s';
464     if (ref($args->{filter}->{message}) eq 'CODE') {
465 dpavlin 35 $msg .= cr_sprintf($args->{fmt}->{message},
466 dpavlin 20 $args->{filter}->{message}->(
467 dpavlin 15 $row->{message}
468     )
469     );
470     } else {
471 dpavlin 35 $msg .= cr_sprintf($args->{fmt}->{message}, $row->{message});
472 dpavlin 15 }
473 dpavlin 11
474 dpavlin 12 if ($append && @msgs) {
475     $msgs[$#msgs] .= " " . $msg;
476     } else {
477     push @msgs, $msg;
478     }
479 dpavlin 11
480     $last_row = $row;
481     }
482    
483     return @msgs;
484     }
485    
486 dpavlin 37 # tags support
487 dpavlin 11
488 dpavlin 37 my $cloud = HTML::TagCloud->new;
489 dpavlin 4
490 dpavlin 37 =head2 add_tag
491 dpavlin 4
492 dpavlin 70 add_tag( id => 42, message => 'irc message', nick => 'foobar' [, me => 1 ] );
493 dpavlin 37
494     =cut
495    
496 dpavlin 70 my @last_tags;
497    
498 dpavlin 37 sub add_tag {
499     my $arg = {@_};
500    
501     return unless ($arg->{id} && $arg->{message});
502    
503     my $m = $arg->{message};
504    
505 dpavlin 70 my @tags;
506    
507 dpavlin 37 while ($m =~ s#$tag_regex##s) {
508     my $tag = $1;
509     next if (! $tag || $tag =~ m/https?:/i);
510     push @{ $tags->{$tag} }, $arg->{id};
511     #warn "+tag $tag: $arg->{id}\n";
512 dpavlin 73 $cloud->add($tag, "$url?tag=$tag", scalar @{$tags->{$tag}} + 1);
513 dpavlin 70 push @tags, $tag;
514    
515 dpavlin 37 }
516 dpavlin 70
517     if ( @tags ) {
518 dpavlin 74 pop @last_tags if $#last_tags == $last_x_tags;
519     unshift @last_tags, { tags => [ @tags ], %$arg };
520 dpavlin 70 }
521    
522 dpavlin 37 }
523    
524     =head2 seed_tags
525    
526     Read all tags from database and create in-memory cache for tags
527    
528     =cut
529    
530     sub seed_tags {
531 dpavlin 74 my $sth = $dbh->prepare(qq{ select id,message,nick,me,time from log where message like '%//%' order by time asc });
532 dpavlin 37 $sth->execute;
533     while (my $row = $sth->fetchrow_hashref) {
534     add_tag( %$row );
535     }
536    
537     foreach my $tag (keys %$tags) {
538 dpavlin 73 $cloud->add($tag, "$url?tag=$tag", scalar @{$tags->{$tag}} + 1);
539 dpavlin 37 }
540     }
541    
542     seed_tags;
543    
544    
545 dpavlin 36 =head2 save_message
546    
547 dpavlin 37 save_message(
548     channel => '#foobar',
549     me => 0,
550     nick => 'dpavlin',
551 dpavlin 70 message => 'test message',
552 dpavlin 37 time => '2006-06-25 18:57:18',
553     );
554 dpavlin 36
555 dpavlin 37 C<time> is optional, it will use C<< now() >> if it's not available.
556    
557     C<me> if not specified will be C<0> (not C</me> message)
558    
559 dpavlin 36 =cut
560    
561     sub save_message {
562 dpavlin 37 my $a = {@_};
563 dpavlin 70 confess "have msg" if $a->{msg};
564 dpavlin 37 $a->{me} ||= 0;
565 dpavlin 38 $a->{time} ||= strftime($TIMESTAMP,localtime());
566 dpavlin 37
567 dpavlin 45 _log
568 dpavlin 37 $a->{channel}, " ",
569     $a->{me} ? "***" . $a->{nick} : "<" . $a->{nick} . ">",
570 dpavlin 70 " " . $a->{message};
571 dpavlin 37
572 dpavlin 87 $sth_insert_log->execute($a->{channel}, $a->{me}, $a->{nick}, $a->{message}, $a->{time});
573 dpavlin 70 add_tag( id => $dbh->last_insert_id(undef,undef,"log",undef), %$a );
574 dpavlin 36 }
575    
576 dpavlin 50
577 dpavlin 37 if ($import_dircproxy) {
578     open(my $l, $import_dircproxy) || die "can't open $import_dircproxy: $!";
579     warn "importing $import_dircproxy...\n";
580 dpavlin 69 my $tz_offset = 1 * 60 * 60; # TZ GMT+2
581 dpavlin 37 while(<$l>) {
582     chomp;
583     if (/^@(\d+)\s(\S+)\s(.+)$/) {
584     my ($time, $nick, $msg) = ($1,$2,$3);
585    
586     my $dt = DateTime->from_epoch( epoch => $time + $tz_offset );
587    
588     my $me = 0;
589     $me = 1 if ($nick =~ m/^\[\S+]/);
590     $nick =~ s/^[\[<]([^!]+).*$/$1/;
591    
592     $msg =~ s/^ACTION\s+// if ($me);
593    
594     save_message(
595     channel => $CHANNEL,
596     me => $me,
597     nick => $nick,
598 dpavlin 70 message => $msg,
599 dpavlin 37 time => $dt->ymd . " " . $dt->hms,
600     ) if ($nick !~ m/^-/);
601    
602     } else {
603 dpavlin 45 _log "can't parse: $_";
604 dpavlin 37 }
605     }
606     close($l);
607     warn "import over\n";
608     exit;
609     }
610    
611 dpavlin 85 #
612     # RSS follow
613     #
614 dpavlin 37
615 dpavlin 85 my $_rss;
616    
617    
618     sub rss_fetch {
619     my ($args) = @_;
620    
621     # how many messages to send out when feed is seen for the first time?
622     my $send_rss_msgs = 1;
623    
624 dpavlin 87 _log "RSS fetch", $args->{url};
625    
626 dpavlin 85 my $feed = XML::Feed->parse(URI->new( $args->{url} ));
627     if ( ! $feed ) {
628     _log("can't fetch RSS ", $args->{url});
629     return;
630     }
631 dpavlin 87 my ( $total, $updates ) = ( 0, 0 );
632 dpavlin 85 for my $entry ($feed->entries) {
633 dpavlin 87 $total++;
634 dpavlin 85
635     # seen allready?
636     return if $_rss->{$feed->link}->{seen}->{$entry->id}++ > 0;
637    
638     sub prefix {
639     my ($txt,$var) = @_;
640     $var =~ s/^\s+//g;
641     return $txt . $var if $var;
642     }
643    
644     my $msg;
645 dpavlin 90 $msg .= prefix( 'From: ' , $args->{name} || $feed->title );
646 dpavlin 85 $msg .= prefix( ' by ' , $entry->author );
647     $msg .= prefix( ' -- ' , $entry->link );
648     # $msg .= prefix( ' id ' , $entry->id );
649    
650     if ( $args->{kernel} && $send_rss_msgs ) {
651     $send_rss_msgs--;
652 dpavlin 88 _log('RSS', $msg);
653     $sth_insert_log->execute( $CHANNEL, 1, $NICK, $msg, undef );
654 dpavlin 85 $args->{kernel}->post( $IRC_ALIAS => notice => $CHANNEL, $msg );
655     $updates++;
656     }
657     }
658    
659     my $sql = qq{ update feeds set last_update = now(), polls = polls + 1 };
660     $sql .= qq{, updates = updates + $updates } if $updates;
661     $sql .= qq{where id = } . $args->{id};
662 dpavlin 86 eval { $dbh->do( $sql ) };
663 dpavlin 85
664 dpavlin 87 _log "RSS got $total items of which $updates new";
665    
666 dpavlin 85 return $updates;
667     }
668    
669     sub rss_fetch_all {
670     my $kernel = shift;
671     my $sql = qq{
672     select id, url, name
673     from feeds
674     where active is true
675     };
676     # limit to newer feeds only if we are not sending messages out
677     $sql .= qq{ and last_update + delay < now() } if $kernel;
678     my $sth = $dbh->prepare( $sql );
679     $sth->execute();
680     warn "# ",$sth->rows," active RSS feeds\n";
681     my $count = 0;
682     while (my $row = $sth->fetchrow_hashref) {
683     $row->{kernel} = $kernel if $kernel;
684     $count += rss_fetch( $row );
685     }
686     return "OK, fetched $count posts from " . $sth->rows . " feeds";
687     }
688    
689    
690     sub rss_check_updates {
691     my $kernel = shift;
692 dpavlin 87 my $last_t = $_rss->{last_poll} || time();
693 dpavlin 85 my $t = time();
694 dpavlin 90 if ( $t - $last_t > $rss_min_delay ) {
695 dpavlin 87 $_rss->{last_poll} = $t;
696 dpavlin 85 _log rss_fetch_all( $kernel );
697     }
698     }
699    
700     # seed rss seen cache so we won't send out all items on startup
701     _log rss_fetch_all;
702    
703 dpavlin 37 #
704     # POE handing part
705     #
706    
707 dpavlin 43 my $ping; # ping stats
708 dpavlin 37
709     POE::Component::IRC->new($IRC_ALIAS);
710    
711 dpavlin 85 POE::Session->create( inline_states => {
712     _start => sub {
713 dpavlin 7 $_[KERNEL]->post($IRC_ALIAS => register => 'all');
714     $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);
715 dpavlin 4 },
716 dpavlin 9 irc_255 => sub { # server is done blabbing
717 dpavlin 7 $_[KERNEL]->post($IRC_ALIAS => join => $CHANNEL);
718 dpavlin 11 $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );
719 dpavlin 4 },
720     irc_public => sub {
721 dpavlin 7 my $kernel = $_[KERNEL];
722     my $nick = (split /!/, $_[ARG0])[0];
723     my $channel = $_[ARG1]->[0];
724     my $msg = $_[ARG2];
725 dpavlin 4
726 dpavlin 70 save_message( channel => $channel, me => 0, nick => $nick, message => $msg);
727 dpavlin 50 meta( $nick, $channel, 'last-msg', $msg );
728 dpavlin 4 },
729 dpavlin 19 irc_ctcp_action => sub {
730     my $kernel = $_[KERNEL];
731     my $nick = (split /!/, $_[ARG0])[0];
732     my $channel = $_[ARG1]->[0];
733     my $msg = $_[ARG2];
734    
735 dpavlin 70 save_message( channel => $channel, me => 1, nick => $nick, message => $msg);
736 dpavlin 50
737 dpavlin 54 if ( $use_twitter ) {
738 dpavlin 58 if ( my $twitter = meta( $nick, $NICK, 'twitter' ) ) {
739 dpavlin 54 my ($login,$passwd) = split(/\s+/,$twitter,2);
740     _log("sending twitter for $nick/$login on $channel ");
741     my $bot = Net::Twitter->new( username=>$login, password=>$passwd );
742     $bot->update("<${channel}> $msg");
743     }
744 dpavlin 50 }
745    
746 dpavlin 19 },
747 dpavlin 43 irc_ping => sub {
748 dpavlin 84 _log( "pong ", $_[ARG0] );
749 dpavlin 48 $ping->{ $_[ARG0] }++;
750 dpavlin 85 rss_check_updates( $_[KERNEL] );
751 dpavlin 43 },
752     irc_invite => sub {
753     my $kernel = $_[KERNEL];
754     my $nick = (split /!/, $_[ARG0])[0];
755     my $channel = $_[ARG1];
756    
757 dpavlin 85 _log "invited to $channel by $nick";
758 dpavlin 43
759     $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, "how nice of you to invite me to $channel, I'll be right there..." );
760     $_[KERNEL]->post($IRC_ALIAS => join => $channel);
761    
762     },
763 dpavlin 7 irc_msg => sub {
764     my $kernel = $_[KERNEL];
765     my $nick = (split /!/, $_[ARG0])[0];
766     my $msg = $_[ARG2];
767 dpavlin 50 my $channel = $_[ARG1]->[0];
768 dpavlin 7
769 dpavlin 8 my $res = "unknown command '$msg', try /msg $NICK help!";
770 dpavlin 11 my @out;
771 dpavlin 7
772 dpavlin 45 _log "<< $msg";
773 dpavlin 7
774 dpavlin 8 if ($msg =~ m/^help/i) {
775 dpavlin 7
776 dpavlin 11 $res = "usage: /msg $NICK comand | commands: stat - user/message stat | last - show backtrace | grep foobar - find foobar";
777 dpavlin 8
778 dpavlin 10 } elsif ($msg =~ m/^msg\s+(\S+)\s+(.*)$/i) {
779    
780 dpavlin 45 _log ">> /msg $1 $2";
781 dpavlin 10 $_[KERNEL]->post( $IRC_ALIAS => privmsg => $1, $2 );
782     $res = '';
783    
784 dpavlin 8 } elsif ($msg =~ m/^stat.*?\s*(\d*)/i) {
785    
786 dpavlin 7 my $nr = $1 || 10;
787    
788     my $sth = $dbh->prepare(qq{
789 dpavlin 40 select
790 dpavlin 57 trim(both '_' from nick) as nick,
791 dpavlin 40 count(*) as count,
792     sum(length(message)) as len
793     from log
794 dpavlin 57 group by trim(both '_' from nick)
795 dpavlin 40 order by len desc,count desc
796     limit $nr
797 dpavlin 7 });
798     $sth->execute();
799     $res = "Top $nr users: ";
800 dpavlin 8 my @users;
801 dpavlin 7 while (my $row = $sth->fetchrow_hashref) {
802 dpavlin 40 push @users,$row->{nick} . ': ' . $row->{count} . '/' . $row->{len} . '=' . sprintf("%.2f", $row->{len}/$row->{count});
803 dpavlin 7 }
804 dpavlin 8 $res .= join(" | ", @users);
805     } elsif ($msg =~ m/^last.*?\s*(\d*)/i) {
806    
807 dpavlin 50 my $limit = $1 || meta( $nick, $channel, 'last-size' ) || 10;
808    
809     foreach my $res (get_from_log( limit => $limit )) {
810 dpavlin 45 _log "last: $res";
811 dpavlin 11 $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );
812 dpavlin 8 }
813    
814 dpavlin 11 $res = '';
815 dpavlin 8
816 dpavlin 21 } elsif ($msg =~ m/^(search|grep)\s+(.*)\s*$/i) {
817 dpavlin 8
818 dpavlin 11 my $what = $2;
819 dpavlin 8
820 dpavlin 21 foreach my $res (get_from_log(
821     limit => 20,
822     search => $what,
823     )) {
824 dpavlin 45 _log "search [$what]: $res";
825 dpavlin 8 $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );
826     }
827    
828     $res = '';
829 dpavlin 11
830 dpavlin 42 } elsif ($msg =~ m/^(?:count|poll)\s+(.*)(?:\s+(\d+))?\s*$/i) {
831    
832     my ($what,$limit) = ($1,$2);
833     $limit ||= 100;
834    
835     my $stat;
836    
837     foreach my $res (get_from_log(
838     limit => $limit,
839     search => $what,
840     full_rows => 1,
841     )) {
842     while ($res->{message} =~ s/\Q$what\E(\+|\-)//) {
843     $stat->{vote}->{$1}++;
844     $stat->{from}->{ $res->{nick} }++;
845     }
846     }
847    
848     my @nicks;
849 dpavlin 43 foreach my $nick (sort { $stat->{from}->{$a} <=> $stat->{from}->{$b} } keys %{ $stat->{from} }) {
850     push @nicks, $nick . ( $stat->{from}->{$nick} == 1 ? '' :
851     "(" . $stat->{from}->{$nick} . ")"
852     );
853 dpavlin 42 }
854    
855     $res =
856 dpavlin 43 "$what ++ " . ( $stat->{vote}->{'+'} || 0 ) .
857     " : " . ( $stat->{vote}->{'-'} || 0 ) . " --" .
858 dpavlin 42 " from " . ( join(", ", @nicks) || 'nobody' );
859    
860 dpavlin 43 $_[KERNEL]->post( $IRC_ALIAS => notice => $nick, $res );
861    
862     } elsif ($msg =~ m/^ping/) {
863     $res = "ping = " . dump( $ping );
864 dpavlin 51 } elsif ($msg =~ m/^conf(?:ig)*\s*(last-size|twitter)*\s*(.*)/) {
865 dpavlin 50 if ( ! defined( $1 ) ) {
866     my $sth = $dbh->prepare(qq{ select name,value,changed from meta where nick = ? and channel = ? });
867     $sth->execute( $nick, $channel );
868 dpavlin 52 $res = "config for $nick on $channel";
869 dpavlin 50 while ( my ($n,$v) = $sth->fetchrow_array ) {
870 dpavlin 52 $res .= " | $n = $v";
871 dpavlin 50 }
872 dpavlin 51 } elsif ( ! $2 ) {
873 dpavlin 50 my $val = meta( $nick, $channel, $1 );
874     $res = "current $1 = " . ( $val ? $val : 'undefined' );
875 dpavlin 51 } else {
876     my $validate = {
877     'last-size' => qr/^\d+/,
878     'twitter' => qr/^\w+\s+\w+/,
879     };
880    
881     my ( $op, $val ) = ( $1, $2 );
882    
883     if ( my $regex = $validate->{$op} ) {
884     if ( $val =~ $regex ) {
885     meta( $nick, $channel, $op, $val );
886     $res = "saved $op = $val";
887     } else {
888     $res = "config option $op = $val doesn't validate against $regex";
889     }
890     } else {
891     $res = "config option $op doesn't exist";
892     }
893 dpavlin 50 }
894 dpavlin 85 } elsif ($msg =~ m/^rss-update/) {
895     $res = rss_fetch_all( $_[KERNEL] );
896     } elsif ($msg =~ m/^rss-clean/) {
897     $_rss = undef;
898 dpavlin 90 $dbh->do( qq{ update feeds set last_update = now() - delay } );
899 dpavlin 85 $res = "OK, cleaned RSS cache";
900 dpavlin 91 } elsif ($msg =~ m/^rss-list/) {
901     my $sth = $dbh->prepare(qq{ select url,name,last_update,active from feeds });
902     $sth->execute;
903     while (my @row = $sth->fetchrow_array) {
904     $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, join(' | ',@row) );
905     }
906     $res = '';
907 dpavlin 85 } elsif ($msg =~ m!^rss-(add|remove|stop|start)\s+(http://\S+)\s*(.*)!) {
908     my $sql = {
909     add => qq{ insert into feeds (url,name) values (?,?) },
910     # remove => qq{ delete from feeds where url = ? and name = ? },
911 dpavlin 91 start => qq{ update feeds set active = true where url = ? },
912     stop => qq{ update feeds set active = false where url = ? },
913 dpavlin 85
914     };
915     if (my $q = $sql->{$1} ) {
916     my $sth = $dbh->prepare( $q );
917 dpavlin 91 my @data = ( $2 );
918     push @data, $3 if ( $q =~ s/\?//g == 2 );
919     warn "## $1 SQL $q with ",dump( @data ),"\n";
920     eval { $sth->execute( @data ) };
921 dpavlin 85 }
922    
923 dpavlin 90 $res = "OK, RSS $1 : $2 - $3";
924 dpavlin 7 }
925    
926 dpavlin 8 if ($res) {
927 dpavlin 45 _log ">> [$nick] $res";
928 dpavlin 8 $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );
929     }
930 dpavlin 7
931 dpavlin 85 rss_check_updates( $_[KERNEL] );
932 dpavlin 7 },
933 dpavlin 10 irc_477 => sub {
934 dpavlin 45 _log "# irc_477: ",$_[ARG1];
935 dpavlin 10 $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "register $NICK" );
936     },
937 dpavlin 7 irc_505 => sub {
938 dpavlin 45 _log "# irc_505: ",$_[ARG1];
939 dpavlin 7 $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "register $NICK" );
940 dpavlin 10 # $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "set hide email on" );
941     # $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "set email dpavlin\@rot13.org" );
942 dpavlin 8 },
943     irc_registered => sub {
944 dpavlin 45 _log "## registrated $NICK";
945 dpavlin 7 $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );
946 dpavlin 10 },
947 dpavlin 41 irc_disconnected => sub {
948 dpavlin 45 _log "## disconnected, reconnecting again";
949 dpavlin 41 $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);
950     },
951     irc_socketerr => sub {
952 dpavlin 45 _log "## socket error... sleeping for $sleep_on_error seconds and retry";
953 dpavlin 41 sleep($sleep_on_error);
954     $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);
955     },
956 dpavlin 11 # irc_433 => sub {
957     # print "# irc_433: ",$_[ARG1], "\n";
958     # warn "## indetify $NICK\n";
959     # $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );
960     # },
961 dpavlin 4 _child => sub {},
962     _default => sub {
963 dpavlin 45 _log sprintf "sID:%s %s %s",
964     $_[SESSION]->ID, $_[ARG0],
965 dpavlin 34 ref($_[ARG1]) eq "ARRAY" ? join(",", map { ref($_) eq "ARRAY" ? join(";", @{$_}) : $_ } @{ $_[ARG1] }) :
966     $_[ARG1] ? $_[ARG1] :
967     "";
968 dpavlin 4 0; # false for signals
969     },
970     },
971     );
972    
973 dpavlin 13 # http server
974    
975     my $httpd = POE::Component::Server::HTTP->new(
976 dpavlin 70 Port => $http_port,
977 dpavlin 83 PreHandler => {
978     '/' => sub {
979     $_[0]->header(Connection => 'close')
980     }
981     },
982 dpavlin 13 ContentHandler => { '/' => \&root_handler },
983     Headers => { Server => 'irc-logger' },
984     );
985    
986     my $style = <<'_END_OF_STYLE_';
987 dpavlin 16 p { margin: 0; padding: 0.1em; }
988 dpavlin 13 .time, .channel { color: #808080; font-size: 60%; }
989 dpavlin 28 .date { float: right; background: #e0e0e0; color: #404040; font-size: 120%; padding: 0.25em; border: 1px dashed #808080; }
990 dpavlin 20 .nick { color: #000000; font-size: 80%; padding: 2px; font-family: courier, courier new, monospace ; }
991 dpavlin 13 .message { color: #000000; font-size: 100%; }
992 dpavlin 16 .search { float: right; }
993 dpavlin 60 a:link.tag, a:visited.tag { border: 1px dashed #ccc; backgound: #ccc; text-decoration: none }
994     a:hover.tag { border: 1px solid #eee }
995     hr { border: 1px dashed #ccc; height: 1px; clear: both; }
996     /*
997 dpavlin 20 .col-0 { background: #ffff66 }
998     .col-1 { background: #a0ffff }
999     .col-2 { background: #99ff99 }
1000     .col-3 { background: #ff9999 }
1001     .col-4 { background: #ff66ff }
1002 dpavlin 60 */
1003 dpavlin 65 .calendar { border: 1px solid red; width: 100%; }
1004     .month { border: 0px; width: 100%; }
1005 dpavlin 13 _END_OF_STYLE_
1006    
1007 dpavlin 70 $max_color = 0;
1008 dpavlin 20
1009 dpavlin 60 my @cols = qw(
1010     #ffcccc #ccffe6 #ccccff #e6ccff #ffccff #ffcce6 #ff9999 #ffcc99 #ffff99
1011     #ccff99 #99ff99 #99ffcc #99ccff #9999ff #cc99ff #ff6666 #ffb366 #ffff66
1012     #66ff66 #66ffb3 #66b3ff #6666ff #ff3333 #33ff33 #3399ff #3333ff #ff3399
1013     #a0a0a0 #ff0000 #ffff00 #80ff00 #0000ff #8000ff #ff00ff #ff0080 #994d00
1014     #999900 #009900 #cc0066 #c0c0c0 #ccff99 #99ff33 #808080 #660033 #ffffff
1015     );
1016    
1017     foreach my $c (@cols) {
1018     $style .= ".col-${max_color} { background: $c }\n";
1019     $max_color++;
1020     }
1021     warn "defined $max_color colors for users...\n";
1022    
1023 dpavlin 13 sub root_handler {
1024     my ($request, $response) = @_;
1025     $response->code(RC_OK);
1026 dpavlin 16
1027 dpavlin 83 # this doesn't seem to work, so moved to PreHandler
1028     #$response->header(Connection => 'close');
1029    
1030 dpavlin 73 return RC_OK if $request->uri =~ m/favicon.ico$/;
1031    
1032 dpavlin 16 my $q;
1033    
1034     if ( $request->method eq 'POST' ) {
1035     $q = new CGI::Simple( $request->content );
1036     } elsif ( $request->uri =~ /\?(.+)$/ ) {
1037     $q = new CGI::Simple( $1 );
1038     } else {
1039     $q = new CGI::Simple;
1040     }
1041    
1042     my $search = $q->param('search') || $q->param('grep') || '';
1043    
1044 dpavlin 85 if ($request->url =~ m#/rss(?:/(tags|last-tag|follow.*)\w*(?:=(\d+))?)?#i) {
1045 dpavlin 77 my $show = lc($1);
1046 dpavlin 79 my $nr = $2;
1047 dpavlin 77
1048 dpavlin 71 my $type = 'RSS'; # Atom
1049 dpavlin 70
1050 dpavlin 72 $response->content_type( 'application/' . lc($type) . '+xml' );
1051 dpavlin 70
1052     my $html = '<!-- error -->';
1053 dpavlin 74 #warn "create $type feed from ",dump( @last_tags );
1054 dpavlin 70
1055     my $feed = XML::Feed->new( $type );
1056 dpavlin 85 $feed->link( $url );
1057 dpavlin 70
1058 dpavlin 77 if ( $show eq 'tags' ) {
1059 dpavlin 79 $nr ||= 50;
1060 dpavlin 77 $feed->title( "tags from $CHANNEL" );
1061     $feed->link( "$url/tags" );
1062     $feed->description( "tag cloud created from messages on channel $CHANNEL which have tags// in them" );
1063 dpavlin 70 my $feed_entry = XML::Feed::Entry->new($type);
1064 dpavlin 79 $feed_entry->title( "$nr tags from $CHANNEL" );
1065 dpavlin 77 $feed_entry->author( $NICK );
1066     $feed_entry->link( '/#tags' );
1067 dpavlin 75
1068 dpavlin 73 $feed_entry->content(
1069 dpavlin 77 qq{<![CDATA[<style type="text/css">}
1070     . $cloud->css
1071     . qq{</style>}
1072 dpavlin 79 . $cloud->html( $nr )
1073 dpavlin 77 . qq{]]>}
1074 dpavlin 70 );
1075     $feed->add_entry( $feed_entry );
1076 dpavlin 77
1077 dpavlin 79 } elsif ( $show eq 'last-tag' ) {
1078 dpavlin 77
1079 dpavlin 79 $nr ||= $last_x_tags;
1080 dpavlin 80 $nr = $last_x_tags if $nr > $last_x_tags;
1081 dpavlin 79
1082     $feed->title( "last $nr tagged messages from $CHANNEL" );
1083 dpavlin 77 $feed->description( "collects messages which have tags// in them" );
1084    
1085     foreach my $m ( @last_tags ) {
1086     # warn dump( $m );
1087     #my $tags = join(' ', @{$m->{tags}} );
1088     my $feed_entry = XML::Feed::Entry->new($type);
1089     $feed_entry->title( $m->{nick} . '@' . $m->{time} );
1090     $feed_entry->author( $m->{nick} );
1091     $feed_entry->link( '/#' . $m->{id} );
1092     $feed_entry->issued( DateTime::Format::Flexible->build( $m->{time} ) );
1093    
1094     my $message = $filter->{message}->( $m->{message} );
1095     $message .= "<br/>\n" unless $message =~ m!<(/p|br/?)>!;
1096 dpavlin 79 # warn "## message = $message\n";
1097 dpavlin 77
1098     #$feed_entry->summary(
1099     $feed_entry->content(
1100     "<![CDATA[$message]]>"
1101     );
1102     $feed_entry->category( join(', ', @{$m->{tags}}) );
1103     $feed->add_entry( $feed_entry );
1104 dpavlin 79
1105     $nr--;
1106     last if $nr <= 0;
1107    
1108 dpavlin 77 }
1109 dpavlin 79
1110 dpavlin 85 } elsif ( $show =~ m/^follow/ ) {
1111    
1112     $feed->title( "Feeds which this bot follows" );
1113    
1114     my $sth = $dbh->prepare( qq{ select * from feeds order by last_update desc } );
1115     $sth->execute;
1116     while (my $row = $sth->fetchrow_hashref) {
1117     my $feed_entry = XML::Feed::Entry->new($type);
1118     $feed_entry->title( $row->{name} );
1119     $feed_entry->link( $row->{url} );
1120     $feed_entry->issued( DateTime::Format::Flexible->build( $row->{last_update} ) );
1121     $feed_entry->content(
1122     '<![CDATA[<pre>' . dump( $row ) . '</pre>]]>'
1123     );
1124     $feed->add_entry( $feed_entry );
1125     }
1126    
1127 dpavlin 79 } else {
1128 dpavlin 85 _log "unknown rss request ",$request->url;
1129 dpavlin 79 return RC_DENY;
1130 dpavlin 70 }
1131    
1132     $response->content( $feed->as_xml );
1133     return RC_OK;
1134     }
1135    
1136     if ( $@ ) {
1137     warn "$@";
1138     }
1139    
1140 dpavlin 86 $response->content_type("text/html; charset=UTF-8");
1141 dpavlin 70
1142 dpavlin 35 my $html =
1143 dpavlin 77 qq{<html><head><title>$NICK</title><style type="text/css">$style}
1144     . $cloud->css
1145     . qq{</style></head><body>}
1146     . qq{
1147 dpavlin 32 <form method="post" class="search" action="/">
1148 dpavlin 16 <input type="text" name="search" value="$search" size="10">
1149     <input type="submit" value="search">
1150     </form>
1151 dpavlin 77 }
1152     . $cloud->html(500)
1153     . qq{<p>};
1154 dpavlin 76
1155     if ($request->url =~ m#/tags?#) {
1156     # nop
1157     } elsif ($request->url =~ m#/history#) {
1158 dpavlin 35 my $sth = $dbh->prepare(qq{
1159 dpavlin 65 select date(time) as date,count(*) as nr,sum(length(message)) as len
1160 dpavlin 35 from log
1161     group by date(time)
1162     order by date(time) desc
1163     });
1164     $sth->execute();
1165     my ($l_yyyy,$l_mm) = (0,0);
1166 dpavlin 65 $html .= qq{<table class="calendar"><tr>};
1167 dpavlin 35 my $cal;
1168 dpavlin 65 my $ord = 0;
1169 dpavlin 35 while (my $row = $sth->fetchrow_hashref) {
1170     # this is probably PostgreSQL specific, expects ISO date
1171     my ($yyyy,$mm,$dd) = split(/-/, $row->{date});
1172     if ($yyyy != $l_yyyy || $mm != $l_mm) {
1173 dpavlin 65 if ( $cal ) {
1174     $html .= qq{<td valign="top">} . $cal->as_HTML() . qq{</td>};
1175     $ord++;
1176     $html .= qq{</tr><tr>} if ( $ord % 3 == 0 );
1177     }
1178 dpavlin 35 $cal = new HTML::CalendarMonthSimple('month'=>$mm,'year'=>$yyyy);
1179 dpavlin 65 $cal->border(1);
1180     $cal->width('30%');
1181     $cal->cellheight('5em');
1182     $cal->tableclass('month');
1183     #$cal->cellclass('day');
1184     $cal->sunday('SUN');
1185     $cal->saturday('SAT');
1186     $cal->weekdays('MON','TUE','WED','THU','FRI');
1187 dpavlin 35 ($l_yyyy,$l_mm) = ($yyyy,$mm);
1188     }
1189 dpavlin 79 $cal->setcontent($dd, qq[
1190 dpavlin 73 <a href="$url?date=$row->{date}">$row->{nr}</a><br/>$row->{len}
1191 dpavlin 89 ]) if $cal;
1192 dpavlin 65
1193 dpavlin 35 }
1194 dpavlin 65 $html .= qq{<td valign="top">} . $cal->as_HTML() . qq{</td></tr></table>};
1195 dpavlin 35
1196     } else {
1197     $html .= join("</p><p>",
1198 dpavlin 13 get_from_log(
1199 dpavlin 68 limit => ( $q->param('last') || $q->param('date') ) ? undef : 100,
1200 dpavlin 28 search => $search || undef,
1201 dpavlin 29 tag => $q->param('tag') || undef,
1202 dpavlin 68 date => $q->param('date') || undef,
1203 dpavlin 13 fmt => {
1204 dpavlin 35 date => sub {
1205     my $date = shift || return;
1206 dpavlin 73 qq{<hr/><div class="date"><a href="$url?date=$date">$date</a></div>};
1207 dpavlin 35 },
1208 dpavlin 13 time => '<span class="time">%s</span> ',
1209     time_channel => '<span class="channel">%s %s</span> ',
1210 dpavlin 20 nick => '%s:&nbsp;',
1211     me_nick => '***%s&nbsp;',
1212 dpavlin 13 message => '<span class="message">%s</span>',
1213     },
1214 dpavlin 70 filter => $filter,
1215 dpavlin 13 )
1216 dpavlin 35 );
1217     }
1218    
1219     $html .= qq{</p>
1220     <hr/>
1221     <p>See <a href="/history">history</a> of all messages.</p>
1222     </body></html>};
1223    
1224     $response->content( $html );
1225 dpavlin 74 warn "<< ", $request->method, " ", $request->uri, " created ", length($html), " bytes\n";
1226 dpavlin 13 return RC_OK;
1227     }
1228    
1229 dpavlin 4 POE::Kernel->run;

Properties

Name Value
svn:executable *

  ViewVC Help
Powered by ViewVC 1.1.26