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