/[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 132 - (show annotations)
Tue Apr 1 19:04:32 2008 UTC (16 years ago) by dpavlin
File MIME type: text/plain
File size: 36398 byte(s)
don't die if we can't convert message to internal database encoding,
instead just report error and skip message (bad, but better than dying)
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 eval { $sth_insert_log->execute($a->{channel}, $a->{me}, $a->{nick}, $a->{message}, $a->{time}); };
614 _log "ERROR: can't archive ", $a->{message} if $@;
615 add_tag( id => $dbh->last_insert_id(undef,undef,"log",undef), %$a );
616 }
617
618
619 if ($import_dircproxy) {
620 open(my $l, $import_dircproxy) || die "can't open $import_dircproxy: $!";
621 warn "importing $import_dircproxy...\n";
622 my $tz_offset = 1 * 60 * 60; # TZ GMT+2
623 while(<$l>) {
624 chomp;
625 if (/^@(\d+)\s(\S+)\s(.+)$/) {
626 my ($time, $nick, $msg) = ($1,$2,$3);
627
628 my $dt = DateTime->from_epoch( epoch => $time + $tz_offset );
629
630 my $me = 0;
631 $me = 1 if ($nick =~ m/^\[\S+]/);
632 $nick =~ s/^[\[<]([^!]+).*$/$1/;
633
634 $msg =~ s/^ACTION\s+// if ($me);
635
636 save_message(
637 channel => $CHANNEL,
638 me => $me,
639 nick => $nick,
640 message => $msg,
641 time => $dt->ymd . " " . $dt->hms,
642 ) if ($nick !~ m/^-/);
643
644 } else {
645 _log "can't parse: $_";
646 }
647 }
648 close($l);
649 warn "import over\n";
650 exit;
651 }
652
653 #
654 # RSS follow
655 #
656
657 my $_stat;
658
659 POE::Component::Client::HTTP->spawn(
660 Alias => 'rss-fetch',
661 Timeout => 30,
662 );
663
664 =head2 rss_parse_xml
665
666 rss_parse_xml({
667 url => 'http://www.example.com/rss',
668 send_rss_msgs => 42,
669 });
670
671 =cut
672
673 sub rss_parse_xml {
674 my ($kernel,$args) = @_;
675
676 warn "## rss_parse_xml ",dump( $args ) if $debug;
677
678 # how many messages to send out when feed is seen for the first time?
679 my $send_rss_msgs = $args->{send_rss_msgs};
680 $send_rss_msgs = 1 if ! defined $send_rss_msgs;
681
682 warn "## RSS fetch first $send_rss_msgs items from", $args->{url} if $debug;
683
684 my $feed = XML::Feed->parse( \$args->{xml} );
685 if ( ! $feed ) {
686 _log "can't fetch RSS ", $args->{url}, XML::Feed->errstr;
687 return;
688 }
689
690 $_stat->{rss}->{url2link}->{ $args->{url} } = $feed->link;
691
692 my ( $total, $updates ) = ( 0, 0 );
693 for my $entry ($feed->entries) {
694 $total++;
695
696 my $seen_times = $_stat->{rss}->{seen}->{$args->{channel}}->{$feed->link}->{$entry->id}++;
697 # seen allready?
698 warn "## $seen_times ",$entry->id if $debug;
699 next if $seen_times > 0;
700
701 sub prefix {
702 my ($txt,$var) = @_;
703 $var =~ s/\s+/ /gs;
704 $var =~ s/^\s+//g;
705 $var =~ s/\s+$//g;
706 return $txt . $var if $var;
707 }
708
709 # fix absolute and relative links to feed entries
710 my $link = $entry->link;
711 if ( $link =~ m!^/! ) {
712 my $host = $args->{url};
713 $host =~ s!^(http://[^/]+).*$!$1!; #!vim
714 $link = "$host/$link";
715 } elsif ( $link !~ m!^http! ) {
716 $link = $args->{url} . $link;
717 }
718
719 my $msg;
720 $msg .= prefix( 'From: ' , $args->{name} || $feed->title );
721 $msg .= prefix( ' by ' , $entry->author );
722 $msg .= prefix( ' | ' , $entry->title );
723 $msg .= prefix( ' | ' , $link );
724 # $msg .= prefix( ' id ' , $entry->id );
725 my @categories = $entry->category;
726 warn "## category = ", dump( @categories ) if $debug;
727 if ( my $tags = $entry->category ) {
728 $tags = join(' ', @$tags) if ref($tags) eq 'ARRAY';
729 $tags =~ s!^\s+!!;
730 $tags =~ s!\s*$! !;
731 $tags =~ s!,?\s+!// !g;
732 $msg .= prefix( ' ' , $tags );
733 }
734
735 if ( $seen_times == 0 && $send_rss_msgs ) {
736 $send_rss_msgs--;
737 if ( ! $args->{private} ) {
738 # FIXME bug! should be save_message
739 save_message( channel => $args->{channel}, me => 1, nick => $NICK, message => $msg );
740 # $sth_insert_log->execute( $args->{channel}, 1, $NICK, $msg, 'now()' );
741 }
742 my ( $type, $to ) = ( 'notice', $args->{channel} );
743 ( $type, $to ) = ( 'privmsg', $args->{nick} ) if $args->{private};
744
745 _log(">> RSS $type to $to:", $msg);
746 $kernel->post( $irc => $type => $to => $msg );
747
748 $updates++;
749 }
750 }
751
752 my $sql = qq{ update feeds set last_update = now(), polls = polls + 1 };
753 $sql .= qq{, updates = updates + $updates } if $updates;
754 $sql .= qq{where id = } . $args->{id};
755 eval { $dbh->do( $sql ) };
756
757 _log "RSS $updates/$total new items from", $args->{url};
758
759 return $updates;
760 }
761
762 sub rss_fetch_all {
763 my ( $kernel, $send_rss_msgs ) = @_;
764 warn "## rss_fetch_all -- send_rss_msgs: $send_rss_msgs\n" if $debug;
765 my $sql = qq{
766 select id, url, name, channel, nick, private
767 from feeds
768 where active is true
769 };
770 # limit to newer feeds only if we are not sending messages out
771 $sql .= qq{ and last_update + delay < now() } if defined ( $_stat->{rss}->{fetch} );
772 my $sth = $dbh->prepare( $sql );
773 $sth->execute();
774 warn "# ",$sth->rows," active RSS feeds\n";
775 my $count = 0;
776 while (my $row = $sth->fetchrow_hashref) {
777 $row->{send_rss_msgs} = $send_rss_msgs if defined $send_rss_msgs;
778 $_stat->{rss}->{fetch}->{ $row->{url} } = $row;
779 $kernel->post(
780 'rss-fetch',
781 'request',
782 'rss_response',
783 HTTP::Request->new( GET => $row->{url} ),
784 );
785 warn "## queued rss-fetch ", dump( $row ) if $debug;
786 }
787 return "OK, scheduled " . $sth->rows . " feeds for refresh";
788 }
789
790
791 sub rss_check_updates {
792 my $kernel = shift;
793 $_stat->{rss}->{last_poll} ||= time();
794 my $dt = time() - $_stat->{rss}->{last_poll};
795 if ( $dt > $rss_min_delay ) {
796 warn "## rss_check_updates $dt > $rss_min_delay\n";
797 $_stat->{rss}->{last_poll} = time();
798 _log rss_fetch_all( $kernel );
799 }
800 }
801
802 sub process_command {
803 my ( $kernel, $nick, $channel, $msg ) = @_;
804
805 my $res = "unknown command '$msg', try /msg $NICK help!";
806
807 if ($msg =~ m/^help/i) {
808
809 $res = "usage: /msg $NICK comand | commands: stat - user/message stat | last - show backtrace | grep foobar - find foobar";
810
811 } elsif ($msg =~ m/^(privmsg|notice)\s+(\S+)\s+(.*)$/i) {
812
813 _log ">> /$1 $2 $3";
814 $kernel->post( $irc => $1 => $2, $3 );
815 $res = '';
816
817 } elsif ($msg =~ m/^stat.*?\s*(\d*)/i) {
818
819 my $nr = $1 || 10;
820
821 my $sth = $dbh->prepare(qq{
822 select
823 trim(both '_' from nick) as nick,
824 count(*) as count,
825 sum(length(message)) as len
826 from log
827 group by trim(both '_' from nick)
828 order by len desc,count desc
829 limit $nr
830 });
831 $sth->execute();
832 $res = "Top $nr users: ";
833 my @users;
834 while (my $row = $sth->fetchrow_hashref) {
835 push @users,$row->{nick} . ': ' . $row->{count} . '/' . $row->{len} . '=' . sprintf("%.2f", $row->{len}/$row->{count});
836 }
837 $res .= join(" | ", @users);
838 } elsif ($msg =~ m/^last.*?\s*(\d*)/i) {
839
840 my $limit = $1 || meta( $nick, $channel, 'last-size' ) || 10;
841
842 foreach my $res (get_from_log( limit => $limit )) {
843 _log "last: $res";
844 $kernel->post( $irc => privmsg => $nick, $res );
845 }
846
847 $res = '';
848
849 } elsif ($msg =~ m/^(search|grep)\s+(.*)\s*$/i) {
850
851 my $what = $2;
852
853 foreach my $res (get_from_log(
854 limit => 20,
855 search => $what,
856 )) {
857 _log "search [$what]: $res";
858 $kernel->post( $irc => privmsg => $nick, $res );
859 }
860
861 $res = '';
862
863 } elsif ($msg =~ m/^(?:count|poll)\s+(.*)(?:\s+(\d+))?\s*$/i) {
864
865 my ($what,$limit) = ($1,$2);
866 $limit ||= 100;
867
868 my $stat;
869
870 foreach my $res (get_from_log(
871 limit => $limit,
872 search => $what,
873 full_rows => 1,
874 )) {
875 while ($res->{message} =~ s/\Q$what\E(\+|\-)//) {
876 $stat->{vote}->{$1}++;
877 $stat->{from}->{ $res->{nick} }++;
878 }
879 }
880
881 my @nicks;
882 foreach my $nick (sort { $stat->{from}->{$a} <=> $stat->{from}->{$b} } keys %{ $stat->{from} }) {
883 push @nicks, $nick . ( $stat->{from}->{$nick} == 1 ? '' :
884 "(" . $stat->{from}->{$nick} . ")"
885 );
886 }
887
888 $res =
889 "$what ++ " . ( $stat->{vote}->{'+'} || 0 ) .
890 " : " . ( $stat->{vote}->{'-'} || 0 ) . " --" .
891 " from " . ( join(", ", @nicks) || 'nobody' );
892
893 $kernel->post( $irc => notice => $nick, $res );
894
895 } elsif ($msg =~ m/^ping/) {
896 $res = "ping = " . dump( $_stat->{ping} );
897 } elsif ($msg =~ m/^conf(?:ig)*\s*(last-size|twitter)*\s*(.*)/) {
898 if ( ! defined( $1 ) ) {
899 my $sth = $dbh->prepare(qq{ select name,value,changed from meta where nick = ? and channel = ? });
900 $sth->execute( $nick, $channel );
901 $res = "config for $nick on $channel";
902 while ( my ($n,$v) = $sth->fetchrow_array ) {
903 $res .= " | $n = $v";
904 }
905 } elsif ( ! $2 ) {
906 my $val = meta( $nick, $channel, $1 );
907 $res = "current $1 = " . ( $val ? $val : 'undefined' );
908 } else {
909 my $validate = {
910 'last-size' => qr/^\d+/,
911 'twitter' => qr/^\w+\s+\w+/,
912 };
913
914 my ( $op, $val ) = ( $1, $2 );
915
916 if ( my $regex = $validate->{$op} ) {
917 if ( $val =~ $regex ) {
918 meta( $nick, $channel, $op, $val );
919 $res = "saved $op = $val";
920 } else {
921 $res = "config option $op = $val doesn't validate against $regex";
922 }
923 } else {
924 $res = "config option $op doesn't exist";
925 }
926 }
927 } elsif ($msg =~ m/^rss-update/) {
928 $res = rss_fetch_all( $kernel );
929 } elsif ($msg =~ m/^rss-list/) {
930 my $sth = $dbh->prepare(qq{ select url,name,last_update,active,channel,nick,private from feeds });
931 $sth->execute;
932 while (my @row = $sth->fetchrow_array) {
933 $kernel->post( $irc => privmsg => $nick, join(' | ',@row) );
934 }
935 $res = '';
936 } elsif ($msg =~ m!^rss-(add|remove|stop|start|clean)(?:-(private))?\s+(http://\S+)\s*(.*)!) {
937 my ( $command, $sub, $url, $arg ) = ( $1,$2,$3,$4 );
938
939 my $channel = $1 if ( $arg =~ s/\s*(#\S+)\s*// );
940 $channel = $nick if $sub eq 'private';
941
942 my $sql = {
943 add => qq{ insert into feeds (url,name,channel,nick,private) values (?,?,?,?,?) },
944 remove => qq{ delete from feeds where url = ? and nick = ? },
945 start => qq{ update feeds set active = true where url = ? },
946 stop => qq{ update feeds set active = false where url = ? },
947 clean => qq{ update feeds set last_update = now() - delay where url = ? },
948 };
949
950 if ( $command eq 'add' && ! $channel ) {
951 $res = "ERROR: got '$msg' which doesn't have #channel in it, ignoring!";
952 } elsif (my $q = $sql->{$command} ) {
953 my $sth = $dbh->prepare( $q );
954 my @data = ( $url );
955 if ( $command eq 'add' ) {
956 push @data, ( $arg, $channel, $nick, $sub eq 'private' ? 1 : 0 );
957 } elsif ( $command eq 'remove' ) {
958 push @data, $nick;
959 }
960 warn "## $command SQL $q with ",dump( @data ),"\n";
961 eval { $sth->execute( @data ) };
962 if ($@) {
963 $res = "ERROR: $@";
964 } else {
965 $res = "OK, RSS executed $command" .
966 ( $sub ? "-$sub " : ' ' ) .
967 ( $channel ? "on $channel " : '' ) .
968 "url $url";
969 if ( $command eq 'clean' ) {
970 my $seen = $_stat->{rss}->{seen} || die "no seen?";
971 my $want_link = $_stat->{rss}->{url2link}->{$url} || warn "no url2link($url)";
972 foreach my $c ( keys %$seen ) {
973 my $c_hash = $seen->{$c} || die "no seen->{$c}";
974 die "not HASH with rss links but ", dump($c_hash) unless ref($c_hash) eq 'HASH';
975 foreach my $link ( keys %$c_hash ) {
976 next unless $link eq $want_link;
977 _log "RSS removed seen $c $url $link";
978 }
979 }
980 } elsif ( $command eq 'add' ) {
981 rss_fetch_all( $kernel );
982 }
983 }
984 } else {
985 $res = "ERROR: don't know what to do with: $msg";
986 }
987 } elsif ($msg =~ m/^rss-clean/) {
988 # this makes sense because we didn't catch rss-clean http://... before!
989 $_stat->{rss} = undef;
990 $dbh->do( qq{ update feeds set last_update = now() - delay } );
991 $res = rss_fetch_all( $kernel );
992 }
993
994 return $res;
995 }
996
997 POE::Session->create( inline_states => {
998 _start => sub {
999 $_[KERNEL]->post( $irc => register => 'all' );
1000 $_[KERNEL]->post( $irc => connect => {} );
1001 },
1002 irc_001 => sub {
1003 my ($kernel,$sender) = @_[KERNEL,SENDER];
1004 my $poco_object = $sender->get_heap();
1005 _log "connected to",$poco_object->server_name();
1006 $kernel->post( $sender => join => $_ ) for @channels;
1007 # seen RSS cache, so don't send out messages
1008 _log rss_fetch_all( $kernel, 0 );
1009 undef;
1010 },
1011 # irc_255 => sub { # server is done blabbing
1012 # $_[KERNEL]->post( $irc => join => $CHANNEL);
1013 # },
1014 irc_public => sub {
1015 my $kernel = $_[KERNEL];
1016 my $nick = (split /!/, $_[ARG0])[0];
1017 my $channel = $_[ARG1]->[0];
1018 my $msg = $_[ARG2];
1019
1020 save_message( channel => $channel, me => 0, nick => $nick, message => $msg);
1021 meta( $nick, $channel, 'last-msg', $msg );
1022 rss_check_updates( $kernel );
1023 },
1024 irc_ctcp_action => sub {
1025 my $kernel = $_[KERNEL];
1026 my $nick = (split /!/, $_[ARG0])[0];
1027 my $channel = $_[ARG1]->[0];
1028 my $msg = $_[ARG2];
1029
1030 save_message( channel => $channel, me => 1, nick => $nick, message => $msg);
1031
1032 if ( $use_twitter ) {
1033 if ( my $twitter = meta( $nick, $NICK, 'twitter' ) ) {
1034 my ($login,$passwd) = split(/\s+/,$twitter,2);
1035 _log("sending twitter for $nick/$login on $channel ");
1036 my $bot = Net::Twitter->new( username=>$login, password=>$passwd );
1037 $bot->update("<${channel}> $msg");
1038 }
1039 }
1040
1041 },
1042 irc_ping => sub {
1043 _log( "pong ", $_[ARG0] );
1044 $_stat->{ping}->{ $_[ARG0] }++;
1045 rss_check_updates( $_[KERNEL] );
1046 },
1047 irc_invite => sub {
1048 my $kernel = $_[KERNEL];
1049 my $nick = (split /!/, $_[ARG0])[0];
1050 my $channel = $_[ARG1];
1051
1052 _log "invited to $channel by $nick";
1053
1054 $_[KERNEL]->post( $irc => privmsg => $nick, "how nice of you to invite me to $channel, I'll be right there..." );
1055 $_[KERNEL]->post( $irc => 'join' => $channel );
1056
1057 },
1058 irc_msg => sub {
1059 my $kernel = $_[KERNEL];
1060 my $nick = (split /!/, $_[ARG0])[0];
1061 my $channel = $_[ARG1]->[0];
1062 my $msg = $_[ARG2];
1063 warn "# ARG = ",dump( @_[ARG0,ARG1,ARG2] ) if $debug;
1064
1065 _log "<< $msg";
1066
1067 my $res = process_command( $_[KERNEL], $nick, $channel, $msg );
1068
1069 if ($res) {
1070 _log ">> [$nick] $res";
1071 $_[KERNEL]->post( $irc => privmsg => $nick, $res );
1072 }
1073
1074 rss_check_updates( $_[KERNEL] );
1075 },
1076 irc_372 => sub {
1077 _log "<< motd",$_[ARG0],$_[ARG1];
1078 },
1079 irc_375 => sub {
1080 _log "<< motd", $_[ARG0], "start";
1081 },
1082 irc_376 => sub {
1083 _log "<< motd", $_[ARG0], "end";
1084 },
1085 # irc_433 => sub {
1086 # print "# irc_433: ",$_[ARG1], "\n";
1087 # warn "## indetify $NICK\n";
1088 # $_[KERNEL]->post( $irc => privmsg => 'nickserv', "IDENTIFY $NICK" );
1089 # },
1090 # irc_451 # please register
1091 irc_477 => sub {
1092 _log "<< irc_477: ",$_[ARG1];
1093 _log ">> IDENTIFY $NICK";
1094 $_[KERNEL]->post( $irc => privmsg => 'NickServ', "IDENTIFY $NICK" );
1095 },
1096 irc_505 => sub {
1097 _log "<< irc_505: ",$_[ARG1];
1098 _log ">> register $NICK";
1099 $_[KERNEL]->post( $irc => privmsg => 'NickServ', "register $NICK" );
1100 # $_[KERNEL]->post( $irc => privmsg => 'nickserv', "IDENTIFY $NICK" );
1101 # $_[KERNEL]->post( $irc => privmsg => 'nickserv', "set hide email on" );
1102 # $_[KERNEL]->post( $irc => privmsg => 'nickserv', "set email dpavlin\@rot13.org" );
1103 },
1104 irc_registered => sub {
1105 _log "<< registered $NICK";
1106 },
1107 irc_disconnected => sub {
1108 _log "## disconnected.. sleeping for $sleep_on_error seconds and reconnecting again";
1109 sleep($sleep_on_error);
1110 $_[KERNEL]->post( $irc => connect => {} );
1111 },
1112 irc_socketerr => sub {
1113 _log "## socket error... sleeping for $sleep_on_error seconds and retry";
1114 sleep($sleep_on_error);
1115 $_[KERNEL]->post( $irc => connect => {} );
1116 },
1117 irc_notice => sub {
1118 _log "<< notice from ", $_[ARG0], $_[ARG1], $_[ARG2];
1119 my $m = $_[ARG2];
1120 if ( $m =~ m!/msg.*(NickServ).*(IDENTIFY)!i ) {
1121 _log ">> suggested to $1 $2";
1122 $_[KERNEL]->post( $irc => privmsg => $1, "$2 $NICK" );
1123 } elsif ( $m =~ m!\Q$NICK\E.*registered!i ) {
1124 _log ">> registreted, so IDENTIFY";
1125 $_[KERNEL]->post( $irc => privmsg => 'nickserv', "IDENTIFY $NICK" );
1126 } else {
1127 warn "## ignore $m\n" if $debug;
1128 }
1129 },
1130 irc_snotice => sub {
1131 _log "<< snotice", $_[ARG0]; #dump( $_[ARG0],$_[ARG1], $_[ARG2] );
1132 if ( $_[ARG0] =~ m!/(QUOTE)\s+(PASS\s+\d+)!i ) {
1133 warn ">> $1 | $2\n";
1134 $_[KERNEL]->post( $irc => lc($1) => $2);
1135 }
1136 },
1137 _child => sub {},
1138 _default => sub {
1139 _log '_default SID:', $_[SESSION]->ID, $_[ARG0], dump( $_[ARG1] );
1140 0; # false for signals
1141 },
1142 rss_response => sub {
1143 my ($request_packet, $response_packet) = @_[ARG0, ARG1];
1144 my $request_object = $request_packet->[0];
1145 my $response_object = $response_packet->[0];
1146
1147 my $row = delete( $_stat->{rss}->{fetch}->{ $request_object->uri } );
1148 if ( $row ) {
1149 $row->{xml} = $response_object->content;
1150 rss_parse_xml( $_[KERNEL], $row );
1151 } else {
1152 warn "## can't find rss->fetch for ", $request_object->uri;
1153 }
1154 },
1155 },
1156 );
1157
1158 # http server
1159
1160 _log "WEB archive at $url";
1161
1162 my $httpd = POE::Component::Server::HTTP->new(
1163 Port => $http_port,
1164 PreHandler => {
1165 '/' => sub {
1166 $_[0]->header(Connection => 'close')
1167 }
1168 },
1169 ContentHandler => { '/' => \&root_handler },
1170 Headers => { Server => 'irc-logger' },
1171 );
1172
1173 my $style = <<'_END_OF_STYLE_';
1174 p { margin: 0; padding: 0.1em; }
1175 .time, .channel { color: #808080; font-size: 60%; }
1176 .date { float: right; background: #e0e0e0; color: #404040; font-size: 120%; padding: 0.25em; border: 1px dashed #808080; }
1177 .nick { color: #000000; font-size: 80%; padding: 2px; font-family: courier, courier new, monospace ; }
1178 .message { color: #000000; font-size: 100%; }
1179 .search { float: right; }
1180 a:link.tag, a:visited.tag { border: 1px dashed #ccc; backgound: #ccc; text-decoration: none }
1181 a:hover.tag { border: 1px solid #eee }
1182 hr { border: 1px dashed #ccc; height: 1px; clear: both; }
1183 /*
1184 .col-0 { background: #ffff66 }
1185 .col-1 { background: #a0ffff }
1186 .col-2 { background: #99ff99 }
1187 .col-3 { background: #ff9999 }
1188 .col-4 { background: #ff66ff }
1189 */
1190 .calendar { border: 1px solid red; width: 100%; }
1191 .month { border: 0px; width: 100%; }
1192 _END_OF_STYLE_
1193
1194 $max_color = 0;
1195
1196 my @cols = qw(
1197 #ffcccc #ccffe6 #ccccff #e6ccff #ffccff #ffcce6 #ff9999 #ffcc99 #ffff99
1198 #ccff99 #99ff99 #99ffcc #99ccff #9999ff #cc99ff #ff6666 #ffb366 #ffff66
1199 #66ff66 #66ffb3 #66b3ff #6666ff #ff3333 #33ff33 #3399ff #3333ff #ff3399
1200 #a0a0a0 #ff0000 #ffff00 #80ff00 #0000ff #8000ff #ff00ff #ff0080 #994d00
1201 #999900 #009900 #cc0066 #c0c0c0 #ccff99 #99ff33 #808080 #660033 #ffffff
1202 );
1203
1204 foreach my $c (@cols) {
1205 $style .= ".col-${max_color} { background: $c }\n";
1206 $max_color++;
1207 }
1208 _log "WEB defined $max_color colors for users...";
1209
1210 sub root_handler {
1211 my ($request, $response) = @_;
1212 $response->code(RC_OK);
1213
1214 # this doesn't seem to work, so moved to PreHandler
1215 #$response->header(Connection => 'close');
1216
1217 return RC_OK if $request->uri =~ m/favicon.ico$/;
1218
1219 my $q;
1220
1221 if ( $request->method eq 'POST' ) {
1222 $q = new CGI::Simple( $request->content );
1223 } elsif ( $request->uri =~ /\?(.+)$/ ) {
1224 $q = new CGI::Simple( $1 );
1225 } else {
1226 $q = new CGI::Simple;
1227 }
1228
1229 my $search = $q->param('search') || $q->param('grep') || '';
1230 my $r_url = $request->url;
1231
1232 my @commands = qw( tags last-tag follow stat );
1233 my $commands_re = join('|',@commands);
1234
1235 if ($r_url =~ m#/rss(?:/($commands_re.*)\w*(?:=(\d+))?)?#i) {
1236 my $show = lc($1);
1237 my $nr = $2;
1238
1239 my $type = 'RSS'; # Atom
1240
1241 $response->content_type( 'application/' . lc($type) . '+xml' );
1242
1243 my $html = '<!-- error -->';
1244 #warn "create $type feed from ",dump( @last_tags );
1245
1246 my $feed = XML::Feed->new( $type );
1247 $feed->link( $url );
1248
1249 my $rc = RC_OK;
1250
1251 if ( $show eq 'tags' ) {
1252 $nr ||= 50;
1253 $feed->title( "tags from $CHANNEL" );
1254 $feed->link( "$url/tags" );
1255 $feed->description( "tag cloud created from messages on channel $CHANNEL which have tags// in them" );
1256 my $feed_entry = XML::Feed::Entry->new($type);
1257 $feed_entry->title( "$nr tags from $CHANNEL" );
1258 $feed_entry->author( $NICK );
1259 $feed_entry->link( '/#tags' );
1260
1261 $feed_entry->content(
1262 qq{<![CDATA[<style type="text/css">}
1263 . $cloud->css
1264 . qq{</style>}
1265 . $cloud->html( $nr )
1266 . qq{]]>}
1267 );
1268 $feed->add_entry( $feed_entry );
1269
1270 } elsif ( $show eq 'last-tag' ) {
1271
1272 $nr ||= $last_x_tags;
1273 $nr = $last_x_tags if $nr > $last_x_tags;
1274
1275 $feed->title( "last $nr tagged messages from $CHANNEL" );
1276 $feed->description( "collects messages which have tags// in them" );
1277
1278 foreach my $m ( @last_tags ) {
1279 # warn dump( $m );
1280 #my $tags = join(' ', @{$m->{tags}} );
1281 my $feed_entry = XML::Feed::Entry->new($type);
1282 $feed_entry->title( $m->{nick} . '@' . $m->{time} );
1283 $feed_entry->author( $m->{nick} );
1284 $feed_entry->link( '/#' . $m->{id} );
1285 $feed_entry->issued( DateTime::Format::Flexible->build( $m->{time} ) );
1286
1287 my $message = $filter->{message}->( $m->{message} );
1288 $message .= "<br/>\n" unless $message =~ m!<(/p|br/?)>!;
1289 # warn "## message = $message\n";
1290
1291 #$feed_entry->summary(
1292 $feed_entry->content(
1293 "<![CDATA[$message]]>"
1294 );
1295 $feed_entry->category( join(', ', @{$m->{tags}}) );
1296 $feed->add_entry( $feed_entry );
1297
1298 $nr--;
1299 last if $nr <= 0;
1300
1301 }
1302
1303 } elsif ( $show =~ m/^follow/ ) {
1304
1305 $feed->title( "Feeds which this bot follows" );
1306
1307 my $sth = $dbh->prepare( qq{ select * from feeds order by last_update desc } );
1308 $sth->execute;
1309 while (my $row = $sth->fetchrow_hashref) {
1310 my $feed_entry = XML::Feed::Entry->new($type);
1311 $feed_entry->title( $row->{name} );
1312 $feed_entry->link( $row->{url} );
1313 $feed_entry->issued( DateTime::Format::Flexible->build( $row->{last_update} ) );
1314 $feed_entry->content(
1315 '<![CDATA[<pre>' . dump( $row ) . '</pre>]]>'
1316 );
1317 $feed->add_entry( $feed_entry );
1318 }
1319
1320 } elsif ( $show =~ m/^stat/ ) {
1321
1322 my $feed_entry = XML::Feed::Entry->new($type);
1323 $feed_entry->title( "Internal stats" );
1324 $feed_entry->content(
1325 '<![CDATA[<pre>' . dump( $_stat ) . '</pre>]]>'
1326 );
1327 $feed->add_entry( $feed_entry );
1328
1329 } else {
1330 _log "WEB unknown rss request $r_url";
1331 $feed->title( "unknown $r_url" );
1332 foreach my $c ( @commands ) {
1333 my $feed_entry = XML::Feed::Entry->new($type);
1334 $feed_entry->title( "rss/$c" );
1335 $feed_entry->link( "$url/rss/$c" );
1336 $feed->add_entry( $feed_entry );
1337 }
1338 $rc = RC_DENY;
1339 }
1340
1341 $response->content( $feed->as_xml );
1342 return $rc;
1343 }
1344
1345 if ( $@ ) {
1346 warn "$@";
1347 }
1348
1349 $response->content_type("text/html; charset=UTF-8");
1350
1351 my $html =
1352 qq{<html><head><title>$NICK</title><style type="text/css">$style}
1353 . $cloud->css
1354 . qq{</style></head><body>}
1355 . qq{
1356 <form method="post" class="search" action="/">
1357 <input type="text" name="search" value="$search" size="10">
1358 <input type="submit" value="search">
1359 </form>
1360 }
1361 . $cloud->html(500)
1362 . qq{<p>};
1363
1364 if ($request->url =~ m#/tags?#) {
1365 # nop
1366 } elsif ($request->url =~ m#/history#) {
1367 my $sth = $dbh->prepare(qq{
1368 select date(time) as date,count(*) as nr,sum(length(message)) as len
1369 from log
1370 group by date(time)
1371 order by date(time) desc
1372 });
1373 $sth->execute();
1374 my ($l_yyyy,$l_mm) = (0,0);
1375 $html .= qq{<table class="calendar"><tr>};
1376 my $cal;
1377 my $ord = 0;
1378 while (my $row = $sth->fetchrow_hashref) {
1379 # this is probably PostgreSQL specific, expects ISO date
1380 my ($yyyy,$mm,$dd) = split(/-/, $row->{date});
1381 if ($yyyy != $l_yyyy || $mm != $l_mm) {
1382 if ( $cal ) {
1383 $html .= qq{<td valign="top">} . $cal->as_HTML() . qq{</td>};
1384 $ord++;
1385 $html .= qq{</tr><tr>} if ( $ord % 3 == 0 );
1386 }
1387 $cal = new HTML::CalendarMonthSimple('month'=>$mm,'year'=>$yyyy);
1388 $cal->border(1);
1389 $cal->width('30%');
1390 $cal->cellheight('5em');
1391 $cal->tableclass('month');
1392 #$cal->cellclass('day');
1393 $cal->sunday('SUN');
1394 $cal->saturday('SAT');
1395 $cal->weekdays('MON','TUE','WED','THU','FRI');
1396 ($l_yyyy,$l_mm) = ($yyyy,$mm);
1397 }
1398 $cal->setcontent($dd, qq[
1399 <a href="$url?date=$row->{date}">$row->{nr}</a><br/>$row->{len}
1400 ]) if $cal;
1401
1402 }
1403 $html .= qq{<td valign="top">} . $cal->as_HTML() . qq{</td></tr></table>};
1404
1405 } else {
1406 $html .= join("</p><p>",
1407 get_from_log(
1408 limit => ( $q->param('last') || $q->param('date') ) ? undef : 100,
1409 search => $search || undef,
1410 tag => $q->param('tag') || undef,
1411 date => $q->param('date') || undef,
1412 fmt => {
1413 date => sub {
1414 my $date = shift || return;
1415 qq{<hr/><div class="date"><a href="$url?date=$date">$date</a></div>};
1416 },
1417 time => '<span class="time">%s</span> ',
1418 time_channel => '<span class="channel">%s %s</span> ',
1419 nick => '%s:&nbsp;',
1420 me_nick => '***%s&nbsp;',
1421 message => '<span class="message">%s</span>',
1422 },
1423 filter => $filter,
1424 )
1425 );
1426 }
1427
1428 $html .= qq{</p>
1429 <hr/>
1430 <p>See <a href="/history">history</a> of all messages.</p>
1431 </body></html>};
1432
1433 $response->content( decode('utf-8',$html) );
1434 warn "<< ", $request->method, " ", $request->uri, " created ", length($html), " bytes\n";
1435 return RC_OK;
1436 }
1437
1438 POE::Kernel->run;

Properties

Name Value
svn:executable *

  ViewVC Help
Powered by ViewVC 1.1.26