/[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 10 by dpavlin, Thu Mar 2 00:19:12 2006 UTC trunk/bin/irc-logger.pl revision 52 by dpavlin, Sun Mar 18 16:45:18 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';
57    my $TIMESTAMP = '%Y-%m-%d %H:%M:%S';
58    
59    my $sleep_on_error = 5;
60    
61  ## END CONFIG  ## END CONFIG
62    
63    
64    
65  use POE qw(Component::IRC Wheel::FollowTail);  use POE qw(Component::IRC Wheel::FollowTail Component::Server::HTTP);
66    use HTTP::Status;
67  use DBI;  use DBI;
68  use Encode qw/from_to/;  use Encode qw/from_to is_utf8/;
69    use Regexp::Common qw /URI/;
70    use CGI::Simple;
71    use HTML::TagCloud;
72    use POSIX qw/strftime/;
73    use HTML::CalendarMonthSimple;
74    use Getopt::Long;
75    use DateTime;
76    use Data::Dump qw/dump/;
77    
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 61  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
193    
194     my @messages = get_from_log(
195            limit => 42,
196            search => '%what to stuff in ilike%',
197            fmt => {
198                    time => '{%s} ',
199                    time_channel => '{%s %s} ',
200                    nick => '%s: ',
201                    me_nick => '***%s ',
202                    message => '%s',
203            },
204            filter => {
205                    message => sub {
206                            # 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
223    
224    sub get_from_log {
225            my $args = {@_};
226    
227            $args->{fmt} ||= {
228                    date => '[%s] ',
229                    time => '{%s} ',
230                    time_channel => '{%s %s} ',
231                    nick => '%s: ',
232                    me_nick => '***%s ',
233                    message => '%s',
234            };
235    
236            my $sql_message = qq{
237                    select
238                            time::date as date,
239                            time::time as time,
240                            channel,
241                            me,
242                            nick,
243                            message
244                    from log
245            };
246    
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";
261            $sql .= " limit " . $args->{limit} if ($args->{limit});
262    
263            my $sth = $dbh->prepare( $sql );
264            if (my $search = $args->{search}) {
265                    $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 {
276                    $sth->execute();
277            }
278            my $last_row = {
279                    date => '',
280                    time => '',
281                    channel => '',
282                    nick => '',
283            };
284    
285            my @rows;
286    
287            while (my $row = $sth->fetchrow_hashref) {
288                    unshift @rows, $row;
289            }
290    
291            # 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) {
337    
338                    $row->{time} =~ s#\.\d+##;
339    
340                    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}) {
346                            $msg .= cr_sprintf($args->{fmt}->{time_channel}, $t, $row->{channel});
347                    } else {
348                            $msg .= cr_sprintf($args->{fmt}->{time}, $t);
349                    }
350    
351                    my $append = 1;
352    
353                    my $nick = $row->{nick};
354    #               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;
367                    }
368    
369                    $args->{fmt}->{message} ||= '%s';
370                    if (ref($args->{filter}->{message}) eq 'CODE') {
371                            $msg .= cr_sprintf($args->{fmt}->{message},
372                                    $args->{filter}->{message}->(
373                                            $row->{message}
374                                    )
375                            );
376                    } else {
377                            $msg .= cr_sprintf($args->{fmt}->{message}, $row->{message});
378                    }
379    
380                    if ($append && @msgs) {
381                            $msgs[$#msgs] .= " " . $msg;
382                    } else {
383                            push @msgs, $msg;
384                    }
385    
386                    $last_row = $row;
387            }
388    
389            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 89  POE::Session->create Line 526  POE::Session->create
526                  $_[KERNEL]->post($IRC_ALIAS => join => '#logger');                  $_[KERNEL]->post($IRC_ALIAS => join => '#logger');
527                  $_[KERNEL]->yield("heartbeat"); # start heartbeat                  $_[KERNEL]->yield("heartbeat"); # start heartbeat
528  #               $_[KERNEL]->yield("my_add", $_) for keys %FOLLOWS;  #               $_[KERNEL]->yield("my_add", $_) for keys %FOLLOWS;
529                    $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );
530      },      },
531      irc_public => sub {      irc_public => sub {
532                  my $kernel = $_[KERNEL];                  my $kernel = $_[KERNEL];
# Line 96  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', 'ISO-8859-2');                  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                  from_to($msg, 'UTF-8', 'ISO-8859-2');                  my $channel = $_[ARG1]->[0];
573                    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;
577    
578                  print "<< $msg\n";                  _log "<< $msg";
579    
580                  if ($msg =~ m/^help/i) {                  if ($msg =~ m/^help/i) {
581    
582                          $res = "usage: /msg $NICK stat - shows user statistics | /msg $NICK last - show backtrace of conversations";                          $res = "usage: /msg $NICK comand | commands: stat - user/message stat | last - show backtrace | grep foobar - find foobar";
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 126  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                          my $nr = $1 || 10;                          my $limit = $1 || meta( $nick, $channel, 'last-size' ) || 10;
614    
615                          my $sth = $dbh->prepare(qq{                          foreach my $res (get_from_log( limit => $limit )) {
616                                  select                                  _log "last: $res";
617                                          time::date as date,                                  from_to($res, $ENCODING, 'UTF-8');
618                                          time::time as time,                                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );
                                         channel,  
                                         nick,  
                                         message  
                                 from log order by log.time desc limit $nr  
                         });  
                         $sth->execute();  
                         $res = "Last $nr messages: ";  
                         my $last_row = {  
                                 date => '',  
                                 time => '',  
                                 channel => '',  
                                 nick => '',  
                         };  
   
                         my @rows;  
   
                         while (my $row = $sth->fetchrow_hashref) {  
                                 unshift @rows, $row;  
619                          }                          }
620    
621                          my @msgs;                          $res = '';
   
                         foreach my $row (@rows) {  
622    
623                                  $row->{time} =~ s#\.\d+##;                  } elsif ($msg =~ m/^(search|grep)\s+(.*)\s*$/i) {
624    
625                                  my $t;                          my $what = $2;
                                 $t = $row->{date} . ' ' if ($last_row->{date} ne $row->{date});  
                                 $t .= $row->{time};  
626    
627                                  my $msg = '';                          foreach my $res (get_from_log(
628                                            limit => 20,
629                                            search => $what,
630                                    )) {
631                                    _log "search [$what]: $res";
632                                    from_to($res, $ENCODING, 'UTF-8');
633                                    $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );
634                            }
635    
636                                  $msg .= "($t";                          $res = '';
                                 $msg .= ' ' . $row->{channel} if ($last_row->{channel} ne $row->{channel});  
                                 $msg .= ") ";  
637    
638                                  $msg .= $row->{nick} . ': '  if ($last_row->{nick} ne $row->{nick});                  } elsif ($msg =~ m/^(?:count|poll)\s+(.*)(?:\s+(\d+))?\s*$/i) {
639    
640                                  $msg .= $row->{message};                          my ($what,$limit) = ($1,$2);
641                            $limit ||= 100;
642    
643                                  push @msgs, $msg;                          my $stat;
644    
645                                  $last_row = $row;                          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                          foreach my $res (@msgs) {                          my @nicks;
657                                  print "last: $res\n";                          foreach my $nick (sort { $stat->{from}->{$a} <=> $stat->{from}->{$b} } keys %{ $stat->{from} }) {
658                                  from_to($res, 'ISO-8859-2', 'UTF-8');                                  push @nicks, $nick . ( $stat->{from}->{$nick} == 1 ? '' :
659                                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );                                          "(" . $stat->{from}->{$nick} . ")"
660                                    );
661                          }                          }
662    
663                          $res = '';                          $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/^conf(?:ig)*\s*(last-size|twitter)*\s*(.*)/) {
673                            if ( ! defined( $1 ) ) {
674                                    my $sth = $dbh->prepare(qq{ select name,value,changed from meta where nick = ? and channel = ? });
675                                    $sth->execute( $nick, $channel );
676                                    $res = "config for $nick on $channel";
677                                    while ( my ($n,$v) = $sth->fetchrow_array ) {
678                                            $res .= " | $n = $v";
679                                    }
680                            } elsif ( ! $2 ) {
681                                    my $val = meta( $nick, $channel, $1 );
682                                    $res = "current $1 = " . ( $val ? $val : 'undefined' );
683                            } else {
684                                    my $validate = {
685                                            'last-size' => qr/^\d+/,
686                                            'twitter' => qr/^\w+\s+\w+/,
687                                    };
688    
689                                    my ( $op, $val ) = ( $1, $2 );
690    
691                                    if ( my $regex = $validate->{$op} ) {
692                                            if ( $val =~ $regex ) {
693                                                    meta( $nick, $channel, $op, $val );
694                                                    $res = "saved $op = $val";
695                                            } else {
696                                                    $res = "config option $op = $val doesn't validate against $regex";
697                                            }
698                                    } else {
699                                            $res = "config option $op doesn't exist";
700                                    }
701                            }
702                  }                  }
703    
704                  if ($res) {                  if ($res) {
705                          print ">> [$nick] $res\n";                          _log ">> [$nick] $res";
706                          from_to($res, 'ISO-8859-2', 'UTF-8');                          from_to($res, $ENCODING, 'UTF-8');
707                          $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );                          $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );
708                  }                  }
709    
710          },          },
711          irc_477 => sub {          irc_477 => sub {
712                  print "# irc_477: ",$_[ARG1], "\n";                  _log "# irc_477: ",$_[ARG1];
713                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "register $NICK" );                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "register $NICK" );
714          },          },
715          irc_505 => sub {          irc_505 => sub {
716                  print "# irc_505: ",$_[ARG1], "\n";                  _log "# irc_505: ",$_[ARG1];
717                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "register $NICK" );                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "register $NICK" );
718  #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "set hide email on" );  #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "set hide email on" );
719  #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "set email dpavlin\@rot13.org" );  #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "set email dpavlin\@rot13.org" );
720          },          },
721          irc_registered => sub {          irc_registered => sub {
722                  warn "## indetify $NICK\n";                  _log "## registrated $NICK";
723                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );
724          },          },
725          irc_433 => sub {          irc_disconnected => sub {
726                  print "# irc_433: ",$_[ARG1], "\n";                  _log "## disconnected, reconnecting again";
727                  warn "## indetify $NICK\n";                  $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);
                 $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );  
         },  
         irc_372 => sub {  
                 print "MOTD: ", $_[ARG1], "\n";  
728          },          },
729          irc_snotice => sub {          irc_socketerr => sub {
730                  print "(server notice): ", $_[ARG0], "\n";                  _log "## socket error... sleeping for $sleep_on_error seconds and retry";
731                    sleep($sleep_on_error);
732                    $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);
733          },          },
734      (map  #       irc_433 => sub {
735       {  #               print "# irc_433: ",$_[ARG1], "\n";
736         ;"irc_$_" => sub { }}  #               warn "## indetify $NICK\n";
737       qw(  #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );
738                  )),  #       },
 #       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  
