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