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