/[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 87 by dpavlin, Fri Mar 7 00:18:02 2008 UTC
# Line 10  irc-logger.pl Line 10  irc-logger.pl
10    
11  ./irc-logger.pl  ./irc-logger.pl
12    
13    =head2 Options
14    
15    =over 4
16    
17    =item --import-dircproxy=filename
18    
19    Import log from C<dircproxy> to C<irc-logger> database
20    
21    =item --log=irc-logger.log
22    
23    Name of log file
24    
25    =item --follow=file.log
26    
27    Follows new messages in file
28    
29    =back
30    
31  =head1 DESCRIPTION  =head1 DESCRIPTION
32    
33  log all conversation on irc channel  log all conversation on irc channel
# Line 18  log all conversation on irc channel Line 36  log all conversation on irc channel
36    
37  ## CONFIG  ## CONFIG
38    
39    my $HOSTNAME = `hostname -f`;
40    chomp($HOSTNAME);
41    
42  my $NICK = 'irc-logger';  my $NICK = 'irc-logger';
43    $NICK .= '-dev' if ($HOSTNAME =~ m/llin/);
44  my $CONNECT =  my $CONNECT =
45    {Server => 'irc.freenode.net',    {Server => 'irc.freenode.net',
46     Nick => $NICK,     Nick => $NICK,
47     Ircname => "try /msg $NICK help",     Ircname => "try /msg $NICK help",
48    };    };
49  my $CHANNEL = '#razmjenavjestina';  my $CHANNEL = '#razmjenavjestina';
50    $CHANNEL = '#irc-logger' if ($HOSTNAME =~ m/llin/);
51  my $IRC_ALIAS = "log";  my $IRC_ALIAS = "log";
52    
53  my %FOLLOWS =  # default log to follow and announce messages
54    (  my $follows_path = 'follows.log';
    ACCESS => "/var/log/apache/access.log",  
    ERROR => "/var/log/apache/error.log",  
   );  
55    
56  my $DSN = 'DBI:Pg:dbname=irc-logger';  my $DSN = 'DBI:Pg:dbname=' . $NICK;
57    
58    # log output encoding
59  my $ENCODING = 'ISO-8859-2';  my $ENCODING = 'ISO-8859-2';
60    my $TIMESTAMP = '%Y-%m-%d %H:%M:%S';
61    
62  ## END CONFIG  my $sleep_on_error = 5;
63    
64    # number of last tags to keep in circular buffer
65    my $last_x_tags = 50;
66    
67    # don't pull rss feeds more often than this
68    my $rss_min_delay = 60;
69    $rss_min_delay = 15;
70    
71    my $http_port = $NICK =~ m/-dev/ ? 8001 : 8000;
72    
73    my $url = "http://$HOSTNAME:$http_port";
74    
75    ## END CONFIG
76    
77  use POE qw(Component::IRC Wheel::FollowTail Component::Server::HTTP);  use POE qw(Component::IRC Wheel::FollowTail Component::Server::HTTP);
78  use HTTP::Status;  use HTTP::Status;
79  use DBI;  use DBI;
80  use Encode qw/from_to/;  use Encode qw/from_to is_utf8/;
81  use Regexp::Common qw /URI/;  use Regexp::Common qw /URI/;
82    use CGI::Simple;
83    use HTML::TagCloud;
84    use POSIX qw/strftime/;
85    use HTML::CalendarMonthSimple;
86    use Getopt::Long;
87    use DateTime;
88    use URI::Escape;
89    use Data::Dump qw/dump/;
90    use DateTime::Format::ISO8601;
91    use Carp qw/confess/;
92    use XML::Feed;
93    use DateTime::Format::Flexible;
94    
95    my $use_twitter = 1;
96    eval { require Net::Twitter; };
97    $use_twitter = 0 if ($@);
98    
99    my $import_dircproxy;
100    my $log_path;
101    GetOptions(
102            'import-dircproxy:s' => \$import_dircproxy,
103            'follows:s' => \$follows_path,
104            'log:s' => \$log_path,
105    );
106    
107    #$SIG{__DIE__} = sub {
108    #       confess "fatal error";
109    #};
110    
111    open(STDOUT, '>', $log_path) || warn "can't redirect log to $log_path: $!";
112    
113    sub _log {
114            my $out = strftime($TIMESTAMP,localtime()) . ' ' . join(" ",@_) . $/;
115            from_to( $out, 'UTF-8', $ENCODING );
116            print $out;
117    }
118    
119  my $dbh = DBI->connect($DSN,"","", { RaiseError => 1, AutoCommit => 1 }) || die $DBI::errstr;  # LOG following
120    
121    my %FOLLOWS =
122      (
123    #   ACCESS => "/var/log/apache/access.log",
124    #   ERROR => "/var/log/apache/error.log",
125      );
126    
127    sub add_follow_path {
128            my $path = shift;
129            my $name = $path;
130            $name =~ s/\..*$//;
131            warn "# using $path to announce messages from $name\n";
132            $FOLLOWS{$name} = $path;
133    }
134    
135    add_follow_path( $follows_path ) if ( -e $follows_path );
136    
137    # HTML formatters
138    
139    my %escape = ('<'=>'&lt;', '>'=>'&gt;', '&'=>'&amp;', '"'=>'&quot;');
140    my $escape_re  = join '|' => keys %escape;
141    
142    my $tag_regex = '\b([\w-_]+)//';
143    
144    my %nick_enumerator;
145    my $max_color = 0;
146    
147    my $filter = {
148            message => sub {
149                    my $m = shift || return;
150    
151                    # protect HTML from wiki modifications
152                    sub e {
153                            my $t = shift;
154                            return 'uri_unescape{' . uri_escape($t) . '}';
155                    }
156    
157                    $m =~ s/($escape_re)/$escape{$1}/gs;
158                    $m =~ s#($RE{URI}{HTTP})#e(qq{<a href="$1">$1</a>})#egs ||
159                    $m =~ s#\/(\w+)\/#<i>$1</i>#gs;
160                    $m =~ s#$tag_regex#e(qq{<a href="$url?tag=$1" class="tag">$1</a>})#egs;
161                    $m =~ s#\*(\w+)\*#<b>$1</b>#gs;
162                    $m =~ s#_(\w+)_#<u>$1</u>#gs;
163    
164                    $m =~ s#uri_unescape{([^}]+)}#uri_unescape($1)#egs;
165                    return $m;
166            },
167            nick => sub {
168                    my $n = shift || return;
169                    if (! $nick_enumerator{$n})  {
170                            my $max = scalar keys %nick_enumerator;
171                            $nick_enumerator{$n} = $max + 1;
172                    }
173                    return '<span class="nick col-' .
174                            ( $nick_enumerator{$n} % $max_color ) .
175                            '">' . $n . '</span>';
176            },
177    };
178    
179  =for SQL schema  my $dbh = DBI->connect($DSN,"","", { RaiseError => 1, AutoCommit => 1 }) || die $DBI::errstr;
180    
181  $dbh->do(qq{  my $sql_schema = {
182            log => qq{
183  create table log (  create table log (
184          id serial,          id serial,
185          time timestamp default now(),          time timestamp default now(),
186          channel text not null,          channel text not null,
187            me boolean default false,
188          nick text not null,          nick text not null,
189          message text not null,          message text not null,
190          primary key(id)          primary key(id)
# Line 65  create table log ( Line 193  create table log (
193  create index log_time on log(time);  create index log_time on log(time);
194  create index log_channel on log(channel);  create index log_channel on log(channel);
195  create index log_nick on log(nick);  create index log_nick on log(nick);
196            },
197            meta => q{
198    create table meta (
199            nick text not null,
200            channel text not null,
201            name text not null,
202            value text,
203            changed timestamp default 'now()',
204            primary key(nick,channel,name)
205    );
206            },
207            feeds => qq{
208    create table feeds (
209            id serial,
210            url text not null,
211            name text,
212            delay interval not null default '5 min',
213            active boolean default true,
214            last_update timestamp default 'now()',
215            polls int default 0,
216            updates int default 0
217    );
218    create unique index feeds_url on feeds(url);
219    insert into feeds (url,name) values ('http://wiki.razmjenavjestina.org/feed/workspace/razmjenavjestina?category=Recent%20Changes','wiki');
220            },
221    };
222    
223    foreach my $table ( keys %$sql_schema ) {
224    
225            eval {
226                    $dbh->do(qq{ select count(*) from $table });
227            };
228    
229            if ($@) {
230                    warn "creating database table $table in $DSN\n";
231                    $dbh->do( $sql_schema->{ $table } );
232            }
233    }
234    
235  });  
236    =head2 meta
237    
238    Set or get some meta data into database
239    
240            meta('nick','channel','var_name', $var_value );
241    
242            $var_value = meta('nick','channel','var_name');
243            ( $var_value, $changed ) = meta('nick','channel','var_name');
244    
245  =cut  =cut
246    
247  my $sth = $dbh->prepare(qq{  sub meta {
248            my ($nick,$channel,$name,$value) = @_;
249    
250            # normalize channel name
251            $channel =~ s/^#//;
252    
253            if (defined($value)) {
254    
255                    my $sth = $dbh->prepare(qq{ update meta set value = ?, changed = now() where nick = ? and channel = ? and name = ? });
256    
257                    eval { $sth->execute( $value, $nick, $channel, $name ) };
258    
259                    # error or no result
260                    if ( $@ || ! $sth->rows ) {
261                            $sth = $dbh->prepare(qq{ insert into meta (value,nick,channel,name,changed) values (?,?,?,?,now()) });
262                            $sth->execute( $value, $nick, $channel, $name );
263                            _log "created $nick/$channel/$name = $value";
264                    } else {
265                            _log "updated $nick/$channel/$name = $value ";
266                    }
267    
268                    return $value;
269    
270            } else {
271    
272                    my $sth = $dbh->prepare(qq{ select value,changed from meta where nick = ? and channel = ? and name = ? });
273                    $sth->execute( $nick, $channel, $name );
274                    my ($v,$c) = $sth->fetchrow_array;
275                    _log "fetched $nick/$channel/$name = $v [$c]";
276                    return ($v,$c) if wantarray;
277                    return $v;
278    
279            }
280    }
281    
282    
283    
284    my $sth_insert_log = $dbh->prepare(qq{
285  insert into log  insert into log
286          (channel, nick, message)          (channel, me, nick, message, time)
287  values (?,?,?)  values (?,?,?,?,?)
288  });  });
289    
290    
291    my $tags;
292    
293  =head2 get_from_log  =head2 get_from_log
294    
295   my @messages = get_from_log(   my @messages = get_from_log(
# Line 85  values (?,?,?) Line 299  values (?,?,?)
299                  time => '{%s} ',                  time => '{%s} ',
300                  time_channel => '{%s %s} ',                  time_channel => '{%s %s} ',
301                  nick => '%s: ',                  nick => '%s: ',
302                    me_nick => '***%s ',
303                  message => '%s',                  message => '%s',
304          },          },
305          message_filter => sub {          filter => {
306                  # modify message content                  message => sub {
307                  return shift;                          # modify message content
308          }                          return shift;
309                    }
310            },
311            context => 5,
312            full_rows => 1,
313   );   );
314    
315    Order is important. Fields are first passed through C<filter> (if available) and
316    then throgh C<< sprintf($fmt->{message}, $message >> if available.
317    
318    C<context> defines number of messages around each search hit for display.
319    
320    C<full_rows> will return database rows for each result with C<date>, C<time>, C<channel>,
321    C<me>, C<nick> and C<message> keys.
322    
323  =cut  =cut
324    
325  sub get_from_log {  sub get_from_log {
326          my $args = {@_};          my $args = {@_};
327    
328          $args->{limit} ||= 10;          if ( ! $args->{fmt} ) {
329                    $args->{fmt} = {
330          $args->{fmt} ||= {                          date => '[%s] ',
331                  time => '{%s} ',                          time => '{%s} ',
332                  time_channel => '{%s %s} ',                          time_channel => '{%s %s} ',
333                  nick => '%s: ',                          nick => '%s: ',
334                  message => '%s',                          me_nick => '***%s ',
335          };                          message => '%s',
336                    };
337            }
338    
339          my $sql = qq{          my $sql_message = qq{
340                  select                  select
341                          time::date as date,                          time::date as date,
342                          time::time as time,                          time::time as time,
343                          channel,                          channel,
344                            me,
345                          nick,                          nick,
346                          message                          message
347                  from log                  from log
348          };          };
349          $sql .= " where message ilike ? " if ($args->{search});  
350            my $sql_context = qq{
351                    select
352                            id
353                    from log
354            };
355    
356            my $context = $1 if ($args->{search} && $args->{search} =~ s/\s*\+(\d+)\s*/ /);
357    
358            my $sql = $context ? $sql_context : $sql_message;
359    
360            sub check_date {
361                    my $date = shift || return;
362                    my $new_date = eval { DateTime::Format::ISO8601->parse_datetime( $date )->ymd; };
363                    if ( $@ ) {
364                            warn "invalid date $date\n";
365                            $new_date = DateTime->now->ymd;
366                    }
367                    return $new_date;
368            }
369    
370            my @where;
371            my @args;
372    
373            if (my $search = $args->{search}) {
374                    $search =~ s/^\s+//;
375                    $search =~ s/\s+$//;
376                    push @where, 'message ilike ? or nick ilike ?';
377                    push @args, ( ( '%' . $search . '%' ) x 2 );
378                    _log "search for '$search'";
379            }
380    
381            if ($args->{tag} && $tags->{ $args->{tag} }) {
382                    push @where, 'id in (' . join(',', @{ $tags->{ $args->{tag} } }) . ')';
383                    _log "search for tags $args->{tag}";
384            }
385    
386            if (my $date = $args->{date} ) {
387                    $date = check_date( $date );
388                    push @where, 'date(time) = ?';
389                    push @args, $date;
390                    _log "search for date $date";
391            }
392    
393            $sql .= " where " . join(" and ", @where) if @where;
394    
395          $sql .= " order by log.time desc";          $sql .= " order by log.time desc";
396          $sql .= " limit " . $args->{limit};          $sql .= " limit " . $args->{limit} if ($args->{limit});
397    
398            #warn "### sql: $sql ", dump( @args );
399    
400          my $sth = $dbh->prepare( $sql );          my $sth = $dbh->prepare( $sql );
401          if ($args->{search}) {          eval { $sth->execute( @args ) };
402                  $sth->execute( $args->{search} );          return if $@;
403          } else {  
                 $sth->execute();  
         }  
404          my $last_row = {          my $last_row = {
405                  date => '',                  date => '',
406                  time => '',                  time => '',
# Line 139  sub get_from_log { Line 414  sub get_from_log {
414                  unshift @rows, $row;                  unshift @rows, $row;
415          }          }
416    
417          my @msgs;          # normalize nick names
418            map {
419                    $_->{nick} =~ s/^_*(.*?)_*$/$1/
420            } @rows;
421    
422            return @rows if ($args->{full_rows});
423    
424            my @msgs = (
425                    "Showing " . ($#rows + 1) . " messages..."
426            );
427    
428            if ($context) {
429                    my @ids = @rows;
430                    @rows = ();
431    
432                    my $last_to = 0;
433    
434                    my $sth = $dbh->prepare( $sql_message . qq{ where id >= ? and id < ? } );
435                    foreach my $row_id (sort { $a->{id} <=> $b->{id} } @ids) {
436                            my $id = $row_id->{id} || die "can't find id in row";
437            
438                            my ($from, $to) = ($id - $context, $id + $context);
439                            $from = $last_to if ($from < $last_to);
440                            $last_to = $to;
441                            $sth->execute( $from, $to );
442    
443                            #warn "## id: $id from: $from to: $to returned: ", $sth->rows, "\n";
444    
445                            while (my $row = $sth->fetchrow_hashref) {
446                                    push @rows, $row;
447                            }
448    
449                    }
450            }
451    
452            # sprintf which can take coderef as first parametar
453            sub cr_sprintf {
454                    my $fmt = shift || return;
455                    if (ref($fmt) eq 'CODE') {
456                            $fmt->(@_);
457                    } else {
458                            sprintf($fmt, @_);
459                    }
460            }
461    
462          foreach my $row (@rows) {          foreach my $row (@rows) {
463    
464                  $row->{time} =~ s#\.\d+##;                  $row->{time} =~ s#\.\d+##;
465    
                 my $t;  
                 $t = $row->{date} . ' ' if ($last_row->{date} ne $row->{date});  
                 $t .= $row->{time};  
   
466                  my $msg = '';                  my $msg = '';
467    
468                    $msg = cr_sprintf($args->{fmt}->{date}, $row->{date}) . ' ' if ($last_row->{date} ne $row->{date});
469                    my $t = $row->{time};
470    
471                  if ($last_row->{channel} ne $row->{channel}) {                  if ($last_row->{channel} ne $row->{channel}) {
472                          $msg .= sprintf($args->{fmt}->{time_channel}, $t, $row->{channel});                          $msg .= cr_sprintf($args->{fmt}->{time_channel}, $t, $row->{channel});
473                  } else {                  } else {
474                          $msg .= sprintf($args->{fmt}->{time}, $t);                          $msg .= cr_sprintf($args->{fmt}->{time}, $t);
475                  }                  }
476    
477                  my $append = 1;                  my $append = 1;
478    
479                  if ($last_row->{nick} ne $row->{nick}) {                  my $nick = $row->{nick};
480                          $msg .= sprintf($args->{fmt}->{nick}, $row->{nick});  #               if ($nick =~ s/^_*(.*?)_*$/$1/) {
481    #                       $row->{nick} = $nick;
482    #               }
483    
484                    if ($last_row->{nick} ne $nick) {
485                            # obfu way to find format for me_nick if needed or fallback to default
486                            my $fmt = $row->{me} ? ( $args->{fmt}->{me_nick} || $args->{fmt}->{nick} ) : $args->{fmt}->{nick};
487                            $fmt ||= '%s';
488    
489                            $nick = $args->{filter}->{nick}->($nick) if (ref($args->{filter}->{nick}) eq 'CODE');
490    
491                            $msg .= cr_sprintf( $fmt, $nick );
492                          $append = 0;                          $append = 0;
493                  }                  }
494    
495                  if (ref($args->{message_filter}) eq 'CODE') {                  $args->{fmt}->{message} ||= '%s';
496                          $msg .= sprintf($args->{fmt}->{message},                  if (ref($args->{filter}->{message}) eq 'CODE') {
497                                  $args->{message_filter}->(                          $msg .= cr_sprintf($args->{fmt}->{message},
498                                    $args->{filter}->{message}->(
499                                          $row->{message}                                          $row->{message}
500                                  )                                  )
501                          );                          );
502                  } else {                  } else {
503                          $msg .= sprintf($args->{fmt}->{message}, $row->{message});                          $msg .= cr_sprintf($args->{fmt}->{message}, $row->{message});
504                  }                  }
505    
506                  if ($append && @msgs) {                  if ($append && @msgs) {
# Line 186  sub get_from_log { Line 515  sub get_from_log {
515          return @msgs;          return @msgs;
516  }  }
517    
518    # tags support
519    
520    my $cloud = HTML::TagCloud->new;
521    
522    =head2 add_tag
523    
524     add_tag( id => 42, message => 'irc message', nick => 'foobar' [, me => 1 ] );
525    
526    =cut
527    
528    my @last_tags;
529    
530    sub add_tag {
531            my $arg = {@_};
532    
533            return unless ($arg->{id} && $arg->{message});
534    
535            my $m = $arg->{message};
536            from_to('UTF-8', 'iso-8859-2', $m) if (is_utf8($m));
537    
538            my @tags;
539    
540            while ($m =~ s#$tag_regex##s) {
541                    my $tag = $1;
542                    next if (! $tag || $tag =~ m/https?:/i);
543                    push @{ $tags->{$tag} }, $arg->{id};
544                    #warn "+tag $tag: $arg->{id}\n";
545                    $cloud->add($tag, "$url?tag=$tag", scalar @{$tags->{$tag}} + 1);
546                    push @tags, $tag;
547    
548            }
549    
550            if ( @tags ) {
551                    pop @last_tags if $#last_tags == $last_x_tags;
552                    unshift @last_tags, { tags => [ @tags ], %$arg };
553            }
554    
555    }
556    
557    =head2 seed_tags
558    
559    Read all tags from database and create in-memory cache for tags
560    
561    =cut
562    
563    sub seed_tags {
564            my $sth = $dbh->prepare(qq{ select id,message,nick,me,time from log where message like '%//%' order by time asc });
565            $sth->execute;
566            while (my $row = $sth->fetchrow_hashref) {
567                    add_tag( %$row );
568            }
569    
570            foreach my $tag (keys %$tags) {
571                    $cloud->add($tag, "$url?tag=$tag", scalar @{$tags->{$tag}} + 1);
572            }
573    }
574    
575    seed_tags;
576    
577    
578    =head2 save_message
579    
580      save_message(
581            channel => '#foobar',
582            me => 0,
583            nick => 'dpavlin',
584            message => 'test message',
585            time => '2006-06-25 18:57:18',
586      );
587    
588    C<time> is optional, it will use C<< now() >> if it's not available.
589    
590    C<me> if not specified will be C<0> (not C</me> message)
591    
592    =cut
593    
594    sub save_message {
595            my $a = {@_};
596            confess "have msg" if $a->{msg};
597            $a->{me} ||= 0;
598            $a->{time} ||= strftime($TIMESTAMP,localtime());
599    
600            _log
601                    $a->{channel}, " ",
602                    $a->{me} ? "***" . $a->{nick} : "<" . $a->{nick} . ">",
603                    " " . $a->{message};
604    
605            $sth_insert_log->execute($a->{channel}, $a->{me}, $a->{nick}, $a->{message}, $a->{time});
606            add_tag( id => $dbh->last_insert_id(undef,undef,"log",undef), %$a );
607    }
608    
609    
610    if ($import_dircproxy) {
611            open(my $l, $import_dircproxy) || die "can't open $import_dircproxy: $!";
612            warn "importing $import_dircproxy...\n";
613            my $tz_offset = 1 * 60 * 60;    # TZ GMT+2
614            while(<$l>) {
615                    chomp;
616                    if (/^@(\d+)\s(\S+)\s(.+)$/) {
617                            my ($time, $nick, $msg) = ($1,$2,$3);
618    
619                            my $dt = DateTime->from_epoch( epoch => $time + $tz_offset );
620    
621                            my $me = 0;
622                            $me = 1 if ($nick =~ m/^\[\S+]/);
623                            $nick =~ s/^[\[<]([^!]+).*$/$1/;
624    
625                            $msg =~ s/^ACTION\s+// if ($me);
626    
627                            save_message(
628                                    channel => $CHANNEL,
629                                    me => $me,
630                                    nick => $nick,
631                                    message => $msg,
632                                    time => $dt->ymd . " " . $dt->hms,
633                            ) if ($nick !~ m/^-/);
634    
635                    } else {
636                            _log "can't parse: $_";
637                    }
638            }
639            close($l);
640            warn "import over\n";
641            exit;
642    }
643    
644    #
645    # RSS follow
646    #
647    
648    my $_rss;
649    
650    
651    sub rss_fetch {
652            my ($args) = @_;
653    
654            # how many messages to send out when feed is seen for the first time?
655            my $send_rss_msgs = 1;
656    
657            _log "RSS fetch", $args->{url};
658    
659            my $feed = XML::Feed->parse(URI->new( $args->{url} ));
660            if ( ! $feed ) {
661                    _log("can't fetch RSS ", $args->{url});
662                    return;
663            }
664            my ( $total, $updates ) = ( 0, 0 );
665            for my $entry ($feed->entries) {
666                    $total++;
667    
668                    # seen allready?
669                    return if $_rss->{$feed->link}->{seen}->{$entry->id}++ > 0;
670    
671                    sub prefix {
672                            my ($txt,$var) = @_;
673                            $var =~ s/^\s+//g;
674                            return $txt . $var if $var;
675                    }
676    
677                    my $msg;
678                    $msg .= prefix( 'From: ' , $feed->title );
679                    $msg .= prefix( ' by ' , $entry->author );
680                    $msg .= prefix( ' -- ' , $entry->link );
681    #               $msg .= prefix( ' id ' , $entry->id );
682    
683                    if ( $args->{kernel} && $send_rss_msgs ) {
684                            warn "# sending to $CHANNEL\n";
685                            $send_rss_msgs--;
686                            $args->{kernel}->post( $IRC_ALIAS => notice => $CHANNEL, $msg );
687                            $updates++;
688                            #$sth_insert_log->execute( $CHANNEL, 1, $NICK, $msg, undef );
689                            _log('RSS', $msg);
690                    }
691            }
692    
693            my $sql = qq{ update feeds set last_update = now(), polls = polls + 1 };
694            $sql .= qq{, updates = updates + $updates } if $updates;
695            $sql .= qq{where id = } . $args->{id};
696            eval { $dbh->do( $sql ) };
697    
698            _log "RSS got $total items of which $updates new";
699    
700            return $updates;
701    }
702    
703    sub rss_fetch_all {
704            my $kernel = shift;
705            my $sql = qq{
706                    select id, url, name
707                    from feeds
708                    where active is true
709            };
710            # limit to newer feeds only if we are not sending messages out
711            $sql .= qq{     and last_update + delay < now() } if $kernel;
712            my $sth = $dbh->prepare( $sql );
713            $sth->execute();
714            warn "# ",$sth->rows," active RSS feeds\n";
715            my $count = 0;
716            while (my $row = $sth->fetchrow_hashref) {
717                    $row->{kernel} = $kernel if $kernel;
718                    $count += rss_fetch( $row );
719            }
720            return "OK, fetched $count posts from " . $sth->rows . " feeds";
721    }
722    
723    
724    sub rss_check_updates {
725            my $kernel = shift;
726            my $last_t = $_rss->{last_poll} || time();
727            my $t = time();
728            if ( $last_t - $t > $rss_min_delay ) {
729                    $_rss->{last_poll} = $t;
730                    _log rss_fetch_all( $kernel );
731            }
732    }
733    
734    # seed rss seen cache so we won't send out all items on startup
735    _log rss_fetch_all;
736    
737    #
738    # POE handing part
739    #
740    
741  my $SKIPPING = 0;               # if skipping, how many we've done  my $SKIPPING = 0;               # if skipping, how many we've done
742  my $SEND_QUEUE;                 # cache  my $SEND_QUEUE;                 # cache
743    my $ping;                                               # ping stats
744    
745  POE::Component::IRC->new($IRC_ALIAS);  POE::Component::IRC->new($IRC_ALIAS);
746    
747  POE::Session->create  POE::Session->create( inline_states => {
748    (inline_states =>          _start => sub {      
    {_start => sub {        
749                  $_[KERNEL]->post($IRC_ALIAS => register => 'all');                  $_[KERNEL]->post($IRC_ALIAS => register => 'all');
750                  $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);                  $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);
751      },      },
752      irc_255 => sub {    # server is done blabbing      irc_255 => sub {    # server is done blabbing
753                  $_[KERNEL]->post($IRC_ALIAS => join => $CHANNEL);                  $_[KERNEL]->post($IRC_ALIAS => join => $CHANNEL);
                 $_[KERNEL]->post($IRC_ALIAS => join => '#logger');  
                 $_[KERNEL]->yield("heartbeat"); # start heartbeat  
 #               $_[KERNEL]->yield("my_add", $_) for keys %FOLLOWS;  
754                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );
755      },      },
756      irc_public => sub {      irc_public => sub {
# Line 211  POE::Session->create Line 759  POE::Session->create
759                  my $channel = $_[ARG1]->[0];                  my $channel = $_[ARG1]->[0];
760                  my $msg = $_[ARG2];                  my $msg = $_[ARG2];
761    
762                  from_to($msg, 'UTF-8', $ENCODING);                  save_message( channel => $channel, me => 0, nick => $nick, message => $msg);
763                    meta( $nick, $channel, 'last-msg', $msg );
764        },
765        irc_ctcp_action => sub {
766                    my $kernel = $_[KERNEL];
767                    my $nick = (split /!/, $_[ARG0])[0];
768                    my $channel = $_[ARG1]->[0];
769                    my $msg = $_[ARG2];
770    
771                    save_message( channel => $channel, me => 1, nick => $nick, message => $msg);
772    
773                    if ( $use_twitter ) {
774                            if ( my $twitter = meta( $nick, $NICK, 'twitter' ) ) {
775                                    my ($login,$passwd) = split(/\s+/,$twitter,2);
776                                    _log("sending twitter for $nick/$login on $channel ");
777                                    my $bot = Net::Twitter->new( username=>$login, password=>$passwd );
778                                    $bot->update("<${channel}> $msg");
779                            }
780                    }
781    
                 print "$channel: <$nick> $msg\n";  
                 $sth->execute($channel, $nick, $msg);  
782      },      },
783            irc_ping => sub {
784                    _log( "pong ", $_[ARG0] );
785                    $ping->{ $_[ARG0] }++;
786                    rss_check_updates( $_[KERNEL] );
787            },
788            irc_invite => sub {
789                    my $kernel = $_[KERNEL];
790                    my $nick = (split /!/, $_[ARG0])[0];
791                    my $channel = $_[ARG1];
792    
793                    _log "invited to $channel by $nick";
794    
795                    $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, "how nice of you to invite me to $channel, I'll be right there..." );
796                    $_[KERNEL]->post($IRC_ALIAS => join => $channel);
797    
798            },
799          irc_msg => sub {          irc_msg => sub {
800                  my $kernel = $_[KERNEL];                  my $kernel = $_[KERNEL];
801                  my $nick = (split /!/, $_[ARG0])[0];                  my $nick = (split /!/, $_[ARG0])[0];
802                  my $msg = $_[ARG2];                  my $msg = $_[ARG2];
803                  from_to($msg, 'UTF-8', $ENCODING);                  my $channel = $_[ARG1]->[0];
804    
805                  my $res = "unknown command '$msg', try /msg $NICK help!";                  my $res = "unknown command '$msg', try /msg $NICK help!";
806                  my @out;                  my @out;
807    
808                  print "<< $msg\n";                  _log "<< $msg";
809    
810                  if ($msg =~ m/^help/i) {                  if ($msg =~ m/^help/i) {
811    
# Line 233  POE::Session->create Line 813  POE::Session->create
813    
814                  } elsif ($msg =~ m/^msg\s+(\S+)\s+(.*)$/i) {                  } elsif ($msg =~ m/^msg\s+(\S+)\s+(.*)$/i) {
815    
816                          print ">> /msg $1 $2\n";                          _log ">> /msg $1 $2";
817                          $_[KERNEL]->post( $IRC_ALIAS => privmsg => $1, $2 );                          $_[KERNEL]->post( $IRC_ALIAS => privmsg => $1, $2 );
818                          $res = '';                          $res = '';
819    
# Line 242  POE::Session->create Line 822  POE::Session->create
822                          my $nr = $1 || 10;                          my $nr = $1 || 10;
823    
824                          my $sth = $dbh->prepare(qq{                          my $sth = $dbh->prepare(qq{
825                                  select nick,count(*) from log group by nick order by count desc limit $nr                                  select
826                                            trim(both '_' from nick) as nick,
827                                            count(*) as count,
828                                            sum(length(message)) as len
829                                    from log
830                                    group by trim(both '_' from nick)
831                                    order by len desc,count desc
832                                    limit $nr
833                          });                          });
834                          $sth->execute();                          $sth->execute();
835                          $res = "Top $nr users: ";                          $res = "Top $nr users: ";
836                          my @users;                          my @users;
837                          while (my $row = $sth->fetchrow_hashref) {                          while (my $row = $sth->fetchrow_hashref) {
838                                  push @users,$row->{nick} . ': ' . $row->{count};                                  push @users,$row->{nick} . ': ' . $row->{count} . '/' . $row->{len} . '=' . sprintf("%.2f", $row->{len}/$row->{count});
839                          }                          }
840                          $res .= join(" | ", @users);                          $res .= join(" | ", @users);
841                  } elsif ($msg =~ m/^last.*?\s*(\d*)/i) {                  } elsif ($msg =~ m/^last.*?\s*(\d*)/i) {
842    
843                          foreach my $res (get_from_log( limit => $1 )) {                          my $limit = $1 || meta( $nick, $channel, 'last-size' ) || 10;
844                                  print "last: $res\n";  
845                                  from_to($res, $ENCODING, 'UTF-8');                          foreach my $res (get_from_log( limit => $limit )) {
846                                    _log "last: $res";
847                                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );                                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );
848                          }                          }
849    
850                          $res = '';                          $res = '';
851    
852                  } elsif ($msg =~ m/^(search|grep)\s+(.*)$/i) {                  } elsif ($msg =~ m/^(search|grep)\s+(.*)\s*$/i) {
853    
854                          my $what = $2;                          my $what = $2;
855    
856                          foreach my $res (get_from_log( limit => 20, search => "%${what}%" )) {                          foreach my $res (get_from_log(
857                                  print "search [$what]: $res\n";                                          limit => 20,
858                                  from_to($res, $ENCODING, 'UTF-8');                                          search => $what,
859                                    )) {
860                                    _log "search [$what]: $res";
861                                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );                                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );
862                          }                          }
863    
864                          $res = '';                          $res = '';
865    
866                    } elsif ($msg =~ m/^(?:count|poll)\s+(.*)(?:\s+(\d+))?\s*$/i) {
867    
868                            my ($what,$limit) = ($1,$2);
869                            $limit ||= 100;
870    
871                            my $stat;
872    
873                            foreach my $res (get_from_log(
874                                            limit => $limit,
875                                            search => $what,
876                                            full_rows => 1,
877                                    )) {
878                                    while ($res->{message} =~ s/\Q$what\E(\+|\-)//) {
879                                            $stat->{vote}->{$1}++;
880                                            $stat->{from}->{ $res->{nick} }++;
881                                    }
882                            }
883    
884                            my @nicks;
885                            foreach my $nick (sort { $stat->{from}->{$a} <=> $stat->{from}->{$b} } keys %{ $stat->{from} }) {
886                                    push @nicks, $nick . ( $stat->{from}->{$nick} == 1 ? '' :
887                                            "(" . $stat->{from}->{$nick} . ")"
888                                    );
889                            }
890    
891                            $res =
892                                    "$what ++ " . ( $stat->{vote}->{'+'} || 0 ) .
893                                    " : " . ( $stat->{vote}->{'-'} || 0 ) . " --" .
894                                    " from " . ( join(", ", @nicks) || 'nobody' );
895    
896                            $_[KERNEL]->post( $IRC_ALIAS => notice => $nick, $res );
897    
898                    } elsif ($msg =~ m/^ping/) {
899                            $res = "ping = " . dump( $ping );
900                    } elsif ($msg =~ m/^conf(?:ig)*\s*(last-size|twitter)*\s*(.*)/) {
901                            if ( ! defined( $1 ) ) {
902                                    my $sth = $dbh->prepare(qq{ select name,value,changed from meta where nick = ? and channel = ? });
903                                    $sth->execute( $nick, $channel );
904                                    $res = "config for $nick on $channel";
905                                    while ( my ($n,$v) = $sth->fetchrow_array ) {
906                                            $res .= " | $n = $v";
907                                    }
908                            } elsif ( ! $2 ) {
909                                    my $val = meta( $nick, $channel, $1 );
910                                    $res = "current $1 = " . ( $val ? $val : 'undefined' );
911                            } else {
912                                    my $validate = {
913                                            'last-size' => qr/^\d+/,
914                                            'twitter' => qr/^\w+\s+\w+/,
915                                    };
916    
917                                    my ( $op, $val ) = ( $1, $2 );
918    
919                                    if ( my $regex = $validate->{$op} ) {
920                                            if ( $val =~ $regex ) {
921                                                    meta( $nick, $channel, $op, $val );
922                                                    $res = "saved $op = $val";
923                                            } else {
924                                                    $res = "config option $op = $val doesn't validate against $regex";
925                                            }
926                                    } else {
927                                            $res = "config option $op doesn't exist";
928                                    }
929                            }
930                    } elsif ($msg =~ m/^rss-update/) {
931                            $res = rss_fetch_all( $_[KERNEL] );
932                    } elsif ($msg =~ m/^rss-clean/) {
933                            $_rss = undef;
934                            $res = "OK, cleaned RSS cache";
935                    } elsif ($msg =~ m!^rss-(add|remove|stop|start)\s+(http://\S+)\s*(.*)!) {
936                            my $sql = {
937                                    add             => qq{ insert into feeds (url,name) values (?,?) },
938    #                               remove  => qq{ delete from feeds                                where url = ? and name = ? },
939                                    start   => qq{ update feeds set active = true   where url = ? -- ? },
940                                    stop    => qq{ update feeds set active = false  where url = ? -- ? },
941                                    
942                            };
943                            if (my $q = $sql->{$1} ) {
944                                    my $sth = $dbh->prepare( $q );
945                                    warn "## SQL $q ( $2 | $3 )\n";
946                                    eval { $sth->execute( $2, $3 ) };
947                            }
948    
949                            $res ||= "OK, RSS $1 : $2 - $3";
950                  }                  }
951    
952                  if ($res) {                  if ($res) {
953                          print ">> [$nick] $res\n";                          _log ">> [$nick] $res";
                         from_to($res, $ENCODING, 'UTF-8');  
954                          $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );                          $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );
955                  }                  }
956    
957                    rss_check_updates( $_[KERNEL] );
958          },          },
959          irc_477 => sub {          irc_477 => sub {
960                  print "# irc_477: ",$_[ARG1], "\n";                  _log "# irc_477: ",$_[ARG1];
961                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "register $NICK" );                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "register $NICK" );
962          },          },
963          irc_505 => sub {          irc_505 => sub {
964                  print "# irc_505: ",$_[ARG1], "\n";                  _log "# irc_505: ",$_[ARG1];
965                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "register $NICK" );                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "register $NICK" );
966  #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "set hide email on" );  #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "set hide email on" );
967  #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "set email dpavlin\@rot13.org" );  #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "set email dpavlin\@rot13.org" );
968          },          },
969          irc_registered => sub {          irc_registered => sub {
970                  warn "## indetify $NICK\n";                  _log "## registrated $NICK";
971                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );
972          },          },
973            irc_disconnected => sub {
974                    _log "## disconnected, reconnecting again";
975                    $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);
976            },
977            irc_socketerr => sub {
978                    _log "## socket error... sleeping for $sleep_on_error seconds and retry";
979                    sleep($sleep_on_error);
980                    $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);
981            },
982  #       irc_433 => sub {  #       irc_433 => sub {
983  #               print "# irc_433: ",$_[ARG1], "\n";  #               print "# irc_433: ",$_[ARG1], "\n";
984  #               warn "## indetify $NICK\n";  #               warn "## indetify $NICK\n";
985  #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );  #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );
986  #       },  #       },
         irc_372 => sub {  
                 print "MOTD: ", $_[ARG1], "\n";  
         },  
         irc_snotice => sub {  
                 print "(server notice): ", $_[ARG0], "\n";  
         },  
     (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  
987      _child => sub {},      _child => sub {},
988      _default => sub {      _default => sub {
989        printf "%s: session %s caught an unhandled %s event.\n",                  _log sprintf "sID:%s %s %s",
990          scalar localtime(), $_[SESSION]->ID, $_[ARG0];                          $_[SESSION]->ID, $_[ARG0],
991        print "The $_[ARG0] event was given these parameters: ",                          ref($_[ARG1]) eq "ARRAY"        ?       join(",", map { ref($_) eq "ARRAY" ? join(";", @{$_}) : $_ } @{ $_[ARG1] })     :
992          join(" ", map({"ARRAY" eq ref $_ ? "[@$_]" : "$_"} @{$_[ARG1]})), "\n";                          $_[ARG1]                                        ?       $_[ARG1]                                        :
993                            "";
994        0;                        # false for signals        0;                        # false for signals
995      },      },
     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);  
     }  
