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