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