/[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 10 by dpavlin, Thu Mar 2 00:19:12 2006 UTC revision 37 by dpavlin, Sun Jun 25 17:40:59 2006 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 => "try /msg $NICK help",     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  ## END CONFIG  ## END CONFIG
54    
55    
56    
57  use POE qw(Component::IRC Wheel::FollowTail);  use POE qw(Component::IRC Wheel::FollowTail Component::Server::HTTP);
58    use HTTP::Status;
59  use DBI;  use DBI;
60  use Encode qw/from_to/;  use Encode qw/from_to is_utf8/;
61    use Regexp::Common qw /URI/;
62    use CGI::Simple;
63    use HTML::TagCloud;
64    use POSIX qw/strftime/;
65    use HTML::CalendarMonthSimple;
66    use Getopt::Long;
67    use DateTime;
68    
69    my $import_dircproxy;
70    GetOptions(
71            'import-dircproxy:s' => \$import_dircproxy,
72    );
73    
74  my $dbh = DBI->connect($DSN,"","", { RaiseError => 1, AutoCommit => 1 }) || die $DBI::errstr;  my $dbh = DBI->connect($DSN,"","", { RaiseError => 1, AutoCommit => 1 }) || die $DBI::errstr;
75    
76  =for SQL schema  eval {
77            $dbh->do(qq{ select count(*) from log });
78    };
79    
80    if ($@) {
81            warn "creating database table in $DSN\n";
82            $dbh->do(<<'_SQL_SCHEMA_');
83    
 $dbh->do(qq{  
84  create table log (  create table log (
85          id serial,          id serial,
86          time timestamp default now(),          time timestamp default now(),
87          channel text not null,          channel text not null,
88            me boolean default false,
89          nick text not null,          nick text not null,
90          message text not null,          message text not null,
91          primary key(id)          primary key(id)
# Line 62  create index log_time on log(time); Line 95  create index log_time on log(time);
95  create index log_channel on log(channel);  create index log_channel on log(channel);
96  create index log_nick on log(nick);  create index log_nick on log(nick);
97    
98  });  _SQL_SCHEMA_
99    }
 =cut  
100    
101  my $sth = $dbh->prepare(qq{  my $sth = $dbh->prepare(qq{
102  insert into log  insert into log
103          (channel, nick, message)          (channel, me, nick, message, time)
104  values (?,?,?)  values (?,?,?,?,?)
105  });  });
106    
107    my $tags;
108    my $tag_regex = '\b([\w-_]+)//';
109    
110    =head2 get_from_log
111    
112     my @messages = get_from_log(
113            limit => 42,
114            search => '%what to stuff in ilike%',
115            fmt => {
116                    time => '{%s} ',
117                    time_channel => '{%s %s} ',
118                    nick => '%s: ',
119                    me_nick => '***%s ',
120                    message => '%s',
121            },
122            filter => {
123                    message => sub {
124                            # modify message content
125                            return shift;
126                    }
127            },
128            context => 5,
129     );
130    
131    Order is important. Fields are first passed through C<filter> (if available) and
132    then throgh C<< sprintf($fmt->{message}, $message >> if available.
133    
134    C<context> defines number of messages around each search hit for display.
135    
136    =cut
137    
138    sub get_from_log {
139            my $args = {@_};
140    
141            $args->{fmt} ||= {
142                    date => '[%s] ',
143                    time => '{%s} ',
144                    time_channel => '{%s %s} ',
145                    nick => '%s: ',
146                    me_nick => '***%s ',
147                    message => '%s',
148            };
149    
150            my $sql_message = qq{
151                    select
152                            time::date as date,
153                            time::time as time,
154                            channel,
155                            me,
156                            nick,
157                            message
158                    from log
159            };
160    
161            my $sql_context = qq{
162                    select
163                            id
164                    from log
165            };
166    
167            my $context = $1 if ($args->{search} && $args->{search} =~ s/\s*\+(\d+)\s*/ /);
168    
169            my $sql = $context ? $sql_context : $sql_message;
170    
171            $sql .= " where message ilike ? or nick ilike ? " if ($args->{search});
172            $sql .= " where id in (" . join(",", @{ $tags->{ $args->{tag} } }) . ") " if ($args->{tag} && $tags->{ $args->{tag} });
173            $sql .= " where date(time) = ? " if ($args->{date});
174            $sql .= " order by log.time desc";
175            $sql .= " limit " . $args->{limit} if ($args->{limit});
176    
177            my $sth = $dbh->prepare( $sql );
178            if (my $search = $args->{search}) {
179                    $search =~ s/^\s+//;
180                    $search =~ s/\s+$//;
181                    $sth->execute( ( '%' . $search . '%' ) x 2 );
182                    warn "search for '$search' returned ", $sth->rows, " results ", $context || '', "\n";
183            } elsif (my $tag = $args->{tag}) {
184                    $sth->execute();
185                    warn "tag '$tag' returned ", $sth->rows, " results ", $context || '', "\n";
186            } elsif (my $date = $args->{date}) {
187                    $sth->execute($date);
188                    warn "found ", $sth->rows, " messages for date $date ", $context || '', "\n";
189            } else {
190                    $sth->execute();
191            }
192            my $last_row = {
193                    date => '',
194                    time => '',
195                    channel => '',
196                    nick => '',
197            };
198    
199            my @rows;
200    
201            while (my $row = $sth->fetchrow_hashref) {
202                    unshift @rows, $row;
203            }
204    
205            my @msgs = (
206                    "Showing " . ($#rows + 1) . " messages..."
207            );
208    
209            if ($context) {
210                    my @ids = @rows;
211                    @rows = ();
212    
213                    my $last_to = 0;
214    
215                    my $sth = $dbh->prepare( $sql_message . qq{ where id >= ? and id < ? } );
216                    foreach my $row_id (sort { $a->{id} <=> $b->{id} } @ids) {
217                            my $id = $row_id->{id} || die "can't find id in row";
218            
219                            my ($from, $to) = ($id - $context, $id + $context);
220                            $from = $last_to if ($from < $last_to);
221                            $last_to = $to;
222                            $sth->execute( $from, $to );
223    
224                            #warn "## id: $id from: $from to: $to returned: ", $sth->rows, "\n";
225    
226                            while (my $row = $sth->fetchrow_hashref) {
227                                    push @rows, $row;
228                            }
229    
230                    }
231            }
232    
233            # sprintf which can take coderef as first parametar
234            sub cr_sprintf {
235                    my $fmt = shift || return;
236                    if (ref($fmt) eq 'CODE') {
237                            $fmt->(@_);
238                    } else {
239                            sprintf($fmt, @_);
240                    }
241            }
242    
243            foreach my $row (@rows) {
244    
245                    $row->{time} =~ s#\.\d+##;
246    
247                    my $msg = '';
248    
249                    $msg = cr_sprintf($args->{fmt}->{date}, $row->{date}) . ' ' if ($last_row->{date} ne $row->{date});
250                    my $t = $row->{time};
251    
252                    if ($last_row->{channel} ne $row->{channel}) {
253                            $msg .= cr_sprintf($args->{fmt}->{time_channel}, $t, $row->{channel});
254                    } else {
255                            $msg .= cr_sprintf($args->{fmt}->{time}, $t);
256                    }
257    
258                    my $append = 1;
259    
260                    my $nick = $row->{nick};
261                    if ($nick =~ s/^_*(.*?)_*$/$1/) {
262                            $row->{nick} = $nick;
263                    }
264    
265                    if ($last_row->{nick} ne $nick) {
266                            # obfu way to find format for me_nick if needed or fallback to default
267                            my $fmt = $row->{me} ? ( $args->{fmt}->{me_nick} || $args->{fmt}->{nick} ) : $args->{fmt}->{nick};
268                            $fmt ||= '%s';
269    
270                            $nick = $args->{filter}->{nick}->($nick) if (ref($args->{filter}->{nick}) eq 'CODE');
271    
272                            $msg .= cr_sprintf( $fmt, $nick );
273                            $append = 0;
274                    }
275    
276                    $args->{fmt}->{message} ||= '%s';
277                    if (ref($args->{filter}->{message}) eq 'CODE') {
278                            $msg .= cr_sprintf($args->{fmt}->{message},
279                                    $args->{filter}->{message}->(
280                                            $row->{message}
281                                    )
282                            );
283                    } else {
284                            $msg .= cr_sprintf($args->{fmt}->{message}, $row->{message});
285                    }
286    
287                    if ($append && @msgs) {
288                            $msgs[$#msgs] .= " " . $msg;
289                    } else {
290                            push @msgs, $msg;
291                    }
292    
293                    $last_row = $row;
294            }
295    
296            return @msgs;
297    }
298    
299    # tags support
300    
301    my $cloud = HTML::TagCloud->new;
302    
303    =head2 add_tag
304    
305     add_tag( id => 42, message => 'irc message' );
306    
307    =cut
308    
309    sub add_tag {
310            my $arg = {@_};
311    
312            return unless ($arg->{id} && $arg->{message});
313    
314            my $m = $arg->{message};
315            from_to('UTF-8', 'iso-8859-2', $m) if (is_utf8($m));
316    
317            while ($m =~ s#$tag_regex##s) {
318                    my $tag = $1;
319                    next if (! $tag || $tag =~ m/https?:/i);
320                    push @{ $tags->{$tag} }, $arg->{id};
321                    #warn "+tag $tag: $arg->{id}\n";
322                    $cloud->add($tag, "?tag=$tag", scalar @{$tags->{$tag}} + 1);
323            }
324    }
325    
326    =head2 seed_tags
327    
328    Read all tags from database and create in-memory cache for tags
329    
330    =cut
331    
332    sub seed_tags {
333            my $sth = $dbh->prepare(qq{ select id,message from log where message like '%//%' });
334            $sth->execute;
335            while (my $row = $sth->fetchrow_hashref) {
336                    add_tag( %$row );
337            }
338    
339            foreach my $tag (keys %$tags) {
340                    $cloud->add($tag, "?tag=$tag", scalar @{$tags->{$tag}} + 1);
341            }
342    }
343    
344    seed_tags;
345    
346    
347    =head2 save_message
348    
349      save_message(
350            channel => '#foobar',
351            me => 0,
352            nick => 'dpavlin',
353            msg => 'test message',
354            time => '2006-06-25 18:57:18',
355      );
356    
357    C<time> is optional, it will use C<< now() >> if it's not available.
358    
359    C<me> if not specified will be C<0> (not C</me> message)
360    
361    =cut
362    
363    sub save_message {
364            my $a = {@_};
365            $a->{me} ||= 0;
366    
367            print
368                    $a->{time} ? $a->{time} . " " : strftime($TIMESTAMP,localtime()),
369                    $a->{channel}, " ",
370                    $a->{me} ? "***" . $a->{nick} : "<" . $a->{nick} . ">",
371                    " " . $a->{msg} . "\n";
372    
373            from_to($a->{msg}, 'UTF-8', $ENCODING);
374    
375            $sth->execute($a->{channel}, $a->{me}, $a->{nick}, $a->{msg}, $a->{time});
376            add_tag( id => $dbh->last_insert_id(undef,undef,"log",undef),
377                    message => $a->{msg});
378    }
379    
380    if ($import_dircproxy) {
381            open(my $l, $import_dircproxy) || die "can't open $import_dircproxy: $!";
382            warn "importing $import_dircproxy...\n";
383            my $tz_offset = 2 * 60 * 60;    # TZ GMT+2
384            while(<$l>) {
385                    chomp;
386                    if (/^@(\d+)\s(\S+)\s(.+)$/) {
387                            my ($time, $nick, $msg) = ($1,$2,$3);
388    
389                            my $dt = DateTime->from_epoch( epoch => $time + $tz_offset );
390    
391                            my $me = 0;
392                            $me = 1 if ($nick =~ m/^\[\S+]/);
393                            $nick =~ s/^[\[<]([^!]+).*$/$1/;
394    
395                            $msg =~ s/^ACTION\s+// if ($me);
396    
397                            save_message(
398                                    channel => $CHANNEL,
399                                    me => $me,
400                                    nick => $nick,
401                                    msg => $msg,
402                                    time => $dt->ymd . " " . $dt->hms,
403                            ) if ($nick !~ m/^-/);
404    
405                    } else {
406                            warn "can't parse: $_\n";
407                    }
408            }
409            close($l);
410            warn "import over\n";
411            exit;
412    }
413    
414    
415    #
416    # POE handing part
417    #
418    
419  my $SKIPPING = 0;               # if skipping, how many we've done  my $SKIPPING = 0;               # if skipping, how many we've done
420  my $SEND_QUEUE;                 # cache  my $SEND_QUEUE;                 # cache
421    
422  POE::Component::IRC->new($IRC_ALIAS);  POE::Component::IRC->new($IRC_ALIAS);
423    
424  POE::Session->create  POE::Session->create( inline_states =>
   (inline_states =>  
425     {_start => sub {           {_start => sub {      
426                  $_[KERNEL]->post($IRC_ALIAS => register => 'all');                  $_[KERNEL]->post($IRC_ALIAS => register => 'all');
427                  $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);                  $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);
# Line 89  POE::Session->create Line 431  POE::Session->create
431                  $_[KERNEL]->post($IRC_ALIAS => join => '#logger');                  $_[KERNEL]->post($IRC_ALIAS => join => '#logger');
432                  $_[KERNEL]->yield("heartbeat"); # start heartbeat                  $_[KERNEL]->yield("heartbeat"); # start heartbeat
433  #               $_[KERNEL]->yield("my_add", $_) for keys %FOLLOWS;  #               $_[KERNEL]->yield("my_add", $_) for keys %FOLLOWS;
434                    $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );
435      },      },
436      irc_public => sub {      irc_public => sub {
437                  my $kernel = $_[KERNEL];                  my $kernel = $_[KERNEL];
# Line 96  POE::Session->create Line 439  POE::Session->create
439                  my $channel = $_[ARG1]->[0];                  my $channel = $_[ARG1]->[0];
440                  my $msg = $_[ARG2];                  my $msg = $_[ARG2];
441    
442                  from_to($msg, 'UTF-8', 'ISO-8859-2');                  save_message( channel => $channel, me => 0, nick => $nick, msg => $msg);
443        },
444        irc_ctcp_action => sub {
445                    my $kernel = $_[KERNEL];
446                    my $nick = (split /!/, $_[ARG0])[0];
447                    my $channel = $_[ARG1]->[0];
448                    my $msg = $_[ARG2];
449    
450                  print "$channel: <$nick> $msg\n";                  save_message( channel => $channel, me => 1, nick => $nick, msg => $msg);
                 $sth->execute($channel, $nick, $msg);  
451      },      },
452          irc_msg => sub {          irc_msg => sub {
453                  my $kernel = $_[KERNEL];                  my $kernel = $_[KERNEL];
454                  my $nick = (split /!/, $_[ARG0])[0];                  my $nick = (split /!/, $_[ARG0])[0];
455                  my $msg = $_[ARG2];                  my $msg = $_[ARG2];
456                  from_to($msg, 'UTF-8', 'ISO-8859-2');                  from_to($msg, 'UTF-8', $ENCODING);
457    
458                  my $res = "unknown command '$msg', try /msg $NICK help!";                  my $res = "unknown command '$msg', try /msg $NICK help!";
459                    my @out;
460    
461                  print "<< $msg\n";                  print "<< $msg\n";
462    
463                  if ($msg =~ m/^help/i) {                  if ($msg =~ m/^help/i) {
464    
465                          $res = "usage: /msg $NICK stat - shows user statistics | /msg $NICK last - show backtrace of conversations";                          $res = "usage: /msg $NICK comand | commands: stat - user/message stat | last - show backtrace | grep foobar - find foobar";
466    
467                  } elsif ($msg =~ m/^msg\s+(\S+)\s+(.*)$/i) {                  } elsif ($msg =~ m/^msg\s+(\S+)\s+(.*)$/i) {
468    
# Line 137  POE::Session->create Line 486  POE::Session->create
486                          $res .= join(" | ", @users);                          $res .= join(" | ", @users);
487                  } elsif ($msg =~ m/^last.*?\s*(\d*)/i) {                  } elsif ($msg =~ m/^last.*?\s*(\d*)/i) {
488    
489                          my $nr = $1 || 10;                          foreach my $res (get_from_log( limit => $1 )) {
490                                    print "last: $res\n";
491                          my $sth = $dbh->prepare(qq{                                  from_to($res, $ENCODING, 'UTF-8');
492                                  select                                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );
                                         time::date as date,  
                                         time::time as time,  
                                         channel,  
                                         nick,  
                                         message  
                                 from log order by log.time desc limit $nr  
                         });  
                         $sth->execute();  
                         $res = "Last $nr messages: ";  
                         my $last_row = {  
                                 date => '',  
                                 time => '',  
                                 channel => '',  
                                 nick => '',  
                         };  
   
                         my @rows;  
   
                         while (my $row = $sth->fetchrow_hashref) {  
                                 unshift @rows, $row;  
493                          }                          }
494    
495                          my @msgs;                          $res = '';
   
                         foreach my $row (@rows) {  
   
                                 $row->{time} =~ s#\.\d+##;  
   
                                 my $t;  
                                 $t = $row->{date} . ' ' if ($last_row->{date} ne $row->{date});  
                                 $t .= $row->{time};  
   
                                 my $msg = '';  
   
                                 $msg .= "($t";  
                                 $msg .= ' ' . $row->{channel} if ($last_row->{channel} ne $row->{channel});  
                                 $msg .= ") ";  
   
                                 $msg .= $row->{nick} . ': '  if ($last_row->{nick} ne $row->{nick});  
496    
497                                  $msg .= $row->{message};                  } elsif ($msg =~ m/^(search|grep)\s+(.*)\s*$/i) {
498    
499                                  push @msgs, $msg;                          my $what = $2;
500    
501                                  $last_row = $row;                          foreach my $res (get_from_log(
502                          }                                          limit => 20,
503                                            search => $what,
504                          foreach my $res (@msgs) {                                  )) {
505                                  print "last: $res\n";                                  print "search [$what]: $res\n";
506                                  from_to($res, 'ISO-8859-2', 'UTF-8');                                  from_to($res, $ENCODING, 'UTF-8');
507                                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );                                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );
508                          }                          }
509    
510                          $res = '';                          $res = '';
511    
512                  }                  }
513    
514                  if ($res) {                  if ($res) {
515                          print ">> [$nick] $res\n";                          print ">> [$nick] $res\n";
516                          from_to($res, 'ISO-8859-2', 'UTF-8');                          from_to($res, $ENCODING, 'UTF-8');
517                          $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );                          $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );
518                  }                  }
519    
# Line 218  POE::Session->create Line 532  POE::Session->create
532                  warn "## indetify $NICK\n";                  warn "## indetify $NICK\n";
533                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );
534          },          },
535          irc_433 => sub {  #       irc_433 => sub {
536                  print "# irc_433: ",$_[ARG1], "\n";  #               print "# irc_433: ",$_[ARG1], "\n";
537                  warn "## indetify $NICK\n";  #               warn "## indetify $NICK\n";
538                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );  #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );
539          },  #       },
         irc_372 => sub {  
                 print "MOTD: ", $_[ARG1], "\n";  
         },  
         irc_snotice => sub {  
                 print "(server notice): ", $_[ARG0], "\n";  
         },  
     (map  
      {  
        ;"irc_$_" => sub { }}  
      qw(  
                 )),  
 #       join  
 #       ctcp_version  
 #       connected snotice ctcp_action ping notice mode part quit  
 #       001 002 003 004 005  
 #       250 251 252 253 254 265 266  
 #       332 333 353 366 372 375 376  
 #       477  
540      _child => sub {},      _child => sub {},
541      _default => sub {      _default => sub {
542        printf "%s: session %s caught an unhandled %s event.\n",                  printf "%s #%s %s %s\n",
543          scalar localtime(), $_[SESSION]->ID, $_[ARG0];                          strftime($TIMESTAMP,localtime()), $_[SESSION]->ID, $_[ARG0],
544        print "The $_[ARG0] event was given these parameters: ",                          ref($_[ARG1]) eq "ARRAY"        ?       join(",", map { ref($_) eq "ARRAY" ? join(";", @{$_}) : $_ } @{ $_[ARG1] })     :
545          join(" ", map({"ARRAY" eq ref $_ ? "[@$_]" : "$_"} @{$_[ARG1]})), "\n";                          $_[ARG1]                                        ?       $_[ARG1]                                        :
546                            "";
547        0;                        # false for signals        0;                        # false for signals
548      },      },
549      my_add => sub {      my_add => sub {
# Line 312  POE::Session->create Line 609  POE::Session->create
609     },     },
610    );    );
611    
612    # http server
613    
614    my $httpd = POE::Component::Server::HTTP->new(
615            Port => $NICK =~ m/-dev/ ? 8001 : 8000,
616            ContentHandler => { '/' => \&root_handler },
617            Headers        => { Server => 'irc-logger' },
618    );
619    
620    my %escape = ('<'=>'&lt;', '>'=>'&gt;', '&'=>'&amp;', '"'=>'&quot;');
621    my $escape_re  = join '|' => keys %escape;
622    
623    my $style = <<'_END_OF_STYLE_';
624    p { margin: 0; padding: 0.1em; }
625    .time, .channel { color: #808080; font-size: 60%; }
626    .date { float: right; background: #e0e0e0; color: #404040; font-size: 120%; padding: 0.25em; border: 1px dashed #808080; }
627    .nick { color: #000000; font-size: 80%; padding: 2px; font-family: courier, courier new, monospace ; }
628    .message { color: #000000; font-size: 100%; }
629    .search { float: right; }
630    .col-0 { background: #ffff66 }
631    .col-1 { background: #a0ffff }
632    .col-2 { background: #99ff99 }
633    .col-3 { background: #ff9999 }
634    .col-4 { background: #ff66ff }
635    a:link.tag, a:visited.tag { border: 1px dashed #ccc; backgound: #ccc; text-decoration: none }
636    a:hover.tag { border: 1px solid #eee }
637    hr { border: 1px dashed #ccc; height: 1px; clear: both; }
638    _END_OF_STYLE_
639    
640    my $max_color = 4;
641    
642    my %nick_enumerator;
643    
644    sub root_handler {
645            my ($request, $response) = @_;
646            $response->code(RC_OK);
647            $response->content_type("text/html; charset=$ENCODING");
648    
649            my $q;
650    
651            if ( $request->method eq 'POST' ) {
652                    $q = new CGI::Simple( $request->content );
653            } elsif ( $request->uri =~ /\?(.+)$/ ) {
654                    $q = new CGI::Simple( $1 );
655            } else {
656                    $q = new CGI::Simple;
657            }
658    
659            my $search = $q->param('search') || $q->param('grep') || '';
660    
661            my $html =
662                    qq{<html><head><title>$NICK</title><style type="text/css">$style} .
663                    $cloud->css .
664                    qq{</style></head><body>} .
665                    qq{
666                    <form method="post" class="search" action="/">
667                    <input type="text" name="search" value="$search" size="10">
668                    <input type="submit" value="search">
669                    </form>
670                    } .
671                    $cloud->html(500) .
672                    qq{<p>};
673            if ($request->url =~ m#/history#) {
674                    my $sth = $dbh->prepare(qq{
675                            select date(time) as date,count(*) as nr
676                                    from log
677                                    group by date(time)
678                                    order by date(time) desc
679                    });
680                    $sth->execute();
681                    my ($l_yyyy,$l_mm) = (0,0);
682                    my $cal;
683                    while (my $row = $sth->fetchrow_hashref) {
684                            # this is probably PostgreSQL specific, expects ISO date
685                            my ($yyyy,$mm,$dd) = split(/-/, $row->{date});
686                            if ($yyyy != $l_yyyy || $mm != $l_mm) {
687                                    $html .= $cal->as_HTML() if ($cal);
688                                    $cal = new HTML::CalendarMonthSimple('month'=>$mm,'year'=>$yyyy);
689                                    $cal->border(2);
690                                    ($l_yyyy,$l_mm) = ($yyyy,$mm);
691                            }
692                            $cal->setcontent($dd, qq{
693                                    <a href="/?date=$row->{date}">$row->{nr}</a>
694                            });
695                    }
696                    $html .= $cal->as_HTML() if ($cal);
697    
698            } else {
699                    $html .= join("</p><p>",
700                            get_from_log(
701                                    limit => $q->param('last') || $q->param('date') ? undef : 100,
702                                    search => $search || undef,
703                                    tag => $q->param('tag') || undef,
704                                    date => $q->param('date') || undef,
705                                    fmt => {
706                                            date => sub {
707                                                    my $date = shift || return;
708                                                    qq{<hr/><div class="date"><a href="/?date=$date">$date</a></div>};
709                                            },
710                                            time => '<span class="time">%s</span> ',
711                                            time_channel => '<span class="channel">%s %s</span> ',
712                                            nick => '%s:&nbsp;',
713                                            me_nick => '***%s&nbsp;',
714                                            message => '<span class="message">%s</span>',
715                                    },
716                                    filter => {
717                                            message => sub {
718                                                    my $m = shift || return;
719                                                    $m =~ s/($escape_re)/$escape{$1}/gs;
720                                                    $m =~ s#($RE{URI}{HTTP})#<a href="$1">$1</a>#gs;
721                                                    $m =~ s#$tag_regex#<a href="?tag=$1" class="tag">$1</a>#g;
722                                                    return $m;
723                                            },
724                                            nick => sub {
725                                                    my $n = shift || return;
726                                                    if (! $nick_enumerator{$n})  {
727                                                            my $max = scalar keys %nick_enumerator;
728                                                            $nick_enumerator{$n} = $max + 1;
729                                                    }
730                                                    return '<span class="nick col-' .
731                                                            ( $nick_enumerator{$n} % $max_color ) .
732                                                            '">' . $n . '</span>';
733                                            },
734                                    },
735                            )
736                    );
737            }
738    
739            $html .= qq{</p>
740            <hr/>
741            <p>See <a href="/history">history</a> of all messages.</p>
742            </body></html>};
743    
744            $response->content( $html );
745            return RC_OK;
746    }
747    
748  POE::Kernel->run;  POE::Kernel->run;

Legend:
Removed from v.10  
changed lines
  Added in v.37

  ViewVC Help
Powered by ViewVC 1.1.26