/[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

Annotation of /trunk/bin/irc-logger.pl

Parent Directory Parent Directory | Revision Log Revision Log


Revision 85 - (hide annotations)
Thu Mar 6 22:16:27 2008 UTC (16 years ago) by dpavlin
File MIME type: text/plain
File size: 32702 byte(s)
First cut at implementing RSS feed fetcher on my own.

First, I tried to use POE::Component::RSSAggregator but
it had additional dependencies on different RSS implementation and lacked
reporting of item authors, so I opted to write it from scratch.

New irc-logger commands:

 rss-add http://www.example.com/index.rss name of feed
 rss-update
 rss-clean

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

Properties

Name Value
svn:executable *

  ViewVC Help
Powered by ViewVC 1.1.26