/[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 36 by dpavlin, Sun Jun 25 16:37:39 2006 UTC trunk/bin/irc-logger.pl revision 107 by dpavlin, Sun Mar 9 19:50:41 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 $HOSTNAME = `hostname`;  my $HOSTNAME = `hostname -f`;
51    chomp($HOSTNAME);
52    
53  my $NICK = 'irc-logger';  my $NICK = 'irc-logger';
54  $NICK .= '-dev' if ($HOSTNAME =~ m/llin/);  $NICK .= '-dev' if ($HOSTNAME =~ m/llin/);
55  my $CONNECT =  my $CONNECT = {
56    {Server => 'irc.freenode.net',          Server => 'irc.freenode.net',
57     Nick => $NICK,          Nick => $NICK,
58     Ircname => "try /msg $NICK help",          Ircname => "try /msg $NICK help",
59    };  };
60  my $CHANNEL = '#razmjenavjestina';  my $CHANNEL = '#razmjenavjestina';
61  $CHANNEL = '#irc-logger' if ($HOSTNAME =~ m/llin/);  $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    
 my $ENCODING = 'ISO-8859-2';  
73  my $TIMESTAMP = '%Y-%m-%d %H:%M:%S';  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 is_utf8/;  
 use Regexp::Common qw /URI/;  
 use CGI::Simple;  
 use HTML::TagCloud;  
 use POSIX qw/strftime/;  
 use HTML::CalendarMonthSimple;  
105    
106  my $dbh = DBI->connect($DSN,"","", { RaiseError => 1, AutoCommit => 1 }) || die $DBI::errstr;  sub _log {
107            print strftime($TIMESTAMP,localtime()) . ' ' . join(" ",@_) . $/;
108    }
109    
110    # HTML formatters
111    
112    my %escape = ('<'=>'&lt;', '>'=>'&gt;', '&'=>'&amp;', '"'=>'&quot;');
113    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  eval {                  $m =~ s/($escape_re)/$escape{$1}/gs;
131          $dbh->do(qq{ select count(*) from log });                  $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 79  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;  my $tags;
 my $tag_regex = '\b([\w-_]+)//';  
269    
270  =head2 get_from_log  =head2 get_from_log
271    
# Line 111  my $tag_regex = '\b([\w-_]+)//'; Line 286  my $tag_regex = '\b([\w-_]+)//';
286                  }                  }
287          },          },
288          context => 5,          context => 5,
289            full_rows => 1,
290   );   );
291    
292  Order is important. Fields are first passed through C<filter> (if available) and  Order is important. Fields are first passed through C<filter> (if available) and
# Line 118  then throgh C<< sprintf($fmt->{message}, Line 294  then throgh C<< sprintf($fmt->{message},
294    
295  C<context> defines number of messages around each search hit for display.  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->{fmt} ||= {          if ( ! $args->{fmt} ) {
306                  date => '[%s] ',                  $args->{fmt} = {
307                  time => '{%s} ',                          date => '[%s] ',
308                  time_channel => '{%s %s} ',                          time => '{%s} ',
309                  nick => '%s: ',                          time_channel => '{%s %s} ',
310                  me_nick => '***%s ',                          nick => '%s: ',
311                  message => '%s',                          me_nick => '***%s ',
312          };                          message => '%s',
313                    };
314            }
315    
316          my $sql_message = qq{          my $sql_message = qq{
317                  select                  select
# Line 153  sub get_from_log { Line 334  sub get_from_log {
334    
335          my $sql = $context ? $sql_context : $sql_message;          my $sql = $context ? $sql_context : $sql_message;
336    
337          $sql .= " where message ilike ? or nick ilike ? " if ($args->{search});          sub check_date {
338          $sql .= " where id in (" . join(",", @{ $tags->{ $args->{tag} } }) . ") " if ($args->{tag} && $tags->{ $args->{tag} });                  my $date = shift || return;
339          $sql .= " where date(time) = ? " if ($args->{date});                  my $new_date = eval { DateTime::Format::ISO8601->parse_datetime( $date )->ymd; };
340          $sql .= " order by log.time desc";                  if ( $@ ) {
341          $sql .= " limit " . $args->{limit} if ($args->{limit});                          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    
         my $sth = $dbh->prepare( $sql );  
351          if (my $search = $args->{search}) {          if (my $search = $args->{search}) {
352                  $search =~ s/^\s+//;                  $search =~ s/^\s+//;
353                  $search =~ s/\s+$//;                  $search =~ s/\s+$//;
354                  $sth->execute( ( '%' . $search . '%' ) x 2 );                  push @where, 'message ilike ? or nick ilike ?';
355                  warn "search for '$search' returned ", $sth->rows, " results ", $context || '', "\n";                  push @args, ( ( '%' . $search . '%' ) x 2 );
356          } elsif (my $tag = $args->{tag}) {                  $msg = "Search for '$search'";
357                  $sth->execute();          }
358                  warn "tag '$tag' returned ", $sth->rows, " results ", $context || '', "\n";  
359          } elsif (my $date = $args->{date}) {          if ($args->{tag} && $tags->{ $args->{tag} }) {
360                  $sth->execute($date);                  push @where, 'id in (' . join(',', @{ $tags->{ $args->{tag} } }) . ')';
361                  warn "found ", $sth->rows, " messages for date $date ", $context || '', "\n";                  $msg = "Search for tags $args->{tag}";
         } else {  
                 $sth->execute();  
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";
374            $sql .= " limit " . $args->{limit} if ($args->{limit});
375    
376            #warn "### sql: $sql ", dump( @args );
377    
378            my $sth = $dbh->prepare( $sql );
379            eval { $sth->execute( @args ) };
380            return if $@;
381    
382            my $nr_results = $sth->rows;
383    
384          my $last_row = {          my $last_row = {
385                  date => '',                  date => '',
386                  time => '',                  time => '',
# Line 187  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) {          if ($context) {
413                  my @ids = @rows;                  my @ids = @rows;
414                  @rows = ();                  @rows = ();
# Line 243  sub get_from_log { Line 461  sub get_from_log {
461                  my $append = 1;                  my $append = 1;
462    
463                  my $nick = $row->{nick};                  my $nick = $row->{nick};
464                  if ($nick =~ s/^_*(.*?)_*$/$1/) {  #               if ($nick =~ s/^_*(.*?)_*$/$1/) {
465                          $row->{nick} = $nick;  #                       $row->{nick} = $nick;
466                  }  #               }
467    
468                    $append = 0 if $row->{me};
469    
470                  if ($last_row->{nick} ne $nick) {                  if ($last_row->{nick} ne $nick) {
471                          # obfu way to find format for me_nick if needed or fallback to default                          # obfu way to find format for me_nick if needed or fallback to default
# Line 281  sub get_from_log { Line 501  sub get_from_log {
501          return @msgs;          return @msgs;
502  }  }
503    
504    # tags support
505    
506    my $cloud = HTML::TagCloud->new;
507    
508  my $SKIPPING = 0;               # if skipping, how many we've done  =head2 add_tag
509  my $SEND_QUEUE;                 # cache  
510     add_tag( id => 42, message => 'irc message', nick => 'foobar' [, me => 1 ] );
511    
512    =cut
513    
514    my @last_tags;
515    
516    sub add_tag {
517            my $arg = {@_};
518    
519            return unless ($arg->{id} && $arg->{message});
520    
521            my $m = $arg->{message};
522    
523            my @tags;
524    
525            while ($m =~ s#$tag_regex##s) {
526                    my $tag = $1;
527                    next if (! $tag || $tag =~ m/https?:/i);
528                    push @{ $tags->{$tag} }, $arg->{id};
529                    #warn "+tag $tag: $arg->{id}\n";
530                    $cloud->add($tag, "$url?tag=$tag", scalar @{$tags->{$tag}} + 1);
531                    push @tags, $tag;
532    
533            }
534    
535            if ( @tags ) {
536                    pop @last_tags if $#last_tags == $last_x_tags;
537                    unshift @last_tags, { tags => [ @tags ], %$arg };
538            }
539    
540    }
541    
542    =head2 seed_tags
543    
544    Read all tags from database and create in-memory cache for tags
545    
546    =cut
547    
548    sub seed_tags {
549            my $sth = $dbh->prepare(qq{ select id,message,nick,me,time from log where message like '%//%' order by time asc });
550            $sth->execute;
551            while (my $row = $sth->fetchrow_hashref) {
552                    add_tag( %$row );
553            }
554    
555            foreach my $tag (keys %$tags) {
556                    $cloud->add($tag, "$url?tag=$tag", scalar @{$tags->{$tag}} + 1);
557            }
558    }
559    
560    seed_tags;
561    
 POE::Component::IRC->new($IRC_ALIAS);  
562    
563  =head2 save_message  =head2 save_message
564    
565    save_message($channel,$me,$nick,$msg);    save_message(
566            channel => '#foobar',
567            me => 0,
568            nick => 'dpavlin',
569            message => 'test message',
570            time => '2006-06-25 18:57:18',
571      );
572    
573    C<time> is optional, it will use C<< now() >> if it's not available.
574    
575    C<me> if not specified will be C<0> (not C</me> message)
576    
577  =cut  =cut
578    
579  sub save_message {  sub save_message {
580          my ($channel,$me,$nick,$msg) = @_;          my $a = {@_};
581          $me ||= 0;          confess "have msg" if $a->{msg};
582          $sth->execute($channel, $me, $nick, $msg);          $a->{me} ||= 0;
583          add_tag( id => $dbh->last_insert_id(undef,undef,"log",undef),          $a->{time} ||= strftime($TIMESTAMP,localtime());
584                  message => $msg);  
585            _log
586                    $a->{channel}, " ",
587                    $a->{me} ? "***" . $a->{nick} : "<" . $a->{nick} . ">",
588                    " " . $a->{message};
589    
590            $sth_insert_log->execute($a->{channel}, $a->{me}, $a->{nick}, $a->{message}, $a->{time});
591            add_tag( id => $dbh->last_insert_id(undef,undef,"log",undef), %$a );
592  }  }
593    
594  POE::Session->create( inline_states =>  
595     {_start => sub {        if ($import_dircproxy) {
596            open(my $l, $import_dircproxy) || die "can't open $import_dircproxy: $!";
597            warn "importing $import_dircproxy...\n";
598            my $tz_offset = 1 * 60 * 60;    # TZ GMT+2
599            while(<$l>) {
600                    chomp;
601                    if (/^@(\d+)\s(\S+)\s(.+)$/) {
602                            my ($time, $nick, $msg) = ($1,$2,$3);
603    
604                            my $dt = DateTime->from_epoch( epoch => $time + $tz_offset );
605    
606                            my $me = 0;
607                            $me = 1 if ($nick =~ m/^\[\S+]/);
608                            $nick =~ s/^[\[<]([^!]+).*$/$1/;
609    
610                            $msg =~ s/^ACTION\s+// if ($me);
611    
612                            save_message(
613                                    channel => $CHANNEL,
614                                    me => $me,
615                                    nick => $nick,
616                                    message => $msg,
617                                    time => $dt->ymd . " " . $dt->hms,
618                            ) if ($nick !~ m/^-/);
619    
620                    } else {
621                            _log "can't parse: $_";
622                    }
623            }
624            close($l);
625            warn "import over\n";
626            exit;
627    }
628    
629    #
630    # RSS follow
631    #
632    
633    my $_rss;
634    
635    
636    sub rss_fetch {
637            my ($args) = @_;
638    
639            # how many messages to send out when feed is seen for the first time?
640            my $send_rss_msgs = 1;
641    
642            _log "RSS fetch", $args->{url};
643    
644            my $feed = XML::Feed->parse(URI->new( $args->{url} ));
645            if ( ! $feed ) {
646                    _log("can't fetch RSS ", $args->{url});
647                    return;
648            }
649    
650            my ( $total, $updates ) = ( 0, 0 );
651            for my $entry ($feed->entries) {
652                    $total++;
653    
654                    # seen allready?
655                    next if $_rss->{$args->{channel}}->{$feed->link}->{$entry->id}++ > 0;
656    
657                    sub prefix {
658                            my ($txt,$var) = @_;
659                            $var =~ s/\s+/ /gs;
660                            $var =~ s/^\s+//g;
661                            $var =~ s/\s+$//g;
662                            return $txt . $var if $var;
663                    }
664    
665                    # fix absolute and relative links to feed entries
666                    my $link = $entry->link;
667                    if ( $link =~ m!^/! ) {
668                            my $host = $args->{url};
669                            $host =~ s!^(http://[^/]+).*$!$1!;      #!vim
670                            $link = "$host/$link";
671                    } elsif ( $link !~ m!^http! ) {
672                            $link = $args->{url} . $link;
673                    }
674    
675                    my $msg;
676                    $msg .= prefix( 'From: ' , $args->{name} || $feed->title );
677                    $msg .= prefix( ' by ' , $entry->author );
678                    $msg .= prefix( ' | ' , $entry->title );
679                    $msg .= prefix( ' | ' , $link );
680    #               $msg .= prefix( ' id ' , $entry->id );
681    
682                    if ( $args->{kernel} && $send_rss_msgs ) {
683                            $send_rss_msgs--;
684                            if ( ! $args->{private} ) {
685                                    # FIXME bug! should be save_message
686    #                               save_message( channel => $args->{channel}, me => 1, nick => $NICK, message => $msg );
687                                    $sth_insert_log->execute( $args->{channel}, 1, $NICK, $msg, 'now()' );
688                            }
689                            my ( $type, $to ) = ( 'notice', $args->{channel} );
690                            ( $type, $to ) = ( 'privmsg', $args->{nick} ) if $args->{private};
691                            _log(">> $type $to |", $msg);
692                            $args->{kernel}->post( $IRC_ALIAS => $type => $to, $msg );
693                            $updates++;
694                    }
695            }
696    
697            my $sql = qq{ update feeds set last_update = now(), polls = polls + 1 };
698            $sql .= qq{, updates = updates + $updates } if $updates;
699            $sql .= qq{where id = } . $args->{id};
700            eval { $dbh->do( $sql ) };
701    
702            _log "RSS got $total items of which $updates new";
703    
704            return $updates;
705    }
706    
707    sub rss_fetch_all {
708            my $kernel = shift;
709            my $sql = qq{
710                    select id, url, name, channel, nick, private
711                    from feeds
712                    where active is true
713            };
714            # limit to newer feeds only if we are not sending messages out
715            $sql .= qq{     and last_update + delay < now() } if $kernel;
716            my $sth = $dbh->prepare( $sql );
717            $sth->execute();
718            warn "# ",$sth->rows," active RSS feeds\n";
719            my $count = 0;
720            while (my $row = $sth->fetchrow_hashref) {
721                    $row->{kernel} = $kernel if $kernel;
722                    $count += rss_fetch( $row );
723            }
724            return "OK, fetched $count posts from " . $sth->rows . " feeds";
725    }
726    
727    
728    sub rss_check_updates {
729            my $kernel = shift;
730            $_rss->{last_poll} ||= time();
731            my $dt = time() - $_rss->{last_poll};
732            warn "## rss_check_updates $dt > $rss_min_delay\n";
733            if ( $dt > $rss_min_delay ) {
734                    $_rss->{last_poll} = time();
735                    _log rss_fetch_all( $kernel );
736            }
737    }
738    
739    # seed rss seen cache so we won't send out all items on startup
740    _log rss_fetch_all;
741    
742    #
743    # POE handing part
744    #
745    
746    my $ping;                                               # ping stats
747    
748    POE::Component::IRC->new($IRC_ALIAS);
749    
750    POE::Session->create( inline_states => {
751            _start => sub {      
752                  $_[KERNEL]->post($IRC_ALIAS => register => 'all');                  $_[KERNEL]->post($IRC_ALIAS => register => 'all');
753                  $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);                  $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);
754      },      },
755      irc_255 => sub {    # server is done blabbing      irc_255 => sub {    # server is done blabbing
756                  $_[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;  
757                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );
758      },      },
759      irc_public => sub {      irc_public => sub {
# Line 319  POE::Session->create( inline_states => Line 762  POE::Session->create( inline_states =>
762                  my $channel = $_[ARG1]->[0];                  my $channel = $_[ARG1]->[0];
763                  my $msg = $_[ARG2];                  my $msg = $_[ARG2];
764    
765                  from_to($msg, 'UTF-8', $ENCODING);                  save_message( channel => $channel, me => 0, nick => $nick, message => $msg);
766                    meta( $nick, $channel, 'last-msg', $msg );
767                  print "$channel: <$nick> $msg\n";                  rss_check_updates( $kernel );
                 save_message($channel, 0, $nick, $msg);  
768      },      },
769      irc_ctcp_action => sub {      irc_ctcp_action => sub {
770                  my $kernel = $_[KERNEL];                  my $kernel = $_[KERNEL];
# Line 330  POE::Session->create( inline_states => Line 772  POE::Session->create( inline_states =>
772                  my $channel = $_[ARG1]->[0];                  my $channel = $_[ARG1]->[0];
773                  my $msg = $_[ARG2];                  my $msg = $_[ARG2];
774    
775                  from_to($msg, 'UTF-8', $ENCODING);                  save_message( channel => $channel, me => 1, nick => $nick, message => $msg);
776    
777                    if ( $use_twitter ) {
778                            if ( my $twitter = meta( $nick, $NICK, 'twitter' ) ) {
779                                    my ($login,$passwd) = split(/\s+/,$twitter,2);
780                                    _log("sending twitter for $nick/$login on $channel ");
781                                    my $bot = Net::Twitter->new( username=>$login, password=>$passwd );
782                                    $bot->update("<${channel}> $msg");
783                            }
784                    }
785    
                 print "$channel ***$nick $msg\n";  
                 save_message($channel, 1, $nick, $msg);  
786      },      },
787            irc_ping => sub {
788                    _log( "pong ", $_[ARG0] );
789                    $ping->{ $_[ARG0] }++;
790                    rss_check_updates( $_[KERNEL] );
791            },
792            irc_invite => sub {
793                    my $kernel = $_[KERNEL];
794                    my $nick = (split /!/, $_[ARG0])[0];
795                    my $channel = $_[ARG1];
796    
797                    _log "invited to $channel by $nick";
798    
799                    $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, "how nice of you to invite me to $channel, I'll be right there..." );
800                    $_[KERNEL]->post($IRC_ALIAS => join => $channel);
801    
802            },
803          irc_msg => sub {          irc_msg => sub {
804                  my $kernel = $_[KERNEL];                  my $kernel = $_[KERNEL];
805                  my $nick = (split /!/, $_[ARG0])[0];                  my $nick = (split /!/, $_[ARG0])[0];
806                  my $msg = $_[ARG2];                  my $msg = $_[ARG2];
807                  from_to($msg, 'UTF-8', $ENCODING);                  my $channel = $_[ARG1]->[0];
808    
809                  my $res = "unknown command '$msg', try /msg $NICK help!";                  my $res = "unknown command '$msg', try /msg $NICK help!";
810                  my @out;                  my @out;
811    
812                  print "<< $msg\n";                  _log "<< $msg";
813    
814                  if ($msg =~ m/^help/i) {                  if ($msg =~ m/^help/i) {
815    
# Line 352  POE::Session->create( inline_states => Line 817  POE::Session->create( inline_states =>
817    
818                  } elsif ($msg =~ m/^msg\s+(\S+)\s+(.*)$/i) {                  } elsif ($msg =~ m/^msg\s+(\S+)\s+(.*)$/i) {
819    
820                          print ">> /msg $1 $2\n";                          _log ">> /msg $1 $2";
821                          $_[KERNEL]->post( $IRC_ALIAS => privmsg => $1, $2 );                          $_[KERNEL]->post( $IRC_ALIAS => privmsg => $1, $2 );
822                          $res = '';                          $res = '';
823    
# Line 361  POE::Session->create( inline_states => Line 826  POE::Session->create( inline_states =>
826                          my $nr = $1 || 10;                          my $nr = $1 || 10;
827    
828                          my $sth = $dbh->prepare(qq{                          my $sth = $dbh->prepare(qq{
829                                  select nick,count(*) from log group by nick order by count desc limit $nr                                  select
830                                            trim(both '_' from nick) as nick,
831                                            count(*) as count,
832                                            sum(length(message)) as len
833                                    from log
834                                    group by trim(both '_' from nick)
835                                    order by len desc,count desc
836                                    limit $nr
837                          });                          });
838                          $sth->execute();                          $sth->execute();
839                          $res = "Top $nr users: ";                          $res = "Top $nr users: ";
840                          my @users;                          my @users;
841                          while (my $row = $sth->fetchrow_hashref) {                          while (my $row = $sth->fetchrow_hashref) {
842                                  push @users,$row->{nick} . ': ' . $row->{count};                                  push @users,$row->{nick} . ': ' . $row->{count} . '/' . $row->{len} . '=' . sprintf("%.2f", $row->{len}/$row->{count});
843                          }                          }
844                          $res .= join(" | ", @users);                          $res .= join(" | ", @users);
845                  } elsif ($msg =~ m/^last.*?\s*(\d*)/i) {                  } elsif ($msg =~ m/^last.*?\s*(\d*)/i) {
846    
847                          foreach my $res (get_from_log( limit => $1 )) {                          my $limit = $1 || meta( $nick, $channel, 'last-size' ) || 10;
848                                  print "last: $res\n";  
849                                  from_to($res, $ENCODING, 'UTF-8');                          foreach my $res (get_from_log( limit => $limit )) {
850                                    _log "last: $res";
851                                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );                                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );
852                          }                          }
853    
# Line 388  POE::Session->create( inline_states => Line 861  POE::Session->create( inline_states =>
861                                          limit => 20,                                          limit => 20,
862                                          search => $what,                                          search => $what,
863                                  )) {                                  )) {
864                                  print "search [$what]: $res\n";                                  _log "search [$what]: $res";
                                 from_to($res, $ENCODING, 'UTF-8');  
865                                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );                                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );
866                          }                          }
867    
868                          $res = '';                          $res = '';
869    
870                    } elsif ($msg =~ m/^(?:count|poll)\s+(.*)(?:\s+(\d+))?\s*$/i) {
871    
872                            my ($what,$limit) = ($1,$2);
873                            $limit ||= 100;
874    
875                            my $stat;
876    
877                            foreach my $res (get_from_log(
878                                            limit => $limit,
879                                            search => $what,
880                                            full_rows => 1,
881                                    )) {
882                                    while ($res->{message} =~ s/\Q$what\E(\+|\-)//) {
883                                            $stat->{vote}->{$1}++;
884                                            $stat->{from}->{ $res->{nick} }++;
885                                    }
886                            }
887    
888                            my @nicks;
889                            foreach my $nick (sort { $stat->{from}->{$a} <=> $stat->{from}->{$b} } keys %{ $stat->{from} }) {
890                                    push @nicks, $nick . ( $stat->{from}->{$nick} == 1 ? '' :
891                                            "(" . $stat->{from}->{$nick} . ")"
892                                    );
893                            }
894    
895                            $res =
896                                    "$what ++ " . ( $stat->{vote}->{'+'} || 0 ) .
897                                    " : " . ( $stat->{vote}->{'-'} || 0 ) . " --" .
898                                    " from " . ( join(", ", @nicks) || 'nobody' );
899    
900                            $_[KERNEL]->post( $IRC_ALIAS => notice => $nick, $res );
901    
902                    } elsif ($msg =~ m/^ping/) {
903                            $res = "ping = " . dump( $ping );
904                    } elsif ($msg =~ m/^conf(?:ig)*\s*(last-size|twitter)*\s*(.*)/) {
905                            if ( ! defined( $1 ) ) {
906                                    my $sth = $dbh->prepare(qq{ select name,value,changed from meta where nick = ? and channel = ? });
907                                    $sth->execute( $nick, $channel );
908                                    $res = "config for $nick on $channel";
909                                    while ( my ($n,$v) = $sth->fetchrow_array ) {
910                                            $res .= " | $n = $v";
911                                    }
912                            } elsif ( ! $2 ) {
913                                    my $val = meta( $nick, $channel, $1 );
914                                    $res = "current $1 = " . ( $val ? $val : 'undefined' );
915                            } else {
916                                    my $validate = {
917                                            'last-size' => qr/^\d+/,
918                                            'twitter' => qr/^\w+\s+\w+/,
919                                    };
920    
921                                    my ( $op, $val ) = ( $1, $2 );
922    
923                                    if ( my $regex = $validate->{$op} ) {
924                                            if ( $val =~ $regex ) {
925                                                    meta( $nick, $channel, $op, $val );
926                                                    $res = "saved $op = $val";
927                                            } else {
928                                                    $res = "config option $op = $val doesn't validate against $regex";
929                                            }
930                                    } else {
931                                            $res = "config option $op doesn't exist";
932                                    }
933                            }
934                    } elsif ($msg =~ m/^rss-update/) {
935                            $res = rss_fetch_all( $_[KERNEL] );
936                    } elsif ($msg =~ m/^rss-clean/) {
937                            $_rss = undef;
938                            $dbh->do( qq{ update feeds set last_update = now() - delay } );
939                            $res = "OK, cleaned RSS cache";
940                    } elsif ($msg =~ m/^rss-list/) {
941                            my $sth = $dbh->prepare(qq{ select url,name,last_update,active,channel,nick,private from feeds });
942                            $sth->execute;
943                            while (my @row = $sth->fetchrow_array) {
944                                    $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, join(' | ',@row) );
945                            }
946                            $res = '';
947                    } elsif ($msg =~ m!^rss-(add|remove|stop|start)(?:-(private))?\s+(http://\S+)\s*(.*)!) {
948                            my ( $command, $sub, $url, $arg ) = ( $1,$2,$3,$4 );
949    
950                            my $channel = $1 if ( $arg =~ s/\s*(#\S+)\s*// );
951                            $channel = $nick if $sub eq 'private';
952    
953                            my $sql = {
954                                    add     => qq{ insert into feeds (url,name,channel,nick,private) values (?,?,?,?,?) },
955    #                               remove  => qq{ delete from feeds                                where url = ? and name = ? },
956                                    start   => qq{ update feeds set active = true   where url = ? },
957                                    stop    => qq{ update feeds set active = false  where url = ? },
958                            };
959    
960                            if ( $command eq 'add' && ! $channel ) {
961                                    $res = "ERROR: got '$msg' which doesn't have #channel in it, ignoring!";
962                            } elsif (my $q = $sql->{$command} ) {
963                                    my $sth = $dbh->prepare( $q );
964                                    my @data = ( $url );
965                                    if ( $command eq 'add' ) {
966                                            push @data, ( $arg, $channel, $nick, $sub eq 'private' ? 1 : 0 );
967                                    }
968                                    warn "## $command SQL $q with ",dump( @data ),"\n";
969                                    eval { $sth->execute( @data ) };
970                                    if ($@) {
971                                            $res = "ERROR: $@";
972                                    } else {
973                                            $res = "OK, RSS [$command|$sub|$url|$arg]";
974                                    }
975                            } else {
976                                    $res = "ERROR: don't know what to do with: $msg";
977                            }
978                  }                  }
979    
980                  if ($res) {                  if ($res) {
981                          print ">> [$nick] $res\n";                          _log ">> [$nick] $res";
                         from_to($res, $ENCODING, 'UTF-8');  
982                          $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );                          $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );
983                  }                  }
984    
985                    rss_check_updates( $_[KERNEL] );
986            },
987            irc_372 => sub {
988                    _log "<< motd",$_[ARG0],$_[ARG1];
989            },
990            irc_375 => sub {
991                    _log "<< motd", $_[ARG0], "start";
992            },
993            irc_376 => sub {
994                    _log "<< motd", $_[ARG0], "end";
995          },          },
996          irc_477 => sub {          irc_477 => sub {
997                  print "# irc_477: ",$_[ARG1], "\n";                  _log "<< irc_477: ",$_[ARG1];
998                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "register $NICK" );                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "register $NICK" );
999          },          },
1000          irc_505 => sub {          irc_505 => sub {
1001                  print "# irc_505: ",$_[ARG1], "\n";                  _log "<< irc_505: ",$_[ARG1];
1002                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "register $NICK" );                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "register $NICK" );
1003  #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "set hide email on" );  #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "set hide email on" );
1004  #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "set email dpavlin\@rot13.org" );  #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "set email dpavlin\@rot13.org" );
1005          },          },
1006          irc_registered => sub {          irc_registered => sub {
1007                  warn "## indetify $NICK\n";                  _log "## registrated $NICK, /msg nickserv IDENTIFY $NICK";
1008                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );
1009          },          },
1010            irc_disconnected => sub {
1011                    _log "## disconnected.. sleeping for $sleep_on_error seconds and reconnecting again";
1012                    sleep($sleep_on_error);
1013                    $_[KERNEL]->post( $IRC_ALIAS => connect => $CONNECT);
1014            },
1015            irc_socketerr => sub {
1016                    _log "## socket error... sleeping for $sleep_on_error seconds and retry";
1017                    sleep($sleep_on_error);
1018                    $_[KERNEL]->post( $IRC_ALIAS => connect => $CONNECT);
1019            },
1020  #       irc_433 => sub {  #       irc_433 => sub {
1021  #               print "# irc_433: ",$_[ARG1], "\n";  #               print "# irc_433: ",$_[ARG1], "\n";
1022  #               warn "## indetify $NICK\n";  #               warn "## indetify $NICK\n";
1023  #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );  #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );
1024  #       },  #       },
1025    #       irc_451 # please register
1026            irc_snotice => sub {
1027                    _log "<< snotice",$_[ARG0];
1028                    if ( $_[ARG0] =~ m!/(QUOTE)\s+(PASS\s+\d+)!i ) {
1029                            warn ">> $1 | $2\n";
1030                            $_[KERNEL]->post( $IRC_ALIAS => lc($1) => $2);
1031                    }
1032            },
1033      _child => sub {},      _child => sub {},
1034      _default => sub {      _default => sub {
1035                  printf "%s #%s %s %s\n",                  _log sprintf "sID:%s %s %s",
1036                          strftime($TIMESTAMP,localtime()), $_[SESSION]->ID, $_[ARG0],                          $_[SESSION]->ID, $_[ARG0],
1037                          ref($_[ARG1]) eq "ARRAY"        ?       join(",", map { ref($_) eq "ARRAY" ? join(";", @{$_}) : $_ } @{ $_[ARG1] })     :                          ref($_[ARG1]) eq "ARRAY"        ?       join(",", map { ref($_) eq "ARRAY" ? join(";", @{$_}) : $_ } @{ $_[ARG1] })     :
1038                          $_[ARG1]                                        ?       $_[ARG1]                                        :                          $_[ARG1]                                        ?       $_[ARG1]                                        :
1039                          "";                          "";
1040        0;                        # false for signals        0;                        # false for signals
1041      },      },
     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);  
     }  
