/[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

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

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

trunk/irc-logger.pl revision 7 by dpavlin, Wed Mar 1 21:29:14 2006 UTC trunk/bin/irc-logger.pl revision 94 by dpavlin, Fri Mar 7 10:50:16 2008 UTC
# Line 10  irc-logger.pl Line 10  irc-logger.pl
10    
11  ./irc-logger.pl  ./irc-logger.pl
12    
13    =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    =item --log=irc-logger.log
22    
23    =back
24    
25  =head1 DESCRIPTION  =head1 DESCRIPTION
26    
27  log all conversation on irc channel  log all conversation on irc channel
# Line 18  log all conversation on irc channel Line 30  log all conversation on irc channel
30    
31  ## CONFIG  ## CONFIG
32    
33  my $NICK = 'irc-logger-dev';  my $HOSTNAME = `hostname -f`;
34    chomp($HOSTNAME);
35    
36    my $NICK = 'irc-logger';
37    $NICK .= '-dev' if ($HOSTNAME =~ m/llin/);
38  my $CONNECT =  my $CONNECT =
39    {Server => 'irc.freenode.net',    {Server => 'irc.freenode.net',
40     Nick => $NICK,     Nick => $NICK,
41     Ircname => 'logger: ask dpavlin@rot13.org'     Ircname => "try /msg $NICK help",
42    };    };
43  my $CHANNEL = '#razmjenavjestina';  my $CHANNEL = '#razmjenavjestina';
44    $CHANNEL = '#irc-logger' if ($HOSTNAME =~ m/llin/);
45  my $IRC_ALIAS = "log";  my $IRC_ALIAS = "log";
46    
47  my %FOLLOWS =  my $DSN = 'DBI:Pg:dbname=' . $NICK;
   (  
    ACCESS => "/var/log/apache/access.log",  
    ERROR => "/var/log/apache/error.log",  
   );  
48    
49  my $DSN = 'DBI:Pg:dbname=irc-logger';  my $TIMESTAMP = '%Y-%m-%d %H:%M:%S';
50    
51  ## END CONFIG  my $sleep_on_error = 5;
52    
53    # number of last tags to keep in circular buffer
54    my $last_x_tags = 50;
55    
56    # don't pull rss feeds more often than this
57    my $rss_min_delay = 60;
58    $rss_min_delay = 15;
59    
60    my $http_port = $NICK =~ m/-dev/ ? 8001 : 8000;
61    
62    my $url = "http://$HOSTNAME:$http_port";
63    
64  use POE qw(Component::IRC Wheel::FollowTail);  ## END CONFIG
65    
66    use POE qw(Component::IRC Component::Server::HTTP);
67    use HTTP::Status;
68  use DBI;  use DBI;
69  use Encode qw/from_to/;  use Regexp::Common qw /URI/;
70    use CGI::Simple;
71    use HTML::TagCloud;
72    use POSIX qw/strftime/;
73    use HTML::CalendarMonthSimple;
74    use Getopt::Long;
75    use DateTime;
76    use URI::Escape;
77    use Data::Dump qw/dump/;
78    use DateTime::Format::ISO8601;
79    use Carp qw/confess/;
80    use XML::Feed;
81    use DateTime::Format::Flexible;
82    
83    my $use_twitter = 1;
84    eval { require Net::Twitter; };
85    $use_twitter = 0 if ($@);
86    
87    my $import_dircproxy;
88    my $log_path;
89    GetOptions(
90            'import-dircproxy:s' => \$import_dircproxy,
91            'log:s' => \$log_path,
92    );
93    
94    #$SIG{__DIE__} = sub {
95    #       confess "fatal error";
96    #};
97    
98  my $dbh = DBI->connect($DSN,"","", { RaiseError => 1, AutoCommit => 1 }) || die $DBI::errstr;  open(STDOUT, '>', $log_path) || warn "can't redirect log to $log_path: $!";
99    
100    sub _log {
101            print strftime($TIMESTAMP,localtime()) . ' ' . join(" ",@_) . $/;
102    }
103    
104    # 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  =for SQL schema                  # 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                    $m =~ s#$tag_regex#e(qq{<a href="$url?tag=$1" class="tag">$1</a>})#egs;
128                    $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  $dbh->do(qq{  my $dbh = DBI->connect($DSN,"","", { RaiseError => 1, AutoCommit => 1 }) || die $DBI::errstr;
147    $dbh->do( qq{ set client_encoding = 'UTF-8' } );
148    
149    my $sql_schema = {
150            log => qq{
151  create table log (  create table log (
152          id serial,          id serial,
153          time timestamp default now(),          time timestamp default now(),
154          channel text not null,          channel text not null,
155            me boolean default false,
156          nick text not null,          nick text not null,
157          message text not null,          message text not null,
158          primary key(id)          primary key(id)
# Line 61  create table log ( Line 161  create table log (
161  create index log_time on log(time);  create index log_time on log(time);
162  create index log_channel on log(channel);  create index log_channel on log(channel);
163  create index log_nick on log(nick);  create index log_nick on log(nick);
164            },
165            meta => q{
166    create table meta (
167            nick text not null,
168            channel text not null,
169            name text not null,
170            value text,
171            changed timestamp default 'now()',
172            primary key(nick,channel,name)
173    );
174            },
175            feeds => qq{
176    create table feeds (
177            id serial,
178            url text not null,
179            name text,
180            delay interval not null default '5 min',
181            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    };
190    
191  });  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    }
202    
203    
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  =cut
214    
215  my $sth = $dbh->prepare(qq{  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    my $sth_insert_log = $dbh->prepare(qq{
253  insert into log  insert into log
254          (channel, nick, message)          (channel, me, nick, message, time)
255  values (?,?,?)  values (?,?,?,?,?)
256  });  });
257    
258    
259  my $SKIPPING = 0;               # if skipping, how many we've done  my $tags;
260  my $SEND_QUEUE;                 # cache  
261    =head2 get_from_log
262    
263     my @messages = get_from_log(
264            limit => 42,
265            search => '%what to stuff in ilike%',
266            fmt => {
267                    time => '{%s} ',
268                    time_channel => '{%s %s} ',
269                    nick => '%s: ',
270                    me_nick => '***%s ',
271                    message => '%s',
272            },
273            filter => {
274                    message => sub {
275                            # modify message content
276                            return shift;
277                    }
278            },
279            context => 5,
280            full_rows => 1,
281     );
282    
283    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    C<context> defines number of messages around each search hit for display.
287    
288    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    =cut
292    
293    sub get_from_log {
294            my $args = {@_};
295    
296            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    
307            my $sql_message = qq{
308                    select
309                            time::date as date,
310                            time::time as time,
311                            channel,
312                            me,
313                            nick,
314                            message
315                    from log
316            };
317    
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            sub check_date {
329                    my $date = shift || return;
330                    my $new_date = eval { DateTime::Format::ISO8601->parse_datetime( $date )->ymd; };
331                    if ( $@ ) {
332                            warn "invalid date $date\n";
333                            $new_date = DateTime->now->ymd;
334                    }
335                    return $new_date;
336            }
337    
338            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            }
348    
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            $sql .= " order by log.time desc";
364            $sql .= " limit " . $args->{limit} if ($args->{limit});
365    
366            #warn "### sql: $sql ", dump( @args );
367    
368            my $sth = $dbh->prepare( $sql );
369            eval { $sth->execute( @args ) };
370            return if $@;
371    
372            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            # normalize nick names
386            map {
387                    $_->{nick} =~ s/^_*(.*?)_*$/$1/
388            } @rows;
389    
390            return @rows if ($args->{full_rows});
391    
392            my @msgs = (
393                    "Showing " . ($#rows + 1) . " messages..."
394            );
395    
396            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            # 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            foreach my $row (@rows) {
431    
432                    $row->{time} =~ s#\.\d+##;
433    
434                    my $msg = '';
435    
436                    $msg = cr_sprintf($args->{fmt}->{date}, $row->{date}) . ' ' if ($last_row->{date} ne $row->{date});
437                    my $t = $row->{time};
438    
439                    if ($last_row->{channel} ne $row->{channel}) {
440                            $msg .= cr_sprintf($args->{fmt}->{time_channel}, $t, $row->{channel});
441                    } else {
442                            $msg .= cr_sprintf($args->{fmt}->{time}, $t);
443                    }
444    
445                    my $append = 1;
446    
447                    my $nick = $row->{nick};
448    #               if ($nick =~ s/^_*(.*?)_*$/$1/) {
449    #                       $row->{nick} = $nick;
450    #               }
451    
452                    if ($last_row->{nick} ne $nick) {
453                            # 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                            $msg .= cr_sprintf( $fmt, $nick );
460                            $append = 0;
461                    }
462    
463                    $args->{fmt}->{message} ||= '%s';
464                    if (ref($args->{filter}->{message}) eq 'CODE') {
465                            $msg .= cr_sprintf($args->{fmt}->{message},
466                                    $args->{filter}->{message}->(
467                                            $row->{message}
468                                    )
469                            );
470                    } else {
471                            $msg .= cr_sprintf($args->{fmt}->{message}, $row->{message});
472                    }
473    
474                    if ($append && @msgs) {
475                            $msgs[$#msgs] .= " " . $msg;
476                    } else {
477                            push @msgs, $msg;
478                    }
479    
480                    $last_row = $row;
481            }
482    
483            return @msgs;
484    }
485    
486    # tags support
487    
488    my $cloud = HTML::TagCloud->new;
489    
490    =head2 add_tag
491    
492     add_tag( id => 42, message => 'irc message', nick => 'foobar' [, me => 1 ] );
493    
494    =cut
495    
496    my @last_tags;
497    
498    sub add_tag {
499            my $arg = {@_};
500    
501            return unless ($arg->{id} && $arg->{message});
502    
503            my $m = $arg->{message};
504    
505            my @tags;
506    
507            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                    $cloud->add($tag, "$url?tag=$tag", scalar @{$tags->{$tag}} + 1);
513                    push @tags, $tag;
514    
515            }
516    
517            if ( @tags ) {
518                    pop @last_tags if $#last_tags == $last_x_tags;
519                    unshift @last_tags, { tags => [ @tags ], %$arg };
520            }
521    
522    }
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            my $sth = $dbh->prepare(qq{ select id,message,nick,me,time from log where message like '%//%' order by time asc });
532            $sth->execute;
533            while (my $row = $sth->fetchrow_hashref) {
534                    add_tag( %$row );
535            }
536    
537            foreach my $tag (keys %$tags) {
538                    $cloud->add($tag, "$url?tag=$tag", scalar @{$tags->{$tag}} + 1);
539            }
540    }
541    
542    seed_tags;
543    
544    
545    =head2 save_message
546    
547      save_message(
548            channel => '#foobar',
549            me => 0,
550            nick => 'dpavlin',
551            message => 'test message',
552            time => '2006-06-25 18:57:18',
553      );
554    
555    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    =cut
560    
561    sub save_message {
562            my $a = {@_};
563            confess "have msg" if $a->{msg};
564            $a->{me} ||= 0;
565            $a->{time} ||= strftime($TIMESTAMP,localtime());
566    
567            _log
568                    $a->{channel}, " ",
569                    $a->{me} ? "***" . $a->{nick} : "<" . $a->{nick} . ">",
570                    " " . $a->{message};
571    
572            $sth_insert_log->execute($a->{channel}, $a->{me}, $a->{nick}, $a->{message}, $a->{time});
573            add_tag( id => $dbh->last_insert_id(undef,undef,"log",undef), %$a );
574    }
575    
576    
577    if ($import_dircproxy) {
578            open(my $l, $import_dircproxy) || die "can't open $import_dircproxy: $!";
579            warn "importing $import_dircproxy...\n";
580            my $tz_offset = 1 * 60 * 60;    # TZ GMT+2
581            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                                    message => $msg,
599                                    time => $dt->ymd . " " . $dt->hms,
600                            ) if ($nick !~ m/^-/);
601    
602                    } else {
603                            _log "can't parse: $_";
604                    }
605            }
606            close($l);
607            warn "import over\n";
608            exit;
609    }
610    
611    #
612    # RSS follow
613    #
614    
615    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            _log "RSS fetch", $args->{url};
625    
626            my $feed = XML::Feed->parse(URI->new( $args->{url} ));
627            if ( ! $feed ) {
628                    _log("can't fetch RSS ", $args->{url});
629                    return;
630            }
631    
632            my ( $total, $updates ) = ( 0, 0 );
633            for my $entry ($feed->entries) {
634                    $total++;
635    
636                    # seen allready?
637                    next if $_rss->{$feed->link}->{seen}->{$entry->id}++ > 0;
638    
639                    sub prefix {
640                            my ($txt,$var) = @_;
641                            $var =~ s/\s+/ /gs;
642                            $var =~ s/^\s+//g;
643                            $var =~ s/\s+$//g;
644                            return $txt . $var if $var;
645                    }
646    
647                    # fix absolute and relative links to feed entries
648                    my $link = $entry->link;
649                    if ( $link =~ m!^/! ) {
650                            my $host = $args->{url};
651                            $host =~ s!^(http://[^/]+).*$!$1!;      #!vim
652                            $link = "$host/$link";
653                    } elsif ( $link !~ m!^http! ) {
654                            $link = $args->{url} . $link;
655                    }
656                    $link =~ s!//+!/!g;
657    
658                    my $msg;
659                    $msg .= prefix( 'From: ' , $args->{name} || $feed->title );
660                    $msg .= prefix( ' by ' , $entry->author );
661                    $msg .= prefix( ' | ' , $entry->title );
662                    $msg .= prefix( ' | ' , $link );
663    #               $msg .= prefix( ' id ' , $entry->id );
664    
665                    if ( $args->{kernel} && $send_rss_msgs ) {
666                            $send_rss_msgs--;
667                            _log('>>', $msg);
668                            $sth_insert_log->execute( $CHANNEL, 1, $NICK, $msg, 'now()' );
669                            $args->{kernel}->post( $IRC_ALIAS => notice => $CHANNEL, $msg );
670                            $updates++;
671                    }
672            }
673    
674            my $sql = qq{ update feeds set last_update = now(), polls = polls + 1 };
675            $sql .= qq{, updates = updates + $updates } if $updates;
676            $sql .= qq{where id = } . $args->{id};
677            eval { $dbh->do( $sql ) };
678    
679            _log "RSS got $total items of which $updates new";
680    
681            return $updates;
682    }
683    
684    sub rss_fetch_all {
685            my $kernel = shift;
686            my $sql = qq{
687                    select id, url, name
688                    from feeds
689                    where active is true
690            };
691            # limit to newer feeds only if we are not sending messages out
692            $sql .= qq{     and last_update + delay < now() } if $kernel;
693            my $sth = $dbh->prepare( $sql );
694            $sth->execute();
695            warn "# ",$sth->rows," active RSS feeds\n";
696            my $count = 0;
697            while (my $row = $sth->fetchrow_hashref) {
698                    $row->{kernel} = $kernel if $kernel;
699                    $count += rss_fetch( $row );
700            }
701            return "OK, fetched $count posts from " . $sth->rows . " feeds";
702    }
703    
704    
705    sub rss_check_updates {
706            my $kernel = shift;
707            my $last_t = $_rss->{last_poll} || time();
708            my $t = time();
709            if ( $t - $last_t > $rss_min_delay ) {
710                    $_rss->{last_poll} = $t;
711                    _log rss_fetch_all( $kernel );
712            }
713    }
714    
715    # seed rss seen cache so we won't send out all items on startup
716    _log rss_fetch_all;
717    
718    #
719    # POE handing part
720    #
721    
722    my $ping;                                               # ping stats
723    
724  POE::Component::IRC->new($IRC_ALIAS);  POE::Component::IRC->new($IRC_ALIAS);
725    
726  POE::Session->create  POE::Session->create( inline_states => {
727    (inline_states =>          _start => sub {      
    {_start => sub {        
728                  $_[KERNEL]->post($IRC_ALIAS => register => 'all');                  $_[KERNEL]->post($IRC_ALIAS => register => 'all');
729                  $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);                  $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);
730      },      },
731      irc_255 => sub {            # server is done blabbing      irc_255 => sub {    # server is done blabbing
732                  $_[KERNEL]->post($IRC_ALIAS => join => $CHANNEL);                  $_[KERNEL]->post($IRC_ALIAS => join => $CHANNEL);
733                  $_[KERNEL]->post($IRC_ALIAS => join => '#logger');                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );
                 $_[KERNEL]->yield("heartbeat"); # start heartbeat  
 #               $_[KERNEL]->yield("my_add", $_) for keys %FOLLOWS;  
734      },      },
735      irc_public => sub {      irc_public => sub {
736                  my $kernel = $_[KERNEL];                  my $kernel = $_[KERNEL];
# Line 96  POE::Session->create Line 738  POE::Session->create
738                  my $channel = $_[ARG1]->[0];                  my $channel = $_[ARG1]->[0];
739                  my $msg = $_[ARG2];                  my $msg = $_[ARG2];
740    
741                  from_to($msg, 'UTF-8', 'ISO-8859-2');                  save_message( channel => $channel, me => 0, nick => $nick, message => $msg);
742                    meta( $nick, $channel, 'last-msg', $msg );
743        },
744        irc_ctcp_action => sub {
745                    my $kernel = $_[KERNEL];
746                    my $nick = (split /!/, $_[ARG0])[0];
747                    my $channel = $_[ARG1]->[0];
748                    my $msg = $_[ARG2];
749    
750                    save_message( channel => $channel, me => 1, nick => $nick, message => $msg);
751    
752                    if ( $use_twitter ) {
753                            if ( my $twitter = meta( $nick, $NICK, 'twitter' ) ) {
754                                    my ($login,$passwd) = split(/\s+/,$twitter,2);
755                                    _log("sending twitter for $nick/$login on $channel ");
756                                    my $bot = Net::Twitter->new( username=>$login, password=>$passwd );
757                                    $bot->update("<${channel}> $msg");
758                            }
759                    }
760    
                 print "$channel: <$nick> $msg\n";  
                 $sth->execute($channel, $nick, $msg);  
761      },      },
762            irc_ping => sub {
763                    _log( "pong ", $_[ARG0] );
764                    $ping->{ $_[ARG0] }++;
765                    rss_check_updates( $_[KERNEL] );
766            },
767            irc_invite => sub {
768                    my $kernel = $_[KERNEL];
769                    my $nick = (split /!/, $_[ARG0])[0];
770                    my $channel = $_[ARG1];
771    
772                    _log "invited to $channel by $nick";
773    
774                    $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, "how nice of you to invite me to $channel, I'll be right there..." );
775                    $_[KERNEL]->post($IRC_ALIAS => join => $channel);
776    
777            },
778          irc_msg => sub {          irc_msg => sub {
779                  my $kernel = $_[KERNEL];                  my $kernel = $_[KERNEL];
780                  my $nick = (split /!/, $_[ARG0])[0];                  my $nick = (split /!/, $_[ARG0])[0];
781                  my $msg = $_[ARG2];                  my $msg = $_[ARG2];
782                  from_to($msg, 'UTF-8', 'ISO-8859-2');                  my $channel = $_[ARG1]->[0];
783    
784                    my $res = "unknown command '$msg', try /msg $NICK help!";
785                    my @out;
786    
787                    _log "<< $msg";
788    
789                  my $res = 'unknown command ' . $msg;                  if ($msg =~ m/^help/i) {
790    
791                  print "<< $msg\n";                          $res = "usage: /msg $NICK comand | commands: stat - user/message stat | last - show backtrace | grep foobar - find foobar";
792    
793                  if ($msg =~ m/^stat.*\s*(\d*)/) {                  } elsif ($msg =~ m/^msg\s+(\S+)\s+(.*)$/i) {
794    
795                            _log ">> /msg $1 $2";
796                            $_[KERNEL]->post( $IRC_ALIAS => privmsg => $1, $2 );
797                            $res = '';
798    
799                    } elsif ($msg =~ m/^stat.*?\s*(\d*)/i) {
800    
801                          my $nr = $1 || 10;                          my $nr = $1 || 10;
802    
803                          my $sth = $dbh->prepare(qq{                          my $sth = $dbh->prepare(qq{
804                                  select nick,count(*) from log group by nick order by count desc limit $nr                                  select
805                                            trim(both '_' from nick) as nick,
806                                            count(*) as count,
807                                            sum(length(message)) as len
808                                    from log
809                                    group by trim(both '_' from nick)
810                                    order by len desc,count desc
811                                    limit $nr
812                          });                          });
813                          $sth->execute();                          $sth->execute();
814                          $res = "Top $nr users: ";                          $res = "Top $nr users: ";
815                            my @users;
816                          while (my $row = $sth->fetchrow_hashref) {                          while (my $row = $sth->fetchrow_hashref) {
817                                  $res .= $row->{nick} . ': ' . $row->{count} . ", ";                                  push @users,$row->{nick} . ': ' . $row->{count} . '/' . $row->{len} . '=' . sprintf("%.2f", $row->{len}/$row->{count});
818                            }
819                            $res .= join(" | ", @users);
820                    } elsif ($msg =~ m/^last.*?\s*(\d*)/i) {
821    
822                            my $limit = $1 || meta( $nick, $channel, 'last-size' ) || 10;
823    
824                            foreach my $res (get_from_log( limit => $limit )) {
825                                    _log "last: $res";
826                                    $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );
827                          }                          }
                 }  
828    
829                  $res =~ s/,\s*$//;                          $res = '';
                 print ">> [$nick] $res\n";  
830    
831                  from_to($res, 'ISO-8859-2', 'UTF-8');                  } elsif ($msg =~ m/^(search|grep)\s+(.*)\s*$/i) {
                 $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );  
832    
833                            my $what = $2;
834    
835                            foreach my $res (get_from_log(
836                                            limit => 20,
837                                            search => $what,
838                                    )) {
839                                    _log "search [$what]: $res";
840                                    $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );
841                            }
842    
843                            $res = '';
844    
845                    } elsif ($msg =~ m/^(?:count|poll)\s+(.*)(?:\s+(\d+))?\s*$/i) {
846    
847                            my ($what,$limit) = ($1,$2);
848                            $limit ||= 100;
849    
850                            my $stat;
851    
852                            foreach my $res (get_from_log(
853                                            limit => $limit,
854                                            search => $what,
855                                            full_rows => 1,
856                                    )) {
857                                    while ($res->{message} =~ s/\Q$what\E(\+|\-)//) {
858                                            $stat->{vote}->{$1}++;
859                                            $stat->{from}->{ $res->{nick} }++;
860                                    }
861                            }
862    
863                            my @nicks;
864                            foreach my $nick (sort { $stat->{from}->{$a} <=> $stat->{from}->{$b} } keys %{ $stat->{from} }) {
865                                    push @nicks, $nick . ( $stat->{from}->{$nick} == 1 ? '' :
866                                            "(" . $stat->{from}->{$nick} . ")"
867                                    );
868                            }
869    
870                            $res =
871                                    "$what ++ " . ( $stat->{vote}->{'+'} || 0 ) .
872                                    " : " . ( $stat->{vote}->{'-'} || 0 ) . " --" .
873                                    " from " . ( join(", ", @nicks) || 'nobody' );
874    
875                            $_[KERNEL]->post( $IRC_ALIAS => notice => $nick, $res );
876    
877                    } elsif ($msg =~ m/^ping/) {
878                            $res = "ping = " . dump( $ping );
879                    } elsif ($msg =~ m/^conf(?:ig)*\s*(last-size|twitter)*\s*(.*)/) {
880                            if ( ! defined( $1 ) ) {
881                                    my $sth = $dbh->prepare(qq{ select name,value,changed from meta where nick = ? and channel = ? });
882                                    $sth->execute( $nick, $channel );
883                                    $res = "config for $nick on $channel";
884                                    while ( my ($n,$v) = $sth->fetchrow_array ) {
885                                            $res .= " | $n = $v";
886                                    }
887                            } elsif ( ! $2 ) {
888                                    my $val = meta( $nick, $channel, $1 );
889                                    $res = "current $1 = " . ( $val ? $val : 'undefined' );
890                            } else {
891                                    my $validate = {
892                                            'last-size' => qr/^\d+/,
893                                            'twitter' => qr/^\w+\s+\w+/,
894                                    };
895    
896                                    my ( $op, $val ) = ( $1, $2 );
897    
898                                    if ( my $regex = $validate->{$op} ) {
899                                            if ( $val =~ $regex ) {
900                                                    meta( $nick, $channel, $op, $val );
901                                                    $res = "saved $op = $val";
902                                            } else {
903                                                    $res = "config option $op = $val doesn't validate against $regex";
904                                            }
905                                    } else {
906                                            $res = "config option $op doesn't exist";
907                                    }
908                            }
909                    } elsif ($msg =~ m/^rss-update/) {
910                            $res = rss_fetch_all( $_[KERNEL] );
911                    } elsif ($msg =~ m/^rss-clean/) {
912                            $_rss = undef;
913                            $dbh->do( qq{ update feeds set last_update = now() - delay } );
914                            $res = "OK, cleaned RSS cache";
915                    } elsif ($msg =~ m/^rss-list/) {
916                            my $sth = $dbh->prepare(qq{ select url,name,last_update,active from feeds });
917                            $sth->execute;
918                            while (my @row = $sth->fetchrow_array) {
919                                    $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, join(' | ',@row) );
920                            }
921                            $res = '';
922                    } elsif ($msg =~ m!^rss-(add|remove|stop|start)\s+(http://\S+)\s*(.*)!) {
923                            my $sql = {
924                                    add             => qq{ insert into feeds (url,name) values (?,?) },
925    #                               remove  => qq{ delete from feeds                                where url = ? and name = ? },
926                                    start   => qq{ update feeds set active = true   where url = ? },
927                                    stop    => qq{ update feeds set active = false  where url = ? },
928                            };
929                            if (my $q = $sql->{$1} ) {
930                                    my $sth = $dbh->prepare( $q );
931                                    my @data = ( $2 );
932                                    push @data, $3 if ( $q =~ s/\?//g == 2 );
933                                    warn "## $1 SQL $q with ",dump( @data ),"\n";
934                                    eval { $sth->execute( @data ) };
935                            }
936    
937                            $res = "OK, RSS $1 : $2 - $3";
938                    }
939    
940                    if ($res) {
941                            _log ">> [$nick] $res";
942                            $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );
943                    }
944    
945                    rss_check_updates( $_[KERNEL] );
946            },
947            irc_477 => sub {
948                    _log "# irc_477: ",$_[ARG1];
949                    $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "register $NICK" );
950          },          },
951          irc_505 => sub {          irc_505 => sub {
952          print "# irc_505: ",$_[ARG1], "\n";                  _log "# irc_505: ",$_[ARG1];
953                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "register $NICK" );                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "register $NICK" );
954                  warn "## register $NICK\n";  #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "set hide email on" );
955    #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "set email dpavlin\@rot13.org" );
956            },
957            irc_registered => sub {
958                    _log "## registrated $NICK";
959                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );
                 warn "## indetify $NICK\n";  
