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