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