/[irc-logger]/trunk/bin/irc-logger.pl
This is repository of my old source code which isn't updated any more. Go to git.rot13.org for current projects!
ViewVC logotype

Diff of /trunk/bin/irc-logger.pl

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

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