960          },          },
961      (map          irc_disconnected => sub {
962       {                  _log "## disconnected, reconnecting again";
963         ;"irc_$_" => sub { }}                  $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);
964       qw(join          },
965          ctcp_version          irc_socketerr => sub {
966          connected snotice ctcp_action ping notice mode part quit                  _log "## socket error... sleeping for $sleep_on_error seconds and retry";
967          001 002 003 004 005                  sleep($sleep_on_error);
968          250 251 252 253 254 265 266                  $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);
969          332 333 353 366 372 375 376          },
970                  477  #       irc_433 => sub {
971                  )),  #               print "# irc_433: ",$_[ARG1], "\n";
972    #               warn "## indetify $NICK\n";
973    #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );
974    #       },
975      _child => sub {},      _child => sub {},
976      _default => sub {      _default => sub {
977        printf "%s: session %s caught an unhandled %s event.\n",                  _log sprintf "sID:%s %s %s",
978          scalar localtime(), $_[SESSION]->ID, $_[ARG0];                          $_[SESSION]->ID, $_[ARG0],
979        print "The $_[ARG0] event was given these parameters: ",                          ref($_[ARG1]) eq "ARRAY"        ?       join(",", map { ref($_) eq "ARRAY" ? join(";", @{$_}) : $_ } @{ $_[ARG1] })     :
980          join(" ", map({"ARRAY" eq ref $_ ? "[@$_]" : "$_"} @{$_[ARG1]})), "\n";                          $_[ARG1]                                        ?       $_[ARG1]                                        :
981                            "";
982        0;                        # false for signals        0;                        # false for signals
983      },      },
     my_add => sub {  
       my $trailing = $_[ARG0];  
       my $session = $_[SESSION];  
       POE::Session->create  
           (inline_states =>  
            {_start => sub {  
               $_[HEAP]->{wheel} =  
                 POE::Wheel::FollowTail->new  
                     (  
                      Filename => $FOLLOWS{$trailing},  
                      InputEvent => 'got_line',  
                     );  
             },  
             got_line => sub {  
               $_[KERNEL]->post($session => my_tailed =>  
                                time, $trailing, $_[ARG0]);  
             },  
            },  
           );  
       
     },  
     my_tailed => sub {  
       my ($time, $file, $line) = @_[ARG0..ARG2];  
       ## $time will be undef on a probe, or a time value if a real line  
   
       ## PoCo::IRC has throttling built in, but no external visibility  
       ## so this is reaching "under the hood"  
       $SEND_QUEUE ||=  
         $_[KERNEL]->alias_resolve($IRC_ALIAS)->get_heap->{send_queue};  
   
       ## handle "no need to keep skipping" transition  
       if ($SKIPPING and @$SEND_QUEUE < 1) {  
         $_[KERNEL]->post($IRC_ALIAS => privmsg => $CHANNEL =>  
                          "[discarded $SKIPPING messages]");  
         $SKIPPING = 0;  
       }  
   
       ## handle potential message display  
       if ($time) {  
         if ($SKIPPING or @$SEND_QUEUE > 3) { # 3 msgs per 10 seconds  
           $SKIPPING++;  
         } else {  
           my @time = localtime $time;  
           $_[KERNEL]->post($IRC_ALIAS => privmsg => $CHANNEL =>  
                            sprintf "%02d:%02d:%02d: %s: %s",  
                            ($time[2] + 11) % 12 + 1, $time[1], $time[0],  
                            $file, $line);  
         }  
       }  
   
       ## handle re-probe/flush if skipping  
       if ($SKIPPING) {  
         $_[KERNEL]->delay($_[STATE] => 0.5); # $time will be undef  
       }  
   
     },  
     my_heartbeat => sub {  
       $_[KERNEL]->yield(my_tailed => time, "heartbeat", "beep");  
       $_[KERNEL]->delay($_[STATE] => 10);  
     }  
