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