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

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

Parent Directory Parent Directory | Revision Log Revision Log


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

Properties

Name Value
svn:executable *

  ViewVC Help
Powered by ViewVC 1.1.26