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