/[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 147 by dpavlin, Sat Aug 28 20:24:57 2010 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 $redis = Redis->new( server => '192.168.1.61:6379' );
571            my @channel = ( 'channel' , $a->{channel}, $a->{nick} );
572            push @channel, 'me' if $a->{me};
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            open(my $l, $import_dircproxy) || die "can't open $import_dircproxy: $!";
586            warn "importing $import_dircproxy...\n";
587            my $tz_offset = 1 * 60 * 60;    # TZ GMT+2
588            while(<$l>) {
589                    chomp;
590                    if (/^@(\d+)\s(\S+)\s(.+)$/) {
591                            my ($time, $nick, $msg) = ($1,$2,$3);
592    
593                            my $dt = DateTime->from_epoch( epoch => $time + $tz_offset );
594    
595                            my $me = 0;
596                            $me = 1 if ($nick =~ m/^\[\S+]/);
597                            $nick =~ s/^[\[<]([^!]+).*$/$1/;
598    
599                            $msg =~ s/^ACTION\s+// if ($me);
600    
601                            save_message(
602                                    channel => $CHANNEL,
603                                    me => $me,
604                                    nick => $nick,
605                                    message => $msg,
606                                    time => $dt->ymd . " " . $dt->hms,
607                            ) if ($nick !~ m/^-/);
608    
609                    } else {
610                            _log "can't parse: $_";
611                    }
612            }
613            close($l);
614            warn "import over\n";
615            exit;
616    }
617    
618                          $res = "usage: /msg $NICK comand | commands: stat - user/message stat | last - show backtrace | grep foobar - find foobar";  #
619    # RSS follow
620    #
621    
622    my $_stat;
623    
624    POE::Component::Client::HTTP->spawn(
625            Alias   => 'rss-fetch',
626            Timeout => 30,
627    );
628    
629                  } elsif ($msg =~ m/^msg\s+(\S+)\s+(.*)$/i) {  =head2 rss_parse_xml
630    
631                          print ">> /msg $1 $2\n";    rss_parse_xml({
632                          $_[KERNEL]->post( $IRC_ALIAS => privmsg => $1, $2 );          url => 'http://www.example.com/rss',
633                          $res = '';          send_rss_msgs => 42,
634      });
635    
636                  } elsif ($msg =~ m/^stat.*?\s*(\d*)/i) {  =cut
637    
638                          my $nr = $1 || 10;  sub rss_parse_xml {
639            my ($kernel,$args) = @_;
640    
641                          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) {  
642    
643                          foreach my $res (get_from_log( limit => $1 )) {          # how many messages to send out when feed is seen for the first time?
644                                  print "last: $res\n";          my $send_rss_msgs = $args->{send_rss_msgs};
645                                  from_to($res, $ENCODING, 'UTF-8');          $send_rss_msgs = 1 if ! defined $send_rss_msgs;
646                                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );  
647            warn "## RSS fetch first $send_rss_msgs items from", $args->{url} if $debug;
648    
649            my $feed;
650            eval { $feed = XML::Feed->parse( \$args->{xml} ) };
651            if ( ! $feed ) {
652                    _log "can't fetch RSS ", $args->{url}, XML::Feed->errstr;
653                    return;
654            }
655    
656            $_stat->{rss}->{url2link}->{ $args->{url} } = $feed->link;
657    
658            my ( $total, $updates ) = ( 0, 0 );
659            for my $entry ($feed->entries) {
660                    $total++;
661    
662                    my $seen_times = $_stat->{rss}->{seen}->{$args->{channel}}->{$feed->link}->{$entry->id}++;
663                    # seen allready?
664                    warn "## $seen_times ",$entry->id if $debug;
665                    next if $seen_times > 0;
666    
667                    sub prefix {
668                            my ($txt,$var) = @_;
669                            $var =~ s/\s+/ /gs;
670                            $var =~ s/^\s+//g;
671                            $var =~ s/\s+$//g;
672                            return $txt . $var if $var;
673                    }
674    
675                    # fix absolute and relative links to feed entries
676                    my $link = $entry->link;
677                    if ( $link =~ m!^/! ) {
678                            my $host = $args->{url};
679                            $host =~ s!^(http://[^/]+).*$!$1!;      #!vim
680                            $link = "$host/$link";
681                    } elsif ( $link !~ m!^http! ) {
682                            $link = $args->{url} . $link;
683                    }
684    
685                    my $msg;
686                    $msg .= prefix( 'From: ' , $args->{name} || $feed->title );
687                    $msg .= prefix( ' by ' , $entry->author );
688                    $msg .= prefix( ' | ' , $entry->title );
689                    $msg .= prefix( ' | ' , $link );
690    #               $msg .= prefix( ' id ' , $entry->id );
691                    my @categories = $entry->category;
692                    warn "## category = ", dump( @categories ) if $debug;
693                    if ( my $tags = $entry->category ) {
694                            $tags = join(' ', @$tags) if ref($tags) eq 'ARRAY';
695                            $tags =~ s!^\s+!!;
696                            $tags =~ s!\s*$! !;
697                            $tags =~ s!,?\s+!// !g;
698                            $msg .= prefix( ' ' , $tags );
699                    }
700    
701                    if ( $seen_times == 0 && $send_rss_msgs ) {
702                            $send_rss_msgs--;
703                            if ( ! $args->{private} ) {
704                                    # FIXME bug! should be save_message
705                                    save_message( channel => $args->{channel}, me => 1, nick => $NICK, message => $msg );
706    #                               $sth_insert_log->execute( $args->{channel}, 1, $NICK, $msg, 'now()' );
707                          }                          }
708                            my ( $type, $to ) = ( 'notice', $args->{channel} );
709                            ( $type, $to ) = ( 'privmsg', $args->{nick} ) if $args->{private};
710    
711                            _log(">> RSS $type to $to:", $msg);
712                            $kernel->post( $irc => $type => $to => $msg );
713    
714                            $updates++;
715                    }
716            }
717    
718            my $sql = qq{ update feeds set last_update = now(), polls = polls + 1 };
719            $sql .= qq{, updates = updates + $updates } if $updates;
720            $sql .= qq{where id = } . $args->{id};
721            eval { $dbh->do( $sql ) };
722    
723            _log "RSS $updates/$total new items from", $args->{url};
724    
725            return $updates;
726    }
727    
728    sub rss_fetch_all {
729            my ( $kernel, $send_rss_msgs )  = @_;
730            warn "## rss_fetch_all -- send_rss_msgs: $send_rss_msgs\n" if $debug;
731            my $sql = qq{
732                    select id, url, name, channel, nick, private
733                    from feeds
734                    where active is true
735            };
736            # limit to newer feeds only if we are not sending messages out
737            $sql .= qq{     and last_update + delay < now() } if defined ( $_stat->{rss}->{fetch} );
738            my $sth = $dbh->prepare( $sql );
739            $sth->execute();
740            warn "# ",$sth->rows," active RSS feeds\n";
741            my $count = 0;
742            while (my $row = $sth->fetchrow_hashref) {
743                    $row->{send_rss_msgs} = $send_rss_msgs if defined $send_rss_msgs;
744                    $_stat->{rss}->{fetch}->{ $row->{url} } = $row;
745                    $kernel->post(
746                            'rss-fetch',
747                            'request',
748                            'rss_response',
749                            HTTP::Request->new( GET => $row->{url} ),
750                    );
751                    warn "## queued rss-fetch ", dump( $row ) if $debug;
752            }
753            return "OK, scheduled " . $sth->rows . " feeds for refresh";
754    }
755    
                         $res = '';  
756    
757                  } elsif ($msg =~ m/^(search|grep)\s+(.*)$/i) {  sub rss_check_updates {
758            my $kernel = shift;
759            $_stat->{rss}->{last_poll} ||= time();
760            my $dt = time() - $_stat->{rss}->{last_poll};
761            if ( $dt > $rss_min_delay ) {
762                    warn "## rss_check_updates $dt > $rss_min_delay\n";
763                    $_stat->{rss}->{last_poll} = time();
764                    _log rss_fetch_all( $kernel );
765            }
766    }
767    
768    sub process_command {
769            my ( $kernel, $nick, $channel, $msg ) = @_;
770    
771            my $res = "unknown command '$msg', try /msg $NICK help!";
772    
773            if ($msg =~ m/^help/i) {
774    
775                    $res = "usage: /msg $NICK comand | commands: stat - user/message stat | last - show backtrace | grep foobar - find foobar";
776    
777            } elsif ($msg =~ m/^(privmsg|notice)\s+(\S+)\s+(.*)$/i) {
778    
779                    _log ">> /$1 $2 $3";
780                    $kernel->post( $irc => $1 => $2, $3 );
781                    $res = '';
782    
783            } elsif ($msg =~ m/^stat.*?\s*(\d*)/i) {
784    
785                    my $nr = $1 || 10;
786    
787                    my $sth = $dbh->prepare(qq{
788                            select
789                                    trim(both '_' from nick) as nick,
790                                    count(*) as count,
791                                    sum(length(message)) as len
792                            from log
793                            group by trim(both '_' from nick)
794                            order by len desc,count desc
795                            limit $nr
796                    });
797                    $sth->execute();
798                    $res = "Top $nr users: ";
799                    my @users;
800                    while (my $row = $sth->fetchrow_hashref) {
801                            push @users,$row->{nick} . ': ' . $row->{count} . '/' . $row->{len} . '=' . sprintf("%.2f", $row->{len}/$row->{count});
802                    }
803                    $res .= join(" | ", @users);
804            } elsif ($msg =~ m/^last.*?\s*(\d*)/i) {
805    
806                    my $limit = $1 || meta( $nick, $channel, 'last-size' ) || 10;
807    
808                    foreach my $res (get_from_log( limit => $limit )) {
809                            _log "last: $res";
810                            $kernel->post( $irc => privmsg => $nick, $res );
811                    }
812    
813                    $res = '';
814    
815            } elsif ($msg =~ m/^(search|grep)\s+(.*)\s*$/i) {
816    
817                    my $what = $2;
818    
819                    foreach my $res (get_from_log(
820                                    limit => 20,
821                                    search => $what,
822                            )) {
823                            _log "search [$what]: $res";
824                            $kernel->post( $irc => privmsg => $nick, $res );
825                    }
826    
827                    $res = '';
828    
829            } elsif ($msg =~ m/^(?:count|poll)\s+(.*)(?:\s+(\d+))?\s*$/i) {
830    
831                    my ($what,$limit) = ($1,$2);
832                    $limit ||= 100;
833    
834                    my $stat;
835    
836                          my $what = $2;                  foreach my $res (get_from_log(
837                                    limit => $limit,
838                                    search => $what,
839                                    full_rows => 1,
840                            )) {
841                            while ($res->{message} =~ s/\Q$what\E(\+|\-)//) {
842                                    $stat->{vote}->{$1}++;
843                                    $stat->{from}->{ $res->{nick} }++;
844                            }
845                    }
846    
847                          foreach my $res (get_from_log( limit => 20, search => $what )) {                  my @nicks;
848                                  print "search [$what]: $res\n";                  foreach my $nick (sort { $stat->{from}->{$a} <=> $stat->{from}->{$b} } keys %{ $stat->{from} }) {
849                                  from_to($res, $ENCODING, 'UTF-8');                          push @nicks, $nick . ( $stat->{from}->{$nick} == 1 ? '' :
850                                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );                                  "(" . $stat->{from}->{$nick} . ")"
851                            );
852                    }
853    
854                    $res =
855                            "$what ++ " . ( $stat->{vote}->{'+'} || 0 ) .
856                            " : " . ( $stat->{vote}->{'-'} || 0 ) . " --" .
857                            " from " . ( join(", ", @nicks) || 'nobody' );
858    
859                    $kernel->post( $irc => notice => $nick, $res );
860    
861            } elsif ($msg =~ m/^ping/) {
862                    $res = "ping = " . dump( $_stat->{ping} );
863            } elsif ($msg =~ m/^conf(?:ig)*\s*(last-size|twitter)*\s*(.*)/) {
864                    if ( ! defined( $1 ) ) {
865                            my $sth = $dbh->prepare(qq{ select name,value,changed from meta where nick = ? and channel = ? });
866                            $sth->execute( $nick, $channel );
867                            $res = "config for $nick on $channel";
868                            while ( my ($n,$v) = $sth->fetchrow_array ) {
869                                    $res .= " | $n = $v";
870                            }
871                    } elsif ( ! $2 ) {
872                            my $val = meta( $nick, $channel, $1 );
873                            $res = "current $1 = " . ( $val ? $val : 'undefined' );
874                    } else {
875                            my $validate = {
876                                    'last-size' => qr/^\d+/,
877                                    'twitter' => qr/^\w+\s+\w+/,
878                            };
879    
880                            my ( $op, $val ) = ( $1, $2 );
881    
882                            if ( my $regex = $validate->{$op} ) {
883                                    if ( $val =~ $regex ) {
884                                            meta( $nick, $channel, $op, $val );
885                                            $res = "saved $op = $val";
886                                    } else {
887                                            $res = "config option $op = $val doesn't validate against $regex";
888                                    }
889                            } else {
890                                    $res = "config option $op doesn't exist";
891                          }                          }
892                    }
893            } elsif ($msg =~ m/^rss-update/) {
894                    $res = rss_fetch_all( $kernel );
895            } elsif ($msg =~ m/^rss-list/) {
896                    my $sth = $dbh->prepare(qq{ select url,name,last_update,active,channel,nick,private from feeds });
897                    $sth->execute;
898                    while (my @row = $sth->fetchrow_array) {
899                            $kernel->post( $irc => privmsg => $nick, join(' | ',@row) );
900                    }
901                    $res = '';
902            } elsif ($msg =~ m!^rss-(add|remove|stop|start|clean)(?:-(private))?\s+(http://\S+)\s*(.*)!) {
903                    my ( $command, $sub, $url, $arg ) = ( $1,$2,$3,$4 );
904    
905                    my $channel = $1 if ( $arg =~ s/\s*(#\S+)\s*// );
906                    $channel = $nick if $sub eq 'private';
907    
908                    my $sql = {
909                            add     => qq{ insert into feeds (url,name,channel,nick,private) values (?,?,?,?,?) },
910                            remove  => qq{ delete from feeds                                where url = ? and nick = ? },
911                            start   => qq{ update feeds set active = true   where url = ? },
912                            stop    => qq{ update feeds set active = false  where url = ? },
913                            clean   => qq{ update feeds set last_update = now() - delay where url = ? },
914                    };
915    
916                    if ( $command eq 'add' && ! $channel ) {
917                            $res = "ERROR: got '$msg' which doesn't have #channel in it, ignoring!";
918                    } elsif (my $q = $sql->{$command} ) {
919                            my $sth = $dbh->prepare( $q );
920                            my @data = ( $url );
921                            if ( $command eq 'add' ) {
922                                    push @data, ( $arg, $channel, $nick, $sub eq 'private' ? 1 : 0 );
923                            } elsif ( $command eq 'remove' ) {
924                                    push @data, $nick;
925                            }
926                            warn "## $command SQL $q with ",dump( @data ),"\n";
927                            eval { $sth->execute( @data ) };
928                            if ($@) {
929                                    $res = "ERROR: $@";
930                            } else {
931                                    $res = "OK, RSS executed $command" .
932                                            ( $sub ? "-$sub " : ' ' ) .
933                                            ( $channel ? "on $channel " : '' ) .
934                                            "url $url";
935                                    if ( $command eq 'clean' ) {
936                                            my $seen = $_stat->{rss}->{seen} || die "no seen?";
937                                            my $want_link = $_stat->{rss}->{url2link}->{$url} || warn "no url2link($url)";
938                                            foreach my $c ( keys %$seen ) {
939                                                    my $c_hash = $seen->{$c} || die "no seen->{$c}";
940                                                    die "not HASH with rss links but ", dump($c_hash) unless ref($c_hash) eq 'HASH';
941                                                    foreach my $link ( keys %$c_hash ) {
942                                                            next unless $link eq $want_link;
943                                                            _log "RSS removed seen $c $url $link";
944                                                    }
945                                            }
946                                    } elsif ( $command eq 'add' ) {
947                                            rss_fetch_all( $kernel );
948                                    }
949                            }
950                    } else {
951                            $res = "ERROR: don't know what to do with: $msg";
952                    }
953            } elsif ($msg =~ m/^rss-clean/) {
954                    # this makes sense because we didn't catch rss-clean http://... before!
955                    $_stat->{rss} = undef;
956                    $dbh->do( qq{ update feeds set last_update = now() - delay } );
957                    $res = rss_fetch_all( $kernel );
958            }
959    
960            return $res;
961    }
962    
963    POE::Session->create( inline_states => {
964            _start => sub {      
965                    $_[KERNEL]->post( $irc => register => 'all' );
966                    $_[KERNEL]->post( $irc => connect => {} );
967        },
968            irc_001 => sub {
969                    my ($kernel,$sender) = @_[KERNEL,SENDER];
970                    my $poco_object = $sender->get_heap();
971                    _log "connected to",$poco_object->server_name();
972                    $kernel->post( $sender => join => $_ ) for @channels;
973                    # seen RSS cache, so don't send out messages
974                    _log rss_fetch_all( $kernel, 0 );
975                    undef;
976            },
977    #       irc_255 => sub {        # server is done blabbing
978    #               $_[KERNEL]->post( $irc => join => $CHANNEL);
979    #       },
980        irc_public => sub {
981                    my $kernel = $_[KERNEL];
982                    my $nick = (split /!/, $_[ARG0])[0];
983                    my $channel = $_[ARG1]->[0];
984                    my $msg = $_[ARG2];
985    
986                          $res = '';                  save_message( channel => $channel, me => 0, nick => $nick, message => $msg);
987                    meta( $nick, $channel, 'last-msg', $msg );
988                    rss_check_updates( $kernel );
989        },
990        irc_ctcp_action => sub {
991                    my $kernel = $_[KERNEL];
992                    my $nick = (split /!/, $_[ARG0])[0];
993                    my $channel = $_[ARG1]->[0];
994                    my $msg = $_[ARG2];
995    
996                    save_message( channel => $channel, me => 1, nick => $nick, message => $msg);
997    
998                    if ( $use_twitter ) {
999                            if ( my $twitter = meta( $nick, $NICK, 'twitter' ) ) {
1000                                    my ($login,$passwd) = split(/\s+/,$twitter,2);
1001                                    _log("sending twitter for $nick/$login on $channel ");
1002                                    my $bot = Net::Twitter->new( username=>$login, password=>$passwd );
1003                                    $bot->update("<${channel}> $msg");
1004                            }
1005                  }                  }
1006    
1007        },
1008            irc_ping => sub {
1009                    _log( "pong ", $_[ARG0] );
1010                    $_stat->{ping}->{ $_[ARG0] }++;
1011                    rss_check_updates( $_[KERNEL] );
1012            },
1013            irc_invite => sub {
1014                    my $kernel = $_[KERNEL];
1015                    my $nick = (split /!/, $_[ARG0])[0];
1016                    my $channel = $_[ARG1];
1017    
1018                    _log "invited to $channel by $nick";
1019    
1020                    $_[KERNEL]->post( $irc => privmsg => $nick, "how nice of you to invite me to $channel, I'll be right there..." );
1021                    $_[KERNEL]->post( $irc => 'join' => $channel );
1022    
1023            },
1024            irc_msg => sub {
1025                    my $kernel = $_[KERNEL];
1026                    my $nick = (split /!/, $_[ARG0])[0];
1027                    my $channel = $_[ARG1]->[0];
1028                    my $msg = $_[ARG2];
1029                    warn "# ARG = ",dump( @_[ARG0,ARG1,ARG2] ) if $debug;
1030    
1031                    _log "<< $msg";
1032    
1033                    my $res = process_command( $_[KERNEL], $nick, $channel, $msg );
1034    
1035                  if ($res) {                  if ($res) {
1036                          print ">> [$nick] $res\n";                          _log ">> [$nick] $res";
1037                          from_to($res, $ENCODING, 'UTF-8');                          $_[KERNEL]->post( $irc => privmsg => $nick, $res );
                         $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );  
1038                  }                  }
1039    
1040                    rss_check_updates( $_[KERNEL] );
1041          },          },
1042          irc_477 => sub {          irc_372 => sub {
1043                  print "# irc_477: ",$_[ARG1], "\n";                  _log "<< motd",$_[ARG0],$_[ARG1];
                 $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "register $NICK" );  
1044          },          },
1045          irc_505 => sub {          irc_375 => sub {
1046                  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" );  
1047          },          },
1048          irc_registered => sub {          irc_376 => sub {
1049                  warn "## indetify $NICK\n";                  _log "<< motd", $_[ARG0], "end";
                 $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );  
1050          },          },
1051  #       irc_433 => sub {  #       irc_433 => sub {
1052  #               print "# irc_433: ",$_[ARG1], "\n";  #               print "# irc_433: ",$_[ARG1], "\n";
1053  #               warn "## indetify $NICK\n";  #               warn "## indetify $NICK\n";
1054  #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );  #               $_[KERNEL]->post( $irc => privmsg => 'nickserv', "IDENTIFY $NICK" );
1055  #       },  #       },
1056          irc_372 => sub {  #       irc_451 # please register
1057                  print "MOTD: ", $_[ARG1], "\n";          irc_477 => sub {
1058                    _log "<< irc_477: ",$_[ARG1];
1059                    _log ">> IDENTIFY $NICK";
1060                    $_[KERNEL]->post( $irc => privmsg => 'NickServ', "IDENTIFY $NICK" );
1061            },
1062            irc_505 => sub {
1063                    _log "<< irc_505: ",$_[ARG1];
1064                    _log ">> register $NICK";
1065                    $_[KERNEL]->post( $irc => privmsg => 'NickServ', "register $NICK" );
1066    #               $_[KERNEL]->post( $irc => privmsg => 'nickserv', "IDENTIFY $NICK" );
1067    #               $_[KERNEL]->post( $irc => privmsg => 'nickserv', "set hide email on" );
1068    #               $_[KERNEL]->post( $irc => privmsg => 'nickserv', "set email dpavlin\@rot13.org" );
1069            },
1070            irc_registered => sub {
1071                    _log "<< registered $NICK";
1072            },
1073            irc_disconnected => sub {
1074                    _log "## disconnected.. sleeping for $sleep_on_error seconds and reconnecting again";
1075                    sleep($sleep_on_error);
1076                    $_[KERNEL]->post( $irc => connect => {} );
1077            },
1078            irc_socketerr => sub {
1079                    _log "## socket error... sleeping for $sleep_on_error seconds and retry";
1080                    sleep($sleep_on_error);
1081                    $_[KERNEL]->post( $irc => connect => {} );
1082            },
1083            irc_notice => sub {
1084                    _log "<< notice from ", $_[ARG0], $_[ARG1], $_[ARG2];
1085                    my $m = $_[ARG2];
1086                    if ( $m =~ m!/msg.*(NickServ).*(IDENTIFY)!i ) {
1087                            _log ">> suggested to $1 $2";
1088                            $_[KERNEL]->post( $irc => privmsg => $1, "$2 $NICK" );
1089                    } elsif ( $m =~ m!\Q$NICK\E.*registered!i ) {
1090                            _log ">> registreted, so IDENTIFY";
1091                            $_[KERNEL]->post( $irc => privmsg => 'nickserv', "IDENTIFY $NICK" );
1092                    } else {
1093                            warn "## ignore $m\n" if $debug;
1094                    }
1095          },          },
1096          irc_snotice => sub {          irc_snotice => sub {
1097                  print "(server notice): ", $_[ARG0], "\n";                  _log "<< snotice", $_[ARG0]; #dump( $_[ARG0],$_[ARG1], $_[ARG2] );
1098                    if ( $_[ARG0] =~ m!/(QUOTE)\s+(PASS\s+\d+)!i ) {
1099                            warn ">> $1 | $2\n";
1100                            $_[KERNEL]->post( $irc => lc($1) => $2);
1101                    }
1102          },          },
     (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  
1103      _child => sub {},      _child => sub {},
1104      _default => sub {      _default => sub {
1105        printf "%s: session %s caught an unhandled %s event.\n",                  _log '_default SID:', $_[SESSION]->ID, $_[ARG0], dump( $_[ARG1] );
1106          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  
       }  
   
1107      },      },
1108      my_heartbeat => sub {          rss_response => sub {
1109        $_[KERNEL]->yield(my_tailed => time, "heartbeat", "beep");                  my ($request_packet, $response_packet) = @_[ARG0, ARG1];
1110        $_[KERNEL]->delay($_[STATE] => 10);                  my $request_object  = $request_packet->[0];
1111      }                  my $response_object = $response_packet->[0];
1112    
1113                    my $row = delete( $_stat->{rss}->{fetch}->{ $request_object->uri } );
1114                    if ( $row ) {
1115                            $row->{xml} = $response_object->content;
1116                            rss_parse_xml( $_[KERNEL], $row );
1117                    } else {
1118                            warn "## can't find rss->fetch for ", $request_object->uri;
1119                    }
1120            },
1121     },     },
1122    );    );
1123    
1124  # http server  # http server
1125    
1126    _log "WEB archive at $url";
1127    
1128  my $httpd = POE::Component::Server::HTTP->new(  my $httpd = POE::Component::Server::HTTP->new(
1129          Port => $NICK =~ m/-dev/ ? 8001 : 8000,          Port => $http_port,
1130            PreHandler => {
1131                    '/' => sub {
1132                            $_[0]->header(Connection => 'close')
1133                    }
1134            },
1135          ContentHandler => { '/' => \&root_handler },          ContentHandler => { '/' => \&root_handler },
1136          Headers        => { Server => 'irc-logger' },          Headers        => { Server => 'irc-logger' },
1137  );  );
1138    
 my %escape = ('<'=>'&lt;', '>'=>'&gt;', '&'=>'&amp;', '"'=>'&quot;');  
 my $escape_re  = join '|' => keys %escape;  
   
