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