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