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

Properties

Name Value
svn:executable *

  ViewVC Help
Powered by ViewVC 1.1.26