/[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 149 by dpavlin, Sat Oct 8 18:33:36 2011 UTC
# Line 2  Line 2 
2  use strict;  use strict;
3  $|++;  $|++;
4    
5    use POE qw(Component::IRC Component::Server::HTTP Component::Client::HTTP);
6    use HTTP::Status;
7    use DBI;
8    use Regexp::Common qw /URI/;
9    use CGI::Simple;
10    use POSIX qw/strftime/;
11    use HTML::CalendarMonthSimple;
12    use Getopt::Long;
13    use DateTime;
14    use URI::Escape;
15    use Data::Dump qw/dump/;
16    use DateTime::Format::ISO8601;
17    use Carp qw/confess/;
18    use XML::Feed;
19    use DateTime::Format::Flexible;
20    use Encode;
21    #use Redis 2.0;
22    
23  =head1 NAME  =head1 NAME
24    
25  irc-logger.pl  irc-logger.pl
# Line 20  Import log from C<dircproxy> to C<irc-lo Line 38  Import log from C<dircproxy> to C<irc-lo
38    
39  =item --log=irc-logger.log  =item --log=irc-logger.log
40    
 Name of log file  
   
 =item --follow=file.log  
   
 Follows new messages in file  
   
41  =back  =back
42    
43  =head1 DESCRIPTION  =head1 DESCRIPTION
# Line 36  log all conversation on irc channel Line 48  log all conversation on irc channel
48    
49  ## CONFIG  ## CONFIG
50    
51    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`;  my $HOSTNAME = `hostname -f`;
61  chomp($HOSTNAME);  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  # default log to follow and announce messages  if ( $HOSTNAME =~ m/llin/ ) {
67  my $follows_path = 'follows.log';          $irc_config->{nick} = 'irc-logger-llin';
68    #       $irc_config = {
69    #               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    
 # log output encoding  
 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;
# Line 66  my $last_x_tags = 50; Line 93  my $last_x_tags = 50;
93    
94  # don't pull rss feeds more often than this  # don't pull rss feeds more often than this
95  my $rss_min_delay = 60;  my $rss_min_delay = 60;
 $rss_min_delay = 15;  
96    
97  my $http_port = $NICK =~ m/-dev/ ? 8001 : 8000;  my $http_port = $NICK =~ m/-dev/ ? 8001 : 8000;
98    
# Line 74  my $url = "http://$HOSTNAME:$http_port"; Line 100  my $url = "http://$HOSTNAME:$http_port";
100    
101  ## END CONFIG  ## END CONFIG
102    
 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;  
   
103  my $use_twitter = 1;  my $use_twitter = 1;
104  eval { require Net::Twitter; };  eval { require Net::Twitter; };
105  $use_twitter = 0 if ($@);  $use_twitter = 0 if ($@);
# Line 100  my $import_dircproxy; Line 108  my $import_dircproxy;
108  my $log_path;  my $log_path;
109  GetOptions(  GetOptions(
110          'import-dircproxy:s' => \$import_dircproxy,          'import-dircproxy:s' => \$import_dircproxy,
         'follows:s' => \$follows_path,  
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          my $out = strftime($TIMESTAMP,localtime()) . ' ' . join(" ",@_) . $/;          print strftime($TIMESTAMP,localtime()) . ' ' . join(" ",map { ref($_) ? dump( $_ ) : $_ } @_) . $/;
         from_to( $out, 'UTF-8', $ENCODING );  
         print $out;  
121  }  }
122    
123  # 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;  
 }  
124    
 add_follow_path( $follows_path ) if ( -e $follows_path );  
125    
126  # HTML formatters  # HTML formatters
127    
128  my %escape = ('<'=>'&lt;', '>'=>'&gt;', '&'=>'&amp;', '"'=>'&quot;');  my %escape = ('<'=>'&lt;', '>'=>'&gt;', '&'=>'&amp;', '"'=>'&quot;');
129  my $escape_re  = join '|' => keys %escape;  my $escape_re  = join '|' => keys %escape;
130    
131  my $tag_regex = '\b([\w-_]+)//';  my $tag_regex = '\b([\w\-_]+)//';
132    
133  my %nick_enumerator;  my %nick_enumerator;
134  my $max_color = 0;  my $max_color = 0;
# Line 151  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) . '}';                          eval { $t = 'uri_unescape{' . uri_escape($t, '^a-zA-Z0-9') . '}'; };
144                            return $t;
145                  }                  }
146    
147                  $m =~ s/($escape_re)/$escape{$1}/gs;                  $m =~ s/($escape_re)/$escape{$1}/gs;
148                  $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;
149                  $m =~ s#\/(\w+)\/#<i>$1</i>#gs;  #               $m =~ s#\/(\w+)\/#<i>$1</i>#gs;
150                  $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;
151                  $m =~ s#\*(\w+)\*#<b>$1</b>#gs;                  $m =~ s#\*(\w+)\*#<b>$1</b>#gs;
152                  $m =~ s#_(\w+)_#<u>$1</u>#gs;                  $m =~ s#_(\w+)_#<u>$1</u>#gs;
# Line 176  my $filter = { Line 166  my $filter = {
166          },          },
167  };  };
168    
169    # POE IRC
170    my $poe_irc = POE::Component::IRC->spawn( %$irc_config ) or
171            die "can't start ", dump( $irc_config ), ": $!";
172    
173    my $irc = $poe_irc->session_id();
174    _log "IRC session_id $irc";
175    
176  my $dbh = DBI->connect($DSN,"","", { RaiseError => 1, AutoCommit => 1 }) || die $DBI::errstr;  my $dbh = DBI->connect($DSN,"","", { RaiseError => 1, AutoCommit => 1 }) || die $DBI::errstr;
177  $dbh->do( qq{ set client_encoding = 'UTF-8' } );  $dbh->do( qq{ set client_encoding = 'UTF-8' } );
178    
# Line 212  create table feeds ( Line 209  create table feeds (
209          name text,          name text,
210          delay interval not null default '5 min',          delay interval not null default '5 min',
211          active boolean default true,          active boolean default true,
212            channel text not null,
213            nick text not null,
214            private boolean default false,
215          last_update timestamp default 'now()',          last_update timestamp default 'now()',
216          polls int default 0,          polls int default 0,
217          updates int default 0          updates int default 0
218  );  );
219  create unique index feeds_url on feeds(url);  create unique index feeds_url on feeds(url);
220  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');
221          },          },
222  };  };
223    
# Line 257  sub meta { Line 257  sub meta {
257    
258                  eval { $sth->execute( $value, $nick, $channel, $name ) };                  eval { $sth->execute( $value, $nick, $channel, $name ) };
259    
260                  # error or no result                  if ( $@ ) {
261                  if ( $@ || ! $sth->rows ) {                          # error
262                            _log("META ERROR: $@");
263                    } elsif ( ! $sth->rows ) {
264                            # no result -> add new
265                          $sth = $dbh->prepare(qq{ insert into meta (value,nick,channel,name,changed) values (?,?,?,?,now()) });                          $sth = $dbh->prepare(qq{ insert into meta (value,nick,channel,name,changed) values (?,?,?,?,now()) });
266                          $sth->execute( $value, $nick, $channel, $name );                          eval { $sth->execute( $value, $nick, $channel, $name ); };
267                          _log "created $nick/$channel/$name = $value";                          if ( $@ ) {
268                                    _log "META ERROR: $@";
269                            } else {
270                                    _log "META: created $nick/$channel/$name = $value\n";
271                            }
272                  } else {                  } else {
273                          _log "updated $nick/$channel/$name = $value ";                          _log "META: updated $nick/$channel/$name = $value\n";
274                  }                  }
275    
276                  return $value;                  return $value;
# Line 273  sub meta { Line 280  sub meta {
280                  my $sth = $dbh->prepare(qq{ select value,changed from meta where nick = ? and channel = ? and name = ? });                  my $sth = $dbh->prepare(qq{ select value,changed from meta where nick = ? and channel = ? and name = ? });
281                  $sth->execute( $nick, $channel, $name );                  $sth->execute( $nick, $channel, $name );
282                  my ($v,$c) = $sth->fetchrow_array;                  my ($v,$c) = $sth->fetchrow_array;
283                  _log "fetched $nick/$channel/$name = $v [$c]";                  warn "## fetched $nick/$channel/$name = $v [$c]\n";
284                  return ($v,$c) if wantarray;                  return ($v,$c) if wantarray;
285                  return $v;                  return $v;
286    
# Line 282  sub meta { Line 289  sub meta {
289    
290    
291    
292  my $sth = $dbh->prepare(qq{  my $sth_insert_log = $dbh->prepare(qq{
293  insert into log  insert into log
294          (channel, me, nick, message, time)          (channel, me, nick, message, time)
295  values (?,?,?,?,?)  values (?,?,?,?,?)
# Line 370  sub get_from_log { Line 377  sub get_from_log {
377    
378          my @where;          my @where;
379          my @args;          my @args;
380            my $msg;
381    
382          if (my $search = $args->{search}) {          if (my $search = $args->{search}) {
383                  $search =~ s/^\s+//;                  $search =~ s/^\s+//;
384                  $search =~ s/\s+$//;                  $search =~ s/\s+$//;
385                  push @where, 'message ilike ? or nick ilike ?';                  push @where, 'message ilike ? or nick ilike ?';
386                  push @args, ( ( '%' . $search . '%' ) x 2 );                  push @args, ( ( '%' . $search . '%' ) x 2 );
387                  _log "search for '$search'";                  $msg = "Search for '$search'";
388          }          }
389    
390          if ($args->{tag} && $tags->{ $args->{tag} }) {          if ($args->{tag} && $tags->{ $args->{tag} }) {
391                  push @where, 'id in (' . join(',', @{ $tags->{ $args->{tag} } }) . ')';                  push @where, 'id in (' . join(',', @{ $tags->{ $args->{tag} } }) . ')';
392                  _log "search for tags $args->{tag}";                  $msg = "Search for tags $args->{tag}";
393          }          }
394    
395          if (my $date = $args->{date} ) {          if (my $date = $args->{date} ) {
396                  $date = check_date( $date );                  $date = check_date( $date );
397                  push @where, 'date(time) = ?';                  push @where, 'date(time) = ?';
398                  push @args, $date;                  push @args, $date;
399                  _log "search for date $date";                  $msg = "search for date $date";
400          }          }
401    
402          $sql .= " where " . join(" and ", @where) if @where;          $sql .= " where " . join(" and ", @where) if @where;
# Line 402  sub get_from_log { Line 410  sub get_from_log {
410          eval { $sth->execute( @args ) };          eval { $sth->execute( @args ) };
411          return if $@;          return if $@;
412    
413            my $nr_results = $sth->rows;
414    
415          my $last_row = {          my $last_row = {
416                  date => '',                  date => '',
417                  time => '',                  time => '',
# Line 422  sub get_from_log { Line 432  sub get_from_log {
432    
433          return @rows if ($args->{full_rows});          return @rows if ($args->{full_rows});
434    
435          my @msgs = (          $msg .= ' produced ' . (
436                  "Showing " . ($#rows + 1) . " messages..."                  $nr_results == 0 ? 'no results' :
437                    $nr_results == 0 ? 'one result' :
438                            $nr_results . ' results'
439          );          );
440    
441            my @msgs = ( $msg );
442    
443          if ($context) {          if ($context) {
444                  my @ids = @rows;                  my @ids = @rows;
445                  @rows = ();                  @rows = ();
# Line 482  sub get_from_log { Line 496  sub get_from_log {
496  #                       $row->{nick} = $nick;  #                       $row->{nick} = $nick;
497  #               }  #               }
498    
499                    $append = 0 if $row->{me};
500    
501                  if ($last_row->{nick} ne $nick) {                  if ($last_row->{nick} ne $nick) {
502                          # obfu way to find format for me_nick if needed or fallback to default                          # obfu way to find format for me_nick if needed or fallback to default
503                          my $fmt = $row->{me} ? ( $args->{fmt}->{me_nick} || $args->{fmt}->{nick} ) : $args->{fmt}->{nick};                          my $fmt = $row->{me} ? ( $args->{fmt}->{me_nick} || $args->{fmt}->{nick} ) : $args->{fmt}->{nick};
# Line 518  sub get_from_log { Line 534  sub get_from_log {
534    
535  # tags support  # tags support
536    
537  my $cloud = HTML::TagCloud->new;  my $cloud = TagCloud->new;
538    $cloud->seed_tags;
 =head2 add_tag  
   
  add_tag( id => 42, message => 'irc message', 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;  
   
539    
540  =head2 save_message  =head2 save_message
541    
# Line 598  sub save_message { Line 559  sub save_message {
559          $a->{me} ||= 0;          $a->{me} ||= 0;
560          $a->{time} ||= strftime($TIMESTAMP,localtime());          $a->{time} ||= strftime($TIMESTAMP,localtime());
561    
562          _log          _log "ARCHIVE",
563                  $a->{channel}, " ",                  $a->{channel}, " ",
564                  $a->{me} ? "***" . $a->{nick} : "<" . $a->{nick} . ">",                  $a->{me} ? "***" . $a->{nick} : "<" . $a->{nick} . ">",
565                  " " . $a->{message};                  " " . $a->{message};
566    
567          $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}); };
568          add_tag( id => $dbh->last_insert_id(undef,undef,"log",undef), %$a );  
569            eval {
570            my @channel = ( 'channel' , $a->{channel}, $a->{nick} );
571            push @channel, 'me' if $a->{me};
572    #       my $redis = Redis->new( server => '192.168.1.61:6379' );
573    #       $redis->publish( join(' ',@channel), $a->{message} );
574            };
575    
576            if ( $@ ) {
577                    _log "ERROR: can't archive ", $a->{message};
578            } else {
579                    $cloud->add_tag( id => $dbh->last_insert_id(undef,undef,"log",undef), %$a );
580            }
581  }  }
582    
583    
# Line 646  if ($import_dircproxy) { Line 619  if ($import_dircproxy) {
619  # RSS follow  # RSS follow
620  #  #
621    
622  my $_rss;  my $_stat;
623    
624    POE::Component::Client::HTTP->spawn(
625            Alias   => 'rss-fetch',
626            Timeout => 30,
627    );
628    
629    =head2 rss_parse_xml
630    
631  sub rss_fetch {    rss_parse_xml({
632          my ($args) = @_;          url => 'http://www.example.com/rss',
633            send_rss_msgs => 42,
634      });
635    
636    =cut
637    
638    sub rss_parse_xml {
639            my ($kernel,$args) = @_;
640    
641            warn "## rss_parse_xml ",dump( $args ) if $debug;
642    
643          # 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?
644          my $send_rss_msgs = 1;          my $send_rss_msgs = $args->{send_rss_msgs};
645            $send_rss_msgs = 1 if ! defined $send_rss_msgs;
646    
647            warn "## RSS fetch first $send_rss_msgs items from", $args->{url} if $debug;
648    
649          my $feed = XML::Feed->parse(URI->new( $args->{url} ));          my $feed;
650            eval { $feed = XML::Feed->parse( \$args->{xml} ) };
651          if ( ! $feed ) {          if ( ! $feed ) {
652                  _log("can't fetch RSS ", $args->{url});                  _log "can't fetch RSS ", $args->{url}, XML::Feed->errstr;
653                  return;                  return;
654          }          }
655          my $updates = 0;  
656            $_stat->{rss}->{url2link}->{ $args->{url} } = $feed->link;
657    
658            my ( $total, $updates ) = ( 0, 0 );
659          for my $entry ($feed->entries) {          for my $entry ($feed->entries) {
660                    $total++;
661    
662                    my $seen_times = $_stat->{rss}->{seen}->{$args->{channel}}->{$feed->link}->{$entry->id}++;
663                  # seen allready?                  # seen allready?
664                  return if $_rss->{$feed->link}->{seen}->{$entry->id}++ > 0;                  warn "## $seen_times ",$entry->id if $debug;
665                    next if $seen_times > 0;
666    
667                  sub prefix {                  sub prefix {
668                          my ($txt,$var) = @_;                          my ($txt,$var) = @_;
669                            $var =~ s/\s+/ /gs;
670                          $var =~ s/^\s+//g;                          $var =~ s/^\s+//g;
671                            $var =~ s/\s+$//g;
672                          return $txt . $var if $var;                          return $txt . $var if $var;
673                  }                  }
674    
675                    # fix absolute and relative links to feed entries
676                    my $link = $entry->link;
677                    if ( $link =~ m!^/! ) {
678                            my $host = $args->{url};
679                            $host =~ s!^(http://[^/]+).*$!$1!;      #!vim
680                            $link = "$host/$link";
681                    } elsif ( $link !~ m!^http! ) {
682                            $link = $args->{url} . $link;
683                    }
684    
685                  my $msg;                  my $msg;
686                  $msg .= prefix( 'From: ' , $feed->title );                  $msg .= prefix( 'From: ' , $args->{name} || $feed->title );
687                  $msg .= prefix( ' by ' , $entry->author );                  $msg .= prefix( ' by ' , $entry->author );
688                  $msg .= prefix( ' -- ' , $entry->link );                  $msg .= prefix( ' | ' , $entry->title );
689                    $msg .= prefix( ' | ' , $link );
690  #               $msg .= prefix( ' id ' , $entry->id );  #               $msg .= prefix( ' id ' , $entry->id );
691                    my @categories = $entry->category;
692                    warn "## category = ", dump( @categories ) if $debug;
693                    if ( my $tags = $entry->category ) {
694                            $tags = join(' ', @$tags) if ref($tags) eq 'ARRAY';
695                            $tags =~ s!^\s+!!;
696                            $tags =~ s!\s*$! !;
697                            $tags =~ s!,?\s+!// !g;
698                            $msg .= prefix( ' ' , $tags );
699                    }
700    
701                  if ( $args->{kernel} && $send_rss_msgs ) {                  if ( $seen_times == 0 && $send_rss_msgs ) {
                         warn "# sending to $CHANNEL\n";  
702                          $send_rss_msgs--;                          $send_rss_msgs--;
703                          $args->{kernel}->post( $IRC_ALIAS => notice => $CHANNEL, $msg );                          if ( ! $args->{private} ) {
704                                    # FIXME bug! should be save_message
705                                    save_message( channel => $args->{channel}, me => 1, nick => $NICK, message => $msg );
706    #                               $sth_insert_log->execute( $args->{channel}, 1, $NICK, $msg, 'now()' );
707                            }
708                            my ( $type, $to ) = ( 'notice', $args->{channel} );
709                            ( $type, $to ) = ( 'privmsg', $args->{nick} ) if $args->{private};
710    
711                            _log(">> RSS $type to $to:", $msg);
712                            $kernel->post( $irc => $type => $to => $msg );
713    
714                          $updates++;                          $updates++;
                         save_message( channel => $CHANNEL, me => 1, nick => $NICK, message => $msg );  
                         _log('RSS', $msg);  
715                  }                  }
716          }          }
717    
# Line 693  sub rss_fetch { Line 720  sub rss_fetch {
720          $sql .= qq{where id = } . $args->{id};          $sql .= qq{where id = } . $args->{id};
721          eval { $dbh->do( $sql ) };          eval { $dbh->do( $sql ) };
722    
723            _log "RSS $updates/$total new items from", $args->{url};
724    
725          return $updates;          return $updates;
726  }  }
727    
728  sub rss_fetch_all {  sub rss_fetch_all {
729          my $kernel = shift;          my ( $kernel, $send_rss_msgs )  = @_;
730            warn "## rss_fetch_all -- send_rss_msgs: $send_rss_msgs\n" if $debug;
731          my $sql = qq{          my $sql = qq{
732                  select id, url, name                  select id, url, name, channel, nick, private
733                  from feeds                  from feeds
734                  where active is true                  where active is true
735          };          };
736          # limit to newer feeds only if we are not sending messages out          # limit to newer feeds only if we are not sending messages out
737          $sql .= qq{     and last_update + delay < now() } if $kernel;          $sql .= qq{     and last_update + delay < now() } if defined ( $_stat->{rss}->{fetch} );
738          my $sth = $dbh->prepare( $sql );          my $sth = $dbh->prepare( $sql );
739          $sth->execute();          $sth->execute();
740          warn "# ",$sth->rows," active RSS feeds\n";          warn "# ",$sth->rows," active RSS feeds\n";
741          my $count = 0;          my $count = 0;
742          while (my $row = $sth->fetchrow_hashref) {          while (my $row = $sth->fetchrow_hashref) {
743                  warn "+++ fetch RSS feed: ",dump( $row );                  $row->{send_rss_msgs} = $send_rss_msgs if defined $send_rss_msgs;
744                  $row->{kernel} = $kernel if $kernel;                  $_stat->{rss}->{fetch}->{ $row->{url} } = $row;
745                  $count += rss_fetch( $row );                  $kernel->post(
746                            'rss-fetch',
747                            'request',
748                            'rss_response',
749                            HTTP::Request->new( GET => $row->{url} ),
750                    );
751                    warn "## queued rss-fetch ", dump( $row ) if $debug;
752          }          }
753          return "OK, fetched $count posts from " . $sth->rows . " feeds";          return "OK, scheduled " . $sth->rows . " feeds for refresh";
754  }  }
755    
 my $rss_last_poll = time();  
756    
757  sub rss_check_updates {  sub rss_check_updates {
758          my $kernel = shift;          my $kernel = shift;
759          my $t = time();          $_stat->{rss}->{last_poll} ||= time();
760          if ( $rss_last_poll - $t > $rss_min_delay ) {          my $dt = time() - $_stat->{rss}->{last_poll};
761                  $rss_last_poll = $t;          if ( $dt > $rss_min_delay ) {
762                    warn "## rss_check_updates $dt > $rss_min_delay\n";
763                    $_stat->{rss}->{last_poll} = time();
764                  _log rss_fetch_all( $kernel );                  _log rss_fetch_all( $kernel );
765          }          }
766  }  }
767    
768  # seed rss seen cache so we won't send out all items on startup  sub process_command {
769  _log rss_fetch_all;          my ( $kernel, $nick, $channel, $msg ) = @_;
770    
771  #          my $res = "unknown command '$msg', try /msg $NICK help!";
772  # POE handing part  
773  #          if ($msg =~ m/^help/i) {
774    
775                    $res = "usage: /msg $NICK comand | commands: stat - user/message stat | last - show backtrace | grep foobar - find foobar";
776    
777            } elsif ($msg =~ m/^(privmsg|notice)\s+(\S+)\s+(.*)$/i) {
778    
779                    _log ">> /$1 $2 $3";
780                    $kernel->post( $irc => $1 => $2, $3 );
781                    $res = '';
782    
783            } elsif ($msg =~ m/^stat.*?\s*(\d*)/i) {
784    
785                    my $nr = $1 || 10;
786    
787                    my $sth = $dbh->prepare(qq{
788                            select
789                                    trim(both '_' from nick) as nick,
790                                    count(*) as count,
791                                    sum(length(message)) as len
792                            from log
793                            group by trim(both '_' from nick)
794                            order by len desc,count desc
795                            limit $nr
796                    });
797                    $sth->execute();
798                    $res = "Top $nr users: ";
799                    my @users;
800                    while (my $row = $sth->fetchrow_hashref) {
801                            push @users,$row->{nick} . ': ' . $row->{count} . '/' . $row->{len} . '=' . sprintf("%.2f", $row->{len}/$row->{count});
802                    }
803                    $res .= join(" | ", @users);
804            } elsif ($msg =~ m/^last.*?\s*(\d*)/i) {
805    
806                    my $limit = $1 || meta( $nick, $channel, 'last-size' ) || 10;
807    
808                    foreach my $res (get_from_log( limit => $limit )) {
809                            _log "last: $res";
810                            $kernel->post( $irc => privmsg => $nick, $res );
811                    }
812    
813                    $res = '';
814    
815            } elsif ($msg =~ m/^(search|grep)\s+(.*)\s*$/i) {
816    
817                    my $what = $2;
818    
819                    foreach my $res (get_from_log(
820                                    limit => 20,
821                                    search => $what,
822                            )) {
823                            _log "search [$what]: $res";
824                            $kernel->post( $irc => privmsg => $nick, $res );
825                    }
826    
827                    $res = '';
828    
829            } elsif ($msg =~ m/^(?:count|poll)\s+(.*)(?:\s+(\d+))?\s*$/i) {
830    
831                    my ($what,$limit) = ($1,$2);
832                    $limit ||= 100;
833    
834                    my $stat;
835    
836                    foreach my $res (get_from_log(
837                                    limit => $limit,
838                                    search => $what,
839                                    full_rows => 1,
840                            )) {
841                            while ($res->{message} =~ s/\Q$what\E(\+|\-)//) {
842                                    $stat->{vote}->{$1}++;
843                                    $stat->{from}->{ $res->{nick} }++;
844                            }
845                    }
846    
847                    my @nicks;
848                    foreach my $nick (sort { $stat->{from}->{$a} <=> $stat->{from}->{$b} } keys %{ $stat->{from} }) {
849                            push @nicks, $nick . ( $stat->{from}->{$nick} == 1 ? '' :
850                                    "(" . $stat->{from}->{$nick} . ")"
851                            );
852                    }
853    
854                    $res =
855                            "$what ++ " . ( $stat->{vote}->{'+'} || 0 ) .
856                            " : " . ( $stat->{vote}->{'-'} || 0 ) . " --" .
857                            " from " . ( join(", ", @nicks) || 'nobody' );
858    
859                    $kernel->post( $irc => notice => $nick, $res );
860    
861            } elsif ($msg =~ m/^ping/) {
862                    $res = "ping = " . dump( $_stat->{ping} );
863            } elsif ($msg =~ m/^conf(?:ig)*\s*(last-size|twitter)*\s*(.*)/) {
864                    if ( ! defined( $1 ) ) {
865                            my $sth = $dbh->prepare(qq{ select name,value,changed from meta where nick = ? and channel = ? });
866                            $sth->execute( $nick, $channel );
867                            $res = "config for $nick on $channel";
868                            while ( my ($n,$v) = $sth->fetchrow_array ) {
869                                    $res .= " | $n = $v";
870                            }
871                    } elsif ( ! $2 ) {
872                            my $val = meta( $nick, $channel, $1 );
873                            $res = "current $1 = " . ( $val ? $val : 'undefined' );
874                    } else {
875                            my $validate = {
876                                    'last-size' => qr/^\d+/,
877                                    'twitter' => qr/^\w+\s+\w+/,
878                            };
879    
880                            my ( $op, $val ) = ( $1, $2 );
881    
882                            if ( my $regex = $validate->{$op} ) {
883                                    if ( $val =~ $regex ) {
884                                            meta( $nick, $channel, $op, $val );
885                                            $res = "saved $op = $val";
886                                    } else {
887                                            $res = "config option $op = $val doesn't validate against $regex";
888                                    }
889                            } else {
890                                    $res = "config option $op doesn't exist";
891                            }
892                    }
893            } elsif ($msg =~ m/^rss-update/) {
894                    $res = rss_fetch_all( $kernel );
895            } elsif ($msg =~ m/^rss-list/) {
896                    my $sth = $dbh->prepare(qq{ select url,name,last_update,active,channel,nick,private from feeds });
897                    $sth->execute;
898                    while (my @row = $sth->fetchrow_array) {
899                            $kernel->post( $irc => privmsg => $nick, join(' | ',@row) );
900                    }
901                    $res = '';
902            } elsif ($msg =~ m!^rss-(add|remove|stop|start|clean)(?:-(private))?\s+(http://\S+)\s*(.*)!) {
903                    my ( $command, $sub, $url, $arg ) = ( $1,$2,$3,$4 );
904    
905                    my $channel = $1 if ( $arg =~ s/\s*(#\S+)\s*// );
906                    $channel = $nick if $sub eq 'private';
907    
908                    my $sql = {
909                            add     => qq{ insert into feeds (url,name,channel,nick,private) values (?,?,?,?,?) },
910                            remove  => qq{ delete from feeds                                where url = ? and nick = ? },
911                            start   => qq{ update feeds set active = true   where url = ? },
912                            stop    => qq{ update feeds set active = false  where url = ? },
913                            clean   => qq{ update feeds set last_update = now() - delay where url = ? },
914                    };
915    
916  my $SKIPPING = 0;               # if skipping, how many we've done                  if ( $command eq 'add' && ! $channel ) {
917  my $SEND_QUEUE;                 # cache                          $res = "ERROR: got '$msg' which doesn't have #channel in it, ignoring!";
918  my $ping;                                               # ping stats                  } elsif (my $q = $sql->{$command} ) {
919                            my $sth = $dbh->prepare( $q );
920                            my @data = ( $url );
921                            if ( $command eq 'add' ) {
922                                    push @data, ( $arg, $channel, $nick, $sub eq 'private' ? 1 : 0 );
923                            } elsif ( $command eq 'remove' ) {
924                                    push @data, $nick;
925                            }
926                            warn "## $command SQL $q with ",dump( @data ),"\n";
927                            eval { $sth->execute( @data ) };
928                            if ($@) {
929                                    $res = "ERROR: $@";
930                            } else {
931                                    $res = "OK, RSS executed $command" .
932                                            ( $sub ? "-$sub " : ' ' ) .
933                                            ( $channel ? "on $channel " : '' ) .
934                                            "url $url";
935                                    if ( $command eq 'clean' ) {
936                                            my $seen = $_stat->{rss}->{seen} || die "no seen?";
937                                            my $want_link = $_stat->{rss}->{url2link}->{$url} || warn "no url2link($url)";
938                                            foreach my $c ( keys %$seen ) {
939                                                    my $c_hash = $seen->{$c} || die "no seen->{$c}";
940                                                    die "not HASH with rss links but ", dump($c_hash) unless ref($c_hash) eq 'HASH';
941                                                    foreach my $link ( keys %$c_hash ) {
942                                                            next unless $link eq $want_link;
943                                                            _log "RSS removed seen $c $url $link";
944                                                    }
945                                            }
946                                    } elsif ( $command eq 'add' ) {
947                                            rss_fetch_all( $kernel );
948                                    }
949                            }
950                    } else {
951                            $res = "ERROR: don't know what to do with: $msg";
952                    }
953            } elsif ($msg =~ m/^rss-clean/) {
954                    # this makes sense because we didn't catch rss-clean http://... before!
955                    $_stat->{rss} = undef;
956                    $dbh->do( qq{ update feeds set last_update = now() - delay } );
957                    $res = rss_fetch_all( $kernel );
958            }
959    
960  POE::Component::IRC->new($IRC_ALIAS);          return $res;
961    }
962    
963  POE::Session->create( inline_states => {  POE::Session->create( inline_states => {
964          _start => sub {                _start => sub {      
965                  $_[KERNEL]->post($IRC_ALIAS => register => 'all');                  $_[KERNEL]->post( $irc => register => 'all' );
966                  $_[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" );  
967      },      },
968            irc_001 => sub {
969                    my ($kernel,$sender) = @_[KERNEL,SENDER];
970                    my $poco_object = $sender->get_heap();
971                    _log "connected to",$poco_object->server_name();
972                    $kernel->post( $sender => join => $_ ) for @channels;
973                    # seen RSS cache, so don't send out messages
974                    _log rss_fetch_all( $kernel, 0 );
975                    undef;
976            },
977    #       irc_255 => sub {        # server is done blabbing
978    #               $_[KERNEL]->post( $irc => join => $CHANNEL);
979    #       },
980      irc_public => sub {      irc_public => sub {
981                  my $kernel = $_[KERNEL];                  my $kernel = $_[KERNEL];
982                  my $nick = (split /!/, $_[ARG0])[0];                  my $nick = (split /!/, $_[ARG0])[0];
# Line 761  POE::Session->create( inline_states => { Line 985  POE::Session->create( inline_states => {
985    
986                  save_message( channel => $channel, me => 0, nick => $nick, message => $msg);                  save_message( channel => $channel, me => 0, nick => $nick, message => $msg);
987                  meta( $nick, $channel, 'last-msg', $msg );                  meta( $nick, $channel, 'last-msg', $msg );
988                    rss_check_updates( $kernel );
989      },      },
990      irc_ctcp_action => sub {      irc_ctcp_action => sub {
991                  my $kernel = $_[KERNEL];                  my $kernel = $_[KERNEL];
# Line 782  POE::Session->create( inline_states => { Line 1007  POE::Session->create( inline_states => {
1007      },      },
1008          irc_ping => sub {          irc_ping => sub {
1009                  _log( "pong ", $_[ARG0] );                  _log( "pong ", $_[ARG0] );
1010                  $ping->{ $_[ARG0] }++;                  $_stat->{ping}->{ $_[ARG0] }++;
1011                  rss_check_updates( $_[KERNEL] );                  rss_check_updates( $_[KERNEL] );
1012          },          },
1013          irc_invite => sub {          irc_invite => sub {
# Line 792  POE::Session->create( inline_states => { Line 1017  POE::Session->create( inline_states => {
1017    
1018                  _log "invited to $channel by $nick";                  _log "invited to $channel by $nick";
1019    
1020                  $_[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..." );
1021                  $_[KERNEL]->post($IRC_ALIAS => join => $channel);                  $_[KERNEL]->post( $irc => 'join' => $channel );
1022    
1023          },          },
1024          irc_msg => sub {          irc_msg => sub {
1025                  my $kernel = $_[KERNEL];                  my $kernel = $_[KERNEL];
1026                  my $nick = (split /!/, $_[ARG0])[0];                  my $nick = (split /!/, $_[ARG0])[0];
                 my $msg = $_[ARG2];  
1027                  my $channel = $_[ARG1]->[0];                  my $channel = $_[ARG1]->[0];
1028                    my $msg = $_[ARG2];
1029                  my $res = "unknown command '$msg', try /msg $NICK help!";                  warn "# ARG = ",dump( @_[ARG0,ARG1,ARG2] ) if $debug;
                 my @out;  
1030    
1031                  _log "<< $msg";                  _log "<< $msg";
1032    
1033                  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";  
                 }  
1034    
1035                  if ($res) {                  if ($res) {
1036                          _log ">> [$nick] $res";                          _log ">> [$nick] $res";
1037                          $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );                          $_[KERNEL]->post( $irc => privmsg => $nick, $res );
1038                  }                  }
1039    
1040                  rss_check_updates( $_[KERNEL] );                  rss_check_updates( $_[KERNEL] );
1041          },          },
1042            irc_372 => sub {
1043                    _log "<< motd",$_[ARG0],$_[ARG1];
1044            },
1045            irc_375 => sub {
1046                    _log "<< motd", $_[ARG0], "start";
1047            },
1048            irc_376 => sub {
1049                    _log "<< motd", $_[ARG0], "end";
1050            },
1051    #       irc_433 => sub {
1052    #               print "# irc_433: ",$_[ARG1], "\n";
1053    #               warn "## indetify $NICK\n";
1054    #               $_[KERNEL]->post( $irc => privmsg => 'nickserv', "IDENTIFY $NICK" );
1055    #       },
1056    #       irc_451 # please register
1057          irc_477 => sub {          irc_477 => sub {
1058                  _log "# irc_477: ",$_[ARG1];                  _log "<< irc_477: ",$_[ARG1];
1059                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "register $NICK" );                  _log ">> IDENTIFY $NICK";
1060                    $_[KERNEL]->post( $irc => privmsg => 'NickServ', "IDENTIFY $NICK" );
1061          },          },
1062          irc_505 => sub {          irc_505 => sub {
1063                  _log "# irc_505: ",$_[ARG1];                  _log "<< irc_505: ",$_[ARG1];
1064                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "register $NICK" );                  _log ">> register $NICK";
1065  #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "set hide email on" );                  $_[KERNEL]->post( $irc => privmsg => 'NickServ', "register $NICK" );
1066  #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "set email dpavlin\@rot13.org" );  #               $_[KERNEL]->post( $irc => privmsg => 'nickserv', "IDENTIFY $NICK" );
1067    #               $_[KERNEL]->post( $irc => privmsg => 'nickserv', "set hide email on" );
1068    #               $_[KERNEL]->post( $irc => privmsg => 'nickserv', "set email dpavlin\@rot13.org" );
1069          },          },
1070          irc_registered => sub {          irc_registered => sub {
1071                  _log "## registrated $NICK";                  _log "<< registered $NICK";
                 $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );  
1072          },          },
1073          irc_disconnected => sub {          irc_disconnected => sub {
1074                  _log "## disconnected, reconnecting again";                  _log "## disconnected.. sleeping for $sleep_on_error seconds and reconnecting again";
1075                  $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);                  sleep($sleep_on_error);
1076                    $_[KERNEL]->post( $irc => connect => {} );
1077          },          },
1078          irc_socketerr => sub {          irc_socketerr => sub {
1079                  _log "## socket error... sleeping for $sleep_on_error seconds and retry";                  _log "## socket error... sleeping for $sleep_on_error seconds and retry";
1080                  sleep($sleep_on_error);                  sleep($sleep_on_error);
1081                  $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);                  $_[KERNEL]->post( $irc => connect => {} );
1082            },
1083            irc_notice => sub {
1084                    _log "<< notice from ", $_[ARG0], $_[ARG1], $_[ARG2];
1085                    my $m = $_[ARG2];
1086                    if ( $m =~ m!/msg.*(NickServ).*(IDENTIFY)!i ) {
1087                            _log ">> suggested to $1 $2";
1088                            $_[KERNEL]->post( $irc => privmsg => $1, "$2 $NICK" );
1089                    } elsif ( $m =~ m!\Q$NICK\E.*registered!i ) {
1090                            _log ">> registreted, so IDENTIFY";
1091                            $_[KERNEL]->post( $irc => privmsg => 'nickserv', "IDENTIFY $NICK" );
1092                    } else {
1093                            warn "## ignore $m\n" if $debug;
1094                    }
1095            },
1096            irc_snotice => sub {
1097                    _log "<< snotice", $_[ARG0]; #dump( $_[ARG0],$_[ARG1], $_[ARG2] );
1098                    if ( $_[ARG0] =~ m!/(QUOTE)\s+(PASS\s+\d+)!i ) {
1099                            warn ">> $1 | $2\n";
1100                            $_[KERNEL]->post( $irc => lc($1) => $2);
1101                    }
1102          },          },
 #       irc_433 => sub {  
 #               print "# irc_433: ",$_[ARG1], "\n";  
 #               warn "## indetify $NICK\n";  
 #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );  
 #       },  
1103      _child => sub {},      _child => sub {},
1104      _default => sub {      _default => sub {
1105                  _log sprintf "sID:%s %s %s",                  _log '_default SID:', $_[SESSION]->ID, $_[ARG0], dump( $_[ARG1] );
1106                          $_[SESSION]->ID, $_[ARG0],                  0; # false for signals
                         ref($_[ARG1]) eq "ARRAY"        ?       join(",", map { ref($_) eq "ARRAY" ? join(";", @{$_}) : $_ } @{ $_[ARG1] })     :  
                         $_[ARG1]                                        ?       $_[ARG1]                                        :  
                         "";  
       0;                        # false for signals  
1107      },      },
1108      my_add => sub {          rss_response => sub {
1109        my $trailing = $_[ARG0];                  my ($request_packet, $response_packet) = @_[ARG0, ARG1];
1110        my $session = $_[SESSION];                  my $request_object  = $request_packet->[0];
1111        POE::Session->create                  my $response_object = $response_packet->[0];
1112            (inline_states =>  
1113             {_start => sub {                  my $row = delete( $_stat->{rss}->{fetch}->{ $request_object->uri } );
1114                $_[HEAP]->{wheel} =                  if ( $row ) {
1115                  POE::Wheel::FollowTail->new                          $row->{xml} = $response_object->content;
1116                      (                          rss_parse_xml( $_[KERNEL], $row );
1117                       Filename => $FOLLOWS{$trailing},                  } else {
1118                       InputEvent => 'got_line',                          warn "## can't find rss->fetch for ", $request_object->uri;
1119                      );                  }
1120                                  warn "+++ following $trailing at $FOLLOWS{$trailing}\n";          },
             },  
             got_line => sub {  
                                 warn "+++ $trailing : $_[ARG0]\n";  
                                 $_[KERNEL]->post($session => my_tailed => time, $trailing, $_[ARG0]);  
             },  
            },  
           );  
       
     },  
     my_tailed => sub {  
       my ($time, $file, $line) = @_[ARG0..ARG2];  
       ## $time will be undef on a probe, or a time value if a real line  
   
       ## PoCo::IRC has throttling built in, but no external visibility  
       ## so this is reaching "under the hood"  
       $SEND_QUEUE ||=  
         $_[KERNEL]->alias_resolve($IRC_ALIAS)->get_heap->{send_queue};  
   
       ## handle "no need to keep skipping" transition  
       if ($SKIPPING and @$SEND_QUEUE < 1) {  
         $_[KERNEL]->post($IRC_ALIAS => privmsg => $CHANNEL =>  
                          "[discarded $SKIPPING messages]");  
         $SKIPPING = 0;  
       }  
   
       ## handle potential message display  
       if ($time) {  
         if ($SKIPPING or @$SEND_QUEUE > 3) { # 3 msgs per 10 seconds  
           $SKIPPING++;  
         } else {  
           my @time = localtime $time;  
           $_[KERNEL]->post($IRC_ALIAS => privmsg => $CHANNEL =>  
                            sprintf "%02d:%02d:%02d: %s: %s",  
                            ($time[2] + 11) % 12 + 1, $time[1], $time[0],  
                            $file, $line);  
         }  
       }  
   
       ## handle re-probe/flush if skipping  
       if ($SKIPPING) {  
         $_[KERNEL]->delay($_[STATE] => 0.5); # $time will be undef  
       }  
   
     },  
     my_heartbeat => sub {  
       $_[KERNEL]->yield(my_tailed => time, "heartbeat", "beep");  
       $_[KERNEL]->delay($_[STATE] => 10);  
     }  
1121     },     },
1122    );    );
1123    
1124  # http server  # http server
1125    
1126    _log "WEB archive at $url";
1127    
1128  my $httpd = POE::Component::Server::HTTP->new(  my $httpd = POE::Component::Server::HTTP->new(
1129          Port => $http_port,          Port => $http_port,
1130          PreHandler => {          PreHandler => {
# Line 1105  foreach my $c (@cols) { Line 1171  foreach my $c (@cols) {
1171          $style .= ".col-${max_color} { background: $c }\n";          $style .= ".col-${max_color} { background: $c }\n";
1172          $max_color++;          $max_color++;
1173  }  }
1174  warn "defined $max_color colors for users...\n";  _log "WEB defined $max_color colors for users...";
1175    
1176  sub root_handler {  sub root_handler {
1177          my ($request, $response) = @_;          my ($request, $response) = @_;
# Line 1116  sub root_handler { Line 1182  sub root_handler {
1182    
1183          return RC_OK if $request->uri =~ m/favicon.ico$/;          return RC_OK if $request->uri =~ m/favicon.ico$/;
1184    
1185            if ( $request->uri =~ m/robots.txt$/ ) {
1186                    $response->content_type( 'text/plain' );
1187                    $response->content( qq{
1188    
1189    User-Agent: *
1190    Disallow: /
1191    
1192                    });
1193                    return RC_OK;
1194            }
1195    
1196          my $q;          my $q;
1197    
1198          if ( $request->method eq 'POST' ) {          if ( $request->method eq 'POST' ) {
# Line 1127  sub root_handler { Line 1204  sub root_handler {
1204          }          }
1205    
1206          my $search = $q->param('search') || $q->param('grep') || '';          my $search = $q->param('search') || $q->param('grep') || '';
1207            my $r_url = $request->url;
1208    
1209          if ($request->url =~ m#/rss(?:/(tags|last-tag|follow.*)\w*(?:=(\d+))?)?#i) {          my @commands = qw( tags last-tag follow stat );
1210            my $commands_re = join('|',@commands);
1211    
1212            if ($r_url =~ m#/rss(?:/($commands_re.*)\w*(?:=(\d+))?)?#i) {
1213                  my $show = lc($1);                  my $show = lc($1);
1214                  my $nr = $2;                  my $nr = $2;
1215    
# Line 1137  sub root_handler { Line 1218  sub root_handler {
1218                  $response->content_type( 'application/' . lc($type) . '+xml' );                  $response->content_type( 'application/' . lc($type) . '+xml' );
1219    
1220                  my $html = '<!-- error -->';                  my $html = '<!-- error -->';
1221                  #warn "create $type feed from ",dump( @last_tags );                  #warn "create $type feed from ",dump( $cloud->last_tags );
1222    
1223                  my $feed = XML::Feed->new( $type );                  my $feed = XML::Feed->new( $type );
1224                  $feed->link( $url );                  $feed->link( $url );
1225    
1226                    my $rc = RC_OK;
1227    
1228                  if ( $show eq 'tags' ) {                  if ( $show eq 'tags' ) {
1229                          $nr ||= 50;                          $nr ||= 50;
1230                          $feed->title( "tags from $CHANNEL" );                          $feed->title( "tags from $CHANNEL" );
# Line 1169  sub root_handler { Line 1252  sub root_handler {
1252                          $feed->title( "last $nr tagged messages from $CHANNEL" );                          $feed->title( "last $nr tagged messages from $CHANNEL" );
1253                          $feed->description( "collects messages which have tags// in them" );                          $feed->description( "collects messages which have tags// in them" );
1254    
1255                          foreach my $m ( @last_tags ) {                          foreach my $m ( $cloud->last_tags ) {
1256  #                               warn dump( $m );  #                               warn dump( $m );
1257                                  #my $tags = join(' ', @{$m->{tags}} );                                  #my $tags = join(' ', @{$m->{tags}} );
1258                                  my $feed_entry = XML::Feed::Entry->new($type);                                  my $feed_entry = XML::Feed::Entry->new($type);
# Line 1211  sub root_handler { Line 1294  sub root_handler {
1294                                  $feed->add_entry( $feed_entry );                                  $feed->add_entry( $feed_entry );
1295                          }                          }
1296    
1297                    } elsif ( $show =~ m/^stat/ ) {
1298    
1299                            my $feed_entry = XML::Feed::Entry->new($type);
1300                            $feed_entry->title( "Internal stats" );
1301                            $feed_entry->content(
1302                                    '<![CDATA[<pre>' . dump( $_stat ) . '</pre>]]>'
1303                            );
1304                            $feed->add_entry( $feed_entry );
1305    
1306                  } else {                  } else {
1307                          _log "unknown rss request ",$request->url;                          _log "WEB unknown rss request $r_url";
1308                          return RC_DENY;                          $feed->title( "unknown $r_url" );
1309                            foreach my $c ( @commands ) {
1310                                    my $feed_entry = XML::Feed::Entry->new($type);
1311                                    $feed_entry->title( "rss/$c" );
1312                                    $feed_entry->link( "$url/rss/$c" );
1313                                    $feed->add_entry( $feed_entry );
1314                            }
1315                            $rc = RC_DENY;
1316                  }                  }
1317    
1318                  $response->content( $feed->as_xml );                  eval { $response->content( $feed->as_xml ); };
1319                  return RC_OK;                  $rc = RC_INTERNAL_SERVER_ERROR if $@;
1320                    return $rc;
1321          }          }
1322    
1323          if ( $@ ) {          if ( $@ ) {
# Line 1229  sub root_handler { Line 1329  sub root_handler {
1329          my $html =          my $html =
1330                  qq{<html><head><title>$NICK</title><style type="text/css">$style}                  qq{<html><head><title>$NICK</title><style type="text/css">$style}
1331                  . $cloud->css                  . $cloud->css
1332                  . qq{</style></head><body>}                  . qq{</style>
1333                    <meta name="google-site-verification" content="oe-LvUiNiQRPpc_uB-3rY4MWvFifkmLf276WzAvTL5U" />  
1334                    </head><body>}
1335                  . qq{                  . qq{
1336                  <form method="post" class="search" action="/">                  <form method="post" class="search" action="/">
1337                  <input type="text" name="search" value="$search" size="10">                  <input type="text" name="search" value="$search" size="10">
# Line 1275  sub root_handler { Line 1377  sub root_handler {
1377                          }                          }
1378                          $cal->setcontent($dd, qq[                          $cal->setcontent($dd, qq[
1379                                  <a href="$url?date=$row->{date}">$row->{nr}</a><br/>$row->{len}                                  <a href="$url?date=$row->{date}">$row->{nr}</a><br/>$row->{len}
1380                          ]);                          ]) if $cal;
1381                                                    
1382                  }                  }
1383                  $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 1385  sub root_handler {
1385          } else {          } else {
1386                  $html .= join("</p><p>",                  $html .= join("</p><p>",
1387                          get_from_log(                          get_from_log(
1388                                  limit => ( $q->param('last') || $q->param('date') ) ? undef : 100,                                  limit => ( $q->param('date') ? undef : $q->param('last') || 100 ),
1389                                  search => $search || undef,                                  search => $search || undef,
1390                                  tag => $q->param('tag') || undef,                                  tag => $q->param('tag') || undef,
1391                                  date => $q->param('date') || undef,                                  date => $q->param('date') || undef,
# Line 1314  sub root_handler { Line 1416  sub root_handler {
1416  }  }
1417    
1418  POE::Kernel->run;  POE::Kernel->run;
1419    
1420    =head1 TagCloud
1421    
1422    Extended L<HTML::TagCloud>
1423    
1424    =cut
1425    
1426    package TagCloud;
1427    use warnings;
1428    use strict;
1429    use HTML::TagCloud;
1430    use base 'HTML::TagCloud';
1431    use Data::Dump qw/dump/;
1432    
1433    =head2 html
1434    
1435    Generate html with number of tags in title of link
1436    
1437    =cut
1438    
1439    sub html {
1440            my($self, $limit) = @_;
1441            my @tags=$self->tags($limit);
1442    
1443            my $ntags = scalar(@tags);
1444            if ($ntags == 0) {
1445                    return "";
1446    #       } elsif ($ntags == 1) {
1447    #               my $tag = $tags[0];
1448    #               return qq{<div id="htmltagcloud"><span class="tagcloud1"><a href="}.
1449    #               $tag->{url}.qq{">}.$tag->{name}.qq{</a></span></div>\n};
1450            }
1451    
1452      my $html = qq{<div id="htmltagcloud">};
1453      foreach my $tag ( sort { lc($a->{name}) cmp lc($b->{name}) } @tags) {
1454        $html .=  sprintf(qq{<span class="tag tagcloud%d"><a href="%s" title="%s">%s</a></span>\n},
1455                    $tag->{level}, $tag->{url}, $tag->{count}, $tag->{name}
1456            );
1457      }
1458      $html .= qq{</div>};
1459      return $html;
1460    }
1461    
1462    =head2 last_tags
1463    
1464      my @tags = $cloud->last_tags;
1465    
1466    =cut
1467    
1468    my @last_tags;
1469    sub last_tags {
1470            return @last_tags;
1471    }
1472    
1473    =head2 add_tag
1474    
1475     $cloud->add_tag( id => 42, message => 'irc message', nick => 'foobar' [, me => 1 ] );
1476    
1477    =cut
1478    
1479    
1480    sub add_tag {
1481            my $self = shift;
1482            my $arg = {@_};
1483    
1484            return unless ($arg->{id} && $arg->{message});
1485    
1486            my $m = $arg->{message};
1487    
1488            my @tags;
1489    
1490            while ($m =~ s#$tag_regex##s) {
1491                    my $tag = $1;
1492                    next if (! $tag || $tag =~ m/https?:/i);
1493                    push @{ $tags->{$tag} }, $arg->{id};
1494                    #warn "+tag $tag: $arg->{id}\n";
1495                    $self->add($tag, "$url?tag=$tag", scalar @{$tags->{$tag}});
1496                    push @tags, $tag;
1497    
1498            }
1499    
1500            if ( @tags ) {
1501                    pop @last_tags if $#last_tags == $last_x_tags;
1502                    unshift @last_tags, { tags => [ @tags ], %$arg };
1503            }
1504    
1505    }
1506    
1507    =head2 seed_tags
1508    
1509    Read all tags from database and create in-memory cache for tags
1510    
1511    =cut
1512    
1513    sub seed_tags {
1514            my $self = shift;
1515            my $sth = $dbh->prepare(qq{ select id,message,nick,me,time from log where message like '%//%' order by time asc });
1516            $sth->execute;
1517            while (my $row = $sth->fetchrow_hashref) {
1518                    $self->add_tag( %$row );
1519            }
1520    
1521            foreach my $tag (keys %$tags) {
1522                    $self->add($tag, "$url?tag=$tag", scalar @{$tags->{$tag}});
1523            }
1524    }
1525    
Legend:
Removed from v.86  
changed lines
  Added in v.149
  ViewVC Help
Powered by ViewVC 1.1.26