/[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 71 by dpavlin, Sun Dec 16 18:51:05 2007 UTC revision 132 by dpavlin, Tue Apr 1 19:04:32 2008 UTC
# Line 2  Line 2 
2  use strict;  use strict;
3  $|++;  $|++;
4    
5    use POE qw(Component::IRC Component::Server::HTTP Component::Client::HTTP);
6    use HTTP::Status;
7    use DBI;
8    use Regexp::Common qw /URI/;
9    use CGI::Simple;
10    use HTML::TagCloud;
11    use POSIX qw/strftime/;
12    use HTML::CalendarMonthSimple;
13    use Getopt::Long;
14    use DateTime;
15    use URI::Escape;
16    use Data::Dump qw/dump/;
17    use DateTime::Format::ISO8601;
18    use Carp qw/confess/;
19    use XML::Feed;
20    use DateTime::Format::Flexible;
21    use Encode;
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  my $http_port = $NICK =~ m/-dev/ ? 8001 : 8000;  # number of last tags to keep in circular buffer
92  my $http_hostname = `hostname`;  my $last_x_tags = 50;
 chomp( $http_hostname );  
93    
94  ## END CONFIG  # don't pull rss feeds more often than this
95    my $rss_min_delay = 60;
96    
97    my $http_port = $NICK =~ m/-dev/ ? 8001 : 8000;
98    
99    my $url = "http://$HOSTNAME:$http_port";
100    
101  use POE qw(Component::IRC Wheel::FollowTail Component::Server::HTTP);  ## END CONFIG
 use HTTP::Status;  
 use DBI;  
 use Encode qw/from_to is_utf8/;  
 use Regexp::Common qw /URI/;  
 use CGI::Simple;  
 use HTML::TagCloud;  
 use POSIX qw/strftime/;  
 use HTML::CalendarMonthSimple;  
 use Getopt::Long;  
 use DateTime;  
 use URI::Escape;  
 use Data::Dump qw/dump/;  
 use DateTime::Format::ISO8601;  
 use Carp qw/confess/;  
 use XML::Feed;  
 use DateTime::Format::Flexible;  
102    
103  my $use_twitter = 1;  my $use_twitter = 1;
104  eval { require Net::Twitter; };  eval { require Net::Twitter; };
# Line 93  my $log_path; Line 109  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  $SIG{__DIE__} = sub {  #$SIG{__DIE__} = sub {
116          confess "fatal error";  #       confess "fatal error";
117  };  #};
   
 open(STDOUT, '>', $log_path) || warn "can't redirect log to $log_path: $!";  
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  # HTML formatters
127    
128  my %escape = ('<'=>'&lt;', '>'=>'&gt;', '&'=>'&amp;', '"'=>'&quot;');  my %escape = ('<'=>'&lt;', '>'=>'&gt;', '&'=>'&amp;', '"'=>'&quot;');
# Line 122  my $filter = { Line 140  my $filter = {
140                  # protect HTML from wiki modifications                  # protect HTML from wiki modifications
141                  sub e {                  sub e {
142                          my $t = shift;                          my $t = shift;
143                          return 'uri_unescape{' . uri_escape($t) . '}';                          return 'uri_unescape{' . uri_escape($t, '^a-zA-Z0-9') . '}';
144                  }                  }
145    
146                  $m =~ s/($escape_re)/$escape{$1}/gs;                  $m =~ s/($escape_re)/$escape{$1}/gs;
147                  $m =~ s#($RE{URI}{HTTP})#e(qq{<a href="$1">$1</a>})#egs ||                  $m =~ s#($RE{URI}{HTTP})#e(qq{<a href="$1">$1</a>})#egs;
148                  $m =~ s#\/(\w+)\/#<i>$1</i>#gs;                  $m =~ s#\/(\w+)\/#<i>$1</i>#gs;
149                  $m =~ s#$tag_regex#e(qq{<a href="?tag=$1" class="tag">$1</a>})#egs;                  $m =~ s#$tag_regex#e(qq{<a href="$url?tag=$1" class="tag">$1</a>})#egs;
150                  $m =~ s#\*(\w+)\*#<b>$1</b>#gs;                  $m =~ s#\*(\w+)\*#<b>$1</b>#gs;
151                  $m =~ s#_(\w+)_#<u>$1</u>#gs;                  $m =~ s#_(\w+)_#<u>$1</u>#gs;
152    
# Line 147  my $filter = { Line 165  my $filter = {
165          },          },
166  };  };
167    
168    # POE IRC
169    my $poe_irc = POE::Component::IRC->spawn( %$irc_config ) or
170            die "can't start ", dump( $irc_config ), ": $!";
171    
172    my $irc = $poe_irc->session_id();
173    _log "IRC session_id $irc";
174    
175  my $dbh = DBI->connect($DSN,"","", { RaiseError => 1, AutoCommit => 1 }) || die $DBI::errstr;  my $dbh = DBI->connect($DSN,"","", { RaiseError => 1, AutoCommit => 1 }) || die $DBI::errstr;
176    $dbh->do( qq{ set client_encoding = 'UTF-8' } );
177    
178  my $sql_schema = {  my $sql_schema = {
179          log => '          log => qq{
180  create table log (  create table log (
181          id serial,          id serial,
182          time timestamp default now(),          time timestamp default now(),
# Line 164  create table log ( Line 190  create table log (
190  create index log_time on log(time);  create index log_time on log(time);
191  create index log_channel on log(channel);  create index log_channel on log(channel);
192  create index log_nick on log(nick);  create index log_nick on log(nick);
193          ',          },
194          meta => '          meta => q{
195  create table meta (  create table meta (
196          nick text not null,          nick text not null,
197          channel text not null,          channel text not null,
198          name text not null,          name text not null,
199          value text,          value text,
200          changed timestamp default now(),          changed timestamp default 'now()',
201          primary key(nick,channel,name)          primary key(nick,channel,name)
202  );  );
203          ',          },
204            feeds => qq{
205    create table feeds (
206            id serial,
207            url text not null,
208            name text,
209            delay interval not null default '5 min',
210            active boolean default true,
211            channel text not null,
212            nick text not null,
213            private boolean default false,
214            last_update timestamp default 'now()',
215            polls int default 0,
216            updates int default 0
217    );
218    create unique index feeds_url on feeds(url);
219    insert into feeds (url,name,channel,nick) values ('http://wiki.razmjenavjestina.org/feed/workspace/razmjenavjestina?category=Recent%20Changes','wiki','$CHANNEL','dpavlin');
220            },
221  };  };
222    
223  foreach my $table ( keys %$sql_schema ) {  foreach my $table ( keys %$sql_schema ) {
# Line 217  sub meta { Line 260  sub meta {
260                  if ( $@ || ! $sth->rows ) {                  if ( $@ || ! $sth->rows ) {
261                          $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()) });
262                          $sth->execute( $value, $nick, $channel, $name );                          $sth->execute( $value, $nick, $channel, $name );
263                          _log "created $nick/$channel/$name = $value";                          warn "## created $nick/$channel/$name = $value\n";
264                  } else {                  } else {
265                          _log "updated $nick/$channel/$name = $value ";                          warn "## updated $nick/$channel/$name = $value\n";
266                  }                  }
267    
268                  return $value;                  return $value;
# Line 229  sub meta { Line 272  sub meta {
272                  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 = ? });
273                  $sth->execute( $nick, $channel, $name );                  $sth->execute( $nick, $channel, $name );
274                  my ($v,$c) = $sth->fetchrow_array;                  my ($v,$c) = $sth->fetchrow_array;
275                  _log "fetched $nick/$channel/$name = $v [$c]";                  warn "## fetched $nick/$channel/$name = $v [$c]\n";
276                  return ($v,$c) if wantarray;                  return ($v,$c) if wantarray;
277                  return $v;                  return $v;
278    
# Line 238  sub meta { Line 281  sub meta {
281    
282    
283    
284  my $sth = $dbh->prepare(qq{  my $sth_insert_log = $dbh->prepare(qq{
285  insert into log  insert into log
286          (channel, me, nick, message, time)          (channel, me, nick, message, time)
287  values (?,?,?,?,?)  values (?,?,?,?,?)
# Line 326  sub get_from_log { Line 369  sub get_from_log {
369    
370          my @where;          my @where;
371          my @args;          my @args;
372            my $msg;
373    
374          if (my $search = $args->{search}) {          if (my $search = $args->{search}) {
375                  $search =~ s/^\s+//;                  $search =~ s/^\s+//;
376                  $search =~ s/\s+$//;                  $search =~ s/\s+$//;
377                  push @where, 'message ilike ? or nick ilike ?';                  push @where, 'message ilike ? or nick ilike ?';
378                  push @args, ( ( '%' . $search . '%' ) x 2 );                  push @args, ( ( '%' . $search . '%' ) x 2 );
379                  _log "search for '$search'";                  $msg = "Search for '$search'";
380          }          }
381    
382          if ($args->{tag} && $tags->{ $args->{tag} }) {          if ($args->{tag} && $tags->{ $args->{tag} }) {
383                  push @where, 'id in (' . join(',', @{ $tags->{ $args->{tag} } }) . ')';                  push @where, 'id in (' . join(',', @{ $tags->{ $args->{tag} } }) . ')';
384                  _log "search for tags $args->{tag}";                  $msg = "Search for tags $args->{tag}";
385          }          }
386    
387          if (my $date = $args->{date} ) {          if (my $date = $args->{date} ) {
388                  $date = check_date( $date );                  $date = check_date( $date );
389                  push @where, 'date(time) = ?';                  push @where, 'date(time) = ?';
390                  push @args, $date;                  push @args, $date;
391                  _log "search for date $date";                  $msg = "search for date $date";
392          }          }
393    
394          $sql .= " where " . join(" and ", @where) if @where;          $sql .= " where " . join(" and ", @where) if @where;
# Line 358  sub get_from_log { Line 402  sub get_from_log {
402          eval { $sth->execute( @args ) };          eval { $sth->execute( @args ) };
403          return if $@;          return if $@;
404    
405            my $nr_results = $sth->rows;
406    
407          my $last_row = {          my $last_row = {
408                  date => '',                  date => '',
409                  time => '',                  time => '',
# Line 378  sub get_from_log { Line 424  sub get_from_log {
424    
425          return @rows if ($args->{full_rows});          return @rows if ($args->{full_rows});
426    
427          my @msgs = (          $msg .= ' produced ' . (
428                  "Showing " . ($#rows + 1) . " messages..."                  $nr_results == 0 ? 'no results' :
429                    $nr_results == 0 ? 'one result' :
430                            $nr_results . ' results'
431          );          );
432    
433            my @msgs = ( $msg );
434    
435          if ($context) {          if ($context) {
436                  my @ids = @rows;                  my @ids = @rows;
437                  @rows = ();                  @rows = ();
# Line 438  sub get_from_log { Line 488  sub get_from_log {
488  #                       $row->{nick} = $nick;  #                       $row->{nick} = $nick;
489  #               }  #               }
490    
491                    $append = 0 if $row->{me};
492    
493                  if ($last_row->{nick} ne $nick) {                  if ($last_row->{nick} ne $nick) {
494                          # 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
495                          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 482  my $cloud = HTML::TagCloud->new; Line 534  my $cloud = HTML::TagCloud->new;
534    
535  =cut  =cut
536    
 my $last_x_tags = 5;  
537  my @last_tags;  my @last_tags;
538    
539  sub add_tag {  sub add_tag {
# Line 491  sub add_tag { Line 542  sub add_tag {
542          return unless ($arg->{id} && $arg->{message});          return unless ($arg->{id} && $arg->{message});
543    
544          my $m = $arg->{message};          my $m = $arg->{message};
         from_to('UTF-8', 'iso-8859-2', $m) if (is_utf8($m));  
545    
546          my @tags;          my @tags;
547    
# Line 500  sub add_tag { Line 550  sub add_tag {
550                  next if (! $tag || $tag =~ m/https?:/i);                  next if (! $tag || $tag =~ m/https?:/i);
551                  push @{ $tags->{$tag} }, $arg->{id};                  push @{ $tags->{$tag} }, $arg->{id};
552                  #warn "+tag $tag: $arg->{id}\n";                  #warn "+tag $tag: $arg->{id}\n";
553                  $cloud->add($tag, "?tag=$tag", scalar @{$tags->{$tag}} + 1);                  $cloud->add($tag, "$url?tag=$tag", scalar @{$tags->{$tag}} + 1);
554                  push @tags, $tag;                  push @tags, $tag;
555    
556          }          }
557    
558          if ( @tags ) {          if ( @tags ) {
559                  shift @last_tags if $#last_tags == $last_x_tags;                  pop @last_tags if $#last_tags == $last_x_tags;
560                  push @last_tags, { tags => [ @tags ], %$arg };                  unshift @last_tags, { tags => [ @tags ], %$arg };
561          }          }
562    
563  }  }
# Line 519  Read all tags from database and create i Line 569  Read all tags from database and create i
569  =cut  =cut
570    
571  sub seed_tags {  sub seed_tags {
572          my $sth = $dbh->prepare(qq{ select id,message,nick,me,time from log where message like '%//%' });          my $sth = $dbh->prepare(qq{ select id,message,nick,me,time from log where message like '%//%' order by time asc });
573          $sth->execute;          $sth->execute;
574          while (my $row = $sth->fetchrow_hashref) {          while (my $row = $sth->fetchrow_hashref) {
575                  add_tag( %$row );                  add_tag( %$row );
576          }          }
577    
578          foreach my $tag (keys %$tags) {          foreach my $tag (keys %$tags) {
579                  $cloud->add($tag, "?tag=$tag", scalar @{$tags->{$tag}} + 1);                  $cloud->add($tag, "$url?tag=$tag", scalar @{$tags->{$tag}} + 1);
580          }          }
581  }  }
582    
# Line 555  sub save_message { Line 605  sub save_message {
605          $a->{me} ||= 0;          $a->{me} ||= 0;
606          $a->{time} ||= strftime($TIMESTAMP,localtime());          $a->{time} ||= strftime($TIMESTAMP,localtime());
607    
608          _log          _log "ARCHIVE",
609                  $a->{channel}, " ",                  $a->{channel}, " ",
610                  $a->{me} ? "***" . $a->{nick} : "<" . $a->{nick} . ">",                  $a->{me} ? "***" . $a->{nick} : "<" . $a->{nick} . ">",
611                  " " . $a->{message};                  " " . $a->{message};
612    
613          from_to($a->{message}, 'UTF-8', $ENCODING);          eval { $sth_insert_log->execute($a->{channel}, $a->{me}, $a->{nick}, $a->{message}, $a->{time}); };
614            _log "ERROR: can't archive ", $a->{message} if $@;
         $sth->execute($a->{channel}, $a->{me}, $a->{nick}, $a->{message}, $a->{time});  
615          add_tag( id => $dbh->last_insert_id(undef,undef,"log",undef), %$a );          add_tag( id => $dbh->last_insert_id(undef,undef,"log",undef), %$a );
616  }  }
617    
# Line 601  if ($import_dircproxy) { Line 650  if ($import_dircproxy) {
650          exit;          exit;
651  }  }
652    
   
653  #  #
654  # POE handing part  # RSS follow
655  #  #
656    
657  my $SKIPPING = 0;               # if skipping, how many we've done  my $_stat;
658  my $SEND_QUEUE;                 # cache  
659  my $ping;                                               # ping stats  POE::Component::Client::HTTP->spawn(
660            Alias   => 'rss-fetch',
661  POE::Component::IRC->new($IRC_ALIAS);          Timeout => 30,
662    );
663  POE::Session->create( inline_states =>  
664     {_start => sub {        =head2 rss_parse_xml
665                  $_[KERNEL]->post($IRC_ALIAS => register => 'all');  
666                  $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);    rss_parse_xml({
667      },          url => 'http://www.example.com/rss',
668      irc_255 => sub {    # server is done blabbing          send_rss_msgs => 42,
669                  $_[KERNEL]->post($IRC_ALIAS => join => $CHANNEL);    });
670                  $_[KERNEL]->post($IRC_ALIAS => join => '#logger');  
671                  $_[KERNEL]->yield("heartbeat"); # start heartbeat  =cut
672  #               $_[KERNEL]->yield("my_add", $_) for keys %FOLLOWS;  
673                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );  sub rss_parse_xml {
674            my ($kernel,$args) = @_;
675    
676            warn "## rss_parse_xml ",dump( $args ) if $debug;
677    
678            # how many messages to send out when feed is seen for the first time?
679            my $send_rss_msgs = $args->{send_rss_msgs};
680            $send_rss_msgs = 1 if ! defined $send_rss_msgs;
681    
682            warn "## RSS fetch first $send_rss_msgs items from", $args->{url} if $debug;
683    
684            my $feed = XML::Feed->parse( \$args->{xml} );
685            if ( ! $feed ) {
686                    _log "can't fetch RSS ", $args->{url}, XML::Feed->errstr;
687                    return;
688            }
689    
690            $_stat->{rss}->{url2link}->{ $args->{url} } = $feed->link;
691    
692            my ( $total, $updates ) = ( 0, 0 );
693            for my $entry ($feed->entries) {
694                    $total++;
695    
696                    my $seen_times = $_stat->{rss}->{seen}->{$args->{channel}}->{$feed->link}->{$entry->id}++;
697                    # seen allready?
698                    warn "## $seen_times ",$entry->id if $debug;
699                    next if $seen_times > 0;
700    
701                    sub prefix {
702                            my ($txt,$var) = @_;
703                            $var =~ s/\s+/ /gs;
704                            $var =~ s/^\s+//g;
705                            $var =~ s/\s+$//g;
706                            return $txt . $var if $var;
707                    }
708    
709                    # fix absolute and relative links to feed entries
710                    my $link = $entry->link;
711                    if ( $link =~ m!^/! ) {
712                            my $host = $args->{url};
713                            $host =~ s!^(http://[^/]+).*$!$1!;      #!vim
714                            $link = "$host/$link";
715                    } elsif ( $link !~ m!^http! ) {
716                            $link = $args->{url} . $link;
717                    }
718    
719                    my $msg;
720                    $msg .= prefix( 'From: ' , $args->{name} || $feed->title );
721                    $msg .= prefix( ' by ' , $entry->author );
722                    $msg .= prefix( ' | ' , $entry->title );
723                    $msg .= prefix( ' | ' , $link );
724    #               $msg .= prefix( ' id ' , $entry->id );
725                    my @categories = $entry->category;
726                    warn "## category = ", dump( @categories ) if $debug;
727                    if ( my $tags = $entry->category ) {
728                            $tags = join(' ', @$tags) if ref($tags) eq 'ARRAY';
729                            $tags =~ s!^\s+!!;
730                            $tags =~ s!\s*$! !;
731                            $tags =~ s!,?\s+!// !g;
732                            $msg .= prefix( ' ' , $tags );
733                    }
734    
735                    if ( $seen_times == 0 && $send_rss_msgs ) {
736                            $send_rss_msgs--;
737                            if ( ! $args->{private} ) {
738                                    # FIXME bug! should be save_message
739                                    save_message( channel => $args->{channel}, me => 1, nick => $NICK, message => $msg );
740    #                               $sth_insert_log->execute( $args->{channel}, 1, $NICK, $msg, 'now()' );
741                            }
742                            my ( $type, $to ) = ( 'notice', $args->{channel} );
743                            ( $type, $to ) = ( 'privmsg', $args->{nick} ) if $args->{private};
744    
745                            _log(">> RSS $type to $to:", $msg);
746                            $kernel->post( $irc => $type => $to => $msg );
747    
748                            $updates++;
749                    }
750            }
751    
752            my $sql = qq{ update feeds set last_update = now(), polls = polls + 1 };
753            $sql .= qq{, updates = updates + $updates } if $updates;
754            $sql .= qq{where id = } . $args->{id};
755            eval { $dbh->do( $sql ) };
756    
757            _log "RSS $updates/$total new items from", $args->{url};
758    
759            return $updates;
760    }
761    
762    sub rss_fetch_all {
763            my ( $kernel, $send_rss_msgs )  = @_;
764            warn "## rss_fetch_all -- send_rss_msgs: $send_rss_msgs\n" if $debug;
765            my $sql = qq{
766                    select id, url, name, channel, nick, private
767                    from feeds
768                    where active is true
769            };
770            # limit to newer feeds only if we are not sending messages out
771            $sql .= qq{     and last_update + delay < now() } if defined ( $_stat->{rss}->{fetch} );
772            my $sth = $dbh->prepare( $sql );
773            $sth->execute();
774            warn "# ",$sth->rows," active RSS feeds\n";
775            my $count = 0;
776            while (my $row = $sth->fetchrow_hashref) {
777                    $row->{send_rss_msgs} = $send_rss_msgs if defined $send_rss_msgs;
778                    $_stat->{rss}->{fetch}->{ $row->{url} } = $row;
779                    $kernel->post(
780                            'rss-fetch',
781                            'request',
782                            'rss_response',
783                            HTTP::Request->new( GET => $row->{url} ),
784                    );
785                    warn "## queued rss-fetch ", dump( $row ) if $debug;
786            }
787            return "OK, scheduled " . $sth->rows . " feeds for refresh";
788    }
789    
790    
791    sub rss_check_updates {
792            my $kernel = shift;
793            $_stat->{rss}->{last_poll} ||= time();
794            my $dt = time() - $_stat->{rss}->{last_poll};
795            if ( $dt > $rss_min_delay ) {
796                    warn "## rss_check_updates $dt > $rss_min_delay\n";
797                    $_stat->{rss}->{last_poll} = time();
798                    _log rss_fetch_all( $kernel );
799            }
800    }
801    
802    sub process_command {
803            my ( $kernel, $nick, $channel, $msg ) = @_;
804    
805            my $res = "unknown command '$msg', try /msg $NICK help!";
806    
807            if ($msg =~ m/^help/i) {
808    
809                    $res = "usage: /msg $NICK comand | commands: stat - user/message stat | last - show backtrace | grep foobar - find foobar";
810    
811            } elsif ($msg =~ m/^(privmsg|notice)\s+(\S+)\s+(.*)$/i) {
812    
813                    _log ">> /$1 $2 $3";
814                    $kernel->post( $irc => $1 => $2, $3 );
815                    $res = '';
816    
817            } elsif ($msg =~ m/^stat.*?\s*(\d*)/i) {
818    
819                    my $nr = $1 || 10;
820    
821                    my $sth = $dbh->prepare(qq{
822                            select
823                                    trim(both '_' from nick) as nick,
824                                    count(*) as count,
825                                    sum(length(message)) as len
826                            from log
827                            group by trim(both '_' from nick)
828                            order by len desc,count desc
829                            limit $nr
830                    });
831                    $sth->execute();
832                    $res = "Top $nr users: ";
833                    my @users;
834                    while (my $row = $sth->fetchrow_hashref) {
835                            push @users,$row->{nick} . ': ' . $row->{count} . '/' . $row->{len} . '=' . sprintf("%.2f", $row->{len}/$row->{count});
836                    }
837                    $res .= join(" | ", @users);
838            } elsif ($msg =~ m/^last.*?\s*(\d*)/i) {
839    
840                    my $limit = $1 || meta( $nick, $channel, 'last-size' ) || 10;
841    
842                    foreach my $res (get_from_log( limit => $limit )) {
843                            _log "last: $res";
844                            $kernel->post( $irc => privmsg => $nick, $res );
845                    }
846    
847                    $res = '';
848    
849            } elsif ($msg =~ m/^(search|grep)\s+(.*)\s*$/i) {
850    
851                    my $what = $2;
852    
853                    foreach my $res (get_from_log(
854                                    limit => 20,
855                                    search => $what,
856                            )) {
857                            _log "search [$what]: $res";
858                            $kernel->post( $irc => privmsg => $nick, $res );
859                    }
860    
861                    $res = '';
862    
863            } elsif ($msg =~ m/^(?:count|poll)\s+(.*)(?:\s+(\d+))?\s*$/i) {
864    
865                    my ($what,$limit) = ($1,$2);
866                    $limit ||= 100;
867    
868                    my $stat;
869    
870                    foreach my $res (get_from_log(
871                                    limit => $limit,
872                                    search => $what,
873                                    full_rows => 1,
874                            )) {
875                            while ($res->{message} =~ s/\Q$what\E(\+|\-)//) {
876                                    $stat->{vote}->{$1}++;
877                                    $stat->{from}->{ $res->{nick} }++;
878                            }
879                    }
880    
881                    my @nicks;
882                    foreach my $nick (sort { $stat->{from}->{$a} <=> $stat->{from}->{$b} } keys %{ $stat->{from} }) {
883                            push @nicks, $nick . ( $stat->{from}->{$nick} == 1 ? '' :
884                                    "(" . $stat->{from}->{$nick} . ")"
885                            );
886                    }
887    
888                    $res =
889                            "$what ++ " . ( $stat->{vote}->{'+'} || 0 ) .
890                            " : " . ( $stat->{vote}->{'-'} || 0 ) . " --" .
891                            " from " . ( join(", ", @nicks) || 'nobody' );
892    
893                    $kernel->post( $irc => notice => $nick, $res );
894    
895            } elsif ($msg =~ m/^ping/) {
896                    $res = "ping = " . dump( $_stat->{ping} );
897            } elsif ($msg =~ m/^conf(?:ig)*\s*(last-size|twitter)*\s*(.*)/) {
898                    if ( ! defined( $1 ) ) {
899                            my $sth = $dbh->prepare(qq{ select name,value,changed from meta where nick = ? and channel = ? });
900                            $sth->execute( $nick, $channel );
901                            $res = "config for $nick on $channel";
902                            while ( my ($n,$v) = $sth->fetchrow_array ) {
903                                    $res .= " | $n = $v";
904                            }
905                    } elsif ( ! $2 ) {
906                            my $val = meta( $nick, $channel, $1 );
907                            $res = "current $1 = " . ( $val ? $val : 'undefined' );
908                    } else {
909                            my $validate = {
910                                    'last-size' => qr/^\d+/,
911                                    'twitter' => qr/^\w+\s+\w+/,
912                            };
913    
914                            my ( $op, $val ) = ( $1, $2 );
915    
916                            if ( my $regex = $validate->{$op} ) {
917                                    if ( $val =~ $regex ) {
918                                            meta( $nick, $channel, $op, $val );
919                                            $res = "saved $op = $val";
920                                    } else {
921                                            $res = "config option $op = $val doesn't validate against $regex";
922                                    }
923                            } else {
924                                    $res = "config option $op doesn't exist";
925                            }
926                    }
927            } elsif ($msg =~ m/^rss-update/) {
928                    $res = rss_fetch_all( $kernel );
929            } elsif ($msg =~ m/^rss-list/) {
930                    my $sth = $dbh->prepare(qq{ select url,name,last_update,active,channel,nick,private from feeds });
931                    $sth->execute;
932                    while (my @row = $sth->fetchrow_array) {
933                            $kernel->post( $irc => privmsg => $nick, join(' | ',@row) );
934                    }
935                    $res = '';
936            } elsif ($msg =~ m!^rss-(add|remove|stop|start|clean)(?:-(private))?\s+(http://\S+)\s*(.*)!) {
937                    my ( $command, $sub, $url, $arg ) = ( $1,$2,$3,$4 );
938    
939                    my $channel = $1 if ( $arg =~ s/\s*(#\S+)\s*// );
940                    $channel = $nick if $sub eq 'private';
941    
942                    my $sql = {
943                            add     => qq{ insert into feeds (url,name,channel,nick,private) values (?,?,?,?,?) },
944                            remove  => qq{ delete from feeds                                where url = ? and nick = ? },
945                            start   => qq{ update feeds set active = true   where url = ? },
946                            stop    => qq{ update feeds set active = false  where url = ? },
947                            clean   => qq{ update feeds set last_update = now() - delay where url = ? },
948                    };
949    
950                    if ( $command eq 'add' && ! $channel ) {
951                            $res = "ERROR: got '$msg' which doesn't have #channel in it, ignoring!";
952                    } elsif (my $q = $sql->{$command} ) {
953                            my $sth = $dbh->prepare( $q );
954                            my @data = ( $url );
955                            if ( $command eq 'add' ) {
956                                    push @data, ( $arg, $channel, $nick, $sub eq 'private' ? 1 : 0 );
957                            } elsif ( $command eq 'remove' ) {
958                                    push @data, $nick;
959                            }
960                            warn "## $command SQL $q with ",dump( @data ),"\n";
961                            eval { $sth->execute( @data ) };
962                            if ($@) {
963                                    $res = "ERROR: $@";
964                            } else {
965                                    $res = "OK, RSS executed $command" .
966                                            ( $sub ? "-$sub " : ' ' ) .
967                                            ( $channel ? "on $channel " : '' ) .
968                                            "url $url";
969                                    if ( $command eq 'clean' ) {
970                                            my $seen = $_stat->{rss}->{seen} || die "no seen?";
971                                            my $want_link = $_stat->{rss}->{url2link}->{$url} || warn "no url2link($url)";
972                                            foreach my $c ( keys %$seen ) {
973                                                    my $c_hash = $seen->{$c} || die "no seen->{$c}";
974                                                    die "not HASH with rss links but ", dump($c_hash) unless ref($c_hash) eq 'HASH';
975                                                    foreach my $link ( keys %$c_hash ) {
976                                                            next unless $link eq $want_link;
977                                                            _log "RSS removed seen $c $url $link";
978                                                    }
979                                            }
980                                    } elsif ( $command eq 'add' ) {
981                                            rss_fetch_all( $kernel );
982                                    }
983                            }
984                    } else {
985                            $res = "ERROR: don't know what to do with: $msg";
986                    }
987            } elsif ($msg =~ m/^rss-clean/) {
988                    # this makes sense because we didn't catch rss-clean http://... before!
989                    $_stat->{rss} = undef;
990                    $dbh->do( qq{ update feeds set last_update = now() - delay } );
991                    $res = rss_fetch_all( $kernel );
992            }
993    
994            return $res;
995    }
996    
997    POE::Session->create( inline_states => {
998            _start => sub {      
999                    $_[KERNEL]->post( $irc => register => 'all' );
1000                    $_[KERNEL]->post( $irc => connect => {} );
1001      },      },
1002            irc_001 => sub {
1003                    my ($kernel,$sender) = @_[KERNEL,SENDER];
1004                    my $poco_object = $sender->get_heap();
1005                    _log "connected to",$poco_object->server_name();
1006                    $kernel->post( $sender => join => $_ ) for @channels;
1007                    # seen RSS cache, so don't send out messages
1008                    _log rss_fetch_all( $kernel, 0 );
1009                    undef;
1010            },
1011    #       irc_255 => sub {        # server is done blabbing
1012    #               $_[KERNEL]->post( $irc => join => $CHANNEL);
1013    #       },
1014      irc_public => sub {      irc_public => sub {
1015                  my $kernel = $_[KERNEL];                  my $kernel = $_[KERNEL];
1016                  my $nick = (split /!/, $_[ARG0])[0];                  my $nick = (split /!/, $_[ARG0])[0];
# Line 632  POE::Session->create( inline_states => Line 1019  POE::Session->create( inline_states =>
1019    
1020                  save_message( channel => $channel, me => 0, nick => $nick, message => $msg);                  save_message( channel => $channel, me => 0, nick => $nick, message => $msg);
1021                  meta( $nick, $channel, 'last-msg', $msg );                  meta( $nick, $channel, 'last-msg', $msg );
1022                    rss_check_updates( $kernel );
1023      },      },
1024      irc_ctcp_action => sub {      irc_ctcp_action => sub {
1025                  my $kernel = $_[KERNEL];                  my $kernel = $_[KERNEL];
# Line 652  POE::Session->create( inline_states => Line 1040  POE::Session->create( inline_states =>
1040    
1041      },      },
1042          irc_ping => sub {          irc_ping => sub {
1043                  warn "pong ", $_[ARG0], $/;                  _log( "pong ", $_[ARG0] );
1044                  $ping->{ $_[ARG0] }++;                  $_stat->{ping}->{ $_[ARG0] }++;
1045                    rss_check_updates( $_[KERNEL] );
1046          },          },
1047          irc_invite => sub {          irc_invite => sub {
1048                  my $kernel = $_[KERNEL];                  my $kernel = $_[KERNEL];
1049                  my $nick = (split /!/, $_[ARG0])[0];                  my $nick = (split /!/, $_[ARG0])[0];
1050                  my $channel = $_[ARG1];                  my $channel = $_[ARG1];
1051    
1052                  warn "invited to $channel by $nick";                  _log "invited to $channel by $nick";
1053    
1054                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, "how nice of you to invite me to $channel, I'll be right there..." );                  $_[KERNEL]->post( $irc => privmsg => $nick, "how nice of you to invite me to $channel, I'll be right there..." );
1055                  $_[KERNEL]->post($IRC_ALIAS => join => $channel);                  $_[KERNEL]->post( $irc => 'join' => $channel );
1056    
1057          },          },
1058          irc_msg => sub {          irc_msg => sub {
1059                  my $kernel = $_[KERNEL];                  my $kernel = $_[KERNEL];
1060                  my $nick = (split /!/, $_[ARG0])[0];                  my $nick = (split /!/, $_[ARG0])[0];
                 my $msg = $_[ARG2];  
1061                  my $channel = $_[ARG1]->[0];                  my $channel = $_[ARG1]->[0];
1062                  from_to($msg, 'UTF-8', $ENCODING);                  my $msg = $_[ARG2];
1063                    warn "# ARG = ",dump( @_[ARG0,ARG1,ARG2] ) if $debug;
                 my $res = "unknown command '$msg', try /msg $NICK help!";  
                 my @out;  
1064    
1065                  _log "<< $msg";                  _log "<< $msg";
1066    
1067                  if ($msg =~ m/^help/i) {                  my $res = process_command( $_[KERNEL], $nick, $channel, $msg );
   
                         $res = "usage: /msg $NICK comand | commands: stat - user/message stat | last - show backtrace | grep foobar - find foobar";  
   
                 } elsif ($msg =~ m/^msg\s+(\S+)\s+(.*)$/i) {  
   
                         _log ">> /msg $1 $2";  
                         $_[KERNEL]->post( $IRC_ALIAS => privmsg => $1, $2 );  
                         $res = '';  
   
                 } elsif ($msg =~ m/^stat.*?\s*(\d*)/i) {  
   
                         my $nr = $1 || 10;  
   
                         my $sth = $dbh->prepare(qq{  
                                 select  
                                         trim(both '_' from nick) as nick,  
                                         count(*) as count,  
                                         sum(length(message)) as len  
                                 from log  
                                 group by trim(both '_' from 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) {  
   
                         my $limit = $1 || meta( $nick, $channel, 'last-size' ) || 10;  
   
                         foreach my $res (get_from_log( limit => $limit )) {  
                                 _log "last: $res";  
                                 from_to($res, $ENCODING, 'UTF-8');  
                                 $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );  
                         }  
   
                         $res = '';  
   
                 } elsif ($msg =~ m/^(search|grep)\s+(.*)\s*$/i) {  
   
                         my $what = $2;  
   
                         foreach my $res (get_from_log(  
                                         limit => 20,  
                                         search => $what,  
                                 )) {  
                                 _log "search [$what]: $res";  
                                 from_to($res, $ENCODING, 'UTF-8');  
                                 $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );  
                         }  
   
                         $res = '';  
   
                 } elsif ($msg =~ m/^(?:count|poll)\s+(.*)(?:\s+(\d+))?\s*$/i) {  
   
                         my ($what,$limit) = ($1,$2);  
                         $limit ||= 100;  
   
                         my $stat;  
   
                         foreach my $res (get_from_log(  
                                         limit => $limit,  
                                         search => $what,  
                                         full_rows => 1,  
                                 )) {  
                                 while ($res->{message} =~ s/\Q$what\E(\+|\-)//) {  
                                         $stat->{vote}->{$1}++;  
                                         $stat->{from}->{ $res->{nick} }++;  
                                 }  
                         }  
   
                         my @nicks;  
                         foreach my $nick (sort { $stat->{from}->{$a} <=> $stat->{from}->{$b} } keys %{ $stat->{from} }) {  
                                 push @nicks, $nick . ( $stat->{from}->{$nick} == 1 ? '' :  
                                         "(" . $stat->{from}->{$nick} . ")"  
                                 );  
                         }  
   
                         $res =  
                                 "$what ++ " . ( $stat->{vote}->{'+'} || 0 ) .  
                                 " : " . ( $stat->{vote}->{'-'} || 0 ) . " --" .  
                                 " from " . ( join(", ", @nicks) || 'nobody' );  
   
                         $_[KERNEL]->post( $IRC_ALIAS => notice => $nick, $res );  
   
                 } elsif ($msg =~ m/^ping/) {  
                         $res = "ping = " . dump( $ping );  
                 } elsif ($msg =~ m/^conf(?:ig)*\s*(last-size|twitter)*\s*(.*)/) {  
                         if ( ! defined( $1 ) ) {  
                                 my $sth = $dbh->prepare(qq{ select name,value,changed from meta where nick = ? and channel = ? });  
                                 $sth->execute( $nick, $channel );  
                                 $res = "config for $nick on $channel";  
                                 while ( my ($n,$v) = $sth->fetchrow_array ) {  
                                         $res .= " | $n = $v";  
                                 }  
                         } elsif ( ! $2 ) {  
                                 my $val = meta( $nick, $channel, $1 );  
                                 $res = "current $1 = " . ( $val ? $val : 'undefined' );  
                         } else {  
                                 my $validate = {  
                                         'last-size' => qr/^\d+/,  
                                         'twitter' => qr/^\w+\s+\w+/,  
                                 };  
   
                                 my ( $op, $val ) = ( $1, $2 );  
   
                                 if ( my $regex = $validate->{$op} ) {  
                                         if ( $val =~ $regex ) {  
                                                 meta( $nick, $channel, $op, $val );  
                                                 $res = "saved $op = $val";  
                                         } else {  
                                                 $res = "config option $op = $val doesn't validate against $regex";  
                                         }  
                                 } else {  
                                         $res = "config option $op doesn't exist";  
                                 }  
                         }  
                 }  
1068    
1069                  if ($res) {                  if ($res) {
1070                          _log ">> [$nick] $res";                          _log ">> [$nick] $res";
1071                          from_to($res, $ENCODING, 'UTF-8');                          $_[KERNEL]->post( $irc => privmsg => $nick, $res );
                         $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );  
1072                  }                  }
1073    
1074                    rss_check_updates( $_[KERNEL] );
1075          },          },
1076            irc_372 => sub {
1077                    _log "<< motd",$_[ARG0],$_[ARG1];
1078            },
1079            irc_375 => sub {
1080                    _log "<< motd", $_[ARG0], "start";
1081            },
1082            irc_376 => sub {
1083                    _log "<< motd", $_[ARG0], "end";
1084            },
1085    #       irc_433 => sub {
1086    #               print "# irc_433: ",$_[ARG1], "\n";
1087    #               warn "## indetify $NICK\n";
1088    #               $_[KERNEL]->post( $irc => privmsg => 'nickserv', "IDENTIFY $NICK" );
1089    #       },
1090    #       irc_451 # please register
1091          irc_477 => sub {          irc_477 => sub {
1092                  _log "# irc_477: ",$_[ARG1];                  _log "<< irc_477: ",$_[ARG1];
1093                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "register $NICK" );                  _log ">> IDENTIFY $NICK";
1094                    $_[KERNEL]->post( $irc => privmsg => 'NickServ', "IDENTIFY $NICK" );
1095          },          },
1096          irc_505 => sub {          irc_505 => sub {
1097                  _log "# irc_505: ",$_[ARG1];                  _log "<< irc_505: ",$_[ARG1];
1098                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "register $NICK" );                  _log ">> register $NICK";
1099  #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "set hide email on" );                  $_[KERNEL]->post( $irc => privmsg => 'NickServ', "register $NICK" );
1100  #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "set email dpavlin\@rot13.org" );  #               $_[KERNEL]->post( $irc => privmsg => 'nickserv', "IDENTIFY $NICK" );
1101    #               $_[KERNEL]->post( $irc => privmsg => 'nickserv', "set hide email on" );
1102    #               $_[KERNEL]->post( $irc => privmsg => 'nickserv', "set email dpavlin\@rot13.org" );
1103          },          },
1104          irc_registered => sub {          irc_registered => sub {
1105                  _log "## registrated $NICK";                  _log "<< registered $NICK";
                 $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );  
1106          },          },
1107          irc_disconnected => sub {          irc_disconnected => sub {
1108                  _log "## disconnected, reconnecting again";                  _log "## disconnected.. sleeping for $sleep_on_error seconds and reconnecting again";
1109                  $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);                  sleep($sleep_on_error);
1110                    $_[KERNEL]->post( $irc => connect => {} );
1111          },          },
1112          irc_socketerr => sub {          irc_socketerr => sub {
1113                  _log "## socket error... sleeping for $sleep_on_error seconds and retry";                  _log "## socket error... sleeping for $sleep_on_error seconds and retry";
1114                  sleep($sleep_on_error);                  sleep($sleep_on_error);
1115                  $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);                  $_[KERNEL]->post( $irc => connect => {} );
1116            },
1117            irc_notice => sub {
1118                    _log "<< notice from ", $_[ARG0], $_[ARG1], $_[ARG2];
1119                    my $m = $_[ARG2];
1120                    if ( $m =~ m!/msg.*(NickServ).*(IDENTIFY)!i ) {
1121                            _log ">> suggested to $1 $2";
1122                            $_[KERNEL]->post( $irc => privmsg => $1, "$2 $NICK" );
1123                    } elsif ( $m =~ m!\Q$NICK\E.*registered!i ) {
1124                            _log ">> registreted, so IDENTIFY";
1125                            $_[KERNEL]->post( $irc => privmsg => 'nickserv', "IDENTIFY $NICK" );
1126                    } else {
1127                            warn "## ignore $m\n" if $debug;
1128                    }
1129            },
1130            irc_snotice => sub {
1131                    _log "<< snotice", $_[ARG0]; #dump( $_[ARG0],$_[ARG1], $_[ARG2] );
1132                    if ( $_[ARG0] =~ m!/(QUOTE)\s+(PASS\s+\d+)!i ) {
1133                            warn ">> $1 | $2\n";
1134                            $_[KERNEL]->post( $irc => lc($1) => $2);
1135                    }
1136          },          },
 #       irc_433 => sub {  
 #               print "# irc_433: ",$_[ARG1], "\n";  
 #               warn "## indetify $NICK\n";  
 #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );  
 #       },  
1137      _child => sub {},      _child => sub {},
1138      _default => sub {      _default => sub {
1139                  _log sprintf "sID:%s %s %s",                  _log '_default SID:', $_[SESSION]->ID, $_[ARG0], dump( $_[ARG1] );
1140                          $_[SESSION]->ID, $_[ARG0],                  0; # false for signals
                         ref($_[ARG1]) eq "ARRAY"        ?       join(",", map { ref($_) eq "ARRAY" ? join(";", @{$_}) : $_ } @{ $_[ARG1] })     :  
                         $_[ARG1]                                        ?       $_[ARG1]                                        :  
                         "";  
       0;                        # false for signals  
     },  
     my_add => sub {  
       my $trailing = $_[ARG0];  
       my $session = $_[SESSION];  
       POE::Session->create  
           (inline_states =>  
            {_start => sub {  
               $_[HEAP]->{wheel} =  
                 POE::Wheel::FollowTail->new  
                     (  
                      Filename => $FOLLOWS{$trailing},  
                      InputEvent => 'got_line',  
                     );  
             },  
             got_line => sub {  
               $_[KERNEL]->post($session => my_tailed =>  
                                time, $trailing, $_[ARG0]);  
             },  
            },  
           );  
       
     },  
     my_tailed => sub {  
       my ($time, $file, $line) = @_[ARG0..ARG2];  
       ## $time will be undef on a probe, or a time value if a real line  
   
       ## PoCo::IRC has throttling built in, but no external visibility  
       ## so this is reaching "under the hood"  
       $SEND_QUEUE ||=  
         $_[KERNEL]->alias_resolve($IRC_ALIAS)->get_heap->{send_queue};  
   
       ## handle "no need to keep skipping" transition  
       if ($SKIPPING and @$SEND_QUEUE < 1) {  
         $_[KERNEL]->post($IRC_ALIAS => privmsg => $CHANNEL =>  
                          "[discarded $SKIPPING messages]");  
         $SKIPPING = 0;  
       }  
   
       ## handle potential message display  
       if ($time) {  
         if ($SKIPPING or @$SEND_QUEUE > 3) { # 3 msgs per 10 seconds  
           $SKIPPING++;  
         } else {  
           my @time = localtime $time;  
           $_[KERNEL]->post($IRC_ALIAS => privmsg => $CHANNEL =>  
                            sprintf "%02d:%02d:%02d: %s: %s",  
                            ($time[2] + 11) % 12 + 1, $time[1], $time[0],  
                            $file, $line);  
         }  
       }  
   
       ## handle re-probe/flush if skipping  
       if ($SKIPPING) {  
         $_[KERNEL]->delay($_[STATE] => 0.5); # $time will be undef  
       }  
   
1141      },      },
1142      my_heartbeat => sub {          rss_response => sub {
1143        $_[KERNEL]->yield(my_tailed => time, "heartbeat", "beep");                  my ($request_packet, $response_packet) = @_[ARG0, ARG1];
1144        $_[KERNEL]->delay($_[STATE] => 10);                  my $request_object  = $request_packet->[0];
1145      }                  my $response_object = $response_packet->[0];
1146    
1147                    my $row = delete( $_stat->{rss}->{fetch}->{ $request_object->uri } );
1148                    if ( $row ) {
1149                            $row->{xml} = $response_object->content;
1150                            rss_parse_xml( $_[KERNEL], $row );
1151                    } else {
1152                            warn "## can't find rss->fetch for ", $request_object->uri;
1153                    }
1154            },
1155     },     },
1156    );    );
1157    
1158  # http server  # http server
1159    
1160    _log "WEB archive at $url";
1161    
1162  my $httpd = POE::Component::Server::HTTP->new(  my $httpd = POE::Component::Server::HTTP->new(
1163          Port => $http_port,          Port => $http_port,
1164            PreHandler => {
1165                    '/' => sub {
1166                            $_[0]->header(Connection => 'close')
1167                    }
1168            },
1169          ContentHandler => { '/' => \&root_handler },          ContentHandler => { '/' => \&root_handler },
1170          Headers        => { Server => 'irc-logger' },          Headers        => { Server => 'irc-logger' },
1171  );  );
# Line 952  foreach my $c (@cols) { Line 1205  foreach my $c (@cols) {
1205          $style .= ".col-${max_color} { background: $c }\n";          $style .= ".col-${max_color} { background: $c }\n";
1206          $max_color++;          $max_color++;
1207  }  }
1208  warn "defined $max_color colors for users...\n";  _log "WEB defined $max_color colors for users...";
1209    
1210  sub root_handler {  sub root_handler {
1211          my ($request, $response) = @_;          my ($request, $response) = @_;
1212          $response->code(RC_OK);          $response->code(RC_OK);
1213    
1214            # this doesn't seem to work, so moved to PreHandler
1215            #$response->header(Connection => 'close');
1216    
1217            return RC_OK if $request->uri =~ m/favicon.ico$/;
1218    
1219          my $q;          my $q;
1220    
1221          if ( $request->method eq 'POST' ) {          if ( $request->method eq 'POST' ) {
# Line 969  sub root_handler { Line 1227  sub root_handler {
1227          }          }
1228    
1229          my $search = $q->param('search') || $q->param('grep') || '';          my $search = $q->param('search') || $q->param('grep') || '';
1230            my $r_url = $request->url;
1231    
1232            my @commands = qw( tags last-tag follow stat );
1233            my $commands_re = join('|',@commands);
1234    
1235            if ($r_url =~ m#/rss(?:/($commands_re.*)\w*(?:=(\d+))?)?#i) {
1236                    my $show = lc($1);
1237                    my $nr = $2;
1238    
         if ($request->url =~ m#/rss#i) {  
1239                  my $type = 'RSS';       # Atom                  my $type = 'RSS';       # Atom
                 my $url = "http://$http_hostname:$http_port";  
1240    
1241                  $response->content_type("application/$type+xml");                  $response->content_type( 'application/' . lc($type) . '+xml' );
1242    
1243                  my $html = '<!-- error -->';                  my $html = '<!-- error -->';
1244                  warn "create $type feed from ",dump( @last_tags );                  #warn "create $type feed from ",dump( @last_tags );
1245    
1246                  my $feed = XML::Feed->new( $type );                  my $feed = XML::Feed->new( $type );
1247                    $feed->link( $url );
1248    
1249                  $feed->title( "last $last_x_tags from $CHANNEL" );                  my $rc = RC_OK;
1250                  $feed->link( "http://$http_hostname:$http_port" );  
1251                  $feed->description( "collects messages which have tags// in them" );                  if ( $show eq 'tags' ) {
1252                            $nr ||= 50;
1253                  foreach my $m ( @last_tags ) {                          $feed->title( "tags from $CHANNEL" );
1254                          warn dump( $m );                          $feed->link( "$url/tags" );
1255                          #my $tags = join(' ', @{$m->{tags}} );                          $feed->description( "tag cloud created from messages on channel $CHANNEL which have tags// in them" );
1256                          my $feed_entry = XML::Feed::Entry->new($type);                          my $feed_entry = XML::Feed::Entry->new($type);
1257                          $feed_entry->title( $m->{nick} . '@' . $m->{time} );                          $feed_entry->title( "$nr tags from $CHANNEL" );
1258                          $feed_entry->author( $m->{nick} );                          $feed_entry->author( $NICK );
1259  #                       $feed_entry->link(  );                          $feed_entry->link( '/#tags'  );
1260                          $feed_entry->issued( DateTime::Format::Flexible->build( $m->{time} ) );  
1261                          $feed_entry->summary(                          $feed_entry->content(
1262                                  '<![CDATA[' .                                  qq{<![CDATA[<style type="text/css">}
1263  #                               $filter->{nick}->( $m->{nick} ) .                                  . $cloud->css
1264  #                               '<tt>' . $m->{nick} . '</tt> ' .                                  . qq{</style>}
1265                                  $filter->{message}->( $m->{message} ) .                                  . $cloud->html( $nr )
1266                                  ']]>'                                  . qq{]]>}
1267                          );                          );
                         $feed_entry->category( join(', ', @{$m->{tags}}) );  
1268                          $feed->add_entry( $feed_entry );                          $feed->add_entry( $feed_entry );
1269    
1270                    } elsif ( $show eq 'last-tag' ) {
1271    
1272                            $nr ||= $last_x_tags;
1273                            $nr = $last_x_tags if $nr > $last_x_tags;
1274    
1275                            $feed->title( "last $nr tagged messages from $CHANNEL" );
1276                            $feed->description( "collects messages which have tags// in them" );
1277    
1278                            foreach my $m ( @last_tags ) {
1279    #                               warn dump( $m );
1280                                    #my $tags = join(' ', @{$m->{tags}} );
1281                                    my $feed_entry = XML::Feed::Entry->new($type);
1282                                    $feed_entry->title( $m->{nick} . '@' . $m->{time} );
1283                                    $feed_entry->author( $m->{nick} );
1284                                    $feed_entry->link( '/#' . $m->{id}  );
1285                                    $feed_entry->issued( DateTime::Format::Flexible->build( $m->{time} ) );
1286    
1287                                    my $message = $filter->{message}->( $m->{message} );
1288                                    $message .= "<br/>\n" unless $message =~ m!<(/p|br/?)>!;
1289    #                               warn "## message = $message\n";
1290    
1291                                    #$feed_entry->summary(
1292                                    $feed_entry->content(
1293                                            "<![CDATA[$message]]>"
1294                                    );
1295                                    $feed_entry->category( join(', ', @{$m->{tags}}) );
1296                                    $feed->add_entry( $feed_entry );
1297    
1298                                    $nr--;
1299                                    last if $nr <= 0;
1300    
1301                            }
1302    
1303                    } elsif ( $show =~ m/^follow/ ) {
1304    
1305                            $feed->title( "Feeds which this bot follows" );
1306    
1307                            my $sth = $dbh->prepare( qq{ select * from feeds order by last_update desc } );
1308                            $sth->execute;
1309                            while (my $row = $sth->fetchrow_hashref) {
1310                                    my $feed_entry = XML::Feed::Entry->new($type);
1311                                    $feed_entry->title( $row->{name} );
1312                                    $feed_entry->link( $row->{url}  );
1313                                    $feed_entry->issued( DateTime::Format::Flexible->build( $row->{last_update} ) );
1314                                    $feed_entry->content(
1315                                            '<![CDATA[<pre>' . dump( $row ) . '</pre>]]>'
1316                                    );
1317                                    $feed->add_entry( $feed_entry );
1318                            }
1319    
1320                    } elsif ( $show =~ m/^stat/ ) {
1321    
1322                            my $feed_entry = XML::Feed::Entry->new($type);
1323                            $feed_entry->title( "Internal stats" );
1324                            $feed_entry->content(
1325                                    '<![CDATA[<pre>' . dump( $_stat ) . '</pre>]]>'
1326                            );
1327                            $feed->add_entry( $feed_entry );
1328    
1329                    } else {
1330                            _log "WEB unknown rss request $r_url";
1331                            $feed->title( "unknown $r_url" );
1332                            foreach my $c ( @commands ) {
1333                                    my $feed_entry = XML::Feed::Entry->new($type);
1334                                    $feed_entry->title( "rss/$c" );
1335                                    $feed_entry->link( "$url/rss/$c" );
1336                                    $feed->add_entry( $feed_entry );
1337                            }
1338                            $rc = RC_DENY;
1339                  }                  }
1340    
1341                  $response->content( $feed->as_xml );                  $response->content( $feed->as_xml );
1342                  return RC_OK;                  return $rc;
1343          }          }
1344    
1345          if ( $@ ) {          if ( $@ ) {
1346                  warn "$@";                  warn "$@";
1347          }          }
1348    
1349          $response->content_type("text/html; charset=$ENCODING");          $response->content_type("text/html; charset=UTF-8");
1350    
1351          my $html =          my $html =
1352                  qq{<html><head><title>$NICK</title><style type="text/css">$style} .                  qq{<html><head><title>$NICK</title><style type="text/css">$style}
1353                  $cloud->css .                  . $cloud->css
1354                  qq{</style></head><body>} .                  . qq{</style></head><body>}
1355                  qq{                  . qq{
1356                  <form method="post" class="search" action="/">                  <form method="post" class="search" action="/">
1357                  <input type="text" name="search" value="$search" size="10">                  <input type="text" name="search" value="$search" size="10">
1358                  <input type="submit" value="search">                  <input type="submit" value="search">
1359                  </form>                  </form>
1360                  } .                  }
1361                  $cloud->html(500) .                  . $cloud->html(500)
1362                  qq{<p>};                  . qq{<p>};
1363          if ($request->url =~ m#/history#) {  
1364            if ($request->url =~ m#/tags?#) {
1365                    # nop
1366            } elsif ($request->url =~ m#/history#) {
1367                  my $sth = $dbh->prepare(qq{                  my $sth = $dbh->prepare(qq{
1368                          select date(time) as date,count(*) as nr,sum(length(message)) as len                          select date(time) as date,count(*) as nr,sum(length(message)) as len
1369                                  from log                                  from log
# Line 1058  sub root_handler { Line 1395  sub root_handler {
1395                                  $cal->weekdays('MON','TUE','WED','THU','FRI');                                  $cal->weekdays('MON','TUE','WED','THU','FRI');
1396                                  ($l_yyyy,$l_mm) = ($yyyy,$mm);                                  ($l_yyyy,$l_mm) = ($yyyy,$mm);
1397                          }                          }
1398                          $cal->setcontent($dd, qq{                          $cal->setcontent($dd, qq[
1399                                  <a href="/?date=$row->{date}">$row->{nr}</a><br/>$row->{len}                                  <a href="$url?date=$row->{date}">$row->{nr}</a><br/>$row->{len}
1400                          });                          ]) if $cal;
1401                                                    
1402                  }                  }
1403                  $html .= qq{<td valign="top">} . $cal->as_HTML() . qq{</td></tr></table>};                  $html .= qq{<td valign="top">} . $cal->as_HTML() . qq{</td></tr></table>};
# Line 1075  sub root_handler { Line 1412  sub root_handler {
1412                                  fmt => {                                  fmt => {
1413                                          date => sub {                                          date => sub {
1414                                                  my $date = shift || return;                                                  my $date = shift || return;
1415                                                  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>};
1416                                          },                                          },
1417                                          time => '<span class="time">%s</span> ',                                          time => '<span class="time">%s</span> ',
1418                                          time_channel => '<span class="channel">%s %s</span> ',                                          time_channel => '<span class="channel">%s %s</span> ',
# Line 1093  sub root_handler { Line 1430  sub root_handler {
1430          <p>See <a href="/history">history</a> of all messages.</p>          <p>See <a href="/history">history</a> of all messages.</p>
1431          </body></html>};          </body></html>};
1432    
1433          $response->content( $html );          $response->content( decode('utf-8',$html) );
1434            warn "<< ", $request->method, " ", $request->uri, " created ", length($html), " bytes\n";
1435          return RC_OK;          return RC_OK;
1436  }  }
1437    

Legend:
Removed from v.71  
changed lines
  Added in v.132

  ViewVC Help
Powered by ViewVC 1.1.26