/[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 13 by dpavlin, Sun Mar 12 14:19:00 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 $NICK = 'irc-logger-dev';  my $HOSTNAME = `hostname`;
30    
31    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    my $sleep_on_error = 5;
54    
55  ## END CONFIG  ## END CONFIG
56    
# Line 42  my $DSN = 'DBI:Pg:dbname=irc-logger'; Line 59  my $DSN = 'DBI:Pg:dbname=irc-logger';
59  use POE qw(Component::IRC Wheel::FollowTail Component::Server::HTTP);  use POE qw(Component::IRC Wheel::FollowTail Component::Server::HTTP);
60  use HTTP::Status;  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 63  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  =head2 get_from_log
113    
114   my @messages = get_from_log(   my @messages = get_from_log(
# Line 82  values (?,?,?) Line 118  values (?,?,?)
118                  time => '{%s} ',                  time => '{%s} ',
119                  time_channel => '{%s %s} ',                  time_channel => '{%s %s} ',
120                  nick => '%s: ',                  nick => '%s: ',
121                    me_nick => '***%s ',
122                  message => '%s',                  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  =cut
143    
144  sub get_from_log {  sub get_from_log {
145          my $args = {@_};          my $args = {@_};
146    
         $args->{limit} ||= 10;  
   
147          $args->{fmt} ||= {          $args->{fmt} ||= {
148                    date => '[%s] ',
149                  time => '{%s} ',                  time => '{%s} ',
150                  time_channel => '{%s %s} ',                  time_channel => '{%s %s} ',
151                  nick => '%s: ',                  nick => '%s: ',
152                    me_nick => '***%s ',
153                  message => '%s',                  message => '%s',
154          };          };
155    
156          my $sql = qq{          my $sql_message = qq{
157                  select                  select
158                          time::date as date,                          time::date as date,
159                          time::time as time,                          time::time as time,
160                          channel,                          channel,
161                            me,
162                          nick,                          nick,
163                          message                          message
164                  from log                  from log
165          };          };
166          $sql .= " where message ilike ? " if ($args->{search});  
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";          $sql .= " order by log.time desc";
181          $sql .= " limit " . $args->{limit};          $sql .= " limit " . $args->{limit} if ($args->{limit});
182    
183          my $sth = $dbh->prepare( $sql );          my $sth = $dbh->prepare( $sql );
184          if ($args->{search}) {          if (my $search = $args->{search}) {
185                  $sth->execute( $args->{search} );                  $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 {          } else {
196                  $sth->execute();                  $sth->execute();
197          }          }
# Line 132  sub get_from_log { Line 208  sub get_from_log {
208                  unshift @rows, $row;                  unshift @rows, $row;
209          }          }
210    
211          my @msgs;          # 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) {          foreach my $row (@rows) {
257    
258                  $row->{time} =~ s#\.\d+##;                  $row->{time} =~ s#\.\d+##;
259    
                 my $t;  
                 $t = $row->{date} . ' ' if ($last_row->{date} ne $row->{date});  
                 $t .= $row->{time};  
   
260                  my $msg = '';                  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}) {                  if ($last_row->{channel} ne $row->{channel}) {
266                          $msg .= sprintf($args->{fmt}->{time_channel}, $t, $row->{channel});                          $msg .= cr_sprintf($args->{fmt}->{time_channel}, $t, $row->{channel});
267                  } else {                  } else {
268                          $msg .= sprintf($args->{fmt}->{time}, $t);                          $msg .= cr_sprintf($args->{fmt}->{time}, $t);
269                  }                  }
270    
271                  my $append = 1;                  my $append = 1;
272    
273                  if ($last_row->{nick} ne $row->{nick}) {                  my $nick = $row->{nick};
274                          $msg .= sprintf($args->{fmt}->{nick}, $row->{nick});  #               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;                          $append = 0;
287                  }                  }
288    
289                  $msg .= sprintf($args->{fmt}->{message}, $row->{message});                  $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) {                  if ($append && @msgs) {
301                          $msgs[$#msgs] .= " " . $msg;                          $msgs[$#msgs] .= " " . $msg;
# Line 171  sub get_from_log { Line 309  sub get_from_log {
309          return @msgs;          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);
# Line 196  POE::Session->create Line 453  POE::Session->create
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        irc_ctcp_action => sub {
459                    my $kernel = $_[KERNEL];
460                    my $nick = (split /!/, $_[ARG0])[0];
461                    my $channel = $_[ARG1]->[0];
462                    my $msg = $_[ARG2];
463    
464                  print "$channel: <$nick> $msg\n";                  save_message( channel => $channel, me => 1, nick => $nick, msg => $msg);
                 $sth->execute($channel, $nick, $msg);  
465      },      },
466          irc_msg => sub {          irc_msg => sub {
467                  my $kernel = $_[KERNEL];                  my $kernel = $_[KERNEL];
468                  my $nick = (split /!/, $_[ARG0])[0];                  my $nick = (split /!/, $_[ARG0])[0];
469                  my $msg = $_[ARG2];                  my $msg = $_[ARG2];
470                  from_to($msg, 'UTF-8', 'ISO-8859-2');                  from_to($msg, 'UTF-8', $ENCODING);
471    
472                  my $res = "unknown command '$msg', try /msg $NICK help!";                  my $res = "unknown command '$msg', try /msg $NICK help!";
473                  my @out;                  my @out;
# Line 227  POE::Session->create Line 489  POE::Session->create
489                          my $nr = $1 || 10;                          my $nr = $1 || 10;
490    
491                          my $sth = $dbh->prepare(qq{                          my $sth = $dbh->prepare(qq{
492                                  select nick,count(*) from log group by nick order by count desc limit $nr                                  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();                          $sth->execute();
502                          $res = "Top $nr users: ";                          $res = "Top $nr users: ";
503                          my @users;                          my @users;
504                          while (my $row = $sth->fetchrow_hashref) {                          while (my $row = $sth->fetchrow_hashref) {
505                                  push @users,$row->{nick} . ': ' . $row->{count};                                  push @users,$row->{nick} . ': ' . $row->{count} . '/' . $row->{len} . '=' . sprintf("%.2f", $row->{len}/$row->{count});
506                          }                          }
507                          $res .= join(" | ", @users);                          $res .= join(" | ", @users);
508                  } elsif ($msg =~ m/^last.*?\s*(\d*)/i) {                  } elsif ($msg =~ m/^last.*?\s*(\d*)/i) {
509    
510                          foreach my $res (get_from_log( limit => $1 )) {                          foreach my $res (get_from_log( limit => ($1 || 100) )) {
511                                  print "last: $res\n";                                  print "last: $res\n";
512                                  from_to($res, 'ISO-8859-2', 'UTF-8');                                  from_to($res, $ENCODING, 'UTF-8');
513                                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );                                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );
514                          }                          }
515    
516                          $res = '';                          $res = '';
517    
518                  } elsif ($msg =~ m/^(search|grep)\s+(.*)$/i) {                  } elsif ($msg =~ m/^(search|grep)\s+(.*)\s*$/i) {
519    
520                          my $what = $2;                          my $what = $2;
521    
522                          foreach my $res (get_from_log( limit => 20, search => "%${what}%" )) {                          foreach my $res (get_from_log(
523                                            limit => 20,
524                                            search => $what,
525                                    )) {
526                                  print "search [$what]: $res\n";                                  print "search [$what]: $res\n";
527                                  from_to($res, 'ISO-8859-2', 'UTF-8');                                  from_to($res, $ENCODING, 'UTF-8');
528                                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );                                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );
529                          }                          }
530    
531                          $res = '';                          $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) {                  if ($res) {
565                          print ">> [$nick] $res\n";                          print ">> [$nick] $res\n";
566                          from_to($res, 'ISO-8859-2', 'UTF-8');                          from_to($res, $ENCODING, 'UTF-8');
567                          $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );                          $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );
568                  }                  }
569    
# Line 281  POE::Session->create Line 582  POE::Session->create
582                  warn "## indetify $NICK\n";                  warn "## indetify $NICK\n";
583                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );                  $_[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 {  #       irc_433 => sub {
595  #               print "# irc_433: ",$_[ARG1], "\n";  #               print "# irc_433: ",$_[ARG1], "\n";
596  #               warn "## indetify $NICK\n";  #               warn "## indetify $NICK\n";
597  #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );  #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );
598  #       },  #       },
         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  
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 378  POE::Session->create Line 671  POE::Session->create
671  # http server  # http server
672    
673  my $httpd = POE::Component::Server::HTTP->new(  my $httpd = POE::Component::Server::HTTP->new(
674          Port => 8000,          Port => $NICK =~ m/-dev/ ? 8001 : 8000,
675          ContentHandler => { '/' => \&root_handler },          ContentHandler => { '/' => \&root_handler },
676          Headers        => { Server => 'irc-logger' },          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_';  my $style = <<'_END_OF_STYLE_';
683    p { margin: 0; padding: 0.1em; }
684  .time, .channel { color: #808080; font-size: 60%; }  .time, .channel { color: #808080; font-size: 60%; }
685  .nick { color: #0000ff; font-size: 80%; }  .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%; }  .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_  _END_OF_STYLE_
698    
699    my $max_color = 4;
700    
701    my %nick_enumerator;
702    
703  sub root_handler {  sub root_handler {
704          my ($request, $response) = @_;          my ($request, $response) = @_;
705          $response->code(RC_OK);          $response->code(RC_OK);
706          $response->content_type('text/html');          $response->content_type("text/html; charset=$ENCODING");
707          $response->content(  
708                  qq{<html><head><title>$NICK</title><style type="text/css">$style</style></head><body>} .          my $q;
709                  "irc-logger url: " . $request->uri . '<br/>' .  
710                  join("<br/>",          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(                          get_from_log(
760                                  limit => 100,                                  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 => {                                  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> ',                                          time => '<span class="time">%s</span> ',
770                                          time_channel => '<span class="channel">%s %s</span> ',                                          time_channel => '<span class="channel">%s %s</span> ',
771                                          nick => '<span class="nick">%s:</span> ',                                          nick => '%s:&nbsp;',
772                                            me_nick => '***%s&nbsp;',
773                                          message => '<span class="message">%s</span>',                                          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                  qq{</body></html>}          }
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;          return RC_OK;
805  }  }
806    

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

  ViewVC Help
Powered by ViewVC 1.1.26