/[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

trunk/irc-logger.pl revision 38 by dpavlin, Sun Jun 25 17:48:33 2006 UTC trunk/bin/irc-logger.pl revision 109 by dpavlin, Sun Mar 9 21:13:15 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 18  irc-logger.pl Line 35  irc-logger.pl
35    
36  Import log from C<dircproxy> to C<irc-logger> database  Import log from C<dircproxy> to C<irc-logger> database
37    
38    =item --log=irc-logger.log
39    
40    =back
41    
42  =head1 DESCRIPTION  =head1 DESCRIPTION
43    
44  log all conversation on irc channel  log all conversation on irc channel
# Line 26  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  ## END CONFIG  my $sleep_on_error = 5;
87    
88    # 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  use POE qw(Component::IRC Wheel::FollowTail Component::Server::HTTP);  my $http_port = $NICK =~ m/-dev/ ? 8001 : 8000;
95  use HTTP::Status;  
96  use DBI;  my $url = "http://$HOSTNAME:$http_port";
97  use Encode qw/from_to is_utf8/;  
98  use Regexp::Common qw /URI/;  ## END CONFIG
99  use CGI::Simple;  
100  use HTML::TagCloud;  my $use_twitter = 1;
101  use POSIX qw/strftime/;  eval { require Net::Twitter; };
102  use HTML::CalendarMonthSimple;  $use_twitter = 0 if ($@);
 use Getopt::Long;  
 use DateTime;  
103    
104  my $import_dircproxy;  my $import_dircproxy;
105    my $log_path;
106  GetOptions(  GetOptions(
107          'import-dircproxy:s' => \$import_dircproxy,          'import-dircproxy:s' => \$import_dircproxy,
108            'log:s' => \$log_path,
109  );  );
110    
111  my $dbh = DBI->connect($DSN,"","", { RaiseError => 1, AutoCommit => 1 }) || die $DBI::errstr;  #$SIG{__DIE__} = sub {
112    #       confess "fatal error";
113    #};
114    
115    open(STDOUT, '>', $log_path) || warn "can't redirect log to $log_path: $!";
116    
117    sub _log {
118            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  eval {                  $m =~ s#uri_unescape{([^}]+)}#uri_unescape($1)#egs;
149          $dbh->do(qq{ select count(*) from log });                  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  if ($@) {  my $dbh = DBI->connect($DSN,"","", { RaiseError => 1, AutoCommit => 1 }) || die $DBI::errstr;
164          warn "creating database table in $DSN\n";  $dbh->do( qq{ set client_encoding = 'UTF-8' } );
         $dbh->do(<<'_SQL_SCHEMA_');  
165    
166    my $sql_schema = {
167            log => qq{
168  create table log (  create table log (
169          id serial,          id serial,
170          time timestamp default now(),          time timestamp default now(),
# Line 94  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 => q{
183    create table meta (
184            nick text not null,
185            channel text not null,
186            name text not null,
187            value text,
188            changed timestamp default 'now()',
189            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 ) {
212    
213  _SQL_SCHEMA_          eval {
214                    $dbh->do(qq{ select count(*) from $table });
215            };
216    
217            if ($@) {
218                    warn "creating database table $table in $DSN\n";
219                    $dbh->do( $sql_schema->{ $table } );
220            }
221  }  }
222    
223  my $sth = $dbh->prepare(qq{  
224    =head2 meta
225    
226    Set or get some meta data into database
227    
228            meta('nick','channel','var_name', $var_value );
229    
230            $var_value = meta('nick','channel','var_name');
231            ( $var_value, $changed ) = meta('nick','channel','var_name');
232    
233    =cut
234    
235    sub meta {
236            my ($nick,$channel,$name,$value) = @_;
237    
238            # normalize channel name
239            $channel =~ s/^#//;
240    
241            if (defined($value)) {
242    
243                    my $sth = $dbh->prepare(qq{ update meta set value = ?, changed = now() where nick = ? and channel = ? and name = ? });
244    
245                    eval { $sth->execute( $value, $nick, $channel, $name ) };
246    
247                    # error or no result
248                    if ( $@ || ! $sth->rows ) {
249                            $sth = $dbh->prepare(qq{ insert into meta (value,nick,channel,name,changed) values (?,?,?,?,now()) });
250                            $sth->execute( $value, $nick, $channel, $name );
251                            warn "## created $nick/$channel/$name = $value\n";
252                    } else {
253                            warn "## updated $nick/$channel/$name = $value\n";
254                    }
255    
256                    return $value;
257    
258            } else {
259    
260                    my $sth = $dbh->prepare(qq{ select value,changed from meta where nick = ? and channel = ? and name = ? });
261                    $sth->execute( $nick, $channel, $name );
262                    my ($v,$c) = $sth->fetchrow_array;
263                    warn "## fetched $nick/$channel/$name = $v [$c]\n";
264                    return ($v,$c) if wantarray;
265                    return $v;
266    
267            }
268    }
269    
270    
271    
272    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 (?,?,?,?,?)
276  });  });
277    
278    
279  my $tags;  my $tags;
 my $tag_regex = '\b([\w-_]+)//';  
280    
281  =head2 get_from_log  =head2 get_from_log
282    
# Line 126  my $tag_regex = '\b([\w-_]+)//'; Line 297  my $tag_regex = '\b([\w-_]+)//';
297                  }                  }
298          },          },
299          context => 5,          context => 5,
300            full_rows => 1,
301   );   );
302    
303  Order is important. Fields are first passed through C<filter> (if available) and  Order is important. Fields are first passed through C<filter> (if available) and
# Line 133  then throgh C<< sprintf($fmt->{message}, Line 305  then throgh C<< sprintf($fmt->{message},
305    
306  C<context> defines number of messages around each search hit for display.  C<context> defines number of messages around each search hit for display.
307    
308    C<full_rows> will return database rows for each result with C<date>, C<time>, C<channel>,
309    C<me>, C<nick> and C<message> keys.
310    
311  =cut  =cut
312    
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 168  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                  warn "search for '$search' returned ", $sth->rows, " results ", $context || '', "\n";                  push @args, ( ( '%' . $search . '%' ) x 2 );
367          } elsif (my $tag = $args->{tag}) {                  $msg = "Search for '$search'";
368                  $sth->execute();          }
369                  warn "tag '$tag' returned ", $sth->rows, " results ", $context || '', "\n";  
370          } elsif (my $date = $args->{date}) {          if ($args->{tag} && $tags->{ $args->{tag} }) {
371                  $sth->execute($date);                  push @where, 'id in (' . join(',', @{ $tags->{ $args->{tag} } }) . ')';
372                  warn "found ", $sth->rows, " messages for date $date ", $context || '', "\n";                  $msg = "Search for tags $args->{tag}";
373          } else {          }
374                  $sth->execute();  
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 202  sub get_from_log { Line 405  sub get_from_log {
405                  unshift @rows, $row;                  unshift @rows, $row;
406          }          }
407    
408          my @msgs = (          # normalize nick names
409                  "Showing " . ($#rows + 1) . " messages..."          map {
410                    $_->{nick} =~ s/^_*(.*?)_*$/$1/
411            } @rows;
412    
413            return @rows if ($args->{full_rows});
414    
415            $msg .= ' produced ' . (
416                    $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 258  sub get_from_log { Line 472  sub get_from_log {
472                  my $append = 1;                  my $append = 1;
473    
474                  my $nick = $row->{nick};                  my $nick = $row->{nick};
475                  if ($nick =~ s/^_*(.*?)_*$/$1/) {  #               if ($nick =~ s/^_*(.*?)_*$/$1/) {
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
# Line 302  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 330  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 350  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 362  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          print          _log
                 $a->{time}, " ",  
597                  $a->{channel}, " ",                  $a->{channel}, " ",
598                  $a->{me} ? "***" . $a->{nick} : "<" . $a->{nick} . ">",                  $a->{me} ? "***" . $a->{nick} : "<" . $a->{nick} . ">",
599                  " " . $a->{msg} . "\n";                  " " . $a->{message};
600    
601          from_to($a->{msg}, 'UTF-8', $ENCODING);          $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), %$a );
         $sth->execute($a->{channel}, $a->{me}, $a->{nick}, $a->{msg}, $a->{time});  
         add_tag( id => $dbh->last_insert_id(undef,undef,"log",undef),  
                 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 399  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    
631                  } else {                  } else {
632                          warn "can't parse: $_\n";                          _log "can't parse: $_";
633                  }                  }
634          }          }
635          close($l);          close($l);
# Line 412  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    
760  POE::Component::IRC->new($IRC_ALIAS);  my $irc = $poe_irc->session_id();
761    _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 440  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 );
787                    rss_check_updates( $kernel );
788      },      },
789      irc_ctcp_action => sub {      irc_ctcp_action => sub {
790                  my $kernel = $_[KERNEL];                  my $kernel = $_[KERNEL];
# Line 448  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 ) {
798                            if ( my $twitter = meta( $nick, $NICK, 'twitter' ) ) {
799                                    my ($login,$passwd) = split(/\s+/,$twitter,2);
800                                    _log("sending twitter for $nick/$login on $channel ");
801                                    my $bot = Net::Twitter->new( username=>$login, password=>$passwd );
802                                    $bot->update("<${channel}> $msg");
803                            }
804                    }
805    
806      },      },
807            irc_ping => sub {
808                    _log( "pong ", $_[ARG0] );
809                    $_stat->{ping}->{ $_[ARG0] }++;
810                    rss_check_updates( $_[KERNEL] );
811            },
812            irc_invite => sub {
813                    my $kernel = $_[KERNEL];
814                    my $nick = (split /!/, $_[ARG0])[0];
815                    my $channel = $_[ARG1];
816    
817                    _log "invited to $channel by $nick";
818    
819                    $_[KERNEL]->post( $irc => privmsg => $nick, "how nice of you to invite me to $channel, I'll be right there..." );
820                    $_[KERNEL]->post( $irc => 'join' => $channel );
821    
822            },
823          irc_msg => sub {          irc_msg => sub {
824                  my $kernel = $_[KERNEL];                  my $kernel = $_[KERNEL];
825                  my $nick = (split /!/, $_[ARG0])[0];                  my $nick = (split /!/, $_[ARG0])[0];
826                  my $msg = $_[ARG2];                  my $msg = $_[ARG2];
827                  from_to($msg, 'UTF-8', $ENCODING);                  my $channel = $_[ARG1]->[0];
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;
831    
832                  print "<< $msg\n";                  _log "<< $msg";
833    
834                  if ($msg =~ m/^help/i) {                  if ($msg =~ m/^help/i) {
835    
# Line 467  POE::Session->create( inline_states => Line 837  POE::Session->create( inline_states =>
837    
838                  } elsif ($msg =~ m/^msg\s+(\S+)\s+(.*)$/i) {                  } elsif ($msg =~ m/^msg\s+(\S+)\s+(.*)$/i) {
839    
840                          print ">> /msg $1 $2\n";                          _log ">> /msg $1 $2";
841                          $_[KERNEL]->post( $IRC_ALIAS => privmsg => $1, $2 );                          $_[KERNEL]->post( $irc => privmsg => $1, $2 );
842                          $res = '';                          $res = '';
843    
844                  } elsif ($msg =~ m/^stat.*?\s*(\d*)/i) {                  } elsif ($msg =~ m/^stat.*?\s*(\d*)/i) {
# Line 476  POE::Session->create( inline_states => Line 846  POE::Session->create( inline_states =>
846                          my $nr = $1 || 10;                          my $nr = $1 || 10;
847    
848                          my $sth = $dbh->prepare(qq{                          my $sth = $dbh->prepare(qq{
849                                  select nick,count(*) from log group by nick order by count desc limit $nr                                  select
850                                            trim(both '_' from nick) as nick,
851                                            count(*) as count,
852                                            sum(length(message)) as len
853                                    from log
854                                    group by trim(both '_' from nick)
855                                    order by len desc,count desc
856                                    limit $nr
857                          });                          });
858                          $sth->execute();                          $sth->execute();
859                          $res = "Top $nr users: ";                          $res = "Top $nr users: ";
860                          my @users;                          my @users;
861                          while (my $row = $sth->fetchrow_hashref) {                          while (my $row = $sth->fetchrow_hashref) {
862                                  push @users,$row->{nick} . ': ' . $row->{count};                                  push @users,$row->{nick} . ': ' . $row->{count} . '/' . $row->{len} . '=' . sprintf("%.2f", $row->{len}/$row->{count});
863                          }                          }
864                          $res .= join(" | ", @users);                          $res .= join(" | ", @users);
865                  } elsif ($msg =~ m/^last.*?\s*(\d*)/i) {                  } elsif ($msg =~ m/^last.*?\s*(\d*)/i) {
866    
867                          foreach my $res (get_from_log( limit => $1 )) {                          my $limit = $1 || meta( $nick, $channel, 'last-size' ) || 10;
868                                  print "last: $res\n";  
869                                  from_to($res, $ENCODING, 'UTF-8');                          foreach my $res (get_from_log( limit => $limit )) {
870                                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );                                  _log "last: $res";
871                                    $_[KERNEL]->post( $irc => privmsg => $nick, $res );
872                          }                          }
873    
874                          $res = '';                          $res = '';
# Line 503  POE::Session->create( inline_states => Line 881  POE::Session->create( inline_states =>
881                                          limit => 20,                                          limit => 20,
882                                          search => $what,                                          search => $what,
883                                  )) {                                  )) {
884                                  print "search [$what]: $res\n";                                  _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 = '';
889    
890                    } elsif ($msg =~ m/^(?:count|poll)\s+(.*)(?:\s+(\d+))?\s*$/i) {
891    
892                            my ($what,$limit) = ($1,$2);
893                            $limit ||= 100;
894    
895                            my $stat;
896    
897                            foreach my $res (get_from_log(
898                                            limit => $limit,
899                                            search => $what,
900                                            full_rows => 1,
901                                    )) {
902                                    while ($res->{message} =~ s/\Q$what\E(\+|\-)//) {
903                                            $stat->{vote}->{$1}++;
904                                            $stat->{from}->{ $res->{nick} }++;
905                                    }
906                            }
907    
908                            my @nicks;
909                            foreach my $nick (sort { $stat->{from}->{$a} <=> $stat->{from}->{$b} } keys %{ $stat->{from} }) {
910                                    push @nicks, $nick . ( $stat->{from}->{$nick} == 1 ? '' :
911                                            "(" . $stat->{from}->{$nick} . ")"
912                                    );
913                            }
914    
915                            $res =
916                                    "$what ++ " . ( $stat->{vote}->{'+'} || 0 ) .
917                                    " : " . ( $stat->{vote}->{'-'} || 0 ) . " --" .
918                                    " from " . ( join(", ", @nicks) || 'nobody' );
919    
920                            $_[KERNEL]->post( $irc => notice => $nick, $res );
921    
922                    } elsif ($msg =~ m/^ping/) {
923                            $res = "ping = " . dump( $_stat->{ping} );
924                    } elsif ($msg =~ m/^conf(?:ig)*\s*(last-size|twitter)*\s*(.*)/) {
925                            if ( ! defined( $1 ) ) {
926                                    my $sth = $dbh->prepare(qq{ select name,value,changed from meta where nick = ? and channel = ? });
927                                    $sth->execute( $nick, $channel );
928                                    $res = "config for $nick on $channel";
929                                    while ( my ($n,$v) = $sth->fetchrow_array ) {
930                                            $res .= " | $n = $v";
931                                    }
932                            } elsif ( ! $2 ) {
933                                    my $val = meta( $nick, $channel, $1 );
934                                    $res = "current $1 = " . ( $val ? $val : 'undefined' );
935                            } else {
936                                    my $validate = {
937                                            'last-size' => qr/^\d+/,
938                                            'twitter' => qr/^\w+\s+\w+/,
939                                    };
940    
941                                    my ( $op, $val ) = ( $1, $2 );
942    
943                                    if ( my $regex = $validate->{$op} ) {
944                                            if ( $val =~ $regex ) {
945                                                    meta( $nick, $channel, $op, $val );
946                                                    $res = "saved $op = $val";
947                                            } else {
948                                                    $res = "config option $op = $val doesn't validate against $regex";
949                                            }
950                                    } else {
951                                            $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                          print ">> [$nick] $res\n";                          _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                  print "# irc_477: ",$_[ARG1], "\n";                  _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                  print "# irc_505: ",$_[ARG1], "\n";                  _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                  warn "## indetify $NICK\n";                  _log "<< registered $NICK";
1028                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );          },
1029            irc_disconnected => sub {
1030                    _log "## disconnected.. sleeping for $sleep_on_error seconds and reconnecting again";
1031                    sleep($sleep_on_error);
1032                    $_[KERNEL]->post( $irc => connect => {} );
1033            },
1034            irc_socketerr => sub {
1035                    _log "## socket error... sleeping for $sleep_on_error seconds and retry";
1036                    sleep($sleep_on_error);
1037                    $_[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                  printf "%s #%s %s %s\n",                  _log sprintf "sID:%s %s %s",
1061                          strftime($TIMESTAMP,localtime()), $_[SESSION]->ID, $_[ARG0],                          $_[SESSION]->ID, $_[ARG0],
1062                          ref($_[ARG1]) eq "ARRAY"        ?       join(",", map { ref($_) eq "ARRAY" ? join(";", @{$_}) : $_ } @{ $_[ARG1] })     :                          ref($_[ARG1]) eq "ARRAY"        ?       join(",", map { ref($_) eq "ARRAY" ? join(";", @{$_}) : $_ } @{ $_[ARG1] })     :
1063                          $_[ARG1]                                        ?       $_[ARG1]                                        :                          $_[ARG1]                                        ?       $_[ARG1]                                        :
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 628  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 658  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 714  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;  
                                                 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 743  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.38  
changed lines
  Added in v.109
  ViewVC Help
Powered by ViewVC 1.1.26