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