/[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 38 by dpavlin, Sun Jun 25 17:48:33 2006 UTC trunk/bin/irc-logger.pl revision 120 by dpavlin, Fri Mar 14 13:37:45 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 18  irc-logger.pl Line 37  irc-logger.pl
37    
38  Import log from C<dircproxy> to C<irc-logger> database  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 26  log all conversation on irc channel Line 49  log all conversation on irc channel
49    
50  ## CONFIG  ## CONFIG
51    
52  my $HOSTNAME = `hostname`;  my $debug = 0;
53    
54    my $irc_config = {
55            nick => 'irc-logger',
56            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    
 my $NICK = 'irc-logger';  
 $NICK .= '-dev' if ($HOSTNAME =~ m/llin/);  
 my $CONNECT =  
   {Server => 'irc.freenode.net',  
    Nick => $NICK,  
    Ircname => "try /msg $NICK help",  
   };  
67  my $CHANNEL = '#razmjenavjestina';  my $CHANNEL = '#razmjenavjestina';
 $CHANNEL = '#irc-logger' if ($HOSTNAME =~ m/llin/);  
 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;  my $DSN = 'DBI:Pg:dbname=' . $NICK;
89    
 my $ENCODING = 'ISO-8859-2';  
90  my $TIMESTAMP = '%Y-%m-%d %H:%M:%S';  my $TIMESTAMP = '%Y-%m-%d %H:%M:%S';
91    
92  ## END CONFIG  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  use POE qw(Component::IRC Wheel::FollowTail Component::Server::HTTP);  my $http_port = $NICK =~ m/-dev/ ? 8001 : 8000;
101  use HTTP::Status;  
102  use DBI;  my $url = "http://$HOSTNAME:$http_port";
103  use Encode qw/from_to is_utf8/;  
104  use Regexp::Common qw /URI/;  ## END CONFIG
105  use CGI::Simple;  
106  use HTML::TagCloud;  my $use_twitter = 1;
107  use POSIX qw/strftime/;  eval { require Net::Twitter; };
108  use HTML::CalendarMonthSimple;  $use_twitter = 0 if ($@);
 use Getopt::Long;  
 use DateTime;  
109    
110  my $import_dircproxy;  my $import_dircproxy;
111    my $log_path;
112  GetOptions(  GetOptions(
113          'import-dircproxy:s' => \$import_dircproxy,          'import-dircproxy:s' => \$import_dircproxy,
114            'log:s' => \$log_path,
115            'queue:s' => \$queue_dir,
116  );  );
117    
118  my $dbh = DBI->connect($DSN,"","", { RaiseError => 1, AutoCommit => 1 }) || die $DBI::errstr;  #$SIG{__DIE__} = sub {
119    #       confess "fatal error";
120    #};
121    
122    sub _log {
123            print strftime($TIMESTAMP,localtime()) . ' ' . join(" ",map { ref($_) ? dump( $_ ) : $_ } @_) . $/;
124    }
125    
126    open(STDOUT, '>', $log_path) && warn "log to $log_path: $!\n";
127    
128    # queue
129    
130    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  eval {                  $m =~ s/($escape_re)/$escape{$1}/gs;
158          $dbh->do(qq{ select count(*) from log });                  $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  if ($@) {  # POE IRC
180          warn "creating database table in $DSN\n";  my $poe_irc = POE::Component::IRC->spawn( %$irc_config ) or
181          $dbh->do(<<'_SQL_SCHEMA_');          die "can't start ", dump( $irc_config ), ": $!";
182    
183    my $irc = $poe_irc->session_id();
184    _log "IRC session_id $irc";
185    
186    my $dbh = DBI->connect($DSN,"","", { RaiseError => 1, AutoCommit => 1 }) || die $DBI::errstr;
187    $dbh->do( qq{ set client_encoding = 'UTF-8' } );
188    
189    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(),
# Line 94  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  _SQL_SCHEMA_          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  my $sth = $dbh->prepare(qq{  
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
257    
258    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, me, nick, message, time)          (channel, me, nick, message, time)
298  values (?,?,?,?,?)  values (?,?,?,?,?)
299  });  });
300    
301    
302  my $tags;  my $tags;
 my $tag_regex = '\b([\w-_]+)//';  
