/[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 27 by dpavlin, Mon May 22 16:19:00 2006 UTC trunk/bin/irc-logger.pl revision 104 by dpavlin, Sun Mar 9 00:47:38 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/;  
 use Regexp::Common qw /URI/;  
 use CGI::Simple;  
105    
106    sub _log {
107            print strftime($TIMESTAMP,localtime()) . ' ' . join(" ",@_) . $/;
108    }
109    
110  my $dbh = DBI->connect($DSN,"","", { RaiseError => 1, AutoCommit => 1 }) || die $DBI::errstr;  # HTML formatters
111    
112    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                    $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  eval {                  $m =~ s#uri_unescape{([^}]+)}#uri_unescape($1)#egs;
138          $dbh->do(qq{ select count(*) from log });                  return $m;
139            },
140            nick => sub {
141                    my $n = shift || return;
142                    if (! $nick_enumerator{$n})  {
143                            my $max = scalar keys %nick_enumerator;
144                            $nick_enumerator{$n} = $max + 1;
145                    }
146                    return '<span class="nick col-' .
147                            ( $nick_enumerator{$n} % $max_color ) .
148                            '">' . $n . '</span>';
149            },
150  };  };
151    
152  if ($@) {  my $dbh = DBI->connect($DSN,"","", { RaiseError => 1, AutoCommit => 1 }) || die $DBI::errstr;
153          warn "creating database table in $DSN\n";  $dbh->do( qq{ set client_encoding = 'UTF-8' } );
         $dbh->do(<<'_SQL_SCHEMA_');  
154    
155    my $sql_schema = {
156            log => qq{
157  create table log (  create table log (
158          id serial,          id serial,
159          time timestamp default now(),          time timestamp default now(),
# Line 72  create table log ( Line 167  create table log (
167  create index log_time on log(time);  create index log_time on log(time);
168  create index log_channel on log(channel);  create index log_channel on log(channel);
169  create index log_nick on log(nick);  create index log_nick on log(nick);
170            },
171            meta => q{
172    create table meta (
173            nick text not null,
174            channel text not null,
175            name text not null,
176            value text,
177            changed timestamp default 'now()',
178            primary key(nick,channel,name)
179    );
180            },
181            feeds => qq{
182    create table feeds (
183            id serial,
184            url text not null,
185            name text,
186            delay interval not null default '5 min',
187            active boolean default true,
188            channel text not null,
189            nick text not null,
190            private boolean default false,
191            last_update timestamp default 'now()',
192            polls int default 0,
193            updates int default 0
194    );
195    create unique index feeds_url on feeds(url);
196    insert into feeds (url,name,channel,nick) values ('http://wiki.razmjenavjestina.org/feed/workspace/razmjenavjestina?category=Recent%20Changes','wiki','$CHANNEL','dpavlin');
197            },
198    };
199    
200    foreach my $table ( keys %$sql_schema ) {
201    
202  _SQL_SCHEMA_          eval {
203                    $dbh->do(qq{ select count(*) from $table });
204            };
205    
206            if ($@) {
207                    warn "creating database table $table in $DSN\n";
208                    $dbh->do( $sql_schema->{ $table } );
209            }
210  }  }
211    
212  my $sth = $dbh->prepare(qq{  
213    =head2 meta
214    
215    Set or get some meta data into database
216    
217            meta('nick','channel','var_name', $var_value );
218    
219            $var_value = meta('nick','channel','var_name');
220            ( $var_value, $changed ) = meta('nick','channel','var_name');
221    
222    =cut
223    
224    sub meta {
225            my ($nick,$channel,$name,$value) = @_;
226    
227            # normalize channel name
228            $channel =~ s/^#//;
229    
230            if (defined($value)) {
231    
232                    my $sth = $dbh->prepare(qq{ update meta set value = ?, changed = now() where nick = ? and channel = ? and name = ? });
233    
234                    eval { $sth->execute( $value, $nick, $channel, $name ) };
235    
236                    # error or no result
237                    if ( $@ || ! $sth->rows ) {
238                            $sth = $dbh->prepare(qq{ insert into meta (value,nick,channel,name,changed) values (?,?,?,?,now()) });
239                            $sth->execute( $value, $nick, $channel, $name );
240                            warn "## created $nick/$channel/$name = $value\n";
241                    } else {
242                            warn "## updated $nick/$channel/$name = $value\n";
243                    }
244    
245                    return $value;
246    
247            } else {
248    
249                    my $sth = $dbh->prepare(qq{ select value,changed from meta where nick = ? and channel = ? and name = ? });
250                    $sth->execute( $nick, $channel, $name );
251                    my ($v,$c) = $sth->fetchrow_array;
252                    warn "## fetched $nick/$channel/$name = $v [$c]\n";
253                    return ($v,$c) if wantarray;
254                    return $v;
255    
256            }
257    }
258    
259    
260    
261    my $sth_insert_log = $dbh->prepare(qq{
262  insert into log  insert into log
263          (channel, me, nick, message)          (channel, me, nick, message, time)
264  values (?,?,?,?)  values (?,?,?,?,?)
265  });  });
266    
267    
268    my $tags;
269    
270  =head2 get_from_log  =head2 get_from_log
271    
272   my @messages = get_from_log(   my @messages = get_from_log(
# Line 101  values (?,?,?,?) Line 286  values (?,?,?,?)
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 108  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 145  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 .= " order by log.time desc";                  my $date = shift || return;
339          $sql .= " limit " . $args->{limit};                  my $new_date = eval { DateTime::Format::ISO8601->parse_datetime( $date )->ymd; };
340                    if ( $@ ) {
341                            warn "invalid date $date\n";
342                            $new_date = DateTime->now->ymd;
343                    }
344                    return $new_date;
345            }
346    
347            my @where;
348            my @args;
349            my $msg;
350    
         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          } else {                  $msg = "Search for '$search'";
357                  $sth->execute();          }
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 171  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 199  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 228  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 255  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                            # FIXME bug! should be save_message
683    #                       save_message( channel => $args->{channel}, me => 1, nick => $NICK, message => $msg );
684                            $sth_insert_log->execute( $args->{channel}, 1, $NICK, $msg, 'now()' );
685                            my ( $type, $to ) = ( 'notice', $args->{channel} );
686                            ( $type, $to ) = ( 'privmsg', $args->{nick} ) if $args->{private};
687                            _log(">> $type $to |", $msg);
688                            $args->{kernel}->post( $IRC_ALIAS => $type => $to, $msg );
689                            $updates++;
690                    }
691            }
692    
693            my $sql = qq{ update feeds set last_update = now(), polls = polls + 1 };
694            $sql .= qq{, updates = updates + $updates } if $updates;
695            $sql .= qq{where id = } . $args->{id};
696            eval { $dbh->do( $sql ) };
697    
698            _log "RSS got $total items of which $updates new";
699    
700            return $updates;
701    }
702    
703    sub rss_fetch_all {
704            my $kernel = shift;
705            my $sql = qq{
706                    select id, url, name, channel, nick, private
707                    from feeds
708                    where active is true
709            };
710            # limit to newer feeds only if we are not sending messages out
711            $sql .= qq{     and last_update + delay < now() } if $kernel;
712            my $sth = $dbh->prepare( $sql );
713            $sth->execute();
714            warn "# ",$sth->rows," active RSS feeds\n";
715            my $count = 0;
716            while (my $row = $sth->fetchrow_hashref) {
717                    $row->{kernel} = $kernel if $kernel;
718                    $count += rss_fetch( $row );
719            }
720            return "OK, fetched $count posts from " . $sth->rows . " feeds";
721    }
722    
723    
724    sub rss_check_updates {
725            my $kernel = shift;
726            $_rss->{last_poll} ||= time();
727            my $dt = time() - $_rss->{last_poll};
728            warn "## rss_check_updates $dt > $rss_min_delay\n";
729            if ( $dt > $rss_min_delay ) {
730                    $_rss->{last_poll} = time();
731                    _log rss_fetch_all( $kernel );
732            }
733    }
734    
735    # seed rss seen cache so we won't send out all items on startup
736    _log rss_fetch_all;
737    
738  my $SKIPPING = 0;               # if skipping, how many we've done  #
739  my $SEND_QUEUE;                 # cache  # POE handing part
740    #
741    
742    my $ping;                                               # ping stats
743    
744  POE::Component::IRC->new($IRC_ALIAS);  POE::Component::IRC->new($IRC_ALIAS);
745    
746  POE::Session->create  POE::Session->create( inline_states => {
747    (inline_states =>          _start => sub {      
    {_start => sub {        
748                  $_[KERNEL]->post($IRC_ALIAS => register => 'all');                  $_[KERNEL]->post($IRC_ALIAS => register => 'all');
749                  $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);                  $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);
750      },      },
751      irc_255 => sub {    # server is done blabbing      irc_255 => sub {    # server is done blabbing
752                  $_[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;  
753                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );
754      },      },
755      irc_public => sub {      irc_public => sub {
# Line 280  POE::Session->create Line 758  POE::Session->create
758                  my $channel = $_[ARG1]->[0];                  my $channel = $_[ARG1]->[0];
759                  my $msg = $_[ARG2];                  my $msg = $_[ARG2];
760    
761                  from_to($msg, 'UTF-8', $ENCODING);                  save_message( channel => $channel, me => 0, nick => $nick, message => $msg);
762                    meta( $nick, $channel, 'last-msg', $msg );
763                  print "$channel: <$nick> $msg\n";                  rss_check_updates( $kernel );
                 $sth->execute($channel, 0, $nick, $msg);  
764      },      },
765      irc_ctcp_action => sub {      irc_ctcp_action => sub {
766                  my $kernel = $_[KERNEL];                  my $kernel = $_[KERNEL];
# Line 291  POE::Session->create Line 768  POE::Session->create
768                  my $channel = $_[ARG1]->[0];                  my $channel = $_[ARG1]->[0];
769                  my $msg = $_[ARG2];                  my $msg = $_[ARG2];
770    
771                  from_to($msg, 'UTF-8', $ENCODING);                  save_message( channel => $channel, me => 1, nick => $nick, message => $msg);
772    
773                    if ( $use_twitter ) {
774                            if ( my $twitter = meta( $nick, $NICK, 'twitter' ) ) {
775                                    my ($login,$passwd) = split(/\s+/,$twitter,2);
776                                    _log("sending twitter for $nick/$login on $channel ");
777                                    my $bot = Net::Twitter->new( username=>$login, password=>$passwd );
778                                    $bot->update("<${channel}> $msg");
779                            }
780                    }
781    
                 print "$channel ***$nick $msg\n";  
                 $sth->execute($channel, 1, $nick, $msg);  
782      },      },
783            irc_ping => sub {
784                    _log( "pong ", $_[ARG0] );
785                    $ping->{ $_[ARG0] }++;
786                    rss_check_updates( $_[KERNEL] );
787            },
788            irc_invite => sub {
789                    my $kernel = $_[KERNEL];
790                    my $nick = (split /!/, $_[ARG0])[0];
791                    my $channel = $_[ARG1];
792    
793                    _log "invited to $channel by $nick";
794    
795                    $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, "how nice of you to invite me to $channel, I'll be right there..." );
796                    $_[KERNEL]->post($IRC_ALIAS => join => $channel);
797    
798            },
799          irc_msg => sub {          irc_msg => sub {
800                  my $kernel = $_[KERNEL];                  my $kernel = $_[KERNEL];
801                  my $nick = (split /!/, $_[ARG0])[0];                  my $nick = (split /!/, $_[ARG0])[0];
802                  my $msg = $_[ARG2];                  my $msg = $_[ARG2];
803                  from_to($msg, 'UTF-8', $ENCODING);                  my $channel = $_[ARG1]->[0];
804    
805                  my $res = "unknown command '$msg', try /msg $NICK help!";                  my $res = "unknown command '$msg', try /msg $NICK help!";
806                  my @out;                  my @out;
807    
808                  print "<< $msg\n";                  _log "<< $msg";
809    
810                  if ($msg =~ m/^help/i) {                  if ($msg =~ m/^help/i) {
811    
# Line 313  POE::Session->create Line 813  POE::Session->create
813    
814                  } elsif ($msg =~ m/^msg\s+(\S+)\s+(.*)$/i) {                  } elsif ($msg =~ m/^msg\s+(\S+)\s+(.*)$/i) {
815    
816                          print ">> /msg $1 $2\n";                          _log ">> /msg $1 $2";
817                          $_[KERNEL]->post( $IRC_ALIAS => privmsg => $1, $2 );                          $_[KERNEL]->post( $IRC_ALIAS => privmsg => $1, $2 );
818                          $res = '';                          $res = '';
819    
# Line 322  POE::Session->create Line 822  POE::Session->create
822                          my $nr = $1 || 10;                          my $nr = $1 || 10;
823    
824                          my $sth = $dbh->prepare(qq{                          my $sth = $dbh->prepare(qq{
825                                  select nick,count(*) from log group by nick order by count desc limit $nr                                  select
826                                            trim(both '_' from nick) as nick,
827                                            count(*) as count,
828                                            sum(length(message)) as len
829                                    from log
830                                    group by trim(both '_' from nick)
831                                    order by len desc,count desc
832                                    limit $nr
833                          });                          });
834                          $sth->execute();                          $sth->execute();
835                          $res = "Top $nr users: ";                          $res = "Top $nr users: ";
836                          my @users;                          my @users;
837                          while (my $row = $sth->fetchrow_hashref) {                          while (my $row = $sth->fetchrow_hashref) {
838                                  push @users,$row->{nick} . ': ' . $row->{count};                                  push @users,$row->{nick} . ': ' . $row->{count} . '/' . $row->{len} . '=' . sprintf("%.2f", $row->{len}/$row->{count});
839                          }                          }
840                          $res .= join(" | ", @users);                          $res .= join(" | ", @users);
841                  } elsif ($msg =~ m/^last.*?\s*(\d*)/i) {                  } elsif ($msg =~ m/^last.*?\s*(\d*)/i) {
842    
843                          foreach my $res (get_from_log( limit => $1 )) {                          my $limit = $1 || meta( $nick, $channel, 'last-size' ) || 10;
844                                  print "last: $res\n";  
845                                  from_to($res, $ENCODING, 'UTF-8');                          foreach my $res (get_from_log( limit => $limit )) {
846                                    _log "last: $res";
847                                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );                                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );
848                          }                          }
849    
# Line 349  POE::Session->create Line 857  POE::Session->create
857                                          limit => 20,                                          limit => 20,
858                                          search => $what,                                          search => $what,
859                                  )) {                                  )) {
860                                  print "search [$what]: $res\n";                                  _log "search [$what]: $res";
                                 from_to($res, $ENCODING, 'UTF-8');  
861                                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );                                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );
862                          }                          }
863    
864                          $res = '';                          $res = '';
865    
866                    } elsif ($msg =~ m/^(?:count|poll)\s+(.*)(?:\s+(\d+))?\s*$/i) {
867    
868                            my ($what,$limit) = ($1,$2);
869                            $limit ||= 100;
870    
871                            my $stat;
872    
873                            foreach my $res (get_from_log(
874                                            limit => $limit,
875                                            search => $what,
876                                            full_rows => 1,
877                                    )) {
878                                    while ($res->{message} =~ s/\Q$what\E(\+|\-)//) {
879                                            $stat->{vote}->{$1}++;
880                                            $stat->{from}->{ $res->{nick} }++;
881                                    }
882                            }
883    
884                            my @nicks;
885                            foreach my $nick (sort { $stat->{from}->{$a} <=> $stat->{from}->{$b} } keys %{ $stat->{from} }) {
886                                    push @nicks, $nick . ( $stat->{from}->{$nick} == 1 ? '' :
887                                            "(" . $stat->{from}->{$nick} . ")"
888                                    );
889                            }
890    
891                            $res =
892                                    "$what ++ " . ( $stat->{vote}->{'+'} || 0 ) .
893                                    " : " . ( $stat->{vote}->{'-'} || 0 ) . " --" .
894                                    " from " . ( join(", ", @nicks) || 'nobody' );
895    
896                            $_[KERNEL]->post( $IRC_ALIAS => notice => $nick, $res );
897    
898                    } elsif ($msg =~ m/^ping/) {
899                            $res = "ping = " . dump( $ping );
900                    } elsif ($msg =~ m/^conf(?:ig)*\s*(last-size|twitter)*\s*(.*)/) {
901                            if ( ! defined( $1 ) ) {
902                                    my $sth = $dbh->prepare(qq{ select name,value,changed from meta where nick = ? and channel = ? });
903                                    $sth->execute( $nick, $channel );
904                                    $res = "config for $nick on $channel";
905                                    while ( my ($n,$v) = $sth->fetchrow_array ) {
906                                            $res .= " | $n = $v";
907                                    }
908                            } elsif ( ! $2 ) {
909                                    my $val = meta( $nick, $channel, $1 );
910                                    $res = "current $1 = " . ( $val ? $val : 'undefined' );
911                            } else {
912                                    my $validate = {
913                                            'last-size' => qr/^\d+/,
914                                            'twitter' => qr/^\w+\s+\w+/,
915                                    };
916    
917                                    my ( $op, $val ) = ( $1, $2 );
918    
919                                    if ( my $regex = $validate->{$op} ) {
920                                            if ( $val =~ $regex ) {
921                                                    meta( $nick, $channel, $op, $val );
922                                                    $res = "saved $op = $val";
923                                            } else {
924                                                    $res = "config option $op = $val doesn't validate against $regex";
925                                            }
926                                    } else {
927                                            $res = "config option $op doesn't exist";
928                                    }
929                            }
930                    } elsif ($msg =~ m/^rss-update/) {
931                            $res = rss_fetch_all( $_[KERNEL] );
932                    } elsif ($msg =~ m/^rss-clean/) {
933                            $_rss = undef;
934                            $dbh->do( qq{ update feeds set last_update = now() - delay } );
935                            $res = "OK, cleaned RSS cache";
936                    } elsif ($msg =~ m/^rss-list/) {
937                            my $sth = $dbh->prepare(qq{ select url,name,last_update,active,channel,nick,private from feeds });
938                            $sth->execute;
939                            while (my @row = $sth->fetchrow_array) {
940                                    $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, join(' | ',@row) );
941                            }
942                            $res = '';
943                    } elsif ($msg =~ m!^rss-(add|remove|stop|start)(?:-(private))?\s+(http://\S+)\s*(.*)!) {
944                            my ( $command, $sub, $url, $arg ) = ( $1,$2,$3,$4 );
945    
946                            my $channel = $1 if ( $arg =~ s/\s*(#\S+)\s*// );
947                            $channel = $nick if $sub eq 'private';
948    
949                            my $sql = {
950                                    add     => qq{ insert into feeds (url,name,channel,nick,private) values (?,?,?,?,?) },
951    #                               remove  => qq{ delete from feeds                                where url = ? and name = ? },
952                                    start   => qq{ update feeds set active = true   where url = ? },
953                                    stop    => qq{ update feeds set active = false  where url = ? },
954                            };
955    
956                            if ( $command eq 'add' && ! $channel ) {
957                                    $res = "ERROR: got '$msg' which doesn't have #channel in it, ignoring!";
958                            } elsif (my $q = $sql->{$command} ) {
959                                    my $sth = $dbh->prepare( $q );
960                                    my @data = ( $url );
961                                    if ( $command eq 'add' ) {
962                                            push @data, ( $arg, $channel, $nick, $sub eq 'private' ? 1 : 0 );
963                                    }
964                                    warn "## $command SQL $q with ",dump( @data ),"\n";
965                                    eval { $sth->execute( @data ) };
966                                    if ($@) {
967                                            $res = "ERROR: $@";
968                                    } else {
969                                            $res = "OK, RSS [$command|$sub|$url|$arg]";
970                                    }
971                            } else {
972                                    $res = "ERROR: don't know what to do with: $msg";
973                            }
974                  }                  }
975    
976                  if ($res) {                  if ($res) {
977                          print ">> [$nick] $res\n";                          _log ">> [$nick] $res";
                         from_to($res, $ENCODING, 'UTF-8');  
978                          $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );                          $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );
979                  }                  }
980    
981                    rss_check_updates( $_[KERNEL] );
982          },          },
983          irc_477 => sub {          irc_477 => sub {
984                  print "# irc_477: ",$_[ARG1], "\n";                  _log "<< irc_477: ",$_[ARG1];
985                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "register $NICK" );                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "register $NICK" );
986          },          },
987          irc_505 => sub {          irc_505 => sub {
988                  print "# irc_505: ",$_[ARG1], "\n";                  _log "<< irc_505: ",$_[ARG1];
989                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "register $NICK" );                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "register $NICK" );
990  #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "set hide email on" );  #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "set hide email on" );
991  #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "set email dpavlin\@rot13.org" );  #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "set email dpavlin\@rot13.org" );
992          },          },
993          irc_registered => sub {          irc_registered => sub {
994                  warn "## indetify $NICK\n";                  _log "## registrated $NICK, /msg nickserv IDENTIFY $NICK";
995                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );
996          },          },
997            irc_disconnected => sub {
998                    _log "## disconnected.. sleeping for $sleep_on_error seconds and reconnecting again";
999                    sleep($sleep_on_error);
1000                    $_[KERNEL]->post( $IRC_ALIAS => connect => $CONNECT);
1001            },
1002            irc_socketerr => sub {
1003                    _log "## socket error... sleeping for $sleep_on_error seconds and retry";
1004                    sleep($sleep_on_error);
1005                    $_[KERNEL]->post( $IRC_ALIAS => connect => $CONNECT);
1006            },
1007  #       irc_433 => sub {  #       irc_433 => sub {
1008  #               print "# irc_433: ",$_[ARG1], "\n";  #               print "# irc_433: ",$_[ARG1], "\n";
1009  #               warn "## indetify $NICK\n";  #               warn "## indetify $NICK\n";
1010  #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );  #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );
1011  #       },  #       },
1012          irc_372 => sub {  #       irc_451 # please register
                 print "MOTD: ", $_[ARG1], "\n";  
         },  
