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

Properties

Name Value
svn:executable *

  ViewVC Help
Powered by ViewVC 1.1.26