/[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 89 by dpavlin, Fri Mar 7 00:43:45 2008 UTC revision 131 by dpavlin, Sun Mar 23 12:32:14 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 HTML::TagCloud;
11    use POSIX qw/strftime/;
12    use HTML::CalendarMonthSimple;
13    use Getopt::Long;
14    use DateTime;
15    use URI::Escape;
16    use Data::Dump qw/dump/;
17    use DateTime::Format::ISO8601;
18    use Carp qw/confess/;
19    use XML::Feed;
20    use DateTime::Format::Flexible;
21    use Encode;
22    
23  =head1 NAME  =head1 NAME
24    
25  irc-logger.pl  irc-logger.pl
# Line 20  Import log from C<dircproxy> to C<irc-lo Line 38  Import log from C<dircproxy> to C<irc-lo
38    
39  =item --log=irc-logger.log  =item --log=irc-logger.log
40    
 Name of log file  
   
 =item --follow=file.log  
   
 Follows new messages in file  
   
41  =back  =back
42    
43  =head1 DESCRIPTION  =head1 DESCRIPTION
# Line 36  log all conversation on irc channel Line 48  log all conversation on irc channel
48    
49  ## CONFIG  ## CONFIG
50    
51    my $debug = 0;
52    
53    my $irc_config = {
54            nick => 'irc-logger',
55            server => 'irc.freenode.net',
56            port => 6667,
57            ircname => 'Anna the bot: try /msg irc-logger help',
58    };
59    
60  my $HOSTNAME = `hostname -f`;  my $HOSTNAME = `hostname -f`;
61  chomp($HOSTNAME);  chomp($HOSTNAME);
62    
63  my $NICK = 'irc-logger';  
 $NICK .= '-dev' if ($HOSTNAME =~ m/llin/);  
 my $CONNECT =  
   {Server => 'irc.freenode.net',  
    Nick => $NICK,  
    Ircname => "try /msg $NICK help",  
   };  
64  my $CHANNEL = '#razmjenavjestina';  my $CHANNEL = '#razmjenavjestina';
 $CHANNEL = '#irc-logger' if ($HOSTNAME =~ m/llin/);  
 my $IRC_ALIAS = "log";  
65    
66  # default log to follow and announce messages  if ( $HOSTNAME =~ m/llin/ ) {
67  my $follows_path = 'follows.log';          $irc_config->{nick} = 'irc-logger-llin';
68    #       $irc_config = {
69    #               nick => 'irc-logger-llin',
70    #               server => 'localhost',
71    #               port => 6668,
72    #       };
73            $CHANNEL = '#irc-logger';
74    } elsif ( $HOSTNAME =~ m/lugarin/ ) {
75            $irc_config->{server} = 'irc.carnet.hr';
76            $CHANNEL = '#riss';
77    }
78    
79    my @channels = ( $CHANNEL );
80    
81    warn "## config = ", dump( $irc_config ) if $debug;
82    
83    my $NICK = $irc_config->{nick} or die "no nick?";
84    
85  my $DSN = 'DBI:Pg:dbname=' . $NICK;  my $DSN = 'DBI:Pg:dbname=' . $NICK;
86    
# Line 64  my $last_x_tags = 50; Line 93  my $last_x_tags = 50;
93    
94  # don't pull rss feeds more often than this  # don't pull rss feeds more often than this
95  my $rss_min_delay = 60;  my $rss_min_delay = 60;
 $rss_min_delay = 15;  
96    
97  my $http_port = $NICK =~ m/-dev/ ? 8001 : 8000;  my $http_port = $NICK =~ m/-dev/ ? 8001 : 8000;
98    
# Line 72  my $url = "http://$HOSTNAME:$http_port"; Line 100  my $url = "http://$HOSTNAME:$http_port";
100    
101  ## END CONFIG  ## END CONFIG
102    
 use POE qw(Component::IRC Wheel::FollowTail Component::Server::HTTP);  
 use HTTP::Status;  
 use DBI;  
 use Regexp::Common qw /URI/;  
 use CGI::Simple;  
 use HTML::TagCloud;  
 use POSIX qw/strftime/;  
 use HTML::CalendarMonthSimple;  
 use Getopt::Long;  
 use DateTime;  
 use URI::Escape;  
 use Data::Dump qw/dump/;  
 use DateTime::Format::ISO8601;  
 use Carp qw/confess/;  
 use XML::Feed;  
 use DateTime::Format::Flexible;  
   
103  my $use_twitter = 1;  my $use_twitter = 1;
104  eval { require Net::Twitter; };  eval { require Net::Twitter; };
105  $use_twitter = 0 if ($@);  $use_twitter = 0 if ($@);
# Line 97  my $import_dircproxy; Line 108  my $import_dircproxy;
108  my $log_path;  my $log_path;
109  GetOptions(  GetOptions(
110          'import-dircproxy:s' => \$import_dircproxy,          'import-dircproxy:s' => \$import_dircproxy,
         'follows:s' => \$follows_path,  
111          'log:s' => \$log_path,          'log:s' => \$log_path,
112            'debug!' => \$debug,
113  );  );
114    
115  #$SIG{__DIE__} = sub {  #$SIG{__DIE__} = sub {
116  #       confess "fatal error";  #       confess "fatal error";
117  #};  #};
118    
 open(STDOUT, '>', $log_path) || warn "can't redirect log to $log_path: $!";  
   
119  sub _log {  sub _log {
120          print strftime($TIMESTAMP,localtime()) . ' ' . join(" ",@_) . $/;          print strftime($TIMESTAMP,localtime()) . ' ' . join(" ",map { ref($_) ? dump( $_ ) : $_ } @_) . $/;
121  }  }
122    
123  # LOG following  open(STDOUT, '>', $log_path) && warn "log to $log_path: $!\n";
124    
 my %FOLLOWS =  
   (  
 #   ACCESS => "/var/log/apache/access.log",  
 #   ERROR => "/var/log/apache/error.log",  
   );  
   
 sub add_follow_path {  
         my $path = shift;  
         my $name = $path;  
         $name =~ s/\..*$//;  
         warn "# using $path to announce messages from $name\n";  
         $FOLLOWS{$name} = $path;  
 }  
   
 add_follow_path( $follows_path ) if ( -e $follows_path );  