1013          irc_snotice => sub {          irc_snotice => sub {
1014                  print "(server notice): ", $_[ARG0], "\n";                  _log "<< snotice",$_[ARG0];
1015                    if ( $_[ARG0] =~ m!/(QUOTE)\s+(PASS\s+\d+)!i ) {
1016                            warn ">> $1 | $2\n";
1017                            $_[KERNEL]->post( $IRC_ALIAS => lc($1) => $2);
1018                    }
1019          },          },
     (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  
1020      _child => sub {},      _child => sub {},
1021      _default => sub {      _default => sub {
1022        printf "%s: session %s caught an unhandled %s event.\n",                  _log sprintf "sID:%s %s %s",
1023          scalar localtime(), $_[SESSION]->ID, $_[ARG0];                          $_[SESSION]->ID, $_[ARG0],
1024        print "The $_[ARG0] event was given these parameters: ",                          ref($_[ARG1]) eq "ARRAY"        ?       join(",", map { ref($_) eq "ARRAY" ? join(";", @{$_}) : $_ } @{ $_[ARG1] })     :
1025          join(" ", map({"ARRAY" eq ref $_ ? "[@$_]" : "$_"} @{$_[ARG1]})), "\n";                          $_[ARG1]                                        ?       $_[ARG1]                                        :
1026                            "";
1027        0;                        # false for signals        0;                        # false for signals
1028      },      },
     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);  
     }  
