/[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 50 by dpavlin, Sun Mar 18 15:37:05 2007 UTC revision 102 by dpavlin, Sat Mar 8 17:38:30 2008 UTC
# Line 2  Line 2 
2  use strict;  use strict;
3  $|++;  $|++;
4    
5    use POE qw(Component::IRC Component::Server::HTTP);
6    use HTTP::Status;
7    use DBI;
8    use Regexp::Common qw /URI/;
9    use CGI::Simple;
10    use HTML::TagCloud;
11    use POSIX qw/strftime/;
12    use HTML::CalendarMonthSimple;
13    use Getopt::Long;
14    use DateTime;
15    use URI::Escape;
16    use Data::Dump qw/dump/;
17    use DateTime::Format::ISO8601;
18    use Carp qw/confess/;
19    use XML::Feed;
20    use DateTime::Format::Flexible;
21    
22  =head1 NAME  =head1 NAME
23    
24  irc-logger.pl  irc-logger.pl
# Line 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
88  use Encode qw/from_to is_utf8/;  
89  use Regexp::Common qw /URI/;  my $use_twitter = 1;
90  use CGI::Simple;  eval { require Net::Twitter; };
91  use HTML::TagCloud;  $use_twitter = 0 if ($@);
 use POSIX qw/strftime/;  
 use HTML::CalendarMonthSimple;  
 use Getopt::Long;  
 use DateTime;  
 use Data::Dump qw/dump/;  
92    
93  my $import_dircproxy;  my $import_dircproxy;
94  my $log_path;  my $log_path;
# Line 82  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 105  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 158  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 170  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 179  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 187  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 224  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 254  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'";
                 $sth->execute();  
                 _log "tag '$tag' returned ", $sth->rows, " results ", $context || '';  
         } elsif (my $date = $args->{date}) {  
                 $sth->execute($date);  
                 _log "found ", $sth->rows, " messages for date $date ", $context || '';  
         } else {  
                 $sth->execute();  
357          }          }
358    
359            if ($args->{tag} && $tags->{ $args->{tag} }) {
360                    push @where, 'id in (' . join(',', @{ $tags->{ $args->{tag} } }) . ')';
361                    $msg = "Search for tags $args->{tag}";
362            }
363    
364            if (my $date = $args->{date} ) {
365                    $date = check_date( $date );
366                    push @where, 'date(time) = ?';
367                    push @args, $date;
368                    $msg = "search for date $date";
369            }
370    
371            $sql .= " where " . join(" and ", @where) if @where;
372    
373            $sql .= " order by log.time desc";
374            $sql .= " limit " . $args->{limit} if ($args->{limit});
375    
376            #warn "### sql: $sql ", dump( @args );
377    
378            my $sth = $dbh->prepare( $sql );
379            eval { $sth->execute( @args ) };
380            return if $@;
381    
382            my $nr_results = $sth->rows;
383    
384          my $last_row = {          my $last_row = {
385                  date => '',                  date => '',
386                  time => '',                  time => '',
# Line 295  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 395  my $cloud = HTML::TagCloud->new; Line 505  my $cloud = HTML::TagCloud->new;
505    
506  =head2 add_tag  =head2 add_tag
507    
508   add_tag( id => 42, message => 'irc message' );   add_tag( id => 42, message => 'irc message', nick => 'foobar' [, me => 1 ] );
509    
510  =cut  =cut
511    
512    my @last_tags;
513    
514  sub add_tag {  sub add_tag {
515          my $arg = {@_};          my $arg = {@_};
516    
517          return unless ($arg->{id} && $arg->{message});          return unless ($arg->{id} && $arg->{message});
518    
519          my $m = $arg->{message};          my $m = $arg->{message};
520          from_to('UTF-8', 'iso-8859-2', $m) if (is_utf8($m));  
521            my @tags;
522    
523          while ($m =~ s#$tag_regex##s) {          while ($m =~ s#$tag_regex##s) {
524                  my $tag = $1;                  my $tag = $1;
525                  next if (! $tag || $tag =~ m/https?:/i);                  next if (! $tag || $tag =~ m/https?:/i);
526                  push @{ $tags->{$tag} }, $arg->{id};                  push @{ $tags->{$tag} }, $arg->{id};
527                  #warn "+tag $tag: $arg->{id}\n";                  #warn "+tag $tag: $arg->{id}\n";
528                  $cloud->add($tag, "?tag=$tag", scalar @{$tags->{$tag}} + 1);                  $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  =head2 seed_tags
# Line 423  Read all tags from database and create i Line 544  Read all tags from database and create i
544  =cut  =cut
545    
546  sub seed_tags {  sub seed_tags {
547          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 });
548          $sth->execute;          $sth->execute;
549          while (my $row = $sth->fetchrow_hashref) {          while (my $row = $sth->fetchrow_hashref) {
550                  add_tag( %$row );                  add_tag( %$row );
551          }          }
552    
553          foreach my $tag (keys %$tags) {          foreach my $tag (keys %$tags) {
554                  $cloud->add($tag, "?tag=$tag", scalar @{$tags->{$tag}} + 1);                  $cloud->add($tag, "$url?tag=$tag", scalar @{$tags->{$tag}} + 1);
555          }          }
556  }  }
557    
# Line 443  seed_tags; Line 564  seed_tags;
564          channel => '#foobar',          channel => '#foobar',
565          me => 0,          me => 0,
566          nick => 'dpavlin',          nick => 'dpavlin',
567          msg => 'test message',          message => 'test message',
568          time => '2006-06-25 18:57:18',          time => '2006-06-25 18:57:18',
569    );    );
570    
# Line 455  C<me> if not specified will be C<0> (not Line 576  C<me> if not specified will be C<0> (not
576    
577  sub save_message {  sub save_message {
578          my $a = {@_};          my $a = {@_};
579            confess "have msg" if $a->{msg};
580          $a->{me} ||= 0;          $a->{me} ||= 0;
581          $a->{time} ||= strftime($TIMESTAMP,localtime());          $a->{time} ||= strftime($TIMESTAMP,localtime());
582    
583          _log          _log
584                  $a->{channel}, " ",                  $a->{channel}, " ",
585                  $a->{me} ? "***" . $a->{nick} : "<" . $a->{nick} . ">",                  $a->{me} ? "***" . $a->{nick} : "<" . $a->{nick} . ">",
586                  " " . $a->{msg};                  " " . $a->{message};
   
         from_to($a->{msg}, 'UTF-8', $ENCODING);  
587    
588          $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});
589          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});  
590  }  }
591    
592    
593  if ($import_dircproxy) {  if ($import_dircproxy) {
594          open(my $l, $import_dircproxy) || die "can't open $import_dircproxy: $!";          open(my $l, $import_dircproxy) || die "can't open $import_dircproxy: $!";
595          warn "importing $import_dircproxy...\n";          warn "importing $import_dircproxy...\n";
596          my $tz_offset = 2 * 60 * 60;    # TZ GMT+2          my $tz_offset = 1 * 60 * 60;    # TZ GMT+2
597          while(<$l>) {          while(<$l>) {
598                  chomp;                  chomp;
599                  if (/^@(\d+)\s(\S+)\s(.+)$/) {                  if (/^@(\d+)\s(\S+)\s(.+)$/) {
# Line 492  if ($import_dircproxy) { Line 611  if ($import_dircproxy) {
611                                  channel => $CHANNEL,                                  channel => $CHANNEL,
612                                  me => $me,                                  me => $me,
613                                  nick => $nick,                                  nick => $nick,
614                                  msg => $msg,                                  message => $msg,
615                                  time => $dt->ymd . " " . $dt->hms,                                  time => $dt->ymd . " " . $dt->hms,
616                          ) if ($nick !~ m/^-/);                          ) if ($nick !~ m/^-/);
617    
# Line 505  if ($import_dircproxy) { Line 624  if ($import_dircproxy) {
624          exit;          exit;
625  }  }
626    
627    #
628    # RSS follow
629    #
630    
631    my $_rss;
632    
633    
634    sub rss_fetch {
635            my ($args) = @_;
636    
637            # how many messages to send out when feed is seen for the first time?
638            my $send_rss_msgs = 1;
639    
640            _log "RSS fetch", $args->{url};
641    
642            my $feed = XML::Feed->parse(URI->new( $args->{url} ));
643            if ( ! $feed ) {
644                    _log("can't fetch RSS ", $args->{url});
645                    return;
646            }
647    
648            my ( $total, $updates ) = ( 0, 0 );
649            for my $entry ($feed->entries) {
650                    $total++;
651    
652                    # seen allready?
653                    next if $_rss->{$args->{channel}}->{$feed->link}->{$entry->id}++ > 0;
654    
655                    sub prefix {
656                            my ($txt,$var) = @_;
657                            $var =~ s/\s+/ /gs;
658                            $var =~ s/^\s+//g;
659                            $var =~ s/\s+$//g;
660                            return $txt . $var if $var;
661                    }
662    
663                    # fix absolute and relative links to feed entries
664                    my $link = $entry->link;
665                    if ( $link =~ m!^/! ) {
666                            my $host = $args->{url};
667                            $host =~ s!^(http://[^/]+).*$!$1!;      #!vim
668                            $link = "$host/$link";
669                    } elsif ( $link !~ m!^http! ) {
670                            $link = $args->{url} . $link;
671                    }
672    
673                    my $msg;
674                    $msg .= prefix( 'From: ' , $args->{name} || $feed->title );
675                    $msg .= prefix( ' by ' , $entry->author );
676                    $msg .= prefix( ' | ' , $entry->title );
677                    $msg .= prefix( ' | ' , $link );
678    #               $msg .= prefix( ' id ' , $entry->id );
679    
680                    if ( $args->{kernel} && $send_rss_msgs ) {
681                            $send_rss_msgs--;
682                            $sth_insert_log->execute( $args->{channel}, 1, $NICK, $msg, 'now()' );
683                            my ( $type, $to ) = ( 'notice', $args->{channel} );
684                            ( $type, $to ) = ( 'privmsg', $args->{nick} ) if $args->{private};
685                            _log(">> $type $to |", $msg);
686                            $args->{kernel}->post( $IRC_ALIAS => $type => $to, $msg );
687                            $updates++;
688                    }
689            }
690    
691            my $sql = qq{ update feeds set last_update = now(), polls = polls + 1 };
692            $sql .= qq{, updates = updates + $updates } if $updates;
693            $sql .= qq{where id = } . $args->{id};
694            eval { $dbh->do( $sql ) };
695    
696            _log "RSS got $total items of which $updates new";
697    
698            return $updates;
699    }
700    
701    sub rss_fetch_all {
702            my $kernel = shift;
703            my $sql = qq{
704                    select id, url, name, channel, nick, private
705                    from feeds
706                    where active is true
707            };
708            # limit to newer feeds only if we are not sending messages out
709            $sql .= qq{     and last_update + delay < now() } if $kernel;
710            my $sth = $dbh->prepare( $sql );
711            $sth->execute();
712            warn "# ",$sth->rows," active RSS feeds\n";
713            my $count = 0;
714            while (my $row = $sth->fetchrow_hashref) {
715                    $row->{kernel} = $kernel if $kernel;
716                    $count += rss_fetch( $row );
717            }
718            return "OK, fetched $count posts from " . $sth->rows . " feeds";
719    }
720    
721    
722    sub rss_check_updates {
723            my $kernel = shift;
724            $_rss->{last_poll} ||= time();
725            my $dt = time() - $_rss->{last_poll};
726            warn "## rss_check_updates $dt > $rss_min_delay\n";
727            if ( $dt > $rss_min_delay ) {
728                    $_rss->{last_poll} = time();
729                    _log rss_fetch_all( $kernel );
730            }
731    }
732    
733    # seed rss seen cache so we won't send out all items on startup
734    _log rss_fetch_all;
735    
736  #  #
737  # POE handing part  # POE handing part
738  #  #
739    
 my $SKIPPING = 0;               # if skipping, how many we've done  
 my $SEND_QUEUE;                 # cache  
740  my $ping;                                               # ping stats  my $ping;                                               # ping stats
741    
742  POE::Component::IRC->new($IRC_ALIAS);  POE::Component::IRC->new($IRC_ALIAS);
743    
744  POE::Session->create( inline_states =>  POE::Session->create( inline_states => {
745     {_start => sub {                _start => sub {      
746                  $_[KERNEL]->post($IRC_ALIAS => register => 'all');                  $_[KERNEL]->post($IRC_ALIAS => register => 'all');
747                  $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);                  $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);
748      },      },
749      irc_255 => sub {    # server is done blabbing      irc_255 => sub {    # server is done blabbing
750                  $_[KERNEL]->post($IRC_ALIAS => join => $CHANNEL);                  $_[KERNEL]->post($IRC_ALIAS => join => $CHANNEL);
                 $_[KERNEL]->post($IRC_ALIAS => join => '#logger');  
                 $_[KERNEL]->yield("heartbeat"); # start heartbeat  
 #               $_[KERNEL]->yield("my_add", $_) for keys %FOLLOWS;  
751                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );
752      },      },
753      irc_public => sub {      irc_public => sub {
# Line 534  POE::Session->create( inline_states => Line 756  POE::Session->create( inline_states =>
756                  my $channel = $_[ARG1]->[0];                  my $channel = $_[ARG1]->[0];
757                  my $msg = $_[ARG2];                  my $msg = $_[ARG2];
758    
759                  save_message( channel => $channel, me => 0, nick => $nick, msg => $msg);                  save_message( channel => $channel, me => 0, nick => $nick, message => $msg);
760                  meta( $nick, $channel, 'last-msg', $msg );                  meta( $nick, $channel, 'last-msg', $msg );
761                    rss_check_updates( $kernel );
762      },      },
763      irc_ctcp_action => sub {      irc_ctcp_action => sub {
764                  my $kernel = $_[KERNEL];                  my $kernel = $_[KERNEL];
# Line 543  POE::Session->create( inline_states => Line 766  POE::Session->create( inline_states =>
766                  my $channel = $_[ARG1]->[0];                  my $channel = $_[ARG1]->[0];
767                  my $msg = $_[ARG2];                  my $msg = $_[ARG2];
768    
769                  save_message( channel => $channel, me => 1, nick => $nick, msg => $msg);                  save_message( channel => $channel, me => 1, nick => $nick, message => $msg);
770    
771                  if ( my $twitter = ( $nick, $channel, 'twitter' ) ) {                  if ( $use_twitter ) {
772                          _log("FIXME: send twitter for $nick on $channel [$twitter]");                          if ( my $twitter = meta( $nick, $NICK, 'twitter' ) ) {
773                                    my ($login,$passwd) = split(/\s+/,$twitter,2);
774                                    _log("sending twitter for $nick/$login on $channel ");
775                                    my $bot = Net::Twitter->new( username=>$login, password=>$passwd );
776                                    $bot->update("<${channel}> $msg");
777                            }
778                  }                  }
779    
780      },      },
781          irc_ping => sub {          irc_ping => sub {
782                  warn "pong ", $_[ARG0], $/;                  _log( "pong ", $_[ARG0] );
783                  $ping->{ $_[ARG0] }++;                  $ping->{ $_[ARG0] }++;
784                    rss_check_updates( $_[KERNEL] );
785          },          },
786          irc_invite => sub {          irc_invite => sub {
787                  my $kernel = $_[KERNEL];                  my $kernel = $_[KERNEL];
788                  my $nick = (split /!/, $_[ARG0])[0];                  my $nick = (split /!/, $_[ARG0])[0];
789                  my $channel = $_[ARG1];                  my $channel = $_[ARG1];
790    
791                  warn "invited to $channel by $nick";                  _log "invited to $channel by $nick";
792    
793                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, "how nice of you to invite me to $channel, I'll be right there..." );                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, "how nice of you to invite me to $channel, I'll be right there..." );
794                  $_[KERNEL]->post($IRC_ALIAS => join => $channel);                  $_[KERNEL]->post($IRC_ALIAS => join => $channel);
# Line 570  POE::Session->create( inline_states => Line 799  POE::Session->create( inline_states =>
799                  my $nick = (split /!/, $_[ARG0])[0];                  my $nick = (split /!/, $_[ARG0])[0];
800                  my $msg = $_[ARG2];                  my $msg = $_[ARG2];
801                  my $channel = $_[ARG1]->[0];                  my $channel = $_[ARG1]->[0];
                 from_to($msg, 'UTF-8', $ENCODING);  
802    
803                  my $res = "unknown command '$msg', try /msg $NICK help!";                  my $res = "unknown command '$msg', try /msg $NICK help!";
804                  my @out;                  my @out;
# Line 593  POE::Session->create( inline_states => Line 821  POE::Session->create( inline_states =>
821    
822                          my $sth = $dbh->prepare(qq{                          my $sth = $dbh->prepare(qq{
823                                  select                                  select
824                                          nick,                                          trim(both '_' from nick) as nick,
825                                          count(*) as count,                                          count(*) as count,
826                                          sum(length(message)) as len                                          sum(length(message)) as len
827                                  from log                                  from log
828                                  group by nick                                  group by trim(both '_' from nick)
829                                  order by len desc,count desc                                  order by len desc,count desc
830                                  limit $nr                                  limit $nr
831                          });                          });
# Line 614  POE::Session->create( inline_states => Line 842  POE::Session->create( inline_states =>
842    
843                          foreach my $res (get_from_log( limit => $limit )) {                          foreach my $res (get_from_log( limit => $limit )) {
844                                  _log "last: $res";                                  _log "last: $res";
                                 from_to($res, $ENCODING, 'UTF-8');  
845                                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );                                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );
846                          }                          }
847    
# Line 629  POE::Session->create( inline_states => Line 856  POE::Session->create( inline_states =>
856                                          search => $what,                                          search => $what,
857                                  )) {                                  )) {
858                                  _log "search [$what]: $res";                                  _log "search [$what]: $res";
                                 from_to($res, $ENCODING, 'UTF-8');  
859                                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );                                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );
860                          }                          }
861    
# Line 669  POE::Session->create( inline_states => Line 895  POE::Session->create( inline_states =>
895    
896                  } elsif ($msg =~ m/^ping/) {                  } elsif ($msg =~ m/^ping/) {
897                          $res = "ping = " . dump( $ping );                          $res = "ping = " . dump( $ping );
898                  } elsif ($msg =~ m/^(?:twitter)\s+(\S+)\s+(.*?)/) {                  } elsif ($msg =~ m/^conf(?:ig)*\s*(last-size|twitter)*\s*(.*)/) {
                         if ( defined( $2 ) ) {  
                                 meta($nick, $channel, 'twitter', "$1\t$2");  
                                 $res = "saved twitter auth for $1 -- /me on $channel will auto-update twitter status";  
                         } else {  
                                 meta($nick, $channel, 'twitter', '' );  
                                 $res = "removed twitter status update for /me on $channel";  
                         }  
                 } elsif ($msg =~ m/^conf(?:ig)*\s*(last-size)*\s*(\d*)/) {  
899                          if ( ! defined( $1 ) ) {                          if ( ! defined( $1 ) ) {
900                                  my $sth = $dbh->prepare(qq{ select name,value,changed from meta where nick = ? and channel = ? });                                  my $sth = $dbh->prepare(qq{ select name,value,changed from meta where nick = ? and channel = ? });
901                                  $sth->execute( $nick, $channel );                                  $sth->execute( $nick, $channel );
902                                  $res = "config for $nick ";                                  $res = "config for $nick on $channel";
903                                  while ( my ($n,$v) = $sth->fetchrow_array ) {                                  while ( my ($n,$v) = $sth->fetchrow_array ) {
904                                          $res .= "| $n = $v";                                          $res .= " | $n = $v";
905                                  }                                  }
906                          } elsif ( defined( $2 ) ) {                          } elsif ( ! $2 ) {
                                 meta( $nick, $channel, $1, $2 );  
                                 $res = "saved $1 = $2";  
                         } else {  
907                                  my $val = meta( $nick, $channel, $1 );                                  my $val = meta( $nick, $channel, $1 );
908                                  $res = "current $1 = " . ( $val ? $val : 'undefined' );                                  $res = "current $1 = " . ( $val ? $val : 'undefined' );
909                            } else {
910                                    my $validate = {
911                                            'last-size' => qr/^\d+/,
912                                            'twitter' => qr/^\w+\s+\w+/,
913                                    };
914    
915                                    my ( $op, $val ) = ( $1, $2 );
916    
917                                    if ( my $regex = $validate->{$op} ) {
918                                            if ( $val =~ $regex ) {
919                                                    meta( $nick, $channel, $op, $val );
920                                                    $res = "saved $op = $val";
921                                            } else {
922                                                    $res = "config option $op = $val doesn't validate against $regex";
923                                            }
924                                    } else {
925                                            $res = "config option $op doesn't exist";
926                                    }
927                            }
928                    } elsif ($msg =~ m/^rss-update/) {
929                            $res = rss_fetch_all( $_[KERNEL] );
930                    } elsif ($msg =~ m/^rss-clean/) {
931                            $_rss = undef;
932                            $dbh->do( qq{ update feeds set last_update = now() - delay } );
933                            $res = "OK, cleaned RSS cache";
934                    } elsif ($msg =~ m/^rss-list/) {
935                            my $sth = $dbh->prepare(qq{ select url,name,last_update,active,channel,nick,private from feeds });
936                            $sth->execute;
937                            while (my @row = $sth->fetchrow_array) {
938                                    $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, join(' | ',@row) );
939                            }
940                            $res = '';
941                    } elsif ($msg =~ m!^rss-(add|remove|stop|start)(?:-(private))?\s+(http://\S+)\s*(.*)!) {
942                            my ( $command, $sub, $url, $arg ) = ( $1,$2,$3,$4 );
943    
944                            my $channel = $1 if ( $arg =~ s/\s*(#\S+)\s*// );
945                            $channel = $nick if $sub eq 'private';
946    
947                            my $sql = {
948                                    add             => qq{ insert into feeds (url,name,channel,nick,private) values (?,?,?,?,?) },
949    #                               remove  => qq{ delete from feeds                                where url = ? and name = ? },
950                                    start   => qq{ update feeds set active = true   where url = ? },
951                                    stop    => qq{ update feeds set active = false  where url = ? },
952                            };
953    
954                            if ( $command eq 'add' && ! $channel ) {
955                                    $res = "ERROR: got '$msg' which doesn't have #channel in it, ignoring!";
956                            } elsif (my $q = $sql->{$command} ) {
957                                    my $sth = $dbh->prepare( $q );
958                                    my @data = ( $url );
959                                    if ( $command eq 'add' ) {
960                                            push @data, ( $arg, $channel, $nick, $sub eq 'private' ? 1 : 0 );
961                                    }
962                                    warn "## $command SQL $q with ",dump( @data ),"\n";
963                                    eval { $sth->execute( @data ) };
964                                    if ($@) {
965                                            $res = "ERROR: $@";
966                                    } else {
967                                            $res = "OK, RSS [$command|$sub|$url|$arg]";
968                                    }
969                            } else {
970                                    $res = "ERROR: don't know what to do with: $msg";
971                          }                          }
972                  }                  }
973    
974                  if ($res) {                  if ($res) {
975                          _log ">> [$nick] $res";                          _log ">> [$nick] $res";
                         from_to($res, $ENCODING, 'UTF-8');  
976                          $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );                          $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );
977                  }                  }
978    
979                    rss_check_updates( $_[KERNEL] );
980          },          },
981          irc_477 => sub {          irc_477 => sub {
982                  _log "# irc_477: ",$_[ARG1];                  _log "# irc_477: ",$_[ARG1];
# Line 738  POE::Session->create( inline_states => Line 1015  POE::Session->create( inline_states =>
1015                          "";                          "";
1016        0;                        # false for signals        0;                        # false for signals
1017      },      },
     my_add => sub {  
       my $trailing = $_[ARG0];  
       my $session = $_[SESSION];  
       POE::Session->create  
           (inline_states =>  
            {_start => sub {  
               $_[HEAP]->{wheel} =  
                 POE::Wheel::FollowTail->new  
                     (  
                      Filename => $FOLLOWS{$trailing},  
                      InputEvent => 'got_line',  
                     );  
             },  
             got_line => sub {  
               $_[KERNEL]->post($session => my_tailed =>  
                                time, $trailing, $_[ARG0]);  
             },  
            },  
           );  
       
     },  
     my_tailed => sub {  
       my ($time, $file, $line) = @_[ARG0..ARG2];  
       ## $time will be undef on a probe, or a time value if a real line  
   
       ## PoCo::IRC has throttling built in, but no external visibility  
       ## so this is reaching "under the hood"  
       $SEND_QUEUE ||=  
         $_[KERNEL]->alias_resolve($IRC_ALIAS)->get_heap->{send_queue};  
   
       ## handle "no need to keep skipping" transition  
       if ($SKIPPING and @$SEND_QUEUE < 1) {  
         $_[KERNEL]->post($IRC_ALIAS => privmsg => $CHANNEL =>  
                          "[discarded $SKIPPING messages]");  
         $SKIPPING = 0;  
       }  
   
       ## handle potential message display  
       if ($time) {  
         if ($SKIPPING or @$SEND_QUEUE > 3) { # 3 msgs per 10 seconds  
           $SKIPPING++;  
         } else {  
           my @time = localtime $time;  
           $_[KERNEL]->post($IRC_ALIAS => privmsg => $CHANNEL =>  
                            sprintf "%02d:%02d:%02d: %s: %s",  
                            ($time[2] + 11) % 12 + 1, $time[1], $time[0],  
                            $file, $line);  
         }  
       }  
   
       ## handle re-probe/flush if skipping  
       if ($SKIPPING) {  
         $_[KERNEL]->delay($_[STATE] => 0.5); # $time will be undef  
       }  
   
     },  
     my_heartbeat => sub {  
       $_[KERNEL]->yield(my_tailed => time, "heartbeat", "beep");  
       $_[KERNEL]->delay($_[STATE] => 10);  
     }  
