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