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