/[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 100 by dpavlin, Sat Mar 8 00:14:41 2008 UTC
# Line 20  Import log from C<dircproxy> to C<irc-lo Line 20  Import log from C<dircproxy> to C<irc-lo
20    
21  =item --log=irc-logger.log  =item --log=irc-logger.log
22    
 Name of log file  
   
23  =back  =back
24    
25  =head1 DESCRIPTION  =head1 DESCRIPTION
# Line 32  log all conversation on irc channel Line 30  log all conversation on irc channel
30    
31  ## CONFIG  ## CONFIG
32    
33  my $HOSTNAME = `hostname`;  my $HOSTNAME = `hostname -f`;
34    chomp($HOSTNAME);
35    
36  my $NICK = 'irc-logger';  my $NICK = 'irc-logger';
37  $NICK .= '-dev' if ($HOSTNAME =~ m/llin/);  $NICK .= '-dev' if ($HOSTNAME =~ m/llin/);
# Line 45  my $CHANNEL = '#razmjenavjestina'; Line 44  my $CHANNEL = '#razmjenavjestina';
44  $CHANNEL = '#irc-logger' if ($HOSTNAME =~ m/llin/);  $CHANNEL = '#irc-logger' if ($HOSTNAME =~ m/llin/);
45  my $IRC_ALIAS = "log";  my $IRC_ALIAS = "log";
46    
 my %FOLLOWS =  
   (  
    ACCESS => "/var/log/apache/access.log",  
    ERROR => "/var/log/apache/error.log",  
   );  
   
47  my $DSN = 'DBI:Pg:dbname=' . $NICK;  my $DSN = 'DBI:Pg:dbname=' . $NICK;
48    
 my $ENCODING = 'ISO-8859-2';  
49  my $TIMESTAMP = '%Y-%m-%d %H:%M:%S';  my $TIMESTAMP = '%Y-%m-%d %H:%M:%S';
50    
51  my $sleep_on_error = 5;  my $sleep_on_error = 5;
52    
53  ## END CONFIG  # number of last tags to keep in circular buffer
54    my $last_x_tags = 50;
55    
56    # don't pull rss feeds more often than this
57    my $rss_min_delay = 60;
58    
59    my $http_port = $NICK =~ m/-dev/ ? 8001 : 8000;
60    
61    my $url = "http://$HOSTNAME:$http_port";
62    
63  use POE qw(Component::IRC Wheel::FollowTail Component::Server::HTTP);  ## END CONFIG
64    
65    use POE qw(Component::IRC Component::Server::HTTP);
66  use HTTP::Status;  use HTTP::Status;
67  use DBI;  use DBI;
 use Encode qw/from_to is_utf8/;  
68  use Regexp::Common qw /URI/;  use Regexp::Common qw /URI/;
69  use CGI::Simple;  use CGI::Simple;
70  use HTML::TagCloud;  use HTML::TagCloud;
# Line 73  use POSIX qw/strftime/; Line 72  use POSIX qw/strftime/;
72  use HTML::CalendarMonthSimple;  use HTML::CalendarMonthSimple;
73  use Getopt::Long;  use Getopt::Long;
74  use DateTime;  use DateTime;
75    use URI::Escape;
76  use Data::Dump qw/dump/;  use Data::Dump qw/dump/;
77    use DateTime::Format::ISO8601;
78    use Carp qw/confess/;
79    use XML::Feed;
80    use DateTime::Format::Flexible;
81    
82    my $use_twitter = 1;
83    eval { require Net::Twitter; };
84    $use_twitter = 0 if ($@);
85    
86  my $import_dircproxy;  my $import_dircproxy;
87  my $log_path;  my $log_path;
# Line 82  GetOptions( Line 90  GetOptions(
90          'log:s' => \$log_path,          'log:s' => \$log_path,
91  );  );
92    
93    #$SIG{__DIE__} = sub {
94    #       confess "fatal error";
95    #};
96    
97  open(STDOUT, '>', $log_path) || warn "can't redirect log to $log_path: $!";  open(STDOUT, '>', $log_path) || warn "can't redirect log to $log_path: $!";
98    
99  sub _log {  sub _log {
100          print strftime($TIMESTAMP,localtime()), ' ', join(" ",@_), $/;          print strftime($TIMESTAMP,localtime()) . ' ' . join(" ",@_) . $/;
101  }  }
102    
103    # HTML formatters
104    
105    my %escape = ('<'=>'&lt;', '>'=>'&gt;', '&'=>'&amp;', '"'=>'&quot;');
106    my $escape_re  = join '|' => keys %escape;
107    
108    my $tag_regex = '\b([\w-_]+)//';
109    
110    my %nick_enumerator;
111    my $max_color = 0;
112    
113    my $filter = {
114            message => sub {
115                    my $m = shift || return;
116    
117                    # protect HTML from wiki modifications
118                    sub e {
119                            my $t = shift;
120                            return 'uri_unescape{' . uri_escape($t, '^a-zA-Z0-9') . '}';
121                    }
122    
123                    $m =~ s/($escape_re)/$escape{$1}/gs;
124                    $m =~ s#($RE{URI}{HTTP})#e(qq{<a href="$1">$1</a>})#egs;
125                    $m =~ s#\/(\w+)\/#<i>$1</i>#gs;
126                    $m =~ s#$tag_regex#e(qq{<a href="$url?tag=$1" class="tag">$1</a>})#egs;
127                    $m =~ s#\*(\w+)\*#<b>$1</b>#gs;
128                    $m =~ s#_(\w+)_#<u>$1</u>#gs;
129    
130                    $m =~ s#uri_unescape{([^}]+)}#uri_unescape($1)#egs;
131                    return $m;
132            },
133            nick => sub {
134                    my $n = shift || return;
135                    if (! $nick_enumerator{$n})  {
136                            my $max = scalar keys %nick_enumerator;
137                            $nick_enumerator{$n} = $max + 1;
138                    }
139                    return '<span class="nick col-' .
140                            ( $nick_enumerator{$n} % $max_color ) .
141                            '">' . $n . '</span>';
142            },
143    };
144    
145  my $dbh = DBI->connect($DSN,"","", { RaiseError => 1, AutoCommit => 1 }) || die $DBI::errstr;  my $dbh = DBI->connect($DSN,"","", { RaiseError => 1, AutoCommit => 1 }) || die $DBI::errstr;
146    $dbh->do( qq{ set client_encoding = 'UTF-8' } );
147    
148  my $sql_schema = {  my $sql_schema = {
149          log => '          log => qq{
150  create table log (  create table log (
151          id serial,          id serial,
152          time timestamp default now(),          time timestamp default now(),
# Line 105  create table log ( Line 160  create table log (
160  create index log_time on log(time);  create index log_time on log(time);
161  create index log_channel on log(channel);  create index log_channel on log(channel);
162  create index log_nick on log(nick);  create index log_nick on log(nick);
163          ',          },
164          meta => '          meta => q{
165  create table meta (  create table meta (
166          nick text not null,          nick text not null,
167          channel text not null,          channel text not null,
168          name text not null,          name text not null,
169          value text,          value text,
170          changed timestamp default now(),          changed timestamp default 'now()',
171          primary key(nick,channel,name)          primary key(nick,channel,name)
172  );  );
173          ',          },
174            feeds => qq{
175    create table feeds (
176            id serial,
177            url text not null,
178            name text,
179            delay interval not null default '5 min',
180            active boolean default true,
181            channel text not null,
182            nick text not null,
183            private boolean default false,
184            last_update timestamp default 'now()',
185            polls int default 0,
186            updates int default 0
187    );
188    create unique index feeds_url on feeds(url);
189    insert into feeds (url,name,channel,nick) values ('http://wiki.razmjenavjestina.org/feed/workspace/razmjenavjestina?category=Recent%20Changes','wiki','$CHANNEL','dpavlin');
190            },
191  };  };
192    
193  foreach my $table ( keys %$sql_schema ) {  foreach my $table ( keys %$sql_schema ) {
# Line 158  sub meta { Line 230  sub meta {
230                  if ( $@ || ! $sth->rows ) {                  if ( $@ || ! $sth->rows ) {
231                          $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()) });
232                          $sth->execute( $value, $nick, $channel, $name );                          $sth->execute( $value, $nick, $channel, $name );
233                          _log "created $nick/$channel/$name = $value";                          warn "## created $nick/$channel/$name = $value\n";
234                  } else {                  } else {
235                          _log "updated $nick/$channel/$name = $value ";                          warn "## updated $nick/$channel/$name = $value\n";
236                  }                  }
237    
238                  return $value;                  return $value;
# Line 170  sub meta { Line 242  sub meta {
242                  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 = ? });
243                  $sth->execute( $nick, $channel, $name );                  $sth->execute( $nick, $channel, $name );
244                  my ($v,$c) = $sth->fetchrow_array;                  my ($v,$c) = $sth->fetchrow_array;
245                  _log "fetched $nick/$channel/$name = $v [$c]";                  warn "## fetched $nick/$channel/$name = $v [$c]\n";
246                  return ($v,$c) if wantarray;                  return ($v,$c) if wantarray;
247                  return $v;                  return $v;
248    
# Line 179  sub meta { Line 251  sub meta {
251    
252    
253    
254  my $sth = $dbh->prepare(qq{  my $sth_insert_log = $dbh->prepare(qq{
255  insert into log  insert into log
256          (channel, me, nick, message, time)          (channel, me, nick, message, time)
257  values (?,?,?,?,?)  values (?,?,?,?,?)
# Line 187  values (?,?,?,?,?) Line 259  values (?,?,?,?,?)
259    
260    
261  my $tags;  my $tags;
 my $tag_regex = '\b([\w-_]+)//';  
262    
263  =head2 get_from_log  =head2 get_from_log
264    
# Line 224  C<me>, C<nick> and C<message> keys. Line 295  C<me>, C<nick> and C<message> keys.
295  sub get_from_log {  sub get_from_log {
296          my $args = {@_};          my $args = {@_};
297    
298          $args->{fmt} ||= {          if ( ! $args->{fmt} ) {
299                  date => '[%s] ',                  $args->{fmt} = {
300                  time => '{%s} ',                          date => '[%s] ',
301                  time_channel => '{%s %s} ',                          time => '{%s} ',
302                  nick => '%s: ',                          time_channel => '{%s %s} ',
303                  me_nick => '***%s ',                          nick => '%s: ',
304                  message => '%s',                          me_nick => '***%s ',
305          };                          message => '%s',
306                    };
307            }
308    
309          my $sql_message = qq{          my $sql_message = qq{
310                  select                  select
# Line 254  sub get_from_log { Line 327  sub get_from_log {
327    
328          my $sql = $context ? $sql_context : $sql_message;          my $sql = $context ? $sql_context : $sql_message;
329    
330          $sql .= " where message ilike ? or nick ilike ? " if ($args->{search});          sub check_date {
331          $sql .= " where id in (" . join(",", @{ $tags->{ $args->{tag} } }) . ") " if ($args->{tag} && $tags->{ $args->{tag} });                  my $date = shift || return;
332          $sql .= " where date(time) = ? " if ($args->{date});                  my $new_date = eval { DateTime::Format::ISO8601->parse_datetime( $date )->ymd; };
333          $sql .= " order by log.time desc";                  if ( $@ ) {
334          $sql .= " limit " . $args->{limit} if ($args->{limit});                          warn "invalid date $date\n";
335                            $new_date = DateTime->now->ymd;
336                    }
337                    return $new_date;
338            }
339    
340            my @where;
341            my @args;
342            my $msg;
343    
         my $sth = $dbh->prepare( $sql );  
344          if (my $search = $args->{search}) {          if (my $search = $args->{search}) {
345                  $search =~ s/^\s+//;                  $search =~ s/^\s+//;
346                  $search =~ s/\s+$//;                  $search =~ s/\s+$//;
347                  $sth->execute( ( '%' . $search . '%' ) x 2 );                  push @where, 'message ilike ? or nick ilike ?';
348                  _log "search for '$search' returned ", $sth->rows, " results ", $context || '';                  push @args, ( ( '%' . $search . '%' ) x 2 );
349          } 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();  
350          }          }
351    
352            if ($args->{tag} && $tags->{ $args->{tag} }) {
353                    push @where, 'id in (' . join(',', @{ $tags->{ $args->{tag} } }) . ')';
354                    $msg = "Search for tags $args->{tag}";
355            }
356    
357            if (my $date = $args->{date} ) {
358                    $date = check_date( $date );
359                    push @where, 'date(time) = ?';
360                    push @args, $date;
361                    $msg = "search for date $date";
362            }
363    
364            $sql .= " where " . join(" and ", @where) if @where;
365    
366            $sql .= " order by log.time desc";
367            $sql .= " limit " . $args->{limit} if ($args->{limit});
368    
369            #warn "### sql: $sql ", dump( @args );
370    
371            my $sth = $dbh->prepare( $sql );
372            eval { $sth->execute( @args ) };
373            return if $@;
374    
375            my $nr_results = $sth->rows;
376    
377          my $last_row = {          my $last_row = {
378                  date => '',                  date => '',
379                  time => '',                  time => '',
# Line 295  sub get_from_log { Line 394  sub get_from_log {
394    
395          return @rows if ($args->{full_rows});          return @rows if ($args->{full_rows});
396    
397          my @msgs = (          $msg .= ' produced ' . (
398                  "Showing " . ($#rows + 1) . " messages..."                  $nr_results == 0 ? 'no results' :
399                    $nr_results == 0 ? 'one result' :
400                            $nr_results . ' results'
401          );          );
402    
403            my @msgs = ( $msg );
404    
405          if ($context) {          if ($context) {
406                  my @ids = @rows;                  my @ids = @rows;
407                  @rows = ();                  @rows = ();
# Line 395  my $cloud = HTML::TagCloud->new; Line 498  my $cloud = HTML::TagCloud->new;
498    
499  =head2 add_tag  =head2 add_tag
500    
501   add_tag( id => 42, message => 'irc message' );   add_tag( id => 42, message => 'irc message', nick => 'foobar' [, me => 1 ] );
502    
503  =cut  =cut
504    
505    my @last_tags;
506    
507  sub add_tag {  sub add_tag {
508          my $arg = {@_};          my $arg = {@_};
509    
510          return unless ($arg->{id} && $arg->{message});          return unless ($arg->{id} && $arg->{message});
511    
512          my $m = $arg->{message};          my $m = $arg->{message};
513          from_to('UTF-8', 'iso-8859-2', $m) if (is_utf8($m));  
514            my @tags;
515    
516          while ($m =~ s#$tag_regex##s) {          while ($m =~ s#$tag_regex##s) {
517                  my $tag = $1;                  my $tag = $1;
518                  next if (! $tag || $tag =~ m/https?:/i);                  next if (! $tag || $tag =~ m/https?:/i);
519                  push @{ $tags->{$tag} }, $arg->{id};                  push @{ $tags->{$tag} }, $arg->{id};
520                  #warn "+tag $tag: $arg->{id}\n";                  #warn "+tag $tag: $arg->{id}\n";
521                  $cloud->add($tag, "?tag=$tag", scalar @{$tags->{$tag}} + 1);                  $cloud->add($tag, "$url?tag=$tag", scalar @{$tags->{$tag}} + 1);
522                    push @tags, $tag;
523    
524          }          }
525    
526            if ( @tags ) {
527                    pop @last_tags if $#last_tags == $last_x_tags;
528                    unshift @last_tags, { tags => [ @tags ], %$arg };
529            }
530    
531  }  }
532    
533  =head2 seed_tags  =head2 seed_tags
# Line 423  Read all tags from database and create i Line 537  Read all tags from database and create i
537  =cut  =cut
538    
539  sub seed_tags {  sub seed_tags {
540          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 });
541          $sth->execute;          $sth->execute;
542          while (my $row = $sth->fetchrow_hashref) {          while (my $row = $sth->fetchrow_hashref) {
543                  add_tag( %$row );                  add_tag( %$row );
544          }          }
545    
546          foreach my $tag (keys %$tags) {          foreach my $tag (keys %$tags) {
547                  $cloud->add($tag, "?tag=$tag", scalar @{$tags->{$tag}} + 1);                  $cloud->add($tag, "$url?tag=$tag", scalar @{$tags->{$tag}} + 1);
548          }          }
549  }  }
550    
# Line 443  seed_tags; Line 557  seed_tags;
557          channel => '#foobar',          channel => '#foobar',
558          me => 0,          me => 0,
559          nick => 'dpavlin',          nick => 'dpavlin',
560          msg => 'test message',          message => 'test message',
561          time => '2006-06-25 18:57:18',          time => '2006-06-25 18:57:18',
562    );    );
563    
# Line 455  C<me> if not specified will be C<0> (not Line 569  C<me> if not specified will be C<0> (not
569    
570  sub save_message {  sub save_message {
571          my $a = {@_};          my $a = {@_};
572            confess "have msg" if $a->{msg};
573          $a->{me} ||= 0;          $a->{me} ||= 0;
574          $a->{time} ||= strftime($TIMESTAMP,localtime());          $a->{time} ||= strftime($TIMESTAMP,localtime());
575    
576          _log          _log
577                  $a->{channel}, " ",                  $a->{channel}, " ",
578                  $a->{me} ? "***" . $a->{nick} : "<" . $a->{nick} . ">",                  $a->{me} ? "***" . $a->{nick} : "<" . $a->{nick} . ">",
579                  " " . $a->{msg};                  " " . $a->{message};
580    
581          from_to($a->{msg}, 'UTF-8', $ENCODING);          $sth_insert_log->execute($a->{channel}, $a->{me}, $a->{nick}, $a->{message}, $a->{time});
582            add_tag( id => $dbh->last_insert_id(undef,undef,"log",undef), %$a );
         $sth->execute($a->{channel}, $a->{me}, $a->{nick}, $a->{msg}, $a->{time});  
         add_tag( id => $dbh->last_insert_id(undef,undef,"log",undef),  
                 message => $a->{msg});  
583  }  }
584    
585    
586  if ($import_dircproxy) {  if ($import_dircproxy) {
587          open(my $l, $import_dircproxy) || die "can't open $import_dircproxy: $!";          open(my $l, $import_dircproxy) || die "can't open $import_dircproxy: $!";
588          warn "importing $import_dircproxy...\n";          warn "importing $import_dircproxy...\n";
589          my $tz_offset = 2 * 60 * 60;    # TZ GMT+2          my $tz_offset = 1 * 60 * 60;    # TZ GMT+2
590          while(<$l>) {          while(<$l>) {
591                  chomp;                  chomp;
592                  if (/^@(\d+)\s(\S+)\s(.+)$/) {                  if (/^@(\d+)\s(\S+)\s(.+)$/) {
# Line 492  if ($import_dircproxy) { Line 604  if ($import_dircproxy) {
604                                  channel => $CHANNEL,                                  channel => $CHANNEL,
605                                  me => $me,                                  me => $me,
606                                  nick => $nick,                                  nick => $nick,
607                                  msg => $msg,                                  message => $msg,
608                                  time => $dt->ymd . " " . $dt->hms,                                  time => $dt->ymd . " " . $dt->hms,
609                          ) if ($nick !~ m/^-/);                          ) if ($nick !~ m/^-/);
610    
# Line 505  if ($import_dircproxy) { Line 617  if ($import_dircproxy) {
617          exit;          exit;
618  }  }
619    
620    #
621    # RSS follow
622    #
623    
624    my $_rss;
625    
626    
627    sub rss_fetch {
628            my ($args) = @_;
629    
630            # how many messages to send out when feed is seen for the first time?
631            my $send_rss_msgs = 1;
632    
633            _log "RSS fetch", $args->{url};
634    
635            my $feed = XML::Feed->parse(URI->new( $args->{url} ));
636            if ( ! $feed ) {
637                    _log("can't fetch RSS ", $args->{url});
638                    return;
639            }
640    
641            my ( $total, $updates ) = ( 0, 0 );
642            for my $entry ($feed->entries) {
643                    $total++;
644    
645                    # seen allready?
646                    next if $_rss->{$args->{channel}}->{$feed->link}->{$entry->id}++ > 0;
647    
648                    sub prefix {
649                            my ($txt,$var) = @_;
650                            $var =~ s/\s+/ /gs;
651                            $var =~ s/^\s+//g;
652                            $var =~ s/\s+$//g;
653                            return $txt . $var if $var;
654                    }
655    
656                    # fix absolute and relative links to feed entries
657                    my $link = $entry->link;
658                    if ( $link =~ m!^/! ) {
659                            my $host = $args->{url};
660                            $host =~ s!^(http://[^/]+).*$!$1!;      #!vim
661                            $link = "$host/$link";
662                    } elsif ( $link !~ m!^http! ) {
663                            $link = $args->{url} . $link;
664                    }
665    
666                    my $msg;
667                    $msg .= prefix( 'From: ' , $args->{name} || $feed->title );
668                    $msg .= prefix( ' by ' , $entry->author );
669                    $msg .= prefix( ' | ' , $entry->title );
670                    $msg .= prefix( ' | ' , $link );
671    #               $msg .= prefix( ' id ' , $entry->id );
672    
673                    if ( $args->{kernel} && $send_rss_msgs ) {
674                            $send_rss_msgs--;
675                            $sth_insert_log->execute( $args->{channel}, 1, $NICK, $msg, 'now()' );
676                            my ( $type, $to ) = ( 'notice', $args->{channel} );
677                            ( $type, $to ) = ( 'privmsg', $args->{nick} ) if $args->{private};
678                            _log(">> $type $to |", $msg);
679                            $args->{kernel}->post( $IRC_ALIAS => $type => $to, $msg );
680                            $updates++;
681                    }
682            }
683    
684            my $sql = qq{ update feeds set last_update = now(), polls = polls + 1 };
685            $sql .= qq{, updates = updates + $updates } if $updates;
686            $sql .= qq{where id = } . $args->{id};
687            eval { $dbh->do( $sql ) };
688    
689            _log "RSS got $total items of which $updates new";
690    
691            return $updates;
692    }
693    
694    sub rss_fetch_all {
695            my $kernel = shift;
696            my $sql = qq{
697                    select id, url, name, channel, nick, private
698                    from feeds
699                    where active is true
700            };
701            # limit to newer feeds only if we are not sending messages out
702            $sql .= qq{     and last_update + delay < now() } if $kernel;
703            my $sth = $dbh->prepare( $sql );
704            $sth->execute();
705            warn "# ",$sth->rows," active RSS feeds\n";
706            my $count = 0;
707            while (my $row = $sth->fetchrow_hashref) {
708                    $row->{kernel} = $kernel if $kernel;
709                    $count += rss_fetch( $row );
710            }
711            return "OK, fetched $count posts from " . $sth->rows . " feeds";
712    }
713    
714    
715    sub rss_check_updates {
716            my $kernel = shift;
717            $_rss->{last_poll} ||= time();
718            my $dt = time() - $_rss->{last_poll};
719            warn "## rss_check_updates $dt > $rss_min_delay\n";
720            if ( $dt > $rss_min_delay ) {
721                    $_rss->{last_poll} = time();
722                    _log rss_fetch_all( $kernel );
723            }
724    }
725    
726    # seed rss seen cache so we won't send out all items on startup
727    _log rss_fetch_all;
728    
729  #  #
730  # POE handing part  # POE handing part
731  #  #
732    
 my $SKIPPING = 0;               # if skipping, how many we've done  
 my $SEND_QUEUE;                 # cache  
733  my $ping;                                               # ping stats  my $ping;                                               # ping stats
734    
735  POE::Component::IRC->new($IRC_ALIAS);  POE::Component::IRC->new($IRC_ALIAS);
736    
737  POE::Session->create( inline_states =>  POE::Session->create( inline_states => {
738     {_start => sub {                _start => sub {      
739                  $_[KERNEL]->post($IRC_ALIAS => register => 'all');                  $_[KERNEL]->post($IRC_ALIAS => register => 'all');
740                  $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);                  $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);
741      },      },
742      irc_255 => sub {    # server is done blabbing      irc_255 => sub {    # server is done blabbing
743                  $_[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;  
744                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );
745      },      },
746      irc_public => sub {      irc_public => sub {
# Line 534  POE::Session->create( inline_states => Line 749  POE::Session->create( inline_states =>
749                  my $channel = $_[ARG1]->[0];                  my $channel = $_[ARG1]->[0];
750                  my $msg = $_[ARG2];                  my $msg = $_[ARG2];
751    
752                  save_message( channel => $channel, me => 0, nick => $nick, msg => $msg);                  save_message( channel => $channel, me => 0, nick => $nick, message => $msg);
753                  meta( $nick, $channel, 'last-msg', $msg );                  meta( $nick, $channel, 'last-msg', $msg );
754                    rss_check_updates( $kernel );
755      },      },
756      irc_ctcp_action => sub {      irc_ctcp_action => sub {
757                  my $kernel = $_[KERNEL];                  my $kernel = $_[KERNEL];
# Line 543  POE::Session->create( inline_states => Line 759  POE::Session->create( inline_states =>
759                  my $channel = $_[ARG1]->[0];                  my $channel = $_[ARG1]->[0];
760                  my $msg = $_[ARG2];                  my $msg = $_[ARG2];
761    
762                  save_message( channel => $channel, me => 1, nick => $nick, msg => $msg);                  save_message( channel => $channel, me => 1, nick => $nick, message => $msg);
763    
764                  if ( my $twitter = ( $nick, $channel, 'twitter' ) ) {                  if ( $use_twitter ) {
765                          _log("FIXME: send twitter for $nick on $channel [$twitter]");                          if ( my $twitter = meta( $nick, $NICK, 'twitter' ) ) {
766                                    my ($login,$passwd) = split(/\s+/,$twitter,2);
767                                    _log("sending twitter for $nick/$login on $channel ");
768                                    my $bot = Net::Twitter->new( username=>$login, password=>$passwd );
769                                    $bot->update("<${channel}> $msg");
770                            }
771                  }                  }
772    
773      },      },
774          irc_ping => sub {          irc_ping => sub {
775                  warn "pong ", $_[ARG0], $/;                  _log( "pong ", $_[ARG0] );
776                  $ping->{ $_[ARG0] }++;                  $ping->{ $_[ARG0] }++;
777                    rss_check_updates( $_[KERNEL] );
778          },          },
779          irc_invite => sub {          irc_invite => sub {
780                  my $kernel = $_[KERNEL];                  my $kernel = $_[KERNEL];
781                  my $nick = (split /!/, $_[ARG0])[0];                  my $nick = (split /!/, $_[ARG0])[0];
782                  my $channel = $_[ARG1];                  my $channel = $_[ARG1];
783    
784                  warn "invited to $channel by $nick";                  _log "invited to $channel by $nick";
785    
786                  $_[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..." );
787                  $_[KERNEL]->post($IRC_ALIAS => join => $channel);                  $_[KERNEL]->post($IRC_ALIAS => join => $channel);
# Line 570  POE::Session->create( inline_states => Line 792  POE::Session->create( inline_states =>
792                  my $nick = (split /!/, $_[ARG0])[0];                  my $nick = (split /!/, $_[ARG0])[0];
793                  my $msg = $_[ARG2];                  my $msg = $_[ARG2];
794                  my $channel = $_[ARG1]->[0];                  my $channel = $_[ARG1]->[0];
                 from_to($msg, 'UTF-8', $ENCODING);  
795    
796                  my $res = "unknown command '$msg', try /msg $NICK help!";                  my $res = "unknown command '$msg', try /msg $NICK help!";
797                  my @out;                  my @out;
# Line 593  POE::Session->create( inline_states => Line 814  POE::Session->create( inline_states =>
814    
815                          my $sth = $dbh->prepare(qq{                          my $sth = $dbh->prepare(qq{
816                                  select                                  select
817                                          nick,                                          trim(both '_' from nick) as nick,
818                                          count(*) as count,                                          count(*) as count,
819                                          sum(length(message)) as len                                          sum(length(message)) as len
820                                  from log                                  from log
821                                  group by nick                                  group by trim(both '_' from nick)
822                                  order by len desc,count desc                                  order by len desc,count desc
823                                  limit $nr                                  limit $nr
824                          });                          });
# Line 614  POE::Session->create( inline_states => Line 835  POE::Session->create( inline_states =>
835    
836                          foreach my $res (get_from_log( limit => $limit )) {                          foreach my $res (get_from_log( limit => $limit )) {
837                                  _log "last: $res";                                  _log "last: $res";
                                 from_to($res, $ENCODING, 'UTF-8');  
838                                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );                                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );
839                          }                          }
840    
# Line 629  POE::Session->create( inline_states => Line 849  POE::Session->create( inline_states =>
849                                          search => $what,                                          search => $what,
850                                  )) {                                  )) {
851                                  _log "search [$what]: $res";                                  _log "search [$what]: $res";
                                 from_to($res, $ENCODING, 'UTF-8');  
852                                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );                                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );
853                          }                          }
854    
# Line 669  POE::Session->create( inline_states => Line 888  POE::Session->create( inline_states =>
888    
889                  } elsif ($msg =~ m/^ping/) {                  } elsif ($msg =~ m/^ping/) {
890                          $res = "ping = " . dump( $ping );                          $res = "ping = " . dump( $ping );
891                  } 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*)/) {  
892                          if ( ! defined( $1 ) ) {                          if ( ! defined( $1 ) ) {
893                                  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 = ? });
894                                  $sth->execute( $nick, $channel );                                  $sth->execute( $nick, $channel );
895                                  $res = "config for $nick ";                                  $res = "config for $nick on $channel";
896                                  while ( my ($n,$v) = $sth->fetchrow_array ) {                                  while ( my ($n,$v) = $sth->fetchrow_array ) {
897                                          $res .= "| $n = $v";                                          $res .= " | $n = $v";
898                                  }                                  }
899                          } elsif ( defined( $2 ) ) {                          } elsif ( ! $2 ) {
                                 meta( $nick, $channel, $1, $2 );  
                                 $res = "saved $1 = $2";  
                         } else {  
900                                  my $val = meta( $nick, $channel, $1 );                                  my $val = meta( $nick, $channel, $1 );
901                                  $res = "current $1 = " . ( $val ? $val : 'undefined' );                                  $res = "current $1 = " . ( $val ? $val : 'undefined' );
902                            } else {
903                                    my $validate = {
904                                            'last-size' => qr/^\d+/,
905                                            'twitter' => qr/^\w+\s+\w+/,
906                                    };
907    
908                                    my ( $op, $val ) = ( $1, $2 );
909    
910                                    if ( my $regex = $validate->{$op} ) {
911                                            if ( $val =~ $regex ) {
912                                                    meta( $nick, $channel, $op, $val );
913                                                    $res = "saved $op = $val";
914                                            } else {
915                                                    $res = "config option $op = $val doesn't validate against $regex";
916                                            }
917                                    } else {
918                                            $res = "config option $op doesn't exist";
919                                    }
920                            }
921                    } elsif ($msg =~ m/^rss-update/) {
922                            $res = rss_fetch_all( $_[KERNEL] );
923                    } elsif ($msg =~ m/^rss-clean/) {
924                            $_rss = undef;
925                            $dbh->do( qq{ update feeds set last_update = now() - delay } );
926                            $res = "OK, cleaned RSS cache";
927                    } elsif ($msg =~ m/^rss-list/) {
928                            my $sth = $dbh->prepare(qq{ select url,name,last_update,active,channel,nick,private from feeds });
929                            $sth->execute;
930                            while (my @row = $sth->fetchrow_array) {
931                                    $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, join(' | ',@row) );
932                            }
933                            $res = '';
934                    } elsif ($msg =~ m!^rss-(add|remove|stop|start)(?:-(private))?\s+(http://\S+)\s*(.*)!) {
935                            my ( $command, $sub, $url, $arg ) = ( $1,$2,$3,$4 );
936    
937                            my $channel = $1 if ( $arg =~ s/\s*(#\S+)\s*// );
938                            $channel = $nick if $sub eq 'private';
939    
940                            my $sql = {
941                                    add             => qq{ insert into feeds (url,name,channel,nick,private) values (?,?,?,?,?) },
942    #                               remove  => qq{ delete from feeds                                where url = ? and name = ? },
943                                    start   => qq{ update feeds set active = true   where url = ? },
944                                    stop    => qq{ update feeds set active = false  where url = ? },
945                            };
946    
947                            if ( $command eq 'add' && ! $channel ) {
948                                    $res = "ERROR: got '$msg' which doesn't have #channel in it, ignoring!";
949                            } elsif (my $q = $sql->{$command} ) {
950                                    my $sth = $dbh->prepare( $q );
951                                    my @data = ( $url );
952                                    if ( $command eq 'add' ) {
953                                            push @data, ( $arg, $channel, $nick, $sub eq 'private' ? 1 : 0 );
954                                    }
955                                    warn "## $command SQL $q with ",dump( @data ),"\n";
956                                    eval { $sth->execute( @data ) };
957                                    if ($@) {
958                                            $res = "ERROR: $@";
959                                    } else {
960                                            $res = "OK, RSS [$command|$sub|$url|$arg]";
961                                    }
962                            } else {
963                                    $res = "ERROR: don't know what to do with: $msg";
964                          }                          }
965                  }                  }
966    
967                  if ($res) {                  if ($res) {
968                          _log ">> [$nick] $res";                          _log ">> [$nick] $res";
                         from_to($res, $ENCODING, 'UTF-8');  
969                          $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );                          $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );
970                  }                  }
971    
972                    rss_check_updates( $_[KERNEL] );
973          },          },
974          irc_477 => sub {          irc_477 => sub {
975                  _log "# irc_477: ",$_[ARG1];                  _log "# irc_477: ",$_[ARG1];
# Line 738  POE::Session->create( inline_states => Line 1008  POE::Session->create( inline_states =>
1008                          "";                          "";
1009        0;                        # false for signals        0;                        # false for signals
1010      },      },
     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);  
     }  
