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

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

  ViewVC Help
Powered by ViewVC 1.1.26