/[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

Diff of /trunk/bin/irc-logger.pl

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

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

Legend:
Removed from v.6  
changed lines
  Added in v.42

  ViewVC Help
Powered by ViewVC 1.1.26