/[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 31 by dpavlin, Sat Jun 17 17:23:26 2006 UTC trunk/bin/irc-logger.pl revision 102 by dpavlin, Sat Mar 8 17:38:30 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 -f`;
51    chomp($HOSTNAME);
52    
53  my $NICK = 'irc-logger';  my $NICK = 'irc-logger';
54  my $CONNECT =  $NICK .= '-dev' if ($HOSTNAME =~ m/llin/);
55    {Server => 'irc.freenode.net',  my $CONNECT = {
56     Nick => $NICK,          Server => 'irc.freenode.net',
57     Ircname => "try /msg $NICK help",          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 is_utf8/;  
 use Regexp::Common qw /URI/;  
 use CGI::Simple;  
 use HTML::TagCloud;  
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  eval {  my %nick_enumerator;
118          $dbh->do(qq{ select count(*) from log });  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            eval {
203                    $dbh->do(qq{ select count(*) from $table });
204            };
205    
206  _SQL_SCHEMA_          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 104  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 111  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->{limit} ||= 10;          if ( ! $args->{fmt} ) {
306                    $args->{fmt} = {
307          $args->{fmt} ||= {                          date => '[%s] ',
308                  date => '[%s] ',                          time => '{%s} ',
309                  time => '{%s} ',                          time_channel => '{%s %s} ',
310                  time_channel => '{%s %s} ',                          nick => '%s: ',
311                  nick => '%s: ',                          me_nick => '***%s ',
312                  me_nick => '***%s ',                          message => '%s',
313                  message => '%s',                  };
314          };          }
315    
316          my $sql_message = qq{          my $sql_message = qq{
317                  select                  select
# Line 148  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 .= " order by log.time desc";                  my $new_date = eval { DateTime::Format::ISO8601->parse_datetime( $date )->ymd; };
340          $sql .= " limit " . $args->{limit};                  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    
         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'";
                 $sth->execute();  
                 warn "tag '$tag' returned ", $sth->rows, " results ", $context || '', "\n";  
         } else {  
                 $sth->execute();  
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";
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 178  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 206  sub get_from_log { Line 433  sub get_from_log {
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    
450                  my $msg = '';                  my $msg = '';
451    
452                  $msg = sprintf($args->{fmt}->{date}, $row->{date}) . ' ' if ($last_row->{date} ne $row->{date});                  $msg = cr_sprintf($args->{fmt}->{date}, $row->{date}) . ' ' if ($last_row->{date} ne $row->{date});
453                  my $t = $row->{time};                  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                  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                  if ($last_row->{nick} ne $nick) {                  if ($last_row->{nick} ne $nick) {
469                          # 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 235  sub get_from_log { Line 472  sub get_from_log {
472    
473                          $nick = $args->{filter}->{nick}->($nick) if (ref($args->{filter}->{nick}) eq 'CODE');                          $nick = $args->{filter}->{nick}->($nick) if (ref($args->{filter}->{nick}) eq 'CODE');
474    
475                          $msg .= sprintf( $fmt, $nick );                          $msg .= cr_sprintf( $fmt, $nick );
476                          $append = 0;                          $append = 0;
477                  }                  }
478    
479                  $args->{fmt}->{message} ||= '%s';                  $args->{fmt}->{message} ||= '%s';
480                  if (ref($args->{filter}->{message}) eq 'CODE') {                  if (ref($args->{filter}->{message}) eq 'CODE') {
481                          $msg .= sprintf($args->{fmt}->{message},                          $msg .= cr_sprintf($args->{fmt}->{message},
482                                  $args->{filter}->{message}->(                                  $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 262  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    =cut
511    
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  my $SKIPPING = 0;               # if skipping, how many we've done  sub rss_check_updates {
723  my $SEND_QUEUE;                 # cache          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 287  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);  
                 add_tag( id => $dbh->last_insert_id(undef,undef,"log",undef),  
                         message => $msg);  
762      },      },
763      irc_ctcp_action => sub {      irc_ctcp_action => sub {
764                  my $kernel = $_[KERNEL];                  my $kernel = $_[KERNEL];
# Line 300  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);  
                 add_tag( id => $dbh->last_insert_id(undef,undef,"log",undef),  
                         message => $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 324  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 333  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    
# Line 360  POE::Session->create Line 855  POE::Session->create
855                                          limit => 20,                                          limit => 20,
856                                          search => $what,                                          search => $what,
857                                  )) {                                  )) {
858                                  print "search [$what]: $res\n";                                  _log "search [$what]: $res";
                                 from_to($res, $ENCODING, 'UTF-8');  
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";
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, reconnecting again";
997                    $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);
998            },
999            irc_socketerr => sub {
1000                    _log "## socket error... sleeping for $sleep_on_error seconds and retry";
1001                    sleep($sleep_on_error);
1002                    $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);
1003            },
1004  #       irc_433 => sub {  #       irc_433 => sub {
1005  #               print "# irc_433: ",$_[ARG1], "\n";  #               print "# irc_433: ",$_[ARG1], "\n";
1006  #               warn "## indetify $NICK\n";  #               warn "## indetify $NICK\n";
1007  #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );  #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );
1008  #       },  #       },
         irc_372 => sub {  
                 print "MOTD: ", $_[ARG1], "\n";  
         },  
         irc_snotice => sub {  
                 print "(server notice): ", $_[ARG0], "\n";  
         },  
     (map  
      {  
        ;"irc_$_" => sub { }}  
      qw(  
                 )),  
 #       join  
 #       ctcp_version  
 #       connected snotice ctcp_action ping notice mode part quit  
 #       001 002 003 004 005  
 #       250 251 252 253 254 265 266  
 #       332 333 353 366 372 375 376  
 #       477  
1009      _child => sub {},      _child => sub {},
1010      _default => sub {      _default => sub {
1011        printf "%s: session %s caught an unhandled %s event.\n",                  _log sprintf "sID:%s %s %s",
1012          scalar localtime(), $_[SESSION]->ID, $_[ARG0];                          $_[SESSION]->ID, $_[ARG0],
1013        print "The $_[ARG0] event was given these parameters: ",                          ref($_[ARG1]) eq "ARRAY"        ?       join(",", map { ref($_) eq "ARRAY" ? join(";", @{$_}) : $_ } @{ $_[ARG1] })     :
1014          join(" ", map({"ARRAY" eq ref $_ ? "[@$_]" : "$_"} @{$_[ARG1]})), "\n";                          $_[ARG1]                                        ?       $_[ARG1]                                        :
1015                            "";
1016        0;                        # false for signals        0;                        # false for signals
1017      },      },
     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);  
     }  
1018     },     },
1019    );    );
1020    
 # 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";  
         }  
 }  
   
 =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;  
   
1021  # http server  # http server
1022    
1023  my $httpd = POE::Component::Server::HTTP->new(  my $httpd = POE::Component::Server::HTTP->new(
1024          Port => $NICK =~ m/-dev/ ? 8001 : 8000,          Port => $http_port,
1025            PreHandler => {
1026                    '/' => sub {
1027                            $_[0]->header(Connection => 'close')
1028                    }
1029            },
1030          ContentHandler => { '/' => \&root_handler },          ContentHandler => { '/' => \&root_handler },
1031          Headers        => { Server => 'irc-logger' },          Headers        => { Server => 'irc-logger' },
1032  );  );
1033    
 my %escape = ('<'=>'&lt;', '>'=>'&gt;', '&'=>'&amp;', '"'=>'&quot;');  
 my $escape_re  = join '|' => keys %escape;  
   
1034  my $style = <<'_END_OF_STYLE_';  my $style = <<'_END_OF_STYLE_';
1035  p { margin: 0; padding: 0.1em; }  p { margin: 0; padding: 0.1em; }
1036  .time, .channel { color: #808080; font-size: 60%; }  .time, .channel { color: #808080; font-size: 60%; }
# Line 548  p { margin: 0; padding: 0.1em; } Line 1038  p { margin: 0; padding: 0.1em; }
1038  .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 ; }
1039  .message { color: #000000; font-size: 100%; }  .message { color: #000000; font-size: 100%; }
1040  .search { float: right; }  .search { float: right; }
1041    a:link.tag, a:visited.tag { border: 1px dashed #ccc; backgound: #ccc; text-decoration: none }
1042    a:hover.tag { border: 1px solid #eee }
1043    hr { border: 1px dashed #ccc; height: 1px; clear: both; }
1044    /*
1045  .col-0 { background: #ffff66 }  .col-0 { background: #ffff66 }
1046  .col-1 { background: #a0ffff }  .col-1 { background: #a0ffff }
1047  .col-2 { background: #99ff99 }  .col-2 { background: #99ff99 }
1048  .col-3 { background: #ff9999 }  .col-3 { background: #ff9999 }
1049  .col-4 { background: #ff66ff }  .col-4 { background: #ff66ff }
1050  a:link.tag, a:visited.tag { border: 1px dashed #ccc; backgound: #ccc; text-decoration: none }  */
1051  a:hover.tag { border: 1px solid #eee }  .calendar { border: 1px solid red; width: 100%; }
1052    .month { border: 0px; width: 100%; }
1053  _END_OF_STYLE_  _END_OF_STYLE_
1054    
1055  my $max_color = 4;  $max_color = 0;
1056    
1057  my %nick_enumerator;  my @cols = qw(
1058            #ffcccc #ccffe6 #ccccff #e6ccff #ffccff #ffcce6 #ff9999 #ffcc99 #ffff99
1059            #ccff99 #99ff99 #99ffcc #99ccff #9999ff #cc99ff #ff6666 #ffb366 #ffff66
1060            #66ff66 #66ffb3 #66b3ff #6666ff #ff3333 #33ff33 #3399ff #3333ff #ff3399
1061            #a0a0a0 #ff0000 #ffff00 #80ff00 #0000ff #8000ff #ff00ff #ff0080 #994d00
1062            #999900 #009900 #cc0066 #c0c0c0 #ccff99 #99ff33 #808080 #660033 #ffffff
1063    );
1064    
1065    foreach my $c (@cols) {
1066            $style .= ".col-${max_color} { background: $c }\n";
1067            $max_color++;
1068    }
1069    warn "defined $max_color colors for users...\n";
1070    
1071  sub root_handler {  sub root_handler {
1072          my ($request, $response) = @_;          my ($request, $response) = @_;
1073          $response->code(RC_OK);          $response->code(RC_OK);
1074          $response->content_type("text/html; charset=$ENCODING");  
1075            # this doesn't seem to work, so moved to PreHandler
1076            #$response->header(Connection => 'close');
1077    
1078            return RC_OK if $request->uri =~ m/favicon.ico$/;
1079    
1080          my $q;          my $q;
1081    
# Line 578  sub root_handler { Line 1089  sub root_handler {
1089    
1090          my $search = $q->param('search') || $q->param('grep') || '';          my $search = $q->param('search') || $q->param('grep') || '';
1091    
1092          $response->content(          if ($request->url =~ m#/rss(?:/(tags|last-tag|follow.*)\w*(?:=(\d+))?)?#i) {
1093                  qq{<html><head><title>$NICK</title><style type="text/css">$style} .                  my $show = lc($1);
1094                  $cloud->css .                  my $nr = $2;
1095                  qq{</style></head><body>} .  
1096                  qq{                  my $type = 'RSS';       # Atom
1097                  <form method="post" class="search">  
1098                    $response->content_type( 'application/' . lc($type) . '+xml' );
1099    
1100                    my $html = '<!-- error -->';
1101                    #warn "create $type feed from ",dump( @last_tags );
1102    
1103                    my $feed = XML::Feed->new( $type );
1104                    $feed->link( $url );
1105    
1106                    if ( $show eq 'tags' ) {
1107                            $nr ||= 50;
1108                            $feed->title( "tags from $CHANNEL" );
1109                            $feed->link( "$url/tags" );
1110                            $feed->description( "tag cloud created from messages on channel $CHANNEL which have tags// in them" );
1111                            my $feed_entry = XML::Feed::Entry->new($type);
1112                            $feed_entry->title( "$nr tags from $CHANNEL" );
1113                            $feed_entry->author( $NICK );
1114                            $feed_entry->link( '/#tags'  );
1115    
1116                            $feed_entry->content(
1117                                    qq{<![CDATA[<style type="text/css">}
1118                                    . $cloud->css
1119                                    . qq{</style>}
1120                                    . $cloud->html( $nr )
1121                                    . qq{]]>}
1122                            );
1123                            $feed->add_entry( $feed_entry );
1124    
1125                    } elsif ( $show eq 'last-tag' ) {
1126    
1127                            $nr ||= $last_x_tags;
1128                            $nr = $last_x_tags if $nr > $last_x_tags;
1129    
1130                            $feed->title( "last $nr tagged messages from $CHANNEL" );
1131                            $feed->description( "collects messages which have tags// in them" );
1132    
1133                            foreach my $m ( @last_tags ) {
1134    #                               warn dump( $m );
1135                                    #my $tags = join(' ', @{$m->{tags}} );
1136                                    my $feed_entry = XML::Feed::Entry->new($type);
1137                                    $feed_entry->title( $m->{nick} . '@' . $m->{time} );
1138                                    $feed_entry->author( $m->{nick} );
1139                                    $feed_entry->link( '/#' . $m->{id}  );
1140                                    $feed_entry->issued( DateTime::Format::Flexible->build( $m->{time} ) );
1141    
1142                                    my $message = $filter->{message}->( $m->{message} );
1143                                    $message .= "<br/>\n" unless $message =~ m!<(/p|br/?)>!;
1144    #                               warn "## message = $message\n";
1145    
1146                                    #$feed_entry->summary(
1147                                    $feed_entry->content(
1148                                            "<![CDATA[$message]]>"
1149                                    );
1150                                    $feed_entry->category( join(', ', @{$m->{tags}}) );
1151                                    $feed->add_entry( $feed_entry );
1152    
1153                                    $nr--;
1154                                    last if $nr <= 0;
1155    
1156                            }
1157    
1158                    } elsif ( $show =~ m/^follow/ ) {
1159    
1160                            $feed->title( "Feeds which this bot follows" );
1161    
1162                            my $sth = $dbh->prepare( qq{ select * from feeds order by last_update desc } );
1163                            $sth->execute;
1164                            while (my $row = $sth->fetchrow_hashref) {
1165                                    my $feed_entry = XML::Feed::Entry->new($type);
1166                                    $feed_entry->title( $row->{name} );
1167                                    $feed_entry->link( $row->{url}  );
1168                                    $feed_entry->issued( DateTime::Format::Flexible->build( $row->{last_update} ) );
1169                                    $feed_entry->content(
1170                                            '<![CDATA[<pre>' . dump( $row ) . '</pre>]]>'
1171                                    );
1172                                    $feed->add_entry( $feed_entry );
1173                            }
1174    
1175                            my $feed_entry = XML::Feed::Entry->new($type);
1176                            $feed_entry->title( "Internal stats" );
1177                            $feed_entry->content(
1178                                    '<![CDATA[<pre>' . dump( $_rss ) . '</pre>]]>'
1179                            );
1180                            $feed->add_entry( $feed_entry );
1181    
1182                    } else {
1183                            _log "unknown rss request ",$request->url;
1184                            return RC_DENY;
1185                    }
1186    
1187                    $response->content( $feed->as_xml );
1188                    return RC_OK;
1189            }
1190    
1191            if ( $@ ) {
1192                    warn "$@";
1193            }
1194    
1195            $response->content_type("text/html; charset=UTF-8");
1196    
1197            my $html =
1198                    qq{<html><head><title>$NICK</title><style type="text/css">$style}
1199                    . $cloud->css
1200                    . qq{</style></head><body>}
1201                    . qq{
1202                    <form method="post" class="search" action="/">
1203                  <input type="text" name="search" value="$search" size="10">                  <input type="text" name="search" value="$search" size="10">
1204                  <input type="submit" value="search">                  <input type="submit" value="search">
1205                  </form>                  </form>
1206                  } .                  }
1207                  $cloud->html(500) .                  . $cloud->html(500)
1208                  qq{<p>} .                  . qq{<p>};
1209                  join("</p><p>",  
1210            if ($request->url =~ m#/tags?#) {
1211                    # nop
1212            } elsif ($request->url =~ m#/history#) {
1213                    my $sth = $dbh->prepare(qq{
1214                            select date(time) as date,count(*) as nr,sum(length(message)) as len
1215                                    from log
1216                                    group by date(time)
1217                                    order by date(time) desc
1218                    });
1219                    $sth->execute();
1220                    my ($l_yyyy,$l_mm) = (0,0);
1221                    $html .= qq{<table class="calendar"><tr>};
1222                    my $cal;
1223                    my $ord = 0;
1224                    while (my $row = $sth->fetchrow_hashref) {
1225                            # this is probably PostgreSQL specific, expects ISO date
1226                            my ($yyyy,$mm,$dd) = split(/-/, $row->{date});
1227                            if ($yyyy != $l_yyyy || $mm != $l_mm) {
1228                                    if ( $cal ) {
1229                                            $html .= qq{<td valign="top">} . $cal->as_HTML() . qq{</td>};
1230                                            $ord++;
1231                                            $html .= qq{</tr><tr>} if ( $ord % 3 == 0 );
1232                                    }
1233                                    $cal = new HTML::CalendarMonthSimple('month'=>$mm,'year'=>$yyyy);
1234                                    $cal->border(1);
1235                                    $cal->width('30%');
1236                                    $cal->cellheight('5em');
1237                                    $cal->tableclass('month');
1238                                    #$cal->cellclass('day');
1239                                    $cal->sunday('SUN');
1240                                    $cal->saturday('SAT');
1241                                    $cal->weekdays('MON','TUE','WED','THU','FRI');
1242                                    ($l_yyyy,$l_mm) = ($yyyy,$mm);
1243                            }
1244                            $cal->setcontent($dd, qq[
1245                                    <a href="$url?date=$row->{date}">$row->{nr}</a><br/>$row->{len}
1246                            ]) if $cal;
1247                            
1248                    }
1249                    $html .= qq{<td valign="top">} . $cal->as_HTML() . qq{</td></tr></table>};
1250    
1251            } else {
1252                    $html .= join("</p><p>",
1253                          get_from_log(                          get_from_log(
1254                                  limit => $q->param('last') || 100,                                  limit => ( $q->param('last') || $q->param('date') ) ? undef : 100,
1255                                  search => $search || undef,                                  search => $search || undef,
1256                                  tag => $q->param('tag') || undef,                                  tag => $q->param('tag') || undef,
1257                                    date => $q->param('date') || undef,
1258                                  fmt => {                                  fmt => {
1259                                          date => '<hr size="1" style="clear: both;"/><div class="date">%s</div> ',                                          date => sub {
1260                                                    my $date = shift || return;
1261                                                    qq{<hr/><div class="date"><a href="$url?date=$date">$date</a></div>};
1262                                            },
1263                                          time => '<span class="time">%s</span> ',                                          time => '<span class="time">%s</span> ',
1264                                          time_channel => '<span class="channel">%s %s</span> ',                                          time_channel => '<span class="channel">%s %s</span> ',
1265                                          nick => '%s:&nbsp;',                                          nick => '%s:&nbsp;',
1266                                          me_nick => '***%s&nbsp;',                                          me_nick => '***%s&nbsp;',
1267                                          message => '<span class="message">%s</span>',                                          message => '<span class="message">%s</span>',
1268                                  },                                  },
1269                                  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>';  
                                         },  
                                 },  
1270                          )                          )
1271                  ) .                  );
1272                  qq{</p></body></html>}          }
1273          );  
1274            $html .= qq{</p>
1275            <hr/>
1276            <p>See <a href="/history">history</a> of all messages.</p>
1277            </body></html>};
1278    
1279            $response->content( $html );
1280            warn "<< ", $request->method, " ", $request->uri, " created ", length($html), " bytes\n";
1281          return RC_OK;          return RC_OK;
1282  }  }
1283    
Legend:
Removed from v.31  
changed lines
  Added in v.102
  ViewVC Help
Powered by ViewVC 1.1.26