/[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 90 by dpavlin, Fri Mar 7 09:50:53 2008 UTC revision 134 by dpavlin, Sat Apr 12 10:41:22 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 30  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';
64  $CHANNEL = '#irc-logger' if ($HOSTNAME =~ m/llin/);  
65  my $IRC_ALIAS = "log";  if ( $HOSTNAME =~ m/llin/ ) {
66            $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    
# Line 55  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 63  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 Component::Server::HTTP);  
 use HTTP::Status;  
 use DBI;  
 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 89  my $log_path; Line 108  my $log_path;
108  GetOptions(  GetOptions(
109          'import-dircproxy:s' => \$import_dircproxy,          'import-dircproxy:s' => \$import_dircproxy,
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  #};  #};
117    
 open(STDOUT, '>', $log_path) || warn "can't redirect log to $log_path: $!";  
   
118  sub _log {  sub _log {
119          print strftime($TIMESTAMP,localtime()) . ' ' . join(" ",@_) . $/;          print strftime($TIMESTAMP,localtime()) . ' ' . join(" ",map { ref($_) ? dump( $_ ) : $_ } @_) . $/;
120  }  }
121    
122    open(STDOUT, '>', $log_path) && warn "log to $log_path: $!\n";
123    
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 118  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 143  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 179  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 228  sub meta { Line 259  sub meta {
259                  if ( $@ || ! $sth->rows ) {                  if ( $@ || ! $sth->rows ) {
260                          $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()) });
261                          $sth->execute( $value, $nick, $channel, $name );                          $sth->execute( $value, $nick, $channel, $name );
262                          _log "created $nick/$channel/$name = $value";                          warn "## created $nick/$channel/$name = $value\n";
263                  } else {                  } else {
264                          _log "updated $nick/$channel/$name = $value ";                          warn "## updated $nick/$channel/$name = $value\n";
265                  }                  }
266    
267                  return $value;                  return $value;
# Line 240  sub meta { Line 271  sub meta {
271                  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 = ? });
272                  $sth->execute( $nick, $channel, $name );                  $sth->execute( $nick, $channel, $name );
273                  my ($v,$c) = $sth->fetchrow_array;                  my ($v,$c) = $sth->fetchrow_array;
274                  _log "fetched $nick/$channel/$name = $v [$c]";                  warn "## fetched $nick/$channel/$name = $v [$c]\n";
275                  return ($v,$c) if wantarray;                  return ($v,$c) if wantarray;
276                  return $v;                  return $v;
277    
# Line 337  sub get_from_log { Line 368  sub get_from_log {
368    
369          my @where;          my @where;
370          my @args;          my @args;
371            my $msg;
372    
373          if (my $search = $args->{search}) {          if (my $search = $args->{search}) {
374                  $search =~ s/^\s+//;                  $search =~ s/^\s+//;
375                  $search =~ s/\s+$//;                  $search =~ s/\s+$//;
376                  push @where, 'message ilike ? or nick ilike ?';                  push @where, 'message ilike ? or nick ilike ?';
377                  push @args, ( ( '%' . $search . '%' ) x 2 );                  push @args, ( ( '%' . $search . '%' ) x 2 );
378                  _log "search for '$search'";                  $msg = "Search for '$search'";
379          }          }
380    
381          if ($args->{tag} && $tags->{ $args->{tag} }) {          if ($args->{tag} && $tags->{ $args->{tag} }) {
382                  push @where, 'id in (' . join(',', @{ $tags->{ $args->{tag} } }) . ')';                  push @where, 'id in (' . join(',', @{ $tags->{ $args->{tag} } }) . ')';
383                  _log "search for tags $args->{tag}";                  $msg = "Search for tags $args->{tag}";
384          }          }
385    
386          if (my $date = $args->{date} ) {          if (my $date = $args->{date} ) {
387                  $date = check_date( $date );                  $date = check_date( $date );
388                  push @where, 'date(time) = ?';                  push @where, 'date(time) = ?';
389                  push @args, $date;                  push @args, $date;
390                  _log "search for date $date";                  $msg = "search for date $date";
391          }          }
392    
393          $sql .= " where " . join(" and ", @where) if @where;          $sql .= " where " . join(" and ", @where) if @where;
# Line 369  sub get_from_log { Line 401  sub get_from_log {
401          eval { $sth->execute( @args ) };          eval { $sth->execute( @args ) };
402          return if $@;          return if $@;
403    
404            my $nr_results = $sth->rows;
405    
406          my $last_row = {          my $last_row = {
407                  date => '',                  date => '',
408                  time => '',                  time => '',
# Line 389  sub get_from_log { Line 423  sub get_from_log {
423    
424          return @rows if ($args->{full_rows});          return @rows if ($args->{full_rows});
425    
426          my @msgs = (          $msg .= ' produced ' . (
427                  "Showing " . ($#rows + 1) . " messages..."                  $nr_results == 0 ? 'no results' :
428                    $nr_results == 0 ? 'one result' :
429                            $nr_results . ' results'
430          );          );
431    
432            my @msgs = ( $msg );
433    
434          if ($context) {          if ($context) {
435                  my @ids = @rows;                  my @ids = @rows;
436                  @rows = ();                  @rows = ();
# Line 449  sub get_from_log { Line 487  sub get_from_log {
487  #                       $row->{nick} = $nick;  #                       $row->{nick} = $nick;
488  #               }  #               }
489    
490                    $append = 0 if $row->{me};
491    
492                  if ($last_row->{nick} ne $nick) {                  if ($last_row->{nick} ne $nick) {
493                          # 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
494                          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 485  sub get_from_log { Line 525  sub get_from_log {
525    
526  # tags support  # tags support
527    
528  my $cloud = HTML::TagCloud->new;  my $cloud = TagCloud->new;
529    $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};  
   
         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;  
   
530    
531  =head2 save_message  =head2 save_message
532    
# Line 564  sub save_message { Line 550  sub save_message {
550          $a->{me} ||= 0;          $a->{me} ||= 0;
551          $a->{time} ||= strftime($TIMESTAMP,localtime());          $a->{time} ||= strftime($TIMESTAMP,localtime());
552    
553          _log          _log "ARCHIVE",
554                  $a->{channel}, " ",                  $a->{channel}, " ",
555                  $a->{me} ? "***" . $a->{nick} : "<" . $a->{nick} . ">",                  $a->{me} ? "***" . $a->{nick} : "<" . $a->{nick} . ">",
556                  " " . $a->{message};                  " " . $a->{message};
557    
558          $sth_insert_log->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}); };
559          add_tag( id => $dbh->last_insert_id(undef,undef,"log",undef), %$a );          _log "ERROR: can't archive ", $a->{message} if $@;
560            $cloud->add_tag( id => $dbh->last_insert_id(undef,undef,"log",undef), %$a );
561  }  }
562    
563    
# Line 612  if ($import_dircproxy) { Line 599  if ($import_dircproxy) {
599  # RSS follow  # RSS follow
600  #  #
601    
602  my $_rss;  my $_stat;
603    
604    POE::Component::Client::HTTP->spawn(
605            Alias   => 'rss-fetch',
606            Timeout => 30,
607    );
608    
609    =head2 rss_parse_xml
610    
611      rss_parse_xml({
612            url => 'http://www.example.com/rss',
613            send_rss_msgs => 42,
614      });
615    
616    =cut
617    
618    sub rss_parse_xml {
619            my ($kernel,$args) = @_;
620    
621  sub rss_fetch {          warn "## rss_parse_xml ",dump( $args ) if $debug;
         my ($args) = @_;  
622    
623          # 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?
624          my $send_rss_msgs = 1;          my $send_rss_msgs = $args->{send_rss_msgs};
625            $send_rss_msgs = 1 if ! defined $send_rss_msgs;
626    
627          _log "RSS fetch", $args->{url};          warn "## RSS fetch first $send_rss_msgs items from", $args->{url} if $debug;
628    
629          my $feed = XML::Feed->parse(URI->new( $args->{url} ));          my $feed = XML::Feed->parse( \$args->{xml} );
630          if ( ! $feed ) {          if ( ! $feed ) {
631                  _log("can't fetch RSS ", $args->{url});                  _log "can't fetch RSS ", $args->{url}, XML::Feed->errstr;
632                  return;                  return;
633          }          }
634    
635            $_stat->{rss}->{url2link}->{ $args->{url} } = $feed->link;
636    
637          my ( $total, $updates ) = ( 0, 0 );          my ( $total, $updates ) = ( 0, 0 );
638          for my $entry ($feed->entries) {          for my $entry ($feed->entries) {
639                  $total++;                  $total++;
640    
641                    my $seen_times = $_stat->{rss}->{seen}->{$args->{channel}}->{$feed->link}->{$entry->id}++;
642                  # seen allready?                  # seen allready?
643                  return if $_rss->{$feed->link}->{seen}->{$entry->id}++ > 0;                  warn "## $seen_times ",$entry->id if $debug;
644                    next if $seen_times > 0;
645    
646                  sub prefix {                  sub prefix {
647                          my ($txt,$var) = @_;                          my ($txt,$var) = @_;
648                            $var =~ s/\s+/ /gs;
649                          $var =~ s/^\s+//g;                          $var =~ s/^\s+//g;
650                            $var =~ s/\s+$//g;
651                          return $txt . $var if $var;                          return $txt . $var if $var;
652                  }                  }
653    
654                    # fix absolute and relative links to feed entries
655                    my $link = $entry->link;
656                    if ( $link =~ m!^/! ) {
657                            my $host = $args->{url};
658                            $host =~ s!^(http://[^/]+).*$!$1!;      #!vim
659                            $link = "$host/$link";
660                    } elsif ( $link !~ m!^http! ) {
661                            $link = $args->{url} . $link;
662                    }
663    
664                  my $msg;                  my $msg;
665                  $msg .= prefix( 'From: ' , $args->{name} || $feed->title );                  $msg .= prefix( 'From: ' , $args->{name} || $feed->title );
666                  $msg .= prefix( ' by ' , $entry->author );                  $msg .= prefix( ' by ' , $entry->author );
667                  $msg .= prefix( ' -- ' , $entry->link );                  $msg .= prefix( ' | ' , $entry->title );
668                    $msg .= prefix( ' | ' , $link );
669  #               $msg .= prefix( ' id ' , $entry->id );  #               $msg .= prefix( ' id ' , $entry->id );
670                    my @categories = $entry->category;
671                    warn "## category = ", dump( @categories ) if $debug;
672                    if ( my $tags = $entry->category ) {
673                            $tags = join(' ', @$tags) if ref($tags) eq 'ARRAY';
674                            $tags =~ s!^\s+!!;
675                            $tags =~ s!\s*$! !;
676                            $tags =~ s!,?\s+!// !g;
677                            $msg .= prefix( ' ' , $tags );
678                    }
679    
680                  if ( $args->{kernel} && $send_rss_msgs ) {                  if ( $seen_times == 0 && $send_rss_msgs ) {
681                          $send_rss_msgs--;                          $send_rss_msgs--;
682                          _log('RSS', $msg);                          if ( ! $args->{private} ) {
683                          $sth_insert_log->execute( $CHANNEL, 1, $NICK, $msg, undef );                                  # FIXME bug! should be save_message
684                          $args->{kernel}->post( $IRC_ALIAS => notice => $CHANNEL, $msg );                                  save_message( channel => $args->{channel}, me => 1, nick => $NICK, message => $msg );
685    #                               $sth_insert_log->execute( $args->{channel}, 1, $NICK, $msg, 'now()' );
686                            }
687                            my ( $type, $to ) = ( 'notice', $args->{channel} );
688                            ( $type, $to ) = ( 'privmsg', $args->{nick} ) if $args->{private};
689    
690                            _log(">> RSS $type to $to:", $msg);
691                            $kernel->post( $irc => $type => $to => $msg );
692    
693                          $updates++;                          $updates++;
694                  }                  }
695          }          }
# Line 661  sub rss_fetch { Line 699  sub rss_fetch {
699          $sql .= qq{where id = } . $args->{id};          $sql .= qq{where id = } . $args->{id};
700          eval { $dbh->do( $sql ) };          eval { $dbh->do( $sql ) };
701    
702          _log "RSS got $total items of which $updates new";          _log "RSS $updates/$total new items from", $args->{url};
703    
704          return $updates;          return $updates;
705  }  }
706    
707  sub rss_fetch_all {  sub rss_fetch_all {
708          my $kernel = shift;          my ( $kernel, $send_rss_msgs )  = @_;
709            warn "## rss_fetch_all -- send_rss_msgs: $send_rss_msgs\n" if $debug;
710          my $sql = qq{          my $sql = qq{
711                  select id, url, name                  select id, url, name, channel, nick, private
712                  from feeds                  from feeds
713                  where active is true                  where active is true
714          };          };
715          # limit to newer feeds only if we are not sending messages out          # limit to newer feeds only if we are not sending messages out
716          $sql .= qq{     and last_update + delay < now() } if $kernel;          $sql .= qq{     and last_update + delay < now() } if defined ( $_stat->{rss}->{fetch} );
717          my $sth = $dbh->prepare( $sql );          my $sth = $dbh->prepare( $sql );
718          $sth->execute();          $sth->execute();
719          warn "# ",$sth->rows," active RSS feeds\n";          warn "# ",$sth->rows," active RSS feeds\n";
720          my $count = 0;          my $count = 0;
721          while (my $row = $sth->fetchrow_hashref) {          while (my $row = $sth->fetchrow_hashref) {
722                  $row->{kernel} = $kernel if $kernel;                  $row->{send_rss_msgs} = $send_rss_msgs if defined $send_rss_msgs;
723                  $count += rss_fetch( $row );                  $_stat->{rss}->{fetch}->{ $row->{url} } = $row;
724                    $kernel->post(
725                            'rss-fetch',
726                            'request',
727                            'rss_response',
728                            HTTP::Request->new( GET => $row->{url} ),
729                    );
730                    warn "## queued rss-fetch ", dump( $row ) if $debug;
731          }          }
732          return "OK, fetched $count posts from " . $sth->rows . " feeds";          return "OK, scheduled " . $sth->rows . " feeds for refresh";
733  }  }
734    
735    
736  sub rss_check_updates {  sub rss_check_updates {
737          my $kernel = shift;          my $kernel = shift;
738          my $last_t = $_rss->{last_poll} || time();          $_stat->{rss}->{last_poll} ||= time();
739          my $t = time();          my $dt = time() - $_stat->{rss}->{last_poll};
740          if ( $t - $last_t > $rss_min_delay ) {          if ( $dt > $rss_min_delay ) {
741                  $_rss->{last_poll} = $t;                  warn "## rss_check_updates $dt > $rss_min_delay\n";
742                    $_stat->{rss}->{last_poll} = time();
743                  _log rss_fetch_all( $kernel );                  _log rss_fetch_all( $kernel );
744          }          }
745  }  }
746    
747  # seed rss seen cache so we won't send out all items on startup  sub process_command {
748  _log rss_fetch_all;          my ( $kernel, $nick, $channel, $msg ) = @_;
749    
750  #          my $res = "unknown command '$msg', try /msg $NICK help!";
751  # POE handing part  
752  #          if ($msg =~ m/^help/i) {
753    
754  my $ping;                                               # ping stats                  $res = "usage: /msg $NICK comand | commands: stat - user/message stat | last - show backtrace | grep foobar - find foobar";
755    
756  POE::Component::IRC->new($IRC_ALIAS);          } elsif ($msg =~ m/^(privmsg|notice)\s+(\S+)\s+(.*)$/i) {
757    
758                    _log ">> /$1 $2 $3";
759                    $kernel->post( $irc => $1 => $2, $3 );
760                    $res = '';
761    
762            } elsif ($msg =~ m/^stat.*?\s*(\d*)/i) {
763    
764                    my $nr = $1 || 10;
765    
766                    my $sth = $dbh->prepare(qq{
767                            select
768                                    trim(both '_' from nick) as nick,
769                                    count(*) as count,
770                                    sum(length(message)) as len
771                            from log
772                            group by trim(both '_' from nick)
773                            order by len desc,count desc
774                            limit $nr
775                    });
776                    $sth->execute();
777                    $res = "Top $nr users: ";
778                    my @users;
779                    while (my $row = $sth->fetchrow_hashref) {
780                            push @users,$row->{nick} . ': ' . $row->{count} . '/' . $row->{len} . '=' . sprintf("%.2f", $row->{len}/$row->{count});
781                    }
782                    $res .= join(" | ", @users);
783            } elsif ($msg =~ m/^last.*?\s*(\d*)/i) {
784    
785                    my $limit = $1 || meta( $nick, $channel, 'last-size' ) || 10;
786    
787                    foreach my $res (get_from_log( limit => $limit )) {
788                            _log "last: $res";
789                            $kernel->post( $irc => privmsg => $nick, $res );
790                    }
791    
792                    $res = '';
793    
794            } elsif ($msg =~ m/^(search|grep)\s+(.*)\s*$/i) {
795    
796                    my $what = $2;
797    
798                    foreach my $res (get_from_log(
799                                    limit => 20,
800                                    search => $what,
801                            )) {
802                            _log "search [$what]: $res";
803                            $kernel->post( $irc => privmsg => $nick, $res );
804                    }
805    
806                    $res = '';
807    
808            } elsif ($msg =~ m/^(?:count|poll)\s+(.*)(?:\s+(\d+))?\s*$/i) {
809    
810                    my ($what,$limit) = ($1,$2);
811                    $limit ||= 100;
812    
813                    my $stat;
814    
815                    foreach my $res (get_from_log(
816                                    limit => $limit,
817                                    search => $what,
818                                    full_rows => 1,
819                            )) {
820                            while ($res->{message} =~ s/\Q$what\E(\+|\-)//) {
821                                    $stat->{vote}->{$1}++;
822                                    $stat->{from}->{ $res->{nick} }++;
823                            }
824                    }
825    
826                    my @nicks;
827                    foreach my $nick (sort { $stat->{from}->{$a} <=> $stat->{from}->{$b} } keys %{ $stat->{from} }) {
828                            push @nicks, $nick . ( $stat->{from}->{$nick} == 1 ? '' :
829                                    "(" . $stat->{from}->{$nick} . ")"
830                            );
831                    }
832    
833                    $res =
834                            "$what ++ " . ( $stat->{vote}->{'+'} || 0 ) .
835                            " : " . ( $stat->{vote}->{'-'} || 0 ) . " --" .
836                            " from " . ( join(", ", @nicks) || 'nobody' );
837    
838                    $kernel->post( $irc => notice => $nick, $res );
839    
840            } elsif ($msg =~ m/^ping/) {
841                    $res = "ping = " . dump( $_stat->{ping} );
842            } elsif ($msg =~ m/^conf(?:ig)*\s*(last-size|twitter)*\s*(.*)/) {
843                    if ( ! defined( $1 ) ) {
844                            my $sth = $dbh->prepare(qq{ select name,value,changed from meta where nick = ? and channel = ? });
845                            $sth->execute( $nick, $channel );
846                            $res = "config for $nick on $channel";
847                            while ( my ($n,$v) = $sth->fetchrow_array ) {
848                                    $res .= " | $n = $v";
849                            }
850                    } elsif ( ! $2 ) {
851                            my $val = meta( $nick, $channel, $1 );
852                            $res = "current $1 = " . ( $val ? $val : 'undefined' );
853                    } else {
854                            my $validate = {
855                                    'last-size' => qr/^\d+/,
856                                    'twitter' => qr/^\w+\s+\w+/,
857                            };
858    
859                            my ( $op, $val ) = ( $1, $2 );
860    
861                            if ( my $regex = $validate->{$op} ) {
862                                    if ( $val =~ $regex ) {
863                                            meta( $nick, $channel, $op, $val );
864                                            $res = "saved $op = $val";
865                                    } else {
866                                            $res = "config option $op = $val doesn't validate against $regex";
867                                    }
868                            } else {
869                                    $res = "config option $op doesn't exist";
870                            }
871                    }
872            } elsif ($msg =~ m/^rss-update/) {
873                    $res = rss_fetch_all( $kernel );
874            } elsif ($msg =~ m/^rss-list/) {
875                    my $sth = $dbh->prepare(qq{ select url,name,last_update,active,channel,nick,private from feeds });
876                    $sth->execute;
877                    while (my @row = $sth->fetchrow_array) {
878                            $kernel->post( $irc => privmsg => $nick, join(' | ',@row) );
879                    }
880                    $res = '';
881            } elsif ($msg =~ m!^rss-(add|remove|stop|start|clean)(?:-(private))?\s+(http://\S+)\s*(.*)!) {
882                    my ( $command, $sub, $url, $arg ) = ( $1,$2,$3,$4 );
883    
884                    my $channel = $1 if ( $arg =~ s/\s*(#\S+)\s*// );
885                    $channel = $nick if $sub eq 'private';
886    
887                    my $sql = {
888                            add     => qq{ insert into feeds (url,name,channel,nick,private) values (?,?,?,?,?) },
889                            remove  => qq{ delete from feeds                                where url = ? and nick = ? },
890                            start   => qq{ update feeds set active = true   where url = ? },
891                            stop    => qq{ update feeds set active = false  where url = ? },
892                            clean   => qq{ update feeds set last_update = now() - delay where url = ? },
893                    };
894    
895                    if ( $command eq 'add' && ! $channel ) {
896                            $res = "ERROR: got '$msg' which doesn't have #channel in it, ignoring!";
897                    } elsif (my $q = $sql->{$command} ) {
898                            my $sth = $dbh->prepare( $q );
899                            my @data = ( $url );
900                            if ( $command eq 'add' ) {
901                                    push @data, ( $arg, $channel, $nick, $sub eq 'private' ? 1 : 0 );
902                            } elsif ( $command eq 'remove' ) {
903                                    push @data, $nick;
904                            }
905                            warn "## $command SQL $q with ",dump( @data ),"\n";
906                            eval { $sth->execute( @data ) };
907                            if ($@) {
908                                    $res = "ERROR: $@";
909                            } else {
910                                    $res = "OK, RSS executed $command" .
911                                            ( $sub ? "-$sub " : ' ' ) .
912                                            ( $channel ? "on $channel " : '' ) .
913                                            "url $url";
914                                    if ( $command eq 'clean' ) {
915                                            my $seen = $_stat->{rss}->{seen} || die "no seen?";
916                                            my $want_link = $_stat->{rss}->{url2link}->{$url} || warn "no url2link($url)";
917                                            foreach my $c ( keys %$seen ) {
918                                                    my $c_hash = $seen->{$c} || die "no seen->{$c}";
919                                                    die "not HASH with rss links but ", dump($c_hash) unless ref($c_hash) eq 'HASH';
920                                                    foreach my $link ( keys %$c_hash ) {
921                                                            next unless $link eq $want_link;
922                                                            _log "RSS removed seen $c $url $link";
923                                                    }
924                                            }
925                                    } elsif ( $command eq 'add' ) {
926                                            rss_fetch_all( $kernel );
927                                    }
928                            }
929                    } else {
930                            $res = "ERROR: don't know what to do with: $msg";
931                    }
932            } elsif ($msg =~ m/^rss-clean/) {
933                    # this makes sense because we didn't catch rss-clean http://... before!
934                    $_stat->{rss} = undef;
935                    $dbh->do( qq{ update feeds set last_update = now() - delay } );
936                    $res = rss_fetch_all( $kernel );
937            }
938    
939            return $res;
940    }
941    
942  POE::Session->create( inline_states => {  POE::Session->create( inline_states => {
943          _start => sub {                _start => sub {      
944                  $_[KERNEL]->post($IRC_ALIAS => register => 'all');                  $_[KERNEL]->post( $irc => register => 'all' );
945                  $_[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 => privmsg => 'nickserv', "IDENTIFY $NICK" );  
946      },      },
947            irc_001 => sub {
948                    my ($kernel,$sender) = @_[KERNEL,SENDER];
949                    my $poco_object = $sender->get_heap();
950                    _log "connected to",$poco_object->server_name();
951                    $kernel->post( $sender => join => $_ ) for @channels;
952                    # seen RSS cache, so don't send out messages
953                    _log rss_fetch_all( $kernel, 0 );
954                    undef;
955            },
956    #       irc_255 => sub {        # server is done blabbing
957    #               $_[KERNEL]->post( $irc => join => $CHANNEL);
958    #       },
959      irc_public => sub {      irc_public => sub {
960                  my $kernel = $_[KERNEL];                  my $kernel = $_[KERNEL];
961                  my $nick = (split /!/, $_[ARG0])[0];                  my $nick = (split /!/, $_[ARG0])[0];
# Line 725  POE::Session->create( inline_states => { Line 964  POE::Session->create( inline_states => {
964    
965                  save_message( channel => $channel, me => 0, nick => $nick, message => $msg);                  save_message( channel => $channel, me => 0, nick => $nick, message => $msg);
966                  meta( $nick, $channel, 'last-msg', $msg );                  meta( $nick, $channel, 'last-msg', $msg );
967                    rss_check_updates( $kernel );
968      },      },
969      irc_ctcp_action => sub {      irc_ctcp_action => sub {
970                  my $kernel = $_[KERNEL];                  my $kernel = $_[KERNEL];
# Line 746  POE::Session->create( inline_states => { Line 986  POE::Session->create( inline_states => {
986      },      },
987          irc_ping => sub {          irc_ping => sub {
988                  _log( "pong ", $_[ARG0] );                  _log( "pong ", $_[ARG0] );
989                  $ping->{ $_[ARG0] }++;                  $_stat->{ping}->{ $_[ARG0] }++;
990                  rss_check_updates( $_[KERNEL] );                  rss_check_updates( $_[KERNEL] );
991          },          },
992          irc_invite => sub {          irc_invite => sub {
# Line 756  POE::Session->create( inline_states => { Line 996  POE::Session->create( inline_states => {
996    
997                  _log "invited to $channel by $nick";                  _log "invited to $channel by $nick";
998    
999                  $_[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..." );
1000                  $_[KERNEL]->post($IRC_ALIAS => join => $channel);                  $_[KERNEL]->post( $irc => 'join' => $channel );
1001    
1002          },          },
1003          irc_msg => sub {          irc_msg => sub {
1004                  my $kernel = $_[KERNEL];                  my $kernel = $_[KERNEL];
1005                  my $nick = (split /!/, $_[ARG0])[0];                  my $nick = (split /!/, $_[ARG0])[0];
                 my $msg = $_[ARG2];  
1006                  my $channel = $_[ARG1]->[0];                  my $channel = $_[ARG1]->[0];
1007                    my $msg = $_[ARG2];
1008                  my $res = "unknown command '$msg', try /msg $NICK help!";                  warn "# ARG = ",dump( @_[ARG0,ARG1,ARG2] ) if $debug;
                 my @out;  
1009    
1010                  _log "<< $msg";                  _log "<< $msg";
1011    
1012                  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;  
                         $dbh->do( qq{ update feeds set last_update = now() - delay } );  
                         $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";  
                 }  
1013    
1014                  if ($res) {                  if ($res) {
1015                          _log ">> [$nick] $res";                          _log ">> [$nick] $res";
1016                          $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );                          $_[KERNEL]->post( $irc => privmsg => $nick, $res );
1017                  }                  }
1018    
1019                  rss_check_updates( $_[KERNEL] );                  rss_check_updates( $_[KERNEL] );
1020          },          },
1021            irc_372 => sub {
1022                    _log "<< motd",$_[ARG0],$_[ARG1];
1023            },
1024            irc_375 => sub {
1025                    _log "<< motd", $_[ARG0], "start";
1026            },
1027            irc_376 => sub {
1028                    _log "<< motd", $_[ARG0], "end";
1029            },
1030    #       irc_433 => sub {
1031    #               print "# irc_433: ",$_[ARG1], "\n";
1032    #               warn "## indetify $NICK\n";
1033    #               $_[KERNEL]->post( $irc => privmsg => 'nickserv', "IDENTIFY $NICK" );
1034    #       },
1035    #       irc_451 # please register
1036          irc_477 => sub {          irc_477 => sub {
1037                  _log "# irc_477: ",$_[ARG1];                  _log "<< irc_477: ",$_[ARG1];
1038                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "register $NICK" );                  _log ">> IDENTIFY $NICK";
1039                    $_[KERNEL]->post( $irc => privmsg => 'NickServ', "IDENTIFY $NICK" );
1040          },          },
1041          irc_505 => sub {          irc_505 => sub {
1042                  _log "# irc_505: ",$_[ARG1];                  _log "<< irc_505: ",$_[ARG1];
1043                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "register $NICK" );                  _log ">> register $NICK";
1044  #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "set hide email on" );                  $_[KERNEL]->post( $irc => privmsg => 'NickServ', "register $NICK" );
1045  #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "set email dpavlin\@rot13.org" );  #               $_[KERNEL]->post( $irc => privmsg => 'nickserv', "IDENTIFY $NICK" );
1046    #               $_[KERNEL]->post( $irc => privmsg => 'nickserv', "set hide email on" );
1047    #               $_[KERNEL]->post( $irc => privmsg => 'nickserv', "set email dpavlin\@rot13.org" );
1048          },          },
1049          irc_registered => sub {          irc_registered => sub {
1050                  _log "## registrated $NICK";                  _log "<< registered $NICK";
                 $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );  
1051          },          },
1052          irc_disconnected => sub {          irc_disconnected => sub {
1053                  _log "## disconnected, reconnecting again";                  _log "## disconnected.. sleeping for $sleep_on_error seconds and reconnecting again";
1054                  $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);                  sleep($sleep_on_error);
1055                    $_[KERNEL]->post( $irc => connect => {} );
1056          },          },
1057          irc_socketerr => sub {          irc_socketerr => sub {
1058                  _log "## socket error... sleeping for $sleep_on_error seconds and retry";                  _log "## socket error... sleeping for $sleep_on_error seconds and retry";
1059                  sleep($sleep_on_error);                  sleep($sleep_on_error);
1060                  $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);                  $_[KERNEL]->post( $irc => connect => {} );
1061            },
1062            irc_notice => sub {
1063                    _log "<< notice from ", $_[ARG0], $_[ARG1], $_[ARG2];
1064                    my $m = $_[ARG2];
1065                    if ( $m =~ m!/msg.*(NickServ).*(IDENTIFY)!i ) {
1066                            _log ">> suggested to $1 $2";
1067                            $_[KERNEL]->post( $irc => privmsg => $1, "$2 $NICK" );
1068                    } elsif ( $m =~ m!\Q$NICK\E.*registered!i ) {
1069                            _log ">> registreted, so IDENTIFY";
1070                            $_[KERNEL]->post( $irc => privmsg => 'nickserv', "IDENTIFY $NICK" );
1071                    } else {
1072                            warn "## ignore $m\n" if $debug;
1073                    }
1074            },
1075            irc_snotice => sub {
1076                    _log "<< snotice", $_[ARG0]; #dump( $_[ARG0],$_[ARG1], $_[ARG2] );
1077                    if ( $_[ARG0] =~ m!/(QUOTE)\s+(PASS\s+\d+)!i ) {
1078                            warn ">> $1 | $2\n";
1079                            $_[KERNEL]->post( $irc => lc($1) => $2);
1080                    }
1081          },          },
 #       irc_433 => sub {  
 #               print "# irc_433: ",$_[ARG1], "\n";  
 #               warn "## indetify $NICK\n";  
 #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );  
 #       },  
1082      _child => sub {},      _child => sub {},
1083      _default => sub {      _default => sub {
1084                  _log sprintf "sID:%s %s %s",                  _log '_default SID:', $_[SESSION]->ID, $_[ARG0], dump( $_[ARG1] );
1085                          $_[SESSION]->ID, $_[ARG0],                  0; # false for signals
                         ref($_[ARG1]) eq "ARRAY"        ?       join(",", map { ref($_) eq "ARRAY" ? join(";", @{$_}) : $_ } @{ $_[ARG1] })     :  
                         $_[ARG1]                                        ?       $_[ARG1]                                        :  
                         "";  
       0;                        # false for signals  
1086      },      },
1087            rss_response => sub {
1088                    my ($request_packet, $response_packet) = @_[ARG0, ARG1];
1089                    my $request_object  = $request_packet->[0];
1090                    my $response_object = $response_packet->[0];
1091    
1092                    my $row = delete( $_stat->{rss}->{fetch}->{ $request_object->uri } );
1093                    if ( $row ) {
1094                            $row->{xml} = $response_object->content;
1095                            rss_parse_xml( $_[KERNEL], $row );
1096                    } else {
1097                            warn "## can't find rss->fetch for ", $request_object->uri;
1098                    }
1099            },
1100     },     },
1101    );    );
1102    
1103  # http server  # http server
1104    
1105    _log "WEB archive at $url";
1106    
1107  my $httpd = POE::Component::Server::HTTP->new(  my $httpd = POE::Component::Server::HTTP->new(
1108          Port => $http_port,          Port => $http_port,
1109          PreHandler => {          PreHandler => {
# Line 1009  foreach my $c (@cols) { Line 1150  foreach my $c (@cols) {
1150          $style .= ".col-${max_color} { background: $c }\n";          $style .= ".col-${max_color} { background: $c }\n";
1151          $max_color++;          $max_color++;
1152  }  }
1153  warn "defined $max_color colors for users...\n";  _log "WEB defined $max_color colors for users...";
1154    
1155  sub root_handler {  sub root_handler {
1156          my ($request, $response) = @_;          my ($request, $response) = @_;
# Line 1031  sub root_handler { Line 1172  sub root_handler {
1172          }          }
1173    
1174          my $search = $q->param('search') || $q->param('grep') || '';          my $search = $q->param('search') || $q->param('grep') || '';
1175            my $r_url = $request->url;
1176    
1177            my @commands = qw( tags last-tag follow stat );
1178            my $commands_re = join('|',@commands);
1179    
1180          if ($request->url =~ m#/rss(?:/(tags|last-tag|follow.*)\w*(?:=(\d+))?)?#i) {          if ($r_url =~ m#/rss(?:/($commands_re.*)\w*(?:=(\d+))?)?#i) {
1181                  my $show = lc($1);                  my $show = lc($1);
1182                  my $nr = $2;                  my $nr = $2;
1183    
# Line 1041  sub root_handler { Line 1186  sub root_handler {
1186                  $response->content_type( 'application/' . lc($type) . '+xml' );                  $response->content_type( 'application/' . lc($type) . '+xml' );
1187    
1188                  my $html = '<!-- error -->';                  my $html = '<!-- error -->';
1189                  #warn "create $type feed from ",dump( @last_tags );                  #warn "create $type feed from ",dump( $cloud->last_tags );
1190    
1191                  my $feed = XML::Feed->new( $type );                  my $feed = XML::Feed->new( $type );
1192                  $feed->link( $url );                  $feed->link( $url );
1193    
1194                    my $rc = RC_OK;
1195    
1196                  if ( $show eq 'tags' ) {                  if ( $show eq 'tags' ) {
1197                          $nr ||= 50;                          $nr ||= 50;
1198                          $feed->title( "tags from $CHANNEL" );                          $feed->title( "tags from $CHANNEL" );
# Line 1073  sub root_handler { Line 1220  sub root_handler {
1220                          $feed->title( "last $nr tagged messages from $CHANNEL" );                          $feed->title( "last $nr tagged messages from $CHANNEL" );
1221                          $feed->description( "collects messages which have tags// in them" );                          $feed->description( "collects messages which have tags// in them" );
1222    
1223                          foreach my $m ( @last_tags ) {                          foreach my $m ( $cloud->last_tags ) {
1224  #                               warn dump( $m );  #                               warn dump( $m );
1225                                  #my $tags = join(' ', @{$m->{tags}} );                                  #my $tags = join(' ', @{$m->{tags}} );
1226                                  my $feed_entry = XML::Feed::Entry->new($type);                                  my $feed_entry = XML::Feed::Entry->new($type);
# Line 1115  sub root_handler { Line 1262  sub root_handler {
1262                                  $feed->add_entry( $feed_entry );                                  $feed->add_entry( $feed_entry );
1263                          }                          }
1264    
1265                    } elsif ( $show =~ m/^stat/ ) {
1266    
1267                            my $feed_entry = XML::Feed::Entry->new($type);
1268                            $feed_entry->title( "Internal stats" );
1269                            $feed_entry->content(
1270                                    '<![CDATA[<pre>' . dump( $_stat ) . '</pre>]]>'
1271                            );
1272                            $feed->add_entry( $feed_entry );
1273    
1274                  } else {                  } else {
1275                          _log "unknown rss request ",$request->url;                          _log "WEB unknown rss request $r_url";
1276                          return RC_DENY;                          $feed->title( "unknown $r_url" );
1277                            foreach my $c ( @commands ) {
1278                                    my $feed_entry = XML::Feed::Entry->new($type);
1279                                    $feed_entry->title( "rss/$c" );
1280                                    $feed_entry->link( "$url/rss/$c" );
1281                                    $feed->add_entry( $feed_entry );
1282                            }
1283                            $rc = RC_DENY;
1284                  }                  }
1285    
1286                  $response->content( $feed->as_xml );                  $response->content( $feed->as_xml );
1287                  return RC_OK;                  return $rc;
1288          }          }
1289    
1290          if ( $@ ) {          if ( $@ ) {
# Line 1187  sub root_handler { Line 1350  sub root_handler {
1350          } else {          } else {
1351                  $html .= join("</p><p>",                  $html .= join("</p><p>",
1352                          get_from_log(                          get_from_log(
1353                                  limit => ( $q->param('last') || $q->param('date') ) ? undef : 100,                                  limit => ( $q->param('date') ? undef : $q->param('last') || 100 ),
1354                                  search => $search || undef,                                  search => $search || undef,
1355                                  tag => $q->param('tag') || undef,                                  tag => $q->param('tag') || undef,
1356                                  date => $q->param('date') || undef,                                  date => $q->param('date') || undef,
# Line 1212  sub root_handler { Line 1375  sub root_handler {
1375          <p>See <a href="/history">history</a> of all messages.</p>          <p>See <a href="/history">history</a> of all messages.</p>
1376          </body></html>};          </body></html>};
1377    
1378          $response->content( $html );          $response->content( decode('utf-8',$html) );
1379          warn "<< ", $request->method, " ", $request->uri, " created ", length($html), " bytes\n";          warn "<< ", $request->method, " ", $request->uri, " created ", length($html), " bytes\n";
1380          return RC_OK;          return RC_OK;
1381  }  }
1382    
1383  POE::Kernel->run;  POE::Kernel->run;
1384    
1385    =head1 TagCloud
1386    
1387    Extended L<HTML::TagCloud>
1388    
1389    =cut
1390    
1391    package TagCloud;
1392    use warnings;
1393    use strict;
1394    use HTML::TagCloud;
1395    use base 'HTML::TagCloud';
1396    use Data::Dump qw/dump/;
1397    
1398    =head2 html
1399    
1400    Generate html with number of tags in title of link
1401    
1402    =cut
1403    
1404    sub html {
1405            my($self, $limit) = @_;
1406            my @tags=$self->tags($limit);
1407    
1408            my $ntags = scalar(@tags);
1409            if ($ntags == 0) {
1410                    return "";
1411    #       } elsif ($ntags == 1) {
1412    #               my $tag = $tags[0];
1413    #               return qq{<div id="htmltagcloud"><span class="tagcloud1"><a href="}.
1414    #               $tag->{url}.qq{">}.$tag->{name}.qq{</a></span></div>\n};
1415            }
1416    
1417      my $html = qq{<div id="htmltagcloud">};
1418      foreach my $tag (@tags) {
1419        $html .=  sprintf(qq{<span class="tag tagcloud%d"><a href="%s" title="%s">%s</a></span>\n},
1420                    $tag->{level}, $tag->{url}, $tag->{count}, $tag->{name}
1421            );
1422      }
1423      $html .= qq{</div>};
1424      return $html;
1425    }
1426    
1427    =head2 last_tags
1428    
1429      my @tags = $cloud->last_tags;
1430    
1431    =cut
1432    
1433    my @last_tags;
1434    sub last_tags {
1435            return @last_tags;
1436    }
1437    
1438    =head2 add_tag
1439    
1440     $cloud->add_tag( id => 42, message => 'irc message', nick => 'foobar' [, me => 1 ] );
1441    
1442    =cut
1443    
1444    
1445    sub add_tag {
1446            my $self = shift;
1447            my $arg = {@_};
1448    
1449            return unless ($arg->{id} && $arg->{message});
1450    
1451            my $m = $arg->{message};
1452    
1453            my @tags;
1454    
1455            while ($m =~ s#$tag_regex##s) {
1456                    my $tag = $1;
1457                    next if (! $tag || $tag =~ m/https?:/i);
1458                    push @{ $tags->{$tag} }, $arg->{id};
1459                    #warn "+tag $tag: $arg->{id}\n";
1460                    $self->add($tag, "$url?tag=$tag", scalar @{$tags->{$tag}});
1461                    push @tags, $tag;
1462    
1463            }
1464    
1465            if ( @tags ) {
1466                    pop @last_tags if $#last_tags == $last_x_tags;
1467                    unshift @last_tags, { tags => [ @tags ], %$arg };
1468            }
1469    
1470    }
1471    
1472    =head2 seed_tags
1473    
1474    Read all tags from database and create in-memory cache for tags
1475    
1476    =cut
1477    
1478    sub seed_tags {
1479            my $self = shift;
1480            my $sth = $dbh->prepare(qq{ select id,message,nick,me,time from log where message like '%//%' order by time asc });
1481            $sth->execute;
1482            while (my $row = $sth->fetchrow_hashref) {
1483                    $self->add_tag( %$row );
1484            }
1485    
1486            foreach my $tag (keys %$tags) {
1487                    $self->add($tag, "$url?tag=$tag", scalar @{$tags->{$tag}});
1488            }
1489    }
1490    
Legend:
Removed from v.90  
changed lines
  Added in v.134
  ViewVC Help
Powered by ViewVC 1.1.26