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