/[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 9 by dpavlin, Wed Mar 1 23:35:56 2006 UTC trunk/bin/irc-logger.pl revision 90 by dpavlin, Fri Mar 7 09:50:53 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 => "try /msg $NICK help",     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    ## END CONFIG
65    
66  use POE qw(Component::IRC Wheel::FollowTail);  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                    # 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  =for SQL schema  my $dbh = DBI->connect($DSN,"","", { RaiseError => 1, AutoCommit => 1 }) || die $DBI::errstr;
147    $dbh->do( qq{ set client_encoding = 'UTF-8' } );
148    
149  $dbh->do(qq{  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            my ( $total, $updates ) = ( 0, 0 );
632            for my $entry ($feed->entries) {
633                    $total++;
634    
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                    $msg .= prefix( 'From: ' , $args->{name} || $feed->title );
646                    $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                            _log('RSS', $msg);
653                            $sth_insert_log->execute( $CHANNEL, 1, $NICK, $msg, undef );
654                            $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            eval { $dbh->do( $sql ) };
663    
664            _log "RSS got $total items of which $updates new";
665    
666            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            my $last_t = $_rss->{last_poll} || time();
693            my $t = time();
694            if ( $t - $last_t > $rss_min_delay ) {
695                    $_rss->{last_poll} = $t;
696                    _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    #
704    # POE handing part
705    #
706    
707    my $ping;                                               # ping stats
708    
709  POE::Component::IRC->new($IRC_ALIAS);  POE::Component::IRC->new($IRC_ALIAS);
710    
711  POE::Session->create  POE::Session->create( inline_states => {
712    (inline_states =>          _start => sub {      
    {_start => sub {        
713                  $_[KERNEL]->post($IRC_ALIAS => register => 'all');                  $_[KERNEL]->post($IRC_ALIAS => register => 'all');
714                  $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);                  $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);
715      },      },
716      irc_255 => sub {    # server is done blabbing      irc_255 => sub {    # server is done blabbing
717                  $_[KERNEL]->post($IRC_ALIAS => join => $CHANNEL);                  $_[KERNEL]->post($IRC_ALIAS => join => $CHANNEL);
718                  $_[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;  
719      },      },
720      irc_public => sub {      irc_public => sub {
721                  my $kernel = $_[KERNEL];                  my $kernel = $_[KERNEL];
# Line 96  POE::Session->create Line 723  POE::Session->create
723                  my $channel = $_[ARG1]->[0];                  my $channel = $_[ARG1]->[0];
724                  my $msg = $_[ARG2];                  my $msg = $_[ARG2];
725    
726                  from_to($msg, 'UTF-8', 'ISO-8859-2');                  save_message( channel => $channel, me => 0, nick => $nick, message => $msg);
727                    meta( $nick, $channel, 'last-msg', $msg );
728        },
729        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                    save_message( channel => $channel, me => 1, nick => $nick, message => $msg);
736    
737                    if ( $use_twitter ) {
738                            if ( my $twitter = meta( $nick, $NICK, 'twitter' ) ) {
739                                    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                    }
745    
                 print "$channel: <$nick> $msg\n";  
                 $sth->execute($channel, $nick, $msg);  
746      },      },
747            irc_ping => sub {
748                    _log( "pong ", $_[ARG0] );
749                    $ping->{ $_[ARG0] }++;
750                    rss_check_updates( $_[KERNEL] );
751            },
752            irc_invite => sub {
753                    my $kernel = $_[KERNEL];
754                    my $nick = (split /!/, $_[ARG0])[0];
755                    my $channel = $_[ARG1];
756    
757                    _log "invited to $channel by $nick";
758    
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          irc_msg => sub {          irc_msg => sub {
764                  my $kernel = $_[KERNEL];                  my $kernel = $_[KERNEL];
765                  my $nick = (split /!/, $_[ARG0])[0];                  my $nick = (split /!/, $_[ARG0])[0];
766                  my $msg = $_[ARG2];                  my $msg = $_[ARG2];
767                  from_to($msg, 'UTF-8', 'ISO-8859-2');                  my $channel = $_[ARG1]->[0];
768    
769                  my $res = "unknown command '$msg', try /msg $NICK help!";                  my $res = "unknown command '$msg', try /msg $NICK help!";
770                    my @out;
771    
772                  print "<< $msg\n";                  _log "<< $msg";
773    
774                  if ($msg =~ m/^help/i) {                  if ($msg =~ m/^help/i) {
775    
776                          $res = "usage: /msg $NICK stat - shows user statistics | /msg $NICK last - show backtrace of conversations";                          $res = "usage: /msg $NICK comand | commands: stat - user/message stat | last - show backtrace | grep foobar - find foobar";
777    
778                    } elsif ($msg =~ m/^msg\s+(\S+)\s+(.*)$/i) {
779    
780                            _log ">> /msg $1 $2";
781                            $_[KERNEL]->post( $IRC_ALIAS => privmsg => $1, $2 );
782                            $res = '';
783    
784                  } elsif ($msg =~ m/^stat.*?\s*(\d*)/i) {                  } elsif ($msg =~ m/^stat.*?\s*(\d*)/i) {
785    
786                          my $nr = $1 || 10;                          my $nr = $1 || 10;
787    
788                          my $sth = $dbh->prepare(qq{                          my $sth = $dbh->prepare(qq{
789                                  select nick,count(*) from log group by nick order by count desc limit $nr                                  select
790                                            trim(both '_' from nick) as nick,
791                                            count(*) as count,
792                                            sum(length(message)) as len
793                                    from log
794                                    group by trim(both '_' from nick)
795                                    order by len desc,count desc
796                                    limit $nr
797                          });                          });
798                          $sth->execute();                          $sth->execute();
799                          $res = "Top $nr users: ";                          $res = "Top $nr users: ";
800                          my @users;                          my @users;
801                          while (my $row = $sth->fetchrow_hashref) {                          while (my $row = $sth->fetchrow_hashref) {
802                                  push @users,$row->{nick} . ': ' . $row->{count};                                  push @users,$row->{nick} . ': ' . $row->{count} . '/' . $row->{len} . '=' . sprintf("%.2f", $row->{len}/$row->{count});
803                          }                          }
804                          $res .= join(" | ", @users);                          $res .= join(" | ", @users);
805                  } elsif ($msg =~ m/^last.*?\s*(\d*)/i) {                  } elsif ($msg =~ m/^last.*?\s*(\d*)/i) {
806    
807                          my $nr = $1 || 10;                          my $limit = $1 || meta( $nick, $channel, 'last-size' ) || 10;
   
                         my $sth = $dbh->prepare(qq{  
                                 select  
                                         time::date as date,  
                                         time::time as time,  
                                         channel,  
                                         nick,  
                                         message  
                                 from log order by log.time desc limit $nr  
                         });  
                         $sth->execute();  
                         $res = "Last $nr messages: ";  
                         my $last_row = {  
                                 date => '',  
                                 time => '',  
                                 channel => '',  
                                 nick => '',  
                         };  
   
                         my @rows;  
808    
809                          while (my $row = $sth->fetchrow_hashref) {                          foreach my $res (get_from_log( limit => $limit )) {
810                                  unshift @rows, $row;                                  _log "last: $res";
811                                    $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );
812                          }                          }
813    
814                          my @msgs;                          $res = '';
815    
816                          foreach my $row (@rows) {                  } elsif ($msg =~ m/^(search|grep)\s+(.*)\s*$/i) {
817    
818                                  $row->{time} =~ s#\.\d+##;                          my $what = $2;
819    
820                                  my $t;                          foreach my $res (get_from_log(
821                                  $t = $row->{date} . ' ' if ($last_row->{date} ne $row->{date});                                          limit => 20,
822                                  $t .= $row->{time};                                          search => $what,
823                                    )) {
824                                    _log "search [$what]: $res";
825                                    $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );
826                            }
827    
828                                  my $msg = '';                          $res = '';
829    
830                                  $msg .= "($t";                  } elsif ($msg =~ m/^(?:count|poll)\s+(.*)(?:\s+(\d+))?\s*$/i) {
                                 $msg .= ' ' . $row->{channel} if ($last_row->{channel} ne $row->{channel});  
                                 $msg .= ") ";  
831    
832                                  $msg .= $row->{nick} . ': '  if ($last_row->{nick} ne $row->{nick});                          my ($what,$limit) = ($1,$2);
833                            $limit ||= 100;
834    
835                                  $msg .= $row->{message};                          my $stat;
836    
837                                  push @msgs, $msg;                          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                                  $last_row = $row;                          my @nicks;
849                            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                          }                          }
854    
855                          foreach my $res (@msgs) {                          $res =
856                                  print "last: $res\n";                                  "$what ++ " . ( $stat->{vote}->{'+'} || 0 ) .
857                                  from_to($res, 'ISO-8859-2', 'UTF-8');                                  " : " . ( $stat->{vote}->{'-'} || 0 ) . " --" .
858                                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );                                  " from " . ( join(", ", @nicks) || 'nobody' );
859    
860                            $_[KERNEL]->post( $IRC_ALIAS => notice => $nick, $res );
861    
862                    } elsif ($msg =~ m/^ping/) {
863                            $res = "ping = " . dump( $ping );
864                    } elsif ($msg =~ m/^conf(?:ig)*\s*(last-size|twitter)*\s*(.*)/) {
865                            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                                    $res = "config for $nick on $channel";
869                                    while ( my ($n,$v) = $sth->fetchrow_array ) {
870                                            $res .= " | $n = $v";
871                                    }
872                            } elsif ( ! $2 ) {
873                                    my $val = meta( $nick, $channel, $1 );
874                                    $res = "current $1 = " . ( $val ? $val : 'undefined' );
875                            } 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                            }
894                    } elsif ($msg =~ m/^rss-update/) {
895                            $res = rss_fetch_all( $_[KERNEL] );
896                    } elsif ($msg =~ m/^rss-clean/) {
897                            $_rss = undef;
898                            $dbh->do( qq{ update feeds set last_update = now() - delay } );
899                            $res = "OK, cleaned RSS cache";
900                    } elsif ($msg =~ m!^rss-(add|remove|stop|start)\s+(http://\S+)\s*(.*)!) {
901                            my $sql = {
902                                    add             => qq{ insert into feeds (url,name) values (?,?) },
903    #                               remove  => qq{ delete from feeds                                where url = ? and name = ? },
904                                    start   => qq{ update feeds set active = true   where url = ? -- ? },
905                                    stop    => qq{ update feeds set active = false  where url = ? -- ? },
906                                    
907                            };
908                            if (my $q = $sql->{$1} ) {
909                                    my $sth = $dbh->prepare( $q );
910                                    warn "## SQL $q ( $2 | $3 )\n";
911                                    eval { $sth->execute( $2, $3 ) };
912                          }                          }
913    
914                          $res = '';                          $res = "OK, RSS $1 : $2 - $3";
915                  }                  }
916    
917                  if ($res) {                  if ($res) {
918                          print ">> [$nick] $res\n";                          _log ">> [$nick] $res";
                         from_to($res, 'ISO-8859-2', 'UTF-8');  
919                          $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );                          $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );
920                  }                  }
921    
922                    rss_check_updates( $_[KERNEL] );
923            },
924            irc_477 => sub {
925                    _log "# irc_477: ",$_[ARG1];
926                    $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "register $NICK" );
927          },          },
928          irc_505 => sub {          irc_505 => sub {
929          print "# irc_505: ",$_[ARG1], "\n";                  _log "# irc_505: ",$_[ARG1];
930                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "register $NICK" );                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "register $NICK" );
931                  warn "## register $NICK\n";  #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "set hide email on" );
932    #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "set email dpavlin\@rot13.org" );
933          },          },
934          irc_registered => sub {          irc_registered => sub {
935                    _log "## registrated $NICK";
936                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );
                 warn "## indetify $NICK\n";  
937          },          },
938      (map          irc_disconnected => sub {
939       {                  _log "## disconnected, reconnecting again";
940         ;"irc_$_" => sub { }}                  $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);
941       qw(join          },
942          ctcp_version          irc_socketerr => sub {
943          connected snotice ctcp_action ping notice mode part quit                  _log "## socket error... sleeping for $sleep_on_error seconds and retry";
944          001 002 003 004 005                  sleep($sleep_on_error);
945          250 251 252 253 254 265 266                  $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);
946          332 333 353 366 372 375 376          },
947                  477  #       irc_433 => sub {
948                  )),  #               print "# irc_433: ",$_[ARG1], "\n";
949    #               warn "## indetify $NICK\n";
950    #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );
951    #       },
952      _child => sub {},      _child => sub {},
953      _default => sub {      _default => sub {
954        printf "%s: session %s caught an unhandled %s event.\n",                  _log sprintf "sID:%s %s %s",
955          scalar localtime(), $_[SESSION]->ID, $_[ARG0];                          $_[SESSION]->ID, $_[ARG0],
956        print "The $_[ARG0] event was given these parameters: ",                          ref($_[ARG1]) eq "ARRAY"        ?       join(",", map { ref($_) eq "ARRAY" ? join(";", @{$_}) : $_ } @{ $_[ARG1] })     :
957          join(" ", map({"ARRAY" eq ref $_ ? "[@$_]" : "$_"} @{$_[ARG1]})), "\n";                          $_[ARG1]                                        ?       $_[ARG1]                                        :
958                            "";
959        0;                        # false for signals        0;                        # false for signals
960      },      },
     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);  
     }  
