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