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