/[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

revision 60 by dpavlin, Sat Apr 14 12:45:03 2007 UTC revision 105 by dpavlin, Sun Mar 9 19:13:16 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 20  Import log from C<dircproxy> to C<irc-lo Line 37  Import log from C<dircproxy> to C<irc-lo
37    
38  =item --log=irc-logger.log  =item --log=irc-logger.log
39    
 Name of log file  
   
40  =back  =back
41    
42  =head1 DESCRIPTION  =head1 DESCRIPTION
# Line 32  log all conversation on irc channel Line 47  log all conversation on irc channel
47    
48  ## CONFIG  ## CONFIG
49    
50  my $HOSTNAME = `hostname`;  my $HOSTNAME = `hostname -f`;
51    chomp($HOSTNAME);
52    
53  my $NICK = 'irc-logger';  my $NICK = 'irc-logger';
54  $NICK .= '-dev' if ($HOSTNAME =~ m/llin/);  $NICK .= '-dev' if ($HOSTNAME =~ m/llin/);
55  my $CONNECT =  my $CONNECT = {
56    {Server => 'irc.freenode.net',          Server => 'irc.freenode.net',
57     Nick => $NICK,          Nick => $NICK,
58     Ircname => "try /msg $NICK help",          Ircname => "try /msg $NICK help",
59    };  };
60  my $CHANNEL = '#razmjenavjestina';  my $CHANNEL = '#razmjenavjestina';
61  $CHANNEL = '#irc-logger' if ($HOSTNAME =~ m/llin/);  $CHANNEL = '#irc-logger' if ($HOSTNAME =~ m/llin/);
62  my $IRC_ALIAS = "log";  my $IRC_ALIAS = "log";
63    
64  my %FOLLOWS =  if ( $HOSTNAME =~ m/lugarin/ ) {
65    (          $CONNECT->{Server} = 'irc.carnet.hr';
66     ACCESS => "/var/log/apache/access.log",          $CHANNEL = '#riss';
67     ERROR => "/var/log/apache/error.log",  }
68    );  
69    warn dump( $HOSTNAME, $CONNECT );
70    
71  my $DSN = 'DBI:Pg:dbname=' . $NICK;  my $DSN = 'DBI:Pg:dbname=' . $NICK;
72    
 my $ENCODING = 'ISO-8859-2';  
73  my $TIMESTAMP = '%Y-%m-%d %H:%M:%S';  my $TIMESTAMP = '%Y-%m-%d %H:%M:%S';
74    
75  my $sleep_on_error = 5;  my $sleep_on_error = 5;
76    
77  ## END CONFIG  # 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  use POE qw(Component::IRC Wheel::FollowTail Component::Server::HTTP);  my $url = "http://$HOSTNAME:$http_port";
86  use HTTP::Status;  
87  use DBI;  ## END CONFIG
 use Encode qw/from_to is_utf8/;  
 use Regexp::Common qw /URI/;  
 use CGI::Simple;  
 use HTML::TagCloud;  
 use POSIX qw/strftime/;  
 use HTML::CalendarMonthSimple;  
 use Getopt::Long;  
 use DateTime;  
 use Data::Dump qw/dump/;  
88    
89  my $use_twitter = 1;  my $use_twitter = 1;
90  eval { require Net::Twitter; };  eval { require Net::Twitter; };
# Line 86  GetOptions( Line 97  GetOptions(
97          'log:s' => \$log_path,          'log:s' => \$log_path,
98  );  );
99    
100    #$SIG{__DIE__} = sub {
101    #       confess "fatal error";
102    #};
103    
104  open(STDOUT, '>', $log_path) || warn "can't redirect log to $log_path: $!";  open(STDOUT, '>', $log_path) || warn "can't redirect log to $log_path: $!";
105    
106  sub _log {  sub _log {
107          print strftime($TIMESTAMP,localtime()), ' ', join(" ",@_), $/;          print strftime($TIMESTAMP,localtime()) . ' ' . join(" ",@_) . $/;
108  }  }
109    
110    # HTML formatters
111    
112    my %escape = ('<'=>'&lt;', '>'=>'&gt;', '&'=>'&amp;', '"'=>'&quot;');
113    my $escape_re  = join '|' => keys %escape;
114    
115    my $tag_regex = '\b([\w-_]+)//';
116    
117    my %nick_enumerator;
118    my $max_color = 0;
119    
120    my $filter = {
121            message => sub {
122                    my $m = shift || return;
123    
124                    # protect HTML from wiki modifications
125                    sub e {
126                            my $t = shift;
127                            return 'uri_unescape{' . uri_escape($t, '^a-zA-Z0-9') . '}';
128                    }
129    
130                    $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  my $dbh = DBI->connect($DSN,"","", { RaiseError => 1, AutoCommit => 1 }) || die $DBI::errstr;  my $dbh = DBI->connect($DSN,"","", { RaiseError => 1, AutoCommit => 1 }) || die $DBI::errstr;
153    $dbh->do( qq{ set client_encoding = 'UTF-8' } );
154    
155  my $sql_schema = {  my $sql_schema = {
156          log => '          log => qq{
157  create table log (  create table log (
158          id serial,          id serial,
159          time timestamp default now(),          time timestamp default now(),
# Line 109  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 => '          meta => q{
172  create table meta (  create table meta (
173          nick text not null,          nick text not null,
174          channel text not null,          channel text not null,
175          name text not null,          name text not null,
176          value text,          value text,
177          changed timestamp default now(),          changed timestamp default 'now()',
178          primary key(nick,channel,name)          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 ) {  foreach my $table ( keys %$sql_schema ) {
# Line 162  sub meta { Line 237  sub meta {
237                  if ( $@ || ! $sth->rows ) {                  if ( $@ || ! $sth->rows ) {
238                          $sth = $dbh->prepare(qq{ insert into meta (value,nick,channel,name,changed) values (?,?,?,?,now()) });                          $sth = $dbh->prepare(qq{ insert into meta (value,nick,channel,name,changed) values (?,?,?,?,now()) });
239                          $sth->execute( $value, $nick, $channel, $name );                          $sth->execute( $value, $nick, $channel, $name );
240                          _log "created $nick/$channel/$name = $value";                          warn "## created $nick/$channel/$name = $value\n";
241                  } else {                  } else {
242                          _log "updated $nick/$channel/$name = $value ";                          warn "## updated $nick/$channel/$name = $value\n";
243                  }                  }
244    
245                  return $value;                  return $value;
# Line 174  sub meta { Line 249  sub meta {
249                  my $sth = $dbh->prepare(qq{ select value,changed from meta where nick = ? and channel = ? and name = ? });                  my $sth = $dbh->prepare(qq{ select value,changed from meta where nick = ? and channel = ? and name = ? });
250                  $sth->execute( $nick, $channel, $name );                  $sth->execute( $nick, $channel, $name );
251                  my ($v,$c) = $sth->fetchrow_array;                  my ($v,$c) = $sth->fetchrow_array;
252                  _log "fetched $nick/$channel/$name = $v [$c]";                  warn "## fetched $nick/$channel/$name = $v [$c]\n";
253                  return ($v,$c) if wantarray;                  return ($v,$c) if wantarray;
254                  return $v;                  return $v;
255    
# Line 183  sub meta { Line 258  sub meta {
258    
259    
260    
261  my $sth = $dbh->prepare(qq{  my $sth_insert_log = $dbh->prepare(qq{
262  insert into log  insert into log
263          (channel, me, nick, message, time)          (channel, me, nick, message, time)
264  values (?,?,?,?,?)  values (?,?,?,?,?)
# Line 191  values (?,?,?,?,?) Line 266  values (?,?,?,?,?)
266    
267    
268  my $tags;  my $tags;
 my $tag_regex = '\b([\w-_]+)//';  
269    
270  =head2 get_from_log  =head2 get_from_log
271    
# Line 228  C<me>, C<nick> and C<message> keys. Line 302  C<me>, C<nick> and C<message> keys.
302  sub get_from_log {  sub get_from_log {
303          my $args = {@_};          my $args = {@_};
304    
305          $args->{fmt} ||= {          if ( ! $args->{fmt} ) {
306                  date => '[%s] ',                  $args->{fmt} = {
307                  time => '{%s} ',                          date => '[%s] ',
308                  time_channel => '{%s %s} ',                          time => '{%s} ',
309                  nick => '%s: ',                          time_channel => '{%s %s} ',
310                  me_nick => '***%s ',                          nick => '%s: ',
311                  message => '%s',                          me_nick => '***%s ',
312          };                          message => '%s',
313                    };
314            }
315    
316          my $sql_message = qq{          my $sql_message = qq{
317                  select                  select
# Line 258  sub get_from_log { Line 334  sub get_from_log {
334    
335          my $sql = $context ? $sql_context : $sql_message;          my $sql = $context ? $sql_context : $sql_message;
336    
337          $sql .= " where message ilike ? or nick ilike ? " if ($args->{search});          sub check_date {
338          $sql .= " where id in (" . join(",", @{ $tags->{ $args->{tag} } }) . ") " if ($args->{tag} && $tags->{ $args->{tag} });                  my $date = shift || return;
339          $sql .= " where date(time) = ? " if ($args->{date});                  my $new_date = eval { DateTime::Format::ISO8601->parse_datetime( $date )->ymd; };
340          $sql .= " order by log.time desc";                  if ( $@ ) {
341          $sql .= " limit " . $args->{limit} if ($args->{limit});                          warn "invalid date $date\n";
342                            $new_date = DateTime->now->ymd;
343                    }
344                    return $new_date;
345            }
346    
347            my @where;
348            my @args;
349            my $msg;
350    
         my $sth = $dbh->prepare( $sql );  
351          if (my $search = $args->{search}) {          if (my $search = $args->{search}) {
352                  $search =~ s/^\s+//;                  $search =~ s/^\s+//;
353                  $search =~ s/\s+$//;                  $search =~ s/\s+$//;
354                  $sth->execute( ( '%' . $search . '%' ) x 2 );                  push @where, 'message ilike ? or nick ilike ?';
355                  _log "search for '$search' returned ", $sth->rows, " results ", $context || '';                  push @args, ( ( '%' . $search . '%' ) x 2 );
356          } elsif (my $tag = $args->{tag}) {                  $msg = "Search for '$search'";
357                  $sth->execute();          }
358                  _log "tag '$tag' returned ", $sth->rows, " results ", $context || '';  
359          } elsif (my $date = $args->{date}) {          if ($args->{tag} && $tags->{ $args->{tag} }) {
360                  $sth->execute($date);                  push @where, 'id in (' . join(',', @{ $tags->{ $args->{tag} } }) . ')';
361                  _log "found ", $sth->rows, " messages for date $date ", $context || '';                  $msg = "Search for tags $args->{tag}";
         } else {  
                 $sth->execute();  
362          }          }
363    
364            if (my $date = $args->{date} ) {
365                    $date = check_date( $date );
366                    push @where, 'date(time) = ?';
367                    push @args, $date;
368                    $msg = "search for date $date";
369            }
370    
371            $sql .= " where " . join(" and ", @where) if @where;
372    
373            $sql .= " order by log.time desc";
374            $sql .= " limit " . $args->{limit} if ($args->{limit});
375    
376            #warn "### sql: $sql ", dump( @args );
377    
378            my $sth = $dbh->prepare( $sql );
379            eval { $sth->execute( @args ) };
380            return if $@;
381    
382            my $nr_results = $sth->rows;
383    
384          my $last_row = {          my $last_row = {
385                  date => '',                  date => '',
386                  time => '',                  time => '',
# Line 299  sub get_from_log { Line 401  sub get_from_log {
401    
402          return @rows if ($args->{full_rows});          return @rows if ($args->{full_rows});
403    
404          my @msgs = (          $msg .= ' produced ' . (
405                  "Showing " . ($#rows + 1) . " messages..."                  $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 359  sub get_from_log { Line 465  sub get_from_log {
465  #                       $row->{nick} = $nick;  #                       $row->{nick} = $nick;
466  #               }  #               }
467    
468                    $append = 0 if $row->{me};
469    
470                  if ($last_row->{nick} ne $nick) {                  if ($last_row->{nick} ne $nick) {
471                          # obfu way to find format for me_nick if needed or fallback to default                          # obfu way to find format for me_nick if needed or fallback to default
472                          my $fmt = $row->{me} ? ( $args->{fmt}->{me_nick} || $args->{fmt}->{nick} ) : $args->{fmt}->{nick};                          my $fmt = $row->{me} ? ( $args->{fmt}->{me_nick} || $args->{fmt}->{nick} ) : $args->{fmt}->{nick};
# Line 399  my $cloud = HTML::TagCloud->new; Line 507  my $cloud = HTML::TagCloud->new;
507    
508  =head2 add_tag  =head2 add_tag
509    
510   add_tag( id => 42, message => 'irc message' );   add_tag( id => 42, message => 'irc message', nick => 'foobar' [, me => 1 ] );
511    
512  =cut  =cut
513    
514    my @last_tags;
515    
516  sub add_tag {  sub add_tag {
517          my $arg = {@_};          my $arg = {@_};
518    
519          return unless ($arg->{id} && $arg->{message});          return unless ($arg->{id} && $arg->{message});
520    
521          my $m = $arg->{message};          my $m = $arg->{message};
522          from_to('UTF-8', 'iso-8859-2', $m) if (is_utf8($m));  
523            my @tags;
524    
525          while ($m =~ s#$tag_regex##s) {          while ($m =~ s#$tag_regex##s) {
526                  my $tag = $1;                  my $tag = $1;
527                  next if (! $tag || $tag =~ m/https?:/i);                  next if (! $tag || $tag =~ m/https?:/i);
528                  push @{ $tags->{$tag} }, $arg->{id};                  push @{ $tags->{$tag} }, $arg->{id};
529                  #warn "+tag $tag: $arg->{id}\n";                  #warn "+tag $tag: $arg->{id}\n";
530                  $cloud->add($tag, "?tag=$tag", scalar @{$tags->{$tag}} + 1);                  $cloud->add($tag, "$url?tag=$tag", scalar @{$tags->{$tag}} + 1);
531                    push @tags, $tag;
532    
533            }
534    
535            if ( @tags ) {
536                    pop @last_tags if $#last_tags == $last_x_tags;
537                    unshift @last_tags, { tags => [ @tags ], %$arg };
538          }          }
539    
540  }  }
541    
542  =head2 seed_tags  =head2 seed_tags
# Line 427  Read all tags from database and create i Line 546  Read all tags from database and create i
546  =cut  =cut
547    
548  sub seed_tags {  sub seed_tags {
549          my $sth = $dbh->prepare(qq{ select id,message from log where message like '%//%' });          my $sth = $dbh->prepare(qq{ select id,message,nick,me,time from log where message like '%//%' order by time asc });
550          $sth->execute;          $sth->execute;
551          while (my $row = $sth->fetchrow_hashref) {          while (my $row = $sth->fetchrow_hashref) {
552                  add_tag( %$row );                  add_tag( %$row );
553          }          }
554    
555          foreach my $tag (keys %$tags) {          foreach my $tag (keys %$tags) {
556                  $cloud->add($tag, "?tag=$tag", scalar @{$tags->{$tag}} + 1);                  $cloud->add($tag, "$url?tag=$tag", scalar @{$tags->{$tag}} + 1);
557          }          }
558  }  }
559    
# Line 447  seed_tags; Line 566  seed_tags;
566          channel => '#foobar',          channel => '#foobar',
567          me => 0,          me => 0,
568          nick => 'dpavlin',          nick => 'dpavlin',
569          msg => 'test message',          message => 'test message',
570          time => '2006-06-25 18:57:18',          time => '2006-06-25 18:57:18',
571    );    );
572    
# Line 459  C<me> if not specified will be C<0> (not Line 578  C<me> if not specified will be C<0> (not
578    
579  sub save_message {  sub save_message {
580          my $a = {@_};          my $a = {@_};
581            confess "have msg" if $a->{msg};
582          $a->{me} ||= 0;          $a->{me} ||= 0;
583          $a->{time} ||= strftime($TIMESTAMP,localtime());          $a->{time} ||= strftime($TIMESTAMP,localtime());
584    
585          _log          _log
586                  $a->{channel}, " ",                  $a->{channel}, " ",
587                  $a->{me} ? "***" . $a->{nick} : "<" . $a->{nick} . ">",                  $a->{me} ? "***" . $a->{nick} : "<" . $a->{nick} . ">",
588                  " " . $a->{msg};                  " " . $a->{message};
   
         from_to($a->{msg}, 'UTF-8', $ENCODING);  
589    
590          $sth->execute($a->{channel}, $a->{me}, $a->{nick}, $a->{msg}, $a->{time});          $sth_insert_log->execute($a->{channel}, $a->{me}, $a->{nick}, $a->{message}, $a->{time});
591          add_tag( id => $dbh->last_insert_id(undef,undef,"log",undef),          add_tag( id => $dbh->last_insert_id(undef,undef,"log",undef), %$a );
                 message => $a->{msg});  
592  }  }
593    
594    
595  if ($import_dircproxy) {  if ($import_dircproxy) {
596          open(my $l, $import_dircproxy) || die "can't open $import_dircproxy: $!";          open(my $l, $import_dircproxy) || die "can't open $import_dircproxy: $!";
597          warn "importing $import_dircproxy...\n";          warn "importing $import_dircproxy...\n";
598          my $tz_offset = 2 * 60 * 60;    # TZ GMT+2          my $tz_offset = 1 * 60 * 60;    # TZ GMT+2
599          while(<$l>) {          while(<$l>) {
600                  chomp;                  chomp;
601                  if (/^@(\d+)\s(\S+)\s(.+)$/) {                  if (/^@(\d+)\s(\S+)\s(.+)$/) {
# Line 496  if ($import_dircproxy) { Line 613  if ($import_dircproxy) {
613                                  channel => $CHANNEL,                                  channel => $CHANNEL,
614                                  me => $me,                                  me => $me,
615                                  nick => $nick,                                  nick => $nick,
616                                  msg => $msg,                                  message => $msg,
617                                  time => $dt->ymd . " " . $dt->hms,                                  time => $dt->ymd . " " . $dt->hms,
618                          ) if ($nick !~ m/^-/);                          ) if ($nick !~ m/^-/);
619    
# Line 509  if ($import_dircproxy) { Line 626  if ($import_dircproxy) {
626          exit;          exit;
627  }  }
628    
629    #
630    # RSS follow
631    #
632    
633    my $_rss;
634    
635    
636    sub rss_fetch {
637            my ($args) = @_;
638    
639            # how many messages to send out when feed is seen for the first time?
640            my $send_rss_msgs = 1;
641    
642            _log "RSS fetch", $args->{url};
643    
644            my $feed = XML::Feed->parse(URI->new( $args->{url} ));
645            if ( ! $feed ) {
646                    _log("can't fetch RSS ", $args->{url});
647                    return;
648            }
649    
650            my ( $total, $updates ) = ( 0, 0 );
651            for my $entry ($feed->entries) {
652                    $total++;
653    
654                    # seen allready?
655                    next if $_rss->{$args->{channel}}->{$feed->link}->{$entry->id}++ > 0;
656    
657                    sub prefix {
658                            my ($txt,$var) = @_;
659                            $var =~ s/\s+/ /gs;
660                            $var =~ s/^\s+//g;
661                            $var =~ s/\s+$//g;
662                            return $txt . $var if $var;
663                    }
664    
665                    # fix absolute and relative links to feed entries
666                    my $link = $entry->link;
667                    if ( $link =~ m!^/! ) {
668                            my $host = $args->{url};
669                            $host =~ s!^(http://[^/]+).*$!$1!;      #!vim
670                            $link = "$host/$link";
671                    } elsif ( $link !~ m!^http! ) {
672                            $link = $args->{url} . $link;
673                    }
674    
675                    my $msg;
676                    $msg .= prefix( 'From: ' , $args->{name} || $feed->title );
677                    $msg .= prefix( ' by ' , $entry->author );
678                    $msg .= prefix( ' | ' , $entry->title );
679                    $msg .= prefix( ' | ' , $link );
680    #               $msg .= prefix( ' id ' , $entry->id );
681    
682                    if ( $args->{kernel} && $send_rss_msgs ) {
683                            $send_rss_msgs--;
684                            # FIXME bug! should be save_message
685    #                       save_message( channel => $args->{channel}, me => 1, nick => $NICK, message => $msg );
686                            $sth_insert_log->execute( $args->{channel}, 1, $NICK, $msg, 'now()' );
687                            my ( $type, $to ) = ( 'notice', $args->{channel} );
688                            ( $type, $to ) = ( 'privmsg', $args->{nick} ) if $args->{private};
689                            _log(">> $type $to |", $msg);
690                            $args->{kernel}->post( $IRC_ALIAS => $type => $to, $msg );
691                            $updates++;
692                    }
693            }
694    
695            my $sql = qq{ update feeds set last_update = now(), polls = polls + 1 };
696            $sql .= qq{, updates = updates + $updates } if $updates;
697            $sql .= qq{where id = } . $args->{id};
698            eval { $dbh->do( $sql ) };
699    
700            _log "RSS got $total items of which $updates new";
701    
702            return $updates;
703    }
704    
705    sub rss_fetch_all {
706            my $kernel = shift;
707            my $sql = qq{
708                    select id, url, name, channel, nick, private
709                    from feeds
710                    where active is true
711            };
712            # limit to newer feeds only if we are not sending messages out
713            $sql .= qq{     and last_update + delay < now() } if $kernel;
714            my $sth = $dbh->prepare( $sql );
715            $sth->execute();
716            warn "# ",$sth->rows," active RSS feeds\n";
717            my $count = 0;
718            while (my $row = $sth->fetchrow_hashref) {
719                    $row->{kernel} = $kernel if $kernel;
720                    $count += rss_fetch( $row );
721            }
722            return "OK, fetched $count posts from " . $sth->rows . " feeds";
723    }
724    
725    
726    sub rss_check_updates {
727            my $kernel = shift;
728            $_rss->{last_poll} ||= time();
729            my $dt = time() - $_rss->{last_poll};
730            warn "## rss_check_updates $dt > $rss_min_delay\n";
731            if ( $dt > $rss_min_delay ) {
732                    $_rss->{last_poll} = time();
733                    _log rss_fetch_all( $kernel );
734            }
735    }
736    
737    # seed rss seen cache so we won't send out all items on startup
738    _log rss_fetch_all;
739    
740  #  #
741  # POE handing part  # POE handing part
742  #  #
743    
 my $SKIPPING = 0;               # if skipping, how many we've done  
 my $SEND_QUEUE;                 # cache  
744  my $ping;                                               # ping stats  my $ping;                                               # ping stats
745    
746  POE::Component::IRC->new($IRC_ALIAS);  POE::Component::IRC->new($IRC_ALIAS);
747    
748  POE::Session->create( inline_states =>  POE::Session->create( inline_states => {
749     {_start => sub {                _start => sub {      
750                  $_[KERNEL]->post($IRC_ALIAS => register => 'all');                  $_[KERNEL]->post($IRC_ALIAS => register => 'all');
751                  $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);                  $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);
752      },      },
753      irc_255 => sub {    # server is done blabbing      irc_255 => sub {    # server is done blabbing
754                  $_[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;  
755                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );
756      },      },
757      irc_public => sub {      irc_public => sub {
# Line 538  POE::Session->create( inline_states => Line 760  POE::Session->create( inline_states =>
760                  my $channel = $_[ARG1]->[0];                  my $channel = $_[ARG1]->[0];
761                  my $msg = $_[ARG2];                  my $msg = $_[ARG2];
762    
763                  save_message( channel => $channel, me => 0, nick => $nick, msg => $msg);                  save_message( channel => $channel, me => 0, nick => $nick, message => $msg);
764                  meta( $nick, $channel, 'last-msg', $msg );                  meta( $nick, $channel, 'last-msg', $msg );
765                    rss_check_updates( $kernel );
766      },      },
767      irc_ctcp_action => sub {      irc_ctcp_action => sub {
768                  my $kernel = $_[KERNEL];                  my $kernel = $_[KERNEL];
# Line 547  POE::Session->create( inline_states => Line 770  POE::Session->create( inline_states =>
770                  my $channel = $_[ARG1]->[0];                  my $channel = $_[ARG1]->[0];
771                  my $msg = $_[ARG2];                  my $msg = $_[ARG2];
772    
773                  save_message( channel => $channel, me => 1, nick => $nick, msg => $msg);                  save_message( channel => $channel, me => 1, nick => $nick, message => $msg);
774    
775                  if ( $use_twitter ) {                  if ( $use_twitter ) {
776                          if ( my $twitter = meta( $nick, $NICK, 'twitter' ) ) {                          if ( my $twitter = meta( $nick, $NICK, 'twitter' ) ) {
# Line 560  POE::Session->create( inline_states => Line 783  POE::Session->create( inline_states =>
783    
784      },      },
785          irc_ping => sub {          irc_ping => sub {
786                  warn "pong ", $_[ARG0], $/;                  _log( "pong ", $_[ARG0] );
787                  $ping->{ $_[ARG0] }++;                  $ping->{ $_[ARG0] }++;
788                    rss_check_updates( $_[KERNEL] );
789          },          },
790          irc_invite => sub {          irc_invite => sub {
791                  my $kernel = $_[KERNEL];                  my $kernel = $_[KERNEL];
792                  my $nick = (split /!/, $_[ARG0])[0];                  my $nick = (split /!/, $_[ARG0])[0];
793                  my $channel = $_[ARG1];                  my $channel = $_[ARG1];
794    
795                  warn "invited to $channel by $nick";                  _log "invited to $channel by $nick";
796    
797                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, "how nice of you to invite me to $channel, I'll be right there..." );                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, "how nice of you to invite me to $channel, I'll be right there..." );
798                  $_[KERNEL]->post($IRC_ALIAS => join => $channel);                  $_[KERNEL]->post($IRC_ALIAS => join => $channel);
# Line 579  POE::Session->create( inline_states => Line 803  POE::Session->create( inline_states =>
803                  my $nick = (split /!/, $_[ARG0])[0];                  my $nick = (split /!/, $_[ARG0])[0];
804                  my $msg = $_[ARG2];                  my $msg = $_[ARG2];
805                  my $channel = $_[ARG1]->[0];                  my $channel = $_[ARG1]->[0];
                 from_to($msg, 'UTF-8', $ENCODING);  
806    
807                  my $res = "unknown command '$msg', try /msg $NICK help!";                  my $res = "unknown command '$msg', try /msg $NICK help!";
808                  my @out;                  my @out;
# Line 623  POE::Session->create( inline_states => Line 846  POE::Session->create( inline_states =>
846    
847                          foreach my $res (get_from_log( limit => $limit )) {                          foreach my $res (get_from_log( limit => $limit )) {
848                                  _log "last: $res";                                  _log "last: $res";
                                 from_to($res, $ENCODING, 'UTF-8');  
849                                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );                                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );
850                          }                          }
851    
# Line 638  POE::Session->create( inline_states => Line 860  POE::Session->create( inline_states =>
860                                          search => $what,                                          search => $what,
861                                  )) {                                  )) {
862                                  _log "search [$what]: $res";                                  _log "search [$what]: $res";
                                 from_to($res, $ENCODING, 'UTF-8');  
863                                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );                                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );
864                          }                          }
865    
# Line 708  POE::Session->create( inline_states => Line 929  POE::Session->create( inline_states =>
929                                          $res = "config option $op doesn't exist";                                          $res = "config option $op doesn't exist";
930                                  }                                  }
931                          }                          }
932                    } elsif ($msg =~ m/^rss-update/) {
933                            $res = rss_fetch_all( $_[KERNEL] );
934                    } elsif ($msg =~ m/^rss-clean/) {
935                            $_rss = undef;
936                            $dbh->do( qq{ update feeds set last_update = now() - delay } );
937                            $res = "OK, cleaned RSS cache";
938                    } elsif ($msg =~ m/^rss-list/) {
939                            my $sth = $dbh->prepare(qq{ select url,name,last_update,active,channel,nick,private from feeds });
940                            $sth->execute;
941                            while (my @row = $sth->fetchrow_array) {
942                                    $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, join(' | ',@row) );
943                            }
944                            $res = '';
945                    } elsif ($msg =~ m!^rss-(add|remove|stop|start)(?:-(private))?\s+(http://\S+)\s*(.*)!) {
946                            my ( $command, $sub, $url, $arg ) = ( $1,$2,$3,$4 );
947    
948                            my $channel = $1 if ( $arg =~ s/\s*(#\S+)\s*// );
949                            $channel = $nick if $sub eq 'private';
950    
951                            my $sql = {
952                                    add     => qq{ insert into feeds (url,name,channel,nick,private) values (?,?,?,?,?) },
953    #                               remove  => qq{ delete from feeds                                where url = ? and name = ? },
954                                    start   => qq{ update feeds set active = true   where url = ? },
955                                    stop    => qq{ update feeds set active = false  where url = ? },
956                            };
957    
958                            if ( $command eq 'add' && ! $channel ) {
959                                    $res = "ERROR: got '$msg' which doesn't have #channel in it, ignoring!";
960                            } elsif (my $q = $sql->{$command} ) {
961                                    my $sth = $dbh->prepare( $q );
962                                    my @data = ( $url );
963                                    if ( $command eq 'add' ) {
964                                            push @data, ( $arg, $channel, $nick, $sub eq 'private' ? 1 : 0 );
965                                    }
966                                    warn "## $command SQL $q with ",dump( @data ),"\n";
967                                    eval { $sth->execute( @data ) };
968                                    if ($@) {
969                                            $res = "ERROR: $@";
970                                    } else {
971                                            $res = "OK, RSS [$command|$sub|$url|$arg]";
972                                    }
973                            } else {
974                                    $res = "ERROR: don't know what to do with: $msg";
975                            }
976                  }                  }
977    
978                  if ($res) {                  if ($res) {
979                          _log ">> [$nick] $res";                          _log ">> [$nick] $res";
                         from_to($res, $ENCODING, 'UTF-8');  
980                          $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );                          $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );
981                  }                  }
982    
983                    rss_check_updates( $_[KERNEL] );
984          },          },
985          irc_477 => sub {          irc_477 => sub {
986                  _log "# irc_477: ",$_[ARG1];                  _log "<< irc_477: ",$_[ARG1];
987                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "register $NICK" );                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "register $NICK" );
988          },          },
989          irc_505 => sub {          irc_505 => sub {
990                  _log "# irc_505: ",$_[ARG1];                  _log "<< irc_505: ",$_[ARG1];
991                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "register $NICK" );                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "register $NICK" );
992  #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "set hide email on" );  #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "set hide email on" );
993  #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "set email dpavlin\@rot13.org" );  #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "set email dpavlin\@rot13.org" );
994          },          },
995          irc_registered => sub {          irc_registered => sub {
996                  _log "## registrated $NICK";                  _log "## registrated $NICK, /msg nickserv IDENTIFY $NICK";
997                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );
998          },          },
999          irc_disconnected => sub {          irc_disconnected => sub {
1000                  _log "## disconnected, reconnecting again";                  _log "## disconnected.. sleeping for $sleep_on_error seconds and reconnecting again";
1001                  $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);                  sleep($sleep_on_error);
1002                    $_[KERNEL]->post( $IRC_ALIAS => connect => $CONNECT);
1003          },          },
1004          irc_socketerr => sub {          irc_socketerr => sub {
1005                  _log "## socket error... sleeping for $sleep_on_error seconds and retry";                  _log "## socket error... sleeping for $sleep_on_error seconds and retry";
1006                  sleep($sleep_on_error);                  sleep($sleep_on_error);
1007                  $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);                  $_[KERNEL]->post( $IRC_ALIAS => connect => $CONNECT);
1008          },          },
1009  #       irc_433 => sub {  #       irc_433 => sub {
1010  #               print "# irc_433: ",$_[ARG1], "\n";  #               print "# irc_433: ",$_[ARG1], "\n";
1011  #               warn "## indetify $NICK\n";  #               warn "## indetify $NICK\n";
1012  #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );  #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );
1013  #       },  #       },
1014    #       irc_451 # please register
1015            irc_snotice => sub {
1016                    _log "<< snotice",$_[ARG0];
1017                    if ( $_[ARG0] =~ m!/(QUOTE)\s+(PASS\s+\d+)!i ) {
1018                            warn ">> $1 | $2\n";
1019                            $_[KERNEL]->post( $IRC_ALIAS => lc($1) => $2);
1020                    }
1021            },
1022      _child => sub {},      _child => sub {},
1023      _default => sub {      _default => sub {
1024                  _log sprintf "sID:%s %s %s",                  _log sprintf "sID:%s %s %s",
# Line 754  POE::Session->create( inline_states => Line 1028  POE::Session->create( inline_states =>
1028                          "";                          "";
1029        0;                        # false for signals        0;                        # false for signals
1030      },      },
     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);  
     }  
1031     },     },
1032    );    );
1033    
1034  # http server  # http server
1035    
1036  my $httpd = POE::Component::Server::HTTP->new(  my $httpd = POE::Component::Server::HTTP->new(
1037          Port => $NICK =~ m/-dev/ ? 8001 : 8000,          Port => $http_port,
1038            PreHandler => {
1039                    '/' => sub {
1040                            $_[0]->header(Connection => 'close')
1041                    }
1042            },
1043          ContentHandler => { '/' => \&root_handler },          ContentHandler => { '/' => \&root_handler },
1044          Headers        => { Server => 'irc-logger' },          Headers        => { Server => 'irc-logger' },
1045  );  );
1046    
 my %escape = ('<'=>'&lt;', '>'=>'&gt;', '&'=>'&amp;', '"'=>'&quot;');  
 my $escape_re  = join '|' => keys %escape;  
   