1139  my $style = <<'_END_OF_STYLE_';  my $style = <<'_END_OF_STYLE_';
1140  p { margin: 0; padding: 0.1em; }  p { margin: 0; padding: 0.1em; }
1141  .time, .channel { color: #808080; font-size: 60%; }  .time, .channel { color: #808080; font-size: 60%; }
1142    .date { float: right; background: #e0e0e0; color: #404040; font-size: 120%; padding: 0.25em; border: 1px dashed #808080; }
1143  .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 ; }
1144  .message { color: #000000; font-size: 100%; }  .message { color: #000000; font-size: 100%; }
1145  .search { float: right; }  .search { float: right; }
1146    a:link.tag, a:visited.tag { border: 1px dashed #ccc; backgound: #ccc; text-decoration: none }
1147    a:hover.tag { border: 1px solid #eee }
1148    hr { border: 1px dashed #ccc; height: 1px; clear: both; }
1149    /*
1150  .col-0 { background: #ffff66 }  .col-0 { background: #ffff66 }
1151  .col-1 { background: #a0ffff }  .col-1 { background: #a0ffff }
1152  .col-2 { background: #99ff99 }  .col-2 { background: #99ff99 }
1153  .col-3 { background: #ff9999 }  .col-3 { background: #ff9999 }
1154  .col-4 { background: #ff66ff }  .col-4 { background: #ff66ff }
1155    */
1156    .calendar { border: 1px solid red; width: 100%; }
1157    .month { border: 0px; width: 100%; }
1158  _END_OF_STYLE_  _END_OF_STYLE_
1159    
1160  my $max_color = 4;  $max_color = 0;
1161    
1162  my %nick_enumerator;  my @cols = qw(
1163            #ffcccc #ccffe6 #ccccff #e6ccff #ffccff #ffcce6 #ff9999 #ffcc99 #ffff99
1164            #ccff99 #99ff99 #99ffcc #99ccff #9999ff #cc99ff #ff6666 #ffb366 #ffff66
1165            #66ff66 #66ffb3 #66b3ff #6666ff #ff3333 #33ff33 #3399ff #3333ff #ff3399
1166            #a0a0a0 #ff0000 #ffff00 #80ff00 #0000ff #8000ff #ff00ff #ff0080 #994d00
1167            #999900 #009900 #cc0066 #c0c0c0 #ccff99 #99ff33 #808080 #660033 #ffffff
1168    );
1169    
1170    foreach my $c (@cols) {
1171            $style .= ".col-${max_color} { background: $c }\n";
1172            $max_color++;
1173    }
1174    _log "WEB defined $max_color colors for users...";
1175    
1176  sub root_handler {  sub root_handler {
1177          my ($request, $response) = @_;          my ($request, $response) = @_;
1178          $response->code(RC_OK);          $response->code(RC_OK);
1179          $response->content_type("text/html; charset=$ENCODING");  
1180            # this doesn't seem to work, so moved to PreHandler
1181            #$response->header(Connection => 'close');
1182    
1183            return RC_OK if $request->uri =~ m/favicon.ico$/;
1184    
1185            if ( $request->uri =~ m/robots.txt$/ ) {
1186                    $response->content_type( 'text/plain' );
1187                    $response->content( qq{
1188    
1189    User-Agent: *
1190    Disallow: /
1191    
1192                    });
1193                    return RC_OK;
1194            }
1195    
1196          my $q;          my $q;
1197    
# Line 470  sub root_handler { Line 1204  sub root_handler {
1204          }          }
1205    
1206          my $search = $q->param('search') || $q->param('grep') || '';          my $search = $q->param('search') || $q->param('grep') || '';
1207            my $r_url = $request->url;
1208    
1209            my @commands = qw( tags last-tag follow stat );
1210            my $commands_re = join('|',@commands);
1211    
1212            if ($r_url =~ m#/rss(?:/($commands_re.*)\w*(?:=(\d+))?)?#i) {
1213                    my $show = lc($1);
1214                    my $nr = $2;
1215    
1216                    my $type = 'RSS';       # Atom
1217    
1218                    $response->content_type( 'application/' . lc($type) . '+xml' );
1219    
1220                    my $html = '<!-- error -->';
1221                    #warn "create $type feed from ",dump( $cloud->last_tags );
1222    
1223                    my $feed = XML::Feed->new( $type );
1224                    $feed->link( $url );
1225    
1226                    my $rc = RC_OK;
1227    
1228                    if ( $show eq 'tags' ) {
1229                            $nr ||= 50;
1230                            $feed->title( "tags from $CHANNEL" );
1231                            $feed->link( "$url/tags" );
1232                            $feed->description( "tag cloud created from messages on channel $CHANNEL which have tags// in them" );
1233                            my $feed_entry = XML::Feed::Entry->new($type);
1234                            $feed_entry->title( "$nr tags from $CHANNEL" );
1235                            $feed_entry->author( $NICK );
1236                            $feed_entry->link( '/#tags'  );
1237    
1238                            $feed_entry->content(
1239                                    qq{<![CDATA[<style type="text/css">}
1240                                    . $cloud->css
1241                                    . qq{</style>}
1242                                    . $cloud->html( $nr )
1243                                    . qq{]]>}
1244                            );
1245                            $feed->add_entry( $feed_entry );
1246    
1247                    } elsif ( $show eq 'last-tag' ) {
1248    
1249                            $nr ||= $last_x_tags;
1250                            $nr = $last_x_tags if $nr > $last_x_tags;
1251    
1252                            $feed->title( "last $nr tagged messages from $CHANNEL" );
1253                            $feed->description( "collects messages which have tags// in them" );
1254    
1255                            foreach my $m ( $cloud->last_tags ) {
1256    #                               warn dump( $m );
1257                                    #my $tags = join(' ', @{$m->{tags}} );
1258                                    my $feed_entry = XML::Feed::Entry->new($type);
1259                                    $feed_entry->title( $m->{nick} . '@' . $m->{time} );
1260                                    $feed_entry->author( $m->{nick} );
1261                                    $feed_entry->link( '/#' . $m->{id}  );
1262                                    $feed_entry->issued( DateTime::Format::Flexible->build( $m->{time} ) );
1263    
1264                                    my $message = $filter->{message}->( $m->{message} );
1265                                    $message .= "<br/>\n" unless $message =~ m!<(/p|br/?)>!;
1266    #                               warn "## message = $message\n";
1267    
1268                                    #$feed_entry->summary(
1269                                    $feed_entry->content(
1270                                            "<![CDATA[$message]]>"
1271                                    );
1272                                    $feed_entry->category( join(', ', @{$m->{tags}}) );
1273                                    $feed->add_entry( $feed_entry );
1274    
1275                                    $nr--;
1276                                    last if $nr <= 0;
1277    
1278                            }
1279    
1280                    } elsif ( $show =~ m/^follow/ ) {
1281    
1282                            $feed->title( "Feeds which this bot follows" );
1283    
1284                            my $sth = $dbh->prepare( qq{ select * from feeds order by last_update desc } );
1285                            $sth->execute;
1286                            while (my $row = $sth->fetchrow_hashref) {
1287                                    my $feed_entry = XML::Feed::Entry->new($type);
1288                                    $feed_entry->title( $row->{name} );
1289                                    $feed_entry->link( $row->{url}  );
1290                                    $feed_entry->issued( DateTime::Format::Flexible->build( $row->{last_update} ) );
1291                                    $feed_entry->content(
1292                                            '<![CDATA[<pre>' . dump( $row ) . '</pre>]]>'
1293                                    );
1294                                    $feed->add_entry( $feed_entry );
1295                            }
1296    
1297                    } elsif ( $show =~ m/^stat/ ) {
1298    
1299                            my $feed_entry = XML::Feed::Entry->new($type);
1300                            $feed_entry->title( "Internal stats" );
1301                            $feed_entry->content(
1302                                    '<![CDATA[<pre>' . dump( $_stat ) . '</pre>]]>'
1303                            );
1304                            $feed->add_entry( $feed_entry );
1305    
1306                    } else {
1307                            _log "WEB unknown rss request $r_url";
1308                            $feed->title( "unknown $r_url" );
1309                            foreach my $c ( @commands ) {
1310                                    my $feed_entry = XML::Feed::Entry->new($type);
1311                                    $feed_entry->title( "rss/$c" );
1312                                    $feed_entry->link( "$url/rss/$c" );
1313                                    $feed->add_entry( $feed_entry );
1314                            }
1315                            $rc = RC_DENY;
1316                    }
1317    
1318                    eval { $response->content( $feed->as_xml ); };
1319                    $rc = RC_INTERNAL_SERVER_ERROR if $@;
1320                    return $rc;
1321            }
1322    
1323            if ( $@ ) {
1324                    warn "$@";
1325            }
1326    
1327          $response->content(          $response->content_type("text/html; charset=UTF-8");
1328                  qq{<html><head><title>$NICK</title><style type="text/css">$style</style></head><body>  
1329                  <form method="post" class="search">          my $html =
1330                    qq{<html><head><title>$NICK</title><style type="text/css">$style}
1331                    . $cloud->css
1332                    . qq{</style></head><body>}
1333                    . qq{
1334                    <form method="post" class="search" action="/">
1335                  <input type="text" name="search" value="$search" size="10">                  <input type="text" name="search" value="$search" size="10">
1336                  <input type="submit" value="search">                  <input type="submit" value="search">
1337                  </form>                  </form>
1338                  <p>                  }
1339                  } .                  . $cloud->html(500)
1340                  join("</p><p>",                  . qq{<p>};
1341    
1342            if ($request->url =~ m#/tags?#) {
1343                    # nop
1344            } elsif ($request->url =~ m#/history#) {
1345                    my $sth = $dbh->prepare(qq{
1346                            select date(time) as date,count(*) as nr,sum(length(message)) as len
1347                                    from log
1348                                    group by date(time)
1349                                    order by date(time) desc
1350                    });
1351                    $sth->execute();
1352                    my ($l_yyyy,$l_mm) = (0,0);
1353                    $html .= qq{<table class="calendar"><tr>};
1354                    my $cal;
1355                    my $ord = 0;
1356                    while (my $row = $sth->fetchrow_hashref) {
1357                            # this is probably PostgreSQL specific, expects ISO date
1358                            my ($yyyy,$mm,$dd) = split(/-/, $row->{date});
1359                            if ($yyyy != $l_yyyy || $mm != $l_mm) {
1360                                    if ( $cal ) {
1361                                            $html .= qq{<td valign="top">} . $cal->as_HTML() . qq{</td>};
1362                                            $ord++;
1363                                            $html .= qq{</tr><tr>} if ( $ord % 3 == 0 );
1364                                    }
1365                                    $cal = new HTML::CalendarMonthSimple('month'=>$mm,'year'=>$yyyy);
1366                                    $cal->border(1);
1367                                    $cal->width('30%');
1368                                    $cal->cellheight('5em');
1369                                    $cal->tableclass('month');
1370                                    #$cal->cellclass('day');
1371                                    $cal->sunday('SUN');
1372                                    $cal->saturday('SAT');
1373                                    $cal->weekdays('MON','TUE','WED','THU','FRI');
1374                                    ($l_yyyy,$l_mm) = ($yyyy,$mm);
1375                            }
1376                            $cal->setcontent($dd, qq[
1377                                    <a href="$url?date=$row->{date}">$row->{nr}</a><br/>$row->{len}
1378                            ]) if $cal;
1379                            
1380                    }
1381                    $html .= qq{<td valign="top">} . $cal->as_HTML() . qq{</td></tr></table>};
1382    
1383            } else {
1384                    $html .= join("</p><p>",
1385                          get_from_log(                          get_from_log(
1386                                  limit => $q->param('limit') || 100,                                  limit => ( $q->param('date') ? undef : $q->param('last') || 100 ),
1387                                  search => $q->param('search') || $q->param('grep') || undef,                                  search => $search || undef,
1388                                    tag => $q->param('tag') || undef,
1389                                    date => $q->param('date') || undef,
1390                                  fmt => {                                  fmt => {
1391                                            date => sub {
1392                                                    my $date = shift || return;
1393                                                    qq{<hr/><div class="date"><a href="$url?date=$date">$date</a></div>};
1394                                            },
1395                                          time => '<span class="time">%s</span> ',                                          time => '<span class="time">%s</span> ',
1396                                          time_channel => '<span class="channel">%s %s</span> ',                                          time_channel => '<span class="channel">%s %s</span> ',
1397                                          nick => '%s:&nbsp;',                                          nick => '%s:&nbsp;',
1398                                          me_nick => '***%s&nbsp;',                                          me_nick => '***%s&nbsp;',
1399                                          message => '<span class="message">%s</span>',                                          message => '<span class="message">%s</span>',
1400                                  },                                  },
1401                                  filter => {                                  filter => $filter,
                                         message => sub {  
                                                 my $m = shift || return;  
                                                 $m =~ s/($escape_re)/$escape{$1}/gs;  
                                                 $m =~ s#($RE{URI}{HTTP})#<a href="$1">$1</a>#gs;  
                                                 return $m;  
                                         },  
                                         nick => sub {  
                                                 my $n = shift || return;  
                                                 if (! $nick_enumerator{$n})  {  
                                                         my $max = scalar keys %nick_enumerator;  
                                                         $nick_enumerator{$n} = $max + 1;  
                                                 }  
                                                 return '<span class="nick col-' .  
                                                         ( $nick_enumerator{$n} % $max_color ) .  
                                                         '">' . $n . '</span>';  
                                         },  
                                 },  
1402                          )                          )
1403                  ) .                  );
1404                  qq{</p></body></html>}          }
1405          );  
1406            $html .= qq{</p>
1407            <hr/>
1408            <p>See <a href="/history">history</a> of all messages.</p>
1409            </body></html>};
1410    
1411            $response->content( $html );
1412            warn "<< ", $request->method, " ", $request->uri, " created ", length($html), " bytes\n";
1413          return RC_OK;          return RC_OK;
1414  }  }
1415    
1416  POE::Kernel->run;  POE::Kernel->run;
1417    
1418    =head1 TagCloud
1419    
1420    Extended L<HTML::TagCloud>
1421    
1422    =cut
1423    
1424    package TagCloud;
1425    use warnings;
1426    use strict;
1427    use HTML::TagCloud;
1428    use base 'HTML::TagCloud';
1429    use Data::Dump qw/dump/;
1430    
1431    =head2 html
1432    
1433    Generate html with number of tags in title of link
1434    
1435    =cut
1436    
1437    sub html {
1438            my($self, $limit) = @_;
1439            my @tags=$self->tags($limit);
1440    
1441            my $ntags = scalar(@tags);
1442            if ($ntags == 0) {
1443                    return "";
1444    #       } elsif ($ntags == 1) {
1445    #               my $tag = $tags[0];
1446    #               return qq{<div id="htmltagcloud"><span class="tagcloud1"><a href="}.
1447    #               $tag->{url}.qq{">}.$tag->{name}.qq{</a></span></div>\n};
1448            }
1449    
1450      my $html = qq{<div id="htmltagcloud">};
1451      foreach my $tag ( sort { lc($a->{name}) cmp lc($b->{name}) } @tags) {
1452        $html .=  sprintf(qq{<span class="tag tagcloud%d"><a href="%s" title="%s">%s</a></span>\n},
1453                    $tag->{level}, $tag->{url}, $tag->{count}, $tag->{name}
1454            );
1455      }
1456      $html .= qq{</div>};
1457      return $html;
1458    }
1459    
1460    =head2 last_tags
1461    
1462      my @tags = $cloud->last_tags;
1463    
1464    =cut
1465    
1466    my @last_tags;
1467    sub last_tags {
1468            return @last_tags;
1469    }
1470    
1471    =head2 add_tag
1472    
1473     $cloud->add_tag( id => 42, message => 'irc message', nick => 'foobar' [, me => 1 ] );
1474    
1475    =cut
1476    
1477    
1478    sub add_tag {
1479            my $self = shift;
1480            my $arg = {@_};
1481    
1482            return unless ($arg->{id} && $arg->{message});
1483    
1484            my $m = $arg->{message};
1485    
1486            my @tags;
1487    
1488            while ($m =~ s#$tag_regex##s) {
1489                    my $tag = $1;
1490                    next if (! $tag || $tag =~ m/https?:/i);
1491                    push @{ $tags->{$tag} }, $arg->{id};
1492                    #warn "+tag $tag: $arg->{id}\n";
1493                    $self->add($tag, "$url?tag=$tag", scalar @{$tags->{$tag}});
1494                    push @tags, $tag;
1495    
1496            }
1497    
1498            if ( @tags ) {
1499                    pop @last_tags if $#last_tags == $last_x_tags;
1500                    unshift @last_tags, { tags => [ @tags ], %$arg };
1501            }
1502    
1503    }
1504    
1505    =head2 seed_tags
1506    
1507    Read all tags from database and create in-memory cache for tags
1508    
1509    =cut
1510    
1511    sub seed_tags {
1512            my $self = shift;
1513            my $sth = $dbh->prepare(qq{ select id,message,nick,me,time from log where message like '%//%' order by time asc });
1514            $sth->execute;
1515            while (my $row = $sth->fetchrow_hashref) {
1516                    $self->add_tag( %$row );
1517            }
1518    
1519            foreach my $tag (keys %$tags) {
1520                    $self->add($tag, "$url?tag=$tag", scalar @{$tags->{$tag}});
1521            }
1522    }
1523    
Legend:
Removed from v.20  
changed lines
  Added in v.147
  ViewVC Help
Powered by ViewVC 1.1.26