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