/[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 15 by dpavlin, Mon Mar 13 12:56:26 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 10  irc-logger.pl Line 27  irc-logger.pl
27    
28  ./irc-logger.pl  ./irc-logger.pl
29    
30    =head2 Options
31    
32    =over 4
33    
34    =item --import-dircproxy=filename
35    
36    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 18  log all conversation on irc channel Line 47  log all conversation on irc channel
47    
48  ## CONFIG  ## CONFIG
49    
50  my $NICK = 'irc-logger';  my $irc_config = {
51  my $CONNECT =          nick => 'irc-logger',
52    {Server => 'irc.freenode.net',          server => 'irc.freenode.net',
53     Nick => $NICK,          port => 6667,
54     Ircname => "try /msg $NICK help",          ircname => 'Anna the bot: try /msg irc-logger help',
55    };  };
56    
57    my $HOSTNAME = `hostname -f`;
58    chomp($HOSTNAME);
59    
60    
61  my $CHANNEL = '#razmjenavjestina';  my $CHANNEL = '#razmjenavjestina';
 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;
83    
84    my $TIMESTAMP = '%Y-%m-%d %H:%M:%S';
85    
86  my $DSN = 'DBI:Pg:dbname=irc-logger';  my $sleep_on_error = 5;
87    
88  my $ENCODING = 'ISO-8859-2';  # 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    my $url = "http://$HOSTNAME:$http_port";
97    
98  ## END CONFIG  ## END CONFIG
99    
100    my $use_twitter = 1;
101    eval { require Net::Twitter; };
102    $use_twitter = 0 if ($@);
103    
104    my $import_dircproxy;
105    my $log_path;
106    GetOptions(
107            'import-dircproxy:s' => \$import_dircproxy,
108            'log:s' => \$log_path,
109    );
110    
111    #$SIG{__DIE__} = sub {
112    #       confess "fatal error";
113    #};
114    
115  use POE qw(Component::IRC Wheel::FollowTail Component::Server::HTTP);  open(STDOUT, '>', $log_path) || warn "can't redirect log to $log_path: $!";
 use HTTP::Status;  
 use DBI;  
 use Encode qw/from_to/;  
 use Regexp::Common qw /URI/;  
116    
117    sub _log {
118            print strftime($TIMESTAMP,localtime()) . ' ' . join(" ",@_) . $/;
119    }
120    
121  my $dbh = DBI->connect($DSN,"","", { RaiseError => 1, AutoCommit => 1 }) || die $DBI::errstr;  # 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  =for SQL schema  my $dbh = DBI->connect($DSN,"","", { RaiseError => 1, AutoCommit => 1 }) || die $DBI::errstr;
164    $dbh->do( qq{ set client_encoding = 'UTF-8' } );
165    
166  $dbh->do(qq{  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(),
171          channel text not null,          channel text not null,
172            me boolean default false,
173          nick text not null,          nick text not null,
174          message text not null,          message text not null,
175          primary key(id)          primary key(id)
# Line 65  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            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    
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  =cut
234    
235  my $sth = $dbh->prepare(qq{  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, nick, message)          (channel, me, nick, message, time)
275  values (?,?,?)  values (?,?,?,?,?)
276  });  });
277    
278    
279    my $tags;
280    
281  =head2 get_from_log  =head2 get_from_log
282    
283   my @messages = get_from_log(   my @messages = get_from_log(
# Line 85  values (?,?,?) Line 287  values (?,?,?)
287                  time => '{%s} ',                  time => '{%s} ',
288                  time_channel => '{%s %s} ',                  time_channel => '{%s %s} ',
289                  nick => '%s: ',                  nick => '%s: ',
290                    me_nick => '***%s ',
291                  message => '%s',                  message => '%s',
292          },          },
293          message_filter => sub {          filter => {
294                  # modify message content                  message => sub {
295                  return shift;                          # modify message content
296          }                          return shift;
297                    }
298            },
299            context => 5,
300            full_rows => 1,
301   );   );
302    
303    Order is important. Fields are first passed through C<filter> (if available) and
304    then throgh C<< sprintf($fmt->{message}, $message >> if available.
305    
306    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->{limit} ||= 10;          if ( ! $args->{fmt} ) {
317                    $args->{fmt} = {
318          $args->{fmt} ||= {                          date => '[%s] ',
319                  time => '{%s} ',                          time => '{%s} ',
320                  time_channel => '{%s %s} ',                          time_channel => '{%s %s} ',
321                  nick => '%s: ',                          nick => '%s: ',
322                  message => '%s',                          me_nick => '***%s ',
323          };                          message => '%s',
324                    };
325            }
326    
327          my $sql = qq{          my $sql_message = qq{
328                  select                  select
329                          time::date as date,                          time::date as date,
330                          time::time as time,                          time::time as time,
331                          channel,                          channel,
332                            me,
333                          nick,                          nick,
334                          message                          message
335                  from log                  from log
336          };          };
337          $sql .= " where message ilike ? " if ($args->{search});  
338            my $sql_context = qq{
339                    select
340                            id
341                    from log
342            };
343    
344            my $context = $1 if ($args->{search} && $args->{search} =~ s/\s*\+(\d+)\s*/ /);
345    
346            my $sql = $context ? $sql_context : $sql_message;
347    
348            sub check_date {
349                    my $date = shift || return;
350                    my $new_date = eval { DateTime::Format::ISO8601->parse_datetime( $date )->ymd; };
351                    if ( $@ ) {
352                            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    
362            if (my $search = $args->{search}) {
363                    $search =~ s/^\s+//;
364                    $search =~ s/\s+$//;
365                    push @where, 'message ilike ? or nick ilike ?';
366                    push @args, ( ( '%' . $search . '%' ) x 2 );
367                    $msg = "Search for '$search'";
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";          $sql .= " order by log.time desc";
385          $sql .= " limit " . $args->{limit};          $sql .= " limit " . $args->{limit} if ($args->{limit});
386    
387            #warn "### sql: $sql ", dump( @args );
388    
389          my $sth = $dbh->prepare( $sql );          my $sth = $dbh->prepare( $sql );
390          if ($args->{search}) {          eval { $sth->execute( @args ) };
391                  $sth->execute( $args->{search} );          return if $@;
392          } else {  
393                  $sth->execute();          my $nr_results = $sth->rows;
394          }  
395          my $last_row = {          my $last_row = {
396                  date => '',                  date => '',
397                  time => '',                  time => '',
# Line 139  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            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) {
424                    my @ids = @rows;
425                    @rows = ();
426    
427                    my $last_to = 0;
428    
429                    my $sth = $dbh->prepare( $sql_message . qq{ where id >= ? and id < ? } );
430                    foreach my $row_id (sort { $a->{id} <=> $b->{id} } @ids) {
431                            my $id = $row_id->{id} || die "can't find id in row";
432            
433                            my ($from, $to) = ($id - $context, $id + $context);
434                            $from = $last_to if ($from < $last_to);
435                            $last_to = $to;
436                            $sth->execute( $from, $to );
437    
438                            #warn "## id: $id from: $from to: $to returned: ", $sth->rows, "\n";
439    
440                            while (my $row = $sth->fetchrow_hashref) {
441                                    push @rows, $row;
442                            }
443    
444                    }
445            }
446    
447            # sprintf which can take coderef as first parametar
448            sub cr_sprintf {
449                    my $fmt = shift || return;
450                    if (ref($fmt) eq 'CODE') {
451                            $fmt->(@_);
452                    } else {
453                            sprintf($fmt, @_);
454                    }
455            }
456    
457          foreach my $row (@rows) {          foreach my $row (@rows) {
458    
459                  $row->{time} =~ s#\.\d+##;                  $row->{time} =~ s#\.\d+##;
460    
                 my $t;  
                 $t = $row->{date} . ' ' if ($last_row->{date} ne $row->{date});  
                 $t .= $row->{time};  
   
461                  my $msg = '';                  my $msg = '';
462    
463                    $msg = cr_sprintf($args->{fmt}->{date}, $row->{date}) . ' ' if ($last_row->{date} ne $row->{date});
464                    my $t = $row->{time};
465    
466                  if ($last_row->{channel} ne $row->{channel}) {                  if ($last_row->{channel} ne $row->{channel}) {
467                          $msg .= sprintf($args->{fmt}->{time_channel}, $t, $row->{channel});                          $msg .= cr_sprintf($args->{fmt}->{time_channel}, $t, $row->{channel});
468                  } else {                  } else {
469                          $msg .= sprintf($args->{fmt}->{time}, $t);                          $msg .= cr_sprintf($args->{fmt}->{time}, $t);
470                  }                  }
471    
472                  my $append = 1;                  my $append = 1;
473    
474                  if ($last_row->{nick} ne $row->{nick}) {                  my $nick = $row->{nick};
475                          $msg .= sprintf($args->{fmt}->{nick}, $row->{nick});  #               if ($nick =~ s/^_*(.*?)_*$/$1/) {
476    #                       $row->{nick} = $nick;
477    #               }
478    
479                    $append = 0 if $row->{me};
480    
481                    if ($last_row->{nick} ne $nick) {
482                            # 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};
484                            $fmt ||= '%s';
485    
486                            $nick = $args->{filter}->{nick}->($nick) if (ref($args->{filter}->{nick}) eq 'CODE');
487    
488                            $msg .= cr_sprintf( $fmt, $nick );
489                          $append = 0;                          $append = 0;
490                  }                  }
491    
492                  if (ref($args->{message_filter}) eq 'CODE') {                  $args->{fmt}->{message} ||= '%s';
493                          $msg .= sprintf($args->{fmt}->{message},                  if (ref($args->{filter}->{message}) eq 'CODE') {
494                                  $args->{message_filter}->(                          $msg .= cr_sprintf($args->{fmt}->{message},
495                                    $args->{filter}->{message}->(
496                                          $row->{message}                                          $row->{message}
497                                  )                                  )
498                          );                          );
499                  } else {                  } else {
500                          $msg .= sprintf($args->{fmt}->{message}, $row->{message});                          $msg .= cr_sprintf($args->{fmt}->{message}, $row->{message});
501                  }                  }
502    
503                  if ($append && @msgs) {                  if ($append && @msgs) {
# Line 186  sub get_from_log { Line 512  sub get_from_log {
512          return @msgs;          return @msgs;
513  }  }
514    
515    # tags support
516    
517    my $cloud = HTML::TagCloud->new;
518    
519    =head2 add_tag
520    
521     add_tag( id => 42, message => 'irc message', nick => 'foobar' [, me => 1 ] );
522    
523    =cut
524    
525    my @last_tags;
526    
527    sub add_tag {
528            my $arg = {@_};
529    
530            return unless ($arg->{id} && $arg->{message});
531    
532            my $m = $arg->{message};
533    
534  my $SKIPPING = 0;               # if skipping, how many we've done          my @tags;
 my $SEND_QUEUE;                 # cache  
535    
536  POE::Component::IRC->new($IRC_ALIAS);          while ($m =~ s#$tag_regex##s) {
537                    my $tag = $1;
538                    next if (! $tag || $tag =~ m/https?:/i);
539                    push @{ $tags->{$tag} }, $arg->{id};
540                    #warn "+tag $tag: $arg->{id}\n";
541                    $cloud->add($tag, "$url?tag=$tag", scalar @{$tags->{$tag}} + 1);
542                    push @tags, $tag;
543    
544  POE::Session->create          }
545    (inline_states =>  
546     {_start => sub {                if ( @tags ) {
547                  $_[KERNEL]->post($IRC_ALIAS => register => 'all');                  pop @last_tags if $#last_tags == $last_x_tags;
548                  $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);                  unshift @last_tags, { tags => [ @tags ], %$arg };
549            }
550    
551    }
552    
553    =head2 seed_tags
554    
555    Read all tags from database and create in-memory cache for tags
556    
557    =cut
558    
559    sub seed_tags {
560            my $sth = $dbh->prepare(qq{ select id,message,nick,me,time from log where message like '%//%' order by time asc });
561            $sth->execute;
562            while (my $row = $sth->fetchrow_hashref) {
563                    add_tag( %$row );
564            }
565    
566            foreach my $tag (keys %$tags) {
567                    $cloud->add($tag, "$url?tag=$tag", scalar @{$tags->{$tag}} + 1);
568            }
569    }
570    
571    seed_tags;
572    
573    
574    =head2 save_message
575    
576      save_message(
577            channel => '#foobar',
578            me => 0,
579            nick => 'dpavlin',
580            message => 'test message',
581            time => '2006-06-25 18:57:18',
582      );
583    
584    C<time> is optional, it will use C<< now() >> if it's not available.
585    
586    C<me> if not specified will be C<0> (not C</me> message)
587    
588    =cut
589    
590    sub save_message {
591            my $a = {@_};
592            confess "have msg" if $a->{msg};
593            $a->{me} ||= 0;
594            $a->{time} ||= strftime($TIMESTAMP,localtime());
595    
596            _log
597                    $a->{channel}, " ",
598                    $a->{me} ? "***" . $a->{nick} : "<" . $a->{nick} . ">",
599                    " " . $a->{message};
600    
601            $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 );
603    }
604    
605    
606    if ($import_dircproxy) {
607            open(my $l, $import_dircproxy) || die "can't open $import_dircproxy: $!";
608            warn "importing $import_dircproxy...\n";
609            my $tz_offset = 1 * 60 * 60;    # TZ GMT+2
610            while(<$l>) {
611                    chomp;
612                    if (/^@(\d+)\s(\S+)\s(.+)$/) {
613                            my ($time, $nick, $msg) = ($1,$2,$3);
614    
615                            my $dt = DateTime->from_epoch( epoch => $time + $tz_offset );
616    
617                            my $me = 0;
618                            $me = 1 if ($nick =~ m/^\[\S+]/);
619                            $nick =~ s/^[\[<]([^!]+).*$/$1/;
620    
621                            $msg =~ s/^ACTION\s+// if ($me);
622    
623                            save_message(
624                                    channel => $CHANNEL,
625                                    me => $me,
626                                    nick => $nick,
627                                    message => $msg,
628                                    time => $dt->ymd . " " . $dt->hms,
629                            ) if ($nick !~ m/^-/);
630    
631                    } else {
632                            _log "can't parse: $_";
633                    }
634            }
635            close($l);
636            warn "import over\n";
637            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
755    #
756    
757    my $poe_irc = POE::Component::IRC->spawn( %$irc_config ) or
758            die "can't start ", dump( $irc_config ), ": $!";
759    
760    my $irc = $poe_irc->session_id();
761    _log "session_id $irc";
762    
763    POE::Session->create( inline_states => {
764            _start => sub {      
765                    $_[KERNEL]->post( $irc => register => 'all' );
766                    $_[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 211  POE::Session->create Line 782  POE::Session->create
782                  my $channel = $_[ARG1]->[0];                  my $channel = $_[ARG1]->[0];
783                  my $msg = $_[ARG2];                  my $msg = $_[ARG2];
784    
785                  from_to($msg, 'UTF-8', $ENCODING);                  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 {
790                    my $kernel = $_[KERNEL];
791                    my $nick = (split /!/, $_[ARG0])[0];
792                    my $channel = $_[ARG1]->[0];
793                    my $msg = $_[ARG2];
794    
795                    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    
                 print "$channel: <$nick> $msg\n";  
                 $sth->execute($channel, $nick, $msg);  
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 233  POE::Session->create Line 837  POE::Session->create
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 242  POE::Session->create Line 846  POE::Session->create
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 = '';
875    
876                  } elsif ($msg =~ m/^(search|grep)\s+(.*)$/i) {                  } elsif ($msg =~ m/^(search|grep)\s+(.*)\s*$/i) {
877    
878                          my $what = $2;                          my $what = $2;
879    
880                          foreach my $res (get_from_log( limit => 20, search => "%${what}%" )) {                          foreach my $res (get_from_log(
881                                  print "search [$what]: $res\n";                                          limit => 20,
882                                  from_to($res, $ENCODING, 'UTF-8');                                          search => $what,
883                                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );                                  )) {
884                                    _log "search [$what]: $res";
885                                    $_[KERNEL]->post( $irc => 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_372 => sub {  #       irc_451 # please register
1045                  print "MOTD: ", $_[ARG1], "\n";          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 {          irc_snotice => sub {
1052                  print "(server notice): ", $_[ARG0], "\n";                  _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          },          },
     (map  
      {  
        ;"irc_$_" => sub { }}  
      qw(  
                 )),  
 #       join  
 #       ctcp_version  
 #       connected snotice ctcp_action ping notice mode part quit  
 #       001 002 003 004 005  
 #       250 251 252 253 254 265 266  
 #       332 333 353 366 372 375 376  
 #       477  
1058      _child => sub {},      _child => sub {},
1059      _default => sub {      _default => sub {
1060        printf "%s: session %s caught an unhandled %s event.\n",                  _log sprintf "sID:%s %s %s",
1061          scalar localtime(), $_[SESSION]->ID, $_[ARG0];                          $_[SESSION]->ID, $_[ARG0],
1062        print "The $_[ARG0] event was given these parameters: ",                          ref($_[ARG1]) eq "ARRAY"        ?       join(",", map { ref($_) eq "ARRAY" ? join(";", @{$_}) : $_ } @{ $_[ARG1] })     :
1063          join(" ", map({"ARRAY" eq ref $_ ? "[@$_]" : "$_"} @{$_[ARG1]})), "\n";                          $_[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    
1083  my $style = <<'_END_OF_STYLE_';  my $style = <<'_END_OF_STYLE_';
1084    p { margin: 0; padding: 0.1em; }
1085  .time, .channel { color: #808080; font-size: 60%; }  .time, .channel { color: #808080; font-size: 60%; }
1086  .nick { color: #0000ff; font-size: 80%; }  .date { float: right; background: #e0e0e0; color: #404040; font-size: 120%; padding: 0.25em; border: 1px dashed #808080; }
1087    .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; }
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 }
1095    .col-1 { background: #a0ffff }
1096    .col-2 { background: #99ff99 }
1097    .col-3 { background: #ff9999 }
1098    .col-4 { background: #ff66ff }
1099    */
1100    .calendar { border: 1px solid red; width: 100%; }
1101    .month { border: 0px; width: 100%; }
1102  _END_OF_STYLE_  _END_OF_STYLE_
1103    
1104    $max_color = 0;
1105    
1106    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          $response->content(          # this doesn't seem to work, so moved to PreHandler
1125                  qq{<html><head><title>$NICK</title><style type="text/css">$style</style></head><body>} .          #$response->header(Connection => 'close');
1126                  "irc-logger url: " . $request->uri . '<br/>' .  
1127                  join("<br/>",          return RC_OK if $request->uri =~ m/favicon.ico$/;
1128    
1129            my $q;
1130    
1131            if ( $request->method eq 'POST' ) {
1132                    $q = new CGI::Simple( $request->content );
1133            } elsif ( $request->uri =~ /\?(.+)$/ ) {
1134                    $q = new CGI::Simple( $1 );
1135            } else {
1136                    $q = new CGI::Simple;
1137            }
1138    
1139            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 =
1262                    qq{<html><head><title>$NICK</title><style type="text/css">$style}
1263                    . $cloud->css
1264                    . qq{</style></head><body>}
1265                    . qq{
1266                    <form method="post" class="search" action="/">
1267                    <input type="text" name="search" value="$search" size="10">
1268                    <input type="submit" value="search">
1269                    </form>
1270                    }
1271                    . $cloud->html(500)
1272                    . qq{<p>};
1273    
1274            if ($request->url =~ m#/tags?#) {
1275                    # nop
1276            } elsif ($request->url =~ m#/history#) {
1277                    my $sth = $dbh->prepare(qq{
1278                            select date(time) as date,count(*) as nr,sum(length(message)) as len
1279                                    from log
1280                                    group by date(time)
1281                                    order by date(time) desc
1282                    });
1283                    $sth->execute();
1284                    my ($l_yyyy,$l_mm) = (0,0);
1285                    $html .= qq{<table class="calendar"><tr>};
1286                    my $cal;
1287                    my $ord = 0;
1288                    while (my $row = $sth->fetchrow_hashref) {
1289                            # this is probably PostgreSQL specific, expects ISO date
1290                            my ($yyyy,$mm,$dd) = split(/-/, $row->{date});
1291                            if ($yyyy != $l_yyyy || $mm != $l_mm) {
1292                                    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);
1298                                    $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);
1307                            }
1308                            $cal->setcontent($dd, qq[
1309                                    <a href="$url?date=$row->{date}">$row->{nr}</a><br/>$row->{len}
1310                            ]) if $cal;
1311                            
1312                    }
1313                    $html .= qq{<td valign="top">} . $cal->as_HTML() . qq{</td></tr></table>};
1314    
1315            } else {
1316                    $html .= join("</p><p>",
1317                          get_from_log(                          get_from_log(
1318                                  limit => 100,                                  limit => ( $q->param('last') || $q->param('date') ) ? undef : 100,
1319                                    search => $search || undef,
1320                                    tag => $q->param('tag') || undef,
1321                                    date => $q->param('date') || undef,
1322                                  fmt => {                                  fmt => {
1323                                            date => sub {
1324                                                    my $date = shift || return;
1325                                                    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> ',
1329                                          nick => '<span class="nick">%s:</span> ',                                          nick => '%s:&nbsp;',
1330                                            me_nick => '***%s&nbsp;',
1331                                          message => '<span class="message">%s</span>',                                          message => '<span class="message">%s</span>',
1332                                  },                                  },
1333                                  message_filter => sub {                                  filter => $filter,
                                         my $m = shift || return;  
                                         $m =~ s#($RE{URI}{HTTP})#<a href="$1">$1</a>#gs;  
                                         return $m;  
                                 },  
1334                          )                          )
1335                  ) .                  );
1336                  qq{</body></html>}          }
1337          );  
1338            $html .= qq{</p>
1339            <hr/>
1340            <p>See <a href="/history">history</a> of all messages.</p>
1341            </body></html>};
1342    
1343            $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.15  
changed lines
  Added in v.109
  ViewVC Help
Powered by ViewVC 1.1.26