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

Properties

Name Value
svn:executable *

  ViewVC Help
Powered by ViewVC 1.1.26