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