/[irc-logger]/trunk/bin/irc-logger.pl
This is repository of my old source code which isn't updated any more. Go to git.rot13.org for current projects!
ViewVC logotype

Diff of /trunk/bin/irc-logger.pl

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 10 by dpavlin, Thu Mar 2 00:19:12 2006 UTC revision 45 by dpavlin, Sat Feb 3 12:18:04 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';
57    my $TIMESTAMP = '%Y-%m-%d %H:%M:%S';
58    
59    my $sleep_on_error = 5;
60    
61  ## END CONFIG  ## END CONFIG
62    
63    
64    
65  use POE qw(Component::IRC Wheel::FollowTail);  use POE qw(Component::IRC Wheel::FollowTail Component::Server::HTTP);
66    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 62  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
128    
129     my @messages = get_from_log(
130            limit => 42,
131            search => '%what to stuff in ilike%',
132            fmt => {
133                    time => '{%s} ',
134                    time_channel => '{%s %s} ',
135                    nick => '%s: ',
136                    me_nick => '***%s ',
137                    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
158    
159    sub get_from_log {
160            my $args = {@_};
161    
162            $args->{fmt} ||= {
163                    date => '[%s] ',
164                    time => '{%s} ',
165                    time_channel => '{%s %s} ',
166                    nick => '%s: ',
167                    me_nick => '***%s ',
168                    message => '%s',
169            };
170    
171            my $sql_message = qq{
172                    select
173                            time::date as date,
174                            time::time as time,
175                            channel,
176                            me,
177                            nick,
178                            message
179                    from log
180            };
181    
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";
196            $sql .= " limit " . $args->{limit} if ($args->{limit});
197    
198            my $sth = $dbh->prepare( $sql );
199            if (my $search = $args->{search}) {
200                    $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 {
211                    $sth->execute();
212            }
213            my $last_row = {
214                    date => '',
215                    time => '',
216                    channel => '',
217                    nick => '',
218            };
219    
220            my @rows;
221    
222            while (my $row = $sth->fetchrow_hashref) {
223                    unshift @rows, $row;
224            }
225    
226            # 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) {
272    
273                    $row->{time} =~ s#\.\d+##;
274    
275                    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}) {
281                            $msg .= cr_sprintf($args->{fmt}->{time_channel}, $t, $row->{channel});
282                    } else {
283                            $msg .= cr_sprintf($args->{fmt}->{time}, $t);
284                    }
285    
286                    my $append = 1;
287    
288                    my $nick = $row->{nick};
289    #               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;
302                    }
303    
304                    $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) {
316                            $msgs[$#msgs] .= " " . $msg;
317                    } else {
318                            push @msgs, $msg;
319                    }
320    
321                    $last_row = $row;
322            }
323    
324            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 89  POE::Session->create Line 460  POE::Session->create
460                  $_[KERNEL]->post($IRC_ALIAS => join => '#logger');                  $_[KERNEL]->post($IRC_ALIAS => join => '#logger');
461                  $_[KERNEL]->yield("heartbeat"); # start heartbeat                  $_[KERNEL]->yield("heartbeat"); # start heartbeat
462  #               $_[KERNEL]->yield("my_add", $_) for keys %FOLLOWS;  #               $_[KERNEL]->yield("my_add", $_) for keys %FOLLOWS;
463                    $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );
464      },      },
465      irc_public => sub {      irc_public => sub {
466                  my $kernel = $_[KERNEL];                  my $kernel = $_[KERNEL];
# Line 96  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', 'ISO-8859-2');                  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];
500                  my $msg = $_[ARG2];                  my $msg = $_[ARG2];
501                  from_to($msg, 'UTF-8', 'ISO-8859-2');                  from_to($msg, 'UTF-8', $ENCODING);
502    
503                  my $res = "unknown command '$msg', try /msg $NICK help!";                  my $res = "unknown command '$msg', try /msg $NICK help!";
504                    my @out;
505    
506                  print "<< $msg\n";                  _log "<< $msg";
507    
508                  if ($msg =~ m/^help/i) {                  if ($msg =~ m/^help/i) {
509    
510                          $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";
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 126  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                          my $nr = $1 || 10;                          foreach my $res (get_from_log( limit => ($1 || 100) )) {
542                                    _log "last: $res";
543                          my $sth = $dbh->prepare(qq{                                  from_to($res, $ENCODING, 'UTF-8');
544                                  select                                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );
                                         time::date as date,  
                                         time::time as time,  
                                         channel,  
                                         nick,  
                                         message  
                                 from log order by log.time desc limit $nr  
                         });  
                         $sth->execute();  
                         $res = "Last $nr messages: ";  
                         my $last_row = {  
                                 date => '',  
                                 time => '',  
                                 channel => '',  
                                 nick => '',  
                         };  
   
                         my @rows;  
   
                         while (my $row = $sth->fetchrow_hashref) {  
                                 unshift @rows, $row;  
545                          }                          }
546    
547                          my @msgs;                          $res = '';
   
                         foreach my $row (@rows) {  
548    
549                                  $row->{time} =~ s#\.\d+##;                  } elsif ($msg =~ m/^(search|grep)\s+(.*)\s*$/i) {
550    
551                                  my $t;                          my $what = $2;
                                 $t = $row->{date} . ' ' if ($last_row->{date} ne $row->{date});  
                                 $t .= $row->{time};  
552    
553                                  my $msg = '';                          foreach my $res (get_from_log(
554                                            limit => 20,
555                                            search => $what,
556                                    )) {
557                                    _log "search [$what]: $res";
558                                    from_to($res, $ENCODING, 'UTF-8');
559                                    $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );
560                            }
561    
562                                  $msg .= "($t";                          $res = '';
                                 $msg .= ' ' . $row->{channel} if ($last_row->{channel} ne $row->{channel});  
                                 $msg .= ") ";  
563    
564                                  $msg .= $row->{nick} . ': '  if ($last_row->{nick} ne $row->{nick});                  } elsif ($msg =~ m/^(?:count|poll)\s+(.*)(?:\s+(\d+))?\s*$/i) {
565    
566                                  $msg .= $row->{message};                          my ($what,$limit) = ($1,$2);
567                            $limit ||= 100;
568    
569                                  push @msgs, $msg;                          my $stat;
570    
571                                  $last_row = $row;                          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                          foreach my $res (@msgs) {                          my @nicks;
583                                  print "last: $res\n";                          foreach my $nick (sort { $stat->{from}->{$a} <=> $stat->{from}->{$b} } keys %{ $stat->{from} }) {
584                                  from_to($res, 'ISO-8859-2', 'UTF-8');                                  push @nicks, $nick . ( $stat->{from}->{$nick} == 1 ? '' :
585                                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );                                          "(" . $stat->{from}->{$nick} . ")"
586                                    );
587                          }                          }
588    
589                          $res = '';                          $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, 'ISO-8859-2', '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";
                 $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );  
         },  
         irc_433 => sub {  
                 print "# irc_433: ",$_[ARG1], "\n";  
                 warn "## indetify $NICK\n";  
619                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );
620          },          },
621          irc_372 => sub {          irc_disconnected => sub {
622                  print "MOTD: ", $_[ARG1], "\n";                  _log "## disconnected, reconnecting again";
623                    $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);
624          },          },
625          irc_snotice => sub {          irc_socketerr => sub {
626                  print "(server notice): ", $_[ARG0], "\n";                  _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      (map  #       irc_433 => sub {
631       {  #               print "# irc_433: ",$_[ARG1], "\n";
632         ;"irc_$_" => sub { }}  #               warn "## indetify $NICK\n";
633       qw(  #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );
634                  )),  #       },
 #       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 312  POE::Session->create Line 704  POE::Session->create
704     },     },
705    );    );
706    
707    # http server
708    
709    my $httpd = POE::Component::Server::HTTP->new(
710            Port => $NICK =~ m/-dev/ ? 8001 : 8000,
711            ContentHandler => { '/' => \&root_handler },
712            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_';
719    p { margin: 0; padding: 0.1em; }
720    .time, .channel { color: #808080; font-size: 60%; }
721    .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%; }
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_
734    
735    my $max_color = 4;
736    
737    my %nick_enumerator;
738    
739    sub root_handler {
740            my ($request, $response) = @_;
741            $response->code(RC_OK);
742            $response->content_type("text/html; charset=$ENCODING");
743    
744            my $q;
745    
746            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(
796                                    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 => {
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> ',
806                                            time_channel => '<span class="channel">%s %s</span> ',
807                                            nick => '%s:&nbsp;',
808                                            me_nick => '***%s&nbsp;',
809                                            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            }
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;
841    }
842    
843  POE::Kernel->run;  POE::Kernel->run;

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

  ViewVC Help
Powered by ViewVC 1.1.26