1029     },     },
1030    );    );
1031    
1032  # http server  # http server
1033    
1034  my $httpd = POE::Component::Server::HTTP->new(  my $httpd = POE::Component::Server::HTTP->new(
1035          Port => $NICK =~ m/-dev/ ? 8001 : 8000,          Port => $http_port,
1036            PreHandler => {
1037                    '/' => sub {
1038                            $_[0]->header(Connection => 'close')
1039                    }
1040            },
1041          ContentHandler => { '/' => \&root_handler },          ContentHandler => { '/' => \&root_handler },
1042          Headers        => { Server => 'irc-logger' },          Headers        => { Server => 'irc-logger' },
1043  );  );
1044    
 my %escape = ('<'=>'&lt;', '>'=>'&gt;', '&'=>'&amp;', '"'=>'&quot;');  
 my $escape_re  = join '|' => keys %escape;  
   
1045  my $style = <<'_END_OF_STYLE_';  my $style = <<'_END_OF_STYLE_';
1046  p { margin: 0; padding: 0.1em; }  p { margin: 0; padding: 0.1em; }
1047  .time, .channel { color: #808080; font-size: 60%; }  .time, .channel { color: #808080; font-size: 60%; }
1048  .date { float: right; clear: right; background: #e0e0e0; color: #404040; font-size: 120%; padding: 0.25em; border: 1px dashed #808080; }  .date { float: right; background: #e0e0e0; color: #404040; font-size: 120%; padding: 0.25em; border: 1px dashed #808080; }
1049  .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 ; }
1050  .message { color: #000000; font-size: 100%; }  .message { color: #000000; font-size: 100%; }
1051  .search { float: right; }  .search { float: right; }
1052    a:link.tag, a:visited.tag { border: 1px dashed #ccc; backgound: #ccc; text-decoration: none }
1053    a:hover.tag { border: 1px solid #eee }
1054    hr { border: 1px dashed #ccc; height: 1px; clear: both; }
1055    /*
1056  .col-0 { background: #ffff66 }  .col-0 { background: #ffff66 }
1057  .col-1 { background: #a0ffff }  .col-1 { background: #a0ffff }
1058  .col-2 { background: #99ff99 }  .col-2 { background: #99ff99 }
1059  .col-3 { background: #ff9999 }  .col-3 { background: #ff9999 }
1060  .col-4 { background: #ff66ff }  .col-4 { background: #ff66ff }
1061    */
1062    .calendar { border: 1px solid red; width: 100%; }
1063    .month { border: 0px; width: 100%; }
1064  _END_OF_STYLE_  _END_OF_STYLE_
1065    
1066  my $max_color = 4;  $max_color = 0;
1067    
1068  my %nick_enumerator;  my @cols = qw(
1069            #ffcccc #ccffe6 #ccccff #e6ccff #ffccff #ffcce6 #ff9999 #ffcc99 #ffff99
1070            #ccff99 #99ff99 #99ffcc #99ccff #9999ff #cc99ff #ff6666 #ffb366 #ffff66
1071            #66ff66 #66ffb3 #66b3ff #6666ff #ff3333 #33ff33 #3399ff #3333ff #ff3399
1072            #a0a0a0 #ff0000 #ffff00 #80ff00 #0000ff #8000ff #ff00ff #ff0080 #994d00
1073            #999900 #009900 #cc0066 #c0c0c0 #ccff99 #99ff33 #808080 #660033 #ffffff
1074    );
1075    
1076    foreach my $c (@cols) {
1077            $style .= ".col-${max_color} { background: $c }\n";
1078            $max_color++;
1079    }
1080    warn "defined $max_color colors for users...\n";
1081    
1082  sub root_handler {  sub root_handler {
1083          my ($request, $response) = @_;          my ($request, $response) = @_;
1084          $response->code(RC_OK);          $response->code(RC_OK);
1085          $response->content_type("text/html; charset=$ENCODING");  
1086            # this doesn't seem to work, so moved to PreHandler
1087            #$response->header(Connection => 'close');
1088    
1089            return RC_OK if $request->uri =~ m/favicon.ico$/;
1090    
1091          my $q;          my $q;
1092    
# Line 519  sub root_handler { Line 1100  sub root_handler {
1100    
1101          my $search = $q->param('search') || $q->param('grep') || '';          my $search = $q->param('search') || $q->param('grep') || '';
1102    
1103          $response->content(          if ($request->url =~ m#/rss(?:/(tags|last-tag|follow.*)\w*(?:=(\d+))?)?#i) {
1104                  qq{<html><head><title>$NICK</title><style type="text/css">$style</style></head><body>                  my $show = lc($1);
1105                  <form method="post" class="search">                  my $nr = $2;
1106    
1107                    my $type = 'RSS';       # Atom
1108    
1109                    $response->content_type( 'application/' . lc($type) . '+xml' );
1110    
1111                    my $html = '<!-- error -->';
1112                    #warn "create $type feed from ",dump( @last_tags );
1113    
1114                    my $feed = XML::Feed->new( $type );
1115                    $feed->link( $url );
1116    
1117                    if ( $show eq 'tags' ) {
1118                            $nr ||= 50;
1119                            $feed->title( "tags from $CHANNEL" );
1120                            $feed->link( "$url/tags" );
1121                            $feed->description( "tag cloud created from messages on channel $CHANNEL which have tags// in them" );
1122                            my $feed_entry = XML::Feed::Entry->new($type);
1123                            $feed_entry->title( "$nr tags from $CHANNEL" );
1124                            $feed_entry->author( $NICK );
1125                            $feed_entry->link( '/#tags'  );
1126    
1127                            $feed_entry->content(
1128                                    qq{<![CDATA[<style type="text/css">}
1129                                    . $cloud->css
1130                                    . qq{</style>}
1131                                    . $cloud->html( $nr )
1132                                    . qq{]]>}
1133                            );
1134                            $feed->add_entry( $feed_entry );
1135    
1136                    } elsif ( $show eq 'last-tag' ) {
1137    
1138                            $nr ||= $last_x_tags;
1139                            $nr = $last_x_tags if $nr > $last_x_tags;
1140    
1141                            $feed->title( "last $nr tagged messages from $CHANNEL" );
1142                            $feed->description( "collects messages which have tags// in them" );
1143    
1144                            foreach my $m ( @last_tags ) {
1145    #                               warn dump( $m );
1146                                    #my $tags = join(' ', @{$m->{tags}} );
1147                                    my $feed_entry = XML::Feed::Entry->new($type);
1148                                    $feed_entry->title( $m->{nick} . '@' . $m->{time} );
1149                                    $feed_entry->author( $m->{nick} );
1150                                    $feed_entry->link( '/#' . $m->{id}  );
1151                                    $feed_entry->issued( DateTime::Format::Flexible->build( $m->{time} ) );
1152    
1153                                    my $message = $filter->{message}->( $m->{message} );
1154                                    $message .= "<br/>\n" unless $message =~ m!<(/p|br/?)>!;
1155    #                               warn "## message = $message\n";
1156    
1157                                    #$feed_entry->summary(
1158                                    $feed_entry->content(
1159                                            "<![CDATA[$message]]>"
1160                                    );
1161                                    $feed_entry->category( join(', ', @{$m->{tags}}) );
1162                                    $feed->add_entry( $feed_entry );
1163    
1164                                    $nr--;
1165                                    last if $nr <= 0;
1166    
1167                            }
1168    
1169                    } elsif ( $show =~ m/^follow/ ) {
1170    
1171                            $feed->title( "Feeds which this bot follows" );
1172    
1173                            my $sth = $dbh->prepare( qq{ select * from feeds order by last_update desc } );
1174                            $sth->execute;
1175                            while (my $row = $sth->fetchrow_hashref) {
1176                                    my $feed_entry = XML::Feed::Entry->new($type);
1177                                    $feed_entry->title( $row->{name} );
1178                                    $feed_entry->link( $row->{url}  );
1179                                    $feed_entry->issued( DateTime::Format::Flexible->build( $row->{last_update} ) );
1180                                    $feed_entry->content(
1181                                            '<![CDATA[<pre>' . dump( $row ) . '</pre>]]>'
1182                                    );
1183                                    $feed->add_entry( $feed_entry );
1184                            }
1185    
1186                            my $feed_entry = XML::Feed::Entry->new($type);
1187                            $feed_entry->title( "Internal stats" );
1188                            $feed_entry->content(
1189                                    '<![CDATA[<pre>' . dump( $_rss ) . '</pre>]]>'
1190                            );
1191                            $feed->add_entry( $feed_entry );
1192    
1193                    } else {
1194                            _log "unknown rss request ",$request->url;
1195                            return RC_DENY;
1196                    }
1197    
1198                    $response->content( $feed->as_xml );
1199                    return RC_OK;
1200            }
1201    
1202            if ( $@ ) {
1203                    warn "$@";
1204            }
1205    
1206            $response->content_type("text/html; charset=UTF-8");
1207    
1208            my $html =
1209                    qq{<html><head><title>$NICK</title><style type="text/css">$style}
1210                    . $cloud->css
1211                    . qq{</style></head><body>}
1212                    . qq{
1213                    <form method="post" class="search" action="/">
1214                  <input type="text" name="search" value="$search" size="10">                  <input type="text" name="search" value="$search" size="10">
1215                  <input type="submit" value="search">                  <input type="submit" value="search">
1216                  </form>                  </form>
1217                  <p>                  }
1218                  } .                  . $cloud->html(500)
1219                  join("</p><p>",                  . qq{<p>};
1220    
1221            if ($request->url =~ m#/tags?#) {
1222                    # nop
1223            } elsif ($request->url =~ m#/history#) {
1224                    my $sth = $dbh->prepare(qq{
1225                            select date(time) as date,count(*) as nr,sum(length(message)) as len
1226                                    from log
1227                                    group by date(time)
1228                                    order by date(time) desc
1229                    });
1230                    $sth->execute();
1231                    my ($l_yyyy,$l_mm) = (0,0);
1232                    $html .= qq{<table class="calendar"><tr>};
1233                    my $cal;
1234                    my $ord = 0;
1235                    while (my $row = $sth->fetchrow_hashref) {
1236                            # this is probably PostgreSQL specific, expects ISO date
1237                            my ($yyyy,$mm,$dd) = split(/-/, $row->{date});
1238                            if ($yyyy != $l_yyyy || $mm != $l_mm) {
1239                                    if ( $cal ) {
1240                                            $html .= qq{<td valign="top">} . $cal->as_HTML() . qq{</td>};
1241                                            $ord++;
1242                                            $html .= qq{</tr><tr>} if ( $ord % 3 == 0 );
1243                                    }
1244                                    $cal = new HTML::CalendarMonthSimple('month'=>$mm,'year'=>$yyyy);
1245                                    $cal->border(1);
1246                                    $cal->width('30%');
1247                                    $cal->cellheight('5em');
1248                                    $cal->tableclass('month');
1249                                    #$cal->cellclass('day');
1250                                    $cal->sunday('SUN');
1251                                    $cal->saturday('SAT');
1252                                    $cal->weekdays('MON','TUE','WED','THU','FRI');
1253                                    ($l_yyyy,$l_mm) = ($yyyy,$mm);
1254                            }
1255                            $cal->setcontent($dd, qq[
1256                                    <a href="$url?date=$row->{date}">$row->{nr}</a><br/>$row->{len}
1257                            ]) if $cal;
1258                            
1259                    }
1260                    $html .= qq{<td valign="top">} . $cal->as_HTML() . qq{</td></tr></table>};
1261    
1262            } else {
1263                    $html .= join("</p><p>",
1264                          get_from_log(                          get_from_log(
1265                                  limit => $q->param('last') || 100,                                  limit => ( $q->param('last') || $q->param('date') ) ? undef : 100,
1266                                  search => $q->param('search') || $q->param('grep') || undef,                                  search => $search || undef,
1267                                    tag => $q->param('tag') || undef,
1268                                    date => $q->param('date') || undef,
1269                                  fmt => {                                  fmt => {
1270                                          date => '<hr size="1" style="clear: both;"/><div class="date">%s</div> ',                                          date => sub {
1271                                                    my $date = shift || return;
1272                                                    qq{<hr/><div class="date"><a href="$url?date=$date">$date</a></div>};
1273                                            },
1274                                          time => '<span class="time">%s</span> ',                                          time => '<span class="time">%s</span> ',
1275                                          time_channel => '<span class="channel">%s %s</span> ',                                          time_channel => '<span class="channel">%s %s</span> ',
1276                                          nick => '%s:&nbsp;',                                          nick => '%s:&nbsp;',
1277                                          me_nick => '***%s&nbsp;',                                          me_nick => '***%s&nbsp;',
1278                                          message => '<span class="message">%s</span>',                                          message => '<span class="message">%s</span>',
1279                                  },                                  },
1280                                  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;  
                                                 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>';  
                                         },  
                                 },  
1281                          )                          )
1282                  ) .                  );
1283                  qq{</p></body></html>}          }
1284          );  
1285            $html .= qq{</p>
1286            <hr/>
1287            <p>See <a href="/history">history</a> of all messages.</p>
1288            </body></html>};
1289    
1290            $response->content( $html );
1291            warn "<< ", $request->method, " ", $request->uri, " created ", length($html), " bytes\n";
1292          return RC_OK;          return RC_OK;
1293  }  }
1294    
Legend:
Removed from v.27  
changed lines
  Added in v.104
  ViewVC Help
Powered by ViewVC 1.1.26