/[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 5 by dpavlin, Mon Feb 27 12:10:07 2006 UTC trunk/bin/irc-logger.pl revision 50 by dpavlin, Sun Mar 18 15:37:05 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 => 'logger: ask dpavlin@rot13.org'     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 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  my $dbh = DBI->connect($DSN,"","", { RaiseError => 1, AutoCommit => 1 }) || die $DBI::errstr;  sub _log {
88            print strftime($TIMESTAMP,localtime()), ' ', join(" ",@_), $/;
89    }
90    
91  =for SQL schema  my $dbh = DBI->connect($DSN,"","", { RaiseError => 1, AutoCommit => 1 }) || die $DBI::errstr;
92    
93  $dbh->do(qq{  my $sql_schema = {
94            log => '
95  create table log (  create table log (
96          id serial,          id serial,
97          time timestamp default now(),          time timestamp default now(),
98          channel text not null,          channel text not null,
99            me boolean default false,
100          nick text not null,          nick text not null,
101          message text not null,          message text not null,
102          primary key(id)          primary key(id)
# Line 60  create table log ( Line 105  create table log (
105  create index log_time on log(time);  create index log_time on log(time);
106  create index log_channel on log(channel);  create index log_channel on log(channel);
107  create index log_nick on log(nick);  create index log_nick on log(nick);
108            ',
109            meta => '
110    create table meta (
111            nick text not null,
112            channel text not null,
113            name text not null,
114            value text,
115            changed timestamp default now(),
116            primary key(nick,channel,name)
117    );
118            ',
119    };
120    
121  });  foreach my $table ( keys %$sql_schema ) {
122    
123            eval {
124                    $dbh->do(qq{ select count(*) from $table });
125            };
126    
127            if ($@) {
128                    warn "creating database table $table in $DSN\n";
129                    $dbh->do( $sql_schema->{ $table } );
130            }
131    }
132    
133    
134    =head2 meta
135    
136    Set or get some meta data into database
137    
138            meta('nick','channel','var_name', $var_value );
139    
140            $var_value = meta('nick','channel','var_name');
141            ( $var_value, $changed ) = meta('nick','channel','var_name');
142    
143  =cut  =cut
144    
145    sub meta {
146            my ($nick,$channel,$name,$value) = @_;
147    
148            # normalize channel name
149            $channel =~ s/^#//;
150    
151            if (defined($value)) {
152    
153                    my $sth = $dbh->prepare(qq{ update meta set value = ?, changed = now() where nick = ? and channel = ? and name = ? });
154    
155                    eval { $sth->execute( $value, $nick, $channel, $name ) };
156    
157                    # error or no result
158                    if ( $@ || ! $sth->rows ) {
159                            $sth = $dbh->prepare(qq{ insert into meta (value,nick,channel,name,changed) values (?,?,?,?,now()) });
160                            $sth->execute( $value, $nick, $channel, $name );
161                            _log "created $nick/$channel/$name = $value";
162                    } else {
163                            _log "updated $nick/$channel/$name = $value ";
164                    }
165    
166                    return $value;
167    
168            } else {
169    
170                    my $sth = $dbh->prepare(qq{ select value,changed from meta where nick = ? and channel = ? and name = ? });
171                    $sth->execute( $nick, $channel, $name );
172                    my ($v,$c) = $sth->fetchrow_array;
173                    _log "fetched $nick/$channel/$name = $v [$c]";
174                    return ($v,$c) if wantarray;
175                    return $v;
176    
177            }
178    }
179    
180    
181    
182  my $sth = $dbh->prepare(qq{  my $sth = $dbh->prepare(qq{
183  insert into log  insert into log
184          (channel, nick, message)          (channel, me, nick, message, time)
185  values (?,?,?)  values (?,?,?,?,?)
186  });  });
187    
188    
189    my $tags;
190    my $tag_regex = '\b([\w-_]+)//';
191    
192    =head2 get_from_log
193    
194     my @messages = get_from_log(
195            limit => 42,
196            search => '%what to stuff in ilike%',
197            fmt => {
198                    time => '{%s} ',
199                    time_channel => '{%s %s} ',
200                    nick => '%s: ',
201                    me_nick => '***%s ',
202                    message => '%s',
203            },
204            filter => {
205                    message => sub {
206                            # modify message content
207                            return shift;
208                    }
209            },
210            context => 5,
211            full_rows => 1,
212     );
213    
214    Order is important. Fields are first passed through C<filter> (if available) and
215    then throgh C<< sprintf($fmt->{message}, $message >> if available.
216    
217    C<context> defines number of messages around each search hit for display.
218    
219    C<full_rows> will return database rows for each result with C<date>, C<time>, C<channel>,
220    C<me>, C<nick> and C<message> keys.
221    
222    =cut
223    
224    sub get_from_log {
225            my $args = {@_};
226    
227            $args->{fmt} ||= {
228                    date => '[%s] ',
229                    time => '{%s} ',
230                    time_channel => '{%s %s} ',
231                    nick => '%s: ',
232                    me_nick => '***%s ',
233                    message => '%s',
234            };
235    
236            my $sql_message = qq{
237                    select
238                            time::date as date,
239                            time::time as time,
240                            channel,
241                            me,
242                            nick,
243                            message
244                    from log
245            };
246    
247            my $sql_context = qq{
248                    select
249                            id
250                    from log
251            };
252    
253            my $context = $1 if ($args->{search} && $args->{search} =~ s/\s*\+(\d+)\s*/ /);
254    
255            my $sql = $context ? $sql_context : $sql_message;
256    
257            $sql .= " where message ilike ? or nick ilike ? " if ($args->{search});
258            $sql .= " where id in (" . join(",", @{ $tags->{ $args->{tag} } }) . ") " if ($args->{tag} && $tags->{ $args->{tag} });
259            $sql .= " where date(time) = ? " if ($args->{date});
260            $sql .= " order by log.time desc";
261            $sql .= " limit " . $args->{limit} if ($args->{limit});
262    
263            my $sth = $dbh->prepare( $sql );
264            if (my $search = $args->{search}) {
265                    $search =~ s/^\s+//;
266                    $search =~ s/\s+$//;
267                    $sth->execute( ( '%' . $search . '%' ) x 2 );
268                    _log "search for '$search' returned ", $sth->rows, " results ", $context || '';
269            } elsif (my $tag = $args->{tag}) {
270                    $sth->execute();
271                    _log "tag '$tag' returned ", $sth->rows, " results ", $context || '';
272            } elsif (my $date = $args->{date}) {
273                    $sth->execute($date);
274                    _log "found ", $sth->rows, " messages for date $date ", $context || '';
275            } else {
276                    $sth->execute();
277            }
278            my $last_row = {
279                    date => '',
280                    time => '',
281                    channel => '',
282                    nick => '',
283            };
284    
285            my @rows;
286    
287            while (my $row = $sth->fetchrow_hashref) {
288                    unshift @rows, $row;
289            }
290    
291            # normalize nick names
292            map {
293                    $_->{nick} =~ s/^_*(.*?)_*$/$1/
294            } @rows;
295    
296            return @rows if ($args->{full_rows});
297    
298            my @msgs = (
299                    "Showing " . ($#rows + 1) . " messages..."
300            );
301    
302            if ($context) {
303                    my @ids = @rows;
304                    @rows = ();
305    
306                    my $last_to = 0;
307    
308                    my $sth = $dbh->prepare( $sql_message . qq{ where id >= ? and id < ? } );
309                    foreach my $row_id (sort { $a->{id} <=> $b->{id} } @ids) {
310                            my $id = $row_id->{id} || die "can't find id in row";
311            
312                            my ($from, $to) = ($id - $context, $id + $context);
313                            $from = $last_to if ($from < $last_to);
314                            $last_to = $to;
315                            $sth->execute( $from, $to );
316    
317                            #warn "## id: $id from: $from to: $to returned: ", $sth->rows, "\n";
318    
319                            while (my $row = $sth->fetchrow_hashref) {
320                                    push @rows, $row;
321                            }
322    
323                    }
324            }
325    
326            # sprintf which can take coderef as first parametar
327            sub cr_sprintf {
328                    my $fmt = shift || return;
329                    if (ref($fmt) eq 'CODE') {
330                            $fmt->(@_);
331                    } else {
332                            sprintf($fmt, @_);
333                    }
334            }
335    
336            foreach my $row (@rows) {
337    
338                    $row->{time} =~ s#\.\d+##;
339    
340                    my $msg = '';
341    
342                    $msg = cr_sprintf($args->{fmt}->{date}, $row->{date}) . ' ' if ($last_row->{date} ne $row->{date});
343                    my $t = $row->{time};
344    
345                    if ($last_row->{channel} ne $row->{channel}) {
346                            $msg .= cr_sprintf($args->{fmt}->{time_channel}, $t, $row->{channel});
347                    } else {
348                            $msg .= cr_sprintf($args->{fmt}->{time}, $t);
349                    }
350    
351                    my $append = 1;
352    
353                    my $nick = $row->{nick};
354    #               if ($nick =~ s/^_*(.*?)_*$/$1/) {
355    #                       $row->{nick} = $nick;
356    #               }
357    
358                    if ($last_row->{nick} ne $nick) {
359                            # obfu way to find format for me_nick if needed or fallback to default
360                            my $fmt = $row->{me} ? ( $args->{fmt}->{me_nick} || $args->{fmt}->{nick} ) : $args->{fmt}->{nick};
361                            $fmt ||= '%s';
362    
363                            $nick = $args->{filter}->{nick}->($nick) if (ref($args->{filter}->{nick}) eq 'CODE');
364    
365                            $msg .= cr_sprintf( $fmt, $nick );
366                            $append = 0;
367                    }
368    
369                    $args->{fmt}->{message} ||= '%s';
370                    if (ref($args->{filter}->{message}) eq 'CODE') {
371                            $msg .= cr_sprintf($args->{fmt}->{message},
372                                    $args->{filter}->{message}->(
373                                            $row->{message}
374                                    )
375                            );
376                    } else {
377                            $msg .= cr_sprintf($args->{fmt}->{message}, $row->{message});
378                    }
379    
380                    if ($append && @msgs) {
381                            $msgs[$#msgs] .= " " . $msg;
382                    } else {
383                            push @msgs, $msg;
384                    }
385    
386                    $last_row = $row;
387            }
388    
389            return @msgs;
390    }
391    
392    # tags support
393    
394    my $cloud = HTML::TagCloud->new;
395    
396    =head2 add_tag
397    
398     add_tag( id => 42, message => 'irc message' );
399    
400    =cut
401    
402    sub add_tag {
403            my $arg = {@_};
404    
405            return unless ($arg->{id} && $arg->{message});
406    
407            my $m = $arg->{message};
408            from_to('UTF-8', 'iso-8859-2', $m) if (is_utf8($m));
409    
410            while ($m =~ s#$tag_regex##s) {
411                    my $tag = $1;
412                    next if (! $tag || $tag =~ m/https?:/i);
413                    push @{ $tags->{$tag} }, $arg->{id};
414                    #warn "+tag $tag: $arg->{id}\n";
415                    $cloud->add($tag, "?tag=$tag", scalar @{$tags->{$tag}} + 1);
416            }
417    }
418    
419    =head2 seed_tags
420    
421    Read all tags from database and create in-memory cache for tags
422    
423    =cut
424    
425    sub seed_tags {
426            my $sth = $dbh->prepare(qq{ select id,message from log where message like '%//%' });
427            $sth->execute;
428            while (my $row = $sth->fetchrow_hashref) {
429                    add_tag( %$row );
430            }
431    
432            foreach my $tag (keys %$tags) {
433                    $cloud->add($tag, "?tag=$tag", scalar @{$tags->{$tag}} + 1);
434            }
435    }
436    
437    seed_tags;
438    
439    
440    =head2 save_message
441    
442      save_message(
443            channel => '#foobar',
444            me => 0,
445            nick => 'dpavlin',
446            msg => 'test message',
447            time => '2006-06-25 18:57:18',
448      );
449    
450    C<time> is optional, it will use C<< now() >> if it's not available.
451    
452    C<me> if not specified will be C<0> (not C</me> message)
453    
454    =cut
455    
456    sub save_message {
457            my $a = {@_};
458            $a->{me} ||= 0;
459            $a->{time} ||= strftime($TIMESTAMP,localtime());
460    
461            _log
462                    $a->{channel}, " ",
463                    $a->{me} ? "***" . $a->{nick} : "<" . $a->{nick} . ">",
464                    " " . $a->{msg};
465    
466            from_to($a->{msg}, 'UTF-8', $ENCODING);
467    
468            $sth->execute($a->{channel}, $a->{me}, $a->{nick}, $a->{msg}, $a->{time});
469            add_tag( id => $dbh->last_insert_id(undef,undef,"log",undef),
470                    message => $a->{msg});
471    }
472    
473    
474    if ($import_dircproxy) {
475            open(my $l, $import_dircproxy) || die "can't open $import_dircproxy: $!";
476            warn "importing $import_dircproxy...\n";
477            my $tz_offset = 2 * 60 * 60;    # TZ GMT+2
478            while(<$l>) {
479                    chomp;
480                    if (/^@(\d+)\s(\S+)\s(.+)$/) {
481                            my ($time, $nick, $msg) = ($1,$2,$3);
482    
483                            my $dt = DateTime->from_epoch( epoch => $time + $tz_offset );
484    
485                            my $me = 0;
486                            $me = 1 if ($nick =~ m/^\[\S+]/);
487                            $nick =~ s/^[\[<]([^!]+).*$/$1/;
488    
489                            $msg =~ s/^ACTION\s+// if ($me);
490    
491                            save_message(
492                                    channel => $CHANNEL,
493                                    me => $me,
494                                    nick => $nick,
495                                    msg => $msg,
496                                    time => $dt->ymd . " " . $dt->hms,
497                            ) if ($nick !~ m/^-/);
498    
499                    } else {
500                            _log "can't parse: $_";
501                    }
502            }
503            close($l);
504            warn "import over\n";
505            exit;
506    }
507    
508    
509    #
510    # POE handing part
511    #
512    
513  my $SKIPPING = 0;               # if skipping, how many we've done  my $SKIPPING = 0;               # if skipping, how many we've done
514  my $SEND_QUEUE;                 # cache  my $SEND_QUEUE;                 # cache
515    my $ping;                                               # ping stats
516    
517  POE::Component::IRC->new($IRC_ALIAS);  POE::Component::IRC->new($IRC_ALIAS);
518    
519  POE::Session->create  POE::Session->create( inline_states =>
   (inline_states =>  
520     {_start => sub {           {_start => sub {      
521        $_[KERNEL]->post($IRC_ALIAS => register => 'all');                  $_[KERNEL]->post($IRC_ALIAS => register => 'all');
522        $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);                  $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);
523      },      },
524      irc_255 => sub {            # server is done blabbing      irc_255 => sub {    # server is done blabbing
525        $_[KERNEL]->post($IRC_ALIAS => join => $CHANNEL);                  $_[KERNEL]->post($IRC_ALIAS => join => $CHANNEL);
526        $_[KERNEL]->post($IRC_ALIAS => join => '#logger');                  $_[KERNEL]->post($IRC_ALIAS => join => '#logger');
527        $_[KERNEL]->yield("heartbeat"); # start heartbeat                  $_[KERNEL]->yield("heartbeat"); # start heartbeat
528  #      $_[KERNEL]->yield("my_add", $_) for keys %FOLLOWS;  #               $_[KERNEL]->yield("my_add", $_) for keys %FOLLOWS;
529                    $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );
530      },      },
531      irc_public => sub {      irc_public => sub {
532            my $kernel = $_[KERNEL];                  my $kernel = $_[KERNEL];
533            my $nick = (split /!/, $_[ARG0])[0];                  my $nick = (split /!/, $_[ARG0])[0];
534            my $channel = $_[ARG1]->[0];                  my $channel = $_[ARG1]->[0];
535            my $msg = $_[ARG2];                  my $msg = $_[ARG2];
536    
537            print "$channel: <$nick> $msg\n";                  save_message( channel => $channel, me => 0, nick => $nick, msg => $msg);
538            $sth->execute($channel, $nick, $msg);                  meta( $nick, $channel, 'last-msg', $msg );
539      },      },
540      (map      irc_ctcp_action => sub {
541       {                  my $kernel = $_[KERNEL];
542         ;"irc_$_" => sub { }}                  my $nick = (split /!/, $_[ARG0])[0];
543       qw(join                  my $channel = $_[ARG1]->[0];
544          ctcp_version                  my $msg = $_[ARG2];
545          connected snotice ctcp_action ping notice mode part quit  
546          001 002 003 004 005                  save_message( channel => $channel, me => 1, nick => $nick, msg => $msg);
547          250 251 252 253 254 265 266  
548          332 333 353 366 372 375 376                  if ( my $twitter = ( $nick, $channel, 'twitter' ) ) {
549                  477                          _log("FIXME: send twitter for $nick on $channel [$twitter]");
550                  )),                  }
551    
552        },
553            irc_ping => sub {
554                    warn "pong ", $_[ARG0], $/;
555                    $ping->{ $_[ARG0] }++;
556            },
557            irc_invite => sub {
558                    my $kernel = $_[KERNEL];
559                    my $nick = (split /!/, $_[ARG0])[0];
560                    my $channel = $_[ARG1];
561    
562                    warn "invited to $channel by $nick";
563    
564                    $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, "how nice of you to invite me to $channel, I'll be right there..." );
565                    $_[KERNEL]->post($IRC_ALIAS => join => $channel);
566    
567            },
568            irc_msg => sub {
569                    my $kernel = $_[KERNEL];
570                    my $nick = (split /!/, $_[ARG0])[0];
571                    my $msg = $_[ARG2];
572                    my $channel = $_[ARG1]->[0];
573                    from_to($msg, 'UTF-8', $ENCODING);
574    
575                    my $res = "unknown command '$msg', try /msg $NICK help!";
576                    my @out;
577    
578                    _log "<< $msg";
579    
580                    if ($msg =~ m/^help/i) {
581    
582                            $res = "usage: /msg $NICK comand | commands: stat - user/message stat | last - show backtrace | grep foobar - find foobar";
583    
584                    } elsif ($msg =~ m/^msg\s+(\S+)\s+(.*)$/i) {
585    
586                            _log ">> /msg $1 $2";
587                            $_[KERNEL]->post( $IRC_ALIAS => privmsg => $1, $2 );
588                            $res = '';
589    
590                    } elsif ($msg =~ m/^stat.*?\s*(\d*)/i) {
591    
592                            my $nr = $1 || 10;
593    
594                            my $sth = $dbh->prepare(qq{
595                                    select
596                                            nick,
597                                            count(*) as count,
598                                            sum(length(message)) as len
599                                    from log
600                                    group by nick
601                                    order by len desc,count desc
602                                    limit $nr
603                            });
604                            $sth->execute();
605                            $res = "Top $nr users: ";
606                            my @users;
607                            while (my $row = $sth->fetchrow_hashref) {
608                                    push @users,$row->{nick} . ': ' . $row->{count} . '/' . $row->{len} . '=' . sprintf("%.2f", $row->{len}/$row->{count});
609                            }
610                            $res .= join(" | ", @users);
611                    } elsif ($msg =~ m/^last.*?\s*(\d*)/i) {
612    
613                            my $limit = $1 || meta( $nick, $channel, 'last-size' ) || 10;
614    
615                            foreach my $res (get_from_log( limit => $limit )) {
616                                    _log "last: $res";
617                                    from_to($res, $ENCODING, 'UTF-8');
618                                    $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );
619                            }
620    
621                            $res = '';
622    
623                    } elsif ($msg =~ m/^(search|grep)\s+(.*)\s*$/i) {
624    
625                            my $what = $2;
626    
627                            foreach my $res (get_from_log(
628                                            limit => 20,
629                                            search => $what,
630                                    )) {
631                                    _log "search [$what]: $res";
632                                    from_to($res, $ENCODING, 'UTF-8');
633                                    $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );
634                            }
635    
636                            $res = '';
637    
638                    } elsif ($msg =~ m/^(?:count|poll)\s+(.*)(?:\s+(\d+))?\s*$/i) {
639    
640                            my ($what,$limit) = ($1,$2);
641                            $limit ||= 100;
642    
643                            my $stat;
644    
645                            foreach my $res (get_from_log(
646                                            limit => $limit,
647                                            search => $what,
648                                            full_rows => 1,
649                                    )) {
650                                    while ($res->{message} =~ s/\Q$what\E(\+|\-)//) {
651                                            $stat->{vote}->{$1}++;
652                                            $stat->{from}->{ $res->{nick} }++;
653                                    }
654                            }
655    
656                            my @nicks;
657                            foreach my $nick (sort { $stat->{from}->{$a} <=> $stat->{from}->{$b} } keys %{ $stat->{from} }) {
658                                    push @nicks, $nick . ( $stat->{from}->{$nick} == 1 ? '' :
659                                            "(" . $stat->{from}->{$nick} . ")"
660                                    );
661                            }
662    
663                            $res =
664                                    "$what ++ " . ( $stat->{vote}->{'+'} || 0 ) .
665                                    " : " . ( $stat->{vote}->{'-'} || 0 ) . " --" .
666                                    " from " . ( join(", ", @nicks) || 'nobody' );
667    
668                            $_[KERNEL]->post( $IRC_ALIAS => notice => $nick, $res );
669    
670                    } elsif ($msg =~ m/^ping/) {
671                            $res = "ping = " . dump( $ping );
672                    } elsif ($msg =~ m/^(?:twitter)\s+(\S+)\s+(.*?)/) {
673                            if ( defined( $2 ) ) {
674                                    meta($nick, $channel, 'twitter', "$1\t$2");
675                                    $res = "saved twitter auth for $1 -- /me on $channel will auto-update twitter status";
676                            } else {
677                                    meta($nick, $channel, 'twitter', '' );
678                                    $res = "removed twitter status update for /me on $channel";
679                            }
680                    } elsif ($msg =~ m/^conf(?:ig)*\s*(last-size)*\s*(\d*)/) {
681                            if ( ! defined( $1 ) ) {
682                                    my $sth = $dbh->prepare(qq{ select name,value,changed from meta where nick = ? and channel = ? });
683                                    $sth->execute( $nick, $channel );
684                                    $res = "config for $nick ";
685                                    while ( my ($n,$v) = $sth->fetchrow_array ) {
686                                            $res .= "| $n = $v";
687                                    }
688                            } elsif ( defined( $2 ) ) {
689                                    meta( $nick, $channel, $1, $2 );
690                                    $res = "saved $1 = $2";
691                            } else {
692                                    my $val = meta( $nick, $channel, $1 );
693                                    $res = "current $1 = " . ( $val ? $val : 'undefined' );
694                            }
695                    }
696    
697                    if ($res) {
698                            _log ">> [$nick] $res";
699                            from_to($res, $ENCODING, 'UTF-8');
700                            $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );
701                    }
702    
703            },
704            irc_477 => sub {
705                    _log "# irc_477: ",$_[ARG1];
706                    $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "register $NICK" );
707            },
708            irc_505 => sub {
709                    _log "# irc_505: ",$_[ARG1];
710                    $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "register $NICK" );
711    #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "set hide email on" );
712    #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "set email dpavlin\@rot13.org" );
713            },
714            irc_registered => sub {
715                    _log "## registrated $NICK";
716                    $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );
717            },
718            irc_disconnected => sub {
719                    _log "## disconnected, reconnecting again";
720                    $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);
721            },
722            irc_socketerr => sub {
723                    _log "## socket error... sleeping for $sleep_on_error seconds and retry";
724                    sleep($sleep_on_error);
725                    $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);
726            },
727    #       irc_433 => sub {
728    #               print "# irc_433: ",$_[ARG1], "\n";
729    #               warn "## indetify $NICK\n";
730    #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );
731    #       },
732      _child => sub {},      _child => sub {},
733      _default => sub {      _default => sub {
734        printf "%s: session %s caught an unhandled %s event.\n",                  _log sprintf "sID:%s %s %s",
735          scalar localtime(), $_[SESSION]->ID, $_[ARG0];                          $_[SESSION]->ID, $_[ARG0],
736        print "The $_[ARG0] event was given these parameters: ",                          ref($_[ARG1]) eq "ARRAY"        ?       join(",", map { ref($_) eq "ARRAY" ? join(";", @{$_}) : $_ } @{ $_[ARG1] })     :
737          join(" ", map({"ARRAY" eq ref $_ ? "[@$_]" : "$_"} @{$_[ARG1]})), "\n";                          $_[ARG1]                                        ?       $_[ARG1]                                        :
738                            "";
739        0;                        # false for signals        0;                        # false for signals
740      },      },
741      my_add => sub {      my_add => sub {
# Line 180  POE::Session->create Line 801  POE::Session->create
801     },     },
802    );    );
803    
804    # http server
805    
806    my $httpd = POE::Component::Server::HTTP->new(
807            Port => $NICK =~ m/-dev/ ? 8001 : 8000,
808            ContentHandler => { '/' => \&root_handler },
809            Headers        => { Server => 'irc-logger' },
810    );
811    
812    my %escape = ('<'=>'&lt;', '>'=>'&gt;', '&'=>'&amp;', '"'=>'&quot;');
813    my $escape_re  = join '|' => keys %escape;
814    
815    my $style = <<'_END_OF_STYLE_';
816    p { margin: 0; padding: 0.1em; }
817    .time, .channel { color: #808080; font-size: 60%; }
818    .date { float: right; background: #e0e0e0; color: #404040; font-size: 120%; padding: 0.25em; border: 1px dashed #808080; }
819    .nick { color: #000000; font-size: 80%; padding: 2px; font-family: courier, courier new, monospace ; }
820    .message { color: #000000; font-size: 100%; }
821    .search { float: right; }
822    .col-0 { background: #ffff66 }
823    .col-1 { background: #a0ffff }
824    .col-2 { background: #99ff99 }
825    .col-3 { background: #ff9999 }
826    .col-4 { background: #ff66ff }
827    a:link.tag, a:visited.tag { border: 1px dashed #ccc; backgound: #ccc; text-decoration: none }
828    a:hover.tag { border: 1px solid #eee }
829    hr { border: 1px dashed #ccc; height: 1px; clear: both; }
830    _END_OF_STYLE_
831    
832    my $max_color = 4;
833    
834    my %nick_enumerator;
835    
836    sub root_handler {
837            my ($request, $response) = @_;
838            $response->code(RC_OK);
839            $response->content_type("text/html; charset=$ENCODING");
840    
841            my $q;
842    
843            if ( $request->method eq 'POST' ) {
844                    $q = new CGI::Simple( $request->content );
845            } elsif ( $request->uri =~ /\?(.+)$/ ) {
846                    $q = new CGI::Simple( $1 );
847            } else {
848                    $q = new CGI::Simple;
849            }
850    
851            my $search = $q->param('search') || $q->param('grep') || '';
852    
853            my $html =
854                    qq{<html><head><title>$NICK</title><style type="text/css">$style} .
855                    $cloud->css .
856                    qq{</style></head><body>} .
857                    qq{
858                    <form method="post" class="search" action="/">
859                    <input type="text" name="search" value="$search" size="10">
860                    <input type="submit" value="search">
861                    </form>
862                    } .
863                    $cloud->html(500) .
864                    qq{<p>};
865            if ($request->url =~ m#/history#) {
866                    my $sth = $dbh->prepare(qq{
867                            select date(time) as date,count(*) as nr
868                                    from log
869                                    group by date(time)
870                                    order by date(time) desc
871                    });
872                    $sth->execute();
873                    my ($l_yyyy,$l_mm) = (0,0);
874                    my $cal;
875                    while (my $row = $sth->fetchrow_hashref) {
876                            # this is probably PostgreSQL specific, expects ISO date
877                            my ($yyyy,$mm,$dd) = split(/-/, $row->{date});
878                            if ($yyyy != $l_yyyy || $mm != $l_mm) {
879                                    $html .= $cal->as_HTML() if ($cal);
880                                    $cal = new HTML::CalendarMonthSimple('month'=>$mm,'year'=>$yyyy);
881                                    $cal->border(2);
882                                    ($l_yyyy,$l_mm) = ($yyyy,$mm);
883                            }
884                            $cal->setcontent($dd, qq{
885                                    <a href="/?date=$row->{date}">$row->{nr}</a>
886                            });
887                    }
888                    $html .= $cal->as_HTML() if ($cal);
889    
890            } else {
891                    $html .= join("</p><p>",
892                            get_from_log(
893                                    limit => $q->param('last') || $q->param('date') ? undef : 100,
894                                    search => $search || undef,
895                                    tag => $q->param('tag') || undef,
896                                    date => $q->param('date') || undef,
897                                    fmt => {
898                                            date => sub {
899                                                    my $date = shift || return;
900                                                    qq{<hr/><div class="date"><a href="/?date=$date">$date</a></div>};
901                                            },
902                                            time => '<span class="time">%s</span> ',
903                                            time_channel => '<span class="channel">%s %s</span> ',
904                                            nick => '%s:&nbsp;',
905                                            me_nick => '***%s&nbsp;',
906                                            message => '<span class="message">%s</span>',
907                                    },
908                                    filter => {
909                                            message => sub {
910                                                    my $m = shift || return;
911                                                    $m =~ s/($escape_re)/$escape{$1}/gs;
912                                                    $m =~ s#($RE{URI}{HTTP})#<a href="$1">$1</a>#gs;
913                                                    $m =~ s#$tag_regex#<a href="?tag=$1" class="tag">$1</a>#g;
914                                                    return $m;
915                                            },
916                                            nick => sub {
917                                                    my $n = shift || return;
918                                                    if (! $nick_enumerator{$n})  {
919                                                            my $max = scalar keys %nick_enumerator;
920                                                            $nick_enumerator{$n} = $max + 1;
921                                                    }
922                                                    return '<span class="nick col-' .
923                                                            ( $nick_enumerator{$n} % $max_color ) .
924                                                            '">' . $n . '</span>';
925                                            },
926                                    },
927                            )
928                    );
929            }
930    
931            $html .= qq{</p>
932            <hr/>
933            <p>See <a href="/history">history</a> of all messages.</p>
934            </body></html>};
935    
936            $response->content( $html );
937            return RC_OK;
938    }
939    
940  POE::Kernel->run;  POE::Kernel->run;

Legend:
Removed from v.5  
changed lines
  Added in v.50

  ViewVC Help
Powered by ViewVC 1.1.26