/[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 14 by dpavlin, Sun Mar 12 14:36:12 2006 UTC trunk/bin/irc-logger.pl revision 91 by dpavlin, Fri Mar 7 10:13:45 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;
69  use Encode qw/from_to/;  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 64  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 84  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            filter => {
274                    message => sub {
275                            # 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 134  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                  $msg .= sprintf($args->{fmt}->{message}, $row->{message});                  $args->{fmt}->{message} ||= '%s';
464                    if (ref($args->{filter}->{message}) eq 'CODE') {
465                            $msg .= cr_sprintf($args->{fmt}->{message},
466                                    $args->{filter}->{message}->(
467                                            $row->{message}
468                                    )
469                            );
470                    } else {
471                            $msg .= cr_sprintf($args->{fmt}->{message}, $row->{message});
472                    }
473    
474                  if ($append && @msgs) {                  if ($append && @msgs) {
475                          $msgs[$#msgs] .= " " . $msg;                          $msgs[$#msgs] .= " " . $msg;
# Line 173  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  my $SKIPPING = 0;               # if skipping, how many we've done  =head2 seed_tags
525  my $SEND_QUEUE;                 # cache  
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            my ( $total, $updates ) = ( 0, 0 );
632            for my $entry ($feed->entries) {
633                    $total++;
634    
635                    # seen allready?
636                    return if $_rss->{$feed->link}->{seen}->{$entry->id}++ > 0;
637    
638                    sub prefix {
639                            my ($txt,$var) = @_;
640                            $var =~ s/^\s+//g;
641                            return $txt . $var if $var;
642                    }
643    
644                    my $msg;
645                    $msg .= prefix( 'From: ' , $args->{name} || $feed->title );
646                    $msg .= prefix( ' by ' , $entry->author );
647                    $msg .= prefix( ' -- ' , $entry->link );
648    #               $msg .= prefix( ' id ' , $entry->id );
649    
650                    if ( $args->{kernel} && $send_rss_msgs ) {
651                            $send_rss_msgs--;
652                            _log('RSS', $msg);
653                            $sth_insert_log->execute( $CHANNEL, 1, $NICK, $msg, undef );
654                            $args->{kernel}->post( $IRC_ALIAS => notice => $CHANNEL, $msg );
655                            $updates++;
656                    }
657            }
658    
659            my $sql = qq{ update feeds set last_update = now(), polls = polls + 1 };
660            $sql .= qq{, updates = updates + $updates } if $updates;
661            $sql .= qq{where id = } . $args->{id};
662            eval { $dbh->do( $sql ) };
663    
664            _log "RSS got $total items of which $updates new";
665    
666            return $updates;
667    }
668    
669    sub rss_fetch_all {
670            my $kernel = shift;
671            my $sql = qq{
672                    select id, url, name
673                    from feeds
674                    where active is true
675            };
676            # limit to newer feeds only if we are not sending messages out
677            $sql .= qq{     and last_update + delay < now() } if $kernel;
678            my $sth = $dbh->prepare( $sql );
679            $sth->execute();
680            warn "# ",$sth->rows," active RSS feeds\n";
681            my $count = 0;
682            while (my $row = $sth->fetchrow_hashref) {
683                    $row->{kernel} = $kernel if $kernel;
684                    $count += rss_fetch( $row );
685            }
686            return "OK, fetched $count posts from " . $sth->rows . " feeds";
687    }
688    
689    
690    sub rss_check_updates {
691            my $kernel = shift;
692            my $last_t = $_rss->{last_poll} || time();
693            my $t = time();
694            if ( $t - $last_t > $rss_min_delay ) {
695                    $_rss->{last_poll} = $t;
696                    _log rss_fetch_all( $kernel );
697            }
698    }
699    
700    # seed rss seen cache so we won't send out all items on startup
701    _log rss_fetch_all;
702    
703    #
704    # POE handing part
705    #
706    
707    my $ping;                                               # ping stats
708    
709  POE::Component::IRC->new($IRC_ALIAS);  POE::Component::IRC->new($IRC_ALIAS);
710    
711  POE::Session->create  POE::Session->create( inline_states => {
712    (inline_states =>          _start => sub {      
    {_start => sub {        
713                  $_[KERNEL]->post($IRC_ALIAS => register => 'all');                  $_[KERNEL]->post($IRC_ALIAS => register => 'all');
714                  $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);                  $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);
715      },      },
716      irc_255 => sub {    # server is done blabbing      irc_255 => sub {    # server is done blabbing
717                  $_[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;  
718                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );
719      },      },
720      irc_public => sub {      irc_public => sub {
# Line 198  POE::Session->create Line 723  POE::Session->create
723                  my $channel = $_[ARG1]->[0];                  my $channel = $_[ARG1]->[0];
724                  my $msg = $_[ARG2];                  my $msg = $_[ARG2];
725    
726                  from_to($msg, 'UTF-8', $ENCODING);                  save_message( channel => $channel, me => 0, nick => $nick, message => $msg);
727                    meta( $nick, $channel, 'last-msg', $msg );
728        },
729        irc_ctcp_action => sub {
730                    my $kernel = $_[KERNEL];
731                    my $nick = (split /!/, $_[ARG0])[0];
732                    my $channel = $_[ARG1]->[0];
733                    my $msg = $_[ARG2];
734    
735                    save_message( channel => $channel, me => 1, nick => $nick, message => $msg);
736    
737                    if ( $use_twitter ) {
738                            if ( my $twitter = meta( $nick, $NICK, 'twitter' ) ) {
739                                    my ($login,$passwd) = split(/\s+/,$twitter,2);
740                                    _log("sending twitter for $nick/$login on $channel ");
741                                    my $bot = Net::Twitter->new( username=>$login, password=>$passwd );
742                                    $bot->update("<${channel}> $msg");
743                            }
744                    }
745    
                 print "$channel: <$nick> $msg\n";  
                 $sth->execute($channel, $nick, $msg);  
746      },      },
747            irc_ping => sub {
748                    _log( "pong ", $_[ARG0] );
749                    $ping->{ $_[ARG0] }++;
750                    rss_check_updates( $_[KERNEL] );
751            },
752            irc_invite => sub {
753                    my $kernel = $_[KERNEL];
754                    my $nick = (split /!/, $_[ARG0])[0];
755                    my $channel = $_[ARG1];
756    
757                    _log "invited to $channel by $nick";
758    
759                    $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, "how nice of you to invite me to $channel, I'll be right there..." );
760                    $_[KERNEL]->post($IRC_ALIAS => join => $channel);
761    
762            },
763          irc_msg => sub {          irc_msg => sub {
764                  my $kernel = $_[KERNEL];                  my $kernel = $_[KERNEL];
765                  my $nick = (split /!/, $_[ARG0])[0];                  my $nick = (split /!/, $_[ARG0])[0];
766                  my $msg = $_[ARG2];                  my $msg = $_[ARG2];
767                  from_to($msg, 'UTF-8', $ENCODING);                  my $channel = $_[ARG1]->[0];
768    
769                  my $res = "unknown command '$msg', try /msg $NICK help!";                  my $res = "unknown command '$msg', try /msg $NICK help!";
770                  my @out;                  my @out;
771    
772                  print "<< $msg\n";                  _log "<< $msg";
773    
774                  if ($msg =~ m/^help/i) {                  if ($msg =~ m/^help/i) {
775    
# Line 220  POE::Session->create Line 777  POE::Session->create
777    
778                  } elsif ($msg =~ m/^msg\s+(\S+)\s+(.*)$/i) {                  } elsif ($msg =~ m/^msg\s+(\S+)\s+(.*)$/i) {
779    
780                          print ">> /msg $1 $2\n";                          _log ">> /msg $1 $2";
781                          $_[KERNEL]->post( $IRC_ALIAS => privmsg => $1, $2 );                          $_[KERNEL]->post( $IRC_ALIAS => privmsg => $1, $2 );
782                          $res = '';                          $res = '';
783    
# Line 229  POE::Session->create Line 786  POE::Session->create
786                          my $nr = $1 || 10;                          my $nr = $1 || 10;
787    
788                          my $sth = $dbh->prepare(qq{                          my $sth = $dbh->prepare(qq{
789                                  select nick,count(*) from log group by nick order by count desc limit $nr                                  select
790                                            trim(both '_' from nick) as nick,
791                                            count(*) as count,
792                                            sum(length(message)) as len
793                                    from log
794                                    group by trim(both '_' from nick)
795                                    order by len desc,count desc
796                                    limit $nr
797                          });                          });
798                          $sth->execute();                          $sth->execute();
799                          $res = "Top $nr users: ";                          $res = "Top $nr users: ";
800                          my @users;                          my @users;
801                          while (my $row = $sth->fetchrow_hashref) {                          while (my $row = $sth->fetchrow_hashref) {
802                                  push @users,$row->{nick} . ': ' . $row->{count};                                  push @users,$row->{nick} . ': ' . $row->{count} . '/' . $row->{len} . '=' . sprintf("%.2f", $row->{len}/$row->{count});
803                          }                          }
804                          $res .= join(" | ", @users);                          $res .= join(" | ", @users);
805                  } elsif ($msg =~ m/^last.*?\s*(\d*)/i) {                  } elsif ($msg =~ m/^last.*?\s*(\d*)/i) {
806    
807                          foreach my $res (get_from_log( limit => $1 )) {                          my $limit = $1 || meta( $nick, $channel, 'last-size' ) || 10;
808                                  print "last: $res\n";  
809                                  from_to($res, $ENCODING, 'UTF-8');                          foreach my $res (get_from_log( limit => $limit )) {
810                                    _log "last: $res";
811                                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );                                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );
812                          }                          }
813    
814                          $res = '';                          $res = '';
815    
816                  } elsif ($msg =~ m/^(search|grep)\s+(.*)$/i) {                  } elsif ($msg =~ m/^(search|grep)\s+(.*)\s*$/i) {
817    
818                          my $what = $2;                          my $what = $2;
819    
820                          foreach my $res (get_from_log( limit => 20, search => "%${what}%" )) {                          foreach my $res (get_from_log(
821                                  print "search [$what]: $res\n";                                          limit => 20,
822                                  from_to($res, $ENCODING, 'UTF-8');                                          search => $what,
823                                    )) {
824                                    _log "search [$what]: $res";
825                                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );                                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );
826                          }                          }
827    
828                          $res = '';                          $res = '';
829    
830                    } elsif ($msg =~ m/^(?:count|poll)\s+(.*)(?:\s+(\d+))?\s*$/i) {
831    
832                            my ($what,$limit) = ($1,$2);
833                            $limit ||= 100;
834    
835                            my $stat;
836    
837                            foreach my $res (get_from_log(
838                                            limit => $limit,
839                                            search => $what,
840                                            full_rows => 1,
841                                    )) {
842                                    while ($res->{message} =~ s/\Q$what\E(\+|\-)//) {
843                                            $stat->{vote}->{$1}++;
844                                            $stat->{from}->{ $res->{nick} }++;
845                                    }
846                            }
847    
848                            my @nicks;
849                            foreach my $nick (sort { $stat->{from}->{$a} <=> $stat->{from}->{$b} } keys %{ $stat->{from} }) {
850                                    push @nicks, $nick . ( $stat->{from}->{$nick} == 1 ? '' :
851                                            "(" . $stat->{from}->{$nick} . ")"
852                                    );
853                            }
854    
855                            $res =
856                                    "$what ++ " . ( $stat->{vote}->{'+'} || 0 ) .
857                                    " : " . ( $stat->{vote}->{'-'} || 0 ) . " --" .
858                                    " from " . ( join(", ", @nicks) || 'nobody' );
859    
860                            $_[KERNEL]->post( $IRC_ALIAS => notice => $nick, $res );
861    
862                    } elsif ($msg =~ m/^ping/) {
863                            $res = "ping = " . dump( $ping );
864                    } elsif ($msg =~ m/^conf(?:ig)*\s*(last-size|twitter)*\s*(.*)/) {
865                            if ( ! defined( $1 ) ) {
866                                    my $sth = $dbh->prepare(qq{ select name,value,changed from meta where nick = ? and channel = ? });
867                                    $sth->execute( $nick, $channel );
868                                    $res = "config for $nick on $channel";
869                                    while ( my ($n,$v) = $sth->fetchrow_array ) {
870                                            $res .= " | $n = $v";
871                                    }
872                            } elsif ( ! $2 ) {
873                                    my $val = meta( $nick, $channel, $1 );
874                                    $res = "current $1 = " . ( $val ? $val : 'undefined' );
875                            } else {
876                                    my $validate = {
877                                            'last-size' => qr/^\d+/,
878                                            'twitter' => qr/^\w+\s+\w+/,
879                                    };
880    
881                                    my ( $op, $val ) = ( $1, $2 );
882    
883                                    if ( my $regex = $validate->{$op} ) {
884                                            if ( $val =~ $regex ) {
885                                                    meta( $nick, $channel, $op, $val );
886                                                    $res = "saved $op = $val";
887                                            } else {
888                                                    $res = "config option $op = $val doesn't validate against $regex";
889                                            }
890                                    } else {
891                                            $res = "config option $op doesn't exist";
892                                    }
893                            }
894                    } elsif ($msg =~ m/^rss-update/) {
895                            $res = rss_fetch_all( $_[KERNEL] );
896                    } elsif ($msg =~ m/^rss-clean/) {
897                            $_rss = undef;
898                            $dbh->do( qq{ update feeds set last_update = now() - delay } );
899                            $res = "OK, cleaned RSS cache";
900                    } elsif ($msg =~ m/^rss-list/) {
901                            my $sth = $dbh->prepare(qq{ select url,name,last_update,active from feeds });
902                            $sth->execute;
903                            while (my @row = $sth->fetchrow_array) {
904                                    $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, join(' | ',@row) );
905                            }
906                            $res = '';
907                    } elsif ($msg =~ m!^rss-(add|remove|stop|start)\s+(http://\S+)\s*(.*)!) {
908                            my $sql = {
909                                    add             => qq{ insert into feeds (url,name) values (?,?) },
910    #                               remove  => qq{ delete from feeds                                where url = ? and name = ? },
911                                    start   => qq{ update feeds set active = true   where url = ? },
912                                    stop    => qq{ update feeds set active = false  where url = ? },
913                                    
914                            };
915                            if (my $q = $sql->{$1} ) {
916                                    my $sth = $dbh->prepare( $q );
917                                    my @data = ( $2 );
918                                    push @data, $3 if ( $q =~ s/\?//g == 2 );
919                                    warn "## $1 SQL $q with ",dump( @data ),"\n";
920                                    eval { $sth->execute( @data ) };
921                            }
922    
923                            $res = "OK, RSS $1 : $2 - $3";
924                  }                  }
925    
926                  if ($res) {                  if ($res) {
927                          print ">> [$nick] $res\n";                          _log ">> [$nick] $res";
                         from_to($res, $ENCODING, 'UTF-8');  
928                          $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );                          $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );
929                  }                  }
930    
931                    rss_check_updates( $_[KERNEL] );
932          },          },
933          irc_477 => sub {          irc_477 => sub {
934                  print "# irc_477: ",$_[ARG1], "\n";                  _log "# irc_477: ",$_[ARG1];
935                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "register $NICK" );                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "register $NICK" );
936          },          },
937          irc_505 => sub {          irc_505 => sub {
938                  print "# irc_505: ",$_[ARG1], "\n";                  _log "# irc_505: ",$_[ARG1];
939                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "register $NICK" );                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "register $NICK" );
940  #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "set hide email on" );  #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "set hide email on" );
941  #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "set email dpavlin\@rot13.org" );  #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "set email dpavlin\@rot13.org" );
942          },          },
943          irc_registered => sub {          irc_registered => sub {
944                  warn "## indetify $NICK\n";                  _log "## registrated $NICK";
945                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );
946          },          },
947            irc_disconnected => sub {
948                    _log "## disconnected, reconnecting again";
949                    $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);
950            },
951            irc_socketerr => sub {
952                    _log "## socket error... sleeping for $sleep_on_error seconds and retry";
953                    sleep($sleep_on_error);
954                    $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);
955            },
956  #       irc_433 => sub {  #       irc_433 => sub {
957  #               print "# irc_433: ",$_[ARG1], "\n";  #               print "# irc_433: ",$_[ARG1], "\n";
958  #               warn "## indetify $NICK\n";  #               warn "## indetify $NICK\n";
959  #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );  #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );
960  #       },  #       },
         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  