1047  my $style = <<'_END_OF_STYLE_';  my $style = <<'_END_OF_STYLE_';
1048  p { margin: 0; padding: 0.1em; }  p { margin: 0; padding: 0.1em; }
1049  .time, .channel { color: #808080; font-size: 60%; }  .time, .channel { color: #808080; font-size: 60%; }
# Line 845  hr { border: 1px dashed #ccc; height: 1p Line 1061  hr { border: 1px dashed #ccc; height: 1p
1061  .col-3 { background: #ff9999 }  .col-3 { background: #ff9999 }
1062  .col-4 { background: #ff66ff }  .col-4 { background: #ff66ff }
1063  */  */
1064    .calendar { border: 1px solid red; width: 100%; }
1065    .month { border: 0px; width: 100%; }
1066  _END_OF_STYLE_  _END_OF_STYLE_
1067    
1068  my $max_color = 4;  $max_color = 0;
1069    
1070  my @cols = qw(  my @cols = qw(
1071          #ffcccc #ccffe6 #ccccff #e6ccff #ffccff #ffcce6 #ff9999 #ffcc99 #ffff99          #ffcccc #ccffe6 #ccccff #e6ccff #ffccff #ffcce6 #ff9999 #ffcc99 #ffff99
# Line 857  my @cols = qw( Line 1075  my @cols = qw(
1075          #999900 #009900 #cc0066 #c0c0c0 #ccff99 #99ff33 #808080 #660033 #ffffff          #999900 #009900 #cc0066 #c0c0c0 #ccff99 #99ff33 #808080 #660033 #ffffff
1076  );  );
1077    
 $max_color = 0;  
1078  foreach my $c (@cols) {  foreach my $c (@cols) {
1079          $style .= ".col-${max_color} { background: $c }\n";          $style .= ".col-${max_color} { background: $c }\n";
1080          $max_color++;          $max_color++;
1081  }  }
1082  warn "defined $max_color colors for users...\n";  warn "defined $max_color colors for users...\n";
1083    
 my %nick_enumerator;  
   
1084  sub root_handler {  sub root_handler {
1085          my ($request, $response) = @_;          my ($request, $response) = @_;
1086          $response->code(RC_OK);          $response->code(RC_OK);
1087          $response->content_type("text/html; charset=$ENCODING");  
1088            # this doesn't seem to work, so moved to PreHandler
1089            #$response->header(Connection => 'close');
1090    
1091            return RC_OK if $request->uri =~ m/favicon.ico$/;
1092    
1093          my $q;          my $q;
1094    
# Line 883  sub root_handler { Line 1102  sub root_handler {
1102    
1103          my $search = $q->param('search') || $q->param('grep') || '';          my $search = $q->param('search') || $q->param('grep') || '';
1104    
1105            if ($request->url =~ m#/rss(?:/(tags|last-tag|follow.*)\w*(?:=(\d+))?)?#i) {
1106                    my $show = lc($1);
1107                    my $nr = $2;
1108    
1109                    my $type = 'RSS';       # Atom
1110    
1111                    $response->content_type( 'application/' . lc($type) . '+xml' );
1112    
1113                    my $html = '<!-- error -->';
1114                    #warn "create $type feed from ",dump( @last_tags );
1115    
1116                    my $feed = XML::Feed->new( $type );
1117                    $feed->link( $url );
1118    
1119                    if ( $show eq 'tags' ) {
1120                            $nr ||= 50;
1121                            $feed->title( "tags from $CHANNEL" );
1122                            $feed->link( "$url/tags" );
1123                            $feed->description( "tag cloud created from messages on channel $CHANNEL which have tags// in them" );
1124                            my $feed_entry = XML::Feed::Entry->new($type);
1125                            $feed_entry->title( "$nr tags from $CHANNEL" );
1126                            $feed_entry->author( $NICK );
1127                            $feed_entry->link( '/#tags'  );
1128    
1129                            $feed_entry->content(
1130                                    qq{<![CDATA[<style type="text/css">}
1131                                    . $cloud->css
1132                                    . qq{</style>}
1133                                    . $cloud->html( $nr )
1134                                    . qq{]]>}
1135                            );
1136                            $feed->add_entry( $feed_entry );
1137    
1138                    } elsif ( $show eq 'last-tag' ) {
1139    
1140                            $nr ||= $last_x_tags;
1141                            $nr = $last_x_tags if $nr > $last_x_tags;
1142    
1143                            $feed->title( "last $nr tagged messages from $CHANNEL" );
1144                            $feed->description( "collects messages which have tags// in them" );
1145    
1146                            foreach my $m ( @last_tags ) {
1147    #                               warn dump( $m );
1148                                    #my $tags = join(' ', @{$m->{tags}} );
1149                                    my $feed_entry = XML::Feed::Entry->new($type);
1150                                    $feed_entry->title( $m->{nick} . '@' . $m->{time} );
1151                                    $feed_entry->author( $m->{nick} );
1152                                    $feed_entry->link( '/#' . $m->{id}  );
1153                                    $feed_entry->issued( DateTime::Format::Flexible->build( $m->{time} ) );
1154    
1155                                    my $message = $filter->{message}->( $m->{message} );
1156                                    $message .= "<br/>\n" unless $message =~ m!<(/p|br/?)>!;
1157    #                               warn "## message = $message\n";
1158    
1159                                    #$feed_entry->summary(
1160                                    $feed_entry->content(
1161                                            "<![CDATA[$message]]>"
1162                                    );
1163                                    $feed_entry->category( join(', ', @{$m->{tags}}) );
1164                                    $feed->add_entry( $feed_entry );
1165    
1166                                    $nr--;
1167                                    last if $nr <= 0;
1168    
1169                            }
1170    
1171                    } elsif ( $show =~ m/^follow/ ) {
1172    
1173                            $feed->title( "Feeds which this bot follows" );
1174    
1175                            my $sth = $dbh->prepare( qq{ select * from feeds order by last_update desc } );
1176                            $sth->execute;
1177                            while (my $row = $sth->fetchrow_hashref) {
1178                                    my $feed_entry = XML::Feed::Entry->new($type);
1179                                    $feed_entry->title( $row->{name} );
1180                                    $feed_entry->link( $row->{url}  );
1181                                    $feed_entry->issued( DateTime::Format::Flexible->build( $row->{last_update} ) );
1182                                    $feed_entry->content(
1183                                            '<![CDATA[<pre>' . dump( $row ) . '</pre>]]>'
1184                                    );
1185                                    $feed->add_entry( $feed_entry );
1186                            }
1187    
1188                            my $feed_entry = XML::Feed::Entry->new($type);
1189                            $feed_entry->title( "Internal stats" );
1190                            $feed_entry->content(
1191                                    '<![CDATA[<pre>' . dump( $_rss ) . '</pre>]]>'
1192                            );
1193                            $feed->add_entry( $feed_entry );
1194    
1195                    } else {
1196                            _log "unknown rss request ",$request->url;
1197                            return RC_DENY;
1198                    }
1199    
1200                    $response->content( $feed->as_xml );
1201                    return RC_OK;
1202            }
1203    
1204            if ( $@ ) {
1205                    warn "$@";
1206            }
1207    
1208            $response->content_type("text/html; charset=UTF-8");
1209    
1210          my $html =          my $html =
1211                  qq{<html><head><title>$NICK</title><style type="text/css">$style} .                  qq{<html><head><title>$NICK</title><style type="text/css">$style}
1212                  $cloud->css .                  . $cloud->css
1213                  qq{</style></head><body>} .                  . qq{</style></head><body>}
1214                  qq{                  . qq{
1215                  <form method="post" class="search" action="/">                  <form method="post" class="search" action="/">
1216                  <input type="text" name="search" value="$search" size="10">                  <input type="text" name="search" value="$search" size="10">
1217                  <input type="submit" value="search">                  <input type="submit" value="search">
1218                  </form>                  </form>
1219                  } .                  }
1220                  $cloud->html(500) .                  . $cloud->html(500)
1221                  qq{<p>};                  . qq{<p>};
1222          if ($request->url =~ m#/history#) {  
1223            if ($request->url =~ m#/tags?#) {
1224                    # nop
1225            } elsif ($request->url =~ m#/history#) {
1226                  my $sth = $dbh->prepare(qq{                  my $sth = $dbh->prepare(qq{
1227                          select date(time) as date,count(*) as nr                          select date(time) as date,count(*) as nr,sum(length(message)) as len
1228                                  from log                                  from log
1229                                  group by date(time)                                  group by date(time)
1230                                  order by date(time) desc                                  order by date(time) desc
1231                  });                  });
1232                  $sth->execute();                  $sth->execute();
1233                  my ($l_yyyy,$l_mm) = (0,0);                  my ($l_yyyy,$l_mm) = (0,0);
1234                    $html .= qq{<table class="calendar"><tr>};
1235                  my $cal;                  my $cal;
1236                    my $ord = 0;
1237                  while (my $row = $sth->fetchrow_hashref) {                  while (my $row = $sth->fetchrow_hashref) {
1238                          # this is probably PostgreSQL specific, expects ISO date                          # this is probably PostgreSQL specific, expects ISO date
1239                          my ($yyyy,$mm,$dd) = split(/-/, $row->{date});                          my ($yyyy,$mm,$dd) = split(/-/, $row->{date});
1240                          if ($yyyy != $l_yyyy || $mm != $l_mm) {                          if ($yyyy != $l_yyyy || $mm != $l_mm) {
1241                                  $html .= $cal->as_HTML() if ($cal);                                  if ( $cal ) {
1242                                            $html .= qq{<td valign="top">} . $cal->as_HTML() . qq{</td>};
1243                                            $ord++;
1244                                            $html .= qq{</tr><tr>} if ( $ord % 3 == 0 );
1245                                    }
1246                                  $cal = new HTML::CalendarMonthSimple('month'=>$mm,'year'=>$yyyy);                                  $cal = new HTML::CalendarMonthSimple('month'=>$mm,'year'=>$yyyy);
1247                                  $cal->border(2);                                  $cal->border(1);
1248                                    $cal->width('30%');
1249                                    $cal->cellheight('5em');
1250                                    $cal->tableclass('month');
1251                                    #$cal->cellclass('day');
1252                                    $cal->sunday('SUN');
1253                                    $cal->saturday('SAT');
1254                                    $cal->weekdays('MON','TUE','WED','THU','FRI');
1255                                  ($l_yyyy,$l_mm) = ($yyyy,$mm);                                  ($l_yyyy,$l_mm) = ($yyyy,$mm);
1256                          }                          }
1257                          $cal->setcontent($dd, qq{                          $cal->setcontent($dd, qq[
1258                                  <a href="/?date=$row->{date}">$row->{nr}</a>                                  <a href="$url?date=$row->{date}">$row->{nr}</a><br/>$row->{len}
1259                          });                          ]) if $cal;
1260                            
1261                  }                  }
1262                  $html .= $cal->as_HTML() if ($cal);                  $html .= qq{<td valign="top">} . $cal->as_HTML() . qq{</td></tr></table>};
1263    
1264          } else {          } else {
1265                  $html .= join("</p><p>",                  $html .= join("</p><p>",
1266                          get_from_log(                          get_from_log(
1267                                  limit => $q->param('last') || $q->param('date') ? undef : 100,                                  limit => ( $q->param('last') || $q->param('date') ) ? undef : 100,
1268                                  search => $search || undef,                                  search => $search || undef,
1269                                  tag => $q->param('tag') || undef,                                  tag => $q->param('tag') || undef,
1270                                  date => $q->param('date') || undef,                                  date => $q->param('date') || undef,
1271                                  fmt => {                                  fmt => {
1272                                          date => sub {                                          date => sub {
1273                                                  my $date = shift || return;                                                  my $date = shift || return;
1274                                                  qq{<hr/><div class="date"><a href="/?date=$date">$date</a></div>};                                                  qq{<hr/><div class="date"><a href="$url?date=$date">$date</a></div>};
1275                                          },                                          },
1276                                          time => '<span class="time">%s</span> ',                                          time => '<span class="time">%s</span> ',
1277                                          time_channel => '<span class="channel">%s %s</span> ',                                          time_channel => '<span class="channel">%s %s</span> ',
# Line 938  sub root_handler { Line 1279  sub root_handler {
1279                                          me_nick => '***%s&nbsp;',                                          me_nick => '***%s&nbsp;',
1280                                          message => '<span class="message">%s</span>',                                          message => '<span class="message">%s</span>',
1281                                  },                                  },
1282                                  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;  
                                                 $m =~ s#\*(\w+)\*#<b>$1</b>#gs;  
                                                 $m =~ s#_(\w+)_#<u>$1</u>#gs;  
                                                 $m =~ s#\/(\w+)\/#<i>$1</i>#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>';  
                                         },  
                                 },  
1283                          )                          )
1284                  );                  );
1285          }          }
# Line 970  sub root_handler { Line 1290  sub root_handler {
1290          </body></html>};          </body></html>};
1291    
1292          $response->content( $html );          $response->content( $html );
1293            warn "<< ", $request->method, " ", $request->uri, " created ", length($html), " bytes\n";
1294          return RC_OK;          return RC_OK;
1295  }  }
1296    
Legend:
Removed from v.60  
changed lines
  Added in v.105
  ViewVC Help
Powered by ViewVC 1.1.26