/[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 86 by dpavlin, Thu Mar 6 22:57:16 2008 UTC revision 140 by dpavlin, Fri Jul 18 20:29:45 2008 UTC
# Line 2  Line 2 
2  use strict;  use strict;
3  $|++;  $|++;
4    
5    use POE qw(Component::IRC Component::Server::HTTP Component::Client::HTTP);
6    use HTTP::Status;
7    use DBI;
8    use Regexp::Common qw /URI/;
9    use CGI::Simple;
10    use POSIX qw/strftime/;
11    use HTML::CalendarMonthSimple;
12    use Getopt::Long;
13    use DateTime;
14    use URI::Escape;
15    use Data::Dump qw/dump/;
16    use DateTime::Format::ISO8601;
17    use Carp qw/confess/;
18    use XML::Feed;
19    use DateTime::Format::Flexible;
20    use Encode;
21    
22  =head1 NAME  =head1 NAME
23    
24  irc-logger.pl  irc-logger.pl
# Line 20  Import log from C<dircproxy> to C<irc-lo Line 37  Import log from C<dircproxy> to C<irc-lo
37    
38  =item --log=irc-logger.log  =item --log=irc-logger.log
39    
 Name of log file  
   
 =item --follow=file.log  
   
 Follows new messages in file  
   
40  =back  =back
41    
42  =head1 DESCRIPTION  =head1 DESCRIPTION
# Line 36  log all conversation on irc channel Line 47  log all conversation on irc channel
47    
48  ## CONFIG  ## CONFIG
49    
50    my $debug = 0;
51    
52    my $irc_config = {
53            nick => 'irc-logger',
54            server => 'irc.freenode.net',
55            port => 6667,
56            ircname => 'Anna the bot: try /msg irc-logger help',
57    };
58    
59  my $HOSTNAME = `hostname -f`;  my $HOSTNAME = `hostname -f`;
60  chomp($HOSTNAME);  chomp($HOSTNAME);
61    
62  my $NICK = 'irc-logger';  
 $NICK .= '-dev' if ($HOSTNAME =~ m/llin/);  
 my $CONNECT =  
   {Server => 'irc.freenode.net',  
    Nick => $NICK,  
    Ircname => "try /msg $NICK help",  
   };  
63  my $CHANNEL = '#razmjenavjestina';  my $CHANNEL = '#razmjenavjestina';
 $CHANNEL = '#irc-logger' if ($HOSTNAME =~ m/llin/);  
 my $IRC_ALIAS = "log";  
64    
65  # default log to follow and announce messages  if ( $HOSTNAME =~ m/llin/ ) {
66  my $follows_path = 'follows.log';          $irc_config->{nick} = 'irc-logger-llin';
67    #       $irc_config = {
68    #               nick => 'irc-logger-llin',
69    #               server => 'localhost',
70    #               port => 6668,
71    #       };
72            $CHANNEL = '#irc-logger';
73    } elsif ( $HOSTNAME =~ m/lugarin/ ) {
74            $irc_config->{server} = 'irc.carnet.hr';
75            $CHANNEL = '#riss';
76    }
77    
78    my @channels = ( $CHANNEL );
79    
80    warn "## config = ", dump( $irc_config ) if $debug;
81    
82    my $NICK = $irc_config->{nick} or die "no nick?";
83    
84  my $DSN = 'DBI:Pg:dbname=' . $NICK;  my $DSN = 'DBI:Pg:dbname=' . $NICK;
85    
 # log output encoding  
 my $ENCODING = 'ISO-8859-2';  
86  my $TIMESTAMP = '%Y-%m-%d %H:%M:%S';  my $TIMESTAMP = '%Y-%m-%d %H:%M:%S';
87    
88  my $sleep_on_error = 5;  my $sleep_on_error = 5;
# Line 66  my $last_x_tags = 50; Line 92  my $last_x_tags = 50;
92    
93  # don't pull rss feeds more often than this  # don't pull rss feeds more often than this
94  my $rss_min_delay = 60;  my $rss_min_delay = 60;
 $rss_min_delay = 15;  
95    
96  my $http_port = $NICK =~ m/-dev/ ? 8001 : 8000;  my $http_port = $NICK =~ m/-dev/ ? 8001 : 8000;
97    
# Line 74  my $url = "http://$HOSTNAME:$http_port"; Line 99  my $url = "http://$HOSTNAME:$http_port";
99    
100  ## END CONFIG  ## END CONFIG
101    
 use POE qw(Component::IRC Wheel::FollowTail Component::Server::HTTP);  
 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  my $use_twitter = 1;  my $use_twitter = 1;
103  eval { require Net::Twitter; };  eval { require Net::Twitter; };
104  $use_twitter = 0 if ($@);  $use_twitter = 0 if ($@);
# Line 100  my $import_dircproxy; Line 107  my $import_dircproxy;
107  my $log_path;  my $log_path;
108  GetOptions(  GetOptions(
109          'import-dircproxy:s' => \$import_dircproxy,          'import-dircproxy:s' => \$import_dircproxy,
         'follows:s' => \$follows_path,  
110          'log:s' => \$log_path,          'log:s' => \$log_path,
111            'debug!' => \$debug,
112  );  );
113    
114  $SIG{__DIE__} = sub {  #$SIG{__DIE__} = sub {
115          confess "fatal error";  #       confess "fatal error";
116  };  #};
   
 open(STDOUT, '>', $log_path) || warn "can't redirect log to $log_path: $!";  
117    
118  sub _log {  sub _log {
119          my $out = strftime($TIMESTAMP,localtime()) . ' ' . join(" ",@_) . $/;          print strftime($TIMESTAMP,localtime()) . ' ' . join(" ",map { ref($_) ? dump( $_ ) : $_ } @_) . $/;
         from_to( $out, 'UTF-8', $ENCODING );  
         print $out;  
120  }  }
121    
122  # LOG following  open(STDOUT, '>', $log_path) && warn "log to $log_path: $!\n";
   
 my %FOLLOWS =  
   (  
 #   ACCESS => "/var/log/apache/access.log",  
 #   ERROR => "/var/log/apache/error.log",  
   );  
   
 sub add_follow_path {  
         my $path = shift;  
         my $name = $path;  
         $name =~ s/\..*$//;  
         warn "# using $path to announce messages from $name\n";  
         $FOLLOWS{$name} = $path;  
 }  
123    
 add_follow_path( $follows_path ) if ( -e $follows_path );  
