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