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