961     },     },
962    );    );
963    
964    # http server
965    
966    my $httpd = POE::Component::Server::HTTP->new(
967            Port => $http_port,
968            PreHandler => {
969                    '/' => sub {
970                            $_[0]->header(Connection => 'close')
971                    }
972            },
973            ContentHandler => { '/' => \&root_handler },
974            Headers        => { Server => 'irc-logger' },
975    );
976    
977    my $style = <<'_END_OF_STYLE_';
978    p { margin: 0; padding: 0.1em; }
979    .time, .channel { color: #808080; font-size: 60%; }
980    .date { float: right; background: #e0e0e0; color: #404040; font-size: 120%; padding: 0.25em; border: 1px dashed #808080; }
981    .nick { color: #000000; font-size: 80%; padding: 2px; font-family: courier, courier new, monospace ; }
982    .message { color: #000000; font-size: 100%; }
983    .search { float: right; }
984    a:link.tag, a:visited.tag { border: 1px dashed #ccc; backgound: #ccc; text-decoration: none }
985    a:hover.tag { border: 1px solid #eee }
986    hr { border: 1px dashed #ccc; height: 1px; clear: both; }
987    /*
988    .col-0 { background: #ffff66 }
989    .col-1 { background: #a0ffff }
990    .col-2 { background: #99ff99 }
991    .col-3 { background: #ff9999 }
992    .col-4 { background: #ff66ff }
993    */
994    .calendar { border: 1px solid red; width: 100%; }
995    .month { border: 0px; width: 100%; }
996    _END_OF_STYLE_
997    
998    $max_color = 0;
999    
1000    my @cols = qw(
1001            #ffcccc #ccffe6 #ccccff #e6ccff #ffccff #ffcce6 #ff9999 #ffcc99 #ffff99
1002            #ccff99 #99ff99 #99ffcc #99ccff #9999ff #cc99ff #ff6666 #ffb366 #ffff66
1003            #66ff66 #66ffb3 #66b3ff #6666ff #ff3333 #33ff33 #3399ff #3333ff #ff3399
1004            #a0a0a0 #ff0000 #ffff00 #80ff00 #0000ff #8000ff #ff00ff #ff0080 #994d00
1005            #999900 #009900 #cc0066 #c0c0c0 #ccff99 #99ff33 #808080 #660033 #ffffff
1006    );
1007    
1008    foreach my $c (@cols) {
1009            $style .= ".col-${max_color} { background: $c }\n";
1010            $max_color++;
1011    }
1012    warn "defined $max_color colors for users...\n";
1013    
1014    sub root_handler {
1015            my ($request, $response) = @_;
1016            $response->code(RC_OK);
1017    
1018            # this doesn't seem to work, so moved to PreHandler
1019            #$response->header(Connection => 'close');
1020    
1021            return RC_OK if $request->uri =~ m/favicon.ico$/;
1022    
1023            my $q;
1024    
1025            if ( $request->method eq 'POST' ) {
1026                    $q = new CGI::Simple( $request->content );
1027            } elsif ( $request->uri =~ /\?(.+)$/ ) {
1028                    $q = new CGI::Simple( $1 );
1029            } else {
1030                    $q = new CGI::Simple;
1031            }
1032    
1033            my $search = $q->param('search') || $q->param('grep') || '';
1034    
1035            if ($request->url =~ m#/rss(?:/(tags|last-tag|follow.*)\w*(?:=(\d+))?)?#i) {
1036                    my $show = lc($1);
1037                    my $nr = $2;
1038    
1039                    my $type = 'RSS';       # Atom
1040    
1041                    $response->content_type( 'application/' . lc($type) . '+xml' );
1042    
1043                    my $html = '<!-- error -->';
1044                    #warn "create $type feed from ",dump( @last_tags );
1045    
1046                    my $feed = XML::Feed->new( $type );
1047                    $feed->link( $url );
1048    
1049                    if ( $show eq 'tags' ) {
1050                            $nr ||= 50;
1051                            $feed->title( "tags from $CHANNEL" );
1052                            $feed->link( "$url/tags" );
1053                            $feed->description( "tag cloud created from messages on channel $CHANNEL which have tags// in them" );
1054                            my $feed_entry = XML::Feed::Entry->new($type);
1055                            $feed_entry->title( "$nr tags from $CHANNEL" );
1056                            $feed_entry->author( $NICK );
1057                            $feed_entry->link( '/#tags'  );
1058    
1059                            $feed_entry->content(
1060                                    qq{<![CDATA[<style type="text/css">}
1061                                    . $cloud->css
1062                                    . qq{</style>}
1063                                    . $cloud->html( $nr )
1064                                    . qq{]]>}
1065                            );
1066                            $feed->add_entry( $feed_entry );
1067    
1068                    } elsif ( $show eq 'last-tag' ) {
1069    
1070                            $nr ||= $last_x_tags;
1071                            $nr = $last_x_tags if $nr > $last_x_tags;
1072    
1073                            $feed->title( "last $nr tagged messages from $CHANNEL" );
1074                            $feed->description( "collects messages which have tags// in them" );
1075    
1076                            foreach my $m ( @last_tags ) {
1077    #                               warn dump( $m );
1078                                    #my $tags = join(' ', @{$m->{tags}} );
1079                                    my $feed_entry = XML::Feed::Entry->new($type);
1080                                    $feed_entry->title( $m->{nick} . '@' . $m->{time} );
1081                                    $feed_entry->author( $m->{nick} );
1082                                    $feed_entry->link( '/#' . $m->{id}  );
1083                                    $feed_entry->issued( DateTime::Format::Flexible->build( $m->{time} ) );
1084    
1085                                    my $message = $filter->{message}->( $m->{message} );
1086                                    $message .= "<br/>\n" unless $message =~ m!<(/p|br/?)>!;
1087    #                               warn "## message = $message\n";
1088    
1089                                    #$feed_entry->summary(
1090                                    $feed_entry->content(
1091                                            "<![CDATA[$message]]>"
1092                                    );
1093                                    $feed_entry->category( join(', ', @{$m->{tags}}) );
1094                                    $feed->add_entry( $feed_entry );
1095    
1096                                    $nr--;
1097                                    last if $nr <= 0;
1098    
1099                            }
1100    
1101                    } elsif ( $show =~ m/^follow/ ) {
1102    
1103                            $feed->title( "Feeds which this bot follows" );
1104    
1105                            my $sth = $dbh->prepare( qq{ select * from feeds order by last_update desc } );
1106                            $sth->execute;
1107                            while (my $row = $sth->fetchrow_hashref) {
1108                                    my $feed_entry = XML::Feed::Entry->new($type);
1109                                    $feed_entry->title( $row->{name} );
1110                                    $feed_entry->link( $row->{url}  );
1111                                    $feed_entry->issued( DateTime::Format::Flexible->build( $row->{last_update} ) );
1112                                    $feed_entry->content(
1113                                            '<![CDATA[<pre>' . dump( $row ) . '</pre>]]>'
1114                                    );
1115                                    $feed->add_entry( $feed_entry );
1116                            }
1117    
1118                    } else {
1119                            _log "unknown rss request ",$request->url;
1120                            return RC_DENY;
1121                    }
1122    
1123                    $response->content( $feed->as_xml );
1124                    return RC_OK;
1125            }
1126    
1127            if ( $@ ) {
1128                    warn "$@";
1129            }
1130    
1131            $response->content_type("text/html; charset=UTF-8");
1132    
1133            my $html =
1134                    qq{<html><head><title>$NICK</title><style type="text/css">$style}
1135                    . $cloud->css
1136                    . qq{</style></head><body>}
1137                    . qq{
1138                    <form method="post" class="search" action="/">
1139                    <input type="text" name="search" value="$search" size="10">
1140                    <input type="submit" value="search">
1141                    </form>
1142                    }
1143                    . $cloud->html(500)
1144                    . qq{<p>};
1145    
1146            if ($request->url =~ m#/tags?#) {
1147                    # nop
1148            } elsif ($request->url =~ m#/history#) {
1149                    my $sth = $dbh->prepare(qq{
1150                            select date(time) as date,count(*) as nr,sum(length(message)) as len
1151                                    from log
1152                                    group by date(time)
1153                                    order by date(time) desc
1154                    });
1155                    $sth->execute();
1156                    my ($l_yyyy,$l_mm) = (0,0);
1157                    $html .= qq{<table class="calendar"><tr>};
1158                    my $cal;
1159                    my $ord = 0;
1160                    while (my $row = $sth->fetchrow_hashref) {
1161                            # this is probably PostgreSQL specific, expects ISO date
1162                            my ($yyyy,$mm,$dd) = split(/-/, $row->{date});
1163                            if ($yyyy != $l_yyyy || $mm != $l_mm) {
1164                                    if ( $cal ) {
1165                                            $html .= qq{<td valign="top">} . $cal->as_HTML() . qq{</td>};
1166                                            $ord++;
1167                                            $html .= qq{</tr><tr>} if ( $ord % 3 == 0 );
1168                                    }
1169                                    $cal = new HTML::CalendarMonthSimple('month'=>$mm,'year'=>$yyyy);
1170                                    $cal->border(1);
1171                                    $cal->width('30%');
1172                                    $cal->cellheight('5em');
1173                                    $cal->tableclass('month');
1174                                    #$cal->cellclass('day');
1175                                    $cal->sunday('SUN');
1176                                    $cal->saturday('SAT');
1177                                    $cal->weekdays('MON','TUE','WED','THU','FRI');
1178                                    ($l_yyyy,$l_mm) = ($yyyy,$mm);
1179                            }
1180                            $cal->setcontent($dd, qq[
1181                                    <a href="$url?date=$row->{date}">$row->{nr}</a><br/>$row->{len}
1182                            ]) if $cal;
1183                            
1184                    }
1185                    $html .= qq{<td valign="top">} . $cal->as_HTML() . qq{</td></tr></table>};
1186    
1187            } else {
1188                    $html .= join("</p><p>",
1189                            get_from_log(
1190                                    limit => ( $q->param('last') || $q->param('date') ) ? undef : 100,
1191                                    search => $search || undef,
1192                                    tag => $q->param('tag') || undef,
1193                                    date => $q->param('date') || undef,
1194                                    fmt => {
1195                                            date => sub {
1196                                                    my $date = shift || return;
1197                                                    qq{<hr/><div class="date"><a href="$url?date=$date">$date</a></div>};
1198                                            },
1199                                            time => '<span class="time">%s</span> ',
1200                                            time_channel => '<span class="channel">%s %s</span> ',
1201                                            nick => '%s:&nbsp;',
1202                                            me_nick => '***%s&nbsp;',
1203                                            message => '<span class="message">%s</span>',
1204                                    },
1205                                    filter => $filter,
1206                            )
1207                    );
1208            }
1209    
1210            $html .= qq{</p>
1211            <hr/>
1212            <p>See <a href="/history">history</a> of all messages.</p>
1213            </body></html>};
1214    
1215            $response->content( $html );
1216            warn "<< ", $request->method, " ", $request->uri, " created ", length($html), " bytes\n";
1217            return RC_OK;
1218    }
1219    
1220  POE::Kernel->run;  POE::Kernel->run;
Legend:
Removed from v.9  
changed lines
  Added in v.90
  ViewVC Help
Powered by ViewVC 1.1.26