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

Properties

Name Value
svn:executable *

  ViewVC Help
Powered by ViewVC 1.1.26