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