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