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