/[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 67 by dpavlin, Sat Sep 29 13:13:41 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    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            sub check_date {
264                    my $date = shift;
265                    $date = eval { DateTime::Format::ISO8601->parse_datetime( $args->{date} )->ymd; };
266                    if ( $@ ) {
267                            warn "invalid date ", $args->{date}, $/;
268                            $date = DateTime->now->ymd;
269                    }
270                    return $date;
271            }
272    
273            $sql .= " where message ilike ? or nick ilike ? " if ($args->{search});
274            $sql .= " where id in (" . join(",", @{ $tags->{ $args->{tag} } }) . ") " if ($args->{tag} && $tags->{ $args->{tag} });
275            if ($args->{date}) {
276                    $sql .= " where date(time) = ? ";
277                    $args->{date} = check_date( $args->{date} );
278            }
279            $sql .= " order by log.time desc";
280            $sql .= " limit " . $args->{limit} if ($args->{limit});
281    
282            my $sth = $dbh->prepare( $sql );
283            if (my $search = $args->{search}) {
284                    $search =~ s/^\s+//;
285                    $search =~ s/\s+$//;
286                    $sth->execute( ( '%' . $search . '%' ) x 2 );
287                    _log "search for '$search' returned ", $sth->rows, " results ", $context || '';
288            } elsif (my $tag = $args->{tag}) {
289                    $sth->execute();
290                    _log "tag '$tag' returned ", $sth->rows, " results ", $context || '';
291            } elsif (my $date = $args->{date}) {
292                    $sth->execute( check_date($date) );
293                    _log "found ", $sth->rows, " messages for date $date ", $context || '';
294            } else {
295                    $sth->execute();
296            }
297            my $last_row = {
298                    date => '',
299                    time => '',
300                    channel => '',
301                    nick => '',
302            };
303    
304            my @rows;
305    
306            while (my $row = $sth->fetchrow_hashref) {
307                    unshift @rows, $row;
308            }
309    
310            # normalize nick names
311            map {
312                    $_->{nick} =~ s/^_*(.*?)_*$/$1/
313            } @rows;
314    
315            return @rows if ($args->{full_rows});
316    
317            my @msgs = (
318                    "Showing " . ($#rows + 1) . " messages..."
319            );
320    
321            if ($context) {
322                    my @ids = @rows;
323                    @rows = ();
324    
325                    my $last_to = 0;
326    
327                    my $sth = $dbh->prepare( $sql_message . qq{ where id >= ? and id < ? } );
328                    foreach my $row_id (sort { $a->{id} <=> $b->{id} } @ids) {
329                            my $id = $row_id->{id} || die "can't find id in row";
330            
331                            my ($from, $to) = ($id - $context, $id + $context);
332                            $from = $last_to if ($from < $last_to);
333                            $last_to = $to;
334                            $sth->execute( $from, $to );
335    
336                            #warn "## id: $id from: $from to: $to returned: ", $sth->rows, "\n";
337    
338                            while (my $row = $sth->fetchrow_hashref) {
339                                    push @rows, $row;
340                            }
341    
342                    }
343            }
344    
345            # sprintf which can take coderef as first parametar
346            sub cr_sprintf {
347                    my $fmt = shift || return;
348                    if (ref($fmt) eq 'CODE') {
349                            $fmt->(@_);
350                    } else {
351                            sprintf($fmt, @_);
352                    }
353            }
354    
355            foreach my $row (@rows) {
356    
357                    $row->{time} =~ s#\.\d+##;
358    
359                    my $msg = '';
360    
361                    $msg = cr_sprintf($args->{fmt}->{date}, $row->{date}) . ' ' if ($last_row->{date} ne $row->{date});
362                    my $t = $row->{time};
363    
364                    if ($last_row->{channel} ne $row->{channel}) {
365                            $msg .= cr_sprintf($args->{fmt}->{time_channel}, $t, $row->{channel});
366                    } else {
367                            $msg .= cr_sprintf($args->{fmt}->{time}, $t);
368                    }
369    
370                    my $append = 1;
371    
372                    my $nick = $row->{nick};
373    #               if ($nick =~ s/^_*(.*?)_*$/$1/) {
374    #                       $row->{nick} = $nick;
375    #               }
376    
377                    if ($last_row->{nick} ne $nick) {
378                            # obfu way to find format for me_nick if needed or fallback to default
379                            my $fmt = $row->{me} ? ( $args->{fmt}->{me_nick} || $args->{fmt}->{nick} ) : $args->{fmt}->{nick};
380                            $fmt ||= '%s';
381    
382                            $nick = $args->{filter}->{nick}->($nick) if (ref($args->{filter}->{nick}) eq 'CODE');
383    
384                            $msg .= cr_sprintf( $fmt, $nick );
385                            $append = 0;
386                    }
387    
388                    $args->{fmt}->{message} ||= '%s';
389                    if (ref($args->{filter}->{message}) eq 'CODE') {
390                            $msg .= cr_sprintf($args->{fmt}->{message},
391                                    $args->{filter}->{message}->(
392                                            $row->{message}
393                                    )
394                            );
395                    } else {
396                            $msg .= cr_sprintf($args->{fmt}->{message}, $row->{message});
397                    }
398    
399                    if ($append && @msgs) {
400                            $msgs[$#msgs] .= " " . $msg;
401                    } else {
402                            push @msgs, $msg;
403                    }
404    
405                    $last_row = $row;
406            }
407    
408            return @msgs;
409    }
410    
411    # tags support
412    
413    my $cloud = HTML::TagCloud->new;
414    
415    =head2 add_tag
416    
417     add_tag( id => 42, message => 'irc message' );
418    
419    =cut
420    
421    sub add_tag {
422            my $arg = {@_};
423    
424            return unless ($arg->{id} && $arg->{message});
425    
426            my $m = $arg->{message};
427            from_to('UTF-8', 'iso-8859-2', $m) if (is_utf8($m));
428    
429            while ($m =~ s#$tag_regex##s) {
430                    my $tag = $1;
431                    next if (! $tag || $tag =~ m/https?:/i);
432                    push @{ $tags->{$tag} }, $arg->{id};
433                    #warn "+tag $tag: $arg->{id}\n";
434                    $cloud->add($tag, "?tag=$tag", scalar @{$tags->{$tag}} + 1);
435            }
436    }
437    
438    =head2 seed_tags
439    
440    Read all tags from database and create in-memory cache for tags
441    
442    =cut
443    
444    sub seed_tags {
445            my $sth = $dbh->prepare(qq{ select id,message from log where message like '%//%' });
446            $sth->execute;
447            while (my $row = $sth->fetchrow_hashref) {
448                    add_tag( %$row );
449            }
450    
451            foreach my $tag (keys %$tags) {
452                    $cloud->add($tag, "?tag=$tag", scalar @{$tags->{$tag}} + 1);
453            }
454    }
455    
456    seed_tags;
457    
458    
459    =head2 save_message
460    
461      save_message(
462            channel => '#foobar',
463            me => 0,
464            nick => 'dpavlin',
465            msg => 'test message',
466            time => '2006-06-25 18:57:18',
467      );
468    
469    C<time> is optional, it will use C<< now() >> if it's not available.
470    
471    C<me> if not specified will be C<0> (not C</me> message)
472    
473    =cut
474    
475    sub save_message {
476            my $a = {@_};
477            $a->{me} ||= 0;
478            $a->{time} ||= strftime($TIMESTAMP,localtime());
479    
480            _log
481                    $a->{channel}, " ",
482                    $a->{me} ? "***" . $a->{nick} : "<" . $a->{nick} . ">",
483                    " " . $a->{msg};
484    
485            from_to($a->{msg}, 'UTF-8', $ENCODING);
486    
487            $sth->execute($a->{channel}, $a->{me}, $a->{nick}, $a->{msg}, $a->{time});
488            add_tag( id => $dbh->last_insert_id(undef,undef,"log",undef),
489                    message => $a->{msg});
490    }
491    
492    
493    if ($import_dircproxy) {
494            open(my $l, $import_dircproxy) || die "can't open $import_dircproxy: $!";
495            warn "importing $import_dircproxy...\n";
496            my $tz_offset = 2 * 60 * 60;    # TZ GMT+2
497            while(<$l>) {
498                    chomp;
499                    if (/^@(\d+)\s(\S+)\s(.+)$/) {
500                            my ($time, $nick, $msg) = ($1,$2,$3);
501    
502                            my $dt = DateTime->from_epoch( epoch => $time + $tz_offset );
503    
504                            my $me = 0;
505                            $me = 1 if ($nick =~ m/^\[\S+]/);
506                            $nick =~ s/^[\[<]([^!]+).*$/$1/;
507    
508                            $msg =~ s/^ACTION\s+// if ($me);
509    
510                            save_message(
511                                    channel => $CHANNEL,
512                                    me => $me,
513                                    nick => $nick,
514                                    msg => $msg,
515                                    time => $dt->ymd . " " . $dt->hms,
516                            ) if ($nick !~ m/^-/);
517    
518                    } else {
519                            _log "can't parse: $_";
520                    }
521            }
522            close($l);
523            warn "import over\n";
524            exit;
525    }
526    
527    
528    #
529    # POE handing part
530    #
531    
532  my $SKIPPING = 0;               # if skipping, how many we've done  my $SKIPPING = 0;               # if skipping, how many we've done
533  my $SEND_QUEUE;                 # cache  my $SEND_QUEUE;                 # cache
534    my $ping;                                               # ping stats
535    
536  POE::Component::IRC->new($IRC_ALIAS);  POE::Component::IRC->new($IRC_ALIAS);
537    
538  POE::Session->create  POE::Session->create( inline_states =>
   (inline_states =>  
539     {_start => sub {           {_start => sub {      
540                  $_[KERNEL]->post($IRC_ALIAS => register => 'all');                  $_[KERNEL]->post($IRC_ALIAS => register => 'all');
541                  $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);                  $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);
542      },      },
543      irc_255 => sub {            # server is done blabbing      irc_255 => sub {    # server is done blabbing
544                  $_[KERNEL]->post($IRC_ALIAS => join => $CHANNEL);                  $_[KERNEL]->post($IRC_ALIAS => join => $CHANNEL);
545                  $_[KERNEL]->post($IRC_ALIAS => join => '#logger');                  $_[KERNEL]->post($IRC_ALIAS => join => '#logger');
546                  $_[KERNEL]->yield("heartbeat"); # start heartbeat                  $_[KERNEL]->yield("heartbeat"); # start heartbeat
547  #               $_[KERNEL]->yield("my_add", $_) for keys %FOLLOWS;  #               $_[KERNEL]->yield("my_add", $_) for keys %FOLLOWS;
548                    $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );
549      },      },
550      irc_public => sub {      irc_public => sub {
551                  my $kernel = $_[KERNEL];                  my $kernel = $_[KERNEL];
# Line 96  POE::Session->create Line 553  POE::Session->create
553                  my $channel = $_[ARG1]->[0];                  my $channel = $_[ARG1]->[0];
554                  my $msg = $_[ARG2];                  my $msg = $_[ARG2];
555    
556                  from_to($msg, 'UTF-8', 'ISO-8859-2');                  save_message( channel => $channel, me => 0, nick => $nick, msg => $msg);
557                    meta( $nick, $channel, 'last-msg', $msg );
558        },
559        irc_ctcp_action => sub {
560                    my $kernel = $_[KERNEL];
561                    my $nick = (split /!/, $_[ARG0])[0];
562                    my $channel = $_[ARG1]->[0];
563                    my $msg = $_[ARG2];
564    
565                    save_message( channel => $channel, me => 1, nick => $nick, msg => $msg);
566    
567                    if ( $use_twitter ) {
568                            if ( my $twitter = meta( $nick, $NICK, 'twitter' ) ) {
569                                    my ($login,$passwd) = split(/\s+/,$twitter,2);
570                                    _log("sending twitter for $nick/$login on $channel ");
571                                    my $bot = Net::Twitter->new( username=>$login, password=>$passwd );
572                                    $bot->update("<${channel}> $msg");
573                            }
574                    }
575    
                 print "$channel: <$nick> $msg\n";  
                 $sth->execute($channel, $nick, $msg);  
576      },      },
577            irc_ping => sub {
578                    warn "pong ", $_[ARG0], $/;
579                    $ping->{ $_[ARG0] }++;
580            },
581            irc_invite => sub {
582                    my $kernel = $_[KERNEL];
583                    my $nick = (split /!/, $_[ARG0])[0];
584                    my $channel = $_[ARG1];
585    
586                    warn "invited to $channel by $nick";
587    
588                    $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, "how nice of you to invite me to $channel, I'll be right there..." );
589                    $_[KERNEL]->post($IRC_ALIAS => join => $channel);
590    
591            },
592          irc_msg => sub {          irc_msg => sub {
593                  my $kernel = $_[KERNEL];                  my $kernel = $_[KERNEL];
594                  my $nick = (split /!/, $_[ARG0])[0];                  my $nick = (split /!/, $_[ARG0])[0];
595                  my $msg = $_[ARG2];                  my $msg = $_[ARG2];
596                  from_to($msg, 'UTF-8', 'ISO-8859-2');                  my $channel = $_[ARG1]->[0];
597                    from_to($msg, 'UTF-8', $ENCODING);
598    
599                  my $res = "unknown command '$msg', try /msg $NICK help!";                  my $res = "unknown command '$msg', try /msg $NICK help!";
600                    my @out;
601    
602                  print "<< $msg\n";                  _log "<< $msg";
603    
604                  if ($msg =~ m/^help/i) {                  if ($msg =~ m/^help/i) {
605    
606                          $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";
607    
608                    } elsif ($msg =~ m/^msg\s+(\S+)\s+(.*)$/i) {
609    
610                            _log ">> /msg $1 $2";
611                            $_[KERNEL]->post( $IRC_ALIAS => privmsg => $1, $2 );
612                            $res = '';
613    
614                  } elsif ($msg =~ m/^stat.*?\s*(\d*)/i) {                  } elsif ($msg =~ m/^stat.*?\s*(\d*)/i) {
615    
616                          my $nr = $1 || 10;                          my $nr = $1 || 10;
617    
618                          my $sth = $dbh->prepare(qq{                          my $sth = $dbh->prepare(qq{
619                                  select nick,count(*) from log group by nick order by count desc limit $nr                                  select
620                                            trim(both '_' from nick) as nick,
621                                            count(*) as count,
622                                            sum(length(message)) as len
623                                    from log
624                                    group by trim(both '_' from nick)
625                                    order by len desc,count desc
626                                    limit $nr
627                          });                          });
628                          $sth->execute();                          $sth->execute();
629                          $res = "Top $nr users: ";                          $res = "Top $nr users: ";
630                          my @users;                          my @users;
631                          while (my $row = $sth->fetchrow_hashref) {                          while (my $row = $sth->fetchrow_hashref) {
632                                  push @users,$row->{nick} . ': ' . $row->{count};                                  push @users,$row->{nick} . ': ' . $row->{count} . '/' . $row->{len} . '=' . sprintf("%.2f", $row->{len}/$row->{count});
633                          }                          }
634                          $res .= join(" | ", @users);                          $res .= join(" | ", @users);
635                  } elsif ($msg =~ m/^last.*?\s*(\d*)/i) {                  } elsif ($msg =~ m/^last.*?\s*(\d*)/i) {
636    
637                          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;  
638    
639                          while (my $row = $sth->fetchrow_hashref) {                          foreach my $res (get_from_log( limit => $limit )) {
640                                  unshift @rows, $row;                                  _log "last: $res";
641                                    from_to($res, $ENCODING, 'UTF-8');
642                                    $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );
643                          }                          }
644    
645                          my @msgs;                          $res = '';
   
                         foreach my $row (@rows) {  
646    
647                                  $row->{time} =~ s#\.\d+##;                  } elsif ($msg =~ m/^(search|grep)\s+(.*)\s*$/i) {
648    
649                                  my $t;                          my $what = $2;
                                 $t = $row->{date} . ' ' if ($last_row->{date} ne $row->{date});  
                                 $t .= $row->{time};  
650    
651                                  my $msg = '';                          foreach my $res (get_from_log(
652                                            limit => 20,
653                                            search => $what,
654                                    )) {
655                                    _log "search [$what]: $res";
656                                    from_to($res, $ENCODING, 'UTF-8');
657                                    $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );
658                            }
659    
660                                  $msg .= "($t";                          $res = '';
                                 $msg .= ' ' . $row->{channel} if ($last_row->{channel} ne $row->{channel});  
                                 $msg .= ") ";  
661    
662                                  $msg .= $row->{nick} . ': '  if ($last_row->{nick} ne $row->{nick});                  } elsif ($msg =~ m/^(?:count|poll)\s+(.*)(?:\s+(\d+))?\s*$/i) {
663    
664                                  $msg .= $row->{message};                          my ($what,$limit) = ($1,$2);
665                            $limit ||= 100;
666    
667                                  push @msgs, $msg;                          my $stat;
668    
669                                  $last_row = $row;                          foreach my $res (get_from_log(
670                                            limit => $limit,
671                                            search => $what,
672                                            full_rows => 1,
673                                    )) {
674                                    while ($res->{message} =~ s/\Q$what\E(\+|\-)//) {
675                                            $stat->{vote}->{$1}++;
676                                            $stat->{from}->{ $res->{nick} }++;
677                                    }
678                          }                          }
679    
680                          foreach my $res (@msgs) {                          my @nicks;
681                                  print "last: $res\n";                          foreach my $nick (sort { $stat->{from}->{$a} <=> $stat->{from}->{$b} } keys %{ $stat->{from} }) {
682                                  from_to($res, 'ISO-8859-2', 'UTF-8');                                  push @nicks, $nick . ( $stat->{from}->{$nick} == 1 ? '' :
683                                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );                                          "(" . $stat->{from}->{$nick} . ")"
684                                    );
685                          }                          }
686    
687                          $res = '';                          $res =
688                                    "$what ++ " . ( $stat->{vote}->{'+'} || 0 ) .
689                                    " : " . ( $stat->{vote}->{'-'} || 0 ) . " --" .
690                                    " from " . ( join(", ", @nicks) || 'nobody' );
691    
692                            $_[KERNEL]->post( $IRC_ALIAS => notice => $nick, $res );
693    
694                    } elsif ($msg =~ m/^ping/) {
695                            $res = "ping = " . dump( $ping );
696                    } elsif ($msg =~ m/^conf(?:ig)*\s*(last-size|twitter)*\s*(.*)/) {
697                            if ( ! defined( $1 ) ) {
698                                    my $sth = $dbh->prepare(qq{ select name,value,changed from meta where nick = ? and channel = ? });
699                                    $sth->execute( $nick, $channel );
700                                    $res = "config for $nick on $channel";
701                                    while ( my ($n,$v) = $sth->fetchrow_array ) {
702                                            $res .= " | $n = $v";
703                                    }
704                            } elsif ( ! $2 ) {
705                                    my $val = meta( $nick, $channel, $1 );
706                                    $res = "current $1 = " . ( $val ? $val : 'undefined' );
707                            } else {
708                                    my $validate = {
709                                            'last-size' => qr/^\d+/,
710                                            'twitter' => qr/^\w+\s+\w+/,
711                                    };
712    
713                                    my ( $op, $val ) = ( $1, $2 );
714    
715                                    if ( my $regex = $validate->{$op} ) {
716                                            if ( $val =~ $regex ) {
717                                                    meta( $nick, $channel, $op, $val );
718                                                    $res = "saved $op = $val";
719                                            } else {
720                                                    $res = "config option $op = $val doesn't validate against $regex";
721                                            }
722                                    } else {
723                                            $res = "config option $op doesn't exist";
724                                    }
725                            }
726                  }                  }
727    
728                  if ($res) {                  if ($res) {
729                          print ">> [$nick] $res\n";                          _log ">> [$nick] $res";
730                          from_to($res, 'ISO-8859-2', 'UTF-8');                          from_to($res, $ENCODING, 'UTF-8');
731                          $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );                          $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );
732                  }                  }
733    
734          },          },
735            irc_477 => sub {
736                    _log "# irc_477: ",$_[ARG1];
737                    $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "register $NICK" );
738            },
739          irc_505 => sub {          irc_505 => sub {
740          print "# irc_505: ",$_[ARG1], "\n";                  _log "# irc_505: ",$_[ARG1];
741                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "register $NICK" );                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "register $NICK" );
742                  warn "## register $NICK\n";  #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "set hide email on" );
743    #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "set email dpavlin\@rot13.org" );
744          },          },
745          irc_registered => sub {          irc_registered => sub {
746                    _log "## registrated $NICK";
747                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );
                 warn "## indetify $NICK\n";  
748          },          },
749      (map          irc_disconnected => sub {
750       {                  _log "## disconnected, reconnecting again";
751         ;"irc_$_" => sub { }}                  $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);
752       qw(join          },
753          ctcp_version          irc_socketerr => sub {
754          connected snotice ctcp_action ping notice mode part quit                  _log "## socket error... sleeping for $sleep_on_error seconds and retry";
755          001 002 003 004 005                  sleep($sleep_on_error);
756          250 251 252 253 254 265 266                  $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);
757          332 333 353 366 372 375 376          },
758                  477  #       irc_433 => sub {
759                  )),  #               print "# irc_433: ",$_[ARG1], "\n";
760    #               warn "## indetify $NICK\n";
761    #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );
762    #       },
763      _child => sub {},      _child => sub {},
764      _default => sub {      _default => sub {
765        printf "%s: session %s caught an unhandled %s event.\n",                  _log sprintf "sID:%s %s %s",
766          scalar localtime(), $_[SESSION]->ID, $_[ARG0];                          $_[SESSION]->ID, $_[ARG0],
767        print "The $_[ARG0] event was given these parameters: ",                          ref($_[ARG1]) eq "ARRAY"        ?       join(",", map { ref($_) eq "ARRAY" ? join(";", @{$_}) : $_ } @{ $_[ARG1] })     :
768          join(" ", map({"ARRAY" eq ref $_ ? "[@$_]" : "$_"} @{$_[ARG1]})), "\n";                          $_[ARG1]                                        ?       $_[ARG1]                                        :
769                            "";
770        0;                        # false for signals        0;                        # false for signals
771      },      },
772      my_add => sub {      my_add => sub {
# Line 289  POE::Session->create Line 832  POE::Session->create
832     },     },
833    );    );
834    
835    # http server
836    
837    my $httpd = POE::Component::Server::HTTP->new(
838            Port => $NICK =~ m/-dev/ ? 8001 : 8000,
839            ContentHandler => { '/' => \&root_handler },
840            Headers        => { Server => 'irc-logger' },
841    );
842    
843    my %escape = ('<'=>'&lt;', '>'=>'&gt;', '&'=>'&amp;', '"'=>'&quot;');
844    my $escape_re  = join '|' => keys %escape;
845    
846    my $style = <<'_END_OF_STYLE_';
847    p { margin: 0; padding: 0.1em; }
848    .time, .channel { color: #808080; font-size: 60%; }
849    .date { float: right; background: #e0e0e0; color: #404040; font-size: 120%; padding: 0.25em; border: 1px dashed #808080; }
850    .nick { color: #000000; font-size: 80%; padding: 2px; font-family: courier, courier new, monospace ; }
851    .message { color: #000000; font-size: 100%; }
852    .search { float: right; }
853    a:link.tag, a:visited.tag { border: 1px dashed #ccc; backgound: #ccc; text-decoration: none }
854    a:hover.tag { border: 1px solid #eee }
855    hr { border: 1px dashed #ccc; height: 1px; clear: both; }
856    /*
857    .col-0 { background: #ffff66 }
858    .col-1 { background: #a0ffff }
859    .col-2 { background: #99ff99 }
860    .col-3 { background: #ff9999 }
861    .col-4 { background: #ff66ff }
862    */
863    .calendar { border: 1px solid red; width: 100%; }
864    .month { border: 0px; width: 100%; }
865    _END_OF_STYLE_
866    
867    my $max_color = 4;
868    
869    my @cols = qw(
870            #ffcccc #ccffe6 #ccccff #e6ccff #ffccff #ffcce6 #ff9999 #ffcc99 #ffff99
871            #ccff99 #99ff99 #99ffcc #99ccff #9999ff #cc99ff #ff6666 #ffb366 #ffff66
872            #66ff66 #66ffb3 #66b3ff #6666ff #ff3333 #33ff33 #3399ff #3333ff #ff3399
873            #a0a0a0 #ff0000 #ffff00 #80ff00 #0000ff #8000ff #ff00ff #ff0080 #994d00
874            #999900 #009900 #cc0066 #c0c0c0 #ccff99 #99ff33 #808080 #660033 #ffffff
875    );
876    
877    $max_color = 0;
878    foreach my $c (@cols) {
879            $style .= ".col-${max_color} { background: $c }\n";
880            $max_color++;
881    }
882    warn "defined $max_color colors for users...\n";
883    
884    my %nick_enumerator;
885    
886    sub root_handler {
887            my ($request, $response) = @_;
888            $response->code(RC_OK);
889            $response->content_type("text/html; charset=$ENCODING");
890    
891            my $q;
892    
893            if ( $request->method eq 'POST' ) {
894                    $q = new CGI::Simple( $request->content );
895            } elsif ( $request->uri =~ /\?(.+)$/ ) {
896                    $q = new CGI::Simple( $1 );
897            } else {
898                    $q = new CGI::Simple;
899            }
900    
901            my $search = $q->param('search') || $q->param('grep') || '';
902    
903            my $html =
904                    qq{<html><head><title>$NICK</title><style type="text/css">$style} .
905                    $cloud->css .
906                    qq{</style></head><body>} .
907                    qq{
908                    <form method="post" class="search" action="/">
909                    <input type="text" name="search" value="$search" size="10">
910                    <input type="submit" value="search">
911                    </form>
912                    } .
913                    $cloud->html(500) .
914                    qq{<p>};
915            if ($request->url =~ m#/history#) {
916                    my $sth = $dbh->prepare(qq{
917                            select date(time) as date,count(*) as nr,sum(length(message)) as len
918                                    from log
919                                    group by date(time)
920                                    order by date(time) desc
921                    });
922                    $sth->execute();
923                    my ($l_yyyy,$l_mm) = (0,0);
924                    $html .= qq{<table class="calendar"><tr>};
925                    my $cal;
926                    my $ord = 0;
927                    while (my $row = $sth->fetchrow_hashref) {
928                            # this is probably PostgreSQL specific, expects ISO date
929                            my ($yyyy,$mm,$dd) = split(/-/, $row->{date});
930                            if ($yyyy != $l_yyyy || $mm != $l_mm) {
931                                    if ( $cal ) {
932                                            $html .= qq{<td valign="top">} . $cal->as_HTML() . qq{</td>};
933                                            $ord++;
934                                            $html .= qq{</tr><tr>} if ( $ord % 3 == 0 );
935                                    }
936                                    $cal = new HTML::CalendarMonthSimple('month'=>$mm,'year'=>$yyyy);
937                                    $cal->border(1);
938                                    $cal->width('30%');
939                                    $cal->cellheight('5em');
940                                    $cal->tableclass('month');
941                                    #$cal->cellclass('day');
942                                    $cal->sunday('SUN');
943                                    $cal->saturday('SAT');
944                                    $cal->weekdays('MON','TUE','WED','THU','FRI');
945                                    ($l_yyyy,$l_mm) = ($yyyy,$mm);
946                            }
947                            $cal->setcontent($dd, qq{
948                                    <a href="/?date=$row->{date}">$row->{nr}</a><br/>$row->{len}
949                            });
950                            
951                    }
952                    $html .= qq{<td valign="top">} . $cal->as_HTML() . qq{</td></tr></table>};
953    
954            } else {
955                    $html .= join("</p><p>",
956                            get_from_log(
957                                    limit => $q->param('last') || $q->param('date') ? undef : 100,
958                                    search => $search || undef,
959                                    tag => $q->param('tag') || undef,
960                                    date => check_date( $q->param('date') ),
961                                    fmt => {
962                                            date => sub {
963                                                    my $date = shift || return;
964                                                    qq{<hr/><div class="date"><a href="/?date=$date">$date</a></div>};
965                                            },
966                                            time => '<span class="time">%s</span> ',
967                                            time_channel => '<span class="channel">%s %s</span> ',
968                                            nick => '%s:&nbsp;',
969                                            me_nick => '***%s&nbsp;',
970                                            message => '<span class="message">%s</span>',
971                                    },
972                                    filter => {
973                                            message => sub {
974                                                    my $m = shift || return;
975    
976                                                    # protect HTML from wiki modifications
977                                                    sub e {
978                                                            my $t = shift;
979                                                            return 'uri_unescape{' . uri_escape($t) . '}';
980                                                    }
981    
982                                                    $m =~ s/($escape_re)/$escape{$1}/gs;
983                                                    $m =~ s#($RE{URI}{HTTP})#e(qq{<a href="$1">$1</a>})#egs;
984                                                    $m =~ s#$tag_regex#e(qq{<a href="?tag=$1" class="tag">$1</a>})#egs;
985                                                    $m =~ s#\*(\w+)\*#<b>$1</b>#gs;
986                                                    $m =~ s#_(\w+)_#<u>$1</u>#gs;
987                                                    $m =~ s#\/(\w+)\/#<i>$1</i>#gs;
988    
989                                                    $m =~ s#uri_unescape{([^}]+)}#uri_unescape($1)#egs;
990                                                    return $m;
991                                            },
992                                            nick => sub {
993                                                    my $n = shift || return;
994                                                    if (! $nick_enumerator{$n})  {
995                                                            my $max = scalar keys %nick_enumerator;
996                                                            $nick_enumerator{$n} = $max + 1;
997                                                    }
998                                                    return '<span class="nick col-' .
999                                                            ( $nick_enumerator{$n} % $max_color ) .
1000                                                            '">' . $n . '</span>';
1001                                            },
1002                                    },
1003                            )
1004                    );
1005            }
1006    
1007            $html .= qq{</p>
1008            <hr/>
1009            <p>See <a href="/history">history</a> of all messages.</p>
1010            </body></html>};
1011    
1012            $response->content( $html );
1013            return RC_OK;
1014    }
1015    
1016  POE::Kernel->run;  POE::Kernel->run;
Legend:
Removed from v.8  
changed lines
  Added in v.67
  ViewVC Help
Powered by ViewVC 1.1.26