/[irc-logger]/trunk/bin/irc-logger.pl
This is repository of my old source code which isn't updated any more. Go to git.rot13.org for current projects!
ViewVC logotype

Diff of /trunk/bin/irc-logger.pl

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

trunk/irc-logger.pl revision 15 by dpavlin, Mon Mar 13 12:56:26 2006 UTC trunk/bin/irc-logger.pl revision 85 by dpavlin, Thu Mar 6 22:16:27 2008 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    =item --follow=file.log
26    
27    Follows new messages in file
28    
29    =back
30    
31  =head1 DESCRIPTION  =head1 DESCRIPTION
32    
33  log all conversation on irc channel  log all conversation on irc channel
# Line 18  log all conversation on irc channel Line 36  log all conversation on irc channel
36    
37  ## CONFIG  ## CONFIG
38    
39    my $HOSTNAME = `hostname -f`;
40    chomp($HOSTNAME);
41    
42  my $NICK = 'irc-logger';  my $NICK = 'irc-logger';
43    $NICK .= '-dev' if ($HOSTNAME =~ m/llin/);
44  my $CONNECT =  my $CONNECT =
45    {Server => 'irc.freenode.net',    {Server => 'irc.freenode.net',
46     Nick => $NICK,     Nick => $NICK,
47     Ircname => "try /msg $NICK help",     Ircname => "try /msg $NICK help",
48    };    };
49  my $CHANNEL = '#razmjenavjestina';  my $CHANNEL = '#razmjenavjestina';
50    $CHANNEL = '#irc-logger' if ($HOSTNAME =~ m/llin/);
51  my $IRC_ALIAS = "log";  my $IRC_ALIAS = "log";
52    
53  my %FOLLOWS =  # default log to follow and announce messages
54    (  my $follows_path = 'follows.log';
    ACCESS => "/var/log/apache/access.log",  
    ERROR => "/var/log/apache/error.log",  
   );  
