/[irc-logger]/trunk/bin/irc-logger.pl
This is repository of my old source code which isn't updated any more. Go to git.rot13.org for current projects!
ViewVC logotype

Diff of /trunk/bin/irc-logger.pl

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

trunk/irc-logger.pl revision 36 by dpavlin, Sun Jun 25 16:37:39 2006 UTC trunk/bin/irc-logger.pl revision 100 by dpavlin, Sat Mar 8 00:14:41 2008 UTC
# Line 10  irc-logger.pl Line 10  irc-logger.pl
10    
11  ./irc-logger.pl  ./irc-logger.pl
12    
13    =head2 Options
14    
15    =over 4
16    
17    =item --import-dircproxy=filename
18    
19    Import log from C<dircproxy> to C<irc-logger> database
20    
21    =item --log=irc-logger.log
22    
23    =back
24    
25  =head1 DESCRIPTION  =head1 DESCRIPTION
26    
27  log all conversation on irc channel  log all conversation on irc channel
# Line 18  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 31  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  ## END CONFIG  my $sleep_on_error = 5;
52    
53    # 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;
71  use POSIX qw/strftime/;  use POSIX qw/strftime/;
72  use HTML::CalendarMonthSimple;  use HTML::CalendarMonthSimple;
73    use Getopt::Long;
74    use DateTime;
75    use URI::Escape;
76    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;
87    my $log_path;
88    GetOptions(
89            'import-dircproxy:s' => \$import_dircproxy,
90            'log:s' => \$log_path,
91    );
92    
93  my $dbh = DBI->connect($DSN,"","", { RaiseError => 1, AutoCommit => 1 }) || die $DBI::errstr;  #$SIG{__DIE__} = sub {
94    #       confess "fatal error";
95    #};
96    
97    open(STDOUT, '>', $log_path) || warn "can't redirect log to $log_path: $!";
98    
99  eval {  sub _log {
100          $dbh->do(qq{ select count(*) from log });          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  if ($@) {  my $dbh = DBI->connect($DSN,"","", { RaiseError => 1, AutoCommit => 1 }) || die $DBI::errstr;
146          warn "creating database table in $DSN\n";  $dbh->do( qq{ set client_encoding = 'UTF-8' } );
         $dbh->do(<<'_SQL_SCHEMA_');  
147    
148    my $sql_schema = {
149            log => qq{
150  create table log (  create table log (
151          id serial,          id serial,
152          time timestamp default now(),          time timestamp default now(),
# Line 79  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 => q{
165    create table meta (
166            nick text not null,
167            channel text not null,
168            name text not null,
169            value text,
170            changed timestamp default 'now()',
171            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 ) {
194    
195            eval {
196                    $dbh->do(qq{ select count(*) from $table });
197            };
198    
199            if ($@) {
200                    warn "creating database table $table in $DSN\n";
201                    $dbh->do( $sql_schema->{ $table } );
202            }
203    }
204    
205    
206    =head2 meta
207    
208    Set or get some meta data into database
209    
210            meta('nick','channel','var_name', $var_value );
211    
212            $var_value = meta('nick','channel','var_name');
213            ( $var_value, $changed ) = meta('nick','channel','var_name');
214    
215    =cut
216    
217    sub meta {
218            my ($nick,$channel,$name,$value) = @_;
219    
220            # normalize channel name
221            $channel =~ s/^#//;
222    
223            if (defined($value)) {
224    
225                    my $sth = $dbh->prepare(qq{ update meta set value = ?, changed = now() where nick = ? and channel = ? and name = ? });
226    
227  _SQL_SCHEMA_                  eval { $sth->execute( $value, $nick, $channel, $name ) };
228    
229                    # error or no result
230                    if ( $@ || ! $sth->rows ) {
231                            $sth = $dbh->prepare(qq{ insert into meta (value,nick,channel,name,changed) values (?,?,?,?,now()) });
232                            $sth->execute( $value, $nick, $channel, $name );
233                            warn "## created $nick/$channel/$name = $value\n";
234                    } else {
235                            warn "## updated $nick/$channel/$name = $value\n";
236                    }
237    
238                    return $value;
239    
240            } else {
241    
242                    my $sth = $dbh->prepare(qq{ select value,changed from meta where nick = ? and channel = ? and name = ? });
243                    $sth->execute( $nick, $channel, $name );
244                    my ($v,$c) = $sth->fetchrow_array;
245                    warn "## fetched $nick/$channel/$name = $v [$c]\n";
246                    return ($v,$c) if wantarray;
247                    return $v;
248    
249            }
250  }  }
251    
252  my $sth = $dbh->prepare(qq{  
253    
254    my $sth_insert_log = $dbh->prepare(qq{
255  insert into log  insert into log
256          (channel, me, nick, message)          (channel, me, nick, message, time)
257  values (?,?,?,?)  values (?,?,?,?,?)
258  });  });
259    
260    
261  my $tags;  my $tags;
 my $tag_regex = '\b([\w-_]+)//';  
262    
263  =head2 get_from_log  =head2 get_from_log
264    
# Line 111  my $tag_regex = '\b([\w-_]+)//'; Line 279  my $tag_regex = '\b([\w-_]+)//';
279                  }                  }
280          },          },
281          context => 5,          context => 5,
282            full_rows => 1,
283   );   );
284    
285  Order is important. Fields are first passed through C<filter> (if available) and  Order is important. Fields are first passed through C<filter> (if available) and
# Line 118  then throgh C<< sprintf($fmt->{message}, Line 287  then throgh C<< sprintf($fmt->{message},
287    
288  C<context> defines number of messages around each search hit for display.  C<context> defines number of messages around each search hit for display.
289    
290    C<full_rows> will return database rows for each result with C<date>, C<time>, C<channel>,
291    C<me>, C<nick> and C<message> keys.
292    
293  =cut  =cut
294    
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 153  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                  warn "search for '$search' returned ", $sth->rows, " results ", $context || '', "\n";                  push @args, ( ( '%' . $search . '%' ) x 2 );
349          } elsif (my $tag = $args->{tag}) {                  $msg = "Search for '$search'";
                 $sth->execute();  
                 warn "tag '$tag' returned ", $sth->rows, " results ", $context || '', "\n";  
         } elsif (my $date = $args->{date}) {  
                 $sth->execute($date);  
                 warn "found ", $sth->rows, " messages for date $date ", $context || '', "\n";  
         } 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 187  sub get_from_log { Line 387  sub get_from_log {
387                  unshift @rows, $row;                  unshift @rows, $row;
388          }          }
389    
390          my @msgs = (          # normalize nick names
391                  "Showing " . ($#rows + 1) . " messages..."          map {
392                    $_->{nick} =~ s/^_*(.*?)_*$/$1/
393            } @rows;
394    
395            return @rows if ($args->{full_rows});
396    
397            $msg .= ' produced ' . (
398                    $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 243  sub get_from_log { Line 454  sub get_from_log {
454                  my $append = 1;                  my $append = 1;
455    
456                  my $nick = $row->{nick};                  my $nick = $row->{nick};
457                  if ($nick =~ s/^_*(.*?)_*$/$1/) {  #               if ($nick =~ s/^_*(.*?)_*$/$1/) {
458                          $row->{nick} = $nick;  #                       $row->{nick} = $nick;
459                  }  #               }
460    
461                  if ($last_row->{nick} ne $nick) {                  if ($last_row->{nick} ne $nick) {
462                          # obfu way to find format for me_nick if needed or fallback to default                          # obfu way to find format for me_nick if needed or fallback to default
# Line 281  sub get_from_log { Line 492  sub get_from_log {
492          return @msgs;          return @msgs;
493  }  }
494    
495    # tags support
496    
497    my $cloud = HTML::TagCloud->new;
498    
499  my $SKIPPING = 0;               # if skipping, how many we've done  =head2 add_tag
500  my $SEND_QUEUE;                 # cache  
501     add_tag( id => 42, message => 'irc message', nick => 'foobar' [, me => 1 ] );
502    
503    =cut
504    
505    my @last_tags;
506    
507    sub add_tag {
508            my $arg = {@_};
509    
510            return unless ($arg->{id} && $arg->{message});
511    
512            my $m = $arg->{message};
513    
514            my @tags;
515    
516            while ($m =~ s#$tag_regex##s) {
517                    my $tag = $1;
518                    next if (! $tag || $tag =~ m/https?:/i);
519                    push @{ $tags->{$tag} }, $arg->{id};
520                    #warn "+tag $tag: $arg->{id}\n";
521                    $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
534    
535    Read all tags from database and create in-memory cache for tags
536    
537    =cut
538    
539    sub seed_tags {
540            my $sth = $dbh->prepare(qq{ select id,message,nick,me,time from log where message like '%//%' order by time asc });
541            $sth->execute;
542            while (my $row = $sth->fetchrow_hashref) {
543                    add_tag( %$row );
544            }
545    
546            foreach my $tag (keys %$tags) {
547                    $cloud->add($tag, "$url?tag=$tag", scalar @{$tags->{$tag}} + 1);
548            }
549    }
550    
551    seed_tags;
552    
 POE::Component::IRC->new($IRC_ALIAS);  
553    
554  =head2 save_message  =head2 save_message
555    
556    save_message($channel,$me,$nick,$msg);    save_message(
557            channel => '#foobar',
558            me => 0,
559            nick => 'dpavlin',
560            message => 'test message',
561            time => '2006-06-25 18:57:18',
562      );
563    
564    C<time> is optional, it will use C<< now() >> if it's not available.
565    
566    C<me> if not specified will be C<0> (not C</me> message)
567    
568  =cut  =cut
569    
570  sub save_message {  sub save_message {
571          my ($channel,$me,$nick,$msg) = @_;          my $a = {@_};
572          $me ||= 0;          confess "have msg" if $a->{msg};
573          $sth->execute($channel, $me, $nick, $msg);          $a->{me} ||= 0;
574          add_tag( id => $dbh->last_insert_id(undef,undef,"log",undef),          $a->{time} ||= strftime($TIMESTAMP,localtime());
575                  message => $msg);  
576            _log
577                    $a->{channel}, " ",
578                    $a->{me} ? "***" . $a->{nick} : "<" . $a->{nick} . ">",
579                    " " . $a->{message};
580    
581            $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 );
583  }  }
584    
585  POE::Session->create( inline_states =>  
586     {_start => sub {        if ($import_dircproxy) {
587            open(my $l, $import_dircproxy) || die "can't open $import_dircproxy: $!";
588            warn "importing $import_dircproxy...\n";
589            my $tz_offset = 1 * 60 * 60;    # TZ GMT+2
590            while(<$l>) {
591                    chomp;
592                    if (/^@(\d+)\s(\S+)\s(.+)$/) {
593                            my ($time, $nick, $msg) = ($1,$2,$3);
594    
595                            my $dt = DateTime->from_epoch( epoch => $time + $tz_offset );
596    
597                            my $me = 0;
598                            $me = 1 if ($nick =~ m/^\[\S+]/);
599                            $nick =~ s/^[\[<]([^!]+).*$/$1/;
600    
601                            $msg =~ s/^ACTION\s+// if ($me);
602    
603                            save_message(
604                                    channel => $CHANNEL,
605                                    me => $me,
606                                    nick => $nick,
607                                    message => $msg,
608                                    time => $dt->ymd . " " . $dt->hms,
609                            ) if ($nick !~ m/^-/);
610    
611                    } else {
612                            _log "can't parse: $_";
613                    }
614            }
615            close($l);
616            warn "import over\n";
617            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
731    #
732    
733    my $ping;                                               # ping stats
734    
735    POE::Component::IRC->new($IRC_ALIAS);
736    
737    POE::Session->create( inline_states => {
738            _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 319  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                  from_to($msg, 'UTF-8', $ENCODING);                  save_message( channel => $channel, me => 0, nick => $nick, message => $msg);
753                    meta( $nick, $channel, 'last-msg', $msg );
754                  print "$channel: <$nick> $msg\n";                  rss_check_updates( $kernel );
                 save_message($channel, 0, $nick, $msg);  
755      },      },
756      irc_ctcp_action => sub {      irc_ctcp_action => sub {
757                  my $kernel = $_[KERNEL];                  my $kernel = $_[KERNEL];
# Line 330  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                  from_to($msg, 'UTF-8', $ENCODING);                  save_message( channel => $channel, me => 1, nick => $nick, message => $msg);
763    
764                    if ( $use_twitter ) {
765                            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    
                 print "$channel ***$nick $msg\n";  
                 save_message($channel, 1, $nick, $msg);  
773      },      },
774            irc_ping => sub {
775                    _log( "pong ", $_[ARG0] );
776                    $ping->{ $_[ARG0] }++;
777                    rss_check_updates( $_[KERNEL] );
778            },
779            irc_invite => sub {
780                    my $kernel = $_[KERNEL];
781                    my $nick = (split /!/, $_[ARG0])[0];
782                    my $channel = $_[ARG1];
783    
784                    _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..." );
787                    $_[KERNEL]->post($IRC_ALIAS => join => $channel);
788    
789            },
790          irc_msg => sub {          irc_msg => sub {
791                  my $kernel = $_[KERNEL];                  my $kernel = $_[KERNEL];
792                  my $nick = (split /!/, $_[ARG0])[0];                  my $nick = (split /!/, $_[ARG0])[0];
793                  my $msg = $_[ARG2];                  my $msg = $_[ARG2];
794                  from_to($msg, 'UTF-8', $ENCODING);                  my $channel = $_[ARG1]->[0];
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;
798    
799                  print "<< $msg\n";                  _log "<< $msg";
800    
801                  if ($msg =~ m/^help/i) {                  if ($msg =~ m/^help/i) {
802    
# Line 352  POE::Session->create( inline_states => Line 804  POE::Session->create( inline_states =>
804    
805                  } elsif ($msg =~ m/^msg\s+(\S+)\s+(.*)$/i) {                  } elsif ($msg =~ m/^msg\s+(\S+)\s+(.*)$/i) {
806    
807                          print ">> /msg $1 $2\n";                          _log ">> /msg $1 $2";
808                          $_[KERNEL]->post( $IRC_ALIAS => privmsg => $1, $2 );                          $_[KERNEL]->post( $IRC_ALIAS => privmsg => $1, $2 );
809                          $res = '';                          $res = '';
810    
# Line 361  POE::Session->create( inline_states => Line 813  POE::Session->create( inline_states =>
813                          my $nr = $1 || 10;                          my $nr = $1 || 10;
814    
815                          my $sth = $dbh->prepare(qq{                          my $sth = $dbh->prepare(qq{
816                                  select nick,count(*) from log group by nick order by count desc limit $nr                                  select
817                                            trim(both '_' from nick) as nick,
818                                            count(*) as count,
819                                            sum(length(message)) as len
820                                    from log
821                                    group by trim(both '_' from nick)
822                                    order by len desc,count desc
823                                    limit $nr
824                          });                          });
825                          $sth->execute();                          $sth->execute();
826                          $res = "Top $nr users: ";                          $res = "Top $nr users: ";
827                          my @users;                          my @users;
828                          while (my $row = $sth->fetchrow_hashref) {                          while (my $row = $sth->fetchrow_hashref) {
829                                  push @users,$row->{nick} . ': ' . $row->{count};                                  push @users,$row->{nick} . ': ' . $row->{count} . '/' . $row->{len} . '=' . sprintf("%.2f", $row->{len}/$row->{count});
830                          }                          }
831                          $res .= join(" | ", @users);                          $res .= join(" | ", @users);
832                  } elsif ($msg =~ m/^last.*?\s*(\d*)/i) {                  } elsif ($msg =~ m/^last.*?\s*(\d*)/i) {
833    
834                          foreach my $res (get_from_log( limit => $1 )) {                          my $limit = $1 || meta( $nick, $channel, 'last-size' ) || 10;
835                                  print "last: $res\n";  
836                                  from_to($res, $ENCODING, 'UTF-8');                          foreach my $res (get_from_log( limit => $limit )) {
837                                    _log "last: $res";
838                                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );                                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );
839                          }                          }
840    
# Line 388  POE::Session->create( inline_states => Line 848  POE::Session->create( inline_states =>
848                                          limit => 20,                                          limit => 20,
849                                          search => $what,                                          search => $what,
850                                  )) {                                  )) {
851                                  print "search [$what]: $res\n";                                  _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    
855                          $res = '';                          $res = '';
856    
857                    } elsif ($msg =~ m/^(?:count|poll)\s+(.*)(?:\s+(\d+))?\s*$/i) {
858    
859                            my ($what,$limit) = ($1,$2);
860                            $limit ||= 100;
861    
862                            my $stat;
863    
864                            foreach my $res (get_from_log(
865                                            limit => $limit,
866                                            search => $what,
867                                            full_rows => 1,
868                                    )) {
869                                    while ($res->{message} =~ s/\Q$what\E(\+|\-)//) {
870                                            $stat->{vote}->{$1}++;
871                                            $stat->{from}->{ $res->{nick} }++;
872                                    }
873                            }
874    
875                            my @nicks;
876                            foreach my $nick (sort { $stat->{from}->{$a} <=> $stat->{from}->{$b} } keys %{ $stat->{from} }) {
877                                    push @nicks, $nick . ( $stat->{from}->{$nick} == 1 ? '' :
878                                            "(" . $stat->{from}->{$nick} . ")"
879                                    );
880                            }
881    
882                            $res =
883                                    "$what ++ " . ( $stat->{vote}->{'+'} || 0 ) .
884                                    " : " . ( $stat->{vote}->{'-'} || 0 ) . " --" .
885                                    " from " . ( join(", ", @nicks) || 'nobody' );
886    
887                            $_[KERNEL]->post( $IRC_ALIAS => notice => $nick, $res );
888    
889                    } elsif ($msg =~ m/^ping/) {
890                            $res = "ping = " . dump( $ping );
891                    } elsif ($msg =~ m/^conf(?:ig)*\s*(last-size|twitter)*\s*(.*)/) {
892                            if ( ! defined( $1 ) ) {
893                                    my $sth = $dbh->prepare(qq{ select name,value,changed from meta where nick = ? and channel = ? });
894                                    $sth->execute( $nick, $channel );
895                                    $res = "config for $nick on $channel";
896                                    while ( my ($n,$v) = $sth->fetchrow_array ) {
897                                            $res .= " | $n = $v";
898                                    }
899                            } elsif ( ! $2 ) {
900                                    my $val = meta( $nick, $channel, $1 );
901                                    $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                          print ">> [$nick] $res\n";                          _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                  print "# irc_477: ",$_[ARG1], "\n";                  _log "# irc_477: ",$_[ARG1];
976                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "register $NICK" );                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "register $NICK" );
977          },          },
978          irc_505 => sub {          irc_505 => sub {
979                  print "# irc_505: ",$_[ARG1], "\n";                  _log "# irc_505: ",$_[ARG1];
980                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "register $NICK" );                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "register $NICK" );
981  #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "set hide email on" );  #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "set hide email on" );
982  #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "set email dpavlin\@rot13.org" );  #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "set email dpavlin\@rot13.org" );
983          },          },
984          irc_registered => sub {          irc_registered => sub {
985                  warn "## indetify $NICK\n";                  _log "## registrated $NICK";
986                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );
987          },          },
988            irc_disconnected => sub {
989                    _log "## disconnected, reconnecting again";
990                    $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);
991            },
992            irc_socketerr => sub {
993                    _log "## socket error... sleeping for $sleep_on_error seconds and retry";
994                    sleep($sleep_on_error);
995                    $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);
996            },
997  #       irc_433 => sub {  #       irc_433 => sub {
998  #               print "# irc_433: ",$_[ARG1], "\n";  #               print "# irc_433: ",$_[ARG1], "\n";
999  #               warn "## indetify $NICK\n";  #               warn "## indetify $NICK\n";
# Line 425  POE::Session->create( inline_states => Line 1001  POE::Session->create( inline_states =>
1001  #       },  #       },
1002      _child => sub {},      _child => sub {},
1003      _default => sub {      _default => sub {
1004                  printf "%s #%s %s %s\n",                  _log sprintf "sID:%s %s %s",
1005                          strftime($TIMESTAMP,localtime()), $_[SESSION]->ID, $_[ARG0],                          $_[SESSION]->ID, $_[ARG0],
1006                          ref($_[ARG1]) eq "ARRAY"        ?       join(",", map { ref($_) eq "ARRAY" ? join(";", @{$_}) : $_ } @{ $_[ARG1] })     :                          ref($_[ARG1]) eq "ARRAY"        ?       join(",", map { ref($_) eq "ARRAY" ? join(";", @{$_}) : $_ } @{ $_[ARG1] })     :
1007                          $_[ARG1]                                        ?       $_[ARG1]                                        :                          $_[ARG1]                                        ?       $_[ARG1]                                        :
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    
 # tags support  
   
 my $cloud = HTML::TagCloud->new;  
   
 =head2 add_tag  
   
  add_tag( id => 42, message => 'irc message' );  
   
 =cut  
   
 sub add_tag {  
         my $arg = {@_};  
   
         return unless ($arg->{id} && $arg->{message});  
   
         my $m = $arg->{message};  
         from_to('UTF-8', 'iso-8859-2', $m) if (is_utf8($m));  
   
         while ($m =~ s#$tag_regex##s) {  
                 my $tag = $1;  
                 next if (! $tag || $tag =~ m/https?:/i);  
                 push @{ $tags->{$tag} }, $arg->{id};  
                 #warn "+tag $tag: $arg->{id}\n";  
                 $cloud->add($tag, "?tag=$tag", scalar @{$tags->{$tag}} + 1);  
         }  
 }  
   
 =head2 seed_tags  
   
 Read all tags from database and create in-memory cache for tags  
   
 =cut  
   
 sub seed_tags {  
         my $sth = $dbh->prepare(qq{ select id,message from log where message like '%//%' });  
         $sth->execute;  
         while (my $row = $sth->fetchrow_hashref) {  
                 add_tag( %$row );  
         }  
   
         foreach my $tag (keys %$tags) {  
                 $cloud->add($tag, "?tag=$tag", scalar @{$tags->{$tag}} + 1);  
         }  
 }  
   
 seed_tags;  
   
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 560  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 591  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 646  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 675  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.36  
changed lines
  Added in v.100
  ViewVC Help
Powered by ViewVC 1.1.26