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