55    
56  my $DSN = 'DBI:Pg:dbname=irc-logger';  my $DSN = 'DBI:Pg:dbname=' . $NICK;
57    
58  my $ENCODING = 'ISO-8859-2';  my $ENCODING = 'ISO-8859-2';
59    my $TIMESTAMP = '%Y-%m-%d %H:%M:%S';
60    
61  ## END CONFIG  my $sleep_on_error = 5;
62    
63    # number of last tags to keep in circular buffer
64    my $last_x_tags = 50;
65    
66    # don't pull rss feeds more often than this
67    my $rss_min_delay = 60;
68    $rss_min_delay = 15;
69    
70    my $http_port = $NICK =~ m/-dev/ ? 8001 : 8000;
71    
72    my $url = "http://$HOSTNAME:$http_port";
73    
74    ## END CONFIG
75    
76  use POE qw(Component::IRC Wheel::FollowTail Component::Server::HTTP);  use POE qw(Component::IRC Wheel::FollowTail Component::Server::HTTP);
77  use HTTP::Status;  use HTTP::Status;
78  use DBI;  use DBI;
79  use Encode qw/from_to/;  use Encode qw/from_to is_utf8/;
80  use Regexp::Common qw /URI/;  use Regexp::Common qw /URI/;
81    use CGI::Simple;
82    use HTML::TagCloud;
83    use POSIX qw/strftime/;
84    use HTML::CalendarMonthSimple;
85    use Getopt::Long;
86    use DateTime;
87    use URI::Escape;
88    use Data::Dump qw/dump/;
89    use DateTime::Format::ISO8601;
90    use Carp qw/confess/;
91    use XML::Feed;
92    use DateTime::Format::Flexible;
93    
94    my $use_twitter = 1;
95    eval { require Net::Twitter; };
96    $use_twitter = 0 if ($@);
97    
98    my $import_dircproxy;
99    my $log_path;
100    GetOptions(
101            'import-dircproxy:s' => \$import_dircproxy,
102            'follows:s' => \$follows_path,
103            'log:s' => \$log_path,
104    );
105    
106    $SIG{__DIE__} = sub {
107            confess "fatal error";
108    };
109    
110  my $dbh = DBI->connect($DSN,"","", { RaiseError => 1, AutoCommit => 1 }) || die $DBI::errstr;  open(STDOUT, '>', $log_path) || warn "can't redirect log to $log_path: $!";
111    
112    sub _log {
113            print strftime($TIMESTAMP,localtime()), ' ', join(" ",@_), $/;
114    }
115    
116    # LOG following
117    
118    my %FOLLOWS =
119      (
120    #   ACCESS => "/var/log/apache/access.log",
121    #   ERROR => "/var/log/apache/error.log",
122      );
123    
124    sub add_follow_path {
125            my $path = shift;
126            my $name = $path;
127            $name =~ s/\..*$//;
128            warn "# using $path to announce messages from $name\n";
129            $FOLLOWS{$name} = $path;
130    }
131    
132    add_follow_path( $follows_path ) if ( -e $follows_path );
133    
134    # HTML formatters
135    
136    my %escape = ('<'=>'&lt;', '>'=>'&gt;', '&'=>'&amp;', '"'=>'&quot;');
137    my $escape_re  = join '|' => keys %escape;
138    
139    my $tag_regex = '\b([\w-_]+)//';
140    
141    my %nick_enumerator;
142    my $max_color = 0;
143    
144    my $filter = {
145            message => sub {
146                    my $m = shift || return;
147    
148                    # protect HTML from wiki modifications
149                    sub e {
150                            my $t = shift;
151                            return 'uri_unescape{' . uri_escape($t) . '}';
152                    }
153    
154  =for SQL schema                  $m =~ s/($escape_re)/$escape{$1}/gs;
155                    $m =~ s#($RE{URI}{HTTP})#e(qq{<a href="$1">$1</a>})#egs ||
156                    $m =~ s#\/(\w+)\/#<i>$1</i>#gs;
157                    $m =~ s#$tag_regex#e(qq{<a href="$url?tag=$1" class="tag">$1</a>})#egs;
158                    $m =~ s#\*(\w+)\*#<b>$1</b>#gs;
159                    $m =~ s#_(\w+)_#<u>$1</u>#gs;
160    
161  $dbh->do(qq{                  $m =~ s#uri_unescape{([^}]+)}#uri_unescape($1)#egs;
162                    return $m;
163            },
164            nick => sub {
165                    my $n = shift || return;
166                    if (! $nick_enumerator{$n})  {
167                            my $max = scalar keys %nick_enumerator;
168                            $nick_enumerator{$n} = $max + 1;
169                    }
170                    return '<span class="nick col-' .
171                            ( $nick_enumerator{$n} % $max_color ) .
172                            '">' . $n . '</span>';
173            },
174    };
175    
176    my $dbh = DBI->connect($DSN,"","", { RaiseError => 1, AutoCommit => 1 }) || die $DBI::errstr;
177    
178    my $sql_schema = {
179            log => qq{
180  create table log (  create table log (
181          id serial,          id serial,
182          time timestamp default now(),          time timestamp default now(),
183          channel text not null,          channel text not null,
184            me boolean default false,
185          nick text not null,          nick text not null,
186          message text not null,          message text not null,
187          primary key(id)          primary key(id)
# Line 65  create table log ( Line 190  create table log (
190  create index log_time on log(time);  create index log_time on log(time);
191  create index log_channel on log(channel);  create index log_channel on log(channel);
192  create index log_nick on log(nick);  create index log_nick on log(nick);
193            },
194            meta => q{
195    create table meta (
196            nick text not null,
197            channel text not null,
198            name text not null,
199            value text,
200            changed timestamp default 'now()',
201            primary key(nick,channel,name)
202    );
203            },
204            feeds => qq{
205    create table feeds (
206            id serial,
207            url text not null,
208            name text,
209            delay interval not null default '30 sec', --'5 min',
210            active boolean default true,
211            last_update timestamp default 'now()',
212            polls int default 0,
213            updates int default 0
214    );
215    create unique index feeds_url on feeds(url);
216    insert into feeds (url,name) values ('http://wiki.razmjenavjestina.org/feed/workspace/razmjenavjestina?category=Recent%20Changes','wiki');
217            },
218    };
219    
220  });  foreach my $table ( keys %$sql_schema ) {
221    
222            eval {
223                    $dbh->do(qq{ select count(*) from $table });
224            };
225    
226            if ($@) {
227                    warn "creating database table $table in $DSN\n";
228                    $dbh->do( $sql_schema->{ $table } );
229            }
230    }
231    
232    
233    =head2 meta
234    
235    Set or get some meta data into database
236    
237            meta('nick','channel','var_name', $var_value );
238    
239            $var_value = meta('nick','channel','var_name');
240            ( $var_value, $changed ) = meta('nick','channel','var_name');
241    
242  =cut  =cut
243    
244    sub meta {
245            my ($nick,$channel,$name,$value) = @_;
246    
247            # normalize channel name
248            $channel =~ s/^#//;
249    
250            if (defined($value)) {
251    
252                    my $sth = $dbh->prepare(qq{ update meta set value = ?, changed = now() where nick = ? and channel = ? and name = ? });
253    
254                    eval { $sth->execute( $value, $nick, $channel, $name ) };
255    
256                    # error or no result
257                    if ( $@ || ! $sth->rows ) {
258                            $sth = $dbh->prepare(qq{ insert into meta (value,nick,channel,name,changed) values (?,?,?,?,now()) });
259                            $sth->execute( $value, $nick, $channel, $name );
260                            _log "created $nick/$channel/$name = $value";
261                    } else {
262                            _log "updated $nick/$channel/$name = $value ";
263                    }
264    
265                    return $value;
266    
267            } else {
268    
269                    my $sth = $dbh->prepare(qq{ select value,changed from meta where nick = ? and channel = ? and name = ? });
270                    $sth->execute( $nick, $channel, $name );
271                    my ($v,$c) = $sth->fetchrow_array;
272                    _log "fetched $nick/$channel/$name = $v [$c]";
273                    return ($v,$c) if wantarray;
274                    return $v;
275    
276            }
277    }
278    
279    
280    
281  my $sth = $dbh->prepare(qq{  my $sth = $dbh->prepare(qq{
282  insert into log  insert into log
283          (channel, nick, message)          (channel, me, nick, message, time)
284  values (?,?,?)  values (?,?,?,?,?)
285  });  });
286    
287    
288    my $tags;
289    
290  =head2 get_from_log  =head2 get_from_log
291    
292   my @messages = get_from_log(   my @messages = get_from_log(
# Line 85  values (?,?,?) Line 296  values (?,?,?)
296                  time => '{%s} ',                  time => '{%s} ',
297                  time_channel => '{%s %s} ',                  time_channel => '{%s %s} ',
298                  nick => '%s: ',                  nick => '%s: ',
299                    me_nick => '***%s ',
300                  message => '%s',                  message => '%s',
301          },          },
302          message_filter => sub {          filter => {
303                  # modify message content                  message => sub {
304                  return shift;                          # modify message content
305          }                          return shift;
306                    }
307            },
308            context => 5,
309            full_rows => 1,
310   );   );
311    
312    Order is important. Fields are first passed through C<filter> (if available) and
313    then throgh C<< sprintf($fmt->{message}, $message >> if available.
314    
315    C<context> defines number of messages around each search hit for display.
316    
317    C<full_rows> will return database rows for each result with C<date>, C<time>, C<channel>,
318    C<me>, C<nick> and C<message> keys.
319    
320  =cut  =cut
321    
322  sub get_from_log {  sub get_from_log {
323          my $args = {@_};          my $args = {@_};
324    
325          $args->{limit} ||= 10;          if ( ! $args->{fmt} ) {
326                    $args->{fmt} = {
327          $args->{fmt} ||= {                          date => '[%s] ',
328                  time => '{%s} ',                          time => '{%s} ',
329                  time_channel => '{%s %s} ',                          time_channel => '{%s %s} ',
330                  nick => '%s: ',                          nick => '%s: ',
331                  message => '%s',                          me_nick => '***%s ',
332          };                          message => '%s',
333                    };
334            }
335    
336          my $sql = qq{          my $sql_message = qq{
337                  select                  select
338                          time::date as date,                          time::date as date,
339                          time::time as time,                          time::time as time,
340                          channel,                          channel,
341                            me,
342                          nick,                          nick,
343                          message                          message
344                  from log                  from log
345          };          };
346          $sql .= " where message ilike ? " if ($args->{search});  
347            my $sql_context = qq{
348                    select
349                            id
350                    from log
351            };
352    
353            my $context = $1 if ($args->{search} && $args->{search} =~ s/\s*\+(\d+)\s*/ /);
354    
355            my $sql = $context ? $sql_context : $sql_message;
356    
357            sub check_date {
358                    my $date = shift || return;
359                    my $new_date = eval { DateTime::Format::ISO8601->parse_datetime( $date )->ymd; };
360                    if ( $@ ) {
361                            warn "invalid date $date\n";
362                            $new_date = DateTime->now->ymd;
363                    }
364                    return $new_date;
365            }
366    
367            my @where;
368            my @args;
369    
370            if (my $search = $args->{search}) {
371                    $search =~ s/^\s+//;
372                    $search =~ s/\s+$//;
373                    push @where, 'message ilike ? or nick ilike ?';
374                    push @args, ( ( '%' . $search . '%' ) x 2 );
375                    _log "search for '$search'";
376            }
377    
378            if ($args->{tag} && $tags->{ $args->{tag} }) {
379                    push @where, 'id in (' . join(',', @{ $tags->{ $args->{tag} } }) . ')';
380                    _log "search for tags $args->{tag}";
381            }
382    
383            if (my $date = $args->{date} ) {
384                    $date = check_date( $date );
385                    push @where, 'date(time) = ?';
386                    push @args, $date;
387                    _log "search for date $date";
388            }
389    
390            $sql .= " where " . join(" and ", @where) if @where;
391    
392          $sql .= " order by log.time desc";          $sql .= " order by log.time desc";
393          $sql .= " limit " . $args->{limit};          $sql .= " limit " . $args->{limit} if ($args->{limit});
394    
395            #warn "### sql: $sql ", dump( @args );
396    
397          my $sth = $dbh->prepare( $sql );          my $sth = $dbh->prepare( $sql );
398          if ($args->{search}) {          eval { $sth->execute( @args ) };
399                  $sth->execute( $args->{search} );          return if $@;
400          } else {  
                 $sth->execute();  
         }  
401          my $last_row = {          my $last_row = {
402                  date => '',                  date => '',
403                  time => '',                  time => '',
# Line 139  sub get_from_log { Line 411  sub get_from_log {
411                  unshift @rows, $row;                  unshift @rows, $row;
412          }          }
413    
414          my @msgs;          # normalize nick names
415            map {
416                    $_->{nick} =~ s/^_*(.*?)_*$/$1/
417            } @rows;
418    
419            return @rows if ($args->{full_rows});
420    
421            my @msgs = (
422                    "Showing " . ($#rows + 1) . " messages..."
423            );
424    
425            if ($context) {
426                    my @ids = @rows;
427                    @rows = ();
428    
429                    my $last_to = 0;
430    
431                    my $sth = $dbh->prepare( $sql_message . qq{ where id >= ? and id < ? } );
432                    foreach my $row_id (sort { $a->{id} <=> $b->{id} } @ids) {
433                            my $id = $row_id->{id} || die "can't find id in row";
434            
435                            my ($from, $to) = ($id - $context, $id + $context);
436                            $from = $last_to if ($from < $last_to);
437                            $last_to = $to;
438                            $sth->execute( $from, $to );
439    
440                            #warn "## id: $id from: $from to: $to returned: ", $sth->rows, "\n";
441    
442                            while (my $row = $sth->fetchrow_hashref) {
443                                    push @rows, $row;
444                            }
445    
446                    }
447            }
448    
449            # sprintf which can take coderef as first parametar
450            sub cr_sprintf {
451                    my $fmt = shift || return;
452                    if (ref($fmt) eq 'CODE') {
453                            $fmt->(@_);
454                    } else {
455                            sprintf($fmt, @_);
456                    }
457            }
458    
459          foreach my $row (@rows) {          foreach my $row (@rows) {
460    
461                  $row->{time} =~ s#\.\d+##;                  $row->{time} =~ s#\.\d+##;
462    
                 my $t;  
                 $t = $row->{date} . ' ' if ($last_row->{date} ne $row->{date});  
                 $t .= $row->{time};  
   
463                  my $msg = '';                  my $msg = '';
464    
465                    $msg = cr_sprintf($args->{fmt}->{date}, $row->{date}) . ' ' if ($last_row->{date} ne $row->{date});
466                    my $t = $row->{time};
467    
468                  if ($last_row->{channel} ne $row->{channel}) {                  if ($last_row->{channel} ne $row->{channel}) {
469                          $msg .= sprintf($args->{fmt}->{time_channel}, $t, $row->{channel});                          $msg .= cr_sprintf($args->{fmt}->{time_channel}, $t, $row->{channel});
470                  } else {                  } else {
471                          $msg .= sprintf($args->{fmt}->{time}, $t);                          $msg .= cr_sprintf($args->{fmt}->{time}, $t);
472                  }                  }
473    
474                  my $append = 1;                  my $append = 1;
475    
476                  if ($last_row->{nick} ne $row->{nick}) {                  my $nick = $row->{nick};
477                          $msg .= sprintf($args->{fmt}->{nick}, $row->{nick});  #               if ($nick =~ s/^_*(.*?)_*$/$1/) {
478    #                       $row->{nick} = $nick;
479    #               }
480    
481                    if ($last_row->{nick} ne $nick) {
482                            # obfu way to find format for me_nick if needed or fallback to default
483                            my $fmt = $row->{me} ? ( $args->{fmt}->{me_nick} || $args->{fmt}->{nick} ) : $args->{fmt}->{nick};
484                            $fmt ||= '%s';
485    
486                            $nick = $args->{filter}->{nick}->($nick) if (ref($args->{filter}->{nick}) eq 'CODE');
487    
488                            $msg .= cr_sprintf( $fmt, $nick );
489                          $append = 0;                          $append = 0;
490                  }                  }
491    
492                  if (ref($args->{message_filter}) eq 'CODE') {                  $args->{fmt}->{message} ||= '%s';
493                          $msg .= sprintf($args->{fmt}->{message},                  if (ref($args->{filter}->{message}) eq 'CODE') {
494                                  $args->{message_filter}->(                          $msg .= cr_sprintf($args->{fmt}->{message},
495                                    $args->{filter}->{message}->(
496                                          $row->{message}                                          $row->{message}
497                                  )                                  )
498                          );                          );
499                  } else {                  } else {
500                          $msg .= sprintf($args->{fmt}->{message}, $row->{message});                          $msg .= cr_sprintf($args->{fmt}->{message}, $row->{message});
501                  }                  }
502    
503                  if ($append && @msgs) {                  if ($append && @msgs) {
# Line 186  sub get_from_log { Line 512  sub get_from_log {
512          return @msgs;          return @msgs;
513  }  }
514    
515    # tags support
516    
517    my $cloud = HTML::TagCloud->new;
518    
519    =head2 add_tag
520    
521     add_tag( id => 42, message => 'irc message', nick => 'foobar' [, me => 1 ] );
522    
523    =cut
524    
525    my @last_tags;
526    
527    sub add_tag {
528            my $arg = {@_};
529    
530            return unless ($arg->{id} && $arg->{message});
531    
532            my $m = $arg->{message};
533            from_to('UTF-8', 'iso-8859-2', $m) if (is_utf8($m));
534    
535            my @tags;
536    
537            while ($m =~ s#$tag_regex##s) {
538                    my $tag = $1;
539                    next if (! $tag || $tag =~ m/https?:/i);
540                    push @{ $tags->{$tag} }, $arg->{id};
541                    #warn "+tag $tag: $arg->{id}\n";
542                    $cloud->add($tag, "$url?tag=$tag", scalar @{$tags->{$tag}} + 1);
543                    push @tags, $tag;
544    
545            }
546    
547            if ( @tags ) {
548                    pop @last_tags if $#last_tags == $last_x_tags;
549                    unshift @last_tags, { tags => [ @tags ], %$arg };
550            }
551    
552    }
553    
554    =head2 seed_tags
555    
556    Read all tags from database and create in-memory cache for tags
557    
558    =cut
559    
560    sub seed_tags {
561            my $sth = $dbh->prepare(qq{ select id,message,nick,me,time from log where message like '%//%' order by time asc });
562            $sth->execute;
563            while (my $row = $sth->fetchrow_hashref) {
564                    add_tag( %$row );
565            }
566    
567            foreach my $tag (keys %$tags) {
568                    $cloud->add($tag, "$url?tag=$tag", scalar @{$tags->{$tag}} + 1);
569            }
570    }
571    
572    seed_tags;
573    
574    
575    =head2 save_message
576    
577      save_message(
578            channel => '#foobar',
579            me => 0,
580            nick => 'dpavlin',
581            message => 'test message',
582            time => '2006-06-25 18:57:18',
583      );
584    
585    C<time> is optional, it will use C<< now() >> if it's not available.
586    
587    C<me> if not specified will be C<0> (not C</me> message)
588    
589    =cut
590    
591    sub save_message {
592            my $a = {@_};
593            confess "have msg" if $a->{msg};
594            $a->{me} ||= 0;
595            $a->{time} ||= strftime($TIMESTAMP,localtime());
596    
597            _log
598                    $a->{channel}, " ",
599                    $a->{me} ? "***" . $a->{nick} : "<" . $a->{nick} . ">",
600                    " " . $a->{message};
601    
602            from_to($a->{message}, 'UTF-8', $ENCODING);
603    
604            $sth->execute($a->{channel}, $a->{me}, $a->{nick}, $a->{message}, $a->{time});
605            add_tag( id => $dbh->last_insert_id(undef,undef,"log",undef), %$a );
606    }
607    
608    
609    if ($import_dircproxy) {
610            open(my $l, $import_dircproxy) || die "can't open $import_dircproxy: $!";
611            warn "importing $import_dircproxy...\n";
612            my $tz_offset = 1 * 60 * 60;    # TZ GMT+2
613            while(<$l>) {
614                    chomp;
615                    if (/^@(\d+)\s(\S+)\s(.+)$/) {
616                            my ($time, $nick, $msg) = ($1,$2,$3);
617    
618                            my $dt = DateTime->from_epoch( epoch => $time + $tz_offset );
619    
620                            my $me = 0;
621                            $me = 1 if ($nick =~ m/^\[\S+]/);
622                            $nick =~ s/^[\[<]([^!]+).*$/$1/;
623    
624                            $msg =~ s/^ACTION\s+// if ($me);
625    
626                            save_message(
627                                    channel => $CHANNEL,
628                                    me => $me,
629                                    nick => $nick,
630                                    message => $msg,
631                                    time => $dt->ymd . " " . $dt->hms,
632                            ) if ($nick !~ m/^-/);
633    
634                    } else {
635                            _log "can't parse: $_";
636                    }
637            }
638            close($l);
639            warn "import over\n";
640            exit;
641    }
642    
643    #
644    # RSS follow
645    #
646    
647    my $_rss;
648    
649    
650    sub rss_fetch {
651            my ($args) = @_;
652    
653            # how many messages to send out when feed is seen for the first time?
654            my $send_rss_msgs = 1;
655    
656            my $feed = XML::Feed->parse(URI->new( $args->{url} ));
657            if ( ! $feed ) {
658                    _log("can't fetch RSS ", $args->{url});
659                    return;
660            }
661            my $updates = 0;
662            for my $entry ($feed->entries) {
663    
664                    # seen allready?
665                    return if $_rss->{$feed->link}->{seen}->{$entry->id}++ > 0;
666    
667                    sub prefix {
668                            my ($txt,$var) = @_;
669                            $var =~ s/^\s+//g;
670                            return $txt . $var if $var;
671                    }
672    
673                    my $msg;
674                    $msg .= prefix( 'From: ' , $feed->title );
675                    $msg .= prefix( ' by ' , $entry->author );
676                    $msg .= prefix( ' -- ' , $entry->link );
677    #               $msg .= prefix( ' id ' , $entry->id );
678    
679                    _log('RSS', $msg);
680    
681                    if ( $args->{kernel} && $send_rss_msgs ) {
682                            warn "# sending to $CHANNEL\n";
683                            $send_rss_msgs--;
684                            $args->{kernel}->post( $IRC_ALIAS => notice => $CHANNEL, $msg );
685                            $updates++;
686                    }
687            }
688    
689            my $sql = qq{ update feeds set last_update = now(), polls = polls + 1 };
690            $sql .= qq{, updates = updates + $updates } if $updates;
691            $sql .= qq{where id = } . $args->{id};
692            $dbh->do( $sql );
693    
694            return $updates;
695    }
696    
697    sub rss_fetch_all {
698            my $kernel = shift;
699            my $sql = qq{
700                    select id, url, name
701                    from feeds
702                    where active is true
703            };
704            # limit to newer feeds only if we are not sending messages out
705            $sql .= qq{     and last_update + delay < now() } if $kernel;
706            my $sth = $dbh->prepare( $sql );
707            $sth->execute();
708            warn "# ",$sth->rows," active RSS feeds\n";
709            my $count = 0;
710            while (my $row = $sth->fetchrow_hashref) {
711                    warn "+++ fetch RSS feed: ",dump( $row );
712                    $row->{kernel} = $kernel if $kernel;
713                    $count += rss_fetch( $row );
714            }
715            return "OK, fetched $count posts from " . $sth->rows . " feeds";
716    }
717    
718    my $rss_last_poll = time();
719    
720    sub rss_check_updates {
721            my $kernel = shift;
722            my $t = time();
723            if ( $rss_last_poll - $t > $rss_min_delay ) {
724                    $rss_last_poll = $t;
725                    _log rss_fetch_all( $kernel );
726            }
727    }
728    
729    # seed rss seen cache so we won't send out all items on startup
730    _log rss_fetch_all;
731    
732    #
733    # POE handing part
734    #
735    
736  my $SKIPPING = 0;               # if skipping, how many we've done  my $SKIPPING = 0;               # if skipping, how many we've done
737  my $SEND_QUEUE;                 # cache  my $SEND_QUEUE;                 # cache
738    my $ping;                                               # ping stats
739    
740  POE::Component::IRC->new($IRC_ALIAS);  POE::Component::IRC->new($IRC_ALIAS);
741    
742  POE::Session->create  POE::Session->create( inline_states => {
743    (inline_states =>          _start => sub {      
    {_start => sub {        
744                  $_[KERNEL]->post($IRC_ALIAS => register => 'all');                  $_[KERNEL]->post($IRC_ALIAS => register => 'all');
745                  $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);                  $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);
746      },      },
# Line 202  POE::Session->create Line 748  POE::Session->create
748                  $_[KERNEL]->post($IRC_ALIAS => join => $CHANNEL);                  $_[KERNEL]->post($IRC_ALIAS => join => $CHANNEL);
749                  $_[KERNEL]->post($IRC_ALIAS => join => '#logger');                  $_[KERNEL]->post($IRC_ALIAS => join => '#logger');
750                  $_[KERNEL]->yield("heartbeat"); # start heartbeat                  $_[KERNEL]->yield("heartbeat"); # start heartbeat
751  #               $_[KERNEL]->yield("my_add", $_) for keys %FOLLOWS;                  $_[KERNEL]->yield("my_add", $_) for keys %FOLLOWS;
752                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );
753      },      },
754      irc_public => sub {      irc_public => sub {
# Line 211  POE::Session->create Line 757  POE::Session->create
757                  my $channel = $_[ARG1]->[0];                  my $channel = $_[ARG1]->[0];
758                  my $msg = $_[ARG2];                  my $msg = $_[ARG2];
759    
760                  from_to($msg, 'UTF-8', $ENCODING);                  save_message( channel => $channel, me => 0, nick => $nick, message => $msg);
761                    meta( $nick, $channel, 'last-msg', $msg );
762        },
763        irc_ctcp_action => sub {
764                    my $kernel = $_[KERNEL];
765                    my $nick = (split /!/, $_[ARG0])[0];
766                    my $channel = $_[ARG1]->[0];
767                    my $msg = $_[ARG2];
768    
769                    save_message( channel => $channel, me => 1, nick => $nick, message => $msg);
770    
771                    if ( $use_twitter ) {
772                            if ( my $twitter = meta( $nick, $NICK, 'twitter' ) ) {
773                                    my ($login,$passwd) = split(/\s+/,$twitter,2);
774                                    _log("sending twitter for $nick/$login on $channel ");
775                                    my $bot = Net::Twitter->new( username=>$login, password=>$passwd );
776                                    $bot->update("<${channel}> $msg");
777                            }
778                    }
779    
                 print "$channel: <$nick> $msg\n";  
                 $sth->execute($channel, $nick, $msg);  
780      },      },
781            irc_ping => sub {
782                    _log( "pong ", $_[ARG0] );
783                    $ping->{ $_[ARG0] }++;
784                    rss_check_updates( $_[KERNEL] );
785            },
786            irc_invite => sub {
787                    my $kernel = $_[KERNEL];
788                    my $nick = (split /!/, $_[ARG0])[0];
789                    my $channel = $_[ARG1];
790    
791                    _log "invited to $channel by $nick";
792    
793                    $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, "how nice of you to invite me to $channel, I'll be right there..." );
794                    $_[KERNEL]->post($IRC_ALIAS => join => $channel);
795    
796            },
797          irc_msg => sub {          irc_msg => sub {
798                  my $kernel = $_[KERNEL];                  my $kernel = $_[KERNEL];
799                  my $nick = (split /!/, $_[ARG0])[0];                  my $nick = (split /!/, $_[ARG0])[0];
800                  my $msg = $_[ARG2];                  my $msg = $_[ARG2];
801                    my $channel = $_[ARG1]->[0];
802                  from_to($msg, 'UTF-8', $ENCODING);                  from_to($msg, 'UTF-8', $ENCODING);
803    
804                  my $res = "unknown command '$msg', try /msg $NICK help!";                  my $res = "unknown command '$msg', try /msg $NICK help!";
805                  my @out;                  my @out;
806    
807                  print "<< $msg\n";                  _log "<< $msg";
808    
809                  if ($msg =~ m/^help/i) {                  if ($msg =~ m/^help/i) {
810    
# Line 233  POE::Session->create Line 812  POE::Session->create
812    
813                  } elsif ($msg =~ m/^msg\s+(\S+)\s+(.*)$/i) {                  } elsif ($msg =~ m/^msg\s+(\S+)\s+(.*)$/i) {
814    
815                          print ">> /msg $1 $2\n";                          _log ">> /msg $1 $2";
816                          $_[KERNEL]->post( $IRC_ALIAS => privmsg => $1, $2 );                          $_[KERNEL]->post( $IRC_ALIAS => privmsg => $1, $2 );
817                          $res = '';                          $res = '';
818    
# Line 242  POE::Session->create Line 821  POE::Session->create
821                          my $nr = $1 || 10;                          my $nr = $1 || 10;
822    
823                          my $sth = $dbh->prepare(qq{                          my $sth = $dbh->prepare(qq{
824                                  select nick,count(*) from log group by nick order by count desc limit $nr                                  select
825                                            trim(both '_' from nick) as nick,
826                                            count(*) as count,
827                                            sum(length(message)) as len
828                                    from log
829                                    group by trim(both '_' from nick)
830                                    order by len desc,count desc
831                                    limit $nr
832                          });                          });
833                          $sth->execute();                          $sth->execute();
834                          $res = "Top $nr users: ";                          $res = "Top $nr users: ";
835                          my @users;                          my @users;
836                          while (my $row = $sth->fetchrow_hashref) {                          while (my $row = $sth->fetchrow_hashref) {
837                                  push @users,$row->{nick} . ': ' . $row->{count};                                  push @users,$row->{nick} . ': ' . $row->{count} . '/' . $row->{len} . '=' . sprintf("%.2f", $row->{len}/$row->{count});
838                          }                          }
839                          $res .= join(" | ", @users);                          $res .= join(" | ", @users);
840                  } elsif ($msg =~ m/^last.*?\s*(\d*)/i) {                  } elsif ($msg =~ m/^last.*?\s*(\d*)/i) {
841    
842                          foreach my $res (get_from_log( limit => $1 )) {                          my $limit = $1 || meta( $nick, $channel, 'last-size' ) || 10;
843                                  print "last: $res\n";  
844                            foreach my $res (get_from_log( limit => $limit )) {
845                                    _log "last: $res";
846                                  from_to($res, $ENCODING, 'UTF-8');                                  from_to($res, $ENCODING, 'UTF-8');
847                                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );                                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );
848                          }                          }
849    
850                          $res = '';                          $res = '';
851    
852                  } elsif ($msg =~ m/^(search|grep)\s+(.*)$/i) {                  } elsif ($msg =~ m/^(search|grep)\s+(.*)\s*$/i) {
853    
854                          my $what = $2;                          my $what = $2;
855    
856                          foreach my $res (get_from_log( limit => 20, search => "%${what}%" )) {                          foreach my $res (get_from_log(
857                                  print "search [$what]: $res\n";                                          limit => 20,
858                                            search => $what,
859                                    )) {
860                                    _log "search [$what]: $res";
861                                  from_to($res, $ENCODING, 'UTF-8');                                  from_to($res, $ENCODING, 'UTF-8');
862                                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );                                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );
863                          }                          }
864    
865                          $res = '';                          $res = '';
866    
867                    } elsif ($msg =~ m/^(?:count|poll)\s+(.*)(?:\s+(\d+))?\s*$/i) {
868    
869                            my ($what,$limit) = ($1,$2);
870                            $limit ||= 100;
871    
872                            my $stat;
873    
874                            foreach my $res (get_from_log(
875                                            limit => $limit,
876                                            search => $what,
877                                            full_rows => 1,
878                                    )) {
879                                    while ($res->{message} =~ s/\Q$what\E(\+|\-)//) {
880                                            $stat->{vote}->{$1}++;
881                                            $stat->{from}->{ $res->{nick} }++;
882                                    }
883                            }
884    
885                            my @nicks;
886                            foreach my $nick (sort { $stat->{from}->{$a} <=> $stat->{from}->{$b} } keys %{ $stat->{from} }) {
887                                    push @nicks, $nick . ( $stat->{from}->{$nick} == 1 ? '' :
888                                            "(" . $stat->{from}->{$nick} . ")"
889                                    );
890                            }
891    
892                            $res =
893                                    "$what ++ " . ( $stat->{vote}->{'+'} || 0 ) .
894                                    " : " . ( $stat->{vote}->{'-'} || 0 ) . " --" .
895                                    " from " . ( join(", ", @nicks) || 'nobody' );
896    
897                            $_[KERNEL]->post( $IRC_ALIAS => notice => $nick, $res );
898    
899                    } elsif ($msg =~ m/^ping/) {
900                            $res = "ping = " . dump( $ping );
901                    } elsif ($msg =~ m/^conf(?:ig)*\s*(last-size|twitter)*\s*(.*)/) {
902                            if ( ! defined( $1 ) ) {
903                                    my $sth = $dbh->prepare(qq{ select name,value,changed from meta where nick = ? and channel = ? });
904                                    $sth->execute( $nick, $channel );
905                                    $res = "config for $nick on $channel";
906                                    while ( my ($n,$v) = $sth->fetchrow_array ) {
907                                            $res .= " | $n = $v";
908                                    }
909                            } elsif ( ! $2 ) {
910                                    my $val = meta( $nick, $channel, $1 );
911                                    $res = "current $1 = " . ( $val ? $val : 'undefined' );
912                            } else {
913                                    my $validate = {
914                                            'last-size' => qr/^\d+/,
915                                            'twitter' => qr/^\w+\s+\w+/,
916                                    };
917    
918                                    my ( $op, $val ) = ( $1, $2 );
919    
920                                    if ( my $regex = $validate->{$op} ) {
921                                            if ( $val =~ $regex ) {
922                                                    meta( $nick, $channel, $op, $val );
923                                                    $res = "saved $op = $val";
924                                            } else {
925                                                    $res = "config option $op = $val doesn't validate against $regex";
926                                            }
927                                    } else {
928                                            $res = "config option $op doesn't exist";
929                                    }
930                            }
931                    } elsif ($msg =~ m/^rss-update/) {
932                            $res = rss_fetch_all( $_[KERNEL] );
933                    } elsif ($msg =~ m/^rss-clean/) {
934                            $_rss = undef;
935                            $res = "OK, cleaned RSS cache";
936                    } elsif ($msg =~ m!^rss-(add|remove|stop|start)\s+(http://\S+)\s*(.*)!) {
937                            my $sql = {
938                                    add             => qq{ insert into feeds (url,name) values (?,?) },
939    #                               remove  => qq{ delete from feeds                                where url = ? and name = ? },
940                                    start   => qq{ update feeds set active = true   where url = ? -- ? },
941                                    stop    => qq{ update feeds set active = false  where url = ? -- ? },
942                                    
943                            };
944                            if (my $q = $sql->{$1} ) {
945                                    my $sth = $dbh->prepare( $q );
946                                    warn "## SQL $q ( $2 | $3 )\n";
947                                    eval { $sth->execute( $2, $3 ) };
948                            }
949    
950                            $res ||= "OK, RSS $1 : $2 - $3";
951                  }                  }
952    
953                  if ($res) {                  if ($res) {
954                          print ">> [$nick] $res\n";                          _log ">> [$nick] $res";
955                          from_to($res, $ENCODING, 'UTF-8');                          from_to($res, $ENCODING, 'UTF-8');
956                          $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );                          $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );
957                  }                  }
958    
959                    rss_check_updates( $_[KERNEL] );
960          },          },
961          irc_477 => sub {          irc_477 => sub {
962                  print "# irc_477: ",$_[ARG1], "\n";                  _log "# irc_477: ",$_[ARG1];
963                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "register $NICK" );                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "register $NICK" );
964          },          },
965          irc_505 => sub {          irc_505 => sub {
966                  print "# irc_505: ",$_[ARG1], "\n";                  _log "# irc_505: ",$_[ARG1];
967                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "register $NICK" );                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "register $NICK" );
968  #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "set hide email on" );  #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "set hide email on" );
969  #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "set email dpavlin\@rot13.org" );  #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "set email dpavlin\@rot13.org" );
970          },          },
971          irc_registered => sub {          irc_registered => sub {
972                  warn "## indetify $NICK\n";                  _log "## registrated $NICK";
973                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );
974          },          },
975            irc_disconnected => sub {
976                    _log "## disconnected, reconnecting again";
977                    $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);
978            },
979            irc_socketerr => sub {
980                    _log "## socket error... sleeping for $sleep_on_error seconds and retry";
981                    sleep($sleep_on_error);
982                    $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);
983            },
984  #       irc_433 => sub {  #       irc_433 => sub {
985  #               print "# irc_433: ",$_[ARG1], "\n";  #               print "# irc_433: ",$_[ARG1], "\n";
986  #               warn "## indetify $NICK\n";  #               warn "## indetify $NICK\n";
987  #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );  #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );
988  #       },  #       },
         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  