125    
126  # HTML formatters  # HTML formatters
127    
# Line 146  my $filter = { Line 140  my $filter = {
140                  # protect HTML from wiki modifications                  # protect HTML from wiki modifications
141                  sub e {                  sub e {
142                          my $t = shift;                          my $t = shift;
143                          return 'uri_unescape{' . uri_escape($t) . '}';                          return 'uri_unescape{' . uri_escape($t, '^a-zA-Z0-9') . '}';
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;
# Line 171  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 207  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 256  sub meta { Line 260  sub meta {
260                  if ( $@ || ! $sth->rows ) {                  if ( $@ || ! $sth->rows ) {
261                          $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()) });
262                          $sth->execute( $value, $nick, $channel, $name );                          $sth->execute( $value, $nick, $channel, $name );
263                          _log "created $nick/$channel/$name = $value";                          warn "## created $nick/$channel/$name = $value\n";
264                  } else {                  } else {
265                          _log "updated $nick/$channel/$name = $value ";                          warn "## updated $nick/$channel/$name = $value\n";
266                  }                  }
267    
268                  return $value;                  return $value;
# Line 268  sub meta { Line 272  sub meta {
272                  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 = ? });
273                  $sth->execute( $nick, $channel, $name );                  $sth->execute( $nick, $channel, $name );
274                  my ($v,$c) = $sth->fetchrow_array;                  my ($v,$c) = $sth->fetchrow_array;
275                  _log "fetched $nick/$channel/$name = $v [$c]";                  warn "## fetched $nick/$channel/$name = $v [$c]\n";
276                  return ($v,$c) if wantarray;                  return ($v,$c) if wantarray;
277                  return $v;                  return $v;
278    
# Line 365  sub get_from_log { Line 369  sub get_from_log {
369    
370          my @where;          my @where;
371          my @args;          my @args;
372            my $msg;
373    
374          if (my $search = $args->{search}) {          if (my $search = $args->{search}) {
375                  $search =~ s/^\s+//;                  $search =~ s/^\s+//;
376                  $search =~ s/\s+$//;                  $search =~ s/\s+$//;
377                  push @where, 'message ilike ? or nick ilike ?';                  push @where, 'message ilike ? or nick ilike ?';
378                  push @args, ( ( '%' . $search . '%' ) x 2 );                  push @args, ( ( '%' . $search . '%' ) x 2 );
379                  _log "search for '$search'";                  $msg = "Search for '$search'";
380          }          }
381    
382          if ($args->{tag} && $tags->{ $args->{tag} }) {          if ($args->{tag} && $tags->{ $args->{tag} }) {
383                  push @where, 'id in (' . join(',', @{ $tags->{ $args->{tag} } }) . ')';                  push @where, 'id in (' . join(',', @{ $tags->{ $args->{tag} } }) . ')';
384                  _log "search for tags $args->{tag}";                  $msg = "Search for tags $args->{tag}";
385          }          }
386    
387          if (my $date = $args->{date} ) {          if (my $date = $args->{date} ) {
388                  $date = check_date( $date );                  $date = check_date( $date );
389                  push @where, 'date(time) = ?';                  push @where, 'date(time) = ?';
390                  push @args, $date;                  push @args, $date;
391                  _log "search for date $date";                  $msg = "search for date $date";
392          }          }
393    
394          $sql .= " where " . join(" and ", @where) if @where;          $sql .= " where " . join(" and ", @where) if @where;
# Line 397  sub get_from_log { Line 402  sub get_from_log {
402          eval { $sth->execute( @args ) };          eval { $sth->execute( @args ) };
403          return if $@;          return if $@;
404    
405            my $nr_results = $sth->rows;
406    
407          my $last_row = {          my $last_row = {
408                  date => '',                  date => '',
409                  time => '',                  time => '',
# Line 417  sub get_from_log { Line 424  sub get_from_log {
424    
425          return @rows if ($args->{full_rows});          return @rows if ($args->{full_rows});
426    
427          my @msgs = (          $msg .= ' produced ' . (
428                  "Showing " . ($#rows + 1) . " messages..."                  $nr_results == 0 ? 'no results' :
429                    $nr_results == 0 ? 'one result' :
430                            $nr_results . ' results'
431          );          );
432    
433            my @msgs = ( $msg );
434    
435          if ($context) {          if ($context) {
436                  my @ids = @rows;                  my @ids = @rows;
437                  @rows = ();                  @rows = ();
# Line 477  sub get_from_log { Line 488  sub get_from_log {
488  #                       $row->{nick} = $nick;  #                       $row->{nick} = $nick;
489  #               }  #               }
490    
491                    $append = 0 if $row->{me};
492    
493                  if ($last_row->{nick} ne $nick) {                  if ($last_row->{nick} ne $nick) {
494                          # 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
495                          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 592  sub save_message { Line 605  sub save_message {
605          $a->{me} ||= 0;          $a->{me} ||= 0;
606          $a->{time} ||= strftime($TIMESTAMP,localtime());          $a->{time} ||= strftime($TIMESTAMP,localtime());
607    
608          _log          _log "ARCHIVE",
609                  $a->{channel}, " ",                  $a->{channel}, " ",
610                  $a->{me} ? "***" . $a->{nick} : "<" . $a->{nick} . ">",                  $a->{me} ? "***" . $a->{nick} : "<" . $a->{nick} . ">",
611                  " " . $a->{message};                  " " . $a->{message};
# Line 640  if ($import_dircproxy) { Line 653  if ($import_dircproxy) {
653  # RSS follow  # RSS follow
654  #  #
655    
656  my $_rss;  my $_stat;
657    
658    POE::Component::Client::HTTP->spawn(
659            Alias   => 'rss-fetch',
660            Timeout => 30,
661    );
662    
663    =head2 rss_parse_xml
664    
665  sub rss_fetch {    rss_parse_xml({
666          my ($args) = @_;          url => 'http://www.example.com/rss',
667            send_rss_msgs => 42,
668      });
669    
670    =cut
671    
672    sub rss_parse_xml {
673            my ($kernel,$args) = @_;
674    
675            warn "## rss_parse_xml ",dump( $args ) if $debug;
676    
677          # 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?
678          my $send_rss_msgs = 1;          my $send_rss_msgs = $args->{send_rss_msgs};
679            $send_rss_msgs = 1 if ! defined $send_rss_msgs;
680    
681          _log "RSS fetch", $args->{url};          warn "## RSS fetch first $send_rss_msgs items from", $args->{url} if $debug;
682    
683          my $feed = XML::Feed->parse(URI->new( $args->{url} ));          my $feed = XML::Feed->parse( \$args->{xml} );
684          if ( ! $feed ) {          if ( ! $feed ) {
685                  _log("can't fetch RSS ", $args->{url});                  _log "can't fetch RSS ", $args->{url}, XML::Feed->errstr;
686                  return;                  return;
687          }          }
688    
689            $_stat->{rss}->{url2link}->{ $args->{url} } = $feed->link;
690    
691          my ( $total, $updates ) = ( 0, 0 );          my ( $total, $updates ) = ( 0, 0 );
692          for my $entry ($feed->entries) {          for my $entry ($feed->entries) {
693                  $total++;                  $total++;
694    
695                    my $seen_times = $_stat->{rss}->{seen}->{$args->{channel}}->{$feed->link}->{$entry->id}++;
696                  # seen allready?                  # seen allready?
697                  return if $_rss->{$feed->link}->{seen}->{$entry->id}++ > 0;                  warn "## $seen_times ",$entry->id if $debug;
698                    next if $seen_times > 0;
699    
700                  sub prefix {                  sub prefix {
701                          my ($txt,$var) = @_;                          my ($txt,$var) = @_;
702                            $var =~ s/\s+/ /gs;
703                          $var =~ s/^\s+//g;                          $var =~ s/^\s+//g;
704                            $var =~ s/\s+$//g;
705                          return $txt . $var if $var;                          return $txt . $var if $var;
706                  }                  }
707    
708                    # fix absolute and relative links to feed entries
709                    my $link = $entry->link;
710                    if ( $link =~ m!^/! ) {
711                            my $host = $args->{url};
712                            $host =~ s!^(http://[^/]+).*$!$1!;      #!vim
713                            $link = "$host/$link";
714                    } elsif ( $link !~ m!^http! ) {
715                            $link = $args->{url} . $link;
716                    }
717    
718                  my $msg;                  my $msg;
719                  $msg .= prefix( 'From: ' , $feed->title );                  $msg .= prefix( 'From: ' , $args->{name} || $feed->title );
720                  $msg .= prefix( ' by ' , $entry->author );                  $msg .= prefix( ' by ' , $entry->author );
721                  $msg .= prefix( ' -- ' , $entry->link );                  $msg .= prefix( ' | ' , $entry->title );
722                    $msg .= prefix( ' | ' , $link );
723  #               $msg .= prefix( ' id ' , $entry->id );  #               $msg .= prefix( ' id ' , $entry->id );
724                    my @categories = $entry->category;
725                    warn "## category = ", dump( @categories ) if $debug;
726                    if ( my $tags = $entry->category ) {
727                            $tags = join(' ', @$tags) if ref($tags) eq 'ARRAY';
728                            $tags =~ s!^\s+!!;
729                            $tags =~ s!\s*$! !;
730                            $tags =~ s!,?\s+!// !g;
731                            $msg .= prefix( ' ' , $tags );
732                    }
733    
734                  if ( $args->{kernel} && $send_rss_msgs ) {                  if ( $seen_times == 0 && $send_rss_msgs ) {
735                          $send_rss_msgs--;                          $send_rss_msgs--;
736                          _log('RSS', $msg);                          if ( ! $args->{private} ) {
737                          $sth_insert_log->execute( $CHANNEL, 1, $NICK, $msg, undef );                                  # FIXME bug! should be save_message
738                          $args->{kernel}->post( $IRC_ALIAS => notice => $CHANNEL, $msg );                                  save_message( channel => $args->{channel}, me => 1, nick => $NICK, message => $msg );
739    #                               $sth_insert_log->execute( $args->{channel}, 1, $NICK, $msg, 'now()' );
740                            }
741                            my ( $type, $to ) = ( 'notice', $args->{channel} );
742                            ( $type, $to ) = ( 'privmsg', $args->{nick} ) if $args->{private};
743    
744                            _log(">> RSS $type to $to:", $msg);
745                            $kernel->post( $irc => $type => $to => $msg );
746    
747                          $updates++;                          $updates++;
748                  }                  }
749          }          }
# Line 689  sub rss_fetch { Line 753  sub rss_fetch {
753          $sql .= qq{where id = } . $args->{id};          $sql .= qq{where id = } . $args->{id};
754          eval { $dbh->do( $sql ) };          eval { $dbh->do( $sql ) };
755    
756          _log "RSS got $total items of which $updates new";          _log "RSS $updates/$total new items from", $args->{url};
757    
758          return $updates;          return $updates;
759  }  }
760    
761  sub rss_fetch_all {  sub rss_fetch_all {
762          my $kernel = shift;          my ( $kernel, $send_rss_msgs )  = @_;
763            warn "## rss_fetch_all -- send_rss_msgs: $send_rss_msgs\n" if $debug;
764          my $sql = qq{          my $sql = qq{
765                  select id, url, name                  select id, url, name, channel, nick, private
766                  from feeds                  from feeds
767                  where active is true                  where active is true
768          };          };
769          # limit to newer feeds only if we are not sending messages out          # limit to newer feeds only if we are not sending messages out
770          $sql .= qq{     and last_update + delay < now() } if $kernel;          $sql .= qq{     and last_update + delay < now() } if defined ( $_stat->{rss}->{fetch} );
771          my $sth = $dbh->prepare( $sql );          my $sth = $dbh->prepare( $sql );
772          $sth->execute();          $sth->execute();
773          warn "# ",$sth->rows," active RSS feeds\n";          warn "# ",$sth->rows," active RSS feeds\n";
774          my $count = 0;          my $count = 0;
775          while (my $row = $sth->fetchrow_hashref) {          while (my $row = $sth->fetchrow_hashref) {
776                  $row->{kernel} = $kernel if $kernel;                  $row->{send_rss_msgs} = $send_rss_msgs if defined $send_rss_msgs;
777                  $count += rss_fetch( $row );                  $_stat->{rss}->{fetch}->{ $row->{url} } = $row;
778                    $kernel->post(
779                            'rss-fetch',
780                            'request',
781                            'rss_response',
782                            HTTP::Request->new( GET => $row->{url} ),
783                    );
784                    warn "## queued rss-fetch ", dump( $row ) if $debug;
785          }          }
786          return "OK, fetched $count posts from " . $sth->rows . " feeds";          return "OK, scheduled " . $sth->rows . " feeds for refresh";
787  }  }
788    
789    
790  sub rss_check_updates {  sub rss_check_updates {
791          my $kernel = shift;          my $kernel = shift;
792          my $last_t = $_rss->{last_poll} || time();          $_stat->{rss}->{last_poll} ||= time();
793          my $t = time();          my $dt = time() - $_stat->{rss}->{last_poll};
794          if ( $last_t - $t > $rss_min_delay ) {          if ( $dt > $rss_min_delay ) {
795                  $_rss->{last_poll} = $t;                  warn "## rss_check_updates $dt > $rss_min_delay\n";
796                    $_stat->{rss}->{last_poll} = time();
797                  _log rss_fetch_all( $kernel );                  _log rss_fetch_all( $kernel );
798          }          }
799  }  }
800    
801  # seed rss seen cache so we won't send out all items on startup  sub process_command {
802  _log rss_fetch_all;          my ( $kernel, $nick, $channel, $msg ) = @_;
803    
804  #          my $res = "unknown command '$msg', try /msg $NICK help!";
805  # POE handing part  
806  #          if ($msg =~ m/^help/i) {
807    
808                    $res = "usage: /msg $NICK comand | commands: stat - user/message stat | last - show backtrace | grep foobar - find foobar";
809    
810            } elsif ($msg =~ m/^(privmsg|notice)\s+(\S+)\s+(.*)$/i) {
811    
812                    _log ">> /$1 $2 $3";
813                    $kernel->post( $irc => $1 => $2, $3 );
814                    $res = '';
815    
816            } elsif ($msg =~ m/^stat.*?\s*(\d*)/i) {
817    
818                    my $nr = $1 || 10;
819    
820                    my $sth = $dbh->prepare(qq{
821                            select
822                                    trim(both '_' from nick) as nick,
823                                    count(*) as count,
824                                    sum(length(message)) as len
825                            from log
826                            group by trim(both '_' from nick)
827                            order by len desc,count desc
828                            limit $nr
829                    });
830                    $sth->execute();
831                    $res = "Top $nr users: ";
832                    my @users;
833                    while (my $row = $sth->fetchrow_hashref) {
834                            push @users,$row->{nick} . ': ' . $row->{count} . '/' . $row->{len} . '=' . sprintf("%.2f", $row->{len}/$row->{count});
835                    }
836                    $res .= join(" | ", @users);
837            } elsif ($msg =~ m/^last.*?\s*(\d*)/i) {
838    
839                    my $limit = $1 || meta( $nick, $channel, 'last-size' ) || 10;
840    
841                    foreach my $res (get_from_log( limit => $limit )) {
842                            _log "last: $res";
843                            $kernel->post( $irc => privmsg => $nick, $res );
844                    }
845    
846                    $res = '';
847    
848            } elsif ($msg =~ m/^(search|grep)\s+(.*)\s*$/i) {
849    
850                    my $what = $2;
851    
852                    foreach my $res (get_from_log(
853                                    limit => 20,
854                                    search => $what,
855                            )) {
856                            _log "search [$what]: $res";
857                            $kernel->post( $irc => privmsg => $nick, $res );
858                    }
859    
860                    $res = '';
861    
862            } elsif ($msg =~ m/^(?:count|poll)\s+(.*)(?:\s+(\d+))?\s*$/i) {
863    
864                    my ($what,$limit) = ($1,$2);
865                    $limit ||= 100;
866    
867                    my $stat;
868    
869                    foreach my $res (get_from_log(
870                                    limit => $limit,
871                                    search => $what,
872                                    full_rows => 1,
873                            )) {
874                            while ($res->{message} =~ s/\Q$what\E(\+|\-)//) {
875                                    $stat->{vote}->{$1}++;
876                                    $stat->{from}->{ $res->{nick} }++;
877                            }
878                    }
879    
880  my $SKIPPING = 0;               # if skipping, how many we've done                  my @nicks;
881  my $SEND_QUEUE;                 # cache                  foreach my $nick (sort { $stat->{from}->{$a} <=> $stat->{from}->{$b} } keys %{ $stat->{from} }) {
882  my $ping;                                               # ping stats                          push @nicks, $nick . ( $stat->{from}->{$nick} == 1 ? '' :
883                                    "(" . $stat->{from}->{$nick} . ")"
884                            );
885                    }
886    
887                    $res =
888                            "$what ++ " . ( $stat->{vote}->{'+'} || 0 ) .
889                            " : " . ( $stat->{vote}->{'-'} || 0 ) . " --" .
890                            " from " . ( join(", ", @nicks) || 'nobody' );
891    
892                    $kernel->post( $irc => notice => $nick, $res );
893    
894            } elsif ($msg =~ m/^ping/) {
895                    $res = "ping = " . dump( $_stat->{ping} );
896            } elsif ($msg =~ m/^conf(?:ig)*\s*(last-size|twitter)*\s*(.*)/) {
897                    if ( ! defined( $1 ) ) {
898                            my $sth = $dbh->prepare(qq{ select name,value,changed from meta where nick = ? and channel = ? });
899                            $sth->execute( $nick, $channel );
900                            $res = "config for $nick on $channel";
901                            while ( my ($n,$v) = $sth->fetchrow_array ) {
902                                    $res .= " | $n = $v";
903                            }
904                    } elsif ( ! $2 ) {
905                            my $val = meta( $nick, $channel, $1 );
906                            $res = "current $1 = " . ( $val ? $val : 'undefined' );
907                    } else {
908                            my $validate = {
909                                    'last-size' => qr/^\d+/,
910                                    'twitter' => qr/^\w+\s+\w+/,
911                            };
912    
913                            my ( $op, $val ) = ( $1, $2 );
914    
915  POE::Component::IRC->new($IRC_ALIAS);                          if ( my $regex = $validate->{$op} ) {
916                                    if ( $val =~ $regex ) {
917                                            meta( $nick, $channel, $op, $val );
918                                            $res = "saved $op = $val";
919                                    } else {
920                                            $res = "config option $op = $val doesn't validate against $regex";
921                                    }
922                            } else {
923                                    $res = "config option $op doesn't exist";
924                            }
925                    }
926            } elsif ($msg =~ m/^rss-update/) {
927                    $res = rss_fetch_all( $kernel );
928            } elsif ($msg =~ m/^rss-list/) {
929                    my $sth = $dbh->prepare(qq{ select url,name,last_update,active,channel,nick,private from feeds });
930                    $sth->execute;
931                    while (my @row = $sth->fetchrow_array) {
932                            $kernel->post( $irc => privmsg => $nick, join(' | ',@row) );
933                    }
934                    $res = '';
935            } elsif ($msg =~ m!^rss-(add|remove|stop|start|clean)(?:-(private))?\s+(http://\S+)\s*(.*)!) {
936                    my ( $command, $sub, $url, $arg ) = ( $1,$2,$3,$4 );
937    
938                    my $channel = $1 if ( $arg =~ s/\s*(#\S+)\s*// );
939                    $channel = $nick if $sub eq 'private';
940    
941                    my $sql = {
942                            add     => qq{ insert into feeds (url,name,channel,nick,private) values (?,?,?,?,?) },
943                            remove  => qq{ delete from feeds                                where url = ? and nick = ? },
944                            start   => qq{ update feeds set active = true   where url = ? },
945                            stop    => qq{ update feeds set active = false  where url = ? },
946                            clean   => qq{ update feeds set last_update = now() - delay where url = ? },
947                    };
948    
949                    if ( $command eq 'add' && ! $channel ) {
950                            $res = "ERROR: got '$msg' which doesn't have #channel in it, ignoring!";
951                    } elsif (my $q = $sql->{$command} ) {
952                            my $sth = $dbh->prepare( $q );
953                            my @data = ( $url );
954                            if ( $command eq 'add' ) {
955                                    push @data, ( $arg, $channel, $nick, $sub eq 'private' ? 1 : 0 );
956                            } elsif ( $command eq 'remove' ) {
957                                    push @data, $nick;
958                            }
959                            warn "## $command SQL $q with ",dump( @data ),"\n";
960                            eval { $sth->execute( @data ) };
961                            if ($@) {
962                                    $res = "ERROR: $@";
963                            } else {
964                                    $res = "OK, RSS executed $command" .
965                                            ( $sub ? "-$sub " : ' ' ) .
966                                            ( $channel ? "on $channel " : '' ) .
967                                            "url $url";
968                                    if ( $command eq 'clean' ) {
969                                            my $seen = $_stat->{rss}->{seen} || die "no seen?";
970                                            my $want_link = $_stat->{rss}->{url2link}->{$url} || warn "no url2link($url)";
971                                            foreach my $c ( keys %$seen ) {
972                                                    my $c_hash = $seen->{$c} || die "no seen->{$c}";
973                                                    die "not HASH with rss links but ", dump($c_hash) unless ref($c_hash) eq 'HASH';
974                                                    foreach my $link ( keys %$c_hash ) {
975                                                            next unless $link eq $want_link;
976                                                            _log "RSS removed seen $c $url $link";
977                                                    }
978                                            }
979                                    } elsif ( $command eq 'add' ) {
980                                            rss_fetch_all( $kernel );
981                                    }
982                            }
983                    } else {
984                            $res = "ERROR: don't know what to do with: $msg";
985                    }
986            } elsif ($msg =~ m/^rss-clean/) {
987                    # this makes sense because we didn't catch rss-clean http://... before!
988                    $_stat->{rss} = undef;
989                    $dbh->do( qq{ update feeds set last_update = now() - delay } );
990                    $res = rss_fetch_all( $kernel );
991            }
992    
993            return $res;
994    }
995    
996  POE::Session->create( inline_states => {  POE::Session->create( inline_states => {
997          _start => sub {                _start => sub {      
998                  $_[KERNEL]->post($IRC_ALIAS => register => 'all');                  $_[KERNEL]->post( $irc => register => 'all' );
999                  $_[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" );  
1000      },      },
1001            irc_001 => sub {
1002                    my ($kernel,$sender) = @_[KERNEL,SENDER];
1003                    my $poco_object = $sender->get_heap();
1004                    _log "connected to",$poco_object->server_name();
1005                    $kernel->post( $sender => join => $_ ) for @channels;
1006                    # seen RSS cache, so don't send out messages
1007                    _log rss_fetch_all( $kernel, 0 );
1008                    undef;
1009            },
1010    #       irc_255 => sub {        # server is done blabbing
1011    #               $_[KERNEL]->post( $irc => join => $CHANNEL);
1012    #       },
1013      irc_public => sub {      irc_public => sub {
1014                  my $kernel = $_[KERNEL];                  my $kernel = $_[KERNEL];
1015                  my $nick = (split /!/, $_[ARG0])[0];                  my $nick = (split /!/, $_[ARG0])[0];
# Line 755  POE::Session->create( inline_states => { Line 1018  POE::Session->create( inline_states => {
1018    
1019                  save_message( channel => $channel, me => 0, nick => $nick, message => $msg);                  save_message( channel => $channel, me => 0, nick => $nick, message => $msg);
1020                  meta( $nick, $channel, 'last-msg', $msg );                  meta( $nick, $channel, 'last-msg', $msg );
1021                    rss_check_updates( $kernel );
1022      },      },
1023      irc_ctcp_action => sub {      irc_ctcp_action => sub {
1024                  my $kernel = $_[KERNEL];                  my $kernel = $_[KERNEL];
# Line 776  POE::Session->create( inline_states => { Line 1040  POE::Session->create( inline_states => {
1040      },      },
1041          irc_ping => sub {          irc_ping => sub {
1042                  _log( "pong ", $_[ARG0] );                  _log( "pong ", $_[ARG0] );
1043                  $ping->{ $_[ARG0] }++;                  $_stat->{ping}->{ $_[ARG0] }++;
1044                  rss_check_updates( $_[KERNEL] );                  rss_check_updates( $_[KERNEL] );
1045          },          },
1046          irc_invite => sub {          irc_invite => sub {
# Line 786  POE::Session->create( inline_states => { Line 1050  POE::Session->create( inline_states => {
1050    
1051                  _log "invited to $channel by $nick";                  _log "invited to $channel by $nick";
1052    
1053                  $_[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..." );
1054                  $_[KERNEL]->post($IRC_ALIAS => join => $channel);                  $_[KERNEL]->post( $irc => 'join' => $channel );
1055    
1056          },          },
1057          irc_msg => sub {          irc_msg => sub {
1058                  my $kernel = $_[KERNEL];                  my $kernel = $_[KERNEL];
1059                  my $nick = (split /!/, $_[ARG0])[0];                  my $nick = (split /!/, $_[ARG0])[0];
                 my $msg = $_[ARG2];  
1060                  my $channel = $_[ARG1]->[0];                  my $channel = $_[ARG1]->[0];
1061                    my $msg = $_[ARG2];
1062                  my $res = "unknown command '$msg', try /msg $NICK help!";                  warn "# ARG = ",dump( @_[ARG0,ARG1,ARG2] ) if $debug;
                 my @out;  
1063    
1064                  _log "<< $msg";                  _log "<< $msg";
1065    
1066                  if ($msg =~ m/^help/i) {                  my $res = process_command( $_[KERNEL], $nick, $channel, $msg );
   
                         $res = "usage: /msg $NICK comand | commands: stat - user/message stat | last - show backtrace | grep foobar - find foobar";  
   
                 } elsif ($msg =~ m/^msg\s+(\S+)\s+(.*)$/i) {  
   
                         _log ">> /msg $1 $2";  
                         $_[KERNEL]->post( $IRC_ALIAS => privmsg => $1, $2 );  
                         $res = '';  
   
                 } elsif ($msg =~ m/^stat.*?\s*(\d*)/i) {  
   
                         my $nr = $1 || 10;  
   
                         my $sth = $dbh->prepare(qq{  
                                 select  
                                         trim(both '_' from nick) as nick,  
                                         count(*) as count,  
                                         sum(length(message)) as len  
                                 from log  
                                 group by trim(both '_' from nick)  
                                 order by len desc,count desc  
                                 limit $nr  
                         });  
                         $sth->execute();  
                         $res = "Top $nr users: ";  
                         my @users;  
                         while (my $row = $sth->fetchrow_hashref) {  
                                 push @users,$row->{nick} . ': ' . $row->{count} . '/' . $row->{len} . '=' . sprintf("%.2f", $row->{len}/$row->{count});  
                         }  
                         $res .= join(" | ", @users);  
                 } elsif ($msg =~ m/^last.*?\s*(\d*)/i) {  
   
                         my $limit = $1 || meta( $nick, $channel, 'last-size' ) || 10;  
   
                         foreach my $res (get_from_log( limit => $limit )) {  
                                 _log "last: $res";  
                                 $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );  
                         }  
   
                         $res = '';  
   
                 } elsif ($msg =~ m/^(search|grep)\s+(.*)\s*$/i) {  
   
                         my $what = $2;  
   
                         foreach my $res (get_from_log(  
                                         limit => 20,  
                                         search => $what,  
                                 )) {  
                                 _log "search [$what]: $res";  
                                 $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );  
                         }  
   
                         $res = '';  
   
                 } elsif ($msg =~ m/^(?:count|poll)\s+(.*)(?:\s+(\d+))?\s*$/i) {  
   
                         my ($what,$limit) = ($1,$2);  
                         $limit ||= 100;  
   
                         my $stat;  
   
                         foreach my $res (get_from_log(  
                                         limit => $limit,  
                                         search => $what,  
                                         full_rows => 1,  
                                 )) {  
                                 while ($res->{message} =~ s/\Q$what\E(\+|\-)//) {  
                                         $stat->{vote}->{$1}++;  
                                         $stat->{from}->{ $res->{nick} }++;  
                                 }  
                         }  
   
                         my @nicks;  
                         foreach my $nick (sort { $stat->{from}->{$a} <=> $stat->{from}->{$b} } keys %{ $stat->{from} }) {  
                                 push @nicks, $nick . ( $stat->{from}->{$nick} == 1 ? '' :  
                                         "(" . $stat->{from}->{$nick} . ")"  
                                 );  
                         }  
   
                         $res =  
                                 "$what ++ " . ( $stat->{vote}->{'+'} || 0 ) .  
                                 " : " . ( $stat->{vote}->{'-'} || 0 ) . " --" .  
                                 " from " . ( join(", ", @nicks) || 'nobody' );  
   
                         $_[KERNEL]->post( $IRC_ALIAS => notice => $nick, $res );  
   
                 } elsif ($msg =~ m/^ping/) {  
                         $res = "ping = " . dump( $ping );  
                 } elsif ($msg =~ m/^conf(?:ig)*\s*(last-size|twitter)*\s*(.*)/) {  
                         if ( ! defined( $1 ) ) {  
                                 my $sth = $dbh->prepare(qq{ select name,value,changed from meta where nick = ? and channel = ? });  
                                 $sth->execute( $nick, $channel );  
                                 $res = "config for $nick on $channel";  
                                 while ( my ($n,$v) = $sth->fetchrow_array ) {  
                                         $res .= " | $n = $v";  
                                 }  
                         } elsif ( ! $2 ) {  
                                 my $val = meta( $nick, $channel, $1 );  
                                 $res = "current $1 = " . ( $val ? $val : 'undefined' );  
                         } else {  
                                 my $validate = {  
                                         'last-size' => qr/^\d+/,  
                                         'twitter' => qr/^\w+\s+\w+/,  
                                 };  
   
                                 my ( $op, $val ) = ( $1, $2 );  
   
                                 if ( my $regex = $validate->{$op} ) {  
                                         if ( $val =~ $regex ) {  
                                                 meta( $nick, $channel, $op, $val );  
                                                 $res = "saved $op = $val";  
                                         } else {  
                                                 $res = "config option $op = $val doesn't validate against $regex";  
                                         }  
                                 } else {  
                                         $res = "config option $op doesn't exist";  
                                 }  
                         }  
                 } elsif ($msg =~ m/^rss-update/) {  
                         $res = rss_fetch_all( $_[KERNEL] );  
                 } elsif ($msg =~ m/^rss-clean/) {  
                         $_rss = undef;  
                         $res = "OK, cleaned RSS cache";  
                 } elsif ($msg =~ m!^rss-(add|remove|stop|start)\s+(http://\S+)\s*(.*)!) {  
                         my $sql = {  
                                 add             => qq{ insert into feeds (url,name) values (?,?) },  
 #                               remove  => qq{ delete from feeds                                where url = ? and name = ? },  
                                 start   => qq{ update feeds set active = true   where url = ? -- ? },  
                                 stop    => qq{ update feeds set active = false  where url = ? -- ? },  
                                   
                         };  
                         if (my $q = $sql->{$1} ) {  
                                 my $sth = $dbh->prepare( $q );  
                                 warn "## SQL $q ( $2 | $3 )\n";  
                                 eval { $sth->execute( $2, $3 ) };  
                         }  
   
                         $res ||= "OK, RSS $1 : $2 - $3";  
                 }  
1067    
1068                  if ($res) {                  if ($res) {
1069                          _log ">> [$nick] $res";                          _log ">> [$nick] $res";
1070                          $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );                          $_[KERNEL]->post( $irc => privmsg => $nick, $res );
1071                  }                  }
1072    
1073                  rss_check_updates( $_[KERNEL] );                  rss_check_updates( $_[KERNEL] );
1074          },          },
1075            irc_372 => sub {
1076                    _log "<< motd",$_[ARG0],$_[ARG1];
1077            },
1078            irc_375 => sub {
1079                    _log "<< motd", $_[ARG0], "start";
1080            },
1081            irc_376 => sub {
1082                    _log "<< motd", $_[ARG0], "end";
1083            },
1084    #       irc_433 => sub {
1085    #               print "# irc_433: ",$_[ARG1], "\n";
1086    #               warn "## indetify $NICK\n";
1087    #               $_[KERNEL]->post( $irc => privmsg => 'nickserv', "IDENTIFY $NICK" );
1088    #       },
1089    #       irc_451 # please register
1090          irc_477 => sub {          irc_477 => sub {
1091                  _log "# irc_477: ",$_[ARG1];                  _log "<< irc_477: ",$_[ARG1];
1092                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "register $NICK" );                  _log ">> IDENTIFY $NICK";
1093                    $_[KERNEL]->post( $irc => privmsg => 'NickServ', "IDENTIFY $NICK" );
1094          },          },
1095          irc_505 => sub {          irc_505 => sub {
1096                  _log "# irc_505: ",$_[ARG1];                  _log "<< irc_505: ",$_[ARG1];
1097                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "register $NICK" );                  _log ">> register $NICK";
1098  #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "set hide email on" );                  $_[KERNEL]->post( $irc => privmsg => 'NickServ', "register $NICK" );
1099  #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "set email dpavlin\@rot13.org" );  #               $_[KERNEL]->post( $irc => privmsg => 'nickserv', "IDENTIFY $NICK" );
1100    #               $_[KERNEL]->post( $irc => privmsg => 'nickserv', "set hide email on" );
1101    #               $_[KERNEL]->post( $irc => privmsg => 'nickserv', "set email dpavlin\@rot13.org" );
1102          },          },
1103          irc_registered => sub {          irc_registered => sub {
1104                  _log "## registrated $NICK";                  _log "<< registered $NICK";
                 $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );  
1105          },          },
1106          irc_disconnected => sub {          irc_disconnected => sub {
1107                  _log "## disconnected, reconnecting again";                  _log "## disconnected.. sleeping for $sleep_on_error seconds and reconnecting again";
1108                  $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);                  sleep($sleep_on_error);
1109                    $_[KERNEL]->post( $irc => connect => {} );
1110          },          },
1111          irc_socketerr => sub {          irc_socketerr => sub {
1112                  _log "## socket error... sleeping for $sleep_on_error seconds and retry";                  _log "## socket error... sleeping for $sleep_on_error seconds and retry";
1113                  sleep($sleep_on_error);                  sleep($sleep_on_error);
1114                  $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);                  $_[KERNEL]->post( $irc => connect => {} );
1115            },
1116            irc_notice => sub {
1117                    _log "<< notice from ", $_[ARG0], $_[ARG1], $_[ARG2];
1118                    my $m = $_[ARG2];
1119                    if ( $m =~ m!/msg.*(NickServ).*(IDENTIFY)!i ) {
1120                            _log ">> suggested to $1 $2";
1121                            $_[KERNEL]->post( $irc => privmsg => $1, "$2 $NICK" );
1122                    } elsif ( $m =~ m!\Q$NICK\E.*registered!i ) {
1123                            _log ">> registreted, so IDENTIFY";
1124                            $_[KERNEL]->post( $irc => privmsg => 'nickserv', "IDENTIFY $NICK" );
1125                    } else {
1126                            warn "## ignore $m\n" if $debug;
1127                    }
1128            },
1129            irc_snotice => sub {
1130                    _log "<< snotice", $_[ARG0]; #dump( $_[ARG0],$_[ARG1], $_[ARG2] );
1131                    if ( $_[ARG0] =~ m!/(QUOTE)\s+(PASS\s+\d+)!i ) {
1132                            warn ">> $1 | $2\n";
1133                            $_[KERNEL]->post( $irc => lc($1) => $2);
1134                    }
1135          },          },
 #       irc_433 => sub {  
 #               print "# irc_433: ",$_[ARG1], "\n";  
 #               warn "## indetify $NICK\n";  
 #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );  
 #       },  
1136      _child => sub {},      _child => sub {},
1137      _default => sub {      _default => sub {
1138                  _log sprintf "sID:%s %s %s",                  _log '_default SID:', $_[SESSION]->ID, $_[ARG0], dump( $_[ARG1] );
1139                          $_[SESSION]->ID, $_[ARG0],                  0; # false for signals
                         ref($_[ARG1]) eq "ARRAY"        ?       join(",", map { ref($_) eq "ARRAY" ? join(";", @{$_}) : $_ } @{ $_[ARG1] })     :  
                         $_[ARG1]                                        ?       $_[ARG1]                                        :  
                         "";  
       0;                        # false for signals  
1140      },      },
1141            rss_response => sub {
1142                    my ($request_packet, $response_packet) = @_[ARG0, ARG1];
1143                    my $request_object  = $request_packet->[0];
1144                    my $response_object = $response_packet->[0];
1145    
1146                    my $row = delete( $_stat->{rss}->{fetch}->{ $request_object->uri } );
1147                    if ( $row ) {
1148                            $row->{xml} = $response_object->content;
1149                            rss_parse_xml( $_[KERNEL], $row );
1150                    } else {
1151                            warn "## can't find rss->fetch for ", $request_object->uri;
1152                    }
1153            },
1154     },     },
1155    );    );
1156    
1157  # http server  # http server
1158    
1159    _log "WEB archive at $url";
1160    
1161  my $httpd = POE::Component::Server::HTTP->new(  my $httpd = POE::Component::Server::HTTP->new(
1162          Port => $http_port,          Port => $http_port,
1163          PreHandler => {          PreHandler => {
# Line 1038  foreach my $c (@cols) { Line 1204  foreach my $c (@cols) {
1204          $style .= ".col-${max_color} { background: $c }\n";          $style .= ".col-${max_color} { background: $c }\n";
1205          $max_color++;          $max_color++;
1206  }  }
1207  warn "defined $max_color colors for users...\n";  _log "WEB defined $max_color colors for users...";
1208    
1209  sub root_handler {  sub root_handler {
1210          my ($request, $response) = @_;          my ($request, $response) = @_;
# Line 1060  sub root_handler { Line 1226  sub root_handler {
1226          }          }
1227    
1228          my $search = $q->param('search') || $q->param('grep') || '';          my $search = $q->param('search') || $q->param('grep') || '';
1229            my $r_url = $request->url;
1230    
1231            my @commands = qw( tags last-tag follow stat );
1232            my $commands_re = join('|',@commands);
1233    
1234          if ($request->url =~ m#/rss(?:/(tags|last-tag|follow.*)\w*(?:=(\d+))?)?#i) {          if ($r_url =~ m#/rss(?:/($commands_re.*)\w*(?:=(\d+))?)?#i) {
1235                  my $show = lc($1);                  my $show = lc($1);
1236                  my $nr = $2;                  my $nr = $2;
1237    
# Line 1075  sub root_handler { Line 1245  sub root_handler {
1245                  my $feed = XML::Feed->new( $type );                  my $feed = XML::Feed->new( $type );
1246                  $feed->link( $url );                  $feed->link( $url );
1247    
1248                    my $rc = RC_OK;
1249    
1250                  if ( $show eq 'tags' ) {                  if ( $show eq 'tags' ) {
1251                          $nr ||= 50;                          $nr ||= 50;
1252                          $feed->title( "tags from $CHANNEL" );                          $feed->title( "tags from $CHANNEL" );
# Line 1144  sub root_handler { Line 1316  sub root_handler {
1316                                  $feed->add_entry( $feed_entry );                                  $feed->add_entry( $feed_entry );
1317                          }                          }
1318    
1319                    } elsif ( $show =~ m/^stat/ ) {
1320    
1321                            my $feed_entry = XML::Feed::Entry->new($type);
1322                            $feed_entry->title( "Internal stats" );
1323                            $feed_entry->content(
1324                                    '<![CDATA[<pre>' . dump( $_stat ) . '</pre>]]>'
1325                            );
1326                            $feed->add_entry( $feed_entry );
1327    
1328                  } else {                  } else {
1329                          _log "unknown rss request ",$request->url;                          _log "WEB unknown rss request $r_url";
1330                          return RC_DENY;                          $feed->title( "unknown $r_url" );
1331                            foreach my $c ( @commands ) {
1332                                    my $feed_entry = XML::Feed::Entry->new($type);
1333                                    $feed_entry->title( "rss/$c" );
1334                                    $feed_entry->link( "$url/rss/$c" );
1335                                    $feed->add_entry( $feed_entry );
1336                            }
1337                            $rc = RC_DENY;
1338                  }                  }
1339    
1340                  $response->content( $feed->as_xml );                  $response->content( $feed->as_xml );
1341                  return RC_OK;                  return $rc;
1342          }          }
1343    
1344          if ( $@ ) {          if ( $@ ) {
# Line 1241  sub root_handler { Line 1429  sub root_handler {
1429          <p>See <a href="/history">history</a> of all messages.</p>          <p>See <a href="/history">history</a> of all messages.</p>
1430          </body></html>};          </body></html>};
1431    
1432          $response->content( $html );          $response->content( decode('utf-8',$html) );
1433          warn "<< ", $request->method, " ", $request->uri, " created ", length($html), " bytes\n";          warn "<< ", $request->method, " ", $request->uri, " created ", length($html), " bytes\n";
1434          return RC_OK;          return RC_OK;
1435  }  }
Legend:
Removed from v.89  
changed lines
  Added in v.131
  ViewVC Help
Powered by ViewVC 1.1.26