984     },     },
985    );    );
986    
987    # http server
988    
989    my $httpd = POE::Component::Server::HTTP->new(
990            Port => $http_port,
991            PreHandler => {
992                    '/' => sub {
993                            $_[0]->header(Connection => 'close')
994                    }
995            },
996            ContentHandler => { '/' => \&root_handler },
997            Headers        => { Server => 'irc-logger' },
998    );
999    
1000    my $style = <<'_END_OF_STYLE_';
1001    p { margin: 0; padding: 0.1em; }
1002    .time, .channel { color: #808080; font-size: 60%; }
1003    .date { float: right; background: #e0e0e0; color: #404040; font-size: 120%; padding: 0.25em; border: 1px dashed #808080; }
1004    .nick { color: #000000; font-size: 80%; padding: 2px; font-family: courier, courier new, monospace ; }
1005    .message { color: #000000; font-size: 100%; }
1006    .search { float: right; }
1007    a:link.tag, a:visited.tag { border: 1px dashed #ccc; backgound: #ccc; text-decoration: none }
1008    a:hover.tag { border: 1px solid #eee }
1009    hr { border: 1px dashed #ccc; height: 1px; clear: both; }
1010    /*
1011    .col-0 { background: #ffff66 }
1012    .col-1 { background: #a0ffff }
1013    .col-2 { background: #99ff99 }
1014    .col-3 { background: #ff9999 }
1015    .col-4 { background: #ff66ff }
1016    */
1017    .calendar { border: 1px solid red; width: 100%; }
1018    .month { border: 0px; width: 100%; }
1019    _END_OF_STYLE_
1020    
1021    $max_color = 0;
1022    
1023    my @cols = qw(
1024            #ffcccc #ccffe6 #ccccff #e6ccff #ffccff #ffcce6 #ff9999 #ffcc99 #ffff99
1025            #ccff99 #99ff99 #99ffcc #99ccff #9999ff #cc99ff #ff6666 #ffb366 #ffff66
1026            #66ff66 #66ffb3 #66b3ff #6666ff #ff3333 #33ff33 #3399ff #3333ff #ff3399
1027            #a0a0a0 #ff0000 #ffff00 #80ff00 #0000ff #8000ff #ff00ff #ff0080 #994d00
1028            #999900 #009900 #cc0066 #c0c0c0 #ccff99 #99ff33 #808080 #660033 #ffffff
1029    );
1030    
1031    foreach my $c (@cols) {
1032            $style .= ".col-${max_color} { background: $c }\n";
1033            $max_color++;
1034    }
1035    warn "defined $max_color colors for users...\n";
1036    
1037    sub root_handler {
1038            my ($request, $response) = @_;
1039            $response->code(RC_OK);
1040    
1041            # this doesn't seem to work, so moved to PreHandler
1042            #$response->header(Connection => 'close');
1043    
1044            return RC_OK if $request->uri =~ m/favicon.ico$/;
1045    
1046            my $q;
1047    
1048            if ( $request->method eq 'POST' ) {
1049                    $q = new CGI::Simple( $request->content );
1050            } elsif ( $request->uri =~ /\?(.+)$/ ) {
1051                    $q = new CGI::Simple( $1 );
1052            } else {
1053                    $q = new CGI::Simple;
1054            }
1055    
1056            my $search = $q->param('search') || $q->param('grep') || '';
1057    
1058            if ($request->url =~ m#/rss(?:/(tags|last-tag|follow.*)\w*(?:=(\d+))?)?#i) {
1059                    my $show = lc($1);
1060                    my $nr = $2;
1061    
1062                    my $type = 'RSS';       # Atom
1063    
1064                    $response->content_type( 'application/' . lc($type) . '+xml' );
1065    
1066                    my $html = '<!-- error -->';
1067                    #warn "create $type feed from ",dump( @last_tags );
1068    
1069                    my $feed = XML::Feed->new( $type );
1070                    $feed->link( $url );
1071    
1072                    if ( $show eq 'tags' ) {
1073                            $nr ||= 50;
1074                            $feed->title( "tags from $CHANNEL" );
1075                            $feed->link( "$url/tags" );
1076                            $feed->description( "tag cloud created from messages on channel $CHANNEL which have tags// in them" );
1077                            my $feed_entry = XML::Feed::Entry->new($type);
1078                            $feed_entry->title( "$nr tags from $CHANNEL" );
1079                            $feed_entry->author( $NICK );
1080                            $feed_entry->link( '/#tags'  );
1081    
1082                            $feed_entry->content(
1083                                    qq{<![CDATA[<style type="text/css">}
1084                                    . $cloud->css
1085                                    . qq{</style>}
1086                                    . $cloud->html( $nr )
1087                                    . qq{]]>}
1088                            );
1089                            $feed->add_entry( $feed_entry );
1090    
1091                    } elsif ( $show eq 'last-tag' ) {
1092    
1093                            $nr ||= $last_x_tags;
1094                            $nr = $last_x_tags if $nr > $last_x_tags;
1095    
1096                            $feed->title( "last $nr tagged messages from $CHANNEL" );
1097                            $feed->description( "collects messages which have tags// in them" );
1098    
1099                            foreach my $m ( @last_tags ) {
1100    #                               warn dump( $m );
1101                                    #my $tags = join(' ', @{$m->{tags}} );
1102                                    my $feed_entry = XML::Feed::Entry->new($type);
1103                                    $feed_entry->title( $m->{nick} . '@' . $m->{time} );
1104                                    $feed_entry->author( $m->{nick} );
1105                                    $feed_entry->link( '/#' . $m->{id}  );
1106                                    $feed_entry->issued( DateTime::Format::Flexible->build( $m->{time} ) );
1107    
1108                                    my $message = $filter->{message}->( $m->{message} );
1109                                    $message .= "<br/>\n" unless $message =~ m!<(/p|br/?)>!;
1110    #                               warn "## message = $message\n";
1111    
1112                                    #$feed_entry->summary(
1113                                    $feed_entry->content(
1114                                            "<![CDATA[$message]]>"
1115                                    );
1116                                    $feed_entry->category( join(', ', @{$m->{tags}}) );
1117                                    $feed->add_entry( $feed_entry );
1118    
1119                                    $nr--;
1120                                    last if $nr <= 0;
1121    
1122                            }
1123    
1124                    } elsif ( $show =~ m/^follow/ ) {
1125    
1126                            $feed->title( "Feeds which this bot follows" );
1127    
1128                            my $sth = $dbh->prepare( qq{ select * from feeds order by last_update desc } );
1129                            $sth->execute;
1130                            while (my $row = $sth->fetchrow_hashref) {
1131                                    my $feed_entry = XML::Feed::Entry->new($type);
1132                                    $feed_entry->title( $row->{name} );
1133                                    $feed_entry->link( $row->{url}  );
1134                                    $feed_entry->issued( DateTime::Format::Flexible->build( $row->{last_update} ) );
1135                                    $feed_entry->content(
1136                                            '<![CDATA[<pre>' . dump( $row ) . '</pre>]]>'
1137                                    );
1138                                    $feed->add_entry( $feed_entry );
1139                            }
1140    
1141                    } else {
1142                            _log "unknown rss request ",$request->url;
1143                            return RC_DENY;
1144                    }
1145    
1146                    $response->content( $feed->as_xml );
1147                    return RC_OK;
1148            }
1149    
1150            if ( $@ ) {
1151                    warn "$@";
1152            }
1153    
1154            $response->content_type("text/html; charset=UTF-8");
1155    
1156            my $html =
1157                    qq{<html><head><title>$NICK</title><style type="text/css">$style}
1158                    . $cloud->css
1159                    . qq{</style></head><body>}
1160                    . qq{
1161                    <form method="post" class="search" action="/">
1162                    <input type="text" name="search" value="$search" size="10">
1163                    <input type="submit" value="search">
1164                    </form>
1165                    }
1166                    . $cloud->html(500)
1167                    . qq{<p>};
1168    
1169            if ($request->url =~ m#/tags?#) {
1170                    # nop
1171            } elsif ($request->url =~ m#/history#) {
1172                    my $sth = $dbh->prepare(qq{
1173                            select date(time) as date,count(*) as nr,sum(length(message)) as len
1174                                    from log
1175                                    group by date(time)
1176                                    order by date(time) desc
1177                    });
1178                    $sth->execute();
1179                    my ($l_yyyy,$l_mm) = (0,0);
1180                    $html .= qq{<table class="calendar"><tr>};
1181                    my $cal;
1182                    my $ord = 0;
1183                    while (my $row = $sth->fetchrow_hashref) {
1184                            # this is probably PostgreSQL specific, expects ISO date
1185                            my ($yyyy,$mm,$dd) = split(/-/, $row->{date});
1186                            if ($yyyy != $l_yyyy || $mm != $l_mm) {
1187                                    if ( $cal ) {
1188                                            $html .= qq{<td valign="top">} . $cal->as_HTML() . qq{</td>};
1189                                            $ord++;
1190                                            $html .= qq{</tr><tr>} if ( $ord % 3 == 0 );
1191                                    }
1192                                    $cal = new HTML::CalendarMonthSimple('month'=>$mm,'year'=>$yyyy);
1193                                    $cal->border(1);
1194                                    $cal->width('30%');
1195                                    $cal->cellheight('5em');
1196                                    $cal->tableclass('month');
1197                                    #$cal->cellclass('day');
1198                                    $cal->sunday('SUN');
1199                                    $cal->saturday('SAT');
1200                                    $cal->weekdays('MON','TUE','WED','THU','FRI');
1201                                    ($l_yyyy,$l_mm) = ($yyyy,$mm);
1202                            }
1203                            $cal->setcontent($dd, qq[
1204                                    <a href="$url?date=$row->{date}">$row->{nr}</a><br/>$row->{len}
1205                            ]) if $cal;
1206                            
1207                    }
1208                    $html .= qq{<td valign="top">} . $cal->as_HTML() . qq{</td></tr></table>};
1209    
1210            } else {
1211                    $html .= join("</p><p>",
1212                            get_from_log(
1213                                    limit => ( $q->param('last') || $q->param('date') ) ? undef : 100,
1214                                    search => $search || undef,
1215                                    tag => $q->param('tag') || undef,
1216                                    date => $q->param('date') || undef,
1217                                    fmt => {
1218                                            date => sub {
1219                                                    my $date = shift || return;
1220                                                    qq{<hr/><div class="date"><a href="$url?date=$date">$date</a></div>};
1221                                            },
1222                                            time => '<span class="time">%s</span> ',
1223                                            time_channel => '<span class="channel">%s %s</span> ',
1224                                            nick => '%s:&nbsp;',
1225                                            me_nick => '***%s&nbsp;',
1226                                            message => '<span class="message">%s</span>',
1227                                    },
1228                                    filter => $filter,
1229                            )
1230                    );
1231            }
1232    
1233            $html .= qq{</p>
1234            <hr/>
1235            <p>See <a href="/history">history</a> of all messages.</p>
1236            </body></html>};
1237    
1238            $response->content( $html );
1239            warn "<< ", $request->method, " ", $request->uri, " created ", length($html), " bytes\n";
1240            return RC_OK;
1241    }
1242    
1243  POE::Kernel->run;  POE::Kernel->run;
Legend:
Removed from v.7  
changed lines
  Added in v.94
  ViewVC Help
Powered by ViewVC 1.1.26