989      _child => sub {},      _child => sub {},
990      _default => sub {      _default => sub {
991        printf "%s: session %s caught an unhandled %s event.\n",                  _log sprintf "sID:%s %s %s",
992          scalar localtime(), $_[SESSION]->ID, $_[ARG0];                          $_[SESSION]->ID, $_[ARG0],
993        print "The $_[ARG0] event was given these parameters: ",                          ref($_[ARG1]) eq "ARRAY"        ?       join(",", map { ref($_) eq "ARRAY" ? join(";", @{$_}) : $_ } @{ $_[ARG1] })     :
994          join(" ", map({"ARRAY" eq ref $_ ? "[@$_]" : "$_"} @{$_[ARG1]})), "\n";                          $_[ARG1]                                        ?       $_[ARG1]                                        :
995                            "";
996        0;                        # false for signals        0;                        # false for signals
997      },      },
998      my_add => sub {      my_add => sub {
# Line 339  POE::Session->create Line 1007  POE::Session->create
1007                       Filename => $FOLLOWS{$trailing},                       Filename => $FOLLOWS{$trailing},
1008                       InputEvent => 'got_line',                       InputEvent => 'got_line',
1009                      );                      );
1010                                    warn "+++ following $trailing at $FOLLOWS{$trailing}\n";
1011              },              },
1012              got_line => sub {              got_line => sub {
1013                $_[KERNEL]->post($session => my_tailed =>                                  warn "+++ $trailing : $_[ARG0]\n";
1014                                 time, $trailing, $_[ARG0]);                                  $_[KERNEL]->post($session => my_tailed => time, $trailing, $_[ARG0]);
1015              },              },
1016             },             },
1017            );            );
# Line 393  POE::Session->create Line 1062  POE::Session->create
1062  # http server  # http server
1063    
1064  my $httpd = POE::Component::Server::HTTP->new(  my $httpd = POE::Component::Server::HTTP->new(
1065          Port => $NICK =~ m/-dev/ ? 8001 : 8000,          Port => $http_port,
1066            PreHandler => {
1067                    '/' => sub {
1068                            $_[0]->header(Connection => 'close')
1069                    }
1070            },
1071          ContentHandler => { '/' => \&root_handler },          ContentHandler => { '/' => \&root_handler },
1072          Headers        => { Server => 'irc-logger' },          Headers        => { Server => 'irc-logger' },
1073  );  );
1074    
1075  my $style = <<'_END_OF_STYLE_';  my $style = <<'_END_OF_STYLE_';
1076    p { margin: 0; padding: 0.1em; }
1077  .time, .channel { color: #808080; font-size: 60%; }  .time, .channel { color: #808080; font-size: 60%; }
1078  .nick { color: #0000ff; font-size: 80%; }  .date { float: right; background: #e0e0e0; color: #404040; font-size: 120%; padding: 0.25em; border: 1px dashed #808080; }
1079    .nick { color: #000000; font-size: 80%; padding: 2px; font-family: courier, courier new, monospace ; }
1080  .message { color: #000000; font-size: 100%; }  .message { color: #000000; font-size: 100%; }
1081    .search { float: right; }
1082    a:link.tag, a:visited.tag { border: 1px dashed #ccc; backgound: #ccc; text-decoration: none }
1083    a:hover.tag { border: 1px solid #eee }
1084    hr { border: 1px dashed #ccc; height: 1px; clear: both; }
1085    /*
1086    .col-0 { background: #ffff66 }
1087    .col-1 { background: #a0ffff }
1088    .col-2 { background: #99ff99 }
1089    .col-3 { background: #ff9999 }
1090    .col-4 { background: #ff66ff }
1091    */
1092    .calendar { border: 1px solid red; width: 100%; }
1093    .month { border: 0px; width: 100%; }
1094  _END_OF_STYLE_  _END_OF_STYLE_
1095    
1096    $max_color = 0;
1097    
1098    my @cols = qw(
1099            #ffcccc #ccffe6 #ccccff #e6ccff #ffccff #ffcce6 #ff9999 #ffcc99 #ffff99
1100            #ccff99 #99ff99 #99ffcc #99ccff #9999ff #cc99ff #ff6666 #ffb366 #ffff66
1101            #66ff66 #66ffb3 #66b3ff #6666ff #ff3333 #33ff33 #3399ff #3333ff #ff3399
1102            #a0a0a0 #ff0000 #ffff00 #80ff00 #0000ff #8000ff #ff00ff #ff0080 #994d00
1103            #999900 #009900 #cc0066 #c0c0c0 #ccff99 #99ff33 #808080 #660033 #ffffff
1104    );
1105    
1106    foreach my $c (@cols) {
1107            $style .= ".col-${max_color} { background: $c }\n";
1108            $max_color++;
1109    }
1110    warn "defined $max_color colors for users...\n";
1111    
1112  sub root_handler {  sub root_handler {
1113          my ($request, $response) = @_;          my ($request, $response) = @_;
1114          $response->code(RC_OK);          $response->code(RC_OK);
1115    
1116            # this doesn't seem to work, so moved to PreHandler
1117            #$response->header(Connection => 'close');
1118    
1119            return RC_OK if $request->uri =~ m/favicon.ico$/;
1120    
1121            my $q;
1122    
1123            if ( $request->method eq 'POST' ) {
1124                    $q = new CGI::Simple( $request->content );
1125            } elsif ( $request->uri =~ /\?(.+)$/ ) {
1126                    $q = new CGI::Simple( $1 );
1127            } else {
1128                    $q = new CGI::Simple;
1129            }
1130    
1131            my $search = $q->param('search') || $q->param('grep') || '';
1132    
1133            if ($request->url =~ m#/rss(?:/(tags|last-tag|follow.*)\w*(?:=(\d+))?)?#i) {
1134                    my $show = lc($1);
1135                    my $nr = $2;
1136    
1137                    my $type = 'RSS';       # Atom
1138    
1139                    $response->content_type( 'application/' . lc($type) . '+xml' );
1140    
1141                    my $html = '<!-- error -->';
1142                    #warn "create $type feed from ",dump( @last_tags );
1143    
1144                    my $feed = XML::Feed->new( $type );
1145                    $feed->link( $url );
1146    
1147                    if ( $show eq 'tags' ) {
1148                            $nr ||= 50;
1149                            $feed->title( "tags from $CHANNEL" );
1150                            $feed->link( "$url/tags" );
1151                            $feed->description( "tag cloud created from messages on channel $CHANNEL which have tags// in them" );
1152                            my $feed_entry = XML::Feed::Entry->new($type);
1153                            $feed_entry->title( "$nr tags from $CHANNEL" );
1154                            $feed_entry->author( $NICK );
1155                            $feed_entry->link( '/#tags'  );
1156    
1157                            $feed_entry->content(
1158                                    qq{<![CDATA[<style type="text/css">}
1159                                    . $cloud->css
1160                                    . qq{</style>}
1161                                    . $cloud->html( $nr )
1162                                    . qq{]]>}
1163                            );
1164                            $feed->add_entry( $feed_entry );
1165    
1166                    } elsif ( $show eq 'last-tag' ) {
1167    
1168                            $nr ||= $last_x_tags;
1169                            $nr = $last_x_tags if $nr > $last_x_tags;
1170    
1171                            $feed->title( "last $nr tagged messages from $CHANNEL" );
1172                            $feed->description( "collects messages which have tags// in them" );
1173    
1174                            foreach my $m ( @last_tags ) {
1175    #                               warn dump( $m );
1176                                    #my $tags = join(' ', @{$m->{tags}} );
1177                                    my $feed_entry = XML::Feed::Entry->new($type);
1178                                    $feed_entry->title( $m->{nick} . '@' . $m->{time} );
1179                                    $feed_entry->author( $m->{nick} );
1180                                    $feed_entry->link( '/#' . $m->{id}  );
1181                                    $feed_entry->issued( DateTime::Format::Flexible->build( $m->{time} ) );
1182    
1183                                    my $message = $filter->{message}->( $m->{message} );
1184                                    $message .= "<br/>\n" unless $message =~ m!<(/p|br/?)>!;
1185    #                               warn "## message = $message\n";
1186                                    from_to( $message, $ENCODING, 'UTF-8' );
1187    
1188                                    #$feed_entry->summary(
1189                                    $feed_entry->content(
1190                                            "<![CDATA[$message]]>"
1191                                    );
1192                                    $feed_entry->category( join(', ', @{$m->{tags}}) );
1193                                    $feed->add_entry( $feed_entry );
1194    
1195                                    $nr--;
1196                                    last if $nr <= 0;
1197    
1198                            }
1199    
1200                    } elsif ( $show =~ m/^follow/ ) {
1201    
1202                            $feed->title( "Feeds which this bot follows" );
1203    
1204                            my $sth = $dbh->prepare( qq{ select * from feeds order by last_update desc } );
1205                            $sth->execute;
1206                            while (my $row = $sth->fetchrow_hashref) {
1207                                    my $feed_entry = XML::Feed::Entry->new($type);
1208                                    $feed_entry->title( $row->{name} );
1209                                    $feed_entry->link( $row->{url}  );
1210                                    $feed_entry->issued( DateTime::Format::Flexible->build( $row->{last_update} ) );
1211                                    $feed_entry->content(
1212                                            '<![CDATA[<pre>' . dump( $row ) . '</pre>]]>'
1213                                    );
1214                                    $feed->add_entry( $feed_entry );
1215                            }
1216    
1217                    } else {
1218                            _log "unknown rss request ",$request->url;
1219                            return RC_DENY;
1220                    }
1221    
1222                    $response->content( $feed->as_xml );
1223                    return RC_OK;
1224            }
1225    
1226            if ( $@ ) {
1227                    warn "$@";
1228            }
1229    
1230          $response->content_type("text/html; charset=$ENCODING");          $response->content_type("text/html; charset=$ENCODING");
1231          $response->content(  
1232                  qq{<html><head><title>$NICK</title><style type="text/css">$style</style></head><body>} .          my $html =
1233                  "irc-logger url: " . $request->uri . '<br/>' .                  qq{<html><head><title>$NICK</title><style type="text/css">$style}
1234                  join("<br/>",                  . $cloud->css
1235                    . qq{</style></head><body>}
1236                    . qq{
1237                    <form method="post" class="search" action="/">
1238                    <input type="text" name="search" value="$search" size="10">
1239                    <input type="submit" value="search">
1240                    </form>
1241                    }
1242                    . $cloud->html(500)
1243                    . qq{<p>};
1244    
1245            if ($request->url =~ m#/tags?#) {
1246                    # nop
1247            } elsif ($request->url =~ m#/history#) {
1248                    my $sth = $dbh->prepare(qq{
1249                            select date(time) as date,count(*) as nr,sum(length(message)) as len
1250                                    from log
1251                                    group by date(time)
1252                                    order by date(time) desc
1253                    });
1254                    $sth->execute();
1255                    my ($l_yyyy,$l_mm) = (0,0);
1256                    $html .= qq{<table class="calendar"><tr>};
1257                    my $cal;
1258                    my $ord = 0;
1259                    while (my $row = $sth->fetchrow_hashref) {
1260                            # this is probably PostgreSQL specific, expects ISO date
1261                            my ($yyyy,$mm,$dd) = split(/-/, $row->{date});
1262                            if ($yyyy != $l_yyyy || $mm != $l_mm) {
1263                                    if ( $cal ) {
1264                                            $html .= qq{<td valign="top">} . $cal->as_HTML() . qq{</td>};
1265                                            $ord++;
1266                                            $html .= qq{</tr><tr>} if ( $ord % 3 == 0 );
1267                                    }
1268                                    $cal = new HTML::CalendarMonthSimple('month'=>$mm,'year'=>$yyyy);
1269                                    $cal->border(1);
1270                                    $cal->width('30%');
1271                                    $cal->cellheight('5em');
1272                                    $cal->tableclass('month');
1273                                    #$cal->cellclass('day');
1274                                    $cal->sunday('SUN');
1275                                    $cal->saturday('SAT');
1276                                    $cal->weekdays('MON','TUE','WED','THU','FRI');
1277                                    ($l_yyyy,$l_mm) = ($yyyy,$mm);
1278                            }
1279                            $cal->setcontent($dd, qq[
1280                                    <a href="$url?date=$row->{date}">$row->{nr}</a><br/>$row->{len}
1281                            ]);
1282                            
1283                    }
1284                    $html .= qq{<td valign="top">} . $cal->as_HTML() . qq{</td></tr></table>};
1285    
1286            } else {
1287                    $html .= join("</p><p>",
1288                          get_from_log(                          get_from_log(
1289                                  limit => 100,                                  limit => ( $q->param('last') || $q->param('date') ) ? undef : 100,
1290                                    search => $search || undef,
1291                                    tag => $q->param('tag') || undef,
1292                                    date => $q->param('date') || undef,
1293                                  fmt => {                                  fmt => {
1294                                            date => sub {
1295                                                    my $date = shift || return;
1296                                                    qq{<hr/><div class="date"><a href="$url?date=$date">$date</a></div>};
1297                                            },
1298                                          time => '<span class="time">%s</span> ',                                          time => '<span class="time">%s</span> ',
1299                                          time_channel => '<span class="channel">%s %s</span> ',                                          time_channel => '<span class="channel">%s %s</span> ',
1300                                          nick => '<span class="nick">%s:</span> ',                                          nick => '%s:&nbsp;',
1301                                            me_nick => '***%s&nbsp;',
1302                                          message => '<span class="message">%s</span>',                                          message => '<span class="message">%s</span>',
1303                                  },                                  },
1304                                  message_filter => sub {                                  filter => $filter,
                                         my $m = shift || return;  
                                         $m =~ s#($RE{URI}{HTTP})#<a href="$1">$1</a>#gs;  
                                         return $m;  
                                 },  
1305                          )                          )
1306                  ) .                  );
1307                  qq{</body></html>}          }
1308          );  
1309            $html .= qq{</p>
1310            <hr/>
1311            <p>See <a href="/history">history</a> of all messages.</p>
1312            </body></html>};
1313    
1314            $response->content( $html );
1315            warn "<< ", $request->method, " ", $request->uri, " created ", length($html), " bytes\n";
1316          return RC_OK;          return RC_OK;
1317  }  }
1318    
Legend:
Removed from v.15  
changed lines
  Added in v.85
  ViewVC Help
Powered by ViewVC 1.1.26