996     },     },
997    );    );
998    
999  # http server  # http server
1000    
1001  my $httpd = POE::Component::Server::HTTP->new(  my $httpd = POE::Component::Server::HTTP->new(
1002          Port => $NICK =~ m/-dev/ ? 8001 : 8000,          Port => $http_port,
1003            PreHandler => {
1004                    '/' => sub {
1005                            $_[0]->header(Connection => 'close')
1006                    }
1007            },
1008          ContentHandler => { '/' => \&root_handler },          ContentHandler => { '/' => \&root_handler },
1009          Headers        => { Server => 'irc-logger' },          Headers        => { Server => 'irc-logger' },
1010  );  );
1011    
1012  my $style = <<'_END_OF_STYLE_';  my $style = <<'_END_OF_STYLE_';
1013    p { margin: 0; padding: 0.1em; }
1014  .time, .channel { color: #808080; font-size: 60%; }  .time, .channel { color: #808080; font-size: 60%; }
1015  .nick { color: #0000ff; font-size: 80%; }  .date { float: right; background: #e0e0e0; color: #404040; font-size: 120%; padding: 0.25em; border: 1px dashed #808080; }
1016    .nick { color: #000000; font-size: 80%; padding: 2px; font-family: courier, courier new, monospace ; }
1017  .message { color: #000000; font-size: 100%; }  .message { color: #000000; font-size: 100%; }
1018    .search { float: right; }
1019    a:link.tag, a:visited.tag { border: 1px dashed #ccc; backgound: #ccc; text-decoration: none }
1020    a:hover.tag { border: 1px solid #eee }
1021    hr { border: 1px dashed #ccc; height: 1px; clear: both; }
1022    /*
1023    .col-0 { background: #ffff66 }
1024    .col-1 { background: #a0ffff }
1025    .col-2 { background: #99ff99 }
1026    .col-3 { background: #ff9999 }
1027    .col-4 { background: #ff66ff }
1028    */
1029    .calendar { border: 1px solid red; width: 100%; }
1030    .month { border: 0px; width: 100%; }
1031  _END_OF_STYLE_  _END_OF_STYLE_
1032    
1033    $max_color = 0;
1034    
1035    my @cols = qw(
1036            #ffcccc #ccffe6 #ccccff #e6ccff #ffccff #ffcce6 #ff9999 #ffcc99 #ffff99
1037            #ccff99 #99ff99 #99ffcc #99ccff #9999ff #cc99ff #ff6666 #ffb366 #ffff66
1038            #66ff66 #66ffb3 #66b3ff #6666ff #ff3333 #33ff33 #3399ff #3333ff #ff3399
1039            #a0a0a0 #ff0000 #ffff00 #80ff00 #0000ff #8000ff #ff00ff #ff0080 #994d00
1040            #999900 #009900 #cc0066 #c0c0c0 #ccff99 #99ff33 #808080 #660033 #ffffff
1041    );
1042    
1043    foreach my $c (@cols) {
1044            $style .= ".col-${max_color} { background: $c }\n";
1045            $max_color++;
1046    }
1047    warn "defined $max_color colors for users...\n";
1048    
1049  sub root_handler {  sub root_handler {
1050          my ($request, $response) = @_;          my ($request, $response) = @_;
1051          $response->code(RC_OK);          $response->code(RC_OK);
1052          $response->content_type("text/html; charset=$ENCODING");  
1053          $response->content(          # this doesn't seem to work, so moved to PreHandler
1054                  qq{<html><head><title>$NICK</title><style type="text/css">$style</style></head><body>} .          #$response->header(Connection => 'close');
1055                  "irc-logger url: " . $request->uri . '<br/>' .  
1056                  join("<br/>",          return RC_OK if $request->uri =~ m/favicon.ico$/;
1057    
1058            my $q;
1059    
1060            if ( $request->method eq 'POST' ) {
1061                    $q = new CGI::Simple( $request->content );
1062            } elsif ( $request->uri =~ /\?(.+)$/ ) {
1063                    $q = new CGI::Simple( $1 );
1064            } else {
1065                    $q = new CGI::Simple;
1066            }
1067    
1068            my $search = $q->param('search') || $q->param('grep') || '';
1069    
1070            if ($request->url =~ m#/rss(?:/(tags|last-tag|follow.*)\w*(?:=(\d+))?)?#i) {
1071                    my $show = lc($1);
1072                    my $nr = $2;
1073    
1074                    my $type = 'RSS';       # Atom
1075    
1076                    $response->content_type( 'application/' . lc($type) . '+xml' );
1077    
1078                    my $html = '<!-- error -->';
1079                    #warn "create $type feed from ",dump( @last_tags );
1080    
1081                    my $feed = XML::Feed->new( $type );
1082                    $feed->link( $url );
1083    
1084                    if ( $show eq 'tags' ) {
1085                            $nr ||= 50;
1086                            $feed->title( "tags from $CHANNEL" );
1087                            $feed->link( "$url/tags" );
1088                            $feed->description( "tag cloud created from messages on channel $CHANNEL which have tags// in them" );
1089                            my $feed_entry = XML::Feed::Entry->new($type);
1090                            $feed_entry->title( "$nr tags from $CHANNEL" );
1091                            $feed_entry->author( $NICK );
1092                            $feed_entry->link( '/#tags'  );
1093    
1094                            $feed_entry->content(
1095                                    qq{<![CDATA[<style type="text/css">}
1096                                    . $cloud->css
1097                                    . qq{</style>}
1098                                    . $cloud->html( $nr )
1099                                    . qq{]]>}
1100                            );
1101                            $feed->add_entry( $feed_entry );
1102    
1103                    } elsif ( $show eq 'last-tag' ) {
1104    
1105                            $nr ||= $last_x_tags;
1106                            $nr = $last_x_tags if $nr > $last_x_tags;
1107    
1108                            $feed->title( "last $nr tagged messages from $CHANNEL" );
1109                            $feed->description( "collects messages which have tags// in them" );
1110    
1111                            foreach my $m ( @last_tags ) {
1112    #                               warn dump( $m );
1113                                    #my $tags = join(' ', @{$m->{tags}} );
1114                                    my $feed_entry = XML::Feed::Entry->new($type);
1115                                    $feed_entry->title( $m->{nick} . '@' . $m->{time} );
1116                                    $feed_entry->author( $m->{nick} );
1117                                    $feed_entry->link( '/#' . $m->{id}  );
1118                                    $feed_entry->issued( DateTime::Format::Flexible->build( $m->{time} ) );
1119    
1120                                    my $message = $filter->{message}->( $m->{message} );
1121                                    $message .= "<br/>\n" unless $message =~ m!<(/p|br/?)>!;
1122    #                               warn "## message = $message\n";
1123    
1124                                    #$feed_entry->summary(
1125                                    $feed_entry->content(
1126                                            "<![CDATA[$message]]>"
1127                                    );
1128                                    $feed_entry->category( join(', ', @{$m->{tags}}) );
1129                                    $feed->add_entry( $feed_entry );
1130    
1131                                    $nr--;
1132                                    last if $nr <= 0;
1133    
1134                            }
1135    
1136                    } elsif ( $show =~ m/^follow/ ) {
1137    
1138                            $feed->title( "Feeds which this bot follows" );
1139    
1140                            my $sth = $dbh->prepare( qq{ select * from feeds order by last_update desc } );
1141                            $sth->execute;
1142                            while (my $row = $sth->fetchrow_hashref) {
1143                                    my $feed_entry = XML::Feed::Entry->new($type);
1144                                    $feed_entry->title( $row->{name} );
1145                                    $feed_entry->link( $row->{url}  );
1146                                    $feed_entry->issued( DateTime::Format::Flexible->build( $row->{last_update} ) );
1147                                    $feed_entry->content(
1148                                            '<![CDATA[<pre>' . dump( $row ) . '</pre>]]>'
1149                                    );
1150                                    $feed->add_entry( $feed_entry );
1151                            }
1152    
1153                    } else {
1154                            _log "unknown rss request ",$request->url;
1155                            return RC_DENY;
1156                    }
1157    
1158                    $response->content( $feed->as_xml );
1159                    return RC_OK;
1160            }
1161    
1162            if ( $@ ) {
1163                    warn "$@";
1164            }
1165    
1166            $response->content_type("text/html; charset=UTF-8");
1167    
1168            my $html =
1169                    qq{<html><head><title>$NICK</title><style type="text/css">$style}
1170                    . $cloud->css
1171                    . qq{</style></head><body>}
1172                    . qq{
1173                    <form method="post" class="search" action="/">
1174                    <input type="text" name="search" value="$search" size="10">
1175                    <input type="submit" value="search">
1176                    </form>
1177                    }
1178                    . $cloud->html(500)
1179                    . qq{<p>};
1180    
1181            if ($request->url =~ m#/tags?#) {
1182                    # nop
1183            } elsif ($request->url =~ m#/history#) {
1184                    my $sth = $dbh->prepare(qq{
1185                            select date(time) as date,count(*) as nr,sum(length(message)) as len
1186                                    from log
1187                                    group by date(time)
1188                                    order by date(time) desc
1189                    });
1190                    $sth->execute();
1191                    my ($l_yyyy,$l_mm) = (0,0);
1192                    $html .= qq{<table class="calendar"><tr>};
1193                    my $cal;
1194                    my $ord = 0;
1195                    while (my $row = $sth->fetchrow_hashref) {
1196                            # this is probably PostgreSQL specific, expects ISO date
1197                            my ($yyyy,$mm,$dd) = split(/-/, $row->{date});
1198                            if ($yyyy != $l_yyyy || $mm != $l_mm) {
1199                                    if ( $cal ) {
1200                                            $html .= qq{<td valign="top">} . $cal->as_HTML() . qq{</td>};
1201                                            $ord++;
1202                                            $html .= qq{</tr><tr>} if ( $ord % 3 == 0 );
1203                                    }
1204                                    $cal = new HTML::CalendarMonthSimple('month'=>$mm,'year'=>$yyyy);
1205                                    $cal->border(1);
1206                                    $cal->width('30%');
1207                                    $cal->cellheight('5em');
1208                                    $cal->tableclass('month');
1209                                    #$cal->cellclass('day');
1210                                    $cal->sunday('SUN');
1211                                    $cal->saturday('SAT');
1212                                    $cal->weekdays('MON','TUE','WED','THU','FRI');
1213                                    ($l_yyyy,$l_mm) = ($yyyy,$mm);
1214                            }
1215                            $cal->setcontent($dd, qq[
1216                                    <a href="$url?date=$row->{date}">$row->{nr}</a><br/>$row->{len}
1217                            ]);
1218                            
1219                    }
1220                    $html .= qq{<td valign="top">} . $cal->as_HTML() . qq{</td></tr></table>};
1221    
1222            } else {
1223                    $html .= join("</p><p>",
1224                          get_from_log(                          get_from_log(
1225                                  limit => 100,                                  limit => ( $q->param('last') || $q->param('date') ) ? undef : 100,
1226                                    search => $search || undef,
1227                                    tag => $q->param('tag') || undef,
1228                                    date => $q->param('date') || undef,
1229                                  fmt => {                                  fmt => {
1230                                            date => sub {
1231                                                    my $date = shift || return;
1232                                                    qq{<hr/><div class="date"><a href="$url?date=$date">$date</a></div>};
1233                                            },
1234                                          time => '<span class="time">%s</span> ',                                          time => '<span class="time">%s</span> ',
1235                                          time_channel => '<span class="channel">%s %s</span> ',                                          time_channel => '<span class="channel">%s %s</span> ',
1236                                          nick => '<span class="nick">%s:</span> ',                                          nick => '%s:&nbsp;',
1237                                            me_nick => '***%s&nbsp;',
1238                                          message => '<span class="message">%s</span>',                                          message => '<span class="message">%s</span>',
1239                                  },                                  },
1240                                  message_filter => sub {                                  filter => $filter,
                                         my $m = shift || return;  
                                         $m =~ s#($RE{URI}{HTTP})#<a href="$1">$1</a>#gs;  
                                         return $m;  
                                 },  
1241                          )                          )
1242                  ) .                  );
1243                  qq{</body></html>}          }
1244          );  
1245            $html .= qq{</p>
1246            <hr/>
1247            <p>See <a href="/history">history</a> of all messages.</p>
1248            </body></html>};
1249    
1250            $response->content( $html );
1251            warn "<< ", $request->method, " ", $request->uri, " created ", length($html), " bytes\n";
1252          return RC_OK;          return RC_OK;
1253  }  }
1254    
Legend:
Removed from v.15  
changed lines
  Added in v.87
  ViewVC Help
Powered by ViewVC 1.1.26