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