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

Properties

Name Value
svn:executable *

  ViewVC Help
Powered by ViewVC 1.1.26