124    
125  # HTML formatters  # HTML formatters
126    
127  my %escape = ('<'=>'&lt;', '>'=>'&gt;', '&'=>'&amp;', '"'=>'&quot;');  my %escape = ('<'=>'&lt;', '>'=>'&gt;', '&'=>'&amp;', '"'=>'&quot;');
128  my $escape_re  = join '|' => keys %escape;  my $escape_re  = join '|' => keys %escape;
129    
130  my $tag_regex = '\b([\w-_]+)//';  my $tag_regex = '\b([\w\-_]+)//';
131    
132  my %nick_enumerator;  my %nick_enumerator;
133  my $max_color = 0;  my $max_color = 0;
# Line 151  my $filter = { Line 139  my $filter = {
139                  # protect HTML from wiki modifications                  # protect HTML from wiki modifications
140                  sub e {                  sub e {
141                          my $t = shift;                          my $t = shift;
142                          return 'uri_unescape{' . uri_escape($t) . '}';                          return 'uri_unescape{' . uri_escape($t, '^a-zA-Z0-9') . '}';
143                  }                  }
144    
145                  $m =~ s/($escape_re)/$escape{$1}/gs;                  $m =~ s/($escape_re)/$escape{$1}/gs;
146                  $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;
147                  $m =~ s#\/(\w+)\/#<i>$1</i>#gs;                  $m =~ s#\/(\w+)\/#<i>$1</i>#gs;
148                  $m =~ s#$tag_regex#e(qq{<a href="$url?tag=$1" class="tag">$1</a>})#egs;                  $m =~ s#$tag_regex#e(qq{<a href="$url?tag=$1" class="tag">$1</a>})#egs;
149                  $m =~ s#\*(\w+)\*#<b>$1</b>#gs;                  $m =~ s#\*(\w+)\*#<b>$1</b>#gs;
# Line 176  my $filter = { Line 164  my $filter = {
164          },          },
165  };  };
166    
167    # POE IRC
168    my $poe_irc = POE::Component::IRC->spawn( %$irc_config ) or
169            die "can't start ", dump( $irc_config ), ": $!";
170    
171    my $irc = $poe_irc->session_id();
172    _log "IRC session_id $irc";
173    
174  my $dbh = DBI->connect($DSN,"","", { RaiseError => 1, AutoCommit => 1 }) || die $DBI::errstr;  my $dbh = DBI->connect($DSN,"","", { RaiseError => 1, AutoCommit => 1 }) || die $DBI::errstr;
175  $dbh->do( qq{ set client_encoding = 'UTF-8' } );  $dbh->do( qq{ set client_encoding = 'UTF-8' } );
176    
# Line 212  create table feeds ( Line 207  create table feeds (
207          name text,          name text,
208          delay interval not null default '5 min',          delay interval not null default '5 min',
209          active boolean default true,          active boolean default true,
210            channel text not null,
211            nick text not null,
212            private boolean default false,
213          last_update timestamp default 'now()',          last_update timestamp default 'now()',
214          polls int default 0,          polls int default 0,
215          updates int default 0          updates int default 0
216  );  );
217  create unique index feeds_url on feeds(url);  create unique index feeds_url on feeds(url);
218  insert into feeds (url,name) values ('http://wiki.razmjenavjestina.org/feed/workspace/razmjenavjestina?category=Recent%20Changes','wiki');  insert into feeds (url,name,channel,nick) values ('http://wiki.razmjenavjestina.org/feed/workspace/razmjenavjestina?category=Recent%20Changes','wiki','$CHANNEL','dpavlin');
219          },          },
220  };  };
221    
# Line 257  sub meta { Line 255  sub meta {
255    
256                  eval { $sth->execute( $value, $nick, $channel, $name ) };                  eval { $sth->execute( $value, $nick, $channel, $name ) };
257    
258                  # error or no result                  if ( $@ ) {
259                  if ( $@ || ! $sth->rows ) {                          # error
260                            _log("META ERROR: $@");
261                    } elsif ( ! $sth->rows ) {
262                            # no result -> add new
263                          $sth = $dbh->prepare(qq{ insert into meta (value,nick,channel,name,changed) values (?,?,?,?,now()) });                          $sth = $dbh->prepare(qq{ insert into meta (value,nick,channel,name,changed) values (?,?,?,?,now()) });
264                          $sth->execute( $value, $nick, $channel, $name );                          eval { $sth->execute( $value, $nick, $channel, $name ); };
265                          _log "created $nick/$channel/$name = $value";                          if ( $@ ) {
266                                    _log "META ERROR: $@";
267                            } else {
268                                    _log "META: created $nick/$channel/$name = $value\n";
269                            }
270                  } else {                  } else {
271                          _log "updated $nick/$channel/$name = $value ";                          _log "META: updated $nick/$channel/$name = $value\n";
272                  }                  }
273    
274                  return $value;                  return $value;
# Line 273  sub meta { Line 278  sub meta {
278                  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 = ? });
279                  $sth->execute( $nick, $channel, $name );                  $sth->execute( $nick, $channel, $name );
280                  my ($v,$c) = $sth->fetchrow_array;                  my ($v,$c) = $sth->fetchrow_array;
281                  _log "fetched $nick/$channel/$name = $v [$c]";                  warn "## fetched $nick/$channel/$name = $v [$c]\n";
282                  return ($v,$c) if wantarray;                  return ($v,$c) if wantarray;
283                  return $v;                  return $v;
284    
# Line 282  sub meta { Line 287  sub meta {
287    
288    
289    
290  my $sth = $dbh->prepare(qq{  my $sth_insert_log = $dbh->prepare(qq{
291  insert into log  insert into log
292          (channel, me, nick, message, time)          (channel, me, nick, message, time)
293  values (?,?,?,?,?)  values (?,?,?,?,?)
# Line 370  sub get_from_log { Line 375  sub get_from_log {
375    
376          my @where;          my @where;
377          my @args;          my @args;
378            my $msg;
379    
380          if (my $search = $args->{search}) {          if (my $search = $args->{search}) {
381                  $search =~ s/^\s+//;                  $search =~ s/^\s+//;
382                  $search =~ s/\s+$//;                  $search =~ s/\s+$//;
383                  push @where, 'message ilike ? or nick ilike ?';                  push @where, 'message ilike ? or nick ilike ?';
384                  push @args, ( ( '%' . $search . '%' ) x 2 );                  push @args, ( ( '%' . $search . '%' ) x 2 );
385                  _log "search for '$search'";                  $msg = "Search for '$search'";
386          }          }
387    
388          if ($args->{tag} && $tags->{ $args->{tag} }) {          if ($args->{tag} && $tags->{ $args->{tag} }) {
389                  push @where, 'id in (' . join(',', @{ $tags->{ $args->{tag} } }) . ')';                  push @where, 'id in (' . join(',', @{ $tags->{ $args->{tag} } }) . ')';
390                  _log "search for tags $args->{tag}";                  $msg = "Search for tags $args->{tag}";
391          }          }
392    
393          if (my $date = $args->{date} ) {          if (my $date = $args->{date} ) {
394                  $date = check_date( $date );                  $date = check_date( $date );
395                  push @where, 'date(time) = ?';                  push @where, 'date(time) = ?';
396                  push @args, $date;                  push @args, $date;
397                  _log "search for date $date";                  $msg = "search for date $date";
398          }          }
399    
400          $sql .= " where " . join(" and ", @where) if @where;          $sql .= " where " . join(" and ", @where) if @where;
# Line 402  sub get_from_log { Line 408  sub get_from_log {
408          eval { $sth->execute( @args ) };          eval { $sth->execute( @args ) };
409          return if $@;          return if $@;
410    
411            my $nr_results = $sth->rows;
412    
413          my $last_row = {          my $last_row = {
414                  date => '',                  date => '',
415                  time => '',                  time => '',
# Line 422  sub get_from_log { Line 430  sub get_from_log {
430    
431          return @rows if ($args->{full_rows});          return @rows if ($args->{full_rows});
432    
433          my @msgs = (          $msg .= ' produced ' . (
434                  "Showing " . ($#rows + 1) . " messages..."                  $nr_results == 0 ? 'no results' :
435                    $nr_results == 0 ? 'one result' :
436                            $nr_results . ' results'
437          );          );
438    
439            my @msgs = ( $msg );
440    
441          if ($context) {          if ($context) {
442                  my @ids = @rows;                  my @ids = @rows;
443                  @rows = ();                  @rows = ();
# Line 482  sub get_from_log { Line 494  sub get_from_log {
494  #                       $row->{nick} = $nick;  #                       $row->{nick} = $nick;
495  #               }  #               }
496    
497                    $append = 0 if $row->{me};
498    
499                  if ($last_row->{nick} ne $nick) {                  if ($last_row->{nick} ne $nick) {
500                          # obfu way to find format for me_nick if needed or fallback to default                          # obfu way to find format for me_nick if needed or fallback to default
501                          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 518  sub get_from_log { Line 532  sub get_from_log {
532    
533  # tags support  # tags support
534    
535  my $cloud = HTML::TagCloud->new;  my $cloud = TagCloud->new;
536    $cloud->seed_tags;
 =head2 add_tag  
   
  add_tag( id => 42, message => 'irc message', nick => 'foobar' [, me => 1 ] );  
   
 =cut  
   
 my @last_tags;  
   
 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));  
   
         my @tags;  
   
         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, "$url?tag=$tag", scalar @{$tags->{$tag}} + 1);  
                 push @tags, $tag;  
   
         }  
   
         if ( @tags ) {  
                 pop @last_tags if $#last_tags == $last_x_tags;  
                 unshift @last_tags, { tags => [ @tags ], %$arg };  
         }  
   
 }  
   
 =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,nick,me,time from log where message like '%//%' order by time asc });  
         $sth->execute;  
         while (my $row = $sth->fetchrow_hashref) {  
                 add_tag( %$row );  
         }  
   
         foreach my $tag (keys %$tags) {  
                 $cloud->add($tag, "$url?tag=$tag", scalar @{$tags->{$tag}} + 1);  
         }  
 }  
   
 seed_tags;  
   
537    
538  =head2 save_message  =head2 save_message
539    
# Line 598  sub save_message { Line 557  sub save_message {
557          $a->{me} ||= 0;          $a->{me} ||= 0;
558          $a->{time} ||= strftime($TIMESTAMP,localtime());          $a->{time} ||= strftime($TIMESTAMP,localtime());
559    
560          _log          _log "ARCHIVE",
561                  $a->{channel}, " ",                  $a->{channel}, " ",
562                  $a->{me} ? "***" . $a->{nick} : "<" . $a->{nick} . ">",                  $a->{me} ? "***" . $a->{nick} : "<" . $a->{nick} . ">",
563                  " " . $a->{message};                  " " . $a->{message};
564    
565          $sth->execute($a->{channel}, $a->{me}, $a->{nick}, $a->{message}, $a->{time});          eval { $sth_insert_log->execute($a->{channel}, $a->{me}, $a->{nick}, $a->{message}, $a->{time}); };
566          add_tag( id => $dbh->last_insert_id(undef,undef,"log",undef), %$a );          if ( $@ ) {
567                    _log "ERROR: can't archive ", $a->{message};
568            } else {
569                    $cloud->add_tag( id => $dbh->last_insert_id(undef,undef,"log",undef), %$a );
570            }
571  }  }
572    
573    
# Line 646  if ($import_dircproxy) { Line 609  if ($import_dircproxy) {
609  # RSS follow  # RSS follow
610  #  #
611    
612  my $_rss;  my $_stat;
613    
614    POE::Component::Client::HTTP->spawn(
615            Alias   => 'rss-fetch',
616            Timeout => 30,
617    );
618    
619    =head2 rss_parse_xml
620    
621  sub rss_fetch {    rss_parse_xml({
622          my ($args) = @_;          url => 'http://www.example.com/rss',
623            send_rss_msgs => 42,
624      });
625    
626    =cut
627    
628    sub rss_parse_xml {
629            my ($kernel,$args) = @_;
630    
631            warn "## rss_parse_xml ",dump( $args ) if $debug;
632    
633          # how many messages to send out when feed is seen for the first time?          # how many messages to send out when feed is seen for the first time?
634          my $send_rss_msgs = 1;          my $send_rss_msgs = $args->{send_rss_msgs};
635            $send_rss_msgs = 1 if ! defined $send_rss_msgs;
636    
637            warn "## RSS fetch first $send_rss_msgs items from", $args->{url} if $debug;
638    
639          my $feed = XML::Feed->parse(URI->new( $args->{url} ));          my $feed;
640            eval { $feed = XML::Feed->parse( \$args->{xml} ) };
641          if ( ! $feed ) {          if ( ! $feed ) {
642                  _log("can't fetch RSS ", $args->{url});                  _log "can't fetch RSS ", $args->{url}, XML::Feed->errstr;
643                  return;                  return;
644          }          }
645          my $updates = 0;  
646            $_stat->{rss}->{url2link}->{ $args->{url} } = $feed->link;
647    
648            my ( $total, $updates ) = ( 0, 0 );
649          for my $entry ($feed->entries) {          for my $entry ($feed->entries) {
650                    $total++;
651    
652                    my $seen_times = $_stat->{rss}->{seen}->{$args->{channel}}->{$feed->link}->{$entry->id}++;
653                  # seen allready?                  # seen allready?
654                  return if $_rss->{$feed->link}->{seen}->{$entry->id}++ > 0;                  warn "## $seen_times ",$entry->id if $debug;
655                    next if $seen_times > 0;
656    
657                  sub prefix {                  sub prefix {
658                          my ($txt,$var) = @_;                          my ($txt,$var) = @_;
659                            $var =~ s/\s+/ /gs;
660                          $var =~ s/^\s+//g;                          $var =~ s/^\s+//g;
661                            $var =~ s/\s+$//g;
662                          return $txt . $var if $var;                          return $txt . $var if $var;
663                  }                  }
664    
665                    # fix absolute and relative links to feed entries
666                    my $link = $entry->link;
667                    if ( $link =~ m!^/! ) {
668                            my $host = $args->{url};
669                            $host =~ s!^(http://[^/]+).*$!$1!;      #!vim
670                            $link = "$host/$link";
671                    } elsif ( $link !~ m!^http! ) {
672                            $link = $args->{url} . $link;
673                    }
674    
675                  my $msg;                  my $msg;
676                  $msg .= prefix( 'From: ' , $feed->title );                  $msg .= prefix( 'From: ' , $args->{name} || $feed->title );
677                  $msg .= prefix( ' by ' , $entry->author );                  $msg .= prefix( ' by ' , $entry->author );
678                  $msg .= prefix( ' -- ' , $entry->link );                  $msg .= prefix( ' | ' , $entry->title );
679                    $msg .= prefix( ' | ' , $link );
680  #               $msg .= prefix( ' id ' , $entry->id );  #               $msg .= prefix( ' id ' , $entry->id );
681                    my @categories = $entry->category;
682                    warn "## category = ", dump( @categories ) if $debug;
683                    if ( my $tags = $entry->category ) {
684                            $tags = join(' ', @$tags) if ref($tags) eq 'ARRAY';
685                            $tags =~ s!^\s+!!;
686                            $tags =~ s!\s*$! !;
687                            $tags =~ s!,?\s+!// !g;
688                            $msg .= prefix( ' ' , $tags );
689                    }
690    
691                  if ( $args->{kernel} && $send_rss_msgs ) {                  if ( $seen_times == 0 && $send_rss_msgs ) {
                         warn "# sending to $CHANNEL\n";  
692                          $send_rss_msgs--;                          $send_rss_msgs--;
693                          $args->{kernel}->post( $IRC_ALIAS => notice => $CHANNEL, $msg );                          if ( ! $args->{private} ) {
694                                    # FIXME bug! should be save_message
695                                    save_message( channel => $args->{channel}, me => 1, nick => $NICK, message => $msg );
696    #                               $sth_insert_log->execute( $args->{channel}, 1, $NICK, $msg, 'now()' );
697                            }
698                            my ( $type, $to ) = ( 'notice', $args->{channel} );
699                            ( $type, $to ) = ( 'privmsg', $args->{nick} ) if $args->{private};
700    
701                            _log(">> RSS $type to $to:", $msg);
702                            $kernel->post( $irc => $type => $to => $msg );
703    
704                          $updates++;                          $updates++;
                         save_message( channel => $CHANNEL, me => 1, nick => $NICK, message => $msg );  
                         _log('RSS', $msg);  
705                  }                  }
706          }          }
707    
# Line 693  sub rss_fetch { Line 710  sub rss_fetch {
710          $sql .= qq{where id = } . $args->{id};          $sql .= qq{where id = } . $args->{id};
711          eval { $dbh->do( $sql ) };          eval { $dbh->do( $sql ) };
712    
713            _log "RSS $updates/$total new items from", $args->{url};
714    
715          return $updates;          return $updates;
716  }  }
717    
718  sub rss_fetch_all {  sub rss_fetch_all {
719          my $kernel = shift;          my ( $kernel, $send_rss_msgs )  = @_;
720            warn "## rss_fetch_all -- send_rss_msgs: $send_rss_msgs\n" if $debug;
721          my $sql = qq{          my $sql = qq{
722                  select id, url, name                  select id, url, name, channel, nick, private
723                  from feeds                  from feeds
724                  where active is true                  where active is true
725          };          };
726          # limit to newer feeds only if we are not sending messages out          # limit to newer feeds only if we are not sending messages out
727          $sql .= qq{     and last_update + delay < now() } if $kernel;          $sql .= qq{     and last_update + delay < now() } if defined ( $_stat->{rss}->{fetch} );
728          my $sth = $dbh->prepare( $sql );          my $sth = $dbh->prepare( $sql );
729          $sth->execute();          $sth->execute();
730          warn "# ",$sth->rows," active RSS feeds\n";          warn "# ",$sth->rows," active RSS feeds\n";
731          my $count = 0;          my $count = 0;
732          while (my $row = $sth->fetchrow_hashref) {          while (my $row = $sth->fetchrow_hashref) {
733                  warn "+++ fetch RSS feed: ",dump( $row );                  $row->{send_rss_msgs} = $send_rss_msgs if defined $send_rss_msgs;
734                  $row->{kernel} = $kernel if $kernel;                  $_stat->{rss}->{fetch}->{ $row->{url} } = $row;
735                  $count += rss_fetch( $row );                  $kernel->post(
736                            'rss-fetch',
737                            'request',
738                            'rss_response',
739                            HTTP::Request->new( GET => $row->{url} ),
740                    );
741                    warn "## queued rss-fetch ", dump( $row ) if $debug;
742          }          }
743          return "OK, fetched $count posts from " . $sth->rows . " feeds";          return "OK, scheduled " . $sth->rows . " feeds for refresh";
744  }  }
745    
 my $rss_last_poll = time();  
746    
747  sub rss_check_updates {  sub rss_check_updates {
748          my $kernel = shift;          my $kernel = shift;
749          my $t = time();          $_stat->{rss}->{last_poll} ||= time();
750          if ( $rss_last_poll - $t > $rss_min_delay ) {          my $dt = time() - $_stat->{rss}->{last_poll};
751                  $rss_last_poll = $t;          if ( $dt > $rss_min_delay ) {
752                    warn "## rss_check_updates $dt > $rss_min_delay\n";
753                    $_stat->{rss}->{last_poll} = time();
754                  _log rss_fetch_all( $kernel );                  _log rss_fetch_all( $kernel );
755          }          }
756  }  }
757    
758  # seed rss seen cache so we won't send out all items on startup  sub process_command {
759  _log rss_fetch_all;          my ( $kernel, $nick, $channel, $msg ) = @_;
760    
761  #          my $res = "unknown command '$msg', try /msg $NICK help!";
762  # POE handing part  
763  #          if ($msg =~ m/^help/i) {
764    
765                    $res = "usage: /msg $NICK comand | commands: stat - user/message stat | last - show backtrace | grep foobar - find foobar";
766    
767            } elsif ($msg =~ m/^(privmsg|notice)\s+(\S+)\s+(.*)$/i) {
768    
769                    _log ">> /$1 $2 $3";
770                    $kernel->post( $irc => $1 => $2, $3 );
771                    $res = '';
772    
773            } elsif ($msg =~ m/^stat.*?\s*(\d*)/i) {
774    
775                    my $nr = $1 || 10;
776    
777                    my $sth = $dbh->prepare(qq{
778                            select
779                                    trim(both '_' from nick) as nick,
780                                    count(*) as count,
781                                    sum(length(message)) as len
782                            from log
783                            group by trim(both '_' from nick)
784                            order by len desc,count desc
785                            limit $nr
786                    });
787                    $sth->execute();
788                    $res = "Top $nr users: ";
789                    my @users;
790                    while (my $row = $sth->fetchrow_hashref) {
791                            push @users,$row->{nick} . ': ' . $row->{count} . '/' . $row->{len} . '=' . sprintf("%.2f", $row->{len}/$row->{count});
792                    }
793                    $res .= join(" | ", @users);
794            } elsif ($msg =~ m/^last.*?\s*(\d*)/i) {
795    
796                    my $limit = $1 || meta( $nick, $channel, 'last-size' ) || 10;
797    
798                    foreach my $res (get_from_log( limit => $limit )) {
799                            _log "last: $res";
800                            $kernel->post( $irc => privmsg => $nick, $res );
801                    }
802    
803  my $SKIPPING = 0;               # if skipping, how many we've done                  $res = '';
 my $SEND_QUEUE;                 # cache  
 my $ping;                                               # ping stats  
804    
805  POE::Component::IRC->new($IRC_ALIAS);          } elsif ($msg =~ m/^(search|grep)\s+(.*)\s*$/i) {
806    
807                    my $what = $2;
808    
809                    foreach my $res (get_from_log(
810                                    limit => 20,
811                                    search => $what,
812                            )) {
813                            _log "search [$what]: $res";
814                            $kernel->post( $irc => privmsg => $nick, $res );
815                    }
816    
817                    $res = '';
818    
819            } elsif ($msg =~ m/^(?:count|poll)\s+(.*)(?:\s+(\d+))?\s*$/i) {
820    
821                    my ($what,$limit) = ($1,$2);
822                    $limit ||= 100;
823    
824                    my $stat;
825    
826                    foreach my $res (get_from_log(
827                                    limit => $limit,
828                                    search => $what,
829                                    full_rows => 1,
830                            )) {
831                            while ($res->{message} =~ s/\Q$what\E(\+|\-)//) {
832                                    $stat->{vote}->{$1}++;
833                                    $stat->{from}->{ $res->{nick} }++;
834                            }
835                    }
836    
837                    my @nicks;
838                    foreach my $nick (sort { $stat->{from}->{$a} <=> $stat->{from}->{$b} } keys %{ $stat->{from} }) {
839                            push @nicks, $nick . ( $stat->{from}->{$nick} == 1 ? '' :
840                                    "(" . $stat->{from}->{$nick} . ")"
841                            );
842                    }
843    
844                    $res =
845                            "$what ++ " . ( $stat->{vote}->{'+'} || 0 ) .
846                            " : " . ( $stat->{vote}->{'-'} || 0 ) . " --" .
847                            " from " . ( join(", ", @nicks) || 'nobody' );
848    
849                    $kernel->post( $irc => notice => $nick, $res );
850    
851            } elsif ($msg =~ m/^ping/) {
852                    $res = "ping = " . dump( $_stat->{ping} );
853            } elsif ($msg =~ m/^conf(?:ig)*\s*(last-size|twitter)*\s*(.*)/) {
854                    if ( ! defined( $1 ) ) {
855                            my $sth = $dbh->prepare(qq{ select name,value,changed from meta where nick = ? and channel = ? });
856                            $sth->execute( $nick, $channel );
857                            $res = "config for $nick on $channel";
858                            while ( my ($n,$v) = $sth->fetchrow_array ) {
859                                    $res .= " | $n = $v";
860                            }
861                    } elsif ( ! $2 ) {
862                            my $val = meta( $nick, $channel, $1 );
863                            $res = "current $1 = " . ( $val ? $val : 'undefined' );
864                    } else {
865                            my $validate = {
866                                    'last-size' => qr/^\d+/,
867                                    'twitter' => qr/^\w+\s+\w+/,
868                            };
869    
870                            my ( $op, $val ) = ( $1, $2 );
871    
872                            if ( my $regex = $validate->{$op} ) {
873                                    if ( $val =~ $regex ) {
874                                            meta( $nick, $channel, $op, $val );
875                                            $res = "saved $op = $val";
876                                    } else {
877                                            $res = "config option $op = $val doesn't validate against $regex";
878                                    }
879                            } else {
880                                    $res = "config option $op doesn't exist";
881                            }
882                    }
883            } elsif ($msg =~ m/^rss-update/) {
884                    $res = rss_fetch_all( $kernel );
885            } elsif ($msg =~ m/^rss-list/) {
886                    my $sth = $dbh->prepare(qq{ select url,name,last_update,active,channel,nick,private from feeds });
887                    $sth->execute;
888                    while (my @row = $sth->fetchrow_array) {
889                            $kernel->post( $irc => privmsg => $nick, join(' | ',@row) );
890                    }
891                    $res = '';
892            } elsif ($msg =~ m!^rss-(add|remove|stop|start|clean)(?:-(private))?\s+(http://\S+)\s*(.*)!) {
893                    my ( $command, $sub, $url, $arg ) = ( $1,$2,$3,$4 );
894    
895                    my $channel = $1 if ( $arg =~ s/\s*(#\S+)\s*// );
896                    $channel = $nick if $sub eq 'private';
897    
898                    my $sql = {
899                            add     => qq{ insert into feeds (url,name,channel,nick,private) values (?,?,?,?,?) },
900                            remove  => qq{ delete from feeds                                where url = ? and nick = ? },
901                            start   => qq{ update feeds set active = true   where url = ? },
902                            stop    => qq{ update feeds set active = false  where url = ? },
903                            clean   => qq{ update feeds set last_update = now() - delay where url = ? },
904                    };
905    
906                    if ( $command eq 'add' && ! $channel ) {
907                            $res = "ERROR: got '$msg' which doesn't have #channel in it, ignoring!";
908                    } elsif (my $q = $sql->{$command} ) {
909                            my $sth = $dbh->prepare( $q );
910                            my @data = ( $url );
911                            if ( $command eq 'add' ) {
912                                    push @data, ( $arg, $channel, $nick, $sub eq 'private' ? 1 : 0 );
913                            } elsif ( $command eq 'remove' ) {
914                                    push @data, $nick;
915                            }
916                            warn "## $command SQL $q with ",dump( @data ),"\n";
917                            eval { $sth->execute( @data ) };
918                            if ($@) {
919                                    $res = "ERROR: $@";
920                            } else {
921                                    $res = "OK, RSS executed $command" .
922                                            ( $sub ? "-$sub " : ' ' ) .
923                                            ( $channel ? "on $channel " : '' ) .
924                                            "url $url";
925                                    if ( $command eq 'clean' ) {
926                                            my $seen = $_stat->{rss}->{seen} || die "no seen?";
927                                            my $want_link = $_stat->{rss}->{url2link}->{$url} || warn "no url2link($url)";
928                                            foreach my $c ( keys %$seen ) {
929                                                    my $c_hash = $seen->{$c} || die "no seen->{$c}";
930                                                    die "not HASH with rss links but ", dump($c_hash) unless ref($c_hash) eq 'HASH';
931                                                    foreach my $link ( keys %$c_hash ) {
932                                                            next unless $link eq $want_link;
933                                                            _log "RSS removed seen $c $url $link";
934                                                    }
935                                            }
936                                    } elsif ( $command eq 'add' ) {
937                                            rss_fetch_all( $kernel );
938                                    }
939                            }
940                    } else {
941                            $res = "ERROR: don't know what to do with: $msg";
942                    }
943            } elsif ($msg =~ m/^rss-clean/) {
944                    # this makes sense because we didn't catch rss-clean http://... before!
945                    $_stat->{rss} = undef;
946                    $dbh->do( qq{ update feeds set last_update = now() - delay } );
947                    $res = rss_fetch_all( $kernel );
948            }
949    
950            return $res;
951    }
952    
953  POE::Session->create( inline_states => {  POE::Session->create( inline_states => {
954          _start => sub {                _start => sub {      
955                  $_[KERNEL]->post($IRC_ALIAS => register => 'all');                  $_[KERNEL]->post( $irc => register => 'all' );
956                  $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);                  $_[KERNEL]->post( $irc => 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" );  
957      },      },
958            irc_001 => sub {
959                    my ($kernel,$sender) = @_[KERNEL,SENDER];
960                    my $poco_object = $sender->get_heap();
961                    _log "connected to",$poco_object->server_name();
962                    $kernel->post( $sender => join => $_ ) for @channels;
963                    # seen RSS cache, so don't send out messages
964                    _log rss_fetch_all( $kernel, 0 );
965                    undef;
966            },
967    #       irc_255 => sub {        # server is done blabbing
968    #               $_[KERNEL]->post( $irc => join => $CHANNEL);
969    #       },
970      irc_public => sub {      irc_public => sub {
971                  my $kernel = $_[KERNEL];                  my $kernel = $_[KERNEL];
972                  my $nick = (split /!/, $_[ARG0])[0];                  my $nick = (split /!/, $_[ARG0])[0];
# Line 761  POE::Session->create( inline_states => { Line 975  POE::Session->create( inline_states => {
975    
976                  save_message( channel => $channel, me => 0, nick => $nick, message => $msg);                  save_message( channel => $channel, me => 0, nick => $nick, message => $msg);
977                  meta( $nick, $channel, 'last-msg', $msg );                  meta( $nick, $channel, 'last-msg', $msg );
978                    rss_check_updates( $kernel );
979      },      },
980      irc_ctcp_action => sub {      irc_ctcp_action => sub {
981                  my $kernel = $_[KERNEL];                  my $kernel = $_[KERNEL];
# Line 782  POE::Session->create( inline_states => { Line 997  POE::Session->create( inline_states => {
997      },      },
998          irc_ping => sub {          irc_ping => sub {
999                  _log( "pong ", $_[ARG0] );                  _log( "pong ", $_[ARG0] );
1000                  $ping->{ $_[ARG0] }++;                  $_stat->{ping}->{ $_[ARG0] }++;
1001                  rss_check_updates( $_[KERNEL] );                  rss_check_updates( $_[KERNEL] );
1002          },          },
1003          irc_invite => sub {          irc_invite => sub {
# Line 792  POE::Session->create( inline_states => { Line 1007  POE::Session->create( inline_states => {
1007    
1008                  _log "invited to $channel by $nick";                  _log "invited to $channel by $nick";
1009    
1010                  $_[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..." );
1011                  $_[KERNEL]->post($IRC_ALIAS => join => $channel);                  $_[KERNEL]->post( $irc => 'join' => $channel );
1012    
1013          },          },
1014          irc_msg => sub {          irc_msg => sub {
1015                  my $kernel = $_[KERNEL];                  my $kernel = $_[KERNEL];
1016                  my $nick = (split /!/, $_[ARG0])[0];                  my $nick = (split /!/, $_[ARG0])[0];
                 my $msg = $_[ARG2];  
1017                  my $channel = $_[ARG1]->[0];                  my $channel = $_[ARG1]->[0];
1018                    my $msg = $_[ARG2];
1019                  my $res = "unknown command '$msg', try /msg $NICK help!";                  warn "# ARG = ",dump( @_[ARG0,ARG1,ARG2] ) if $debug;
                 my @out;  
1020    
1021                  _log "<< $msg";                  _log "<< $msg";
1022    
1023                  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";  
                                 $_[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";  
                                 $_[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";  
                                 }  
                         }  
                 } elsif ($msg =~ m/^rss-update/) {  
                         $res = rss_fetch_all( $_[KERNEL] );  
                 } elsif ($msg =~ m/^rss-clean/) {  
                         $_rss = undef;  
                         $res = "OK, cleaned RSS cache";  
                 } elsif ($msg =~ m!^rss-(add|remove|stop|start)\s+(http://\S+)\s*(.*)!) {  
                         my $sql = {  
                                 add             => qq{ insert into feeds (url,name) values (?,?) },  
 #                               remove  => qq{ delete from feeds                                where url = ? and name = ? },  
                                 start   => qq{ update feeds set active = true   where url = ? -- ? },  
                                 stop    => qq{ update feeds set active = false  where url = ? -- ? },  
                                   
                         };  
                         if (my $q = $sql->{$1} ) {  
                                 my $sth = $dbh->prepare( $q );  
                                 warn "## SQL $q ( $2 | $3 )\n";  
                                 eval { $sth->execute( $2, $3 ) };  
                         }  
   
                         $res ||= "OK, RSS $1 : $2 - $3";  
                 }  
1024    
1025                  if ($res) {                  if ($res) {
1026                          _log ">> [$nick] $res";                          _log ">> [$nick] $res";
1027                          $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );                          $_[KERNEL]->post( $irc => privmsg => $nick, $res );
1028                  }                  }
1029    
1030                  rss_check_updates( $_[KERNEL] );                  rss_check_updates( $_[KERNEL] );
1031          },          },
1032            irc_372 => sub {
1033                    _log "<< motd",$_[ARG0],$_[ARG1];
1034            },
1035            irc_375 => sub {
1036                    _log "<< motd", $_[ARG0], "start";
1037            },
1038            irc_376 => sub {
1039                    _log "<< motd", $_[ARG0], "end";
1040            },
1041    #       irc_433 => sub {
1042    #               print "# irc_433: ",$_[ARG1], "\n";
1043    #               warn "## indetify $NICK\n";
1044    #               $_[KERNEL]->post( $irc => privmsg => 'nickserv', "IDENTIFY $NICK" );
1045    #       },
1046    #       irc_451 # please register
1047          irc_477 => sub {          irc_477 => sub {
1048                  _log "# irc_477: ",$_[ARG1];                  _log "<< irc_477: ",$_[ARG1];
1049                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "register $NICK" );                  _log ">> IDENTIFY $NICK";
1050                    $_[KERNEL]->post( $irc => privmsg => 'NickServ', "IDENTIFY $NICK" );
1051          },          },
1052          irc_505 => sub {          irc_505 => sub {
1053                  _log "# irc_505: ",$_[ARG1];                  _log "<< irc_505: ",$_[ARG1];
1054                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "register $NICK" );                  _log ">> register $NICK";
1055  #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "set hide email on" );                  $_[KERNEL]->post( $irc => privmsg => 'NickServ', "register $NICK" );
1056  #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "set email dpavlin\@rot13.org" );  #               $_[KERNEL]->post( $irc => privmsg => 'nickserv', "IDENTIFY $NICK" );
1057    #               $_[KERNEL]->post( $irc => privmsg => 'nickserv', "set hide email on" );
1058    #               $_[KERNEL]->post( $irc => privmsg => 'nickserv', "set email dpavlin\@rot13.org" );
1059          },          },
1060          irc_registered => sub {          irc_registered => sub {
1061                  _log "## registrated $NICK";                  _log "<< registered $NICK";
                 $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );  
1062          },          },
1063          irc_disconnected => sub {          irc_disconnected => sub {
1064                  _log "## disconnected, reconnecting again";                  _log "## disconnected.. sleeping for $sleep_on_error seconds and reconnecting again";
1065                  $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);                  sleep($sleep_on_error);
1066                    $_[KERNEL]->post( $irc => connect => {} );
1067          },          },
1068          irc_socketerr => sub {          irc_socketerr => sub {
1069                  _log "## socket error... sleeping for $sleep_on_error seconds and retry";                  _log "## socket error... sleeping for $sleep_on_error seconds and retry";
1070                  sleep($sleep_on_error);                  sleep($sleep_on_error);
1071                  $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);                  $_[KERNEL]->post( $irc => connect => {} );
1072            },
1073            irc_notice => sub {
1074                    _log "<< notice from ", $_[ARG0], $_[ARG1], $_[ARG2];
1075                    my $m = $_[ARG2];
1076                    if ( $m =~ m!/msg.*(NickServ).*(IDENTIFY)!i ) {
1077                            _log ">> suggested to $1 $2";
1078                            $_[KERNEL]->post( $irc => privmsg => $1, "$2 $NICK" );
1079                    } elsif ( $m =~ m!\Q$NICK\E.*registered!i ) {
1080                            _log ">> registreted, so IDENTIFY";
1081                            $_[KERNEL]->post( $irc => privmsg => 'nickserv', "IDENTIFY $NICK" );
1082                    } else {
1083                            warn "## ignore $m\n" if $debug;
1084                    }
1085            },
1086            irc_snotice => sub {
1087                    _log "<< snotice", $_[ARG0]; #dump( $_[ARG0],$_[ARG1], $_[ARG2] );
1088                    if ( $_[ARG0] =~ m!/(QUOTE)\s+(PASS\s+\d+)!i ) {
1089                            warn ">> $1 | $2\n";
1090                            $_[KERNEL]->post( $irc => lc($1) => $2);
1091                    }
1092          },          },
 #       irc_433 => sub {  
 #               print "# irc_433: ",$_[ARG1], "\n";  
 #               warn "## indetify $NICK\n";  
 #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );  
 #       },  
1093      _child => sub {},      _child => sub {},
1094      _default => sub {      _default => sub {
1095                  _log sprintf "sID:%s %s %s",                  _log '_default SID:', $_[SESSION]->ID, $_[ARG0], dump( $_[ARG1] );
1096                          $_[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',  
                     );  
                                 warn "+++ following $trailing at $FOLLOWS{$trailing}\n";  
             },  
             got_line => sub {  
                                 warn "+++ $trailing : $_[ARG0]\n";  
                                 $_[KERNEL]->post($session => my_tailed => time, $trailing, $_[ARG0]);  
             },  
            },  
           );  
       
1097      },      },
1098      my_tailed => sub {          rss_response => sub {
1099        my ($time, $file, $line) = @_[ARG0..ARG2];                  my ($request_packet, $response_packet) = @_[ARG0, ARG1];
1100        ## $time will be undef on a probe, or a time value if a real line                  my $request_object  = $request_packet->[0];
1101                    my $response_object = $response_packet->[0];
1102        ## PoCo::IRC has throttling built in, but no external visibility  
1103        ## so this is reaching "under the hood"                  my $row = delete( $_stat->{rss}->{fetch}->{ $request_object->uri } );
1104        $SEND_QUEUE ||=                  if ( $row ) {
1105          $_[KERNEL]->alias_resolve($IRC_ALIAS)->get_heap->{send_queue};                          $row->{xml} = $response_object->content;
1106                            rss_parse_xml( $_[KERNEL], $row );
1107        ## handle "no need to keep skipping" transition                  } else {
1108        if ($SKIPPING and @$SEND_QUEUE < 1) {                          warn "## can't find rss->fetch for ", $request_object->uri;
1109          $_[KERNEL]->post($IRC_ALIAS => privmsg => $CHANNEL =>                  }
1110                           "[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);  
     }  
1111     },     },
1112    );    );
1113    
1114  # http server  # http server
1115    
1116    _log "WEB archive at $url";
1117    
1118  my $httpd = POE::Component::Server::HTTP->new(  my $httpd = POE::Component::Server::HTTP->new(
1119          Port => $http_port,          Port => $http_port,
1120          PreHandler => {          PreHandler => {
# Line 1105  foreach my $c (@cols) { Line 1161  foreach my $c (@cols) {
1161          $style .= ".col-${max_color} { background: $c }\n";          $style .= ".col-${max_color} { background: $c }\n";
1162          $max_color++;          $max_color++;
1163  }  }
1164  warn "defined $max_color colors for users...\n";  _log "WEB defined $max_color colors for users...";
1165    
1166  sub root_handler {  sub root_handler {
1167          my ($request, $response) = @_;          my ($request, $response) = @_;
# Line 1127  sub root_handler { Line 1183  sub root_handler {
1183          }          }
1184    
1185          my $search = $q->param('search') || $q->param('grep') || '';          my $search = $q->param('search') || $q->param('grep') || '';
1186            my $r_url = $request->url;
1187    
1188            my @commands = qw( tags last-tag follow stat );
1189            my $commands_re = join('|',@commands);
1190    
1191          if ($request->url =~ m#/rss(?:/(tags|last-tag|follow.*)\w*(?:=(\d+))?)?#i) {          if ($r_url =~ m#/rss(?:/($commands_re.*)\w*(?:=(\d+))?)?#i) {
1192                  my $show = lc($1);                  my $show = lc($1);
1193                  my $nr = $2;                  my $nr = $2;
1194    
# Line 1137  sub root_handler { Line 1197  sub root_handler {
1197                  $response->content_type( 'application/' . lc($type) . '+xml' );                  $response->content_type( 'application/' . lc($type) . '+xml' );
1198    
1199                  my $html = '<!-- error -->';                  my $html = '<!-- error -->';
1200                  #warn "create $type feed from ",dump( @last_tags );                  #warn "create $type feed from ",dump( $cloud->last_tags );
1201    
1202                  my $feed = XML::Feed->new( $type );                  my $feed = XML::Feed->new( $type );
1203                  $feed->link( $url );                  $feed->link( $url );
1204    
1205                    my $rc = RC_OK;
1206    
1207                  if ( $show eq 'tags' ) {                  if ( $show eq 'tags' ) {
1208                          $nr ||= 50;                          $nr ||= 50;
1209                          $feed->title( "tags from $CHANNEL" );                          $feed->title( "tags from $CHANNEL" );
# Line 1169  sub root_handler { Line 1231  sub root_handler {
1231                          $feed->title( "last $nr tagged messages from $CHANNEL" );                          $feed->title( "last $nr tagged messages from $CHANNEL" );
1232                          $feed->description( "collects messages which have tags// in them" );                          $feed->description( "collects messages which have tags// in them" );
1233    
1234                          foreach my $m ( @last_tags ) {                          foreach my $m ( $cloud->last_tags ) {
1235  #                               warn dump( $m );  #                               warn dump( $m );
1236                                  #my $tags = join(' ', @{$m->{tags}} );                                  #my $tags = join(' ', @{$m->{tags}} );
1237                                  my $feed_entry = XML::Feed::Entry->new($type);                                  my $feed_entry = XML::Feed::Entry->new($type);
# Line 1211  sub root_handler { Line 1273  sub root_handler {
1273                                  $feed->add_entry( $feed_entry );                                  $feed->add_entry( $feed_entry );
1274                          }                          }
1275    
1276                    } elsif ( $show =~ m/^stat/ ) {
1277    
1278                            my $feed_entry = XML::Feed::Entry->new($type);
1279                            $feed_entry->title( "Internal stats" );
1280                            $feed_entry->content(
1281                                    '<![CDATA[<pre>' . dump( $_stat ) . '</pre>]]>'
1282                            );
1283                            $feed->add_entry( $feed_entry );
1284    
1285                  } else {                  } else {
1286                          _log "unknown rss request ",$request->url;                          _log "WEB unknown rss request $r_url";
1287                          return RC_DENY;                          $feed->title( "unknown $r_url" );
1288                            foreach my $c ( @commands ) {
1289                                    my $feed_entry = XML::Feed::Entry->new($type);
1290                                    $feed_entry->title( "rss/$c" );
1291                                    $feed_entry->link( "$url/rss/$c" );
1292                                    $feed->add_entry( $feed_entry );
1293                            }
1294                            $rc = RC_DENY;
1295                  }                  }
1296    
1297                  $response->content( $feed->as_xml );                  eval { $response->content( $feed->as_xml ); };
1298                  return RC_OK;                  $rc = RC_INTERNAL_SERVER_ERROR if $@;
1299                    return $rc;
1300          }          }
1301    
1302          if ( $@ ) {          if ( $@ ) {
# Line 1275  sub root_handler { Line 1354  sub root_handler {
1354                          }                          }
1355                          $cal->setcontent($dd, qq[                          $cal->setcontent($dd, qq[
1356                                  <a href="$url?date=$row->{date}">$row->{nr}</a><br/>$row->{len}                                  <a href="$url?date=$row->{date}">$row->{nr}</a><br/>$row->{len}
1357                          ]);                          ]) if $cal;
1358                                                    
1359                  }                  }
1360                  $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 1283  sub root_handler { Line 1362  sub root_handler {
1362          } else {          } else {
1363                  $html .= join("</p><p>",                  $html .= join("</p><p>",
1364                          get_from_log(                          get_from_log(
1365                                  limit => ( $q->param('last') || $q->param('date') ) ? undef : 100,                                  limit => ( $q->param('date') ? undef : $q->param('last') || 100 ),
1366                                  search => $search || undef,                                  search => $search || undef,
1367                                  tag => $q->param('tag') || undef,                                  tag => $q->param('tag') || undef,
1368                                  date => $q->param('date') || undef,                                  date => $q->param('date') || undef,
# Line 1314  sub root_handler { Line 1393  sub root_handler {
1393  }  }
1394    
1395  POE::Kernel->run;  POE::Kernel->run;
1396    
1397    =head1 TagCloud
1398    
1399    Extended L<HTML::TagCloud>
1400    
1401    =cut
1402    
1403    package TagCloud;
1404    use warnings;
1405    use strict;
1406    use HTML::TagCloud;
1407    use base 'HTML::TagCloud';
1408    use Data::Dump qw/dump/;
1409    
1410    =head2 html
1411    
1412    Generate html with number of tags in title of link
1413    
1414    =cut
1415    
1416    sub html {
1417            my($self, $limit) = @_;
1418            my @tags=$self->tags($limit);
1419    
1420            my $ntags = scalar(@tags);
1421            if ($ntags == 0) {
1422                    return "";
1423    #       } elsif ($ntags == 1) {
1424    #               my $tag = $tags[0];
1425    #               return qq{<div id="htmltagcloud"><span class="tagcloud1"><a href="}.
1426    #               $tag->{url}.qq{">}.$tag->{name}.qq{</a></span></div>\n};
1427            }
1428    
1429      my $html = qq{<div id="htmltagcloud">};
1430      foreach my $tag ( sort { lc($a->{name}) cmp lc($b->{name}) } @tags) {
1431        $html .=  sprintf(qq{<span class="tag tagcloud%d"><a href="%s" title="%s">%s</a></span>\n},
1432                    $tag->{level}, $tag->{url}, $tag->{count}, $tag->{name}
1433            );
1434      }
1435      $html .= qq{</div>};
1436      return $html;
1437    }
1438    
1439    =head2 last_tags
1440    
1441      my @tags = $cloud->last_tags;
1442    
1443    =cut
1444    
1445    my @last_tags;
1446    sub last_tags {
1447            return @last_tags;
1448    }
1449    
1450    =head2 add_tag
1451    
1452     $cloud->add_tag( id => 42, message => 'irc message', nick => 'foobar' [, me => 1 ] );
1453    
1454    =cut
1455    
1456    
1457    sub add_tag {
1458            my $self = shift;
1459            my $arg = {@_};
1460    
1461            return unless ($arg->{id} && $arg->{message});
1462    
1463            my $m = $arg->{message};
1464    
1465            my @tags;
1466    
1467            while ($m =~ s#$tag_regex##s) {
1468                    my $tag = $1;
1469                    next if (! $tag || $tag =~ m/https?:/i);
1470                    push @{ $tags->{$tag} }, $arg->{id};
1471                    #warn "+tag $tag: $arg->{id}\n";
1472                    $self->add($tag, "$url?tag=$tag", scalar @{$tags->{$tag}});
1473                    push @tags, $tag;
1474    
1475            }
1476    
1477            if ( @tags ) {
1478                    pop @last_tags if $#last_tags == $last_x_tags;
1479                    unshift @last_tags, { tags => [ @tags ], %$arg };
1480            }
1481    
1482    }
1483    
1484    =head2 seed_tags
1485    
1486    Read all tags from database and create in-memory cache for tags
1487    
1488    =cut
1489    
1490    sub seed_tags {
1491            my $self = shift;
1492            my $sth = $dbh->prepare(qq{ select id,message,nick,me,time from log where message like '%//%' order by time asc });
1493            $sth->execute;
1494            while (my $row = $sth->fetchrow_hashref) {
1495                    $self->add_tag( %$row );
1496            }
1497    
1498            foreach my $tag (keys %$tags) {
1499                    $self->add($tag, "$url?tag=$tag", scalar @{$tags->{$tag}});
1500            }
1501    }
1502    
Legend:
Removed from v.86  
changed lines
  Added in v.140
  ViewVC Help
Powered by ViewVC 1.1.26