1042     },     },
1043    );    );
1044    
 # tags support  
   
 my $cloud = HTML::TagCloud->new;  
   
 =head2 add_tag  
   
  add_tag( id => 42, message => 'irc message' );  
   
 =cut  
   
 sub add_tag {  
         my $arg = {@_};  
   
         return unless ($arg->{id} && $arg->{message});  
   
         my $m = $arg->{message};  
         from_to('UTF-8', 'iso-8859-2', $m) if (is_utf8($m));  
   
         while ($m =~ s#$tag_regex##s) {  
                 my $tag = $1;  
                 next if (! $tag || $tag =~ m/https?:/i);  
                 push @{ $tags->{$tag} }, $arg->{id};  
                 #warn "+tag $tag: $arg->{id}\n";  
                 $cloud->add($tag, "?tag=$tag", scalar @{$tags->{$tag}} + 1);  
         }  
 }  
   
 =head2 seed_tags  
   
 Read all tags from database and create in-memory cache for tags  
   
 =cut  
   
 sub seed_tags {  
         my $sth = $dbh->prepare(qq{ select id,message from log where message like '%//%' });  
         $sth->execute;  
         while (my $row = $sth->fetchrow_hashref) {  
                 add_tag( %$row );  
         }  
   
         foreach my $tag (keys %$tags) {  
                 $cloud->add($tag, "?tag=$tag", scalar @{$tags->{$tag}} + 1);  
         }  
 }  
   
 seed_tags;  
   