1011     },     },
1012    );    );
1013    
1014  # http server  # http server
1015    
1016  my $httpd = POE::Component::Server::HTTP->new(  my $httpd = POE::Component::Server::HTTP->new(
1017          Port => $NICK =~ m/-dev/ ? 8001 : 8000,          Port => $http_port,
1018            PreHandler => {
1019                    '/' => sub {
1020                            $_[0]->header(Connection => 'close')
1021                    }
1022            },
1023          ContentHandler => { '/' => \&root_handler },          ContentHandler => { '/' => \&root_handler },
1024          Headers        => { Server => 'irc-logger' },          Headers        => { Server => 'irc-logger' },
1025  );  );
1026    
 my %escape = ('<'=>'&lt;', '>'=>'&gt;', '&'=>'&amp;', '"'=>'&quot;');  
 my $escape_re  = join '|' => keys %escape;  
   
1027  my $style = <<'_END_OF_STYLE_';  my $style = <<'_END_OF_STYLE_';
1028  p { margin: 0; padding: 0.1em; }  p { margin: 0; padding: 0.1em; }
1029  .time, .channel { color: #808080; font-size: 60%; }  .time, .channel { color: #808080; font-size: 60%; }
# Line 819  p { margin: 0; padding: 0.1em; } Line 1031  p { margin: 0; padding: 0.1em; }
1031  .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 ; }
1032  .message { color: #000000; font-size: 100%; }  .message { color: #000000; font-size: 100%; }
1033  .search { float: right; }  .search { float: right; }
1034    a:link.tag, a:visited.tag { border: 1px dashed #ccc; backgound: #ccc; text-decoration: none }
1035    a:hover.tag { border: 1px solid #eee }
1036    hr { border: 1px dashed #ccc; height: 1px; clear: both; }
1037    /*
1038  .col-0 { background: #ffff66 }  .col-0 { background: #ffff66 }
1039  .col-1 { background: #a0ffff }  .col-1 { background: #a0ffff }
1040  .col-2 { background: #99ff99 }  .col-2 { background: #99ff99 }
1041  .col-3 { background: #ff9999 }  .col-3 { background: #ff9999 }
1042  .col-4 { background: #ff66ff }  .col-4 { background: #ff66ff }
1043  a:link.tag, a:visited.tag { border: 1px dashed #ccc; backgound: #ccc; text-decoration: none }  */
1044  a:hover.tag { border: 1px solid #eee }  .calendar { border: 1px solid red; width: 100%; }
1045  hr { border: 1px dashed #ccc; height: 1px; clear: both; }  .month { border: 0px; width: 100%; }
1046  _END_OF_STYLE_  _END_OF_STYLE_
1047    
1048  my $max_color = 4;  $max_color = 0;
1049    
1050  my %nick_enumerator;  my @cols = qw(
1051            #ffcccc #ccffe6 #ccccff #e6ccff #ffccff #ffcce6 #ff9999 #ffcc99 #ffff99
1052            #ccff99 #99ff99 #99ffcc #99ccff #9999ff #cc99ff #ff6666 #ffb366 #ffff66
1053            #66ff66 #66ffb3 #66b3ff #6666ff #ff3333 #33ff33 #3399ff #3333ff #ff3399
1054            #a0a0a0 #ff0000 #ffff00 #80ff00 #0000ff #8000ff #ff00ff #ff0080 #994d00
1055            #999900 #009900 #cc0066 #c0c0c0 #ccff99 #99ff33 #808080 #660033 #ffffff
1056    );
1057    
1058    foreach my $c (@cols) {
1059            $style .= ".col-${max_color} { background: $c }\n";
1060            $max_color++;
1061    }
1062    warn "defined $max_color colors for users...\n";
1063    
1064  sub root_handler {  sub root_handler {
1065          my ($request, $response) = @_;          my ($request, $response) = @_;
1066          $response->code(RC_OK);          $response->code(RC_OK);
1067          $response->content_type("text/html; charset=$ENCODING");  
1068            # this doesn't seem to work, so moved to PreHandler
1069            #$response->header(Connection => 'close');
1070    
1071            return RC_OK if $request->uri =~ m/favicon.ico$/;
1072    
1073          my $q;          my $q;
1074    
# Line 850  sub root_handler { Line 1082  sub root_handler {
1082    
1083          my $search = $q->param('search') || $q->param('grep') || '';          my $search = $q->param('search') || $q->param('grep') || '';
1084    
1085            if ($request->url =~ m#/rss(?:/(tags|last-tag|follow.*)\w*(?:=(\d+))?)?#i) {
1086                    my $show = lc($1);
1087                    my $nr = $2;
1088    
1089                    my $type = 'RSS';       # Atom
1090    
1091                    $response->content_type( 'application/' . lc($type) . '+xml' );
1092    
1093                    my $html = '<!-- error -->';
1094                    #warn "create $type feed from ",dump( @last_tags );
1095    
1096                    my $feed = XML::Feed->new( $type );
1097                    $feed->link( $url );
1098    
1099                    if ( $show eq 'tags' ) {
1100                            $nr ||= 50;
1101                            $feed->title( "tags from $CHANNEL" );
1102                            $feed->link( "$url/tags" );
1103                            $feed->description( "tag cloud created from messages on channel $CHANNEL which have tags// in them" );
1104                            my $feed_entry = XML::Feed::Entry->new($type);
1105                            $feed_entry->title( "$nr tags from $CHANNEL" );
1106                            $feed_entry->author( $NICK );
1107                            $feed_entry->link( '/#tags'  );
1108    
1109                            $feed_entry->content(
1110                                    qq{<![CDATA[<style type="text/css">}
1111                                    . $cloud->css
1112                                    . qq{</style>}
1113                                    . $cloud->html( $nr )
1114                                    . qq{]]>}
1115                            );
1116                            $feed->add_entry( $feed_entry );
1117    
1118                    } elsif ( $show eq 'last-tag' ) {
1119    
1120                            $nr ||= $last_x_tags;
1121                            $nr = $last_x_tags if $nr > $last_x_tags;
1122    
1123                            $feed->title( "last $nr tagged messages from $CHANNEL" );
1124                            $feed->description( "collects messages which have tags// in them" );
1125    
1126                            foreach my $m ( @last_tags ) {
1127    #                               warn dump( $m );
1128                                    #my $tags = join(' ', @{$m->{tags}} );
1129                                    my $feed_entry = XML::Feed::Entry->new($type);
1130                                    $feed_entry->title( $m->{nick} . '@' . $m->{time} );
1131                                    $feed_entry->author( $m->{nick} );
1132                                    $feed_entry->link( '/#' . $m->{id}  );
1133                                    $feed_entry->issued( DateTime::Format::Flexible->build( $m->{time} ) );
1134    
1135                                    my $message = $filter->{message}->( $m->{message} );
1136                                    $message .= "<br/>\n" unless $message =~ m!<(/p|br/?)>!;
1137    #                               warn "## message = $message\n";
1138    
1139                                    #$feed_entry->summary(
1140                                    $feed_entry->content(
1141                                            "<![CDATA[$message]]>"
1142                                    );
1143                                    $feed_entry->category( join(', ', @{$m->{tags}}) );
1144                                    $feed->add_entry( $feed_entry );
1145    
1146                                    $nr--;
1147                                    last if $nr <= 0;
1148    
1149                            }
1150    
1151                    } elsif ( $show =~ m/^follow/ ) {
1152    
1153                            $feed->title( "Feeds which this bot follows" );
1154    
1155                            my $sth = $dbh->prepare( qq{ select * from feeds order by last_update desc } );
1156                            $sth->execute;
1157                            while (my $row = $sth->fetchrow_hashref) {
1158                                    my $feed_entry = XML::Feed::Entry->new($type);
1159                                    $feed_entry->title( $row->{name} );
1160                                    $feed_entry->link( $row->{url}  );
1161                                    $feed_entry->issued( DateTime::Format::Flexible->build( $row->{last_update} ) );
1162                                    $feed_entry->content(
1163                                            '<![CDATA[<pre>' . dump( $row ) . '</pre>]]>'
1164                                    );
1165                                    $feed->add_entry( $feed_entry );
1166                            }
1167    
1168                            my $feed_entry = XML::Feed::Entry->new($type);
1169                            $feed_entry->title( "Internal stats" );
1170                            $feed_entry->content(
1171                                    '<![CDATA[<pre>' . dump( $_rss ) . '</pre>]]>'
1172                            );
1173                            $feed->add_entry( $feed_entry );
1174    
1175                    } else {
1176                            _log "unknown rss request ",$request->url;
1177                            return RC_DENY;
1178                    }
1179    
1180                    $response->content( $feed->as_xml );
1181                    return RC_OK;
1182            }
1183    
1184            if ( $@ ) {
1185                    warn "$@";
1186            }
1187    
1188            $response->content_type("text/html; charset=UTF-8");
1189    
1190          my $html =          my $html =
1191                  qq{<html><head><title>$NICK</title><style type="text/css">$style} .                  qq{<html><head><title>$NICK</title><style type="text/css">$style}
1192                  $cloud->css .                  . $cloud->css
1193                  qq{</style></head><body>} .                  . qq{</style></head><body>}
1194                  qq{                  . qq{
1195                  <form method="post" class="search" action="/">                  <form method="post" class="search" action="/">
1196                  <input type="text" name="search" value="$search" size="10">                  <input type="text" name="search" value="$search" size="10">
1197                  <input type="submit" value="search">                  <input type="submit" value="search">
1198                  </form>                  </form>
1199                  } .                  }
1200                  $cloud->html(500) .                  . $cloud->html(500)
1201                  qq{<p>};                  . qq{<p>};
1202          if ($request->url =~ m#/history#) {  
1203            if ($request->url =~ m#/tags?#) {
1204                    # nop
1205            } elsif ($request->url =~ m#/history#) {
1206                  my $sth = $dbh->prepare(qq{                  my $sth = $dbh->prepare(qq{
1207                          select date(time) as date,count(*) as nr                          select date(time) as date,count(*) as nr,sum(length(message)) as len
1208                                  from log                                  from log
1209                                  group by date(time)                                  group by date(time)
1210                                  order by date(time) desc                                  order by date(time) desc
1211                  });                  });
1212                  $sth->execute();                  $sth->execute();
1213                  my ($l_yyyy,$l_mm) = (0,0);                  my ($l_yyyy,$l_mm) = (0,0);
1214                    $html .= qq{<table class="calendar"><tr>};
1215                  my $cal;                  my $cal;
1216                    my $ord = 0;
1217                  while (my $row = $sth->fetchrow_hashref) {                  while (my $row = $sth->fetchrow_hashref) {
1218                          # this is probably PostgreSQL specific, expects ISO date                          # this is probably PostgreSQL specific, expects ISO date
1219                          my ($yyyy,$mm,$dd) = split(/-/, $row->{date});                          my ($yyyy,$mm,$dd) = split(/-/, $row->{date});
1220                          if ($yyyy != $l_yyyy || $mm != $l_mm) {                          if ($yyyy != $l_yyyy || $mm != $l_mm) {
1221                                  $html .= $cal->as_HTML() if ($cal);                                  if ( $cal ) {
1222                                            $html .= qq{<td valign="top">} . $cal->as_HTML() . qq{</td>};
1223                                            $ord++;
1224                                            $html .= qq{</tr><tr>} if ( $ord % 3 == 0 );
1225                                    }
1226                                  $cal = new HTML::CalendarMonthSimple('month'=>$mm,'year'=>$yyyy);                                  $cal = new HTML::CalendarMonthSimple('month'=>$mm,'year'=>$yyyy);
1227                                  $cal->border(2);                                  $cal->border(1);
1228                                    $cal->width('30%');
1229                                    $cal->cellheight('5em');
1230                                    $cal->tableclass('month');
1231                                    #$cal->cellclass('day');
1232                                    $cal->sunday('SUN');
1233                                    $cal->saturday('SAT');
1234                                    $cal->weekdays('MON','TUE','WED','THU','FRI');
1235                                  ($l_yyyy,$l_mm) = ($yyyy,$mm);                                  ($l_yyyy,$l_mm) = ($yyyy,$mm);
1236                          }                          }
1237                          $cal->setcontent($dd, qq{                          $cal->setcontent($dd, qq[
1238                                  <a href="/?date=$row->{date}">$row->{nr}</a>                                  <a href="$url?date=$row->{date}">$row->{nr}</a><br/>$row->{len}
1239                          });                          ]) if $cal;
1240                            
1241                  }                  }
1242                  $html .= $cal->as_HTML() if ($cal);                  $html .= qq{<td valign="top">} . $cal->as_HTML() . qq{</td></tr></table>};
1243    
1244          } else {          } else {
1245                  $html .= join("</p><p>",                  $html .= join("</p><p>",
1246                          get_from_log(                          get_from_log(
1247                                  limit => $q->param('last') || $q->param('date') ? undef : 100,                                  limit => ( $q->param('last') || $q->param('date') ) ? undef : 100,
1248                                  search => $search || undef,                                  search => $search || undef,
1249                                  tag => $q->param('tag') || undef,                                  tag => $q->param('tag') || undef,
1250                                  date => $q->param('date') || undef,                                  date => $q->param('date') || undef,
1251                                  fmt => {                                  fmt => {
1252                                          date => sub {                                          date => sub {
1253                                                  my $date = shift || return;                                                  my $date = shift || return;
1254                                                  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>};
1255                                          },                                          },
1256                                          time => '<span class="time">%s</span> ',                                          time => '<span class="time">%s</span> ',
1257                                          time_channel => '<span class="channel">%s %s</span> ',                                          time_channel => '<span class="channel">%s %s</span> ',
# Line 905  sub root_handler { Line 1259  sub root_handler {
1259                                          me_nick => '***%s&nbsp;',                                          me_nick => '***%s&nbsp;',
1260                                          message => '<span class="message">%s</span>',                                          message => '<span class="message">%s</span>',
1261                                  },                                  },
1262                                  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>';  
                                         },  
                                 },  
1263                          )                          )
1264                  );                  );
1265          }          }
# Line 934  sub root_handler { Line 1270  sub root_handler {
1270          </body></html>};          </body></html>};
1271    
1272          $response->content( $html );          $response->content( $html );
1273            warn "<< ", $request->method, " ", $request->uri, " created ", length($html), " bytes\n";
1274          return RC_OK;          return RC_OK;
1275  }  }
1276    
Legend:
Removed from v.50  
changed lines
  Added in v.100
  ViewVC Help
Powered by ViewVC 1.1.26