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