303    
304  =head2 get_from_log  =head2 get_from_log
305    
# Line 126  my $tag_regex = '\b([\w-_]+)//'; Line 320  my $tag_regex = '\b([\w-_]+)//';
320                  }                  }
321          },          },
322          context => 5,          context => 5,
323            full_rows => 1,
324   );   );
325    
326  Order is important. Fields are first passed through C<filter> (if available) and  Order is important. Fields are first passed through C<filter> (if available) and
# Line 133  then throgh C<< sprintf($fmt->{message}, Line 328  then throgh C<< sprintf($fmt->{message},
328    
329  C<context> defines number of messages around each search hit for display.  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->{fmt} ||= {          if ( ! $args->{fmt} ) {
340                  date => '[%s] ',                  $args->{fmt} = {
341                  time => '{%s} ',                          date => '[%s] ',
342                  time_channel => '{%s %s} ',                          time => '{%s} ',
343                  nick => '%s: ',                          time_channel => '{%s %s} ',
344                  me_nick => '***%s ',                          nick => '%s: ',
345                  message => '%s',                          me_nick => '***%s ',
346          };                          message => '%s',
347                    };
348            }
349    
350          my $sql_message = qq{          my $sql_message = qq{
351                  select                  select
# Line 168  sub get_from_log { Line 368  sub get_from_log {
368    
369          my $sql = $context ? $sql_context : $sql_message;          my $sql = $context ? $sql_context : $sql_message;
370    
371          $sql .= " where message ilike ? or nick ilike ? " if ($args->{search});          sub check_date {
372          $sql .= " where id in (" . join(",", @{ $tags->{ $args->{tag} } }) . ") " if ($args->{tag} && $tags->{ $args->{tag} });                  my $date = shift || return;
373          $sql .= " where date(time) = ? " if ($args->{date});                  my $new_date = eval { DateTime::Format::ISO8601->parse_datetime( $date )->ymd; };
374          $sql .= " order by log.time desc";                  if ( $@ ) {
375          $sql .= " limit " . $args->{limit} if ($args->{limit});                          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    
         my $sth = $dbh->prepare( $sql );  
385          if (my $search = $args->{search}) {          if (my $search = $args->{search}) {
386                  $search =~ s/^\s+//;                  $search =~ s/^\s+//;
387                  $search =~ s/\s+$//;                  $search =~ s/\s+$//;
388                  $sth->execute( ( '%' . $search . '%' ) x 2 );                  push @where, 'message ilike ? or nick ilike ?';
389                  warn "search for '$search' returned ", $sth->rows, " results ", $context || '', "\n";                  push @args, ( ( '%' . $search . '%' ) x 2 );
390          } elsif (my $tag = $args->{tag}) {                  $msg = "Search for '$search'";
                 $sth->execute();  
                 warn "tag '$tag' returned ", $sth->rows, " results ", $context || '', "\n";  
         } elsif (my $date = $args->{date}) {  
                 $sth->execute($date);  
                 warn "found ", $sth->rows, " messages for date $date ", $context || '', "\n";  
         } else {  
                 $sth->execute();  
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";
408            $sql .= " limit " . $args->{limit} if ($args->{limit});
409    
410            #warn "### sql: $sql ", dump( @args );
411    
412            my $sth = $dbh->prepare( $sql );
413            eval { $sth->execute( @args ) };
414            return if $@;
415    
416            my $nr_results = $sth->rows;
417    
418          my $last_row = {          my $last_row = {
419                  date => '',                  date => '',
420                  time => '',                  time => '',
# Line 202  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                  "Showing " . ($#rows + 1) . " messages..."          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) {          if ($context) {
447                  my @ids = @rows;                  my @ids = @rows;
448                  @rows = ();                  @rows = ();
# Line 258  sub get_from_log { Line 495  sub get_from_log {
495                  my $append = 1;                  my $append = 1;
496    
497                  my $nick = $row->{nick};                  my $nick = $row->{nick};
498                  if ($nick =~ s/^_*(.*?)_*$/$1/) {  #               if ($nick =~ s/^_*(.*?)_*$/$1/) {
499                          $row->{nick} = $nick;  #                       $row->{nick} = $nick;
500                  }  #               }
501    
502                    $append = 0 if $row->{me};
503    
504                  if ($last_row->{nick} ne $nick) {                  if ($last_row->{nick} ne $nick) {
505                          # obfu way to find format for me_nick if needed or fallback to default                          # obfu way to find format for me_nick if needed or fallback to default
# Line 302  my $cloud = HTML::TagCloud->new; Line 541  my $cloud = HTML::TagCloud->new;
541    
542  =head2 add_tag  =head2 add_tag
543    
544   add_tag( id => 42, message => 'irc message' );   add_tag( id => 42, message => 'irc message', nick => 'foobar' [, me => 1 ] );
545    
546  =cut  =cut
547    
548    my @last_tags;
549    
550  sub add_tag {  sub add_tag {
551          my $arg = {@_};          my $arg = {@_};
552    
553          return unless ($arg->{id} && $arg->{message});          return unless ($arg->{id} && $arg->{message});
554    
555          my $m = $arg->{message};          my $m = $arg->{message};
556          from_to('UTF-8', 'iso-8859-2', $m) if (is_utf8($m));  
557            my @tags;
558    
559          while ($m =~ s#$tag_regex##s) {          while ($m =~ s#$tag_regex##s) {
560                  my $tag = $1;                  my $tag = $1;
561                  next if (! $tag || $tag =~ m/https?:/i);                  next if (! $tag || $tag =~ m/https?:/i);
562                  push @{ $tags->{$tag} }, $arg->{id};                  push @{ $tags->{$tag} }, $arg->{id};
563                  #warn "+tag $tag: $arg->{id}\n";                  #warn "+tag $tag: $arg->{id}\n";
564                  $cloud->add($tag, "?tag=$tag", scalar @{$tags->{$tag}} + 1);                  $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  =head2 seed_tags
# Line 330  Read all tags from database and create i Line 580  Read all tags from database and create i
580  =cut  =cut
581    
582  sub seed_tags {  sub seed_tags {
583          my $sth = $dbh->prepare(qq{ select id,message from log where message like '%//%' });          my $sth = $dbh->prepare(qq{ select id,message,nick,me,time from log where message like '%//%' order by time asc });
584          $sth->execute;          $sth->execute;
585          while (my $row = $sth->fetchrow_hashref) {          while (my $row = $sth->fetchrow_hashref) {
586                  add_tag( %$row );                  add_tag( %$row );
587          }          }
588    
589          foreach my $tag (keys %$tags) {          foreach my $tag (keys %$tags) {
590                  $cloud->add($tag, "?tag=$tag", scalar @{$tags->{$tag}} + 1);                  $cloud->add($tag, "$url?tag=$tag", scalar @{$tags->{$tag}} + 1);
591          }          }
592  }  }
593    
# Line 350  seed_tags; Line 600  seed_tags;
600          channel => '#foobar',          channel => '#foobar',
601          me => 0,          me => 0,
602          nick => 'dpavlin',          nick => 'dpavlin',
603          msg => 'test message',          message => 'test message',
604          time => '2006-06-25 18:57:18',          time => '2006-06-25 18:57:18',
605    );    );
606    
# Line 362  C<me> if not specified will be C<0> (not Line 612  C<me> if not specified will be C<0> (not
612    
613  sub save_message {  sub save_message {
614          my $a = {@_};          my $a = {@_};
615            confess "have msg" if $a->{msg};
616          $a->{me} ||= 0;          $a->{me} ||= 0;
617          $a->{time} ||= strftime($TIMESTAMP,localtime());          $a->{time} ||= strftime($TIMESTAMP,localtime());
618    
619          print          _log
                 $a->{time}, " ",  
620                  $a->{channel}, " ",                  $a->{channel}, " ",
621                  $a->{me} ? "***" . $a->{nick} : "<" . $a->{nick} . ">",                  $a->{me} ? "***" . $a->{nick} : "<" . $a->{nick} . ">",
622                  " " . $a->{msg} . "\n";                  " " . $a->{message};
623    
624          from_to($a->{msg}, 'UTF-8', $ENCODING);          $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 );
         $sth->execute($a->{channel}, $a->{me}, $a->{nick}, $a->{msg}, $a->{time});  
         add_tag( id => $dbh->last_insert_id(undef,undef,"log",undef),  
                 message => $a->{msg});  
626  }  }
627    
628    
629  if ($import_dircproxy) {  if ($import_dircproxy) {
630          open(my $l, $import_dircproxy) || die "can't open $import_dircproxy: $!";          open(my $l, $import_dircproxy) || die "can't open $import_dircproxy: $!";
631          warn "importing $import_dircproxy...\n";          warn "importing $import_dircproxy...\n";
632          my $tz_offset = 2 * 60 * 60;    # TZ GMT+2          my $tz_offset = 1 * 60 * 60;    # TZ GMT+2
633          while(<$l>) {          while(<$l>) {
634                  chomp;                  chomp;
635                  if (/^@(\d+)\s(\S+)\s(.+)$/) {                  if (/^@(\d+)\s(\S+)\s(.+)$/) {
# Line 399  if ($import_dircproxy) { Line 647  if ($import_dircproxy) {
647                                  channel => $CHANNEL,                                  channel => $CHANNEL,
648                                  me => $me,                                  me => $me,
649                                  nick => $nick,                                  nick => $nick,
650                                  msg => $msg,                                  message => $msg,
651                                  time => $dt->ymd . " " . $dt->hms,                                  time => $dt->ymd . " " . $dt->hms,
652                          ) if ($nick !~ m/^-/);                          ) if ($nick !~ m/^-/);
653    
654                  } else {                  } else {
655                          warn "can't parse: $_\n";                          _log "can't parse: $_";
656                  }                  }
657          }          }
658          close($l);          close($l);
# Line 412  if ($import_dircproxy) { Line 660  if ($import_dircproxy) {
660          exit;          exit;
661  }  }
662    
   
663  #  #
664  # POE handing part  # RSS follow
665  #  #
666    
667  my $SKIPPING = 0;               # if skipping, how many we've done  my $_stat;
668  my $SEND_QUEUE;                 # cache  
669    
670    sub rss_fetch {
671            my ($args) = @_;
672    
673            # how many messages to send out when feed is seen for the first time?
674            my $send_rss_msgs = 1;
675    
676            _log "RSS fetch", $args->{url};
677    
678            my $feed = XML::Feed->parse(URI->new( $args->{url} ));
679            if ( ! $feed ) {
680                    _log("can't fetch RSS ", $args->{url});
681                    return;
682            }
683    
684            $_stat->{rss}->{url2link}->{ $args->{url} } = $feed->link;
685    
686            my ( $total, $updates ) = ( 0, 0 );
687            for my $entry ($feed->entries) {
688                    $total++;
689    
690                    my $seen_times = $_stat->{rss}->{seen}->{$args->{channel}}->{$feed->link}->{$entry->id}++;
691                    # seen allready?
692                    warn "## $seen_times ",$feed->link if $debug;
693                    next if $seen_times > 0;
694    
695                    sub prefix {
696                            my ($txt,$var) = @_;
697                            $var =~ s/\s+/ /gs;
698                            $var =~ s/^\s+//g;
699                            $var =~ s/\s+$//g;
700                            return $txt . $var if $var;
701                    }
702    
703                    # fix absolute and relative links to feed entries
704                    my $link = $entry->link;
705                    if ( $link =~ m!^/! ) {
706                            my $host = $args->{url};
707                            $host =~ s!^(http://[^/]+).*$!$1!;      #!vim
708                            $link = "$host/$link";
709                    } elsif ( $link !~ m!^http! ) {
710                            $link = $args->{url} . $link;
711                    }
712    
713                    my $msg;
714                    $msg .= prefix( 'From: ' , $args->{name} || $feed->title );
715                    $msg .= prefix( ' by ' , $entry->author );
716                    $msg .= prefix( ' | ' , $entry->title );
717                    $msg .= prefix( ' | ' , $link );
718    #               $msg .= prefix( ' id ' , $entry->id );
719                    if ( my $tags = $entry->category ) {
720                            $tags =~ s!^\s+!!;
721                            $tags =~ s!\s*$! !;
722                            $tags =~ s!,?\s+!// !g;
723                            $msg .= prefix( ' ' , $tags );
724                    }
725    
726                    if ( $seen_times == 0 && $send_rss_msgs ) {
727                            $send_rss_msgs--;
728                            if ( ! $args->{private} ) {
729                                    # FIXME bug! should be save_message
730                                    save_message( channel => $args->{channel}, me => 1, nick => $NICK, message => $msg );
731    #                               $sth_insert_log->execute( $args->{channel}, 1, $NICK, $msg, 'now()' );
732                            }
733                            my ( $type, $to ) = ( 'notice', $args->{channel} );
734                            ( $type, $to ) = ( 'privmsg', $args->{nick} ) if $args->{private};
735    
736                            _log(">> $type $to", $msg);
737    #                       $args->{kernel}->post( $irc => $type => $to, $msg );
738                            # XXX enqueue message to send later
739                            sub enqueue_post {
740                                    my $post = dump( @_ );
741                                    warn "## queue_post $post\n" if $debug;
742                                    $dq->enqueue_string( $post );
743                            }
744                            enqueue_post( $type => $to => $msg );
745    
746                            $updates++;
747                    }
748            }
749    
750            my $sql = qq{ update feeds set last_update = now(), polls = polls + 1 };
751            $sql .= qq{, updates = updates + $updates } if $updates;
752            $sql .= qq{where id = } . $args->{id};
753            eval { $dbh->do( $sql ) };
754    
755            _log "RSS got $total items of which $updates new";
756    
757            return $updates;
758    }
759    
760    sub rss_fetch_all {
761            my $kernel = shift;
762            my $sql = qq{
763                    select id, url, name, channel, nick, private
764                    from feeds
765                    where active is true
766            };
767            # limit to newer feeds only if we are not sending messages out
768            $sql .= qq{     and last_update + delay < now() } if $kernel;
769            my $sth = $dbh->prepare( $sql );
770            $sth->execute();
771            warn "# ",$sth->rows," active RSS feeds\n";
772            my $count = 0;
773            while (my $row = $sth->fetchrow_hashref) {
774                    $row->{kernel} = $kernel if $kernel;
775                    $count += rss_fetch( $row );
776            }
777            return "OK, fetched $count posts from " . $sth->rows . " feeds";
778    }
779    
780    
781    sub rss_check_updates {
782            my $kernel = shift;
783            $_stat->{rss}->{last_poll} ||= time();
784            my $dt = time() - $_stat->{rss}->{last_poll};
785            if ( $dt > $rss_min_delay ) {
786                    warn "## rss_check_updates $dt > $rss_min_delay\n";
787                    $_stat->{rss}->{last_poll} = time();
788                    _log rss_fetch_all( $kernel );
789            }
790            # XXX send queue messages
791            while ( my $job = $dq->pickup_queued_job() ) {
792                    my $data = read_file( $job->get_data_path ) || die "can't load ", $job->get_data_path, ": $!";
793    #               $kernel->post( $irc => $type => $to, $msg );
794                    my @data = eval $data;
795                    _log ">> post from queue ", $irc, @data;
796                    $kernel->post( $irc => @data );
797                    $job->finish;
798                    warn "## done queued job: ",dump( @data ) if $debug;
799            }
800    }
801    
802  POE::Component::IRC->new($IRC_ALIAS);  # seed rss seen cache so we won't send out all items on startup
803    _log rss_fetch_all if ! $debug;
804    
805  POE::Session->create( inline_states =>  POE::Session->create( inline_states => {
806     {_start => sub {                _start => sub {      
807                  $_[KERNEL]->post($IRC_ALIAS => register => 'all');                  $_[KERNEL]->post( $irc => register => 'all' );
808                  $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);                  $_[KERNEL]->post( $irc => connect => {} );
809      },      },
810            irc_001 => sub {
811                    my ($kernel,$sender) = @_[KERNEL,SENDER];
812                    my $poco_object = $sender->get_heap();
813                    _log "connected to",$poco_object->server_name();
814                    $kernel->post( $sender => join => $_ ) for @channels;
815                    undef;
816            },
817      irc_255 => sub {    # server is done blabbing      irc_255 => sub {    # server is done blabbing
818                  $_[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" );  
819      },      },
820      irc_public => sub {      irc_public => sub {
821                  my $kernel = $_[KERNEL];                  my $kernel = $_[KERNEL];
# Line 440  POE::Session->create( inline_states => Line 823  POE::Session->create( inline_states =>
823                  my $channel = $_[ARG1]->[0];                  my $channel = $_[ARG1]->[0];
824                  my $msg = $_[ARG2];                  my $msg = $_[ARG2];
825    
826                  save_message( channel => $channel, me => 0, nick => $nick, msg => $msg);                  save_message( channel => $channel, me => 0, nick => $nick, message => $msg);
827                    meta( $nick, $channel, 'last-msg', $msg );
828                    rss_check_updates( $kernel );
829      },      },
830      irc_ctcp_action => sub {      irc_ctcp_action => sub {
831                  my $kernel = $_[KERNEL];                  my $kernel = $_[KERNEL];
# Line 448  POE::Session->create( inline_states => Line 833  POE::Session->create( inline_states =>
833                  my $channel = $_[ARG1]->[0];                  my $channel = $_[ARG1]->[0];
834                  my $msg = $_[ARG2];                  my $msg = $_[ARG2];
835    
836                  save_message( channel => $channel, me => 1, nick => $nick, msg => $msg);                  save_message( channel => $channel, me => 1, nick => $nick, message => $msg);
837    
838                    if ( $use_twitter ) {
839                            if ( my $twitter = meta( $nick, $NICK, 'twitter' ) ) {
840                                    my ($login,$passwd) = split(/\s+/,$twitter,2);
841                                    _log("sending twitter for $nick/$login on $channel ");
842                                    my $bot = Net::Twitter->new( username=>$login, password=>$passwd );
843                                    $bot->update("<${channel}> $msg");
844                            }
845                    }
846    
847      },      },
848            irc_ping => sub {
849                    _log( "pong ", $_[ARG0] );
850                    $_stat->{ping}->{ $_[ARG0] }++;
851                    rss_check_updates( $_[KERNEL] );
852            },
853            irc_invite => sub {
854                    my $kernel = $_[KERNEL];
855                    my $nick = (split /!/, $_[ARG0])[0];
856                    my $channel = $_[ARG1];
857    
858                    _log "invited to $channel by $nick";
859    
860                    $_[KERNEL]->post( $irc => privmsg => $nick, "how nice of you to invite me to $channel, I'll be right there..." );
861                    $_[KERNEL]->post( $irc => 'join' => $channel );
862    
863            },
864          irc_msg => sub {          irc_msg => sub {
865                  my $kernel = $_[KERNEL];                  my $kernel = $_[KERNEL];
866                  my $nick = (split /!/, $_[ARG0])[0];                  my $nick = (split /!/, $_[ARG0])[0];
867                  my $msg = $_[ARG2];                  my $msg = $_[ARG2];
868                  from_to($msg, 'UTF-8', $ENCODING);                  my $channel = $_[ARG1]->[0];
869                    warn "# ARG = ",dump( @_[ARG0,ARG1,ARG2] ) if $debug;
870    
871                  my $res = "unknown command '$msg', try /msg $NICK help!";                  my $res = "unknown command '$msg', try /msg $NICK help!";
872                  my @out;                  my @out;
873    
874                  print "<< $msg\n";                  _log "<< $msg";
875    
876                  if ($msg =~ m/^help/i) {                  if ($msg =~ m/^help/i) {
877    
878                          $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";
879    
880                  } elsif ($msg =~ m/^msg\s+(\S+)\s+(.*)$/i) {                  } elsif ($msg =~ m/^(privmsg|notice)\s+(\S+)\s+(.*)$/i) {
881    
882                          print ">> /msg $1 $2\n";                          _log ">> /$1 $2 $3";
883                          $_[KERNEL]->post( $IRC_ALIAS => privmsg => $1, $2 );                          $_[KERNEL]->post( $irc => $1 => $2, $3 );
884                          $res = '';                          $res = '';
885    
886                  } elsif ($msg =~ m/^stat.*?\s*(\d*)/i) {                  } elsif ($msg =~ m/^stat.*?\s*(\d*)/i) {
# Line 476  POE::Session->create( inline_states => Line 888  POE::Session->create( inline_states =>
888                          my $nr = $1 || 10;                          my $nr = $1 || 10;
889    
890                          my $sth = $dbh->prepare(qq{                          my $sth = $dbh->prepare(qq{
891                                  select nick,count(*) from log group by nick order by count desc limit $nr                                  select
892                                            trim(both '_' from nick) as nick,
893                                            count(*) as count,
894                                            sum(length(message)) as len
895                                    from log
896                                    group by trim(both '_' from nick)
897                                    order by len desc,count desc
898                                    limit $nr
899                          });                          });
900                          $sth->execute();                          $sth->execute();
901                          $res = "Top $nr users: ";                          $res = "Top $nr users: ";
902                          my @users;                          my @users;
903                          while (my $row = $sth->fetchrow_hashref) {                          while (my $row = $sth->fetchrow_hashref) {
904                                  push @users,$row->{nick} . ': ' . $row->{count};                                  push @users,$row->{nick} . ': ' . $row->{count} . '/' . $row->{len} . '=' . sprintf("%.2f", $row->{len}/$row->{count});
905                          }                          }
906                          $res .= join(" | ", @users);                          $res .= join(" | ", @users);
907                  } elsif ($msg =~ m/^last.*?\s*(\d*)/i) {                  } elsif ($msg =~ m/^last.*?\s*(\d*)/i) {
908    
909                          foreach my $res (get_from_log( limit => $1 )) {                          my $limit = $1 || meta( $nick, $channel, 'last-size' ) || 10;
910                                  print "last: $res\n";  
911                                  from_to($res, $ENCODING, 'UTF-8');                          foreach my $res (get_from_log( limit => $limit )) {
912                                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );                                  _log "last: $res";
913                                    $_[KERNEL]->post( $irc => privmsg => $nick, $res );
914                          }                          }
915    
916                          $res = '';                          $res = '';
# Line 503  POE::Session->create( inline_states => Line 923  POE::Session->create( inline_states =>
923                                          limit => 20,                                          limit => 20,
924                                          search => $what,                                          search => $what,
925                                  )) {                                  )) {
926                                  print "search [$what]: $res\n";                                  _log "search [$what]: $res";
927                                  from_to($res, $ENCODING, 'UTF-8');                                  $_[KERNEL]->post( $irc => privmsg => $nick, $res );
                                 $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );  
928                          }                          }
929    
930                          $res = '';                          $res = '';
931    
932                    } elsif ($msg =~ m/^(?:count|poll)\s+(.*)(?:\s+(\d+))?\s*$/i) {
933    
934                            my ($what,$limit) = ($1,$2);
935                            $limit ||= 100;
936    
937                            my $stat;
938    
939                            foreach my $res (get_from_log(
940                                            limit => $limit,
941                                            search => $what,
942                                            full_rows => 1,
943                                    )) {
944                                    while ($res->{message} =~ s/\Q$what\E(\+|\-)//) {
945                                            $stat->{vote}->{$1}++;
946                                            $stat->{from}->{ $res->{nick} }++;
947                                    }
948                            }
949    
950                            my @nicks;
951                            foreach my $nick (sort { $stat->{from}->{$a} <=> $stat->{from}->{$b} } keys %{ $stat->{from} }) {
952                                    push @nicks, $nick . ( $stat->{from}->{$nick} == 1 ? '' :
953                                            "(" . $stat->{from}->{$nick} . ")"
954                                    );
955                            }
956    
957                            $res =
958                                    "$what ++ " . ( $stat->{vote}->{'+'} || 0 ) .
959                                    " : " . ( $stat->{vote}->{'-'} || 0 ) . " --" .
960                                    " from " . ( join(", ", @nicks) || 'nobody' );
961    
962                            $_[KERNEL]->post( $irc => notice => $nick, $res );
963    
964                    } elsif ($msg =~ m/^ping/) {
965                            $res = "ping = " . dump( $_stat->{ping} );
966                    } elsif ($msg =~ m/^conf(?:ig)*\s*(last-size|twitter)*\s*(.*)/) {
967                            if ( ! defined( $1 ) ) {
968                                    my $sth = $dbh->prepare(qq{ select name,value,changed from meta where nick = ? and channel = ? });
969                                    $sth->execute( $nick, $channel );
970                                    $res = "config for $nick on $channel";
971                                    while ( my ($n,$v) = $sth->fetchrow_array ) {
972                                            $res .= " | $n = $v";
973                                    }
974                            } elsif ( ! $2 ) {
975                                    my $val = meta( $nick, $channel, $1 );
976                                    $res = "current $1 = " . ( $val ? $val : 'undefined' );
977                            } else {
978                                    my $validate = {
979                                            'last-size' => qr/^\d+/,
980                                            'twitter' => qr/^\w+\s+\w+/,
981                                    };
982    
983                                    my ( $op, $val ) = ( $1, $2 );
984    
985                                    if ( my $regex = $validate->{$op} ) {
986                                            if ( $val =~ $regex ) {
987                                                    meta( $nick, $channel, $op, $val );
988                                                    $res = "saved $op = $val";
989                                            } else {
990                                                    $res = "config option $op = $val doesn't validate against $regex";
991                                            }
992                                    } else {
993                                            $res = "config option $op doesn't exist";
994                                    }
995                            }
996                    } elsif ($msg =~ m/^rss-update/) {
997                            $res = rss_fetch_all( $_[KERNEL] );
998                    } elsif ($msg =~ m/^rss-list/) {
999                            my $sth = $dbh->prepare(qq{ select url,name,last_update,active,channel,nick,private from feeds });
1000                            $sth->execute;
1001                            while (my @row = $sth->fetchrow_array) {
1002                                    $_[KERNEL]->post( $irc => privmsg => $nick, join(' | ',@row) );
1003                            }
1004                            $res = '';
1005                    } elsif ($msg =~ m!^rss-(add|remove|stop|start|clean)(?:-(private))?\s+(http://\S+)\s*(.*)!) {
1006                            my ( $command, $sub, $url, $arg ) = ( $1,$2,$3,$4 );
1007    
1008                            my $channel = $1 if ( $arg =~ s/\s*(#\S+)\s*// );
1009                            $channel = $nick if $sub eq 'private';
1010    
1011                            my $sql = {
1012                                    add     => qq{ insert into feeds (url,name,channel,nick,private) values (?,?,?,?,?) },
1013    #                               remove  => qq{ delete from feeds                                where url = ? and name = ? },
1014                                    start   => qq{ update feeds set active = true   where url = ? },
1015                                    stop    => qq{ update feeds set active = false  where url = ? },
1016                                    clean   => qq{ update feeds set last_update = now() - delay where url = ? },
1017                            };
1018    
1019                            if ( $command eq 'add' && ! $channel ) {
1020                                    $res = "ERROR: got '$msg' which doesn't have #channel in it, ignoring!";
1021                            } elsif (my $q = $sql->{$command} ) {
1022                                    my $sth = $dbh->prepare( $q );
1023                                    my @data = ( $url );
1024                                    if ( $command eq 'add' ) {
1025                                            push @data, ( $arg, $channel, $nick, $sub eq 'private' ? 1 : 0 );
1026                                    }
1027                                    warn "## $command SQL $q with ",dump( @data ),"\n";
1028                                    eval { $sth->execute( @data ) };
1029                                    if ($@) {
1030                                            $res = "ERROR: $@";
1031                                    } else {
1032                                            $res = "OK, RSS executed $command " . ( $sub ? "-$sub" : '' ) ."on $channel url $url";
1033                                            if ( $command eq 'clean' ) {
1034                                                    my $seen = $_stat->{rss}->{seen} || die "no seen?";
1035                                                    my $want_link = $_stat->{rss}->{url2link}->{$url} || warn "no url2link($url)";
1036                                                    foreach my $c ( keys %$seen ) {
1037                                                            my $c_hash = $seen->{$c} || die "no seen->{$c}";
1038                                                            die "not HASH with rss links but ", dump($c_hash) unless ref($c_hash) eq 'HASH';
1039                                                            foreach my $link ( keys %$c_hash ) {
1040                                                                    next unless $link eq $want_link;
1041                                                                    _log "RSS removed seen $c $url $link";
1042                                                            }
1043                                                    }
1044                                            }
1045                                    }
1046                            } else {
1047                                    $res = "ERROR: don't know what to do with: $msg";
1048                            }
1049                    } elsif ($msg =~ m/^rss-clean/) {
1050                            # this makes sense because we didn't catch rss-clean http://... before!
1051                            $_stat->{rss} = undef;
1052                            $dbh->do( qq{ update feeds set last_update = now() - delay } );
1053                            $res = "OK, cleaned RSS cache";
1054                  }                  }
1055    
1056                  if ($res) {                  if ($res) {
1057                          print ">> [$nick] $res\n";                          _log ">> [$nick] $res";
1058                          from_to($res, $ENCODING, 'UTF-8');                          $_[KERNEL]->post( $irc => privmsg => $nick, $res );
                         $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );  
1059                  }                  }
1060    
1061                    rss_check_updates( $_[KERNEL] );
1062          },          },
1063          irc_477 => sub {          irc_372 => sub {
1064                  print "# irc_477: ",$_[ARG1], "\n";                  _log "<< motd",$_[ARG0],$_[ARG1];
                 $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "register $NICK" );  
1065          },          },
1066          irc_505 => sub {          irc_375 => sub {
1067                  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" );  
1068          },          },
1069          irc_registered => sub {          irc_376 => sub {
1070                  warn "## indetify $NICK\n";                  _log "<< motd", $_[ARG0], "end";
                 $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );  
1071          },          },
1072  #       irc_433 => sub {  #       irc_433 => sub {
1073  #               print "# irc_433: ",$_[ARG1], "\n";  #               print "# irc_433: ",$_[ARG1], "\n";
1074  #               warn "## indetify $NICK\n";  #               warn "## indetify $NICK\n";
1075  #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );  #               $_[KERNEL]->post( $irc => privmsg => 'nickserv', "IDENTIFY $NICK" );
1076  #       },  #       },
1077    #       irc_451 # please register
1078            irc_477 => sub {
1079                    _log "<< irc_477: ",$_[ARG1];
1080                    _log ">> IDENTIFY $NICK";
1081                    $_[KERNEL]->post( $irc => privmsg => 'NickServ', "IDENTIFY $NICK" );
1082            },
1083            irc_505 => sub {
1084                    _log "<< irc_505: ",$_[ARG1];
1085                    _log ">> register $NICK";
1086                    $_[KERNEL]->post( $irc => privmsg => 'NickServ', "register $NICK" );
1087    #               $_[KERNEL]->post( $irc => privmsg => 'nickserv', "IDENTIFY $NICK" );
1088    #               $_[KERNEL]->post( $irc => privmsg => 'nickserv', "set hide email on" );
1089    #               $_[KERNEL]->post( $irc => privmsg => 'nickserv', "set email dpavlin\@rot13.org" );
1090            },
1091            irc_registered => sub {
1092                    _log "<< registered $NICK";
1093            },
1094            irc_disconnected => sub {
1095                    _log "## disconnected.. sleeping for $sleep_on_error seconds and reconnecting again";
1096                    sleep($sleep_on_error);
1097                    $_[KERNEL]->post( $irc => connect => {} );
1098            },
1099            irc_socketerr => sub {
1100                    _log "## socket error... sleeping for $sleep_on_error seconds and retry";
1101                    sleep($sleep_on_error);
1102                    $_[KERNEL]->post( $irc => connect => {} );
1103            },
1104            irc_notice => sub {
1105                    _log "<< notice from ", $_[ARG0], $_[ARG1], $_[ARG2];
1106                    my $m = $_[ARG2];
1107                    if ( $m =~ m!/msg.*(NickServ).*(IDENTIFY)!i ) {
1108                            _log ">> suggested to $1 $2";
1109                            $_[KERNEL]->post( $irc => privmsg => $1, "$2 $NICK" );
1110                    } elsif ( $m =~ m!\Q$NICK\E.*registered!i ) {
1111                            _log ">> registreted, so IDENTIFY";
1112                            $_[KERNEL]->post( $irc => privmsg => 'nickserv', "IDENTIFY $NICK" );
1113                    } else {
1114                            warn "## ignore $m\n" if $debug;
1115                    }
1116            },
1117            irc_snotice => sub {
1118                    _log "<< snotice", $_[ARG0]; #dump( $_[ARG0],$_[ARG1], $_[ARG2] );
1119                    if ( $_[ARG0] =~ m!/(QUOTE)\s+(PASS\s+\d+)!i ) {
1120                            warn ">> $1 | $2\n";
1121                            $_[KERNEL]->post( $irc => lc($1) => $2);
1122                    }
1123            },
1124      _child => sub {},      _child => sub {},
1125      _default => sub {      _default => sub {
1126                  printf "%s #%s %s %s\n",                  _log sprintf "sID:%s %s %s",
1127                          strftime($TIMESTAMP,localtime()), $_[SESSION]->ID, $_[ARG0],                          $_[SESSION]->ID, $_[ARG0],
1128                          ref($_[ARG1]) eq "ARRAY"        ?       join(",", map { ref($_) eq "ARRAY" ? join(";", @{$_}) : $_ } @{ $_[ARG1] })     :                          ref($_[ARG1]) eq "ARRAY"        ?       join(",", map { ref($_) eq "ARRAY" ? join(";", @{$_}) : $_ } @{ $_[ARG1] })     :
1129                          $_[ARG1]                                        ?       $_[ARG1]                                        :                          $_[ARG1]                                        ?       $_[ARG1]                                        :
1130                          "";                          "";
1131        0;                        # false for signals        0;                        # false for signals
1132      },      },
     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);  
     }  
1133     },     },
1134    );    );
1135    
1136  # http server  # http server
1137    
1138    _log "WEB archive at $url";
1139    
1140  my $httpd = POE::Component::Server::HTTP->new(  my $httpd = POE::Component::Server::HTTP->new(
1141          Port => $NICK =~ m/-dev/ ? 8001 : 8000,          Port => $http_port,
1142            PreHandler => {
1143                    '/' => sub {
1144                            $_[0]->header(Connection => 'close')
1145                    }
1146            },
1147          ContentHandler => { '/' => \&root_handler },          ContentHandler => { '/' => \&root_handler },
1148          Headers        => { Server => 'irc-logger' },          Headers        => { Server => 'irc-logger' },
1149  );  );
1150    
 my %escape = ('<'=>'&lt;', '>'=>'&gt;', '&'=>'&amp;', '"'=>'&quot;');  
 my $escape_re  = join '|' => keys %escape;  
   
