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