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