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