961      _child => sub {},      _child => sub {},
962      _default => sub {      _default => sub {
963        printf "%s: session %s caught an unhandled %s event.\n",                  _log sprintf "sID:%s %s %s",
964          scalar localtime(), $_[SESSION]->ID, $_[ARG0];                          $_[SESSION]->ID, $_[ARG0],
965        print "The $_[ARG0] event was given these parameters: ",                          ref($_[ARG1]) eq "ARRAY"        ?       join(",", map { ref($_) eq "ARRAY" ? join(";", @{$_}) : $_ } @{ $_[ARG1] })     :
966          join(" ", map({"ARRAY" eq ref $_ ? "[@$_]" : "$_"} @{$_[ARG1]})), "\n";                          $_[ARG1]                                        ?       $_[ARG1]                                        :
967                            "";
968        0;                        # false for signals        0;                        # false for signals
969      },      },
     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);  
     }  
970     },     },
971    );    );
972    
973  # http server  # http server
974    
975  my $httpd = POE::Component::Server::HTTP->new(  my $httpd = POE::Component::Server::HTTP->new(
976          Port => $NICK =~ m/-dev/ ? 8001 : 8000,          Port => $http_port,
977            PreHandler => {
978                    '/' => sub {
979                            $_[0]->header(Connection => 'close')
980                    }
981            },
982          ContentHandler => { '/' => \&root_handler },          ContentHandler => { '/' => \&root_handler },
983          Headers        => { Server => 'irc-logger' },          Headers        => { Server => 'irc-logger' },
984  );  );
985    
986  my $style = <<'_END_OF_STYLE_';  my $style = <<'_END_OF_STYLE_';
987    p { margin: 0; padding: 0.1em; }
988  .time, .channel { color: #808080; font-size: 60%; }  .time, .channel { color: #808080; font-size: 60%; }
989  .nick { color: #0000ff; font-size: 80%; }  .date { float: right; background: #e0e0e0; color: #404040; font-size: 120%; padding: 0.25em; border: 1px dashed #808080; }
990    .nick { color: #000000; font-size: 80%; padding: 2px; font-family: courier, courier new, monospace ; }
991  .message { color: #000000; font-size: 100%; }  .message { color: #000000; font-size: 100%; }
992    .search { float: right; }
993    a:link.tag, a:visited.tag { border: 1px dashed #ccc; backgound: #ccc; text-decoration: none }
994    a:hover.tag { border: 1px solid #eee }
995    hr { border: 1px dashed #ccc; height: 1px; clear: both; }
996    /*
997    .col-0 { background: #ffff66 }
998    .col-1 { background: #a0ffff }
999    .col-2 { background: #99ff99 }
1000    .col-3 { background: #ff9999 }
1001    .col-4 { background: #ff66ff }
1002    */
1003    .calendar { border: 1px solid red; width: 100%; }
1004    .month { border: 0px; width: 100%; }
1005  _END_OF_STYLE_  _END_OF_STYLE_
1006    
1007    $max_color = 0;
1008    
1009    my @cols = qw(
1010            #ffcccc #ccffe6 #ccccff #e6ccff #ffccff #ffcce6 #ff9999 #ffcc99 #ffff99
1011            #ccff99 #99ff99 #99ffcc #99ccff #9999ff #cc99ff #ff6666 #ffb366 #ffff66
1012            #66ff66 #66ffb3 #66b3ff #6666ff #ff3333 #33ff33 #3399ff #3333ff #ff3399
1013            #a0a0a0 #ff0000 #ffff00 #80ff00 #0000ff #8000ff #ff00ff #ff0080 #994d00
1014            #999900 #009900 #cc0066 #c0c0c0 #ccff99 #99ff33 #808080 #660033 #ffffff
1015    );
1016    
1017    foreach my $c (@cols) {
1018            $style .= ".col-${max_color} { background: $c }\n";
1019            $max_color++;
1020    }
1021    warn "defined $max_color colors for users...\n";
1022    
1023  sub root_handler {  sub root_handler {
1024          my ($request, $response) = @_;          my ($request, $response) = @_;
1025          $response->code(RC_OK);          $response->code(RC_OK);
1026          $response->content_type("text/html; charset=$ENCODING");  
1027          $response->content(          # this doesn't seem to work, so moved to PreHandler
1028                  qq{<html><head><title>$NICK</title><style type="text/css">$style</style></head><body>} .          #$response->header(Connection => 'close');
1029                  "irc-logger url: " . $request->uri . '<br/>' .  
1030                  join("<br/>",          return RC_OK if $request->uri =~ m/favicon.ico$/;
1031    
1032            my $q;
1033    
1034            if ( $request->method eq 'POST' ) {
1035                    $q = new CGI::Simple( $request->content );
1036            } elsif ( $request->uri =~ /\?(.+)$/ ) {
1037                    $q = new CGI::Simple( $1 );
1038            } else {
1039                    $q = new CGI::Simple;
1040            }
1041    
1042            my $search = $q->param('search') || $q->param('grep') || '';
1043    
1044            if ($request->url =~ m#/rss(?:/(tags|last-tag|follow.*)\w*(?:=(\d+))?)?#i) {
1045                    my $show = lc($1);
1046                    my $nr = $2;
1047    
1048                    my $type = 'RSS';       # Atom
1049    
1050                    $response->content_type( 'application/' . lc($type) . '+xml' );
1051    
1052                    my $html = '<!-- error -->';
1053                    #warn "create $type feed from ",dump( @last_tags );
1054    
1055                    my $feed = XML::Feed->new( $type );
1056                    $feed->link( $url );
1057    
1058                    if ( $show eq 'tags' ) {
1059                            $nr ||= 50;
1060                            $feed->title( "tags from $CHANNEL" );
1061                            $feed->link( "$url/tags" );
1062                            $feed->description( "tag cloud created from messages on channel $CHANNEL which have tags// in them" );
1063                            my $feed_entry = XML::Feed::Entry->new($type);
1064                            $feed_entry->title( "$nr tags from $CHANNEL" );
1065                            $feed_entry->author( $NICK );
1066                            $feed_entry->link( '/#tags'  );
1067    
1068                            $feed_entry->content(
1069                                    qq{<![CDATA[<style type="text/css">}
1070                                    . $cloud->css
1071                                    . qq{</style>}
1072                                    . $cloud->html( $nr )
1073                                    . qq{]]>}
1074                            );
1075                            $feed->add_entry( $feed_entry );
1076    
1077                    } elsif ( $show eq 'last-tag' ) {
1078    
1079                            $nr ||= $last_x_tags;
1080                            $nr = $last_x_tags if $nr > $last_x_tags;
1081    
1082                            $feed->title( "last $nr tagged messages from $CHANNEL" );
1083                            $feed->description( "collects messages which have tags// in them" );
1084    
1085                            foreach my $m ( @last_tags ) {
1086    #                               warn dump( $m );
1087                                    #my $tags = join(' ', @{$m->{tags}} );
1088                                    my $feed_entry = XML::Feed::Entry->new($type);
1089                                    $feed_entry->title( $m->{nick} . '@' . $m->{time} );
1090                                    $feed_entry->author( $m->{nick} );
1091                                    $feed_entry->link( '/#' . $m->{id}  );
1092                                    $feed_entry->issued( DateTime::Format::Flexible->build( $m->{time} ) );
1093    
1094                                    my $message = $filter->{message}->( $m->{message} );
1095                                    $message .= "<br/>\n" unless $message =~ m!<(/p|br/?)>!;
1096    #                               warn "## message = $message\n";
1097    
1098                                    #$feed_entry->summary(
1099                                    $feed_entry->content(
1100                                            "<![CDATA[$message]]>"
1101                                    );
1102                                    $feed_entry->category( join(', ', @{$m->{tags}}) );
1103                                    $feed->add_entry( $feed_entry );
1104    
1105                                    $nr--;
1106                                    last if $nr <= 0;
1107    
1108                            }
1109    
1110                    } elsif ( $show =~ m/^follow/ ) {
1111    
1112                            $feed->title( "Feeds which this bot follows" );
1113    
1114                            my $sth = $dbh->prepare( qq{ select * from feeds order by last_update desc } );
1115                            $sth->execute;
1116                            while (my $row = $sth->fetchrow_hashref) {
1117                                    my $feed_entry = XML::Feed::Entry->new($type);
1118                                    $feed_entry->title( $row->{name} );
1119                                    $feed_entry->link( $row->{url}  );
1120                                    $feed_entry->issued( DateTime::Format::Flexible->build( $row->{last_update} ) );
1121                                    $feed_entry->content(
1122                                            '<![CDATA[<pre>' . dump( $row ) . '</pre>]]>'
1123                                    );
1124                                    $feed->add_entry( $feed_entry );
1125                            }
1126    
1127                    } else {
1128                            _log "unknown rss request ",$request->url;
1129                            return RC_DENY;
1130                    }
1131    
1132                    $response->content( $feed->as_xml );
1133                    return RC_OK;
1134            }
1135    
1136            if ( $@ ) {
1137                    warn "$@";
1138            }
1139    
1140            $response->content_type("text/html; charset=UTF-8");
1141    
1142            my $html =
1143                    qq{<html><head><title>$NICK</title><style type="text/css">$style}
1144                    . $cloud->css
1145                    . qq{</style></head><body>}
1146                    . qq{
1147                    <form method="post" class="search" action="/">
1148                    <input type="text" name="search" value="$search" size="10">
1149                    <input type="submit" value="search">
1150                    </form>
1151                    }
1152                    . $cloud->html(500)
1153                    . qq{<p>};
1154    
1155            if ($request->url =~ m#/tags?#) {
1156                    # nop
1157            } elsif ($request->url =~ m#/history#) {
1158                    my $sth = $dbh->prepare(qq{
1159                            select date(time) as date,count(*) as nr,sum(length(message)) as len
1160                                    from log
1161                                    group by date(time)
1162                                    order by date(time) desc
1163                    });
1164                    $sth->execute();
1165                    my ($l_yyyy,$l_mm) = (0,0);
1166                    $html .= qq{<table class="calendar"><tr>};
1167                    my $cal;
1168                    my $ord = 0;
1169                    while (my $row = $sth->fetchrow_hashref) {
1170                            # this is probably PostgreSQL specific, expects ISO date
1171                            my ($yyyy,$mm,$dd) = split(/-/, $row->{date});
1172                            if ($yyyy != $l_yyyy || $mm != $l_mm) {
1173                                    if ( $cal ) {
1174                                            $html .= qq{<td valign="top">} . $cal->as_HTML() . qq{</td>};
1175                                            $ord++;
1176                                            $html .= qq{</tr><tr>} if ( $ord % 3 == 0 );
1177                                    }
1178                                    $cal = new HTML::CalendarMonthSimple('month'=>$mm,'year'=>$yyyy);
1179                                    $cal->border(1);
1180                                    $cal->width('30%');
1181                                    $cal->cellheight('5em');
1182                                    $cal->tableclass('month');
1183                                    #$cal->cellclass('day');
1184                                    $cal->sunday('SUN');
1185                                    $cal->saturday('SAT');
1186                                    $cal->weekdays('MON','TUE','WED','THU','FRI');
1187                                    ($l_yyyy,$l_mm) = ($yyyy,$mm);
1188                            }
1189                            $cal->setcontent($dd, qq[
1190                                    <a href="$url?date=$row->{date}">$row->{nr}</a><br/>$row->{len}
1191                            ]) if $cal;
1192                            
1193                    }
1194                    $html .= qq{<td valign="top">} . $cal->as_HTML() . qq{</td></tr></table>};
1195    
1196            } else {
1197                    $html .= join("</p><p>",
1198                          get_from_log(                          get_from_log(
1199                                  limit => 100,                                  limit => ( $q->param('last') || $q->param('date') ) ? undef : 100,
1200                                    search => $search || undef,
1201                                    tag => $q->param('tag') || undef,
1202                                    date => $q->param('date') || undef,
1203                                  fmt => {                                  fmt => {
1204                                            date => sub {
1205                                                    my $date = shift || return;
1206                                                    qq{<hr/><div class="date"><a href="$url?date=$date">$date</a></div>};
1207                                            },
1208                                          time => '<span class="time">%s</span> ',                                          time => '<span class="time">%s</span> ',
1209                                          time_channel => '<span class="channel">%s %s</span> ',                                          time_channel => '<span class="channel">%s %s</span> ',
1210                                          nick => '<span class="nick">%s:</span> ',                                          nick => '%s:&nbsp;',
1211                                            me_nick => '***%s&nbsp;',
1212                                          message => '<span class="message">%s</span>',                                          message => '<span class="message">%s</span>',
1213                                  },                                  },
1214                                    filter => $filter,
1215                          )                          )
1216                  ) .                  );
1217                  qq{</body></html>}          }
1218          );  
1219            $html .= qq{</p>
1220            <hr/>
1221            <p>See <a href="/history">history</a> of all messages.</p>
1222            </body></html>};
1223    
1224            $response->content( $html );
1225            warn "<< ", $request->method, " ", $request->uri, " created ", length($html), " bytes\n";
1226          return RC_OK;          return RC_OK;
1227  }  }
1228    
Legend:
Removed from v.14  
changed lines
  Added in v.91
  ViewVC Help
Powered by ViewVC 1.1.26