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