1151  my $style = <<'_END_OF_STYLE_';  my $style = <<'_END_OF_STYLE_';
1152  p { margin: 0; padding: 0.1em; }  p { margin: 0; padding: 0.1em; }
1153  .time, .channel { color: #808080; font-size: 60%; }  .time, .channel { color: #808080; font-size: 60%; }
# Line 628  p { margin: 0; padding: 0.1em; } Line 1155  p { margin: 0; padding: 0.1em; }
1155  .nick { color: #000000; font-size: 80%; padding: 2px; font-family: courier, courier new, monospace ; }  .nick { color: #000000; font-size: 80%; padding: 2px; font-family: courier, courier new, monospace ; }
1156  .message { color: #000000; font-size: 100%; }  .message { color: #000000; font-size: 100%; }
1157  .search { float: right; }  .search { float: right; }
1158    a:link.tag, a:visited.tag { border: 1px dashed #ccc; backgound: #ccc; text-decoration: none }
1159    a:hover.tag { border: 1px solid #eee }
1160    hr { border: 1px dashed #ccc; height: 1px; clear: both; }
1161    /*
1162  .col-0 { background: #ffff66 }  .col-0 { background: #ffff66 }
1163  .col-1 { background: #a0ffff }  .col-1 { background: #a0ffff }
1164  .col-2 { background: #99ff99 }  .col-2 { background: #99ff99 }
1165  .col-3 { background: #ff9999 }  .col-3 { background: #ff9999 }
1166  .col-4 { background: #ff66ff }  .col-4 { background: #ff66ff }
1167  a:link.tag, a:visited.tag { border: 1px dashed #ccc; backgound: #ccc; text-decoration: none }  */
1168  a:hover.tag { border: 1px solid #eee }  .calendar { border: 1px solid red; width: 100%; }
1169  hr { border: 1px dashed #ccc; height: 1px; clear: both; }  .month { border: 0px; width: 100%; }
1170  _END_OF_STYLE_  _END_OF_STYLE_
1171    
1172  my $max_color = 4;  $max_color = 0;
1173    
1174  my %nick_enumerator;  my @cols = qw(
1175            #ffcccc #ccffe6 #ccccff #e6ccff #ffccff #ffcce6 #ff9999 #ffcc99 #ffff99
1176            #ccff99 #99ff99 #99ffcc #99ccff #9999ff #cc99ff #ff6666 #ffb366 #ffff66
1177            #66ff66 #66ffb3 #66b3ff #6666ff #ff3333 #33ff33 #3399ff #3333ff #ff3399
1178            #a0a0a0 #ff0000 #ffff00 #80ff00 #0000ff #8000ff #ff00ff #ff0080 #994d00
1179            #999900 #009900 #cc0066 #c0c0c0 #ccff99 #99ff33 #808080 #660033 #ffffff
1180    );
1181    
1182    foreach my $c (@cols) {
1183            $style .= ".col-${max_color} { background: $c }\n";
1184            $max_color++;
1185    }
1186    _log "WEB defined $max_color colors for users...";
1187    
1188  sub root_handler {  sub root_handler {
1189          my ($request, $response) = @_;          my ($request, $response) = @_;
1190          $response->code(RC_OK);          $response->code(RC_OK);
1191          $response->content_type("text/html; charset=$ENCODING");  
1192            # this doesn't seem to work, so moved to PreHandler
1193            #$response->header(Connection => 'close');
1194    
1195            return RC_OK if $request->uri =~ m/favicon.ico$/;
1196    
1197          my $q;          my $q;
1198    
# Line 658  sub root_handler { Line 1205  sub root_handler {
1205          }          }
1206    
1207          my $search = $q->param('search') || $q->param('grep') || '';          my $search = $q->param('search') || $q->param('grep') || '';
1208            my $r_url = $request->url;
1209    
1210            my @commands = qw( tags last-tag follow stat );
1211            my $commands_re = join('|',@commands);
1212    
1213            if ($r_url =~ m#/rss(?:/($commands_re.*)\w*(?:=(\d+))?)?#i) {
1214                    my $show = lc($1);
1215                    my $nr = $2;
1216    
1217                    my $type = 'RSS';       # Atom
1218    
1219                    $response->content_type( 'application/' . lc($type) . '+xml' );
1220    
1221                    my $html = '<!-- error -->';
1222                    #warn "create $type feed from ",dump( @last_tags );
1223    
1224                    my $feed = XML::Feed->new( $type );
1225                    $feed->link( $url );
1226    
1227                    my $rc = RC_OK;
1228    
1229                    if ( $show eq 'tags' ) {
1230                            $nr ||= 50;
1231                            $feed->title( "tags from $CHANNEL" );
1232                            $feed->link( "$url/tags" );
1233                            $feed->description( "tag cloud created from messages on channel $CHANNEL which have tags// in them" );
1234                            my $feed_entry = XML::Feed::Entry->new($type);
1235                            $feed_entry->title( "$nr tags from $CHANNEL" );
1236                            $feed_entry->author( $NICK );
1237                            $feed_entry->link( '/#tags'  );
1238    
1239                            $feed_entry->content(
1240                                    qq{<![CDATA[<style type="text/css">}
1241                                    . $cloud->css
1242                                    . qq{</style>}
1243                                    . $cloud->html( $nr )
1244                                    . qq{]]>}
1245                            );
1246                            $feed->add_entry( $feed_entry );
1247    
1248                    } elsif ( $show eq 'last-tag' ) {
1249    
1250                            $nr ||= $last_x_tags;
1251                            $nr = $last_x_tags if $nr > $last_x_tags;
1252    
1253                            $feed->title( "last $nr tagged messages from $CHANNEL" );
1254                            $feed->description( "collects messages which have tags// in them" );
1255    
1256                            foreach my $m ( @last_tags ) {
1257    #                               warn dump( $m );
1258                                    #my $tags = join(' ', @{$m->{tags}} );
1259                                    my $feed_entry = XML::Feed::Entry->new($type);
1260                                    $feed_entry->title( $m->{nick} . '@' . $m->{time} );
1261                                    $feed_entry->author( $m->{nick} );
1262                                    $feed_entry->link( '/#' . $m->{id}  );
1263                                    $feed_entry->issued( DateTime::Format::Flexible->build( $m->{time} ) );
1264    
1265                                    my $message = $filter->{message}->( $m->{message} );
1266                                    $message .= "<br/>\n" unless $message =~ m!<(/p|br/?)>!;
1267    #                               warn "## message = $message\n";
1268    
1269                                    #$feed_entry->summary(
1270                                    $feed_entry->content(
1271                                            "<![CDATA[$message]]>"
1272                                    );
1273                                    $feed_entry->category( join(', ', @{$m->{tags}}) );
1274                                    $feed->add_entry( $feed_entry );
1275    
1276                                    $nr--;
1277                                    last if $nr <= 0;
1278    
1279                            }
1280    
1281                    } elsif ( $show =~ m/^follow/ ) {
1282    
1283                            $feed->title( "Feeds which this bot follows" );
1284    
1285                            my $sth = $dbh->prepare( qq{ select * from feeds order by last_update desc } );
1286                            $sth->execute;
1287                            while (my $row = $sth->fetchrow_hashref) {
1288                                    my $feed_entry = XML::Feed::Entry->new($type);
1289                                    $feed_entry->title( $row->{name} );
1290                                    $feed_entry->link( $row->{url}  );
1291                                    $feed_entry->issued( DateTime::Format::Flexible->build( $row->{last_update} ) );
1292                                    $feed_entry->content(
1293                                            '<![CDATA[<pre>' . dump( $row ) . '</pre>]]>'
1294                                    );
1295                                    $feed->add_entry( $feed_entry );
1296                            }
1297    
1298                    } elsif ( $show =~ m/^stat/ ) {
1299    
1300                            my $feed_entry = XML::Feed::Entry->new($type);
1301                            $feed_entry->title( "Internal stats" );
1302                            $feed_entry->content(
1303                                    '<![CDATA[<pre>' . dump( $_stat ) . '</pre>]]>'
1304                            );
1305                            $feed->add_entry( $feed_entry );
1306    
1307                    } else {
1308                            _log "WEB unknown rss request $r_url";
1309                            $feed->title( "unknown $r_url" );
1310                            foreach my $c ( @commands ) {
1311                                    my $feed_entry = XML::Feed::Entry->new($type);
1312                                    $feed_entry->title( "rss/$c" );
1313                                    $feed_entry->link( "$url/rss/$c" );
1314                                    $feed->add_entry( $feed_entry );
1315                            }
1316                            $rc = RC_DENY;
1317                    }
1318    
1319                    $response->content( $feed->as_xml );
1320                    return $rc;
1321            }
1322    
1323            if ( $@ ) {
1324                    warn "$@";
1325            }
1326    
1327            $response->content_type("text/html; charset=UTF-8");
1328    
1329          my $html =          my $html =
1330                  qq{<html><head><title>$NICK</title><style type="text/css">$style} .                  qq{<html><head><title>$NICK</title><style type="text/css">$style}
1331                  $cloud->css .                  . $cloud->css
1332                  qq{</style></head><body>} .                  . qq{</style></head><body>}
1333                  qq{                  . qq{
1334                  <form method="post" class="search" action="/">                  <form method="post" class="search" action="/">
1335                  <input type="text" name="search" value="$search" size="10">                  <input type="text" name="search" value="$search" size="10">
1336                  <input type="submit" value="search">                  <input type="submit" value="search">
1337                  </form>                  </form>
1338                  } .                  }
1339                  $cloud->html(500) .                  . $cloud->html(500)
1340                  qq{<p>};                  . qq{<p>};
1341          if ($request->url =~ m#/history#) {  
1342            if ($request->url =~ m#/tags?#) {
1343                    # nop
1344            } elsif ($request->url =~ m#/history#) {
1345                  my $sth = $dbh->prepare(qq{                  my $sth = $dbh->prepare(qq{
1346                          select date(time) as date,count(*) as nr                          select date(time) as date,count(*) as nr,sum(length(message)) as len
1347                                  from log                                  from log
1348                                  group by date(time)                                  group by date(time)
1349                                  order by date(time) desc                                  order by date(time) desc
1350                  });                  });
1351                  $sth->execute();                  $sth->execute();
1352                  my ($l_yyyy,$l_mm) = (0,0);                  my ($l_yyyy,$l_mm) = (0,0);
1353                    $html .= qq{<table class="calendar"><tr>};
1354                  my $cal;                  my $cal;
1355                    my $ord = 0;
1356                  while (my $row = $sth->fetchrow_hashref) {                  while (my $row = $sth->fetchrow_hashref) {
1357                          # this is probably PostgreSQL specific, expects ISO date                          # this is probably PostgreSQL specific, expects ISO date
1358                          my ($yyyy,$mm,$dd) = split(/-/, $row->{date});                          my ($yyyy,$mm,$dd) = split(/-/, $row->{date});
1359                          if ($yyyy != $l_yyyy || $mm != $l_mm) {                          if ($yyyy != $l_yyyy || $mm != $l_mm) {
1360                                  $html .= $cal->as_HTML() if ($cal);                                  if ( $cal ) {
1361                                            $html .= qq{<td valign="top">} . $cal->as_HTML() . qq{</td>};
1362                                            $ord++;
1363                                            $html .= qq{</tr><tr>} if ( $ord % 3 == 0 );
1364                                    }
1365                                  $cal = new HTML::CalendarMonthSimple('month'=>$mm,'year'=>$yyyy);                                  $cal = new HTML::CalendarMonthSimple('month'=>$mm,'year'=>$yyyy);
1366                                  $cal->border(2);                                  $cal->border(1);
1367                                    $cal->width('30%');
1368                                    $cal->cellheight('5em');
1369                                    $cal->tableclass('month');
1370                                    #$cal->cellclass('day');
1371                                    $cal->sunday('SUN');
1372                                    $cal->saturday('SAT');
1373                                    $cal->weekdays('MON','TUE','WED','THU','FRI');
1374                                  ($l_yyyy,$l_mm) = ($yyyy,$mm);                                  ($l_yyyy,$l_mm) = ($yyyy,$mm);
1375                          }                          }
1376                          $cal->setcontent($dd, qq{                          $cal->setcontent($dd, qq[
1377                                  <a href="/?date=$row->{date}">$row->{nr}</a>                                  <a href="$url?date=$row->{date}">$row->{nr}</a><br/>$row->{len}
1378                          });                          ]) if $cal;
1379                            
1380                  }                  }
1381                  $html .= $cal->as_HTML() if ($cal);                  $html .= qq{<td valign="top">} . $cal->as_HTML() . qq{</td></tr></table>};
1382    
1383          } else {          } else {
1384                  $html .= join("</p><p>",                  $html .= join("</p><p>",
1385                          get_from_log(                          get_from_log(
1386                                  limit => $q->param('last') || $q->param('date') ? undef : 100,                                  limit => ( $q->param('last') || $q->param('date') ) ? undef : 100,
1387                                  search => $search || undef,                                  search => $search || undef,
1388                                  tag => $q->param('tag') || undef,                                  tag => $q->param('tag') || undef,
1389                                  date => $q->param('date') || undef,                                  date => $q->param('date') || undef,
1390                                  fmt => {                                  fmt => {
1391                                          date => sub {                                          date => sub {
1392                                                  my $date = shift || return;                                                  my $date = shift || return;
1393                                                  qq{<hr/><div class="date"><a href="/?date=$date">$date</a></div>};                                                  qq{<hr/><div class="date"><a href="$url?date=$date">$date</a></div>};
1394                                          },                                          },
1395                                          time => '<span class="time">%s</span> ',                                          time => '<span class="time">%s</span> ',
1396                                          time_channel => '<span class="channel">%s %s</span> ',                                          time_channel => '<span class="channel">%s %s</span> ',
# Line 714  sub root_handler { Line 1398  sub root_handler {
1398                                          me_nick => '***%s&nbsp;',                                          me_nick => '***%s&nbsp;',
1399                                          message => '<span class="message">%s</span>',                                          message => '<span class="message">%s</span>',
1400                                  },                                  },
1401                                  filter => {                                  filter => $filter,
                                         message => sub {  
                                                 my $m = shift || return;  
                                                 $m =~ s/($escape_re)/$escape{$1}/gs;  
                                                 $m =~ s#($RE{URI}{HTTP})#<a href="$1">$1</a>#gs;  
                                                 $m =~ s#$tag_regex#<a href="?tag=$1" class="tag">$1</a>#g;  
                                                 return $m;  
                                         },  
                                         nick => sub {  
                                                 my $n = shift || return;  
                                                 if (! $nick_enumerator{$n})  {  
                                                         my $max = scalar keys %nick_enumerator;  
                                                         $nick_enumerator{$n} = $max + 1;  
                                                 }  
                                                 return '<span class="nick col-' .  
                                                         ( $nick_enumerator{$n} % $max_color ) .  
                                                         '">' . $n . '</span>';  
                                         },  
                                 },  
1402                          )                          )
1403                  );                  );
1404          }          }
# Line 743  sub root_handler { Line 1409  sub root_handler {
1409          </body></html>};          </body></html>};
1410    
1411          $response->content( $html );          $response->content( $html );
1412            warn "<< ", $request->method, " ", $request->uri, " created ", length($html), " bytes\n";
1413          return RC_OK;          return RC_OK;
1414  }  }
1415    

Legend:
Removed from v.38  
changed lines
  Added in v.120

  ViewVC Help
Powered by ViewVC 1.1.26