/[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 140 by dpavlin, Fri Jul 18 20:29:45 2008 UTC
# Line 2  Line 2 
2  use strict;  use strict;
3  $|++;  $|++;
4    
5    use POE qw(Component::IRC Component::Server::HTTP Component::Client::HTTP);
6    use HTTP::Status;
7    use DBI;
8    use Regexp::Common qw /URI/;
9    use CGI::Simple;
10    use POSIX qw/strftime/;
11    use HTML::CalendarMonthSimple;
12    use Getopt::Long;
13    use DateTime;
14    use URI::Escape;
15    use Data::Dump qw/dump/;
16    use DateTime::Format::ISO8601;
17    use Carp qw/confess/;
18    use XML::Feed;
19    use DateTime::Format::Flexible;
20    use Encode;
21    
22  =head1 NAME  =head1 NAME
23    
24  irc-logger.pl  irc-logger.pl
# Line 10  irc-logger.pl Line 27  irc-logger.pl
27    
28  ./irc-logger.pl  ./irc-logger.pl
29    
30    =head2 Options
31    
32    =over 4
33    
34    =item --import-dircproxy=filename
35    
36    Import log from C<dircproxy> to C<irc-logger> database
37    
38    =item --log=irc-logger.log
39    
40    =back
41    
42  =head1 DESCRIPTION  =head1 DESCRIPTION
43    
44  log all conversation on irc channel  log all conversation on irc channel
# Line 18  log all conversation on irc channel Line 47  log all conversation on irc channel
47    
48  ## CONFIG  ## CONFIG
49    
50  my $HOSTNAME = `hostname`;  my $debug = 0;
51    
52    my $irc_config = {
53            nick => 'irc-logger',
54            server => 'irc.freenode.net',
55            port => 6667,
56            ircname => 'Anna the bot: try /msg irc-logger help',
57    };
58    
59    my $HOSTNAME = `hostname -f`;
60    chomp($HOSTNAME);
61    
62    
 my $NICK = 'irc-logger';  
 $NICK .= '-dev' if ($HOSTNAME =~ m/llin/);  
 my $CONNECT =  
   {Server => 'irc.freenode.net',  
    Nick => $NICK,  
    Ircname => "try /msg $NICK help",  
   };  
63  my $CHANNEL = '#razmjenavjestina';  my $CHANNEL = '#razmjenavjestina';
 $CHANNEL = '#irc-logger' if ($HOSTNAME =~ m/llin/);  
 my $IRC_ALIAS = "log";  
64    
65  my %FOLLOWS =  if ( $HOSTNAME =~ m/llin/ ) {
66    (          $irc_config->{nick} = 'irc-logger-llin';
67     ACCESS => "/var/log/apache/access.log",  #       $irc_config = {
68     ERROR => "/var/log/apache/error.log",  #               nick => 'irc-logger-llin',
69    );  #               server => 'localhost',
70    #               port => 6668,
71    #       };
72            $CHANNEL = '#irc-logger';
73    } elsif ( $HOSTNAME =~ m/lugarin/ ) {
74            $irc_config->{server} = 'irc.carnet.hr';
75            $CHANNEL = '#riss';
76    }
77    
78    my @channels = ( $CHANNEL );
79    
80    warn "## config = ", dump( $irc_config ) if $debug;
81    
82    my $NICK = $irc_config->{nick} or die "no nick?";
83    
84  my $DSN = 'DBI:Pg:dbname=' . $NICK;  my $DSN = 'DBI:Pg:dbname=' . $NICK;
85    
 my $ENCODING = 'ISO-8859-2';  
86  my $TIMESTAMP = '%Y-%m-%d %H:%M:%S';  my $TIMESTAMP = '%Y-%m-%d %H:%M:%S';
87    
88    my $sleep_on_error = 5;
89    
90    # number of last tags to keep in circular buffer
91    my $last_x_tags = 50;
92    
93    # don't pull rss feeds more often than this
94    my $rss_min_delay = 60;
95    
96    my $http_port = $NICK =~ m/-dev/ ? 8001 : 8000;
97    
98    my $url = "http://$HOSTNAME:$http_port";
99    
100  ## END CONFIG  ## END CONFIG
101    
102    my $use_twitter = 1;
103    eval { require Net::Twitter; };
104    $use_twitter = 0 if ($@);
105    
106    my $import_dircproxy;
107    my $log_path;
108    GetOptions(
109            'import-dircproxy:s' => \$import_dircproxy,
110            'log:s' => \$log_path,
111            'debug!' => \$debug,
112    );
113    
114    #$SIG{__DIE__} = sub {
115    #       confess "fatal error";
116    #};
117    
118  use POE qw(Component::IRC Wheel::FollowTail Component::Server::HTTP);  sub _log {
119  use HTTP::Status;          print strftime($TIMESTAMP,localtime()) . ' ' . join(" ",map { ref($_) ? dump( $_ ) : $_ } @_) . $/;
120  use DBI;  }
121  use Encode qw/from_to is_utf8/;  
122  use Regexp::Common qw /URI/;  open(STDOUT, '>', $log_path) && warn "log to $log_path: $!\n";
 use CGI::Simple;  
 use HTML::TagCloud;  
 use POSIX qw/strftime/;  
 use HTML::CalendarMonthSimple;  
123    
 my $dbh = DBI->connect($DSN,"","", { RaiseError => 1, AutoCommit => 1 }) || die $DBI::errstr;  
124    
125  eval {  # HTML formatters
126          $dbh->do(qq{ select count(*) from log });  
127    my %escape = ('<'=>'&lt;', '>'=>'&gt;', '&'=>'&amp;', '"'=>'&quot;');
128    my $escape_re  = join '|' => keys %escape;
129    
130    my $tag_regex = '\b([\w\-_]+)//';
131    
132    my %nick_enumerator;
133    my $max_color = 0;
134    
135    my $filter = {
136            message => sub {
137                    my $m = shift || return;
138    
139                    # protect HTML from wiki modifications
140                    sub e {
141                            my $t = shift;
142                            return 'uri_unescape{' . uri_escape($t, '^a-zA-Z0-9') . '}';
143                    }
144    
145                    $m =~ s/($escape_re)/$escape{$1}/gs;
146                    $m =~ s#($RE{URI}{HTTP})#e(qq{<a href="$1">$1</a>})#egs;
147                    $m =~ s#\/(\w+)\/#<i>$1</i>#gs;
148                    $m =~ s#$tag_regex#e(qq{<a href="$url?tag=$1" class="tag">$1</a>})#egs;
149                    $m =~ s#\*(\w+)\*#<b>$1</b>#gs;
150                    $m =~ s#_(\w+)_#<u>$1</u>#gs;
151    
152                    $m =~ s#uri_unescape{([^}]+)}#uri_unescape($1)#egs;
153                    return $m;
154            },
155            nick => sub {
156                    my $n = shift || return;
157                    if (! $nick_enumerator{$n})  {
158                            my $max = scalar keys %nick_enumerator;
159                            $nick_enumerator{$n} = $max + 1;
160                    }
161                    return '<span class="nick col-' .
162                            ( $nick_enumerator{$n} % $max_color ) .
163                            '">' . $n . '</span>';
164            },
165  };  };
166    
167  if ($@) {  # POE IRC
168          warn "creating database table in $DSN\n";  my $poe_irc = POE::Component::IRC->spawn( %$irc_config ) or
169          $dbh->do(<<'_SQL_SCHEMA_');          die "can't start ", dump( $irc_config ), ": $!";
170    
171    my $irc = $poe_irc->session_id();
172    _log "IRC session_id $irc";
173    
174    my $dbh = DBI->connect($DSN,"","", { RaiseError => 1, AutoCommit => 1 }) || die $DBI::errstr;
175    $dbh->do( qq{ set client_encoding = 'UTF-8' } );
176    
177    my $sql_schema = {
178            log => qq{
179  create table log (  create table log (
180          id serial,          id serial,
181          time timestamp default now(),          time timestamp default now(),
# Line 79  create table log ( Line 189  create table log (
189  create index log_time on log(time);  create index log_time on log(time);
190  create index log_channel on log(channel);  create index log_channel on log(channel);
191  create index log_nick on log(nick);  create index log_nick on log(nick);
192            },
193            meta => q{
194    create table meta (
195            nick text not null,
196            channel text not null,
197            name text not null,
198            value text,
199            changed timestamp default 'now()',
200            primary key(nick,channel,name)
201    );
202            },
203            feeds => qq{
204    create table feeds (
205            id serial,
206            url text not null,
207            name text,
208            delay interval not null default '5 min',
209            active boolean default true,
210            channel text not null,
211            nick text not null,
212            private boolean default false,
213            last_update timestamp default 'now()',
214            polls int default 0,
215            updates int default 0
216    );
217    create unique index feeds_url on feeds(url);
218    insert into feeds (url,name,channel,nick) values ('http://wiki.razmjenavjestina.org/feed/workspace/razmjenavjestina?category=Recent%20Changes','wiki','$CHANNEL','dpavlin');
219            },
220    };
221    
222    foreach my $table ( keys %$sql_schema ) {
223    
224            eval {
225                    $dbh->do(qq{ select count(*) from $table });
226            };
227    
228  _SQL_SCHEMA_          if ($@) {
229                    warn "creating database table $table in $DSN\n";
230                    $dbh->do( $sql_schema->{ $table } );
231            }
232  }  }
233    
234  my $sth = $dbh->prepare(qq{  
235    =head2 meta
236    
237    Set or get some meta data into database
238    
239            meta('nick','channel','var_name', $var_value );
240    
241            $var_value = meta('nick','channel','var_name');
242            ( $var_value, $changed ) = meta('nick','channel','var_name');
243    
244    =cut
245    
246    sub meta {
247            my ($nick,$channel,$name,$value) = @_;
248    
249            # normalize channel name
250            $channel =~ s/^#//;
251    
252            if (defined($value)) {
253    
254                    my $sth = $dbh->prepare(qq{ update meta set value = ?, changed = now() where nick = ? and channel = ? and name = ? });
255    
256                    eval { $sth->execute( $value, $nick, $channel, $name ) };
257    
258                    if ( $@ ) {
259                            # error
260                            _log("META ERROR: $@");
261                    } elsif ( ! $sth->rows ) {
262                            # no result -> add new
263                            $sth = $dbh->prepare(qq{ insert into meta (value,nick,channel,name,changed) values (?,?,?,?,now()) });
264                            eval { $sth->execute( $value, $nick, $channel, $name ); };
265                            if ( $@ ) {
266                                    _log "META ERROR: $@";
267                            } else {
268                                    _log "META: created $nick/$channel/$name = $value\n";
269                            }
270                    } else {
271                            _log "META: updated $nick/$channel/$name = $value\n";
272                    }
273    
274                    return $value;
275    
276            } else {
277    
278                    my $sth = $dbh->prepare(qq{ select value,changed from meta where nick = ? and channel = ? and name = ? });
279                    $sth->execute( $nick, $channel, $name );
280                    my ($v,$c) = $sth->fetchrow_array;
281                    warn "## fetched $nick/$channel/$name = $v [$c]\n";
282                    return ($v,$c) if wantarray;
283                    return $v;
284    
285            }
286    }
287    
288    
289    
290    my $sth_insert_log = $dbh->prepare(qq{
291  insert into log  insert into log
292          (channel, me, nick, message)          (channel, me, nick, message, time)
293  values (?,?,?,?)  values (?,?,?,?,?)
294  });  });
295    
296    
297  my $tags;  my $tags;
 my $tag_regex = '\b([\w-_]+)//';  
298    
299  =head2 get_from_log  =head2 get_from_log
300    
# Line 111  my $tag_regex = '\b([\w-_]+)//'; Line 315  my $tag_regex = '\b([\w-_]+)//';
315                  }                  }
316          },          },
317          context => 5,          context => 5,
318            full_rows => 1,
319   );   );
320    
321  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 323  then throgh C<< sprintf($fmt->{message},
323    
324  C<context> defines number of messages around each search hit for display.  C<context> defines number of messages around each search hit for display.
325    
326    C<full_rows> will return database rows for each result with C<date>, C<time>, C<channel>,
327    C<me>, C<nick> and C<message> keys.
328    
329  =cut  =cut
330    
331  sub get_from_log {  sub get_from_log {
332          my $args = {@_};          my $args = {@_};
333    
334          $args->{fmt} ||= {          if ( ! $args->{fmt} ) {
335                  date => '[%s] ',                  $args->{fmt} = {
336                  time => '{%s} ',                          date => '[%s] ',
337                  time_channel => '{%s %s} ',                          time => '{%s} ',
338                  nick => '%s: ',                          time_channel => '{%s %s} ',
339                  me_nick => '***%s ',                          nick => '%s: ',
340                  message => '%s',                          me_nick => '***%s ',
341          };                          message => '%s',
342                    };
343            }
344    
345          my $sql_message = qq{          my $sql_message = qq{
346                  select                  select
# Line 153  sub get_from_log { Line 363  sub get_from_log {
363    
364          my $sql = $context ? $sql_context : $sql_message;          my $sql = $context ? $sql_context : $sql_message;
365    
366          $sql .= " where message ilike ? or nick ilike ? " if ($args->{search});          sub check_date {
367          $sql .= " where id in (" . join(",", @{ $tags->{ $args->{tag} } }) . ") " if ($args->{tag} && $tags->{ $args->{tag} });                  my $date = shift || return;
368          $sql .= " where date(time) = ? " if ($args->{date});                  my $new_date = eval { DateTime::Format::ISO8601->parse_datetime( $date )->ymd; };
369          $sql .= " order by log.time desc";                  if ( $@ ) {
370          $sql .= " limit " . $args->{limit} if ($args->{limit});                          warn "invalid date $date\n";
371                            $new_date = DateTime->now->ymd;
372                    }
373                    return $new_date;
374            }
375    
376            my @where;
377            my @args;
378            my $msg;
379    
         my $sth = $dbh->prepare( $sql );  
380          if (my $search = $args->{search}) {          if (my $search = $args->{search}) {
381                  $search =~ s/^\s+//;                  $search =~ s/^\s+//;
382                  $search =~ s/\s+$//;                  $search =~ s/\s+$//;
383                  $sth->execute( ( '%' . $search . '%' ) x 2 );                  push @where, 'message ilike ? or nick ilike ?';
384                  warn "search for '$search' returned ", $sth->rows, " results ", $context || '', "\n";                  push @args, ( ( '%' . $search . '%' ) x 2 );
385          } elsif (my $tag = $args->{tag}) {                  $msg = "Search for '$search'";
386                  $sth->execute();          }
387                  warn "tag '$tag' returned ", $sth->rows, " results ", $context || '', "\n";  
388          } elsif (my $date = $args->{date}) {          if ($args->{tag} && $tags->{ $args->{tag} }) {
389                  $sth->execute($date);                  push @where, 'id in (' . join(',', @{ $tags->{ $args->{tag} } }) . ')';
390                  warn "found ", $sth->rows, " messages for date $date ", $context || '', "\n";                  $msg = "Search for tags $args->{tag}";
391          } else {          }
392                  $sth->execute();  
393            if (my $date = $args->{date} ) {
394                    $date = check_date( $date );
395                    push @where, 'date(time) = ?';
396                    push @args, $date;
397                    $msg = "search for date $date";
398          }          }
399    
400            $sql .= " where " . join(" and ", @where) if @where;
401    
402            $sql .= " order by log.time desc";
403            $sql .= " limit " . $args->{limit} if ($args->{limit});
404    
405            #warn "### sql: $sql ", dump( @args );
406    
407            my $sth = $dbh->prepare( $sql );
408            eval { $sth->execute( @args ) };
409            return if $@;
410    
411            my $nr_results = $sth->rows;
412    
413          my $last_row = {          my $last_row = {
414                  date => '',                  date => '',
415                  time => '',                  time => '',
# Line 187  sub get_from_log { Line 423  sub get_from_log {
423                  unshift @rows, $row;                  unshift @rows, $row;
424          }          }
425    
426          my @msgs = (          # normalize nick names
427                  "Showing " . ($#rows + 1) . " messages..."          map {
428                    $_->{nick} =~ s/^_*(.*?)_*$/$1/
429            } @rows;
430    
431            return @rows if ($args->{full_rows});
432    
433            $msg .= ' produced ' . (
434                    $nr_results == 0 ? 'no results' :
435                    $nr_results == 0 ? 'one result' :
436                            $nr_results . ' results'
437          );          );
438    
439            my @msgs = ( $msg );
440    
441          if ($context) {          if ($context) {
442                  my @ids = @rows;                  my @ids = @rows;
443                  @rows = ();                  @rows = ();
# Line 243  sub get_from_log { Line 490  sub get_from_log {
490                  my $append = 1;                  my $append = 1;
491    
492                  my $nick = $row->{nick};                  my $nick = $row->{nick};
493                  if ($nick =~ s/^_*(.*?)_*$/$1/) {  #               if ($nick =~ s/^_*(.*?)_*$/$1/) {
494                          $row->{nick} = $nick;  #                       $row->{nick} = $nick;
495                  }  #               }
496    
497                    $append = 0 if $row->{me};
498    
499                  if ($last_row->{nick} ne $nick) {                  if ($last_row->{nick} ne $nick) {
500                          # 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 530  sub get_from_log {
530          return @msgs;          return @msgs;
531  }  }
532    
533    # tags support
534    
535  my $SKIPPING = 0;               # if skipping, how many we've done  my $cloud = TagCloud->new;
536  my $SEND_QUEUE;                 # cache  $cloud->seed_tags;
   
 POE::Component::IRC->new($IRC_ALIAS);  
537    
538  =head2 save_message  =head2 save_message
539    
540    save_message($channel,$me,$nick,$msg);    save_message(
541            channel => '#foobar',
542            me => 0,
543            nick => 'dpavlin',
544            message => 'test message',
545            time => '2006-06-25 18:57:18',
546      );
547    
548    C<time> is optional, it will use C<< now() >> if it's not available.
549    
550    C<me> if not specified will be C<0> (not C</me> message)
551    
552  =cut  =cut
553    
554  sub save_message {  sub save_message {
555          my ($channel,$me,$nick,$msg) = @_;          my $a = {@_};
556          $me ||= 0;          confess "have msg" if $a->{msg};
557          $sth->execute($channel, $me, $nick, $msg);          $a->{me} ||= 0;
558          add_tag( id => $dbh->last_insert_id(undef,undef,"log",undef),          $a->{time} ||= strftime($TIMESTAMP,localtime());
559                  message => $msg);  
560            _log "ARCHIVE",
561                    $a->{channel}, " ",
562                    $a->{me} ? "***" . $a->{nick} : "<" . $a->{nick} . ">",
563                    " " . $a->{message};
564    
565            eval { $sth_insert_log->execute($a->{channel}, $a->{me}, $a->{nick}, $a->{message}, $a->{time}); };
566            if ( $@ ) {
567                    _log "ERROR: can't archive ", $a->{message};
568            } else {
569                    $cloud->add_tag( id => $dbh->last_insert_id(undef,undef,"log",undef), %$a );
570            }
571  }  }
572    
 POE::Session->create( inline_states =>  
    {_start => sub {        
                 $_[KERNEL]->post($IRC_ALIAS => register => 'all');  
                 $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);  
     },  
     irc_255 => sub {    # server is done blabbing  
                 $_[KERNEL]->post($IRC_ALIAS => join => $CHANNEL);  
                 $_[KERNEL]->post($IRC_ALIAS => join => '#logger');  
                 $_[KERNEL]->yield("heartbeat"); # start heartbeat  
 #               $_[KERNEL]->yield("my_add", $_) for keys %FOLLOWS;  
                 $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );  
     },  
     irc_public => sub {  
                 my $kernel = $_[KERNEL];  
                 my $nick = (split /!/, $_[ARG0])[0];  
                 my $channel = $_[ARG1]->[0];  
                 my $msg = $_[ARG2];  
573    
574                  from_to($msg, 'UTF-8', $ENCODING);  if ($import_dircproxy) {
575            open(my $l, $import_dircproxy) || die "can't open $import_dircproxy: $!";
576            warn "importing $import_dircproxy...\n";
577            my $tz_offset = 1 * 60 * 60;    # TZ GMT+2
578            while(<$l>) {
579                    chomp;
580                    if (/^@(\d+)\s(\S+)\s(.+)$/) {
581                            my ($time, $nick, $msg) = ($1,$2,$3);
582    
583                            my $dt = DateTime->from_epoch( epoch => $time + $tz_offset );
584    
585                            my $me = 0;
586                            $me = 1 if ($nick =~ m/^\[\S+]/);
587                            $nick =~ s/^[\[<]([^!]+).*$/$1/;
588    
589                            $msg =~ s/^ACTION\s+// if ($me);
590    
591                            save_message(
592                                    channel => $CHANNEL,
593                                    me => $me,
594                                    nick => $nick,
595                                    message => $msg,
596                                    time => $dt->ymd . " " . $dt->hms,
597                            ) if ($nick !~ m/^-/);
598    
599                  print "$channel: <$nick> $msg\n";                  } else {
600                  save_message($channel, 0, $nick, $msg);                          _log "can't parse: $_";
601      },                  }
602      irc_ctcp_action => sub {          }
603                  my $kernel = $_[KERNEL];          close($l);
604                  my $nick = (split /!/, $_[ARG0])[0];          warn "import over\n";
605                  my $channel = $_[ARG1]->[0];          exit;
606                  my $msg = $_[ARG2];  }
607    
608                  from_to($msg, 'UTF-8', $ENCODING);  #
609    # RSS follow
610    #
611    
612    my $_stat;
613    
614    POE::Component::Client::HTTP->spawn(
615            Alias   => 'rss-fetch',
616            Timeout => 30,
617    );
618    
619                  print "$channel ***$nick $msg\n";  =head2 rss_parse_xml
620                  save_message($channel, 1, $nick, $msg);  
621      },    rss_parse_xml({
622          irc_msg => sub {          url => 'http://www.example.com/rss',
623                  my $kernel = $_[KERNEL];          send_rss_msgs => 42,
624                  my $nick = (split /!/, $_[ARG0])[0];    });
                 my $msg = $_[ARG2];  
                 from_to($msg, 'UTF-8', $ENCODING);  
625    
626                  my $res = "unknown command '$msg', try /msg $NICK help!";  =cut
                 my @out;  
627    
628                  print "<< $msg\n";  sub rss_parse_xml {
629            my ($kernel,$args) = @_;
630    
631                  if ($msg =~ m/^help/i) {          warn "## rss_parse_xml ",dump( $args ) if $debug;
632    
633                          $res = "usage: /msg $NICK comand | commands: stat - user/message stat | last - show backtrace | grep foobar - find foobar";          # how many messages to send out when feed is seen for the first time?
634            my $send_rss_msgs = $args->{send_rss_msgs};
635            $send_rss_msgs = 1 if ! defined $send_rss_msgs;
636    
637            warn "## RSS fetch first $send_rss_msgs items from", $args->{url} if $debug;
638    
639            my $feed;
640            eval { $feed = XML::Feed->parse( \$args->{xml} ) };
641            if ( ! $feed ) {
642                    _log "can't fetch RSS ", $args->{url}, XML::Feed->errstr;
643                    return;
644            }
645    
646                  } elsif ($msg =~ m/^msg\s+(\S+)\s+(.*)$/i) {          $_stat->{rss}->{url2link}->{ $args->{url} } = $feed->link;
647    
648                          print ">> /msg $1 $2\n";          my ( $total, $updates ) = ( 0, 0 );
649                          $_[KERNEL]->post( $IRC_ALIAS => privmsg => $1, $2 );          for my $entry ($feed->entries) {
650                          $res = '';                  $total++;
651    
652                    my $seen_times = $_stat->{rss}->{seen}->{$args->{channel}}->{$feed->link}->{$entry->id}++;
653                    # seen allready?
654                    warn "## $seen_times ",$entry->id if $debug;
655                    next if $seen_times > 0;
656    
657                    sub prefix {
658                            my ($txt,$var) = @_;
659                            $var =~ s/\s+/ /gs;
660                            $var =~ s/^\s+//g;
661                            $var =~ s/\s+$//g;
662                            return $txt . $var if $var;
663                    }
664    
665                  } elsif ($msg =~ m/^stat.*?\s*(\d*)/i) {                  # fix absolute and relative links to feed entries
666                    my $link = $entry->link;
667                    if ( $link =~ m!^/! ) {
668                            my $host = $args->{url};
669                            $host =~ s!^(http://[^/]+).*$!$1!;      #!vim
670                            $link = "$host/$link";
671                    } elsif ( $link !~ m!^http! ) {
672                            $link = $args->{url} . $link;
673                    }
674    
675                          my $nr = $1 || 10;                  my $msg;
676                    $msg .= prefix( 'From: ' , $args->{name} || $feed->title );
677                    $msg .= prefix( ' by ' , $entry->author );
678                    $msg .= prefix( ' | ' , $entry->title );
679                    $msg .= prefix( ' | ' , $link );
680    #               $msg .= prefix( ' id ' , $entry->id );
681                    my @categories = $entry->category;
682                    warn "## category = ", dump( @categories ) if $debug;
683                    if ( my $tags = $entry->category ) {
684                            $tags = join(' ', @$tags) if ref($tags) eq 'ARRAY';
685                            $tags =~ s!^\s+!!;
686                            $tags =~ s!\s*$! !;
687                            $tags =~ s!,?\s+!// !g;
688                            $msg .= prefix( ' ' , $tags );
689                    }
690    
691                          my $sth = $dbh->prepare(qq{                  if ( $seen_times == 0 && $send_rss_msgs ) {
692                                  select nick,count(*) from log group by nick order by count desc limit $nr                          $send_rss_msgs--;
693                          });                          if ( ! $args->{private} ) {
694                          $sth->execute();                                  # FIXME bug! should be save_message
695                          $res = "Top $nr users: ";                                  save_message( channel => $args->{channel}, me => 1, nick => $NICK, message => $msg );
696                          my @users;  #                               $sth_insert_log->execute( $args->{channel}, 1, $NICK, $msg, 'now()' );
                         while (my $row = $sth->fetchrow_hashref) {  
                                 push @users,$row->{nick} . ': ' . $row->{count};  
697                          }                          }
698                          $res .= join(" | ", @users);                          my ( $type, $to ) = ( 'notice', $args->{channel} );
699                  } elsif ($msg =~ m/^last.*?\s*(\d*)/i) {                          ( $type, $to ) = ( 'privmsg', $args->{nick} ) if $args->{private};
700    
701                          foreach my $res (get_from_log( limit => $1 )) {                          _log(">> RSS $type to $to:", $msg);
702                                  print "last: $res\n";                          $kernel->post( $irc => $type => $to => $msg );
                                 from_to($res, $ENCODING, 'UTF-8');  
                                 $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );  
                         }  
703    
704                          $res = '';                          $updates++;
705                    }
706            }
707    
708                  } elsif ($msg =~ m/^(search|grep)\s+(.*)\s*$/i) {          my $sql = qq{ update feeds set last_update = now(), polls = polls + 1 };
709            $sql .= qq{, updates = updates + $updates } if $updates;
710            $sql .= qq{where id = } . $args->{id};
711            eval { $dbh->do( $sql ) };
712    
713                          my $what = $2;          _log "RSS $updates/$total new items from", $args->{url};
714    
715                          foreach my $res (get_from_log(          return $updates;
716                                          limit => 20,  }
                                         search => $what,  
                                 )) {  
                                 print "search [$what]: $res\n";  
                                 from_to($res, $ENCODING, 'UTF-8');  
                                 $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );  
                         }  
717    
718                          $res = '';  sub rss_fetch_all {
719            my ( $kernel, $send_rss_msgs )  = @_;
720            warn "## rss_fetch_all -- send_rss_msgs: $send_rss_msgs\n" if $debug;
721            my $sql = qq{
722                    select id, url, name, channel, nick, private
723                    from feeds
724                    where active is true
725            };
726            # limit to newer feeds only if we are not sending messages out
727            $sql .= qq{     and last_update + delay < now() } if defined ( $_stat->{rss}->{fetch} );
728            my $sth = $dbh->prepare( $sql );
729            $sth->execute();
730            warn "# ",$sth->rows," active RSS feeds\n";
731            my $count = 0;
732            while (my $row = $sth->fetchrow_hashref) {
733                    $row->{send_rss_msgs} = $send_rss_msgs if defined $send_rss_msgs;
734                    $_stat->{rss}->{fetch}->{ $row->{url} } = $row;
735                    $kernel->post(
736                            'rss-fetch',
737                            'request',
738                            'rss_response',
739                            HTTP::Request->new( GET => $row->{url} ),
740                    );
741                    warn "## queued rss-fetch ", dump( $row ) if $debug;
742            }
743            return "OK, scheduled " . $sth->rows . " feeds for refresh";
744    }
745    
746    
747    sub rss_check_updates {
748            my $kernel = shift;
749            $_stat->{rss}->{last_poll} ||= time();
750            my $dt = time() - $_stat->{rss}->{last_poll};
751            if ( $dt > $rss_min_delay ) {
752                    warn "## rss_check_updates $dt > $rss_min_delay\n";
753                    $_stat->{rss}->{last_poll} = time();
754                    _log rss_fetch_all( $kernel );
755            }
756    }
757    
758    sub process_command {
759            my ( $kernel, $nick, $channel, $msg ) = @_;
760    
761            my $res = "unknown command '$msg', try /msg $NICK help!";
762    
763            if ($msg =~ m/^help/i) {
764    
765                    $res = "usage: /msg $NICK comand | commands: stat - user/message stat | last - show backtrace | grep foobar - find foobar";
766    
767            } elsif ($msg =~ m/^(privmsg|notice)\s+(\S+)\s+(.*)$/i) {
768    
769                    _log ">> /$1 $2 $3";
770                    $kernel->post( $irc => $1 => $2, $3 );
771                    $res = '';
772    
773            } elsif ($msg =~ m/^stat.*?\s*(\d*)/i) {
774    
775                    my $nr = $1 || 10;
776    
777                    my $sth = $dbh->prepare(qq{
778                            select
779                                    trim(both '_' from nick) as nick,
780                                    count(*) as count,
781                                    sum(length(message)) as len
782                            from log
783                            group by trim(both '_' from nick)
784                            order by len desc,count desc
785                            limit $nr
786                    });
787                    $sth->execute();
788                    $res = "Top $nr users: ";
789                    my @users;
790                    while (my $row = $sth->fetchrow_hashref) {
791                            push @users,$row->{nick} . ': ' . $row->{count} . '/' . $row->{len} . '=' . sprintf("%.2f", $row->{len}/$row->{count});
792                  }                  }
793                    $res .= join(" | ", @users);
794            } elsif ($msg =~ m/^last.*?\s*(\d*)/i) {
795    
796                  if ($res) {                  my $limit = $1 || meta( $nick, $channel, 'last-size' ) || 10;
797                          print ">> [$nick] $res\n";  
798                          from_to($res, $ENCODING, 'UTF-8');                  foreach my $res (get_from_log( limit => $limit )) {
799                          $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );                          _log "last: $res";
800                            $kernel->post( $irc => privmsg => $nick, $res );
801                  }                  }
802    
803          },                  $res = '';
         irc_477 => sub {  
                 print "# irc_477: ",$_[ARG1], "\n";  
                 $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "register $NICK" );  
         },  
         irc_505 => sub {  
                 print "# irc_505: ",$_[ARG1], "\n";  
                 $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "register $NICK" );  
 #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "set hide email on" );  
 #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "set email dpavlin\@rot13.org" );  
         },  
         irc_registered => sub {  
                 warn "## indetify $NICK\n";  
                 $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );  
         },  
 #       irc_433 => sub {  
 #               print "# irc_433: ",$_[ARG1], "\n";  
 #               warn "## indetify $NICK\n";  
 #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );  
 #       },  
     _child => sub {},  
     _default => sub {  
                 printf "%s #%s %s %s\n",  
                         strftime($TIMESTAMP,localtime()), $_[SESSION]->ID, $_[ARG0],  
                         ref($_[ARG1]) eq "ARRAY"        ?       join(",", map { ref($_) eq "ARRAY" ? join(";", @{$_}) : $_ } @{ $_[ARG1] })     :  
                         $_[ARG1]                                        ?       $_[ARG1]                                        :  
                         "";  
       0;                        # false for signals  
     },  
     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  
       }  
804    
805      },          } elsif ($msg =~ m/^(search|grep)\s+(.*)\s*$/i) {
     my_heartbeat => sub {  
       $_[KERNEL]->yield(my_tailed => time, "heartbeat", "beep");  
       $_[KERNEL]->delay($_[STATE] => 10);  
     }  
    },  
   );  
806    
807  # tags support                  my $what = $2;
808    
809  my $cloud = HTML::TagCloud->new;                  foreach my $res (get_from_log(
810                                    limit => 20,
811                                    search => $what,
812                            )) {
813                            _log "search [$what]: $res";
814                            $kernel->post( $irc => privmsg => $nick, $res );
815                    }
816    
817  =head2 add_tag                  $res = '';
818    
819   add_tag( id => 42, message => 'irc message' );          } elsif ($msg =~ m/^(?:count|poll)\s+(.*)(?:\s+(\d+))?\s*$/i) {
820    
821  =cut                  my ($what,$limit) = ($1,$2);
822                    $limit ||= 100;
823    
824  sub add_tag {                  my $stat;
         my $arg = {@_};  
825    
826          return unless ($arg->{id} && $arg->{message});                  foreach my $res (get_from_log(
827                                    limit => $limit,
828                                    search => $what,
829                                    full_rows => 1,
830                            )) {
831                            while ($res->{message} =~ s/\Q$what\E(\+|\-)//) {
832                                    $stat->{vote}->{$1}++;
833                                    $stat->{from}->{ $res->{nick} }++;
834                            }
835                    }
836    
837          my $m = $arg->{message};                  my @nicks;
838          from_to('UTF-8', 'iso-8859-2', $m) if (is_utf8($m));                  foreach my $nick (sort { $stat->{from}->{$a} <=> $stat->{from}->{$b} } keys %{ $stat->{from} }) {
839                            push @nicks, $nick . ( $stat->{from}->{$nick} == 1 ? '' :
840                                    "(" . $stat->{from}->{$nick} . ")"
841                            );
842                    }
843    
844          while ($m =~ s#$tag_regex##s) {                  $res =
845                  my $tag = $1;                          "$what ++ " . ( $stat->{vote}->{'+'} || 0 ) .
846                  next if (! $tag || $tag =~ m/https?:/i);                          " : " . ( $stat->{vote}->{'-'} || 0 ) . " --" .
847                  push @{ $tags->{$tag} }, $arg->{id};                          " from " . ( join(", ", @nicks) || 'nobody' );
848                  #warn "+tag $tag: $arg->{id}\n";  
849                  $cloud->add($tag, "?tag=$tag", scalar @{$tags->{$tag}} + 1);                  $kernel->post( $irc => notice => $nick, $res );
850    
851            } elsif ($msg =~ m/^ping/) {
852                    $res = "ping = " . dump( $_stat->{ping} );
853            } elsif ($msg =~ m/^conf(?:ig)*\s*(last-size|twitter)*\s*(.*)/) {
854                    if ( ! defined( $1 ) ) {
855                            my $sth = $dbh->prepare(qq{ select name,value,changed from meta where nick = ? and channel = ? });
856                            $sth->execute( $nick, $channel );
857                            $res = "config for $nick on $channel";
858                            while ( my ($n,$v) = $sth->fetchrow_array ) {
859                                    $res .= " | $n = $v";
860                            }
861                    } elsif ( ! $2 ) {
862                            my $val = meta( $nick, $channel, $1 );
863                            $res = "current $1 = " . ( $val ? $val : 'undefined' );
864                    } else {
865                            my $validate = {
866                                    'last-size' => qr/^\d+/,
867                                    'twitter' => qr/^\w+\s+\w+/,
868                            };
869    
870                            my ( $op, $val ) = ( $1, $2 );
871    
872                            if ( my $regex = $validate->{$op} ) {
873                                    if ( $val =~ $regex ) {
874                                            meta( $nick, $channel, $op, $val );
875                                            $res = "saved $op = $val";
876                                    } else {
877                                            $res = "config option $op = $val doesn't validate against $regex";
878                                    }
879                            } else {
880                                    $res = "config option $op doesn't exist";
881                            }
882                    }
883            } elsif ($msg =~ m/^rss-update/) {
884                    $res = rss_fetch_all( $kernel );
885            } elsif ($msg =~ m/^rss-list/) {
886                    my $sth = $dbh->prepare(qq{ select url,name,last_update,active,channel,nick,private from feeds });
887                    $sth->execute;
888                    while (my @row = $sth->fetchrow_array) {
889                            $kernel->post( $irc => privmsg => $nick, join(' | ',@row) );
890                    }
891                    $res = '';
892            } elsif ($msg =~ m!^rss-(add|remove|stop|start|clean)(?:-(private))?\s+(http://\S+)\s*(.*)!) {
893                    my ( $command, $sub, $url, $arg ) = ( $1,$2,$3,$4 );
894    
895                    my $channel = $1 if ( $arg =~ s/\s*(#\S+)\s*// );
896                    $channel = $nick if $sub eq 'private';
897    
898                    my $sql = {
899                            add     => qq{ insert into feeds (url,name,channel,nick,private) values (?,?,?,?,?) },
900                            remove  => qq{ delete from feeds                                where url = ? and nick = ? },
901                            start   => qq{ update feeds set active = true   where url = ? },
902                            stop    => qq{ update feeds set active = false  where url = ? },
903                            clean   => qq{ update feeds set last_update = now() - delay where url = ? },
904                    };
905    
906                    if ( $command eq 'add' && ! $channel ) {
907                            $res = "ERROR: got '$msg' which doesn't have #channel in it, ignoring!";
908                    } elsif (my $q = $sql->{$command} ) {
909                            my $sth = $dbh->prepare( $q );
910                            my @data = ( $url );
911                            if ( $command eq 'add' ) {
912                                    push @data, ( $arg, $channel, $nick, $sub eq 'private' ? 1 : 0 );
913                            } elsif ( $command eq 'remove' ) {
914                                    push @data, $nick;
915                            }
916                            warn "## $command SQL $q with ",dump( @data ),"\n";
917                            eval { $sth->execute( @data ) };
918                            if ($@) {
919                                    $res = "ERROR: $@";
920                            } else {
921                                    $res = "OK, RSS executed $command" .
922                                            ( $sub ? "-$sub " : ' ' ) .
923                                            ( $channel ? "on $channel " : '' ) .
924                                            "url $url";
925                                    if ( $command eq 'clean' ) {
926                                            my $seen = $_stat->{rss}->{seen} || die "no seen?";
927                                            my $want_link = $_stat->{rss}->{url2link}->{$url} || warn "no url2link($url)";
928                                            foreach my $c ( keys %$seen ) {
929                                                    my $c_hash = $seen->{$c} || die "no seen->{$c}";
930                                                    die "not HASH with rss links but ", dump($c_hash) unless ref($c_hash) eq 'HASH';
931                                                    foreach my $link ( keys %$c_hash ) {
932                                                            next unless $link eq $want_link;
933                                                            _log "RSS removed seen $c $url $link";
934                                                    }
935                                            }
936                                    } elsif ( $command eq 'add' ) {
937                                            rss_fetch_all( $kernel );
938                                    }
939                            }
940                    } else {
941                            $res = "ERROR: don't know what to do with: $msg";
942                    }
943            } elsif ($msg =~ m/^rss-clean/) {
944                    # this makes sense because we didn't catch rss-clean http://... before!
945                    $_stat->{rss} = undef;
946                    $dbh->do( qq{ update feeds set last_update = now() - delay } );
947                    $res = rss_fetch_all( $kernel );
948          }          }
949    
950            return $res;
951  }  }
952    
953  =head2 seed_tags  POE::Session->create( inline_states => {
954            _start => sub {      
955                    $_[KERNEL]->post( $irc => register => 'all' );
956                    $_[KERNEL]->post( $irc => connect => {} );
957        },
958            irc_001 => sub {
959                    my ($kernel,$sender) = @_[KERNEL,SENDER];
960                    my $poco_object = $sender->get_heap();
961                    _log "connected to",$poco_object->server_name();
962                    $kernel->post( $sender => join => $_ ) for @channels;
963                    # seen RSS cache, so don't send out messages
964                    _log rss_fetch_all( $kernel, 0 );
965                    undef;
966            },
967    #       irc_255 => sub {        # server is done blabbing
968    #               $_[KERNEL]->post( $irc => join => $CHANNEL);
969    #       },
970        irc_public => sub {
971                    my $kernel = $_[KERNEL];
972                    my $nick = (split /!/, $_[ARG0])[0];
973                    my $channel = $_[ARG1]->[0];
974                    my $msg = $_[ARG2];
975    
976  Read all tags from database and create in-memory cache for tags                  save_message( channel => $channel, me => 0, nick => $nick, message => $msg);
977                    meta( $nick, $channel, 'last-msg', $msg );
978                    rss_check_updates( $kernel );
979        },
980        irc_ctcp_action => sub {
981                    my $kernel = $_[KERNEL];
982                    my $nick = (split /!/, $_[ARG0])[0];
983                    my $channel = $_[ARG1]->[0];
984                    my $msg = $_[ARG2];
985    
986  =cut                  save_message( channel => $channel, me => 1, nick => $nick, message => $msg);
987    
988  sub seed_tags {                  if ( $use_twitter ) {
989          my $sth = $dbh->prepare(qq{ select id,message from log where message like '%//%' });                          if ( my $twitter = meta( $nick, $NICK, 'twitter' ) ) {
990          $sth->execute;                                  my ($login,$passwd) = split(/\s+/,$twitter,2);
991          while (my $row = $sth->fetchrow_hashref) {                                  _log("sending twitter for $nick/$login on $channel ");
992                  add_tag( %$row );                                  my $bot = Net::Twitter->new( username=>$login, password=>$passwd );
993          }                                  $bot->update("<${channel}> $msg");
994                            }
995                    }
996    
997          foreach my $tag (keys %$tags) {      },
998                  $cloud->add($tag, "?tag=$tag", scalar @{$tags->{$tag}} + 1);          irc_ping => sub {
999          }                  _log( "pong ", $_[ARG0] );
1000  }                  $_stat->{ping}->{ $_[ARG0] }++;
1001                    rss_check_updates( $_[KERNEL] );
1002            },
1003            irc_invite => sub {
1004                    my $kernel = $_[KERNEL];
1005                    my $nick = (split /!/, $_[ARG0])[0];
1006                    my $channel = $_[ARG1];
1007    
1008                    _log "invited to $channel by $nick";
1009    
1010                    $_[KERNEL]->post( $irc => privmsg => $nick, "how nice of you to invite me to $channel, I'll be right there..." );
1011                    $_[KERNEL]->post( $irc => 'join' => $channel );
1012    
1013            },
1014            irc_msg => sub {
1015                    my $kernel = $_[KERNEL];
1016                    my $nick = (split /!/, $_[ARG0])[0];
1017                    my $channel = $_[ARG1]->[0];
1018                    my $msg = $_[ARG2];
1019                    warn "# ARG = ",dump( @_[ARG0,ARG1,ARG2] ) if $debug;
1020    
1021  seed_tags;                  _log "<< $msg";
1022    
1023                    my $res = process_command( $_[KERNEL], $nick, $channel, $msg );
1024    
1025                    if ($res) {
1026                            _log ">> [$nick] $res";
1027                            $_[KERNEL]->post( $irc => privmsg => $nick, $res );
1028                    }
1029    
1030                    rss_check_updates( $_[KERNEL] );
1031            },
1032            irc_372 => sub {
1033                    _log "<< motd",$_[ARG0],$_[ARG1];
1034            },
1035            irc_375 => sub {
1036                    _log "<< motd", $_[ARG0], "start";
1037            },
1038            irc_376 => sub {
1039                    _log "<< motd", $_[ARG0], "end";
1040            },
1041    #       irc_433 => sub {
1042    #               print "# irc_433: ",$_[ARG1], "\n";
1043    #               warn "## indetify $NICK\n";
1044    #               $_[KERNEL]->post( $irc => privmsg => 'nickserv', "IDENTIFY $NICK" );
1045    #       },
1046    #       irc_451 # please register
1047            irc_477 => sub {
1048                    _log "<< irc_477: ",$_[ARG1];
1049                    _log ">> IDENTIFY $NICK";
1050                    $_[KERNEL]->post( $irc => privmsg => 'NickServ', "IDENTIFY $NICK" );
1051            },
1052            irc_505 => sub {
1053                    _log "<< irc_505: ",$_[ARG1];
1054                    _log ">> register $NICK";
1055                    $_[KERNEL]->post( $irc => privmsg => 'NickServ', "register $NICK" );
1056    #               $_[KERNEL]->post( $irc => privmsg => 'nickserv', "IDENTIFY $NICK" );
1057    #               $_[KERNEL]->post( $irc => privmsg => 'nickserv', "set hide email on" );
1058    #               $_[KERNEL]->post( $irc => privmsg => 'nickserv', "set email dpavlin\@rot13.org" );
1059            },
1060            irc_registered => sub {
1061                    _log "<< registered $NICK";
1062            },
1063            irc_disconnected => sub {
1064                    _log "## disconnected.. sleeping for $sleep_on_error seconds and reconnecting again";
1065                    sleep($sleep_on_error);
1066                    $_[KERNEL]->post( $irc => connect => {} );
1067            },
1068            irc_socketerr => sub {
1069                    _log "## socket error... sleeping for $sleep_on_error seconds and retry";
1070                    sleep($sleep_on_error);
1071                    $_[KERNEL]->post( $irc => connect => {} );
1072            },
1073            irc_notice => sub {
1074                    _log "<< notice from ", $_[ARG0], $_[ARG1], $_[ARG2];
1075                    my $m = $_[ARG2];
1076                    if ( $m =~ m!/msg.*(NickServ).*(IDENTIFY)!i ) {
1077                            _log ">> suggested to $1 $2";
1078                            $_[KERNEL]->post( $irc => privmsg => $1, "$2 $NICK" );
1079                    } elsif ( $m =~ m!\Q$NICK\E.*registered!i ) {
1080                            _log ">> registreted, so IDENTIFY";
1081                            $_[KERNEL]->post( $irc => privmsg => 'nickserv', "IDENTIFY $NICK" );
1082                    } else {
1083                            warn "## ignore $m\n" if $debug;
1084                    }
1085            },
1086            irc_snotice => sub {
1087                    _log "<< snotice", $_[ARG0]; #dump( $_[ARG0],$_[ARG1], $_[ARG2] );
1088                    if ( $_[ARG0] =~ m!/(QUOTE)\s+(PASS\s+\d+)!i ) {
1089                            warn ">> $1 | $2\n";
1090                            $_[KERNEL]->post( $irc => lc($1) => $2);
1091                    }
1092            },
1093        _child => sub {},
1094        _default => sub {
1095                    _log '_default SID:', $_[SESSION]->ID, $_[ARG0], dump( $_[ARG1] );
1096                    0; # false for signals
1097        },
1098            rss_response => sub {
1099                    my ($request_packet, $response_packet) = @_[ARG0, ARG1];
1100                    my $request_object  = $request_packet->[0];
1101                    my $response_object = $response_packet->[0];
1102    
1103                    my $row = delete( $_stat->{rss}->{fetch}->{ $request_object->uri } );
1104                    if ( $row ) {
1105                            $row->{xml} = $response_object->content;
1106                            rss_parse_xml( $_[KERNEL], $row );
1107                    } else {
1108                            warn "## can't find rss->fetch for ", $request_object->uri;
1109                    }
1110            },
1111       },
1112      );
1113    
1114  # http server  # http server
1115    
1116    _log "WEB archive at $url";
1117    
1118  my $httpd = POE::Component::Server::HTTP->new(  my $httpd = POE::Component::Server::HTTP->new(
1119          Port => $NICK =~ m/-dev/ ? 8001 : 8000,          Port => $http_port,
1120            PreHandler => {
1121                    '/' => sub {
1122                            $_[0]->header(Connection => 'close')
1123                    }
1124            },
1125          ContentHandler => { '/' => \&root_handler },          ContentHandler => { '/' => \&root_handler },
1126          Headers        => { Server => 'irc-logger' },          Headers        => { Server => 'irc-logger' },
1127  );  );
1128    
 my %escape = ('<'=>'&lt;', '>'=>'&gt;', '&'=>'&amp;', '"'=>'&quot;');  
 my $escape_re  = join '|' => keys %escape;  
   
1129  my $style = <<'_END_OF_STYLE_';  my $style = <<'_END_OF_STYLE_';
1130  p { margin: 0; padding: 0.1em; }  p { margin: 0; padding: 0.1em; }
1131  .time, .channel { color: #808080; font-size: 60%; }  .time, .channel { color: #808080; font-size: 60%; }
# Line 560  p { margin: 0; padding: 0.1em; } Line 1133  p { margin: 0; padding: 0.1em; }
1133  .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 ; }
1134  .message { color: #000000; font-size: 100%; }  .message { color: #000000; font-size: 100%; }
1135  .search { float: right; }  .search { float: right; }
1136    a:link.tag, a:visited.tag { border: 1px dashed #ccc; backgound: #ccc; text-decoration: none }
1137    a:hover.tag { border: 1px solid #eee }
1138    hr { border: 1px dashed #ccc; height: 1px; clear: both; }
1139    /*
1140  .col-0 { background: #ffff66 }  .col-0 { background: #ffff66 }
1141  .col-1 { background: #a0ffff }  .col-1 { background: #a0ffff }
1142  .col-2 { background: #99ff99 }  .col-2 { background: #99ff99 }
1143  .col-3 { background: #ff9999 }  .col-3 { background: #ff9999 }
1144  .col-4 { background: #ff66ff }  .col-4 { background: #ff66ff }
1145  a:link.tag, a:visited.tag { border: 1px dashed #ccc; backgound: #ccc; text-decoration: none }  */
1146  a:hover.tag { border: 1px solid #eee }  .calendar { border: 1px solid red; width: 100%; }
1147  hr { border: 1px dashed #ccc; height: 1px; clear: both; }  .month { border: 0px; width: 100%; }
1148  _END_OF_STYLE_  _END_OF_STYLE_
1149    
1150  my $max_color = 4;  $max_color = 0;
1151    
1152  my %nick_enumerator;  my @cols = qw(
1153            #ffcccc #ccffe6 #ccccff #e6ccff #ffccff #ffcce6 #ff9999 #ffcc99 #ffff99
1154            #ccff99 #99ff99 #99ffcc #99ccff #9999ff #cc99ff #ff6666 #ffb366 #ffff66
1155            #66ff66 #66ffb3 #66b3ff #6666ff #ff3333 #33ff33 #3399ff #3333ff #ff3399
1156            #a0a0a0 #ff0000 #ffff00 #80ff00 #0000ff #8000ff #ff00ff #ff0080 #994d00
1157            #999900 #009900 #cc0066 #c0c0c0 #ccff99 #99ff33 #808080 #660033 #ffffff
1158    );
1159    
1160    foreach my $c (@cols) {
1161            $style .= ".col-${max_color} { background: $c }\n";
1162            $max_color++;
1163    }
1164    _log "WEB defined $max_color colors for users...";
1165    
1166  sub root_handler {  sub root_handler {
1167          my ($request, $response) = @_;          my ($request, $response) = @_;
1168          $response->code(RC_OK);          $response->code(RC_OK);
1169          $response->content_type("text/html; charset=$ENCODING");  
1170            # this doesn't seem to work, so moved to PreHandler
1171            #$response->header(Connection => 'close');
1172    
1173            return RC_OK if $request->uri =~ m/favicon.ico$/;
1174    
1175          my $q;          my $q;
1176    
# Line 590  sub root_handler { Line 1183  sub root_handler {
1183          }          }
1184    
1185          my $search = $q->param('search') || $q->param('grep') || '';          my $search = $q->param('search') || $q->param('grep') || '';
1186            my $r_url = $request->url;
1187    
1188            my @commands = qw( tags last-tag follow stat );
1189            my $commands_re = join('|',@commands);
1190    
1191            if ($r_url =~ m#/rss(?:/($commands_re.*)\w*(?:=(\d+))?)?#i) {
1192                    my $show = lc($1);
1193                    my $nr = $2;
1194    
1195                    my $type = 'RSS';       # Atom
1196    
1197                    $response->content_type( 'application/' . lc($type) . '+xml' );
1198    
1199                    my $html = '<!-- error -->';
1200                    #warn "create $type feed from ",dump( $cloud->last_tags );
1201    
1202                    my $feed = XML::Feed->new( $type );
1203                    $feed->link( $url );
1204    
1205                    my $rc = RC_OK;
1206    
1207                    if ( $show eq 'tags' ) {
1208                            $nr ||= 50;
1209                            $feed->title( "tags from $CHANNEL" );
1210                            $feed->link( "$url/tags" );
1211                            $feed->description( "tag cloud created from messages on channel $CHANNEL which have tags// in them" );
1212                            my $feed_entry = XML::Feed::Entry->new($type);
1213                            $feed_entry->title( "$nr tags from $CHANNEL" );
1214                            $feed_entry->author( $NICK );
1215                            $feed_entry->link( '/#tags'  );
1216    
1217                            $feed_entry->content(
1218                                    qq{<![CDATA[<style type="text/css">}
1219                                    . $cloud->css
1220                                    . qq{</style>}
1221                                    . $cloud->html( $nr )
1222                                    . qq{]]>}
1223                            );
1224                            $feed->add_entry( $feed_entry );
1225    
1226                    } elsif ( $show eq 'last-tag' ) {
1227    
1228                            $nr ||= $last_x_tags;
1229                            $nr = $last_x_tags if $nr > $last_x_tags;
1230    
1231                            $feed->title( "last $nr tagged messages from $CHANNEL" );
1232                            $feed->description( "collects messages which have tags// in them" );
1233    
1234                            foreach my $m ( $cloud->last_tags ) {
1235    #                               warn dump( $m );
1236                                    #my $tags = join(' ', @{$m->{tags}} );
1237                                    my $feed_entry = XML::Feed::Entry->new($type);
1238                                    $feed_entry->title( $m->{nick} . '@' . $m->{time} );
1239                                    $feed_entry->author( $m->{nick} );
1240                                    $feed_entry->link( '/#' . $m->{id}  );
1241                                    $feed_entry->issued( DateTime::Format::Flexible->build( $m->{time} ) );
1242    
1243                                    my $message = $filter->{message}->( $m->{message} );
1244                                    $message .= "<br/>\n" unless $message =~ m!<(/p|br/?)>!;
1245    #                               warn "## message = $message\n";
1246    
1247                                    #$feed_entry->summary(
1248                                    $feed_entry->content(
1249                                            "<![CDATA[$message]]>"
1250                                    );
1251                                    $feed_entry->category( join(', ', @{$m->{tags}}) );
1252                                    $feed->add_entry( $feed_entry );
1253    
1254                                    $nr--;
1255                                    last if $nr <= 0;
1256    
1257                            }
1258    
1259                    } elsif ( $show =~ m/^follow/ ) {
1260    
1261                            $feed->title( "Feeds which this bot follows" );
1262    
1263                            my $sth = $dbh->prepare( qq{ select * from feeds order by last_update desc } );
1264                            $sth->execute;
1265                            while (my $row = $sth->fetchrow_hashref) {
1266                                    my $feed_entry = XML::Feed::Entry->new($type);
1267                                    $feed_entry->title( $row->{name} );
1268                                    $feed_entry->link( $row->{url}  );
1269                                    $feed_entry->issued( DateTime::Format::Flexible->build( $row->{last_update} ) );
1270                                    $feed_entry->content(
1271                                            '<![CDATA[<pre>' . dump( $row ) . '</pre>]]>'
1272                                    );
1273                                    $feed->add_entry( $feed_entry );
1274                            }
1275    
1276                    } elsif ( $show =~ m/^stat/ ) {
1277    
1278                            my $feed_entry = XML::Feed::Entry->new($type);
1279                            $feed_entry->title( "Internal stats" );
1280                            $feed_entry->content(
1281                                    '<![CDATA[<pre>' . dump( $_stat ) . '</pre>]]>'
1282                            );
1283                            $feed->add_entry( $feed_entry );
1284    
1285                    } else {
1286                            _log "WEB unknown rss request $r_url";
1287                            $feed->title( "unknown $r_url" );
1288                            foreach my $c ( @commands ) {
1289                                    my $feed_entry = XML::Feed::Entry->new($type);
1290                                    $feed_entry->title( "rss/$c" );
1291                                    $feed_entry->link( "$url/rss/$c" );
1292                                    $feed->add_entry( $feed_entry );
1293                            }
1294                            $rc = RC_DENY;
1295                    }
1296    
1297                    eval { $response->content( $feed->as_xml ); };
1298                    $rc = RC_INTERNAL_SERVER_ERROR if $@;
1299                    return $rc;
1300            }
1301    
1302            if ( $@ ) {
1303                    warn "$@";
1304            }
1305    
1306            $response->content_type("text/html; charset=UTF-8");
1307    
1308          my $html =          my $html =
1309                  qq{<html><head><title>$NICK</title><style type="text/css">$style} .                  qq{<html><head><title>$NICK</title><style type="text/css">$style}
1310                  $cloud->css .                  . $cloud->css
1311                  qq{</style></head><body>} .                  . qq{</style></head><body>}
1312                  qq{                  . qq{
1313                  <form method="post" class="search" action="/">                  <form method="post" class="search" action="/">
1314                  <input type="text" name="search" value="$search" size="10">                  <input type="text" name="search" value="$search" size="10">
1315                  <input type="submit" value="search">                  <input type="submit" value="search">
1316                  </form>                  </form>
1317                  } .                  }
1318                  $cloud->html(500) .                  . $cloud->html(500)
1319                  qq{<p>};                  . qq{<p>};
1320          if ($request->url =~ m#/history#) {  
1321            if ($request->url =~ m#/tags?#) {
1322                    # nop
1323            } elsif ($request->url =~ m#/history#) {
1324                  my $sth = $dbh->prepare(qq{                  my $sth = $dbh->prepare(qq{
1325                          select date(time) as date,count(*) as nr                          select date(time) as date,count(*) as nr,sum(length(message)) as len
1326                                  from log                                  from log
1327                                  group by date(time)                                  group by date(time)
1328                                  order by date(time) desc                                  order by date(time) desc
1329                  });                  });
1330                  $sth->execute();                  $sth->execute();
1331                  my ($l_yyyy,$l_mm) = (0,0);                  my ($l_yyyy,$l_mm) = (0,0);
1332                    $html .= qq{<table class="calendar"><tr>};
1333                  my $cal;                  my $cal;
1334                    my $ord = 0;
1335                  while (my $row = $sth->fetchrow_hashref) {                  while (my $row = $sth->fetchrow_hashref) {
1336                          # this is probably PostgreSQL specific, expects ISO date                          # this is probably PostgreSQL specific, expects ISO date
1337                          my ($yyyy,$mm,$dd) = split(/-/, $row->{date});                          my ($yyyy,$mm,$dd) = split(/-/, $row->{date});
1338                          if ($yyyy != $l_yyyy || $mm != $l_mm) {                          if ($yyyy != $l_yyyy || $mm != $l_mm) {
1339                                  $html .= $cal->as_HTML() if ($cal);                                  if ( $cal ) {
1340                                            $html .= qq{<td valign="top">} . $cal->as_HTML() . qq{</td>};
1341                                            $ord++;
1342                                            $html .= qq{</tr><tr>} if ( $ord % 3 == 0 );
1343                                    }
1344                                  $cal = new HTML::CalendarMonthSimple('month'=>$mm,'year'=>$yyyy);                                  $cal = new HTML::CalendarMonthSimple('month'=>$mm,'year'=>$yyyy);
1345                                  $cal->border(2);                                  $cal->border(1);
1346                                    $cal->width('30%');
1347                                    $cal->cellheight('5em');
1348                                    $cal->tableclass('month');
1349                                    #$cal->cellclass('day');
1350                                    $cal->sunday('SUN');
1351                                    $cal->saturday('SAT');
1352                                    $cal->weekdays('MON','TUE','WED','THU','FRI');
1353                                  ($l_yyyy,$l_mm) = ($yyyy,$mm);                                  ($l_yyyy,$l_mm) = ($yyyy,$mm);
1354                          }                          }
1355                          $cal->setcontent($dd, qq{                          $cal->setcontent($dd, qq[
1356                                  <a href="/?date=$row->{date}">$row->{nr}</a>                                  <a href="$url?date=$row->{date}">$row->{nr}</a><br/>$row->{len}
1357                          });                          ]) if $cal;
1358                            
1359                  }                  }
1360                  $html .= $cal->as_HTML() if ($cal);                  $html .= qq{<td valign="top">} . $cal->as_HTML() . qq{</td></tr></table>};
1361    
1362          } else {          } else {
1363                  $html .= join("</p><p>",                  $html .= join("</p><p>",
1364                          get_from_log(                          get_from_log(
1365                                  limit => $q->param('last') || $q->param('date') ? undef : 100,                                  limit => ( $q->param('date') ? undef : $q->param('last') || 100 ),
1366                                  search => $search || undef,                                  search => $search || undef,
1367                                  tag => $q->param('tag') || undef,                                  tag => $q->param('tag') || undef,
1368                                  date => $q->param('date') || undef,                                  date => $q->param('date') || undef,
1369                                  fmt => {                                  fmt => {
1370                                          date => sub {                                          date => sub {
1371                                                  my $date = shift || return;                                                  my $date = shift || return;
1372                                                  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>};
1373                                          },                                          },
1374                                          time => '<span class="time">%s</span> ',                                          time => '<span class="time">%s</span> ',
1375                                          time_channel => '<span class="channel">%s %s</span> ',                                          time_channel => '<span class="channel">%s %s</span> ',
# Line 646  sub root_handler { Line 1377  sub root_handler {
1377                                          me_nick => '***%s&nbsp;',                                          me_nick => '***%s&nbsp;',
1378                                          message => '<span class="message">%s</span>',                                          message => '<span class="message">%s</span>',
1379                                  },                                  },
1380                                  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>';  
                                         },  
                                 },  
1381                          )                          )
1382                  );                  );
1383          }          }
# Line 675  sub root_handler { Line 1388  sub root_handler {
1388          </body></html>};          </body></html>};
1389    
1390          $response->content( $html );          $response->content( $html );
1391            warn "<< ", $request->method, " ", $request->uri, " created ", length($html), " bytes\n";
1392          return RC_OK;          return RC_OK;
1393  }  }
1394    
1395  POE::Kernel->run;  POE::Kernel->run;
1396    
1397    =head1 TagCloud
1398    
1399    Extended L<HTML::TagCloud>
1400    
1401    =cut
1402    
1403    package TagCloud;
1404    use warnings;
1405    use strict;
1406    use HTML::TagCloud;
1407    use base 'HTML::TagCloud';
1408    use Data::Dump qw/dump/;
1409    
1410    =head2 html
1411    
1412    Generate html with number of tags in title of link
1413    
1414    =cut
1415    
1416    sub html {
1417            my($self, $limit) = @_;
1418            my @tags=$self->tags($limit);
1419    
1420            my $ntags = scalar(@tags);
1421            if ($ntags == 0) {
1422                    return "";
1423    #       } elsif ($ntags == 1) {
1424    #               my $tag = $tags[0];
1425    #               return qq{<div id="htmltagcloud"><span class="tagcloud1"><a href="}.
1426    #               $tag->{url}.qq{">}.$tag->{name}.qq{</a></span></div>\n};
1427            }
1428    
1429      my $html = qq{<div id="htmltagcloud">};
1430      foreach my $tag ( sort { lc($a->{name}) cmp lc($b->{name}) } @tags) {
1431        $html .=  sprintf(qq{<span class="tag tagcloud%d"><a href="%s" title="%s">%s</a></span>\n},
1432                    $tag->{level}, $tag->{url}, $tag->{count}, $tag->{name}
1433            );
1434      }
1435      $html .= qq{</div>};
1436      return $html;
1437    }
1438    
1439    =head2 last_tags
1440    
1441      my @tags = $cloud->last_tags;
1442    
1443    =cut
1444    
1445    my @last_tags;
1446    sub last_tags {
1447            return @last_tags;
1448    }
1449    
1450    =head2 add_tag
1451    
1452     $cloud->add_tag( id => 42, message => 'irc message', nick => 'foobar' [, me => 1 ] );
1453    
1454    =cut
1455    
1456    
1457    sub add_tag {
1458            my $self = shift;
1459            my $arg = {@_};
1460    
1461            return unless ($arg->{id} && $arg->{message});
1462    
1463            my $m = $arg->{message};
1464    
1465            my @tags;
1466    
1467            while ($m =~ s#$tag_regex##s) {
1468                    my $tag = $1;
1469                    next if (! $tag || $tag =~ m/https?:/i);
1470                    push @{ $tags->{$tag} }, $arg->{id};
1471                    #warn "+tag $tag: $arg->{id}\n";
1472                    $self->add($tag, "$url?tag=$tag", scalar @{$tags->{$tag}});
1473                    push @tags, $tag;
1474    
1475            }
1476    
1477            if ( @tags ) {
1478                    pop @last_tags if $#last_tags == $last_x_tags;
1479                    unshift @last_tags, { tags => [ @tags ], %$arg };
1480            }
1481    
1482    }
1483    
1484    =head2 seed_tags
1485    
1486    Read all tags from database and create in-memory cache for tags
1487    
1488    =cut
1489    
1490    sub seed_tags {
1491            my $self = shift;
1492            my $sth = $dbh->prepare(qq{ select id,message,nick,me,time from log where message like '%//%' order by time asc });
1493            $sth->execute;
1494            while (my $row = $sth->fetchrow_hashref) {
1495                    $self->add_tag( %$row );
1496            }
1497    
1498            foreach my $tag (keys %$tags) {
1499                    $self->add($tag, "$url?tag=$tag", scalar @{$tags->{$tag}});
1500            }
1501    }
1502    
Legend:
Removed from v.36  
changed lines
  Added in v.140
  ViewVC Help
Powered by ViewVC 1.1.26