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

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

Legend:
Removed from v.14  
changed lines
  Added in v.48

  ViewVC Help
Powered by ViewVC 1.1.26