1045  # http server  # http server
1046    
1047  my $httpd = POE::Component::Server::HTTP->new(  my $httpd = POE::Component::Server::HTTP->new(
1048          Port => $NICK =~ m/-dev/ ? 8001 : 8000,          Port => $http_port,
1049            PreHandler => {
1050                    '/' => sub {
1051                            $_[0]->header(Connection => 'close')
1052                    }
1053            },
1054          ContentHandler => { '/' => \&root_handler },          ContentHandler => { '/' => \&root_handler },
1055          Headers        => { Server => 'irc-logger' },          Headers        => { Server => 'irc-logger' },
1056  );  );
1057    
 my %escape = ('<'=>'&lt;', '>'=>'&gt;', '&'=>'&amp;', '"'=>'&quot;');  
 my $escape_re  = join '|' => keys %escape;  
   
1058  my $style = <<'_END_OF_STYLE_';  my $style = <<'_END_OF_STYLE_';
1059  p { margin: 0; padding: 0.1em; }  p { margin: 0; padding: 0.1em; }
1060  .time, .channel { color: #808080; font-size: 60%; }  .time, .channel { color: #808080; font-size: 60%; }
# Line 560  p { margin: 0; padding: 0.1em; } Line 1062  p { margin: 0; padding: 0.1em; }
1062  .nick { color: #000000; font-size: 80%; padding: 2px; font-family: courier, courier new, monospace ; }  .nick { color: #000000; font-size: 80%; padding: 2px; font-family: courier, courier new, monospace ; }
1063  .message { color: #000000; font-size: 100%; }  .message { color: #000000; font-size: 100%; }
1064  .search { float: right; }  .search { float: right; }
1065    a:link.tag, a:visited.tag { border: 1px dashed #ccc; backgound: #ccc; text-decoration: none }
1066    a:hover.tag { border: 1px solid #eee }
1067    hr { border: 1px dashed #ccc; height: 1px; clear: both; }
1068    /*
1069  .col-0 { background: #ffff66 }  .col-0 { background: #ffff66 }
1070  .col-1 { background: #a0ffff }  .col-1 { background: #a0ffff }
1071  .col-2 { background: #99ff99 }  .col-2 { background: #99ff99 }
1072  .col-3 { background: #ff9999 }  .col-3 { background: #ff9999 }
1073  .col-4 { background: #ff66ff }  .col-4 { background: #ff66ff }
1074  a:link.tag, a:visited.tag { border: 1px dashed #ccc; backgound: #ccc; text-decoration: none }  */
1075  a:hover.tag { border: 1px solid #eee }  .calendar { border: 1px solid red; width: 100%; }
1076  hr { border: 1px dashed #ccc; height: 1px; clear: both; }  .month { border: 0px; width: 100%; }
1077  _END_OF_STYLE_  _END_OF_STYLE_
1078    
1079  my $max_color = 4;  $max_color = 0;
1080    
1081  my %nick_enumerator;  my @cols = qw(
1082            #ffcccc #ccffe6 #ccccff #e6ccff #ffccff #ffcce6 #ff9999 #ffcc99 #ffff99
1083            #ccff99 #99ff99 #99ffcc #99ccff #9999ff #cc99ff #ff6666 #ffb366 #ffff66
1084            #66ff66 #66ffb3 #66b3ff #6666ff #ff3333 #33ff33 #3399ff #3333ff #ff3399
1085            #a0a0a0 #ff0000 #ffff00 #80ff00 #0000ff #8000ff #ff00ff #ff0080 #994d00
1086            #999900 #009900 #cc0066 #c0c0c0 #ccff99 #99ff33 #808080 #660033 #ffffff
1087    );
1088    
1089    foreach my $c (@cols) {
1090            $style .= ".col-${max_color} { background: $c }\n";
1091            $max_color++;
1092    }
1093    warn "defined $max_color colors for users...\n";
1094    
1095  sub root_handler {  sub root_handler {
1096          my ($request, $response) = @_;          my ($request, $response) = @_;
1097          $response->code(RC_OK);          $response->code(RC_OK);
1098          $response->content_type("text/html; charset=$ENCODING");  
1099            # this doesn't seem to work, so moved to PreHandler
1100            #$response->header(Connection => 'close');
1101    
1102            return RC_OK if $request->uri =~ m/favicon.ico$/;
1103    
1104          my $q;          my $q;
1105    
# Line 591  sub root_handler { Line 1113  sub root_handler {
1113    
1114          my $search = $q->param('search') || $q->param('grep') || '';          my $search = $q->param('search') || $q->param('grep') || '';
1115    
1116            if ($request->url =~ m#/rss(?:/(tags|last-tag|follow.*)\w*(?:=(\d+))?)?#i) {
1117                    my $show = lc($1);
1118                    my $nr = $2;
1119    
1120                    my $type = 'RSS';       # Atom
1121    
1122                    $response->content_type( 'application/' . lc($type) . '+xml' );
1123    
1124                    my $html = '<!-- error -->';
1125                    #warn "create $type feed from ",dump( @last_tags );
1126    
1127                    my $feed = XML::Feed->new( $type );
1128                    $feed->link( $url );
1129    
1130                    if ( $show eq 'tags' ) {
1131                            $nr ||= 50;
1132                            $feed->title( "tags from $CHANNEL" );
1133                            $feed->link( "$url/tags" );
1134                            $feed->description( "tag cloud created from messages on channel $CHANNEL which have tags// in them" );
1135                            my $feed_entry = XML::Feed::Entry->new($type);
1136                            $feed_entry->title( "$nr tags from $CHANNEL" );
1137                            $feed_entry->author( $NICK );
1138                            $feed_entry->link( '/#tags'  );
1139    
1140                            $feed_entry->content(
1141                                    qq{<![CDATA[<style type="text/css">}
1142                                    . $cloud->css
1143                                    . qq{</style>}
1144                                    . $cloud->html( $nr )
1145                                    . qq{]]>}
1146                            );
1147                            $feed->add_entry( $feed_entry );
1148    
1149                    } elsif ( $show eq 'last-tag' ) {
1150    
1151                            $nr ||= $last_x_tags;
1152                            $nr = $last_x_tags if $nr > $last_x_tags;
1153    
1154                            $feed->title( "last $nr tagged messages from $CHANNEL" );
1155                            $feed->description( "collects messages which have tags// in them" );
1156    
1157                            foreach my $m ( @last_tags ) {
1158    #                               warn dump( $m );
1159                                    #my $tags = join(' ', @{$m->{tags}} );
1160                                    my $feed_entry = XML::Feed::Entry->new($type);
1161                                    $feed_entry->title( $m->{nick} . '@' . $m->{time} );
1162                                    $feed_entry->author( $m->{nick} );
1163                                    $feed_entry->link( '/#' . $m->{id}  );
1164                                    $feed_entry->issued( DateTime::Format::Flexible->build( $m->{time} ) );
1165    
1166                                    my $message = $filter->{message}->( $m->{message} );
1167                                    $message .= "<br/>\n" unless $message =~ m!<(/p|br/?)>!;
1168    #                               warn "## message = $message\n";
1169    
1170                                    #$feed_entry->summary(
1171                                    $feed_entry->content(
1172                                            "<![CDATA[$message]]>"
1173                                    );
1174                                    $feed_entry->category( join(', ', @{$m->{tags}}) );
1175                                    $feed->add_entry( $feed_entry );
1176    
1177                                    $nr--;
1178                                    last if $nr <= 0;
1179    
1180                            }
1181    
1182                    } elsif ( $show =~ m/^follow/ ) {
1183    
1184                            $feed->title( "Feeds which this bot follows" );
1185    
1186                            my $sth = $dbh->prepare( qq{ select * from feeds order by last_update desc } );
1187                            $sth->execute;
1188                            while (my $row = $sth->fetchrow_hashref) {
1189                                    my $feed_entry = XML::Feed::Entry->new($type);
1190                                    $feed_entry->title( $row->{name} );
1191                                    $feed_entry->link( $row->{url}  );
1192                                    $feed_entry->issued( DateTime::Format::Flexible->build( $row->{last_update} ) );
1193                                    $feed_entry->content(
1194                                            '<![CDATA[<pre>' . dump( $row ) . '</pre>]]>'
1195                                    );
1196                                    $feed->add_entry( $feed_entry );
1197                            }
1198    
1199                            my $feed_entry = XML::Feed::Entry->new($type);
1200                            $feed_entry->title( "Internal stats" );
1201                            $feed_entry->content(
1202                                    '<![CDATA[<pre>' . dump( $_rss ) . '</pre>]]>'
1203                            );
1204                            $feed->add_entry( $feed_entry );
1205    
1206                    } else {
1207                            _log "unknown rss request ",$request->url;
1208                            return RC_DENY;
1209                    }
1210    
1211                    $response->content( $feed->as_xml );
1212                    return RC_OK;
1213            }
1214    
1215            if ( $@ ) {
1216                    warn "$@";
1217            }
1218    
1219            $response->content_type("text/html; charset=UTF-8");
1220    
1221          my $html =          my $html =
1222                  qq{<html><head><title>$NICK</title><style type="text/css">$style} .                  qq{<html><head><title>$NICK</title><style type="text/css">$style}
1223                  $cloud->css .                  . $cloud->css
1224                  qq{</style></head><body>} .                  . qq{</style></head><body>}
1225                  qq{                  . qq{
1226                  <form method="post" class="search" action="/">                  <form method="post" class="search" action="/">
1227                  <input type="text" name="search" value="$search" size="10">                  <input type="text" name="search" value="$search" size="10">
1228                  <input type="submit" value="search">                  <input type="submit" value="search">
1229                  </form>                  </form>
1230                  } .                  }
1231                  $cloud->html(500) .                  . $cloud->html(500)
1232                  qq{<p>};                  . qq{<p>};
1233          if ($request->url =~ m#/history#) {  
1234            if ($request->url =~ m#/tags?#) {
1235                    # nop
1236            } elsif ($request->url =~ m#/history#) {
1237                  my $sth = $dbh->prepare(qq{                  my $sth = $dbh->prepare(qq{
1238                          select date(time) as date,count(*) as nr                          select date(time) as date,count(*) as nr,sum(length(message)) as len
1239                                  from log                                  from log
1240                                  group by date(time)                                  group by date(time)
1241                                  order by date(time) desc                                  order by date(time) desc
1242                  });                  });
1243                  $sth->execute();                  $sth->execute();
1244                  my ($l_yyyy,$l_mm) = (0,0);                  my ($l_yyyy,$l_mm) = (0,0);
1245                    $html .= qq{<table class="calendar"><tr>};
1246                  my $cal;                  my $cal;
1247                    my $ord = 0;
1248                  while (my $row = $sth->fetchrow_hashref) {                  while (my $row = $sth->fetchrow_hashref) {
1249                          # this is probably PostgreSQL specific, expects ISO date                          # this is probably PostgreSQL specific, expects ISO date
1250                          my ($yyyy,$mm,$dd) = split(/-/, $row->{date});                          my ($yyyy,$mm,$dd) = split(/-/, $row->{date});
1251                          if ($yyyy != $l_yyyy || $mm != $l_mm) {                          if ($yyyy != $l_yyyy || $mm != $l_mm) {
1252                                  $html .= $cal->as_HTML() if ($cal);                                  if ( $cal ) {
1253                                            $html .= qq{<td valign="top">} . $cal->as_HTML() . qq{</td>};
1254                                            $ord++;
1255                                            $html .= qq{</tr><tr>} if ( $ord % 3 == 0 );
1256                                    }
1257                                  $cal = new HTML::CalendarMonthSimple('month'=>$mm,'year'=>$yyyy);                                  $cal = new HTML::CalendarMonthSimple('month'=>$mm,'year'=>$yyyy);
1258                                  $cal->border(2);                                  $cal->border(1);
1259                                    $cal->width('30%');
1260                                    $cal->cellheight('5em');
1261                                    $cal->tableclass('month');
1262                                    #$cal->cellclass('day');
1263                                    $cal->sunday('SUN');
1264                                    $cal->saturday('SAT');
1265                                    $cal->weekdays('MON','TUE','WED','THU','FRI');
1266                                  ($l_yyyy,$l_mm) = ($yyyy,$mm);                                  ($l_yyyy,$l_mm) = ($yyyy,$mm);
1267                          }                          }
1268                          $cal->setcontent($dd, qq{                          $cal->setcontent($dd, qq[
1269                                  <a href="/?date=$row->{date}">$row->{nr}</a>                                  <a href="$url?date=$row->{date}">$row->{nr}</a><br/>$row->{len}
1270                          });                          ]) if $cal;
1271                            
1272                  }                  }
1273                  $html .= $cal->as_HTML() if ($cal);                  $html .= qq{<td valign="top">} . $cal->as_HTML() . qq{</td></tr></table>};
1274    
1275          } else {          } else {
1276                  $html .= join("</p><p>",                  $html .= join("</p><p>",
1277                          get_from_log(                          get_from_log(
1278                                  limit => $q->param('last') || $q->param('date') ? undef : 100,                                  limit => ( $q->param('last') || $q->param('date') ) ? undef : 100,
1279                                  search => $search || undef,                                  search => $search || undef,
1280                                  tag => $q->param('tag') || undef,                                  tag => $q->param('tag') || undef,
1281                                  date => $q->param('date') || undef,                                  date => $q->param('date') || undef,
1282                                  fmt => {                                  fmt => {
1283                                          date => sub {                                          date => sub {
1284                                                  my $date = shift || return;                                                  my $date = shift || return;
1285                                                  qq{<hr/><div class="date"><a href="/?date=$date">$date</a></div> '};                                                  qq{<hr/><div class="date"><a href="$url?date=$date">$date</a></div>};
1286                                          },                                          },
1287                                          time => '<span class="time">%s</span> ',                                          time => '<span class="time">%s</span> ',
1288                                          time_channel => '<span class="channel">%s %s</span> ',                                          time_channel => '<span class="channel">%s %s</span> ',
# Line 646  sub root_handler { Line 1290  sub root_handler {
1290                                          me_nick => '***%s&nbsp;',                                          me_nick => '***%s&nbsp;',
1291                                          message => '<span class="message">%s</span>',                                          message => '<span class="message">%s</span>',
1292                                  },                                  },
1293                                  filter => {                                  filter => $filter,
                                         message => sub {  
                                                 my $m = shift || return;  
                                                 $m =~ s/($escape_re)/$escape{$1}/gs;  
                                                 $m =~ s#($RE{URI}{HTTP})#<a href="$1">$1</a>#gs;  
                                                 $m =~ s#$tag_regex#<a href="?tag=$1" class="tag">$1</a>#g;  
                                                 return $m;  
                                         },  
                                         nick => sub {  
                                                 my $n = shift || return;  
                                                 if (! $nick_enumerator{$n})  {  
                                                         my $max = scalar keys %nick_enumerator;  
                                                         $nick_enumerator{$n} = $max + 1;  
                                                 }  
                                                 return '<span class="nick col-' .  
                                                         ( $nick_enumerator{$n} % $max_color ) .  
                                                         '">' . $n . '</span>';  
                                         },  
                                 },  
1294                          )                          )
1295                  );                  );
1296          }          }
# Line 675  sub root_handler { Line 1301  sub root_handler {
1301          </body></html>};          </body></html>};
1302    
1303          $response->content( $html );          $response->content( $html );
1304            warn "<< ", $request->method, " ", $request->uri, " created ", length($html), " bytes\n";
1305          return RC_OK;          return RC_OK;
1306  }  }
1307    
Legend:
Removed from v.36  
changed lines
  Added in v.107
  ViewVC Help
Powered by ViewVC 1.1.26