/[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 59 by dpavlin, Sat Apr 7 22:57:08 2007 UTC revision 111 by dpavlin, Sun Mar 9 22:12:06 2008 UTC
# Line 2  Line 2 
2  use strict;  use strict;
3  $|++;  $|++;
4    
5    use POE qw(Component::IRC Component::Server::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    
22  =head1 NAME  =head1 NAME
23    
24  irc-logger.pl  irc-logger.pl
# Line 20  Import log from C<dircproxy> to C<irc-lo Line 37  Import log from C<dircproxy> to C<irc-lo
37    
38  =item --log=irc-logger.log  =item --log=irc-logger.log
39    
 Name of log file  
   
40  =back  =back
41    
42  =head1 DESCRIPTION  =head1 DESCRIPTION
# Line 32  log all conversation on irc channel Line 47  log all conversation on irc channel
47    
48  ## CONFIG  ## CONFIG
49    
50  my $HOSTNAME = `hostname`;  my $irc_config = {
51            nick => 'irc-logger',
52            server => 'irc.freenode.net',
53            port => 6667,
54            ircname => 'Anna the bot: try /msg irc-logger help',
55    };
56    
57    my $HOSTNAME = `hostname -f`;
58    chomp($HOSTNAME);
59    
60    
 my $NICK = 'irc-logger';  
 $NICK .= '-dev' if ($HOSTNAME =~ m/llin/);  
 my $CONNECT =  
   {Server => 'irc.freenode.net',  
    Nick => $NICK,  
    Ircname => "try /msg $NICK help",  
   };  
61  my $CHANNEL = '#razmjenavjestina';  my $CHANNEL = '#razmjenavjestina';
 $CHANNEL = '#irc-logger' if ($HOSTNAME =~ m/llin/);  
 my $IRC_ALIAS = "log";  
62    
63  my %FOLLOWS =  if ( $HOSTNAME =~ m/llin/ ) {
64    (          $irc_config->{nick} = 'irc-logger-dev';
65     ACCESS => "/var/log/apache/access.log",  #       $irc_config = {
66     ERROR => "/var/log/apache/error.log",  #               nick => 'irc-logger-dev',
67    );  #               server => 'localhost',
68    #               port => 6668,
69    #       };
70            $CHANNEL = '#irc-logger';
71    } elsif ( $HOSTNAME =~ m/lugarin/ ) {
72            $irc_config->{server} = 'irc.carnet.hr';
73            $CHANNEL = '#riss';
74    }
75    
76    my @channels = ( $CHANNEL );
77    
78    warn "# config = ", dump( $irc_config ), $/;
79    
80    my $NICK = $irc_config->{nick} or die "no nick?";
81    
82  my $DSN = 'DBI:Pg:dbname=' . $NICK;  my $DSN = 'DBI:Pg:dbname=' . $NICK;
83    
 my $ENCODING = 'ISO-8859-2';  
84  my $TIMESTAMP = '%Y-%m-%d %H:%M:%S';  my $TIMESTAMP = '%Y-%m-%d %H:%M:%S';
85    
86  my $sleep_on_error = 5;  my $sleep_on_error = 5;
87    
88  ## END CONFIG  # number of last tags to keep in circular buffer
89    my $last_x_tags = 50;
90    
91    # don't pull rss feeds more often than this
92    my $rss_min_delay = 60;
93    
94    my $http_port = $NICK =~ m/-dev/ ? 8001 : 8000;
95    
96  use POE qw(Component::IRC Wheel::FollowTail Component::Server::HTTP);  my $url = "http://$HOSTNAME:$http_port";
97  use HTTP::Status;  
98  use DBI;  ## END CONFIG
 use Encode qw/from_to is_utf8/;  
 use Regexp::Common qw /URI/;  
 use CGI::Simple;  
 use HTML::TagCloud;  
 use POSIX qw/strftime/;  
 use HTML::CalendarMonthSimple;  
 use Getopt::Long;  
 use DateTime;  
 use Data::Dump qw/dump/;  
99    
100  my $use_twitter = 1;  my $use_twitter = 1;
101  eval { require Net::Twitter; };  eval { require Net::Twitter; };
# Line 86  GetOptions( Line 108  GetOptions(
108          'log:s' => \$log_path,          'log:s' => \$log_path,
109  );  );
110    
111    #$SIG{__DIE__} = sub {
112    #       confess "fatal error";
113    #};
114    
115  open(STDOUT, '>', $log_path) || warn "can't redirect log to $log_path: $!";  open(STDOUT, '>', $log_path) || warn "can't redirect log to $log_path: $!";
116    
117  sub _log {  sub _log {
118          print strftime($TIMESTAMP,localtime()), ' ', join(" ",@_), $/;          print strftime($TIMESTAMP,localtime()) . ' ' . join(" ",@_) . $/;
119  }  }
120    
121    # HTML formatters
122    
123    my %escape = ('<'=>'&lt;', '>'=>'&gt;', '&'=>'&amp;', '"'=>'&quot;');
124    my $escape_re  = join '|' => keys %escape;
125    
126    my $tag_regex = '\b([\w-_]+)//';
127    
128    my %nick_enumerator;
129    my $max_color = 0;
130    
131    my $filter = {
132            message => sub {
133                    my $m = shift || return;
134    
135                    # protect HTML from wiki modifications
136                    sub e {
137                            my $t = shift;
138                            return 'uri_unescape{' . uri_escape($t, '^a-zA-Z0-9') . '}';
139                    }
140    
141                    $m =~ s/($escape_re)/$escape{$1}/gs;
142                    $m =~ s#($RE{URI}{HTTP})#e(qq{<a href="$1">$1</a>})#egs;
143                    $m =~ s#\/(\w+)\/#<i>$1</i>#gs;
144                    $m =~ s#$tag_regex#e(qq{<a href="$url?tag=$1" class="tag">$1</a>})#egs;
145                    $m =~ s#\*(\w+)\*#<b>$1</b>#gs;
146                    $m =~ s#_(\w+)_#<u>$1</u>#gs;
147    
148                    $m =~ s#uri_unescape{([^}]+)}#uri_unescape($1)#egs;
149                    return $m;
150            },
151            nick => sub {
152                    my $n = shift || return;
153                    if (! $nick_enumerator{$n})  {
154                            my $max = scalar keys %nick_enumerator;
155                            $nick_enumerator{$n} = $max + 1;
156                    }
157                    return '<span class="nick col-' .
158                            ( $nick_enumerator{$n} % $max_color ) .
159                            '">' . $n . '</span>';
160            },
161    };
162    
163  my $dbh = DBI->connect($DSN,"","", { RaiseError => 1, AutoCommit => 1 }) || die $DBI::errstr;  my $dbh = DBI->connect($DSN,"","", { RaiseError => 1, AutoCommit => 1 }) || die $DBI::errstr;
164    $dbh->do( qq{ set client_encoding = 'UTF-8' } );
165    
166  my $sql_schema = {  my $sql_schema = {
167          log => '          log => qq{
168  create table log (  create table log (
169          id serial,          id serial,
170          time timestamp default now(),          time timestamp default now(),
# Line 109  create table log ( Line 178  create table log (
178  create index log_time on log(time);  create index log_time on log(time);
179  create index log_channel on log(channel);  create index log_channel on log(channel);
180  create index log_nick on log(nick);  create index log_nick on log(nick);
181          ',          },
182          meta => '          meta => q{
183  create table meta (  create table meta (
184          nick text not null,          nick text not null,
185          channel text not null,          channel text not null,
186          name text not null,          name text not null,
187          value text,          value text,
188          changed timestamp default now(),          changed timestamp default 'now()',
189          primary key(nick,channel,name)          primary key(nick,channel,name)
190  );  );
191          ',          },
192            feeds => qq{
193    create table feeds (
194            id serial,
195            url text not null,
196            name text,
197            delay interval not null default '5 min',
198            active boolean default true,
199            channel text not null,
200            nick text not null,
201            private boolean default false,
202            last_update timestamp default 'now()',
203            polls int default 0,
204            updates int default 0
205    );
206    create unique index feeds_url on feeds(url);
207    insert into feeds (url,name,channel,nick) values ('http://wiki.razmjenavjestina.org/feed/workspace/razmjenavjestina?category=Recent%20Changes','wiki','$CHANNEL','dpavlin');
208            },
209  };  };
210    
211  foreach my $table ( keys %$sql_schema ) {  foreach my $table ( keys %$sql_schema ) {
# Line 162  sub meta { Line 248  sub meta {
248                  if ( $@ || ! $sth->rows ) {                  if ( $@ || ! $sth->rows ) {
249                          $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()) });
250                          $sth->execute( $value, $nick, $channel, $name );                          $sth->execute( $value, $nick, $channel, $name );
251                          _log "created $nick/$channel/$name = $value";                          warn "## created $nick/$channel/$name = $value\n";
252                  } else {                  } else {
253                          _log "updated $nick/$channel/$name = $value ";                          warn "## updated $nick/$channel/$name = $value\n";
254                  }                  }
255    
256                  return $value;                  return $value;
# Line 174  sub meta { Line 260  sub meta {
260                  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 = ? });
261                  $sth->execute( $nick, $channel, $name );                  $sth->execute( $nick, $channel, $name );
262                  my ($v,$c) = $sth->fetchrow_array;                  my ($v,$c) = $sth->fetchrow_array;
263                  _log "fetched $nick/$channel/$name = $v [$c]";                  warn "## fetched $nick/$channel/$name = $v [$c]\n";
264                  return ($v,$c) if wantarray;                  return ($v,$c) if wantarray;
265                  return $v;                  return $v;
266    
# Line 183  sub meta { Line 269  sub meta {
269    
270    
271    
272  my $sth = $dbh->prepare(qq{  my $sth_insert_log = $dbh->prepare(qq{
273  insert into log  insert into log
274          (channel, me, nick, message, time)          (channel, me, nick, message, time)
275  values (?,?,?,?,?)  values (?,?,?,?,?)
# Line 191  values (?,?,?,?,?) Line 277  values (?,?,?,?,?)
277    
278    
279  my $tags;  my $tags;
 my $tag_regex = '\b([\w-_]+)//';  
280    
281  =head2 get_from_log  =head2 get_from_log
282    
# Line 228  C<me>, C<nick> and C<message> keys. Line 313  C<me>, C<nick> and C<message> keys.
313  sub get_from_log {  sub get_from_log {
314          my $args = {@_};          my $args = {@_};
315    
316          $args->{fmt} ||= {          if ( ! $args->{fmt} ) {
317                  date => '[%s] ',                  $args->{fmt} = {
318                  time => '{%s} ',                          date => '[%s] ',
319                  time_channel => '{%s %s} ',                          time => '{%s} ',
320                  nick => '%s: ',                          time_channel => '{%s %s} ',
321                  me_nick => '***%s ',                          nick => '%s: ',
322                  message => '%s',                          me_nick => '***%s ',
323          };                          message => '%s',
324                    };
325            }
326    
327          my $sql_message = qq{          my $sql_message = qq{
328                  select                  select
# Line 258  sub get_from_log { Line 345  sub get_from_log {
345    
346          my $sql = $context ? $sql_context : $sql_message;          my $sql = $context ? $sql_context : $sql_message;
347    
348          $sql .= " where message ilike ? or nick ilike ? " if ($args->{search});          sub check_date {
349          $sql .= " where id in (" . join(",", @{ $tags->{ $args->{tag} } }) . ") " if ($args->{tag} && $tags->{ $args->{tag} });                  my $date = shift || return;
350          $sql .= " where date(time) = ? " if ($args->{date});                  my $new_date = eval { DateTime::Format::ISO8601->parse_datetime( $date )->ymd; };
351          $sql .= " order by log.time desc";                  if ( $@ ) {
352          $sql .= " limit " . $args->{limit} if ($args->{limit});                          warn "invalid date $date\n";
353                            $new_date = DateTime->now->ymd;
354                    }
355                    return $new_date;
356            }
357    
358            my @where;
359            my @args;
360            my $msg;
361    
         my $sth = $dbh->prepare( $sql );  
362          if (my $search = $args->{search}) {          if (my $search = $args->{search}) {
363                  $search =~ s/^\s+//;                  $search =~ s/^\s+//;
364                  $search =~ s/\s+$//;                  $search =~ s/\s+$//;
365                  $sth->execute( ( '%' . $search . '%' ) x 2 );                  push @where, 'message ilike ? or nick ilike ?';
366                  _log "search for '$search' returned ", $sth->rows, " results ", $context || '';                  push @args, ( ( '%' . $search . '%' ) x 2 );
367          } elsif (my $tag = $args->{tag}) {                  $msg = "Search for '$search'";
                 $sth->execute();  
                 _log "tag '$tag' returned ", $sth->rows, " results ", $context || '';  
         } elsif (my $date = $args->{date}) {  
                 $sth->execute($date);  
                 _log "found ", $sth->rows, " messages for date $date ", $context || '';  
         } else {  
                 $sth->execute();  
368          }          }
369    
370            if ($args->{tag} && $tags->{ $args->{tag} }) {
371                    push @where, 'id in (' . join(',', @{ $tags->{ $args->{tag} } }) . ')';
372                    $msg = "Search for tags $args->{tag}";
373            }
374    
375            if (my $date = $args->{date} ) {
376                    $date = check_date( $date );
377                    push @where, 'date(time) = ?';
378                    push @args, $date;
379                    $msg = "search for date $date";
380            }
381    
382            $sql .= " where " . join(" and ", @where) if @where;
383    
384            $sql .= " order by log.time desc";
385            $sql .= " limit " . $args->{limit} if ($args->{limit});
386    
387            #warn "### sql: $sql ", dump( @args );
388    
389            my $sth = $dbh->prepare( $sql );
390            eval { $sth->execute( @args ) };
391            return if $@;
392    
393            my $nr_results = $sth->rows;
394    
395          my $last_row = {          my $last_row = {
396                  date => '',                  date => '',
397                  time => '',                  time => '',
# Line 299  sub get_from_log { Line 412  sub get_from_log {
412    
413          return @rows if ($args->{full_rows});          return @rows if ($args->{full_rows});
414    
415          my @msgs = (          $msg .= ' produced ' . (
416                  "Showing " . ($#rows + 1) . " messages..."                  $nr_results == 0 ? 'no results' :
417                    $nr_results == 0 ? 'one result' :
418                            $nr_results . ' results'
419          );          );
420    
421            my @msgs = ( $msg );
422    
423          if ($context) {          if ($context) {
424                  my @ids = @rows;                  my @ids = @rows;
425                  @rows = ();                  @rows = ();
# Line 359  sub get_from_log { Line 476  sub get_from_log {
476  #                       $row->{nick} = $nick;  #                       $row->{nick} = $nick;
477  #               }  #               }
478    
479                    $append = 0 if $row->{me};
480    
481                  if ($last_row->{nick} ne $nick) {                  if ($last_row->{nick} ne $nick) {
482                          # 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
483                          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 399  my $cloud = HTML::TagCloud->new; Line 518  my $cloud = HTML::TagCloud->new;
518    
519  =head2 add_tag  =head2 add_tag
520    
521   add_tag( id => 42, message => 'irc message' );   add_tag( id => 42, message => 'irc message', nick => 'foobar' [, me => 1 ] );
522    
523  =cut  =cut
524    
525    my @last_tags;
526    
527  sub add_tag {  sub add_tag {
528          my $arg = {@_};          my $arg = {@_};
529    
530          return unless ($arg->{id} && $arg->{message});          return unless ($arg->{id} && $arg->{message});
531    
532          my $m = $arg->{message};          my $m = $arg->{message};
533          from_to('UTF-8', 'iso-8859-2', $m) if (is_utf8($m));  
534            my @tags;
535    
536          while ($m =~ s#$tag_regex##s) {          while ($m =~ s#$tag_regex##s) {
537                  my $tag = $1;                  my $tag = $1;
538                  next if (! $tag || $tag =~ m/https?:/i);                  next if (! $tag || $tag =~ m/https?:/i);
539                  push @{ $tags->{$tag} }, $arg->{id};                  push @{ $tags->{$tag} }, $arg->{id};
540                  #warn "+tag $tag: $arg->{id}\n";                  #warn "+tag $tag: $arg->{id}\n";
541                  $cloud->add($tag, "?tag=$tag", scalar @{$tags->{$tag}} + 1);                  $cloud->add($tag, "$url?tag=$tag", scalar @{$tags->{$tag}} + 1);
542                    push @tags, $tag;
543    
544            }
545    
546            if ( @tags ) {
547                    pop @last_tags if $#last_tags == $last_x_tags;
548                    unshift @last_tags, { tags => [ @tags ], %$arg };
549          }          }
550    
551  }  }
552    
553  =head2 seed_tags  =head2 seed_tags
# Line 427  Read all tags from database and create i Line 557  Read all tags from database and create i
557  =cut  =cut
558    
559  sub seed_tags {  sub seed_tags {
560          my $sth = $dbh->prepare(qq{ select id,message from log where message like '%//%' });          my $sth = $dbh->prepare(qq{ select id,message,nick,me,time from log where message like '%//%' order by time asc });
561          $sth->execute;          $sth->execute;
562          while (my $row = $sth->fetchrow_hashref) {          while (my $row = $sth->fetchrow_hashref) {
563                  add_tag( %$row );                  add_tag( %$row );
564          }          }
565    
566          foreach my $tag (keys %$tags) {          foreach my $tag (keys %$tags) {
567                  $cloud->add($tag, "?tag=$tag", scalar @{$tags->{$tag}} + 1);                  $cloud->add($tag, "$url?tag=$tag", scalar @{$tags->{$tag}} + 1);
568          }          }
569  }  }
570    
# Line 447  seed_tags; Line 577  seed_tags;
577          channel => '#foobar',          channel => '#foobar',
578          me => 0,          me => 0,
579          nick => 'dpavlin',          nick => 'dpavlin',
580          msg => 'test message',          message => 'test message',
581          time => '2006-06-25 18:57:18',          time => '2006-06-25 18:57:18',
582    );    );
583    
# Line 459  C<me> if not specified will be C<0> (not Line 589  C<me> if not specified will be C<0> (not
589    
590  sub save_message {  sub save_message {
591          my $a = {@_};          my $a = {@_};
592            confess "have msg" if $a->{msg};
593          $a->{me} ||= 0;          $a->{me} ||= 0;
594          $a->{time} ||= strftime($TIMESTAMP,localtime());          $a->{time} ||= strftime($TIMESTAMP,localtime());
595    
596          _log          _log
597                  $a->{channel}, " ",                  $a->{channel}, " ",
598                  $a->{me} ? "***" . $a->{nick} : "<" . $a->{nick} . ">",                  $a->{me} ? "***" . $a->{nick} : "<" . $a->{nick} . ">",
599                  " " . $a->{msg};                  " " . $a->{message};
   
         from_to($a->{msg}, 'UTF-8', $ENCODING);  
600    
601          $sth->execute($a->{channel}, $a->{me}, $a->{nick}, $a->{msg}, $a->{time});          $sth_insert_log->execute($a->{channel}, $a->{me}, $a->{nick}, $a->{message}, $a->{time});
602          add_tag( id => $dbh->last_insert_id(undef,undef,"log",undef),          add_tag( id => $dbh->last_insert_id(undef,undef,"log",undef), %$a );
                 message => $a->{msg});  
603  }  }
604    
605    
606  if ($import_dircproxy) {  if ($import_dircproxy) {
607          open(my $l, $import_dircproxy) || die "can't open $import_dircproxy: $!";          open(my $l, $import_dircproxy) || die "can't open $import_dircproxy: $!";
608          warn "importing $import_dircproxy...\n";          warn "importing $import_dircproxy...\n";
609          my $tz_offset = 2 * 60 * 60;    # TZ GMT+2          my $tz_offset = 1 * 60 * 60;    # TZ GMT+2
610          while(<$l>) {          while(<$l>) {
611                  chomp;                  chomp;
612                  if (/^@(\d+)\s(\S+)\s(.+)$/) {                  if (/^@(\d+)\s(\S+)\s(.+)$/) {
# Line 496  if ($import_dircproxy) { Line 624  if ($import_dircproxy) {
624                                  channel => $CHANNEL,                                  channel => $CHANNEL,
625                                  me => $me,                                  me => $me,
626                                  nick => $nick,                                  nick => $nick,
627                                  msg => $msg,                                  message => $msg,
628                                  time => $dt->ymd . " " . $dt->hms,                                  time => $dt->ymd . " " . $dt->hms,
629                          ) if ($nick !~ m/^-/);                          ) if ($nick !~ m/^-/);
630    
# Line 509  if ($import_dircproxy) { Line 637  if ($import_dircproxy) {
637          exit;          exit;
638  }  }
639    
640    #
641    # RSS follow
642    #
643    
644    my $_stat;
645    
646    
647    sub rss_fetch {
648            my ($args) = @_;
649    
650            # how many messages to send out when feed is seen for the first time?
651            my $send_rss_msgs = 1;
652    
653            _log "RSS fetch", $args->{url};
654    
655            my $feed = XML::Feed->parse(URI->new( $args->{url} ));
656            if ( ! $feed ) {
657                    _log("can't fetch RSS ", $args->{url});
658                    return;
659            }
660    
661            my ( $total, $updates ) = ( 0, 0 );
662            for my $entry ($feed->entries) {
663                    $total++;
664    
665                    # seen allready?
666                    next if $_stat->{rss}->{seen}->{$args->{channel}}->{$feed->link}->{$entry->id}++ > 0;
667    
668                    sub prefix {
669                            my ($txt,$var) = @_;
670                            $var =~ s/\s+/ /gs;
671                            $var =~ s/^\s+//g;
672                            $var =~ s/\s+$//g;
673                            return $txt . $var if $var;
674                    }
675    
676                    # fix absolute and relative links to feed entries
677                    my $link = $entry->link;
678                    if ( $link =~ m!^/! ) {
679                            my $host = $args->{url};
680                            $host =~ s!^(http://[^/]+).*$!$1!;      #!vim
681                            $link = "$host/$link";
682                    } elsif ( $link !~ m!^http! ) {
683                            $link = $args->{url} . $link;
684                    }
685    
686                    my $msg;
687                    $msg .= prefix( 'From: ' , $args->{name} || $feed->title );
688                    $msg .= prefix( ' by ' , $entry->author );
689                    $msg .= prefix( ' | ' , $entry->title );
690                    $msg .= prefix( ' | ' , $link );
691    #               $msg .= prefix( ' id ' , $entry->id );
692    
693                    if ( $args->{kernel} && $send_rss_msgs ) {
694                            $send_rss_msgs--;
695                            if ( ! $args->{private} ) {
696                                    # FIXME bug! should be save_message
697    #                               save_message( channel => $args->{channel}, me => 1, nick => $NICK, message => $msg );
698                                    $sth_insert_log->execute( $args->{channel}, 1, $NICK, $msg, 'now()' );
699                            }
700                            my ( $type, $to ) = ( 'notice', $args->{channel} );
701                            ( $type, $to ) = ( 'privmsg', $args->{nick} ) if $args->{private};
702                            _log(">> $type $to |", $msg);
703                            $args->{kernel}->post( irc => $type => $to, $msg );
704                            $updates++;
705                    }
706            }
707    
708            my $sql = qq{ update feeds set last_update = now(), polls = polls + 1 };
709            $sql .= qq{, updates = updates + $updates } if $updates;
710            $sql .= qq{where id = } . $args->{id};
711            eval { $dbh->do( $sql ) };
712    
713            _log "RSS got $total items of which $updates new";
714    
715            return $updates;
716    }
717    
718    sub rss_fetch_all {
719            my $kernel = shift;
720            my $sql = qq{
721                    select id, url, name, channel, nick, private
722                    from feeds
723                    where active is true
724            };
725            # limit to newer feeds only if we are not sending messages out
726            $sql .= qq{     and last_update + delay < now() } if $kernel;
727            my $sth = $dbh->prepare( $sql );
728            $sth->execute();
729            warn "# ",$sth->rows," active RSS feeds\n";
730            my $count = 0;
731            while (my $row = $sth->fetchrow_hashref) {
732                    $row->{kernel} = $kernel if $kernel;
733                    $count += rss_fetch( $row );
734            }
735            return "OK, fetched $count posts from " . $sth->rows . " feeds";
736    }
737    
738    
739    sub rss_check_updates {
740            my $kernel = shift;
741            $_stat->{rss}->{last_poll} ||= time();
742            my $dt = time() - $_stat->{rss}->{last_poll};
743            warn "## rss_check_updates $dt > $rss_min_delay\n";
744            if ( $dt > $rss_min_delay ) {
745                    $_stat->{rss}->{last_poll} = time();
746                    _log rss_fetch_all( $kernel );
747            }
748    }
749    
750    # seed rss seen cache so we won't send out all items on startup
751    _log rss_fetch_all;
752    
753  #  #
754  # POE handing part  # POE handing part
755  #  #
756    
757  my $SKIPPING = 0;               # if skipping, how many we've done  my $poe_irc = POE::Component::IRC->spawn( %$irc_config ) or
758  my $SEND_QUEUE;                 # cache          die "can't start ", dump( $irc_config ), ": $!";
759  my $ping;                                               # ping stats  
760    my $irc = $poe_irc->session_id();
761  POE::Component::IRC->new($IRC_ALIAS);  _log "session_id $irc";
762    
763  POE::Session->create( inline_states =>  POE::Session->create( inline_states => {
764     {_start => sub {                _start => sub {      
765                  $_[KERNEL]->post($IRC_ALIAS => register => 'all');                  $_[KERNEL]->post( $irc => register => 'all' );
766                  $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);                  $_[KERNEL]->post( $irc => connect => {} );
767      },      },
768            irc_001 => sub {
769                    my ($kernel,$sender) = @_[KERNEL,SENDER];
770                    my $poco_object = $sender->get_heap();
771                    _log "connected to",$poco_object->server_name();
772                    $kernel->post( $sender => join => $_ ) for @channels;
773                    undef;
774            },
775      irc_255 => sub {    # server is done blabbing      irc_255 => sub {    # server is done blabbing
776                  $_[KERNEL]->post($IRC_ALIAS => join => $CHANNEL);                  $_[KERNEL]->post( $irc => join => $CHANNEL);
777                  $_[KERNEL]->post($IRC_ALIAS => join => '#logger');                  $_[KERNEL]->post( $irc => privmsg => 'nickserv', "IDENTIFY $NICK" );
                 $_[KERNEL]->yield("heartbeat"); # start heartbeat  
 #               $_[KERNEL]->yield("my_add", $_) for keys %FOLLOWS;  
                 $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );  
778      },      },
779      irc_public => sub {      irc_public => sub {
780                  my $kernel = $_[KERNEL];                  my $kernel = $_[KERNEL];
# Line 538  POE::Session->create( inline_states => Line 782  POE::Session->create( inline_states =>
782                  my $channel = $_[ARG1]->[0];                  my $channel = $_[ARG1]->[0];
783                  my $msg = $_[ARG2];                  my $msg = $_[ARG2];
784    
785                  save_message( channel => $channel, me => 0, nick => $nick, msg => $msg);                  save_message( channel => $channel, me => 0, nick => $nick, message => $msg);
786                  meta( $nick, $channel, 'last-msg', $msg );                  meta( $nick, $channel, 'last-msg', $msg );
787                    rss_check_updates( $kernel );
788      },      },
789      irc_ctcp_action => sub {      irc_ctcp_action => sub {
790                  my $kernel = $_[KERNEL];                  my $kernel = $_[KERNEL];
# Line 547  POE::Session->create( inline_states => Line 792  POE::Session->create( inline_states =>
792                  my $channel = $_[ARG1]->[0];                  my $channel = $_[ARG1]->[0];
793                  my $msg = $_[ARG2];                  my $msg = $_[ARG2];
794    
795                  save_message( channel => $channel, me => 1, nick => $nick, msg => $msg);                  save_message( channel => $channel, me => 1, nick => $nick, message => $msg);
796    
797                  if ( $use_twitter ) {                  if ( $use_twitter ) {
798                          if ( my $twitter = meta( $nick, $NICK, 'twitter' ) ) {                          if ( my $twitter = meta( $nick, $NICK, 'twitter' ) ) {
# Line 560  POE::Session->create( inline_states => Line 805  POE::Session->create( inline_states =>
805    
806      },      },
807          irc_ping => sub {          irc_ping => sub {
808                  warn "pong ", $_[ARG0], $/;                  _log( "pong ", $_[ARG0] );
809                  $ping->{ $_[ARG0] }++;                  $_stat->{ping}->{ $_[ARG0] }++;
810                    rss_check_updates( $_[KERNEL] );
811          },          },
812          irc_invite => sub {          irc_invite => sub {
813                  my $kernel = $_[KERNEL];                  my $kernel = $_[KERNEL];
814                  my $nick = (split /!/, $_[ARG0])[0];                  my $nick = (split /!/, $_[ARG0])[0];
815                  my $channel = $_[ARG1];                  my $channel = $_[ARG1];
816    
817                  warn "invited to $channel by $nick";                  _log "invited to $channel by $nick";
818    
819                  $_[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..." );
820                  $_[KERNEL]->post($IRC_ALIAS => join => $channel);                  $_[KERNEL]->post( $irc => 'join' => $channel );
821    
822          },          },
823          irc_msg => sub {          irc_msg => sub {
# Line 579  POE::Session->create( inline_states => Line 825  POE::Session->create( inline_states =>
825                  my $nick = (split /!/, $_[ARG0])[0];                  my $nick = (split /!/, $_[ARG0])[0];
826                  my $msg = $_[ARG2];                  my $msg = $_[ARG2];
827                  my $channel = $_[ARG1]->[0];                  my $channel = $_[ARG1]->[0];
                 from_to($msg, 'UTF-8', $ENCODING);  
828    
829                  my $res = "unknown command '$msg', try /msg $NICK help!";                  my $res = "unknown command '$msg', try /msg $NICK help!";
830                  my @out;                  my @out;
# Line 590  POE::Session->create( inline_states => Line 835  POE::Session->create( inline_states =>
835    
836                          $res = "usage: /msg $NICK comand | commands: stat - user/message stat | last - show backtrace | grep foobar - find foobar";                          $res = "usage: /msg $NICK comand | commands: stat - user/message stat | last - show backtrace | grep foobar - find foobar";
837    
838                  } elsif ($msg =~ m/^msg\s+(\S+)\s+(.*)$/i) {                  } elsif ($msg =~ m/^(privmsg|notice)\s+(\S+)\s+(.*)$/i) {
839    
840                          _log ">> /msg $1 $2";                          _log ">> /$1 $2 $3";
841                          $_[KERNEL]->post( $IRC_ALIAS => privmsg => $1, $2 );                          $_[KERNEL]->post( $irc => $1 => $2, $3 );
842                          $res = '';                          $res = '';
843    
844                  } elsif ($msg =~ m/^stat.*?\s*(\d*)/i) {                  } elsif ($msg =~ m/^stat.*?\s*(\d*)/i) {
# Line 623  POE::Session->create( inline_states => Line 868  POE::Session->create( inline_states =>
868    
869                          foreach my $res (get_from_log( limit => $limit )) {                          foreach my $res (get_from_log( limit => $limit )) {
870                                  _log "last: $res";                                  _log "last: $res";
871                                  from_to($res, $ENCODING, 'UTF-8');                                  $_[KERNEL]->post( $irc => privmsg => $nick, $res );
                                 $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );  
872                          }                          }
873    
874                          $res = '';                          $res = '';
# Line 638  POE::Session->create( inline_states => Line 882  POE::Session->create( inline_states =>
882                                          search => $what,                                          search => $what,
883                                  )) {                                  )) {
884                                  _log "search [$what]: $res";                                  _log "search [$what]: $res";
885                                  from_to($res, $ENCODING, 'UTF-8');                                  $_[KERNEL]->post( $irc => privmsg => $nick, $res );
                                 $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );  
886                          }                          }
887    
888                          $res = '';                          $res = '';
# Line 674  POE::Session->create( inline_states => Line 917  POE::Session->create( inline_states =>
917                                  " : " . ( $stat->{vote}->{'-'} || 0 ) . " --" .                                  " : " . ( $stat->{vote}->{'-'} || 0 ) . " --" .
918                                  " from " . ( join(", ", @nicks) || 'nobody' );                                  " from " . ( join(", ", @nicks) || 'nobody' );
919    
920                          $_[KERNEL]->post( $IRC_ALIAS => notice => $nick, $res );                          $_[KERNEL]->post( $irc => notice => $nick, $res );
921    
922                  } elsif ($msg =~ m/^ping/) {                  } elsif ($msg =~ m/^ping/) {
923                          $res = "ping = " . dump( $ping );                          $res = "ping = " . dump( $_stat->{ping} );
924                  } elsif ($msg =~ m/^conf(?:ig)*\s*(last-size|twitter)*\s*(.*)/) {                  } elsif ($msg =~ m/^conf(?:ig)*\s*(last-size|twitter)*\s*(.*)/) {
925                          if ( ! defined( $1 ) ) {                          if ( ! defined( $1 ) ) {
926                                  my $sth = $dbh->prepare(qq{ select name,value,changed from meta where nick = ? and channel = ? });                                  my $sth = $dbh->prepare(qq{ select name,value,changed from meta where nick = ? and channel = ? });
# Line 708  POE::Session->create( inline_states => Line 951  POE::Session->create( inline_states =>
951                                          $res = "config option $op doesn't exist";                                          $res = "config option $op doesn't exist";
952                                  }                                  }
953                          }                          }
954                    } elsif ($msg =~ m/^rss-update/) {
955                            $res = rss_fetch_all( $_[KERNEL] );
956                    } elsif ($msg =~ m/^rss-clean/) {
957                            $_stat->{rss} = undef;
958                            $dbh->do( qq{ update feeds set last_update = now() - delay } );
959                            $res = "OK, cleaned RSS cache";
960                    } elsif ($msg =~ m/^rss-list/) {
961                            my $sth = $dbh->prepare(qq{ select url,name,last_update,active,channel,nick,private from feeds });
962                            $sth->execute;
963                            while (my @row = $sth->fetchrow_array) {
964                                    $_[KERNEL]->post( $irc => privmsg => $nick, join(' | ',@row) );
965                            }
966                            $res = '';
967                    } elsif ($msg =~ m!^rss-(add|remove|stop|start)(?:-(private))?\s+(http://\S+)\s*(.*)!) {
968                            my ( $command, $sub, $url, $arg ) = ( $1,$2,$3,$4 );
969    
970                            my $channel = $1 if ( $arg =~ s/\s*(#\S+)\s*// );
971                            $channel = $nick if $sub eq 'private';
972    
973                            my $sql = {
974                                    add     => qq{ insert into feeds (url,name,channel,nick,private) values (?,?,?,?,?) },
975    #                               remove  => qq{ delete from feeds                                where url = ? and name = ? },
976                                    start   => qq{ update feeds set active = true   where url = ? },
977                                    stop    => qq{ update feeds set active = false  where url = ? },
978                            };
979    
980                            if ( $command eq 'add' && ! $channel ) {
981                                    $res = "ERROR: got '$msg' which doesn't have #channel in it, ignoring!";
982                            } elsif (my $q = $sql->{$command} ) {
983                                    my $sth = $dbh->prepare( $q );
984                                    my @data = ( $url );
985                                    if ( $command eq 'add' ) {
986                                            push @data, ( $arg, $channel, $nick, $sub eq 'private' ? 1 : 0 );
987                                    }
988                                    warn "## $command SQL $q with ",dump( @data ),"\n";
989                                    eval { $sth->execute( @data ) };
990                                    if ($@) {
991                                            $res = "ERROR: $@";
992                                    } else {
993                                            $res = "OK, RSS [$command|$sub|$url|$arg]";
994                                    }
995                            } else {
996                                    $res = "ERROR: don't know what to do with: $msg";
997                            }
998                  }                  }
999    
1000                  if ($res) {                  if ($res) {
1001                          _log ">> [$nick] $res";                          _log ">> [$nick] $res";
1002                          from_to($res, $ENCODING, 'UTF-8');                          $_[KERNEL]->post( $irc => privmsg => $nick, $res );
                         $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );  
1003                  }                  }
1004    
1005                    rss_check_updates( $_[KERNEL] );
1006            },
1007            irc_372 => sub {
1008                    _log "<< motd",$_[ARG0],$_[ARG1];
1009            },
1010            irc_375 => sub {
1011                    _log "<< motd", $_[ARG0], "start";
1012            },
1013            irc_376 => sub {
1014                    _log "<< motd", $_[ARG0], "end";
1015          },          },
1016          irc_477 => sub {          irc_477 => sub {
1017                  _log "# irc_477: ",$_[ARG1];                  _log "<< irc_477: ",$_[ARG1];
1018                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "register $NICK" );                  $_[KERNEL]->post( $irc => privmsg => 'nickserv', "register $NICK" );
1019          },          },
1020          irc_505 => sub {          irc_505 => sub {
1021                  _log "# irc_505: ",$_[ARG1];                  _log "<< irc_505: ",$_[ARG1];
1022                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "register $NICK" );                  $_[KERNEL]->post( $irc => privmsg => 'nickserv', "register $NICK" );
1023  #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "set hide email on" );  #               $_[KERNEL]->post( $irc => privmsg => 'nickserv', "set hide email on" );
1024  #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "set email dpavlin\@rot13.org" );  #               $_[KERNEL]->post( $irc => privmsg => 'nickserv', "set email dpavlin\@rot13.org" );
1025          },          },
1026          irc_registered => sub {          irc_registered => sub {
1027                  _log "## registrated $NICK";                  _log "<< registered $NICK";
                 $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );  
1028          },          },
1029          irc_disconnected => sub {          irc_disconnected => sub {
1030                  _log "## disconnected, reconnecting again";                  _log "## disconnected.. sleeping for $sleep_on_error seconds and reconnecting again";
1031                  $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);                  sleep($sleep_on_error);
1032                    $_[KERNEL]->post( $irc => connect => {} );
1033          },          },
1034          irc_socketerr => sub {          irc_socketerr => sub {
1035                  _log "## socket error... sleeping for $sleep_on_error seconds and retry";                  _log "## socket error... sleeping for $sleep_on_error seconds and retry";
1036                  sleep($sleep_on_error);                  sleep($sleep_on_error);
1037                  $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);                  $_[KERNEL]->post( $irc => connect => {} );
1038          },          },
1039  #       irc_433 => sub {  #       irc_433 => sub {
1040  #               print "# irc_433: ",$_[ARG1], "\n";  #               print "# irc_433: ",$_[ARG1], "\n";
1041  #               warn "## indetify $NICK\n";  #               warn "## indetify $NICK\n";
1042  #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );  #               $_[KERNEL]->post( $irc => privmsg => 'nickserv', "IDENTIFY $NICK" );
1043  #       },  #       },
1044    #       irc_451 # please register
1045            irc_notice => sub {
1046                    _log "<< notice",$_[ARG0];
1047                    if ( $_[ARG0] =~ m!/msg\s+NickServ\s+IDENTIFY!i ) {
1048                            $_[KERNEL]->post( $irc => privmsg => 'nickserv', "IDENTIFY $NICK" );
1049                    }
1050            },
1051            irc_snotice => sub {
1052                    _log "<< snotice",$_[ARG0];
1053                    if ( $_[ARG0] =~ m!/(QUOTE)\s+(PASS\s+\d+)!i ) {
1054                            warn ">> $1 | $2\n";
1055                            $_[KERNEL]->post( $irc => lc($1) => $2);
1056                    }
1057            },
1058      _child => sub {},      _child => sub {},
1059      _default => sub {      _default => sub {
1060                  _log sprintf "sID:%s %s %s",                  _log sprintf "sID:%s %s %s",
# Line 754  POE::Session->create( inline_states => Line 1064  POE::Session->create( inline_states =>
1064                          "";                          "";
1065        0;                        # false for signals        0;                        # false for signals
1066      },      },
     my_add => sub {  
       my $trailing = $_[ARG0];  
       my $session = $_[SESSION];  
       POE::Session->create  
           (inline_states =>  
            {_start => sub {  
               $_[HEAP]->{wheel} =  
                 POE::Wheel::FollowTail->new  
                     (  
                      Filename => $FOLLOWS{$trailing},  
                      InputEvent => 'got_line',  
                     );  
             },  
             got_line => sub {  
               $_[KERNEL]->post($session => my_tailed =>  
                                time, $trailing, $_[ARG0]);  
             },  
            },  
           );  
       
     },  
     my_tailed => sub {  
       my ($time, $file, $line) = @_[ARG0..ARG2];  
       ## $time will be undef on a probe, or a time value if a real line  
   
       ## PoCo::IRC has throttling built in, but no external visibility  
       ## so this is reaching "under the hood"  
       $SEND_QUEUE ||=  
         $_[KERNEL]->alias_resolve($IRC_ALIAS)->get_heap->{send_queue};  
   
       ## handle "no need to keep skipping" transition  
       if ($SKIPPING and @$SEND_QUEUE < 1) {  
         $_[KERNEL]->post($IRC_ALIAS => privmsg => $CHANNEL =>  
                          "[discarded $SKIPPING messages]");  
         $SKIPPING = 0;  
       }  
   
       ## handle potential message display  
       if ($time) {  
         if ($SKIPPING or @$SEND_QUEUE > 3) { # 3 msgs per 10 seconds  
           $SKIPPING++;  
         } else {  
           my @time = localtime $time;  
           $_[KERNEL]->post($IRC_ALIAS => privmsg => $CHANNEL =>  
                            sprintf "%02d:%02d:%02d: %s: %s",  
                            ($time[2] + 11) % 12 + 1, $time[1], $time[0],  
                            $file, $line);  
         }  
       }  
   
       ## handle re-probe/flush if skipping  
       if ($SKIPPING) {  
         $_[KERNEL]->delay($_[STATE] => 0.5); # $time will be undef  
       }  
   
     },  
     my_heartbeat => sub {  
       $_[KERNEL]->yield(my_tailed => time, "heartbeat", "beep");  
       $_[KERNEL]->delay($_[STATE] => 10);  
     }  
1067     },     },
1068    );    );
1069    
1070  # http server  # http server
1071    
1072  my $httpd = POE::Component::Server::HTTP->new(  my $httpd = POE::Component::Server::HTTP->new(
1073          Port => $NICK =~ m/-dev/ ? 8001 : 8000,          Port => $http_port,
1074            PreHandler => {
1075                    '/' => sub {
1076                            $_[0]->header(Connection => 'close')
1077                    }
1078            },
1079          ContentHandler => { '/' => \&root_handler },          ContentHandler => { '/' => \&root_handler },
1080          Headers        => { Server => 'irc-logger' },          Headers        => { Server => 'irc-logger' },
1081  );  );
1082    
 my %escape = ('<'=>'&lt;', '>'=>'&gt;', '&'=>'&amp;', '"'=>'&quot;');  
 my $escape_re  = join '|' => keys %escape;  
   
1083  my $style = <<'_END_OF_STYLE_';  my $style = <<'_END_OF_STYLE_';
1084  p { margin: 0; padding: 0.1em; }  p { margin: 0; padding: 0.1em; }
1085  .time, .channel { color: #808080; font-size: 60%; }  .time, .channel { color: #808080; font-size: 60%; }
# Line 835  p { margin: 0; padding: 0.1em; } Line 1087  p { margin: 0; padding: 0.1em; }
1087  .nick { color: #000000; font-size: 80%; padding: 2px; font-family: courier, courier new, monospace ; }  .nick { color: #000000; font-size: 80%; padding: 2px; font-family: courier, courier new, monospace ; }
1088  .message { color: #000000; font-size: 100%; }  .message { color: #000000; font-size: 100%; }
1089  .search { float: right; }  .search { float: right; }
1090    a:link.tag, a:visited.tag { border: 1px dashed #ccc; backgound: #ccc; text-decoration: none }
1091    a:hover.tag { border: 1px solid #eee }
1092    hr { border: 1px dashed #ccc; height: 1px; clear: both; }
1093    /*
1094  .col-0 { background: #ffff66 }  .col-0 { background: #ffff66 }
1095  .col-1 { background: #a0ffff }  .col-1 { background: #a0ffff }
1096  .col-2 { background: #99ff99 }  .col-2 { background: #99ff99 }
1097  .col-3 { background: #ff9999 }  .col-3 { background: #ff9999 }
1098  .col-4 { background: #ff66ff }  .col-4 { background: #ff66ff }
1099  a:link.tag, a:visited.tag { border: 1px dashed #ccc; backgound: #ccc; text-decoration: none }  */
1100  a:hover.tag { border: 1px solid #eee }  .calendar { border: 1px solid red; width: 100%; }
1101  hr { border: 1px dashed #ccc; height: 1px; clear: both; }  .month { border: 0px; width: 100%; }
1102  _END_OF_STYLE_  _END_OF_STYLE_
1103    
1104  my $max_color = 4;  $max_color = 0;
1105    
1106  my %nick_enumerator;  my @cols = qw(
1107            #ffcccc #ccffe6 #ccccff #e6ccff #ffccff #ffcce6 #ff9999 #ffcc99 #ffff99
1108            #ccff99 #99ff99 #99ffcc #99ccff #9999ff #cc99ff #ff6666 #ffb366 #ffff66
1109            #66ff66 #66ffb3 #66b3ff #6666ff #ff3333 #33ff33 #3399ff #3333ff #ff3399
1110            #a0a0a0 #ff0000 #ffff00 #80ff00 #0000ff #8000ff #ff00ff #ff0080 #994d00
1111            #999900 #009900 #cc0066 #c0c0c0 #ccff99 #99ff33 #808080 #660033 #ffffff
1112    );
1113    
1114    foreach my $c (@cols) {
1115            $style .= ".col-${max_color} { background: $c }\n";
1116            $max_color++;
1117    }
1118    warn "defined $max_color colors for users...\n";
1119    
1120  sub root_handler {  sub root_handler {
1121          my ($request, $response) = @_;          my ($request, $response) = @_;
1122          $response->code(RC_OK);          $response->code(RC_OK);
1123          $response->content_type("text/html; charset=$ENCODING");  
1124            # this doesn't seem to work, so moved to PreHandler
1125            #$response->header(Connection => 'close');
1126    
1127            return RC_OK if $request->uri =~ m/favicon.ico$/;
1128    
1129          my $q;          my $q;
1130    
# Line 865  sub root_handler { Line 1137  sub root_handler {
1137          }          }
1138    
1139          my $search = $q->param('search') || $q->param('grep') || '';          my $search = $q->param('search') || $q->param('grep') || '';
1140            my $r_url = $request->url;
1141    
1142            my @commands = qw( tags last-tag follow stat );
1143            my $commands_re = join('|',@commands);
1144    
1145            if ($r_url =~ m#/rss(?:/($commands_re.*)\w*(?:=(\d+))?)?#i) {
1146                    my $show = lc($1);
1147                    my $nr = $2;
1148    
1149                    my $type = 'RSS';       # Atom
1150    
1151                    $response->content_type( 'application/' . lc($type) . '+xml' );
1152    
1153                    my $html = '<!-- error -->';
1154                    #warn "create $type feed from ",dump( @last_tags );
1155    
1156                    my $feed = XML::Feed->new( $type );
1157                    $feed->link( $url );
1158    
1159                    my $rc = RC_OK;
1160    
1161                    if ( $show eq 'tags' ) {
1162                            $nr ||= 50;
1163                            $feed->title( "tags from $CHANNEL" );
1164                            $feed->link( "$url/tags" );
1165                            $feed->description( "tag cloud created from messages on channel $CHANNEL which have tags// in them" );
1166                            my $feed_entry = XML::Feed::Entry->new($type);
1167                            $feed_entry->title( "$nr tags from $CHANNEL" );
1168                            $feed_entry->author( $NICK );
1169                            $feed_entry->link( '/#tags'  );
1170    
1171                            $feed_entry->content(
1172                                    qq{<![CDATA[<style type="text/css">}
1173                                    . $cloud->css
1174                                    . qq{</style>}
1175                                    . $cloud->html( $nr )
1176                                    . qq{]]>}
1177                            );
1178                            $feed->add_entry( $feed_entry );
1179    
1180                    } elsif ( $show eq 'last-tag' ) {
1181    
1182                            $nr ||= $last_x_tags;
1183                            $nr = $last_x_tags if $nr > $last_x_tags;
1184    
1185                            $feed->title( "last $nr tagged messages from $CHANNEL" );
1186                            $feed->description( "collects messages which have tags// in them" );
1187    
1188                            foreach my $m ( @last_tags ) {
1189    #                               warn dump( $m );
1190                                    #my $tags = join(' ', @{$m->{tags}} );
1191                                    my $feed_entry = XML::Feed::Entry->new($type);
1192                                    $feed_entry->title( $m->{nick} . '@' . $m->{time} );
1193                                    $feed_entry->author( $m->{nick} );
1194                                    $feed_entry->link( '/#' . $m->{id}  );
1195                                    $feed_entry->issued( DateTime::Format::Flexible->build( $m->{time} ) );
1196    
1197                                    my $message = $filter->{message}->( $m->{message} );
1198                                    $message .= "<br/>\n" unless $message =~ m!<(/p|br/?)>!;
1199    #                               warn "## message = $message\n";
1200    
1201                                    #$feed_entry->summary(
1202                                    $feed_entry->content(
1203                                            "<![CDATA[$message]]>"
1204                                    );
1205                                    $feed_entry->category( join(', ', @{$m->{tags}}) );
1206                                    $feed->add_entry( $feed_entry );
1207    
1208                                    $nr--;
1209                                    last if $nr <= 0;
1210    
1211                            }
1212    
1213                    } elsif ( $show =~ m/^follow/ ) {
1214    
1215                            $feed->title( "Feeds which this bot follows" );
1216    
1217                            my $sth = $dbh->prepare( qq{ select * from feeds order by last_update desc } );
1218                            $sth->execute;
1219                            while (my $row = $sth->fetchrow_hashref) {
1220                                    my $feed_entry = XML::Feed::Entry->new($type);
1221                                    $feed_entry->title( $row->{name} );
1222                                    $feed_entry->link( $row->{url}  );
1223                                    $feed_entry->issued( DateTime::Format::Flexible->build( $row->{last_update} ) );
1224                                    $feed_entry->content(
1225                                            '<![CDATA[<pre>' . dump( $row ) . '</pre>]]>'
1226                                    );
1227                                    $feed->add_entry( $feed_entry );
1228                            }
1229    
1230                    } elsif ( $show =~ m/^stat/ ) {
1231    
1232                            my $feed_entry = XML::Feed::Entry->new($type);
1233                            $feed_entry->title( "Internal stats" );
1234                            $feed_entry->content(
1235                                    '<![CDATA[<pre>' . dump( $_stat ) . '</pre>]]>'
1236                            );
1237                            $feed->add_entry( $feed_entry );
1238    
1239                    } else {
1240                            _log "unknown rss request $r_url";
1241                            $feed->title( "unknown $r_url" );
1242                            foreach my $c ( @commands ) {
1243                                    my $feed_entry = XML::Feed::Entry->new($type);
1244                                    $feed_entry->title( "rss/$c" );
1245                                    $feed_entry->link( "$url/rss/$c" );
1246                                    $feed->add_entry( $feed_entry );
1247                            }
1248                            $rc = RC_DENY;
1249                    }
1250    
1251                    $response->content( $feed->as_xml );
1252                    return $rc;
1253            }
1254    
1255            if ( $@ ) {
1256                    warn "$@";
1257            }
1258    
1259            $response->content_type("text/html; charset=UTF-8");
1260    
1261          my $html =          my $html =
1262                  qq{<html><head><title>$NICK</title><style type="text/css">$style} .                  qq{<html><head><title>$NICK</title><style type="text/css">$style}
1263                  $cloud->css .                  . $cloud->css
1264                  qq{</style></head><body>} .                  . qq{</style></head><body>}
1265                  qq{                  . qq{
1266                  <form method="post" class="search" action="/">                  <form method="post" class="search" action="/">
1267                  <input type="text" name="search" value="$search" size="10">                  <input type="text" name="search" value="$search" size="10">
1268                  <input type="submit" value="search">                  <input type="submit" value="search">
1269                  </form>                  </form>
1270                  } .                  }
1271                  $cloud->html(500) .                  . $cloud->html(500)
1272                  qq{<p>};                  . qq{<p>};
1273          if ($request->url =~ m#/history#) {  
1274            if ($request->url =~ m#/tags?#) {
1275                    # nop
1276            } elsif ($request->url =~ m#/history#) {
1277                  my $sth = $dbh->prepare(qq{                  my $sth = $dbh->prepare(qq{
1278                          select date(time) as date,count(*) as nr                          select date(time) as date,count(*) as nr,sum(length(message)) as len
1279                                  from log                                  from log
1280                                  group by date(time)                                  group by date(time)
1281                                  order by date(time) desc                                  order by date(time) desc
1282                  });                  });
1283                  $sth->execute();                  $sth->execute();
1284                  my ($l_yyyy,$l_mm) = (0,0);                  my ($l_yyyy,$l_mm) = (0,0);
1285                    $html .= qq{<table class="calendar"><tr>};
1286                  my $cal;                  my $cal;
1287                    my $ord = 0;
1288                  while (my $row = $sth->fetchrow_hashref) {                  while (my $row = $sth->fetchrow_hashref) {
1289                          # this is probably PostgreSQL specific, expects ISO date                          # this is probably PostgreSQL specific, expects ISO date
1290                          my ($yyyy,$mm,$dd) = split(/-/, $row->{date});                          my ($yyyy,$mm,$dd) = split(/-/, $row->{date});
1291                          if ($yyyy != $l_yyyy || $mm != $l_mm) {                          if ($yyyy != $l_yyyy || $mm != $l_mm) {
1292                                  $html .= $cal->as_HTML() if ($cal);                                  if ( $cal ) {
1293                                            $html .= qq{<td valign="top">} . $cal->as_HTML() . qq{</td>};
1294                                            $ord++;
1295                                            $html .= qq{</tr><tr>} if ( $ord % 3 == 0 );
1296                                    }
1297                                  $cal = new HTML::CalendarMonthSimple('month'=>$mm,'year'=>$yyyy);                                  $cal = new HTML::CalendarMonthSimple('month'=>$mm,'year'=>$yyyy);
1298                                  $cal->border(2);                                  $cal->border(1);
1299                                    $cal->width('30%');
1300                                    $cal->cellheight('5em');
1301                                    $cal->tableclass('month');
1302                                    #$cal->cellclass('day');
1303                                    $cal->sunday('SUN');
1304                                    $cal->saturday('SAT');
1305                                    $cal->weekdays('MON','TUE','WED','THU','FRI');
1306                                  ($l_yyyy,$l_mm) = ($yyyy,$mm);                                  ($l_yyyy,$l_mm) = ($yyyy,$mm);
1307                          }                          }
1308                          $cal->setcontent($dd, qq{                          $cal->setcontent($dd, qq[
1309                                  <a href="/?date=$row->{date}">$row->{nr}</a>                                  <a href="$url?date=$row->{date}">$row->{nr}</a><br/>$row->{len}
1310                          });                          ]) if $cal;
1311                            
1312                  }                  }
1313                  $html .= $cal->as_HTML() if ($cal);                  $html .= qq{<td valign="top">} . $cal->as_HTML() . qq{</td></tr></table>};
1314    
1315          } else {          } else {
1316                  $html .= join("</p><p>",                  $html .= join("</p><p>",
1317                          get_from_log(                          get_from_log(
1318                                  limit => $q->param('last') || $q->param('date') ? undef : 100,                                  limit => ( $q->param('last') || $q->param('date') ) ? undef : 100,
1319                                  search => $search || undef,                                  search => $search || undef,
1320                                  tag => $q->param('tag') || undef,                                  tag => $q->param('tag') || undef,
1321                                  date => $q->param('date') || undef,                                  date => $q->param('date') || undef,
1322                                  fmt => {                                  fmt => {
1323                                          date => sub {                                          date => sub {
1324                                                  my $date = shift || return;                                                  my $date = shift || return;
1325                                                  qq{<hr/><div class="date"><a href="/?date=$date">$date</a></div>};                                                  qq{<hr/><div class="date"><a href="$url?date=$date">$date</a></div>};
1326                                          },                                          },
1327                                          time => '<span class="time">%s</span> ',                                          time => '<span class="time">%s</span> ',
1328                                          time_channel => '<span class="channel">%s %s</span> ',                                          time_channel => '<span class="channel">%s %s</span> ',
# Line 921  sub root_handler { Line 1330  sub root_handler {
1330                                          me_nick => '***%s&nbsp;',                                          me_nick => '***%s&nbsp;',
1331                                          message => '<span class="message">%s</span>',                                          message => '<span class="message">%s</span>',
1332                                  },                                  },
1333                                  filter => {                                  filter => $filter,
                                         message => sub {  
                                                 my $m = shift || return;  
                                                 $m =~ s/($escape_re)/$escape{$1}/gs;  
                                                 $m =~ s#($RE{URI}{HTTP})#<a href="$1">$1</a>#gs;  
                                                 $m =~ s#$tag_regex#<a href="?tag=$1" class="tag">$1</a>#g;  
                                                 $m =~ s#\*(\w+)\*#<b>$1</b>#gs;  
                                                 $m =~ s#_(\w+)_#<u>$1</u>#gs;  
                                                 $m =~ s#\/(\w+)\/#<i>$1</i>#gs;  
                                                 return $m;  
                                         },  
                                         nick => sub {  
                                                 my $n = shift || return;  
                                                 if (! $nick_enumerator{$n})  {  
                                                         my $max = scalar keys %nick_enumerator;  
                                                         $nick_enumerator{$n} = $max + 1;  
                                                 }  
                                                 return '<span class="nick col-' .  
                                                         ( $nick_enumerator{$n} % $max_color ) .  
                                                         '">' . $n . '</span>';  
                                         },  
                                 },  
1334                          )                          )
1335                  );                  );
1336          }          }
# Line 953  sub root_handler { Line 1341  sub root_handler {
1341          </body></html>};          </body></html>};
1342    
1343          $response->content( $html );          $response->content( $html );
1344            warn "<< ", $request->method, " ", $request->uri, " created ", length($html), " bytes\n";
1345          return RC_OK;          return RC_OK;
1346  }  }
1347    
Legend:
Removed from v.59  
changed lines
  Added in v.111
  ViewVC Help
Powered by ViewVC 1.1.26