/[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 41 - (show annotations)
Tue Oct 24 12:51:49 2006 UTC (17 years, 5 months ago) by dpavlin
Original Path: trunk/irc-logger.pl
File MIME type: text/plain
File size: 18845 byte(s)
sleep and reconnect on socket errors
1 #!/usr/bin/perl -w
2 use strict;
3 $|++;
4
5 =head1 NAME
6
7 irc-logger.pl
8
9 =head1 SYNOPSIS
10
11 ./irc-logger.pl
12
13 =head2 Options
14
15 =over 4
16
17 =item --import-dircproxy=filename
18
19 Import log from C<dircproxy> to C<irc-logger> database
20
21 =head1 DESCRIPTION
22
23 log all conversation on irc channel
24
25 =cut
26
27 ## CONFIG
28
29 my $HOSTNAME = `hostname`;
30
31 my $NICK = 'irc-logger';
32 $NICK .= '-dev' if ($HOSTNAME =~ m/llin/);
33 my $CONNECT =
34 {Server => 'irc.freenode.net',
35 Nick => $NICK,
36 Ircname => "try /msg $NICK help",
37 };
38 my $CHANNEL = '#razmjenavjestina';
39 $CHANNEL = '#irc-logger' if ($HOSTNAME =~ m/llin/);
40 my $IRC_ALIAS = "log";
41
42 my %FOLLOWS =
43 (
44 ACCESS => "/var/log/apache/access.log",
45 ERROR => "/var/log/apache/error.log",
46 );
47
48 my $DSN = 'DBI:Pg:dbname=' . $NICK;
49
50 my $ENCODING = 'ISO-8859-2';
51 my $TIMESTAMP = '%Y-%m-%d %H:%M:%S';
52
53 my $sleep_on_error = 5;
54
55 ## END CONFIG
56
57
58
59 use POE qw(Component::IRC Wheel::FollowTail Component::Server::HTTP);
60 use HTTP::Status;
61 use DBI;
62 use Encode qw/from_to is_utf8/;
63 use Regexp::Common qw /URI/;
64 use CGI::Simple;
65 use HTML::TagCloud;
66 use POSIX qw/strftime/;
67 use HTML::CalendarMonthSimple;
68 use Getopt::Long;
69 use DateTime;
70
71 my $import_dircproxy;
72 GetOptions(
73 'import-dircproxy:s' => \$import_dircproxy,
74 );
75
76 my $dbh = DBI->connect($DSN,"","", { RaiseError => 1, AutoCommit => 1 }) || die $DBI::errstr;
77
78 eval {
79 $dbh->do(qq{ select count(*) from log });
80 };
81
82 if ($@) {
83 warn "creating database table in $DSN\n";
84 $dbh->do(<<'_SQL_SCHEMA_');
85
86 create table log (
87 id serial,
88 time timestamp default now(),
89 channel text not null,
90 me boolean default false,
91 nick text not null,
92 message text not null,
93 primary key(id)
94 );
95
96 create index log_time on log(time);
97 create index log_channel on log(channel);
98 create index log_nick on log(nick);
99
100 _SQL_SCHEMA_
101 }
102
103 my $sth = $dbh->prepare(qq{
104 insert into log
105 (channel, me, nick, message, time)
106 values (?,?,?,?,?)
107 });
108
109 my $tags;
110 my $tag_regex = '\b([\w-_]+)//';
111
112 =head2 get_from_log
113
114 my @messages = get_from_log(
115 limit => 42,
116 search => '%what to stuff in ilike%',
117 fmt => {
118 time => '{%s} ',
119 time_channel => '{%s %s} ',
120 nick => '%s: ',
121 me_nick => '***%s ',
122 message => '%s',
123 },
124 filter => {
125 message => sub {
126 # modify message content
127 return shift;
128 }
129 },
130 context => 5,
131 );
132
133 Order is important. Fields are first passed through C<filter> (if available) and
134 then throgh C<< sprintf($fmt->{message}, $message >> if available.
135
136 C<context> defines number of messages around each search hit for display.
137
138 =cut
139
140 sub get_from_log {
141 my $args = {@_};
142
143 $args->{fmt} ||= {
144 date => '[%s] ',
145 time => '{%s} ',
146 time_channel => '{%s %s} ',
147 nick => '%s: ',
148 me_nick => '***%s ',
149 message => '%s',
150 };
151
152 my $sql_message = qq{
153 select
154 time::date as date,
155 time::time as time,
156 channel,
157 me,
158 nick,
159 message
160 from log
161 };
162
163 my $sql_context = qq{
164 select
165 id
166 from log
167 };
168
169 my $context = $1 if ($args->{search} && $args->{search} =~ s/\s*\+(\d+)\s*/ /);
170
171 my $sql = $context ? $sql_context : $sql_message;
172
173 $sql .= " where message ilike ? or nick ilike ? " if ($args->{search});
174 $sql .= " where id in (" . join(",", @{ $tags->{ $args->{tag} } }) . ") " if ($args->{tag} && $tags->{ $args->{tag} });
175 $sql .= " where date(time) = ? " if ($args->{date});
176 $sql .= " order by log.time desc";
177 $sql .= " limit " . $args->{limit} if ($args->{limit});
178
179 my $sth = $dbh->prepare( $sql );
180 if (my $search = $args->{search}) {
181 $search =~ s/^\s+//;
182 $search =~ s/\s+$//;
183 $sth->execute( ( '%' . $search . '%' ) x 2 );
184 warn "search for '$search' returned ", $sth->rows, " results ", $context || '', "\n";
185 } elsif (my $tag = $args->{tag}) {
186 $sth->execute();
187 warn "tag '$tag' returned ", $sth->rows, " results ", $context || '', "\n";
188 } elsif (my $date = $args->{date}) {
189 $sth->execute($date);
190 warn "found ", $sth->rows, " messages for date $date ", $context || '', "\n";
191 } else {
192 $sth->execute();
193 }
194 my $last_row = {
195 date => '',
196 time => '',
197 channel => '',
198 nick => '',
199 };
200
201 my @rows;
202
203 while (my $row = $sth->fetchrow_hashref) {
204 unshift @rows, $row;
205 }
206
207 my @msgs = (
208 "Showing " . ($#rows + 1) . " messages..."
209 );
210
211 if ($context) {
212 my @ids = @rows;
213 @rows = ();
214
215 my $last_to = 0;
216
217 my $sth = $dbh->prepare( $sql_message . qq{ where id >= ? and id < ? } );
218 foreach my $row_id (sort { $a->{id} <=> $b->{id} } @ids) {
219 my $id = $row_id->{id} || die "can't find id in row";
220
221 my ($from, $to) = ($id - $context, $id + $context);
222 $from = $last_to if ($from < $last_to);
223 $last_to = $to;
224 $sth->execute( $from, $to );
225
226 #warn "## id: $id from: $from to: $to returned: ", $sth->rows, "\n";
227
228 while (my $row = $sth->fetchrow_hashref) {
229 push @rows, $row;
230 }
231
232 }
233 }
234
235 # sprintf which can take coderef as first parametar
236 sub cr_sprintf {
237 my $fmt = shift || return;
238 if (ref($fmt) eq 'CODE') {
239 $fmt->(@_);
240 } else {
241 sprintf($fmt, @_);
242 }
243 }
244
245 foreach my $row (@rows) {
246
247 $row->{time} =~ s#\.\d+##;
248
249 my $msg = '';
250
251 $msg = cr_sprintf($args->{fmt}->{date}, $row->{date}) . ' ' if ($last_row->{date} ne $row->{date});
252 my $t = $row->{time};
253
254 if ($last_row->{channel} ne $row->{channel}) {
255 $msg .= cr_sprintf($args->{fmt}->{time_channel}, $t, $row->{channel});
256 } else {
257 $msg .= cr_sprintf($args->{fmt}->{time}, $t);
258 }
259
260 my $append = 1;
261
262 my $nick = $row->{nick};
263 if ($nick =~ s/^_*(.*?)_*$/$1/) {
264 $row->{nick} = $nick;
265 }
266
267 if ($last_row->{nick} ne $nick) {
268 # obfu way to find format for me_nick if needed or fallback to default
269 my $fmt = $row->{me} ? ( $args->{fmt}->{me_nick} || $args->{fmt}->{nick} ) : $args->{fmt}->{nick};
270 $fmt ||= '%s';
271
272 $nick = $args->{filter}->{nick}->($nick) if (ref($args->{filter}->{nick}) eq 'CODE');
273
274 $msg .= cr_sprintf( $fmt, $nick );
275 $append = 0;
276 }
277
278 $args->{fmt}->{message} ||= '%s';
279 if (ref($args->{filter}->{message}) eq 'CODE') {
280 $msg .= cr_sprintf($args->{fmt}->{message},
281 $args->{filter}->{message}->(
282 $row->{message}
283 )
284 );
285 } else {
286 $msg .= cr_sprintf($args->{fmt}->{message}, $row->{message});
287 }
288
289 if ($append && @msgs) {
290 $msgs[$#msgs] .= " " . $msg;
291 } else {
292 push @msgs, $msg;
293 }
294
295 $last_row = $row;
296 }
297
298 return @msgs;
299 }
300
301 # tags support
302
303 my $cloud = HTML::TagCloud->new;
304
305 =head2 add_tag
306
307 add_tag( id => 42, message => 'irc message' );
308
309 =cut
310
311 sub add_tag {
312 my $arg = {@_};
313
314 return unless ($arg->{id} && $arg->{message});
315
316 my $m = $arg->{message};
317 from_to('UTF-8', 'iso-8859-2', $m) if (is_utf8($m));
318
319 while ($m =~ s#$tag_regex##s) {
320 my $tag = $1;
321 next if (! $tag || $tag =~ m/https?:/i);
322 push @{ $tags->{$tag} }, $arg->{id};
323 #warn "+tag $tag: $arg->{id}\n";
324 $cloud->add($tag, "?tag=$tag", scalar @{$tags->{$tag}} + 1);
325 }
326 }
327
328 =head2 seed_tags
329
330 Read all tags from database and create in-memory cache for tags
331
332 =cut
333
334 sub seed_tags {
335 my $sth = $dbh->prepare(qq{ select id,message from log where message like '%//%' });
336 $sth->execute;
337 while (my $row = $sth->fetchrow_hashref) {
338 add_tag( %$row );
339 }
340
341 foreach my $tag (keys %$tags) {
342 $cloud->add($tag, "?tag=$tag", scalar @{$tags->{$tag}} + 1);
343 }
344 }
345
346 seed_tags;
347
348
349 =head2 save_message
350
351 save_message(
352 channel => '#foobar',
353 me => 0,
354 nick => 'dpavlin',
355 msg => 'test message',
356 time => '2006-06-25 18:57:18',
357 );
358
359 C<time> is optional, it will use C<< now() >> if it's not available.
360
361 C<me> if not specified will be C<0> (not C</me> message)
362
363 =cut
364
365 sub save_message {
366 my $a = {@_};
367 $a->{me} ||= 0;
368 $a->{time} ||= strftime($TIMESTAMP,localtime());
369
370 print
371 $a->{time}, " ",
372 $a->{channel}, " ",
373 $a->{me} ? "***" . $a->{nick} : "<" . $a->{nick} . ">",
374 " " . $a->{msg} . "\n";
375
376 from_to($a->{msg}, 'UTF-8', $ENCODING);
377
378 $sth->execute($a->{channel}, $a->{me}, $a->{nick}, $a->{msg}, $a->{time});
379 add_tag( id => $dbh->last_insert_id(undef,undef,"log",undef),
380 message => $a->{msg});
381 }
382
383 if ($import_dircproxy) {
384 open(my $l, $import_dircproxy) || die "can't open $import_dircproxy: $!";
385 warn "importing $import_dircproxy...\n";
386 my $tz_offset = 2 * 60 * 60; # TZ GMT+2
387 while(<$l>) {
388 chomp;
389 if (/^@(\d+)\s(\S+)\s(.+)$/) {
390 my ($time, $nick, $msg) = ($1,$2,$3);
391
392 my $dt = DateTime->from_epoch( epoch => $time + $tz_offset );
393
394 my $me = 0;
395 $me = 1 if ($nick =~ m/^\[\S+]/);
396 $nick =~ s/^[\[<]([^!]+).*$/$1/;
397
398 $msg =~ s/^ACTION\s+// if ($me);
399
400 save_message(
401 channel => $CHANNEL,
402 me => $me,
403 nick => $nick,
404 msg => $msg,
405 time => $dt->ymd . " " . $dt->hms,
406 ) if ($nick !~ m/^-/);
407
408 } else {
409 warn "can't parse: $_\n";
410 }
411 }
412 close($l);
413 warn "import over\n";
414 exit;
415 }
416
417
418 #
419 # POE handing part
420 #
421
422 my $SKIPPING = 0; # if skipping, how many we've done
423 my $SEND_QUEUE; # cache
424
425 POE::Component::IRC->new($IRC_ALIAS);
426
427 POE::Session->create( inline_states =>
428 {_start => sub {
429 $_[KERNEL]->post($IRC_ALIAS => register => 'all');
430 $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);
431 },
432 irc_255 => sub { # server is done blabbing
433 $_[KERNEL]->post($IRC_ALIAS => join => $CHANNEL);
434 $_[KERNEL]->post($IRC_ALIAS => join => '#logger');
435 $_[KERNEL]->yield("heartbeat"); # start heartbeat
436 # $_[KERNEL]->yield("my_add", $_) for keys %FOLLOWS;
437 $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );
438 },
439 irc_public => sub {
440 my $kernel = $_[KERNEL];
441 my $nick = (split /!/, $_[ARG0])[0];
442 my $channel = $_[ARG1]->[0];
443 my $msg = $_[ARG2];
444
445 save_message( channel => $channel, me => 0, nick => $nick, msg => $msg);
446 },
447 irc_ctcp_action => sub {
448 my $kernel = $_[KERNEL];
449 my $nick = (split /!/, $_[ARG0])[0];
450 my $channel = $_[ARG1]->[0];
451 my $msg = $_[ARG2];
452
453 save_message( channel => $channel, me => 1, nick => $nick, msg => $msg);
454 },
455 irc_msg => sub {
456 my $kernel = $_[KERNEL];
457 my $nick = (split /!/, $_[ARG0])[0];
458 my $msg = $_[ARG2];
459 from_to($msg, 'UTF-8', $ENCODING);
460
461 my $res = "unknown command '$msg', try /msg $NICK help!";
462 my @out;
463
464 print "<< $msg\n";
465
466 if ($msg =~ m/^help/i) {
467
468 $res = "usage: /msg $NICK comand | commands: stat - user/message stat | last - show backtrace | grep foobar - find foobar";
469
470 } elsif ($msg =~ m/^msg\s+(\S+)\s+(.*)$/i) {
471
472 print ">> /msg $1 $2\n";
473 $_[KERNEL]->post( $IRC_ALIAS => privmsg => $1, $2 );
474 $res = '';
475
476 } elsif ($msg =~ m/^stat.*?\s*(\d*)/i) {
477
478 my $nr = $1 || 10;
479
480 my $sth = $dbh->prepare(qq{
481 select
482 nick,
483 count(*) as count,
484 sum(length(message)) as len
485 from log
486 group by nick
487 order by len desc,count desc
488 limit $nr
489 });
490 $sth->execute();
491 $res = "Top $nr users: ";
492 my @users;
493 while (my $row = $sth->fetchrow_hashref) {
494 push @users,$row->{nick} . ': ' . $row->{count} . '/' . $row->{len} . '=' . sprintf("%.2f", $row->{len}/$row->{count});
495 }
496 $res .= join(" | ", @users);
497 } elsif ($msg =~ m/^last.*?\s*(\d*)/i) {
498
499 foreach my $res (get_from_log( limit => ($1 || 100) )) {
500 print "last: $res\n";
501 from_to($res, $ENCODING, 'UTF-8');
502 $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );
503 }
504
505 $res = '';
506
507 } elsif ($msg =~ m/^(search|grep)\s+(.*)\s*$/i) {
508
509 my $what = $2;
510
511 foreach my $res (get_from_log(
512 limit => 20,
513 search => $what,
514 )) {
515 print "search [$what]: $res\n";
516 from_to($res, $ENCODING, 'UTF-8');
517 $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );
518 }
519
520 $res = '';
521
522 }
523
524 if ($res) {
525 print ">> [$nick] $res\n";
526 from_to($res, $ENCODING, 'UTF-8');
527 $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );
528 }
529
530 },
531 irc_477 => sub {
532 print "# irc_477: ",$_[ARG1], "\n";
533 $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "register $NICK" );
534 },
535 irc_505 => sub {
536 print "# irc_505: ",$_[ARG1], "\n";
537 $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "register $NICK" );
538 # $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "set hide email on" );
539 # $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "set email dpavlin\@rot13.org" );
540 },
541 irc_registered => sub {
542 warn "## indetify $NICK\n";
543 $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );
544 },
545 irc_disconnected => sub {
546 warn "## disconnected, reconnecting again\n";
547 $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);
548 },
549 irc_socketerr => sub {
550 warn "## socket error... sleeping for $sleep_on_error seconds and retry";
551 sleep($sleep_on_error);
552 $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);
553 },
554 # irc_433 => sub {
555 # print "# irc_433: ",$_[ARG1], "\n";
556 # warn "## indetify $NICK\n";
557 # $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );
558 # },
559 _child => sub {},
560 _default => sub {
561 printf "%s #%s %s %s\n",
562 strftime($TIMESTAMP,localtime()), $_[SESSION]->ID, $_[ARG0],
563 ref($_[ARG1]) eq "ARRAY" ? join(",", map { ref($_) eq "ARRAY" ? join(";", @{$_}) : $_ } @{ $_[ARG1] }) :
564 $_[ARG1] ? $_[ARG1] :
565 "";
566 0; # false for signals
567 },
568 my_add => sub {
569 my $trailing = $_[ARG0];
570 my $session = $_[SESSION];
571 POE::Session->create
572 (inline_states =>
573 {_start => sub {
574 $_[HEAP]->{wheel} =
575 POE::Wheel::FollowTail->new
576 (
577 Filename => $FOLLOWS{$trailing},
578 InputEvent => 'got_line',
579 );
580 },
581 got_line => sub {
582 $_[KERNEL]->post($session => my_tailed =>
583 time, $trailing, $_[ARG0]);
584 },
585 },
586 );
587
588 },
589 my_tailed => sub {
590 my ($time, $file, $line) = @_[ARG0..ARG2];
591 ## $time will be undef on a probe, or a time value if a real line
592
593 ## PoCo::IRC has throttling built in, but no external visibility
594 ## so this is reaching "under the hood"
595 $SEND_QUEUE ||=
596 $_[KERNEL]->alias_resolve($IRC_ALIAS)->get_heap->{send_queue};
597
598 ## handle "no need to keep skipping" transition
599 if ($SKIPPING and @$SEND_QUEUE < 1) {
600 $_[KERNEL]->post($IRC_ALIAS => privmsg => $CHANNEL =>
601 "[discarded $SKIPPING messages]");
602 $SKIPPING = 0;
603 }
604
605 ## handle potential message display
606 if ($time) {
607 if ($SKIPPING or @$SEND_QUEUE > 3) { # 3 msgs per 10 seconds
608 $SKIPPING++;
609 } else {
610 my @time = localtime $time;
611 $_[KERNEL]->post($IRC_ALIAS => privmsg => $CHANNEL =>
612 sprintf "%02d:%02d:%02d: %s: %s",
613 ($time[2] + 11) % 12 + 1, $time[1], $time[0],
614 $file, $line);
615 }
616 }
617
618 ## handle re-probe/flush if skipping
619 if ($SKIPPING) {
620 $_[KERNEL]->delay($_[STATE] => 0.5); # $time will be undef
621 }
622
623 },
624 my_heartbeat => sub {
625 $_[KERNEL]->yield(my_tailed => time, "heartbeat", "beep");
626 $_[KERNEL]->delay($_[STATE] => 10);
627 }
628 },
629 );
630
631 # http server
632
633 my $httpd = POE::Component::Server::HTTP->new(
634 Port => $NICK =~ m/-dev/ ? 8001 : 8000,
635 ContentHandler => { '/' => \&root_handler },
636 Headers => { Server => 'irc-logger' },
637 );
638
639 my %escape = ('<'=>'&lt;', '>'=>'&gt;', '&'=>'&amp;', '"'=>'&quot;');
640 my $escape_re = join '|' => keys %escape;
641
642 my $style = <<'_END_OF_STYLE_';
643 p { margin: 0; padding: 0.1em; }
644 .time, .channel { color: #808080; font-size: 60%; }
645 .date { float: right; background: #e0e0e0; color: #404040; font-size: 120%; padding: 0.25em; border: 1px dashed #808080; }
646 .nick { color: #000000; font-size: 80%; padding: 2px; font-family: courier, courier new, monospace ; }
647 .message { color: #000000; font-size: 100%; }
648 .search { float: right; }
649 .col-0 { background: #ffff66 }
650 .col-1 { background: #a0ffff }
651 .col-2 { background: #99ff99 }
652 .col-3 { background: #ff9999 }
653 .col-4 { background: #ff66ff }
654 a:link.tag, a:visited.tag { border: 1px dashed #ccc; backgound: #ccc; text-decoration: none }
655 a:hover.tag { border: 1px solid #eee }
656 hr { border: 1px dashed #ccc; height: 1px; clear: both; }
657 _END_OF_STYLE_
658
659 my $max_color = 4;
660
661 my %nick_enumerator;
662
663 sub root_handler {
664 my ($request, $response) = @_;
665 $response->code(RC_OK);
666 $response->content_type("text/html; charset=$ENCODING");
667
668 my $q;
669
670 if ( $request->method eq 'POST' ) {
671 $q = new CGI::Simple( $request->content );
672 } elsif ( $request->uri =~ /\?(.+)$/ ) {
673 $q = new CGI::Simple( $1 );
674 } else {
675 $q = new CGI::Simple;
676 }
677
678 my $search = $q->param('search') || $q->param('grep') || '';
679
680 my $html =
681 qq{<html><head><title>$NICK</title><style type="text/css">$style} .
682 $cloud->css .
683 qq{</style></head><body>} .
684 qq{
685 <form method="post" class="search" action="/">
686 <input type="text" name="search" value="$search" size="10">
687 <input type="submit" value="search">
688 </form>
689 } .
690 $cloud->html(500) .
691 qq{<p>};
692 if ($request->url =~ m#/history#) {
693 my $sth = $dbh->prepare(qq{
694 select date(time) as date,count(*) as nr
695 from log
696 group by date(time)
697 order by date(time) desc
698 });
699 $sth->execute();
700 my ($l_yyyy,$l_mm) = (0,0);
701 my $cal;
702 while (my $row = $sth->fetchrow_hashref) {
703 # this is probably PostgreSQL specific, expects ISO date
704 my ($yyyy,$mm,$dd) = split(/-/, $row->{date});
705 if ($yyyy != $l_yyyy || $mm != $l_mm) {
706 $html .= $cal->as_HTML() if ($cal);
707 $cal = new HTML::CalendarMonthSimple('month'=>$mm,'year'=>$yyyy);
708 $cal->border(2);
709 ($l_yyyy,$l_mm) = ($yyyy,$mm);
710 }
711 $cal->setcontent($dd, qq{
712 <a href="/?date=$row->{date}">$row->{nr}</a>
713 });
714 }
715 $html .= $cal->as_HTML() if ($cal);
716
717 } else {
718 $html .= join("</p><p>",
719 get_from_log(
720 limit => $q->param('last') || $q->param('date') ? undef : 100,
721 search => $search || undef,
722 tag => $q->param('tag') || undef,
723 date => $q->param('date') || undef,
724 fmt => {
725 date => sub {
726 my $date = shift || return;
727 qq{<hr/><div class="date"><a href="/?date=$date">$date</a></div>};
728 },
729 time => '<span class="time">%s</span> ',
730 time_channel => '<span class="channel">%s %s</span> ',
731 nick => '%s:&nbsp;',
732 me_nick => '***%s&nbsp;',
733 message => '<span class="message">%s</span>',
734 },
735 filter => {
736 message => sub {
737 my $m = shift || return;
738 $m =~ s/($escape_re)/$escape{$1}/gs;
739 $m =~ s#($RE{URI}{HTTP})#<a href="$1">$1</a>#gs;
740 $m =~ s#$tag_regex#<a href="?tag=$1" class="tag">$1</a>#g;
741 return $m;
742 },
743 nick => sub {
744 my $n = shift || return;
745 if (! $nick_enumerator{$n}) {
746 my $max = scalar keys %nick_enumerator;
747 $nick_enumerator{$n} = $max + 1;
748 }
749 return '<span class="nick col-' .
750 ( $nick_enumerator{$n} % $max_color ) .
751 '">' . $n . '</span>';
752 },
753 },
754 )
755 );
756 }
757
758 $html .= qq{</p>
759 <hr/>
760 <p>See <a href="/history">history</a> of all messages.</p>
761 </body></html>};
762
763 $response->content( $html );
764 return RC_OK;
765 }
766
767 POE::Kernel->run;

Properties

Name Value
svn:executable *

  ViewVC Help
Powered by ViewVC 1.1.26