/[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 8 by dpavlin, Wed Mar 1 22:42:21 2006 UTC trunk/bin/irc-logger.pl revision 54 by dpavlin, Sun Mar 18 17:14:52 2007 UTC
# Line 10  irc-logger.pl Line 10  irc-logger.pl
10    
11  ./irc-logger.pl  ./irc-logger.pl
12    
13    =head2 Options
14    
15    =over 4
16    
17    =item --import-dircproxy=filename
18    
19    Import log from C<dircproxy> to C<irc-logger> database
20    
21    =item --log=irc-logger.log
22    
23    Name of log file
24    
25    =back
26    
27  =head1 DESCRIPTION  =head1 DESCRIPTION
28    
29  log all conversation on irc channel  log all conversation on irc channel
# Line 18  log all conversation on irc channel Line 32  log all conversation on irc channel
32    
33  ## CONFIG  ## CONFIG
34    
35  my $NICK = 'irc-logger-dev';  my $HOSTNAME = `hostname`;
36    
37    my $NICK = 'irc-logger';
38    $NICK .= '-dev' if ($HOSTNAME =~ m/llin/);
39  my $CONNECT =  my $CONNECT =
40    {Server => 'irc.freenode.net',    {Server => 'irc.freenode.net',
41     Nick => $NICK,     Nick => $NICK,
42     Ircname => "try /msg $NICK help",     Ircname => "try /msg $NICK help",
43    };    };
44  my $CHANNEL = '#razmjenavjestina';  my $CHANNEL = '#razmjenavjestina';
45    $CHANNEL = '#irc-logger' if ($HOSTNAME =~ m/llin/);
46  my $IRC_ALIAS = "log";  my $IRC_ALIAS = "log";
47    
48  my %FOLLOWS =  my %FOLLOWS =
# Line 33  my %FOLLOWS = Line 51  my %FOLLOWS =
51     ERROR => "/var/log/apache/error.log",     ERROR => "/var/log/apache/error.log",
52    );    );
53    
54  my $DSN = 'DBI:Pg:dbname=irc-logger';  my $DSN = 'DBI:Pg:dbname=' . $NICK;
55    
56    my $ENCODING = 'ISO-8859-2';
57    my $TIMESTAMP = '%Y-%m-%d %H:%M:%S';
58    
59    my $sleep_on_error = 5;
60    
61  ## END CONFIG  ## END CONFIG
62    
63    
64    
65  use POE qw(Component::IRC Wheel::FollowTail);  use POE qw(Component::IRC Wheel::FollowTail Component::Server::HTTP);
66    use HTTP::Status;
67  use DBI;  use DBI;
68  use Encode qw/from_to/;  use Encode qw/from_to is_utf8/;
69    use Regexp::Common qw /URI/;
70    use CGI::Simple;
71    use HTML::TagCloud;
72    use POSIX qw/strftime/;
73    use HTML::CalendarMonthSimple;
74    use Getopt::Long;
75    use DateTime;
76    use Data::Dump qw/dump/;
77    
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 61  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
197    
198     my @messages = get_from_log(
199            limit => 42,
200            search => '%what to stuff in ilike%',
201            fmt => {
202                    time => '{%s} ',
203                    time_channel => '{%s %s} ',
204                    nick => '%s: ',
205                    me_nick => '***%s ',
206                    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
227    
228    sub get_from_log {
229            my $args = {@_};
230    
231            $args->{fmt} ||= {
232                    date => '[%s] ',
233                    time => '{%s} ',
234                    time_channel => '{%s %s} ',
235                    nick => '%s: ',
236                    me_nick => '***%s ',
237                    message => '%s',
238            };
239    
240            my $sql_message = qq{
241                    select
242                            time::date as date,
243                            time::time as time,
244                            channel,
245                            me,
246                            nick,
247                            message
248                    from log
249            };
250    
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";
265            $sql .= " limit " . $args->{limit} if ($args->{limit});
266    
267            my $sth = $dbh->prepare( $sql );
268            if (my $search = $args->{search}) {
269                    $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 {
280                    $sth->execute();
281            }
282            my $last_row = {
283                    date => '',
284                    time => '',
285                    channel => '',
286                    nick => '',
287            };
288    
289            my @rows;
290    
291            while (my $row = $sth->fetchrow_hashref) {
292                    unshift @rows, $row;
293            }
294    
295            # 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) {
341    
342                    $row->{time} =~ s#\.\d+##;
343    
344                    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}) {
350                            $msg .= cr_sprintf($args->{fmt}->{time_channel}, $t, $row->{channel});
351                    } else {
352                            $msg .= cr_sprintf($args->{fmt}->{time}, $t);
353                    }
354    
355                    my $append = 1;
356    
357                    my $nick = $row->{nick};
358    #               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;
371                    }
372    
373                    $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) {
385                            $msgs[$#msgs] .= " " . $msg;
386                    } else {
387                            push @msgs, $msg;
388                    }
389    
390                    $last_row = $row;
391            }
392    
393            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);
527      },      },
528      irc_255 => sub {            # server is done blabbing      irc_255 => sub {    # server is done blabbing
529                  $_[KERNEL]->post($IRC_ALIAS => join => $CHANNEL);                  $_[KERNEL]->post($IRC_ALIAS => join => $CHANNEL);
530                  $_[KERNEL]->post($IRC_ALIAS => join => '#logger');                  $_[KERNEL]->post($IRC_ALIAS => join => '#logger');
531                  $_[KERNEL]->yield("heartbeat"); # start heartbeat                  $_[KERNEL]->yield("heartbeat"); # start heartbeat
532  #               $_[KERNEL]->yield("my_add", $_) for keys %FOLLOWS;  #               $_[KERNEL]->yield("my_add", $_) for keys %FOLLOWS;
533                    $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );
534      },      },
535      irc_public => sub {      irc_public => sub {
536                  my $kernel = $_[KERNEL];                  my $kernel = $_[KERNEL];
# Line 96  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', 'ISO-8859-2');                  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, $channel, '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                  from_to($msg, 'UTF-8', 'ISO-8859-2');                  my $channel = $_[ARG1]->[0];
582                    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;
586    
587                  print "<< $msg\n";                  _log "<< $msg";
588    
589                  if ($msg =~ m/^help/i) {                  if ($msg =~ m/^help/i) {
590    
591                          $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";
592    
593                    } elsif ($msg =~ m/^msg\s+(\S+)\s+(.*)$/i) {
594    
595                            _log ">> /msg $1 $2";
596                            $_[KERNEL]->post( $IRC_ALIAS => privmsg => $1, $2 );
597                            $res = '';
598    
599                  } elsif ($msg =~ m/^stat.*?\s*(\d*)/i) {                  } elsif ($msg =~ m/^stat.*?\s*(\d*)/i) {
600    
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                                            nick,
606                                            count(*) as count,
607                                            sum(length(message)) as len
608                                    from log
609                                    group by 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                          my $nr = $1 || 10;                          my $limit = $1 || meta( $nick, $channel, 'last-size' ) || 10;
   
                         my $sth = $dbh->prepare(qq{  
                                 select  
                                         time::date as date,  
                                         time::time as time,  
                                         channel,  
                                         nick,  
                                         message  
                                 from log order by time desc limit $nr  
                         });  
                         $sth->execute();  
                         $res = "Last $nr messages: ";  
                         my $last_row = {  
                                 date => '',  
                                 time => '',  
                                 channel => '',  
                                 nick => '',  
                         };  
   
                         my @rows;  
623    
624                          while (my $row = $sth->fetchrow_hashref) {                          foreach my $res (get_from_log( limit => $limit )) {
625                                  unshift @rows, $row;                                  _log "last: $res";
626                                    from_to($res, $ENCODING, 'UTF-8');
627                                    $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );
628                          }                          }
629    
630                          my @msgs;                          $res = '';
   
                         foreach my $row (@rows) {  
631    
632                                  $row->{time} =~ s#\.\d+##;                  } elsif ($msg =~ m/^(search|grep)\s+(.*)\s*$/i) {
633    
634                                  my $t;                          my $what = $2;
                                 $t = $row->{date} . ' ' if ($last_row->{date} ne $row->{date});  
                                 $t .= $row->{time};  
635    
636                                  my $msg = '';                          foreach my $res (get_from_log(
637                                            limit => 20,
638                                            search => $what,
639                                    )) {
640                                    _log "search [$what]: $res";
641                                    from_to($res, $ENCODING, 'UTF-8');
642                                    $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );
643                            }
644    
645                                  $msg .= "($t";                          $res = '';
                                 $msg .= ' ' . $row->{channel} if ($last_row->{channel} ne $row->{channel});  
                                 $msg .= ") ";  
646    
647                                  $msg .= $row->{nick} . ': '  if ($last_row->{nick} ne $row->{nick});                  } elsif ($msg =~ m/^(?:count|poll)\s+(.*)(?:\s+(\d+))?\s*$/i) {
648    
649                                  $msg .= $row->{message};                          my ($what,$limit) = ($1,$2);
650                            $limit ||= 100;
651    
652                                  push @msgs, $msg;                          my $stat;
653    
654                                  $last_row = $row;                          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                          foreach my $res (@msgs) {                          my @nicks;
666                                  print "last: $res\n";                          foreach my $nick (sort { $stat->{from}->{$a} <=> $stat->{from}->{$b} } keys %{ $stat->{from} }) {
667                                  from_to($res, 'ISO-8859-2', 'UTF-8');                                  push @nicks, $nick . ( $stat->{from}->{$nick} == 1 ? '' :
668                                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );                                          "(" . $stat->{from}->{$nick} . ")"
669                                    );
670                          }                          }
671    
672                          $res = '';                          $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, 'ISO-8859-2', '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 {
721                    _log "# irc_477: ",$_[ARG1];
722                    $_[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                  warn "## register $NICK\n";  #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "set hide email on" );
728    #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "set email dpavlin\@rot13.org" );
729          },          },
730          irc_registered => sub {          irc_registered => sub {
731                    _log "## registrated $NICK";
732                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );
                 warn "## indetify $NICK\n";  
733          },          },
734      (map          irc_disconnected => sub {
735       {                  _log "## disconnected, reconnecting again";
736         ;"irc_$_" => sub { }}                  $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);
737       qw(join          },
738          ctcp_version          irc_socketerr => sub {
739          connected snotice ctcp_action ping notice mode part quit                  _log "## socket error... sleeping for $sleep_on_error seconds and retry";
740          001 002 003 004 005                  sleep($sleep_on_error);
741          250 251 252 253 254 265 266                  $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);
742          332 333 353 366 372 375 376          },
743                  477  #       irc_433 => sub {
744                  )),  #               print "# irc_433: ",$_[ARG1], "\n";
745    #               warn "## indetify $NICK\n";
746    #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );
747    #       },
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 289  POE::Session->create Line 817  POE::Session->create
817     },     },
818    );    );
819    
820    # http server
821    
822    my $httpd = POE::Component::Server::HTTP->new(
823            Port => $NICK =~ m/-dev/ ? 8001 : 8000,
824            ContentHandler => { '/' => \&root_handler },
825            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_';
832    p { margin: 0; padding: 0.1em; }
833    .time, .channel { color: #808080; font-size: 60%; }
834    .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%; }
837    .search { float: right; }
838    .col-0 { background: #ffff66 }
839    .col-1 { background: #a0ffff }
840    .col-2 { background: #99ff99 }
841    .col-3 { background: #ff9999 }
842    .col-4 { background: #ff66ff }
843    a:link.tag, a:visited.tag { border: 1px dashed #ccc; backgound: #ccc; text-decoration: none }
844    a:hover.tag { border: 1px solid #eee }
845    hr { border: 1px dashed #ccc; height: 1px; clear: both; }
846    _END_OF_STYLE_
847    
848    my $max_color = 4;
849    
850    my %nick_enumerator;
851    
852    sub root_handler {
853            my ($request, $response) = @_;
854            $response->code(RC_OK);
855            $response->content_type("text/html; charset=$ENCODING");
856    
857            my $q;
858    
859            if ( $request->method eq 'POST' ) {
860                    $q = new CGI::Simple( $request->content );
861            } elsif ( $request->uri =~ /\?(.+)$/ ) {
862                    $q = new CGI::Simple( $1 );
863            } else {
864                    $q = new CGI::Simple;
865            }
866    
867            my $search = $q->param('search') || $q->param('grep') || '';
868    
869            my $html =
870                    qq{<html><head><title>$NICK</title><style type="text/css">$style} .
871                    $cloud->css .
872                    qq{</style></head><body>} .
873                    qq{
874                    <form method="post" class="search" action="/">
875                    <input type="text" name="search" value="$search" size="10">
876                    <input type="submit" value="search">
877                    </form>
878                    } .
879                    $cloud->html(500) .
880                    qq{<p>};
881            if ($request->url =~ m#/history#) {
882                    my $sth = $dbh->prepare(qq{
883                            select date(time) as date,count(*) as nr
884                                    from log
885                                    group by date(time)
886                                    order by date(time) desc
887                    });
888                    $sth->execute();
889                    my ($l_yyyy,$l_mm) = (0,0);
890                    my $cal;
891                    while (my $row = $sth->fetchrow_hashref) {
892                            # this is probably PostgreSQL specific, expects ISO date
893                            my ($yyyy,$mm,$dd) = split(/-/, $row->{date});
894                            if ($yyyy != $l_yyyy || $mm != $l_mm) {
895                                    $html .= $cal->as_HTML() if ($cal);
896                                    $cal = new HTML::CalendarMonthSimple('month'=>$mm,'year'=>$yyyy);
897                                    $cal->border(2);
898                                    ($l_yyyy,$l_mm) = ($yyyy,$mm);
899                            }
900                            $cal->setcontent($dd, qq{
901                                    <a href="/?date=$row->{date}">$row->{nr}</a>
902                            });
903                    }
904                    $html .= $cal->as_HTML() if ($cal);
905    
906            } else {
907                    $html .= join("</p><p>",
908                            get_from_log(
909                                    limit => $q->param('last') || $q->param('date') ? undef : 100,
910                                    search => $search || undef,
911                                    tag => $q->param('tag') || undef,
912                                    date => $q->param('date') || undef,
913                                    fmt => {
914                                            date => sub {
915                                                    my $date = shift || return;
916                                                    qq{<hr/><div class="date"><a href="/?date=$date">$date</a></div>};
917                                            },
918                                            time => '<span class="time">%s</span> ',
919                                            time_channel => '<span class="channel">%s %s</span> ',
920                                            nick => '%s:&nbsp;',
921                                            me_nick => '***%s&nbsp;',
922                                            message => '<span class="message">%s</span>',
923                                    },
924                                    filter => {
925                                            message => sub {
926                                                    my $m = shift || return;
927                                                    $m =~ s/($escape_re)/$escape{$1}/gs;
928                                                    $m =~ s#($RE{URI}{HTTP})#<a href="$1">$1</a>#gs;
929                                                    $m =~ s#$tag_regex#<a href="?tag=$1" class="tag">$1</a>#g;
930                                                    return $m;
931                                            },
932                                            nick => sub {
933                                                    my $n = shift || return;
934                                                    if (! $nick_enumerator{$n})  {
935                                                            my $max = scalar keys %nick_enumerator;
936                                                            $nick_enumerator{$n} = $max + 1;
937                                                    }
938                                                    return '<span class="nick col-' .
939                                                            ( $nick_enumerator{$n} % $max_color ) .
940                                                            '">' . $n . '</span>';
941                                            },
942                                    },
943                            )
944                    );
945            }
946    
947            $html .= qq{</p>
948            <hr/>
949            <p>See <a href="/history">history</a> of all messages.</p>
950            </body></html>};
951    
952            $response->content( $html );
953            return RC_OK;
954    }
955    
956  POE::Kernel->run;  POE::Kernel->run;
Legend:
Removed from v.8  
changed lines
  Added in v.54
  ViewVC Help
Powered by ViewVC 1.1.26