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