739      _child => sub {},      _child => sub {},
740      _default => sub {      _default => sub {
741        printf "%s: session %s caught an unhandled %s event.\n",                  _log sprintf "sID:%s %s %s",
742          scalar localtime(), $_[SESSION]->ID, $_[ARG0];                          $_[SESSION]->ID, $_[ARG0],
743        print "The $_[ARG0] event was given these parameters: ",                          ref($_[ARG1]) eq "ARRAY"        ?       join(",", map { ref($_) eq "ARRAY" ? join(";", @{$_}) : $_ } @{ $_[ARG1] })     :
744          join(" ", map({"ARRAY" eq ref $_ ? "[@$_]" : "$_"} @{$_[ARG1]})), "\n";                          $_[ARG1]                                        ?       $_[ARG1]                                        :
745                            "";
746        0;                        # false for signals        0;                        # false for signals
747      },      },
748      my_add => sub {      my_add => sub {
# Line 312  POE::Session->create Line 808  POE::Session->create
808     },     },
809    );    );
810    
811    # http server
812    
813    my $httpd = POE::Component::Server::HTTP->new(
814            Port => $NICK =~ m/-dev/ ? 8001 : 8000,
815            ContentHandler => { '/' => \&root_handler },
816            Headers        => { Server => 'irc-logger' },
817    );
818    
819    my %escape = ('<'=>'&lt;', '>'=>'&gt;', '&'=>'&amp;', '"'=>'&quot;');
820    my $escape_re  = join '|' => keys %escape;
821    
822    my $style = <<'_END_OF_STYLE_';
823    p { margin: 0; padding: 0.1em; }
824    .time, .channel { color: #808080; font-size: 60%; }
825    .date { float: right; background: #e0e0e0; color: #404040; font-size: 120%; padding: 0.25em; border: 1px dashed #808080; }
826    .nick { color: #000000; font-size: 80%; padding: 2px; font-family: courier, courier new, monospace ; }
827    .message { color: #000000; font-size: 100%; }
828    .search { float: right; }
829    .col-0 { background: #ffff66 }
830    .col-1 { background: #a0ffff }
831    .col-2 { background: #99ff99 }
832    .col-3 { background: #ff9999 }
833    .col-4 { background: #ff66ff }
834    a:link.tag, a:visited.tag { border: 1px dashed #ccc; backgound: #ccc; text-decoration: none }
835    a:hover.tag { border: 1px solid #eee }
836    hr { border: 1px dashed #ccc; height: 1px; clear: both; }
837    _END_OF_STYLE_
838    
839    my $max_color = 4;
840    
841    my %nick_enumerator;
842    
843    sub root_handler {
844            my ($request, $response) = @_;
845            $response->code(RC_OK);
846            $response->content_type("text/html; charset=$ENCODING");
847    
848            my $q;
849    
850            if ( $request->method eq 'POST' ) {
851                    $q = new CGI::Simple( $request->content );
852            } elsif ( $request->uri =~ /\?(.+)$/ ) {
853                    $q = new CGI::Simple( $1 );
854            } else {
855                    $q = new CGI::Simple;
856            }
857    
858            my $search = $q->param('search') || $q->param('grep') || '';
859    
860            my $html =
861                    qq{<html><head><title>$NICK</title><style type="text/css">$style} .
862                    $cloud->css .
863                    qq{</style></head><body>} .
864                    qq{
865                    <form method="post" class="search" action="/">
866                    <input type="text" name="search" value="$search" size="10">
867                    <input type="submit" value="search">
868                    </form>
869                    } .
870                    $cloud->html(500) .
871                    qq{<p>};
872            if ($request->url =~ m#/history#) {
873                    my $sth = $dbh->prepare(qq{
874                            select date(time) as date,count(*) as nr
875                                    from log
876                                    group by date(time)
877                                    order by date(time) desc
878                    });
879                    $sth->execute();
880                    my ($l_yyyy,$l_mm) = (0,0);
881                    my $cal;
882                    while (my $row = $sth->fetchrow_hashref) {
883                            # this is probably PostgreSQL specific, expects ISO date
884                            my ($yyyy,$mm,$dd) = split(/-/, $row->{date});
885                            if ($yyyy != $l_yyyy || $mm != $l_mm) {
886                                    $html .= $cal->as_HTML() if ($cal);
887                                    $cal = new HTML::CalendarMonthSimple('month'=>$mm,'year'=>$yyyy);
888                                    $cal->border(2);
889                                    ($l_yyyy,$l_mm) = ($yyyy,$mm);
890                            }
891                            $cal->setcontent($dd, qq{
892                                    <a href="/?date=$row->{date}">$row->{nr}</a>
893                            });
894                    }
895                    $html .= $cal->as_HTML() if ($cal);
896    
897            } else {
898                    $html .= join("</p><p>",
899                            get_from_log(
900                                    limit => $q->param('last') || $q->param('date') ? undef : 100,
901                                    search => $search || undef,
902                                    tag => $q->param('tag') || undef,
903                                    date => $q->param('date') || undef,
904                                    fmt => {
905                                            date => sub {
906                                                    my $date = shift || return;
907                                                    qq{<hr/><div class="date"><a href="/?date=$date">$date</a></div>};
908                                            },
909                                            time => '<span class="time">%s</span> ',
910                                            time_channel => '<span class="channel">%s %s</span> ',
911                                            nick => '%s:&nbsp;',
912                                            me_nick => '***%s&nbsp;',
913                                            message => '<span class="message">%s</span>',
914                                    },
915                                    filter => {
916                                            message => sub {
917                                                    my $m = shift || return;
918                                                    $m =~ s/($escape_re)/$escape{$1}/gs;
919                                                    $m =~ s#($RE{URI}{HTTP})#<a href="$1">$1</a>#gs;
920                                                    $m =~ s#$tag_regex#<a href="?tag=$1" class="tag">$1</a>#g;
921                                                    return $m;
922                                            },
923                                            nick => sub {
924                                                    my $n = shift || return;
925                                                    if (! $nick_enumerator{$n})  {
926                                                            my $max = scalar keys %nick_enumerator;
927                                                            $nick_enumerator{$n} = $max + 1;
928                                                    }
929                                                    return '<span class="nick col-' .
930                                                            ( $nick_enumerator{$n} % $max_color ) .
931                                                            '">' . $n . '</span>';
932                                            },
933                                    },
934                            )
935                    );
936            }
937    
938            $html .= qq{</p>
939            <hr/>
940            <p>See <a href="/history">history</a> of all messages.</p>
941            </body></html>};
942    
943            $response->content( $html );
944            return RC_OK;
945    }
946    
947  POE::Kernel->run;  POE::Kernel->run;

Legend:
Removed from v.10  
changed lines
  Added in v.52

  ViewVC Help
Powered by ViewVC 1.1.26