1018     },     },
1019    );    );
1020    
1021  # http server  # http server
1022    
1023  my $httpd = POE::Component::Server::HTTP->new(  my $httpd = POE::Component::Server::HTTP->new(
1024          Port => $NICK =~ m/-dev/ ? 8001 : 8000,          Port => $http_port,
1025            PreHandler => {
1026                    '/' => sub {
1027                            $_[0]->header(Connection => 'close')
1028                    }
1029            },
1030          ContentHandler => { '/' => \&root_handler },          ContentHandler => { '/' => \&root_handler },
1031          Headers        => { Server => 'irc-logger' },          Headers        => { Server => 'irc-logger' },
1032  );  );
1033    
 my %escape = ('<'=>'&lt;', '>'=>'&gt;', '&'=>'&amp;', '"'=>'&quot;');  
 my $escape_re  = join '|' => keys %escape;  
   
1034  my $style = <<'_END_OF_STYLE_';  my $style = <<'_END_OF_STYLE_';
1035  p { margin: 0; padding: 0.1em; }  p { margin: 0; padding: 0.1em; }
1036  .time, .channel { color: #808080; font-size: 60%; }  .time, .channel { color: #808080; font-size: 60%; }
# Line 819  p { margin: 0; padding: 0.1em; } Line 1038  p { margin: 0; padding: 0.1em; }
1038  .nick { color: #000000; font-size: 80%; padding: 2px; font-family: courier, courier new, monospace ; }  .nick { color: #000000; font-size: 80%; padding: 2px; font-family: courier, courier new, monospace ; }
1039  .message { color: #000000; font-size: 100%; }  .message { color: #000000; font-size: 100%; }
1040  .search { float: right; }  .search { float: right; }
1041    a:link.tag, a:visited.tag { border: 1px dashed #ccc; backgound: #ccc; text-decoration: none }
1042    a:hover.tag { border: 1px solid #eee }
1043    hr { border: 1px dashed #ccc; height: 1px; clear: both; }
1044    /*
1045  .col-0 { background: #ffff66 }  .col-0 { background: #ffff66 }
1046  .col-1 { background: #a0ffff }  .col-1 { background: #a0ffff }
1047  .col-2 { background: #99ff99 }  .col-2 { background: #99ff99 }
1048  .col-3 { background: #ff9999 }  .col-3 { background: #ff9999 }
1049  .col-4 { background: #ff66ff }  .col-4 { background: #ff66ff }
1050  a:link.tag, a:visited.tag { border: 1px dashed #ccc; backgound: #ccc; text-decoration: none }  */
1051  a:hover.tag { border: 1px solid #eee }  .calendar { border: 1px solid red; width: 100%; }
1052  hr { border: 1px dashed #ccc; height: 1px; clear: both; }  .month { border: 0px; width: 100%; }
1053  _END_OF_STYLE_  _END_OF_STYLE_
1054    
1055  my $max_color = 4;  $max_color = 0;
1056    
1057  my %nick_enumerator;  my @cols = qw(
1058            #ffcccc #ccffe6 #ccccff #e6ccff #ffccff #ffcce6 #ff9999 #ffcc99 #ffff99
1059            #ccff99 #99ff99 #99ffcc #99ccff #9999ff #cc99ff #ff6666 #ffb366 #ffff66
1060            #66ff66 #66ffb3 #66b3ff #6666ff #ff3333 #33ff33 #3399ff #3333ff #ff3399
1061            #a0a0a0 #ff0000 #ffff00 #80ff00 #0000ff #8000ff #ff00ff #ff0080 #994d00
1062            #999900 #009900 #cc0066 #c0c0c0 #ccff99 #99ff33 #808080 #660033 #ffffff
1063    );
1064    
1065    foreach my $c (@cols) {
1066            $style .= ".col-${max_color} { background: $c }\n";
1067            $max_color++;
1068    }
1069    warn "defined $max_color colors for users...\n";
1070    
1071  sub root_handler {  sub root_handler {
1072          my ($request, $response) = @_;          my ($request, $response) = @_;
1073          $response->code(RC_OK);          $response->code(RC_OK);
1074          $response->content_type("text/html; charset=$ENCODING");  
1075            # this doesn't seem to work, so moved to PreHandler
1076            #$response->header(Connection => 'close');
1077    
1078            return RC_OK if $request->uri =~ m/favicon.ico$/;
1079    
1080          my $q;          my $q;
1081    
# Line 850  sub root_handler { Line 1089  sub root_handler {
1089    
1090          my $search = $q->param('search') || $q->param('grep') || '';          my $search = $q->param('search') || $q->param('grep') || '';
1091    
1092            if ($request->url =~ m#/rss(?:/(tags|last-tag|follow.*)\w*(?:=(\d+))?)?#i) {
1093                    my $show = lc($1);
1094                    my $nr = $2;
1095    
1096                    my $type = 'RSS';       # Atom
1097    
1098                    $response->content_type( 'application/' . lc($type) . '+xml' );
1099    
1100                    my $html = '<!-- error -->';
1101                    #warn "create $type feed from ",dump( @last_tags );
1102    
1103                    my $feed = XML::Feed->new( $type );
1104                    $feed->link( $url );
1105    
1106                    if ( $show eq 'tags' ) {
1107                            $nr ||= 50;
1108                            $feed->title( "tags from $CHANNEL" );
1109                            $feed->link( "$url/tags" );
1110                            $feed->description( "tag cloud created from messages on channel $CHANNEL which have tags// in them" );
1111                            my $feed_entry = XML::Feed::Entry->new($type);
1112                            $feed_entry->title( "$nr tags from $CHANNEL" );
1113                            $feed_entry->author( $NICK );
1114                            $feed_entry->link( '/#tags'  );
1115    
1116                            $feed_entry->content(
1117                                    qq{<![CDATA[<style type="text/css">}
1118                                    . $cloud->css
1119                                    . qq{</style>}
1120                                    . $cloud->html( $nr )
1121                                    . qq{]]>}
1122                            );
1123                            $feed->add_entry( $feed_entry );
1124    
1125                    } elsif ( $show eq 'last-tag' ) {
1126    
1127                            $nr ||= $last_x_tags;
1128                            $nr = $last_x_tags if $nr > $last_x_tags;
1129    
1130                            $feed->title( "last $nr tagged messages from $CHANNEL" );
1131                            $feed->description( "collects messages which have tags// in them" );
1132    
1133                            foreach my $m ( @last_tags ) {
1134    #                               warn dump( $m );
1135                                    #my $tags = join(' ', @{$m->{tags}} );
1136                                    my $feed_entry = XML::Feed::Entry->new($type);
1137                                    $feed_entry->title( $m->{nick} . '@' . $m->{time} );
1138                                    $feed_entry->author( $m->{nick} );
1139                                    $feed_entry->link( '/#' . $m->{id}  );
1140                                    $feed_entry->issued( DateTime::Format::Flexible->build( $m->{time} ) );
1141    
1142                                    my $message = $filter->{message}->( $m->{message} );
1143                                    $message .= "<br/>\n" unless $message =~ m!<(/p|br/?)>!;
1144    #                               warn "## message = $message\n";
1145    
1146                                    #$feed_entry->summary(
1147                                    $feed_entry->content(
1148                                            "<![CDATA[$message]]>"
1149                                    );
1150                                    $feed_entry->category( join(', ', @{$m->{tags}}) );
1151                                    $feed->add_entry( $feed_entry );
1152    
1153                                    $nr--;
1154                                    last if $nr <= 0;
1155    
1156                            }
1157    
1158                    } elsif ( $show =~ m/^follow/ ) {
1159    
1160                            $feed->title( "Feeds which this bot follows" );
1161    
1162                            my $sth = $dbh->prepare( qq{ select * from feeds order by last_update desc } );
1163                            $sth->execute;
1164                            while (my $row = $sth->fetchrow_hashref) {
1165                                    my $feed_entry = XML::Feed::Entry->new($type);
1166                                    $feed_entry->title( $row->{name} );
1167                                    $feed_entry->link( $row->{url}  );
1168                                    $feed_entry->issued( DateTime::Format::Flexible->build( $row->{last_update} ) );
1169                                    $feed_entry->content(
1170                                            '<![CDATA[<pre>' . dump( $row ) . '</pre>]]>'
1171                                    );
1172                                    $feed->add_entry( $feed_entry );
1173                            }
1174    
1175                            my $feed_entry = XML::Feed::Entry->new($type);
1176                            $feed_entry->title( "Internal stats" );
1177                            $feed_entry->content(
1178                                    '<![CDATA[<pre>' . dump( $_rss ) . '</pre>]]>'
1179                            );
1180                            $feed->add_entry( $feed_entry );
1181    
1182                    } else {
1183                            _log "unknown rss request ",$request->url;
1184                            return RC_DENY;
1185                    }
1186    
1187                    $response->content( $feed->as_xml );
1188                    return RC_OK;
1189            }
1190    
1191            if ( $@ ) {
1192                    warn "$@";
1193            }
1194    
1195            $response->content_type("text/html; charset=UTF-8");
1196    
1197          my $html =          my $html =
1198                  qq{<html><head><title>$NICK</title><style type="text/css">$style} .                  qq{<html><head><title>$NICK</title><style type="text/css">$style}
1199                  $cloud->css .                  . $cloud->css
1200                  qq{</style></head><body>} .                  . qq{</style></head><body>}
1201                  qq{                  . qq{
1202                  <form method="post" class="search" action="/">                  <form method="post" class="search" action="/">
1203                  <input type="text" name="search" value="$search" size="10">                  <input type="text" name="search" value="$search" size="10">
1204                  <input type="submit" value="search">                  <input type="submit" value="search">
1205                  </form>                  </form>
1206                  } .                  }
1207                  $cloud->html(500) .                  . $cloud->html(500)
1208                  qq{<p>};                  . qq{<p>};
1209          if ($request->url =~ m#/history#) {  
1210            if ($request->url =~ m#/tags?#) {
1211                    # nop
1212            } elsif ($request->url =~ m#/history#) {
1213                  my $sth = $dbh->prepare(qq{                  my $sth = $dbh->prepare(qq{
1214                          select date(time) as date,count(*) as nr                          select date(time) as date,count(*) as nr,sum(length(message)) as len
1215                                  from log                                  from log
1216                                  group by date(time)                                  group by date(time)
1217                                  order by date(time) desc                                  order by date(time) desc
1218                  });                  });
1219                  $sth->execute();                  $sth->execute();
1220                  my ($l_yyyy,$l_mm) = (0,0);                  my ($l_yyyy,$l_mm) = (0,0);
1221                    $html .= qq{<table class="calendar"><tr>};
1222                  my $cal;                  my $cal;
1223                    my $ord = 0;
1224                  while (my $row = $sth->fetchrow_hashref) {                  while (my $row = $sth->fetchrow_hashref) {
1225                          # this is probably PostgreSQL specific, expects ISO date                          # this is probably PostgreSQL specific, expects ISO date
1226                          my ($yyyy,$mm,$dd) = split(/-/, $row->{date});                          my ($yyyy,$mm,$dd) = split(/-/, $row->{date});
1227                          if ($yyyy != $l_yyyy || $mm != $l_mm) {                          if ($yyyy != $l_yyyy || $mm != $l_mm) {
1228                                  $html .= $cal->as_HTML() if ($cal);                                  if ( $cal ) {
1229                                            $html .= qq{<td valign="top">} . $cal->as_HTML() . qq{</td>};
1230                                            $ord++;
1231                                            $html .= qq{</tr><tr>} if ( $ord % 3 == 0 );
1232                                    }
1233                                  $cal = new HTML::CalendarMonthSimple('month'=>$mm,'year'=>$yyyy);                                  $cal = new HTML::CalendarMonthSimple('month'=>$mm,'year'=>$yyyy);
1234                                  $cal->border(2);                                  $cal->border(1);
1235                                    $cal->width('30%');
1236                                    $cal->cellheight('5em');
1237                                    $cal->tableclass('month');
1238                                    #$cal->cellclass('day');
1239                                    $cal->sunday('SUN');
1240                                    $cal->saturday('SAT');
1241                                    $cal->weekdays('MON','TUE','WED','THU','FRI');
1242                                  ($l_yyyy,$l_mm) = ($yyyy,$mm);                                  ($l_yyyy,$l_mm) = ($yyyy,$mm);
1243                          }                          }
1244                          $cal->setcontent($dd, qq{                          $cal->setcontent($dd, qq[
1245                                  <a href="/?date=$row->{date}">$row->{nr}</a>                                  <a href="$url?date=$row->{date}">$row->{nr}</a><br/>$row->{len}
1246                          });                          ]) if $cal;
1247                            
1248                  }                  }
1249                  $html .= $cal->as_HTML() if ($cal);                  $html .= qq{<td valign="top">} . $cal->as_HTML() . qq{</td></tr></table>};
1250    
1251          } else {          } else {
1252                  $html .= join("</p><p>",                  $html .= join("</p><p>",
1253                          get_from_log(                          get_from_log(
1254                                  limit => $q->param('last') || $q->param('date') ? undef : 100,                                  limit => ( $q->param('last') || $q->param('date') ) ? undef : 100,
1255                                  search => $search || undef,                                  search => $search || undef,
1256                                  tag => $q->param('tag') || undef,                                  tag => $q->param('tag') || undef,
1257                                  date => $q->param('date') || undef,                                  date => $q->param('date') || undef,
1258                                  fmt => {                                  fmt => {
1259                                          date => sub {                                          date => sub {
1260                                                  my $date = shift || return;                                                  my $date = shift || return;
1261                                                  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>};
1262                                          },                                          },
1263                                          time => '<span class="time">%s</span> ',                                          time => '<span class="time">%s</span> ',
1264                                          time_channel => '<span class="channel">%s %s</span> ',                                          time_channel => '<span class="channel">%s %s</span> ',
# Line 905  sub root_handler { Line 1266  sub root_handler {
1266                                          me_nick => '***%s&nbsp;',                                          me_nick => '***%s&nbsp;',
1267                                          message => '<span class="message">%s</span>',                                          message => '<span class="message">%s</span>',
1268                                  },                                  },
1269                                  filter => {                                  filter => $filter,
                                         message => sub {  
                                                 my $m = shift || return;  
                                                 $m =~ s/($escape_re)/$escape{$1}/gs;  
                                                 $m =~ s#($RE{URI}{HTTP})#<a href="$1">$1</a>#gs;  
                                                 $m =~ s#$tag_regex#<a href="?tag=$1" class="tag">$1</a>#g;  
                                                 return $m;  
                                         },  
                                         nick => sub {  
                                                 my $n = shift || return;  
                                                 if (! $nick_enumerator{$n})  {  
                                                         my $max = scalar keys %nick_enumerator;  
                                                         $nick_enumerator{$n} = $max + 1;  
                                                 }  
                                                 return '<span class="nick col-' .  
                                                         ( $nick_enumerator{$n} % $max_color ) .  
                                                         '">' . $n . '</span>';  
                                         },  
                                 },  
1270                          )                          )
1271                  );                  );
1272          }          }
# Line 934  sub root_handler { Line 1277  sub root_handler {
1277          </body></html>};          </body></html>};
1278    
1279          $response->content( $html );          $response->content( $html );
1280            warn "<< ", $request->method, " ", $request->uri, " created ", length($html), " bytes\n";
1281          return RC_OK;          return RC_OK;
1282  }  }
1283    
Legend:
Removed from v.50  
changed lines
  Added in v.102
  ViewVC Help
Powered by ViewVC 1.1.26