/[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

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