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

Properties

Name Value
svn:executable *

  ViewVC Help
Powered by ViewVC 1.1.26