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

Legend:
Removed from v.12  
changed lines
  Added in v.43

  ViewVC Help
Powered by ViewVC 1.1.26