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

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

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

revision 92 by dpavlin, Fri Mar 7 10:30:57 2008 UTC revision 150 by dpavlin, Sat Oct 8 18:43:21 2011 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    #use Redis 2.0;
22    
23  =head1 NAME  =head1 NAME
24    
25  irc-logger.pl  irc-logger.pl
# Line 30  log all conversation on irc channel Line 48  log all conversation on irc channel
48    
49  ## CONFIG  ## CONFIG
50    
51    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`;  my $HOSTNAME = `hostname -f`;
61  chomp($HOSTNAME);  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';
65  $CHANNEL = '#irc-logger' if ($HOSTNAME =~ m/llin/);  
66  my $IRC_ALIAS = "log";  if ( $HOSTNAME =~ m/llin/ ) {
67            $irc_config->{nick} = 'irc-logger-llin';
68    #       $irc_config = {
69    #               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    
# Line 55  my $last_x_tags = 50; Line 93  my $last_x_tags = 50;
93    
94  # don't pull rss feeds more often than this  # don't pull rss feeds more often than this
95  my $rss_min_delay = 60;  my $rss_min_delay = 60;
 $rss_min_delay = 15;  
96    
97  my $http_port = $NICK =~ m/-dev/ ? 8001 : 8000;  my $http_port = $NICK =~ m/-dev/ ? 8001 : 8000;
98    
# Line 63  my $url = "http://$HOSTNAME:$http_port"; Line 100  my $url = "http://$HOSTNAME:$http_port";
100    
101  ## END CONFIG  ## END CONFIG
102    
 use POE qw(Component::IRC Component::Server::HTTP);  
 use HTTP::Status;  
 use DBI;  
 use Regexp::Common qw /URI/;  
 use CGI::Simple;  
 use HTML::TagCloud;  
 use POSIX qw/strftime/;  
 use HTML::CalendarMonthSimple;  
 use Getopt::Long;  
 use DateTime;  
 use URI::Escape;  
 use Data::Dump qw/dump/;  
 use DateTime::Format::ISO8601;  
 use Carp qw/confess/;  
 use XML::Feed;  
 use DateTime::Format::Flexible;  
   
103  my $use_twitter = 1;  my $use_twitter = 1;
104  eval { require Net::Twitter; };  eval { require Net::Twitter; };
105  $use_twitter = 0 if ($@);  $use_twitter = 0 if ($@);
# Line 89  my $log_path; Line 109  my $log_path;
109  GetOptions(  GetOptions(
110          'import-dircproxy:s' => \$import_dircproxy,          'import-dircproxy:s' => \$import_dircproxy,
111          'log:s' => \$log_path,          'log:s' => \$log_path,
112            'debug!' => \$debug,
113  );  );
114    
115  #$SIG{__DIE__} = sub {  #$SIG{__DIE__} = sub {
116  #       confess "fatal error";  #       confess "fatal error";
117  #};  #};
118    
 open(STDOUT, '>', $log_path) || warn "can't redirect log to $log_path: $!";  
   
119  sub _log {  sub _log {
120          print strftime($TIMESTAMP,localtime()) . ' ' . join(" ",@_) . $/;          print strftime($TIMESTAMP,localtime()) . ' ' . join(" ",map { ref($_) ? dump( $_ ) : $_ } @_) . $/;
121  }  }
122    
123    open(STDOUT, '>', $log_path) && warn "log to $log_path: $!\n";
124    
125    
126  # HTML formatters  # HTML formatters
127    
128  my %escape = ('<'=>'&lt;', '>'=>'&gt;', '&'=>'&amp;', '"'=>'&quot;');  my %escape = ('<'=>'&lt;', '>'=>'&gt;', '&'=>'&amp;', '"'=>'&quot;');
129  my $escape_re  = join '|' => keys %escape;  my $escape_re  = join '|' => keys %escape;
130    
131  my $tag_regex = '\b([\w-_]+)//';  my $tag_regex = '\b([\w\-_]+)//';
132    
133  my %nick_enumerator;  my %nick_enumerator;
134  my $max_color = 0;  my $max_color = 0;
# Line 118  my $filter = { Line 140  my $filter = {
140                  # protect HTML from wiki modifications                  # protect HTML from wiki modifications
141                  sub e {                  sub e {
142                          my $t = shift;                          my $t = shift;
143                          return 'uri_unescape{' . uri_escape($t) . '}';                          eval { $t = 'uri_unescape{' . uri_escape($t, '^a-zA-Z0-9') . '}'; };
144                            return $t;
145                  }                  }
146    
147                  $m =~ s/($escape_re)/$escape{$1}/gs;                  $m =~ s/($escape_re)/$escape{$1}/gs;
148                  $m =~ s#($RE{URI}{HTTP})#e(qq{<a href="$1">$1</a>})#egs ||                  $m =~ s#($RE{URI}{HTTP})#e(qq{<a href="$1">$1</a>})#egs;
149                  $m =~ s#\/(\w+)\/#<i>$1</i>#gs;  #               $m =~ s#\/(\w+)\/#<i>$1</i>#gs;
150                  $m =~ s#$tag_regex#e(qq{<a href="$url?tag=$1" class="tag">$1</a>})#egs;                  $m =~ s#$tag_regex#e(qq{<a href="$url?tag=$1" class="tag">$1</a>})#egs;
151                  $m =~ s#\*(\w+)\*#<b>$1</b>#gs;                  $m =~ s#\*(\w+)\*#<b>$1</b>#gs;
152                  $m =~ s#_(\w+)_#<u>$1</u>#gs;                  $m =~ s#_(\w+)_#<u>$1</u>#gs;
# Line 143  my $filter = { Line 166  my $filter = {
166          },          },
167  };  };
168    
169    # POE IRC
170    my $poe_irc = POE::Component::IRC->spawn( %$irc_config ) or
171            die "can't start ", dump( $irc_config ), ": $!";
172    
173    my $irc = $poe_irc->session_id();
174    _log "IRC session_id $irc";
175    
176  my $dbh = DBI->connect($DSN,"","", { RaiseError => 1, AutoCommit => 1 }) || die $DBI::errstr;  my $dbh = DBI->connect($DSN,"","", { RaiseError => 1, AutoCommit => 1 }) || die $DBI::errstr;
177  $dbh->do( qq{ set client_encoding = 'UTF-8' } );  $dbh->do( qq{ set client_encoding = 'UTF-8' } );
178    
# Line 179  create table feeds ( Line 209  create table feeds (
209          name text,          name text,
210          delay interval not null default '5 min',          delay interval not null default '5 min',
211          active boolean default true,          active boolean default true,
212            channel text not null,
213            nick text not null,
214            private boolean default false,
215          last_update timestamp default 'now()',          last_update timestamp default 'now()',
216          polls int default 0,          polls int default 0,
217          updates int default 0          updates int default 0
218  );  );
219  create unique index feeds_url on feeds(url);  create unique index feeds_url on feeds(url);
220  insert into feeds (url,name) values ('http://wiki.razmjenavjestina.org/feed/workspace/razmjenavjestina?category=Recent%20Changes','wiki');  insert into feeds (url,name,channel,nick) values ('http://wiki.razmjenavjestina.org/feed/workspace/razmjenavjestina?category=Recent%20Changes','wiki','$CHANNEL','dpavlin');
221          },          },
222  };  };
223    
# Line 224  sub meta { Line 257  sub meta {
257    
258                  eval { $sth->execute( $value, $nick, $channel, $name ) };                  eval { $sth->execute( $value, $nick, $channel, $name ) };
259    
260                  # error or no result                  if ( $@ ) {
261                  if ( $@ || ! $sth->rows ) {                          # error
262                            _log("META ERROR: $@");
263                    } elsif ( ! $sth->rows ) {
264                            # no result -> add new
265                          $sth = $dbh->prepare(qq{ insert into meta (value,nick,channel,name,changed) values (?,?,?,?,now()) });                          $sth = $dbh->prepare(qq{ insert into meta (value,nick,channel,name,changed) values (?,?,?,?,now()) });
266                          $sth->execute( $value, $nick, $channel, $name );                          eval { $sth->execute( $value, $nick, $channel, $name ); };
267                          _log "created $nick/$channel/$name = $value";                          if ( $@ ) {
268                                    _log "META ERROR: $@";
269                            } else {
270                                    _log "META: created $nick/$channel/$name = $value\n";
271                            }
272                  } else {                  } else {
273                          _log "updated $nick/$channel/$name = $value ";                          _log "META: updated $nick/$channel/$name = $value\n";
274                  }                  }
275    
276                  return $value;                  return $value;
# Line 240  sub meta { Line 280  sub meta {
280                  my $sth = $dbh->prepare(qq{ select value,changed from meta where nick = ? and channel = ? and name = ? });                  my $sth = $dbh->prepare(qq{ select value,changed from meta where nick = ? and channel = ? and name = ? });
281                  $sth->execute( $nick, $channel, $name );                  $sth->execute( $nick, $channel, $name );
282                  my ($v,$c) = $sth->fetchrow_array;                  my ($v,$c) = $sth->fetchrow_array;
283                  _log "fetched $nick/$channel/$name = $v [$c]";                  warn "## fetched $nick/$channel/$name = $v [$c]\n";
284                  return ($v,$c) if wantarray;                  return ($v,$c) if wantarray;
285                  return $v;                  return $v;
286    
# Line 337  sub get_from_log { Line 377  sub get_from_log {
377    
378          my @where;          my @where;
379          my @args;          my @args;
380            my $msg;
381    
382          if (my $search = $args->{search}) {          if (my $search = $args->{search}) {
383                  $search =~ s/^\s+//;                  $search =~ s/^\s+//;
384                  $search =~ s/\s+$//;                  $search =~ s/\s+$//;
385                  push @where, 'message ilike ? or nick ilike ?';                  push @where, 'message ilike ? or nick ilike ?';
386                  push @args, ( ( '%' . $search . '%' ) x 2 );                  push @args, ( ( '%' . $search . '%' ) x 2 );
387                  _log "search for '$search'";                  $msg = "Search for '$search'";
388          }          }
389    
390          if ($args->{tag} && $tags->{ $args->{tag} }) {          if ($args->{tag} && $tags->{ $args->{tag} }) {
391                  push @where, 'id in (' . join(',', @{ $tags->{ $args->{tag} } }) . ')';                  push @where, 'id in (' . join(',', @{ $tags->{ $args->{tag} } }) . ')';
392                  _log "search for tags $args->{tag}";                  $msg = "Search for tags $args->{tag}";
393          }          }
394    
395          if (my $date = $args->{date} ) {          if (my $date = $args->{date} ) {
396                  $date = check_date( $date );                  $date = check_date( $date );
397                  push @where, 'date(time) = ?';                  push @where, 'date(time) = ?';
398                  push @args, $date;                  push @args, $date;
399                  _log "search for date $date";                  $msg = "search for date $date";
400          }          }
401    
402          $sql .= " where " . join(" and ", @where) if @where;          $sql .= " where " . join(" and ", @where) if @where;
# Line 369  sub get_from_log { Line 410  sub get_from_log {
410          eval { $sth->execute( @args ) };          eval { $sth->execute( @args ) };
411          return if $@;          return if $@;
412    
413            my $nr_results = $sth->rows;
414    
415          my $last_row = {          my $last_row = {
416                  date => '',                  date => '',
417                  time => '',                  time => '',
# Line 389  sub get_from_log { Line 432  sub get_from_log {
432    
433          return @rows if ($args->{full_rows});          return @rows if ($args->{full_rows});
434    
435          my @msgs = (          $msg .= ' produced ' . (
436                  "Showing " . ($#rows + 1) . " messages..."                  $nr_results == 0 ? 'no results' :
437                    $nr_results == 0 ? 'one result' :
438                            $nr_results . ' results'
439          );          );
440    
441            my @msgs = ( $msg );
442    
443          if ($context) {          if ($context) {
444                  my @ids = @rows;                  my @ids = @rows;
445                  @rows = ();                  @rows = ();
# Line 449  sub get_from_log { Line 496  sub get_from_log {
496  #                       $row->{nick} = $nick;  #                       $row->{nick} = $nick;
497  #               }  #               }
498    
499                    $append = 0 if $row->{me};
500    
501                  if ($last_row->{nick} ne $nick) {                  if ($last_row->{nick} ne $nick) {
502                          # 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
503                          my $fmt = $row->{me} ? ( $args->{fmt}->{me_nick} || $args->{fmt}->{nick} ) : $args->{fmt}->{nick};                          my $fmt = $row->{me} ? ( $args->{fmt}->{me_nick} || $args->{fmt}->{nick} ) : $args->{fmt}->{nick};
# Line 485  sub get_from_log { Line 534  sub get_from_log {
534    
535  # tags support  # tags support
536    
537  my $cloud = HTML::TagCloud->new;  my $cloud = TagCloud->new;
538    $cloud->seed_tags;
 =head2 add_tag  
   
  add_tag( id => 42, message => 'irc message', nick => 'foobar' [, me => 1 ] );  
   
 =cut  
   
 my @last_tags;  
   
 sub add_tag {  
         my $arg = {@_};  
   
         return unless ($arg->{id} && $arg->{message});  
   
         my $m = $arg->{message};  
   
         my @tags;  
   
         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, "$url?tag=$tag", scalar @{$tags->{$tag}} + 1);  
                 push @tags, $tag;  
   
         }  
   
         if ( @tags ) {  
                 pop @last_tags if $#last_tags == $last_x_tags;  
                 unshift @last_tags, { tags => [ @tags ], %$arg };  
         }  
   
 }  
   
 =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,nick,me,time from log where message like '%//%' order by time asc });  
         $sth->execute;  
         while (my $row = $sth->fetchrow_hashref) {  
                 add_tag( %$row );  
         }  
   
         foreach my $tag (keys %$tags) {  
                 $cloud->add($tag, "$url?tag=$tag", scalar @{$tags->{$tag}} + 1);  
         }  
 }  
   
 seed_tags;  
   
539    
540  =head2 save_message  =head2 save_message
541    
# Line 564  sub save_message { Line 559  sub save_message {
559          $a->{me} ||= 0;          $a->{me} ||= 0;
560          $a->{time} ||= strftime($TIMESTAMP,localtime());          $a->{time} ||= strftime($TIMESTAMP,localtime());
561    
562          _log          _log "ARCHIVE",
563                  $a->{channel}, " ",                  $a->{channel}, " ",
564                  $a->{me} ? "***" . $a->{nick} : "<" . $a->{nick} . ">",                  $a->{me} ? "***" . $a->{nick} : "<" . $a->{nick} . ">",
565                  " " . $a->{message};                  " " . $a->{message};
566    
567          $sth_insert_log->execute($a->{channel}, $a->{me}, $a->{nick}, $a->{message}, $a->{time});          eval { $sth_insert_log->execute($a->{channel}, $a->{me}, $a->{nick}, $a->{message}, $a->{time}); };
568          add_tag( id => $dbh->last_insert_id(undef,undef,"log",undef), %$a );  
569            eval {
570            my @channel = ( 'channel' , $a->{channel}, $a->{nick} );
571            push @channel, 'me' if $a->{me};
572    #       my $redis = Redis->new( server => '192.168.1.61:6379' );
573    #       $redis->publish( join(' ',@channel), $a->{message} );
574            };
575    
576            if ( $@ ) {
577                    _log "ERROR: can't archive ", $a->{message};
578            } else {
579                    $cloud->add_tag( id => $dbh->last_insert_id(undef,undef,"log",undef), %$a );
580            }
581  }  }
582    
583    
584  if ($import_dircproxy) {  if ($import_dircproxy) {
585            my ( $from_time, $date_time ) = $dbh->selectrow_array(qq{
586                    select date_part('epoch',max(time)),max(time) from log
587            });
588    
589            warn "IMPORT $date_time [$from_time]\n";
590    
591          open(my $l, $import_dircproxy) || die "can't open $import_dircproxy: $!";          open(my $l, $import_dircproxy) || die "can't open $import_dircproxy: $!";
592          warn "importing $import_dircproxy...\n";          warn "importing $import_dircproxy...\n";
593          my $tz_offset = 1 * 60 * 60;    # TZ GMT+2          my $tz_offset = 1 * 60 * 60;    # TZ GMT+2
# Line 583  if ($import_dircproxy) { Line 596  if ($import_dircproxy) {
596                  if (/^@(\d+)\s(\S+)\s(.+)$/) {                  if (/^@(\d+)\s(\S+)\s(.+)$/) {
597                          my ($time, $nick, $msg) = ($1,$2,$3);                          my ($time, $nick, $msg) = ($1,$2,$3);
598    
599                            next if $time <= $from_time;
600    
601                          my $dt = DateTime->from_epoch( epoch => $time + $tz_offset );                          my $dt = DateTime->from_epoch( epoch => $time + $tz_offset );
602    
603                          my $me = 0;                          my $me = 0;
# Line 612  if ($import_dircproxy) { Line 627  if ($import_dircproxy) {
627  # RSS follow  # RSS follow
628  #  #
629    
630  my $_rss;  my $_stat;
631    
632    POE::Component::Client::HTTP->spawn(
633            Alias   => 'rss-fetch',
634            Timeout => 30,
635    );
636    
637  sub rss_fetch {  =head2 rss_parse_xml
638          my ($args) = @_;  
639      rss_parse_xml({
640            url => 'http://www.example.com/rss',
641            send_rss_msgs => 42,
642      });
643    
644    =cut
645    
646    sub rss_parse_xml {
647            my ($kernel,$args) = @_;
648    
649            warn "## rss_parse_xml ",dump( $args ) if $debug;
650    
651          # how many messages to send out when feed is seen for the first time?          # how many messages to send out when feed is seen for the first time?
652          my $send_rss_msgs = 1;          my $send_rss_msgs = $args->{send_rss_msgs};
653            $send_rss_msgs = 1 if ! defined $send_rss_msgs;
654    
655          _log "RSS fetch", $args->{url};          warn "## RSS fetch first $send_rss_msgs items from", $args->{url} if $debug;
656    
657          my $feed = XML::Feed->parse(URI->new( $args->{url} ));          my $feed;
658            eval { $feed = XML::Feed->parse( \$args->{xml} ) };
659          if ( ! $feed ) {          if ( ! $feed ) {
660                  _log("can't fetch RSS ", $args->{url});                  _log "can't fetch RSS ", $args->{url}, XML::Feed->errstr;
661                  return;                  return;
662          }          }
663    
664            $_stat->{rss}->{url2link}->{ $args->{url} } = $feed->link;
665    
666          my ( $total, $updates ) = ( 0, 0 );          my ( $total, $updates ) = ( 0, 0 );
667          for my $entry ($feed->entries) {          for my $entry ($feed->entries) {
668                  $total++;                  $total++;
669    
670                    my $seen_times = $_stat->{rss}->{seen}->{$args->{channel}}->{$feed->link}->{$entry->id}++;
671                  # seen allready?                  # seen allready?
672                  next if $_rss->{$feed->link}->{seen}->{$entry->id}++ > 0;                  warn "## $seen_times ",$entry->id if $debug;
673                    next if $seen_times > 0;
674    
675                  sub prefix {                  sub prefix {
676                          my ($txt,$var) = @_;                          my ($txt,$var) = @_;
677                            $var =~ s/\s+/ /gs;
678                          $var =~ s/^\s+//g;                          $var =~ s/^\s+//g;
679                            $var =~ s/\s+$//g;
680                          return $txt . $var if $var;                          return $txt . $var if $var;
681                  }                  }
682    
683                    # fix absolute and relative links to feed entries
684                    my $link = $entry->link;
685                    if ( $link =~ m!^/! ) {
686                            my $host = $args->{url};
687                            $host =~ s!^(http://[^/]+).*$!$1!;      #!vim
688                            $link = "$host/$link";
689                    } elsif ( $link !~ m!^http! ) {
690                            $link = $args->{url} . $link;
691                    }
692    
693                  my $msg;                  my $msg;
694                  $msg .= prefix( 'From: ' , $args->{name} || $feed->title );                  $msg .= prefix( 'From: ' , $args->{name} || $feed->title );
695                  $msg .= prefix( ' by ' , $entry->author );                  $msg .= prefix( ' by ' , $entry->author );
696                  $msg .= prefix( ' | ' , $entry->title );                  $msg .= prefix( ' | ' , $entry->title );
697                  $msg .= prefix( ' | ' , $entry->link );                  $msg .= prefix( ' | ' , $link );
698  #               $msg .= prefix( ' id ' , $entry->id );  #               $msg .= prefix( ' id ' , $entry->id );
699                    my @categories = $entry->category;
700                    warn "## category = ", dump( @categories ) if $debug;
701                    if ( my $tags = $entry->category ) {
702                            $tags = join(' ', @$tags) if ref($tags) eq 'ARRAY';
703                            $tags =~ s!^\s+!!;
704                            $tags =~ s!\s*$! !;
705                            $tags =~ s!,?\s+!// !g;
706                            $msg .= prefix( ' ' , $tags );
707                    }
708    
709                  if ( $args->{kernel} && $send_rss_msgs ) {                  if ( $seen_times == 0 && $send_rss_msgs ) {
710                          $send_rss_msgs--;                          $send_rss_msgs--;
711                          _log('>>', $msg);                          if ( ! $args->{private} ) {
712                          $sth_insert_log->execute( $CHANNEL, 1, $NICK, $msg, 'now()' );                                  # FIXME bug! should be save_message
713                          $args->{kernel}->post( $IRC_ALIAS => notice => $CHANNEL, $msg );                                  save_message( channel => $args->{channel}, me => 1, nick => $NICK, message => $msg );
714    #                               $sth_insert_log->execute( $args->{channel}, 1, $NICK, $msg, 'now()' );
715                            }
716                            my ( $type, $to ) = ( 'notice', $args->{channel} );
717                            ( $type, $to ) = ( 'privmsg', $args->{nick} ) if $args->{private};
718    
719                            _log(">> RSS $type to $to:", $msg);
720                            $kernel->post( $irc => $type => $to => $msg );
721    
722                          $updates++;                          $updates++;
723                  }                  }
724          }          }
# Line 663  sub rss_fetch { Line 728  sub rss_fetch {
728          $sql .= qq{where id = } . $args->{id};          $sql .= qq{where id = } . $args->{id};
729          eval { $dbh->do( $sql ) };          eval { $dbh->do( $sql ) };
730    
731          _log "RSS got $total items of which $updates new";          _log "RSS $updates/$total new items from", $args->{url};
732    
733          return $updates;          return $updates;
734  }  }
735    
736  sub rss_fetch_all {  sub rss_fetch_all {
737          my $kernel = shift;          my ( $kernel, $send_rss_msgs )  = @_;
738            warn "## rss_fetch_all -- send_rss_msgs: $send_rss_msgs\n" if $debug;
739          my $sql = qq{          my $sql = qq{
740                  select id, url, name                  select id, url, name, channel, nick, private
741                  from feeds                  from feeds
742                  where active is true                  where active is true
743          };          };
744          # limit to newer feeds only if we are not sending messages out          # limit to newer feeds only if we are not sending messages out
745          $sql .= qq{     and last_update + delay < now() } if $kernel;          $sql .= qq{     and last_update + delay < now() } if defined ( $_stat->{rss}->{fetch} );
746          my $sth = $dbh->prepare( $sql );          my $sth = $dbh->prepare( $sql );
747          $sth->execute();          $sth->execute();
748          warn "# ",$sth->rows," active RSS feeds\n";          warn "# ",$sth->rows," active RSS feeds\n";
749          my $count = 0;          my $count = 0;
750          while (my $row = $sth->fetchrow_hashref) {          while (my $row = $sth->fetchrow_hashref) {
751                  $row->{kernel} = $kernel if $kernel;                  $row->{send_rss_msgs} = $send_rss_msgs if defined $send_rss_msgs;
752                  $count += rss_fetch( $row );                  $_stat->{rss}->{fetch}->{ $row->{url} } = $row;
753                    $kernel->post(
754                            'rss-fetch',
755                            'request',
756                            'rss_response',
757                            HTTP::Request->new( GET => $row->{url} ),
758                    );
759                    warn "## queued rss-fetch ", dump( $row ) if $debug;
760          }          }
761          return "OK, fetched $count posts from " . $sth->rows . " feeds";          return "OK, scheduled " . $sth->rows . " feeds for refresh";
762  }  }
763    
764    
765  sub rss_check_updates {  sub rss_check_updates {
766          my $kernel = shift;          my $kernel = shift;
767          my $last_t = $_rss->{last_poll} || time();          $_stat->{rss}->{last_poll} ||= time();
768          my $t = time();          my $dt = time() - $_stat->{rss}->{last_poll};
769          if ( $t - $last_t > $rss_min_delay ) {          if ( $dt > $rss_min_delay ) {
770                  $_rss->{last_poll} = $t;                  warn "## rss_check_updates $dt > $rss_min_delay\n";
771                    $_stat->{rss}->{last_poll} = time();
772                  _log rss_fetch_all( $kernel );                  _log rss_fetch_all( $kernel );
773          }          }
774  }  }
775    
776  # seed rss seen cache so we won't send out all items on startup  sub process_command {
777  _log rss_fetch_all;          my ( $kernel, $nick, $channel, $msg ) = @_;
778    
779  #          my $res = "unknown command '$msg', try /msg $NICK help!";
780  # POE handing part  
781  #          if ($msg =~ m/^help/i) {
782    
783                    $res = "usage: /msg $NICK comand | commands: stat - user/message stat | last - show backtrace | grep foobar - find foobar";
784    
785            } elsif ($msg =~ m/^(privmsg|notice)\s+(\S+)\s+(.*)$/i) {
786    
787                    _log ">> /$1 $2 $3";
788                    $kernel->post( $irc => $1 => $2, $3 );
789                    $res = '';
790    
791            } elsif ($msg =~ m/^stat.*?\s*(\d*)/i) {
792    
793                    my $nr = $1 || 10;
794    
795                    my $sth = $dbh->prepare(qq{
796                            select
797                                    trim(both '_' from nick) as nick,
798                                    count(*) as count,
799                                    sum(length(message)) as len
800                            from log
801                            group by trim(both '_' from nick)
802                            order by len desc,count desc
803                            limit $nr
804                    });
805                    $sth->execute();
806                    $res = "Top $nr users: ";
807                    my @users;
808                    while (my $row = $sth->fetchrow_hashref) {
809                            push @users,$row->{nick} . ': ' . $row->{count} . '/' . $row->{len} . '=' . sprintf("%.2f", $row->{len}/$row->{count});
810                    }
811                    $res .= join(" | ", @users);
812            } elsif ($msg =~ m/^last.*?\s*(\d*)/i) {
813    
814                    my $limit = $1 || meta( $nick, $channel, 'last-size' ) || 10;
815    
816                    foreach my $res (get_from_log( limit => $limit )) {
817                            _log "last: $res";
818                            $kernel->post( $irc => privmsg => $nick, $res );
819                    }
820    
821                    $res = '';
822    
823            } elsif ($msg =~ m/^(search|grep)\s+(.*)\s*$/i) {
824    
825                    my $what = $2;
826    
827                    foreach my $res (get_from_log(
828                                    limit => 20,
829                                    search => $what,
830                            )) {
831                            _log "search [$what]: $res";
832                            $kernel->post( $irc => privmsg => $nick, $res );
833                    }
834    
835                    $res = '';
836    
837            } elsif ($msg =~ m/^(?:count|poll)\s+(.*)(?:\s+(\d+))?\s*$/i) {
838    
839                    my ($what,$limit) = ($1,$2);
840                    $limit ||= 100;
841    
842                    my $stat;
843    
844                    foreach my $res (get_from_log(
845                                    limit => $limit,
846                                    search => $what,
847                                    full_rows => 1,
848                            )) {
849                            while ($res->{message} =~ s/\Q$what\E(\+|\-)//) {
850                                    $stat->{vote}->{$1}++;
851                                    $stat->{from}->{ $res->{nick} }++;
852                            }
853                    }
854    
855                    my @nicks;
856                    foreach my $nick (sort { $stat->{from}->{$a} <=> $stat->{from}->{$b} } keys %{ $stat->{from} }) {
857                            push @nicks, $nick . ( $stat->{from}->{$nick} == 1 ? '' :
858                                    "(" . $stat->{from}->{$nick} . ")"
859                            );
860                    }
861    
862                    $res =
863                            "$what ++ " . ( $stat->{vote}->{'+'} || 0 ) .
864                            " : " . ( $stat->{vote}->{'-'} || 0 ) . " --" .
865                            " from " . ( join(", ", @nicks) || 'nobody' );
866    
867                    $kernel->post( $irc => notice => $nick, $res );
868    
869            } elsif ($msg =~ m/^ping/) {
870                    $res = "ping = " . dump( $_stat->{ping} );
871            } elsif ($msg =~ m/^conf(?:ig)*\s*(last-size|twitter)*\s*(.*)/) {
872                    if ( ! defined( $1 ) ) {
873                            my $sth = $dbh->prepare(qq{ select name,value,changed from meta where nick = ? and channel = ? });
874                            $sth->execute( $nick, $channel );
875                            $res = "config for $nick on $channel";
876                            while ( my ($n,$v) = $sth->fetchrow_array ) {
877                                    $res .= " | $n = $v";
878                            }
879                    } elsif ( ! $2 ) {
880                            my $val = meta( $nick, $channel, $1 );
881                            $res = "current $1 = " . ( $val ? $val : 'undefined' );
882                    } else {
883                            my $validate = {
884                                    'last-size' => qr/^\d+/,
885                                    'twitter' => qr/^\w+\s+\w+/,
886                            };
887    
888                            my ( $op, $val ) = ( $1, $2 );
889    
890                            if ( my $regex = $validate->{$op} ) {
891                                    if ( $val =~ $regex ) {
892                                            meta( $nick, $channel, $op, $val );
893                                            $res = "saved $op = $val";
894                                    } else {
895                                            $res = "config option $op = $val doesn't validate against $regex";
896                                    }
897                            } else {
898                                    $res = "config option $op doesn't exist";
899                            }
900                    }
901            } elsif ($msg =~ m/^rss-update/) {
902                    $res = rss_fetch_all( $kernel );
903            } elsif ($msg =~ m/^rss-list/) {
904                    my $sth = $dbh->prepare(qq{ select url,name,last_update,active,channel,nick,private from feeds });
905                    $sth->execute;
906                    while (my @row = $sth->fetchrow_array) {
907                            $kernel->post( $irc => privmsg => $nick, join(' | ',@row) );
908                    }
909                    $res = '';
910            } elsif ($msg =~ m!^rss-(add|remove|stop|start|clean)(?:-(private))?\s+(http://\S+)\s*(.*)!) {
911                    my ( $command, $sub, $url, $arg ) = ( $1,$2,$3,$4 );
912    
913                    my $channel = $1 if ( $arg =~ s/\s*(#\S+)\s*// );
914                    $channel = $nick if $sub eq 'private';
915    
916                    my $sql = {
917                            add     => qq{ insert into feeds (url,name,channel,nick,private) values (?,?,?,?,?) },
918                            remove  => qq{ delete from feeds                                where url = ? and nick = ? },
919                            start   => qq{ update feeds set active = true   where url = ? },
920                            stop    => qq{ update feeds set active = false  where url = ? },
921                            clean   => qq{ update feeds set last_update = now() - delay where url = ? },
922                    };
923    
924  my $ping;                                               # ping stats                  if ( $command eq 'add' && ! $channel ) {
925                            $res = "ERROR: got '$msg' which doesn't have #channel in it, ignoring!";
926                    } elsif (my $q = $sql->{$command} ) {
927                            my $sth = $dbh->prepare( $q );
928                            my @data = ( $url );
929                            if ( $command eq 'add' ) {
930                                    push @data, ( $arg, $channel, $nick, $sub eq 'private' ? 1 : 0 );
931                            } elsif ( $command eq 'remove' ) {
932                                    push @data, $nick;
933                            }
934                            warn "## $command SQL $q with ",dump( @data ),"\n";
935                            eval { $sth->execute( @data ) };
936                            if ($@) {
937                                    $res = "ERROR: $@";
938                            } else {
939                                    $res = "OK, RSS executed $command" .
940                                            ( $sub ? "-$sub " : ' ' ) .
941                                            ( $channel ? "on $channel " : '' ) .
942                                            "url $url";
943                                    if ( $command eq 'clean' ) {
944                                            my $seen = $_stat->{rss}->{seen} || die "no seen?";
945                                            my $want_link = $_stat->{rss}->{url2link}->{$url} || warn "no url2link($url)";
946                                            foreach my $c ( keys %$seen ) {
947                                                    my $c_hash = $seen->{$c} || die "no seen->{$c}";
948                                                    die "not HASH with rss links but ", dump($c_hash) unless ref($c_hash) eq 'HASH';
949                                                    foreach my $link ( keys %$c_hash ) {
950                                                            next unless $link eq $want_link;
951                                                            _log "RSS removed seen $c $url $link";
952                                                    }
953                                            }
954                                    } elsif ( $command eq 'add' ) {
955                                            rss_fetch_all( $kernel );
956                                    }
957                            }
958                    } else {
959                            $res = "ERROR: don't know what to do with: $msg";
960                    }
961            } elsif ($msg =~ m/^rss-clean/) {
962                    # this makes sense because we didn't catch rss-clean http://... before!
963                    $_stat->{rss} = undef;
964                    $dbh->do( qq{ update feeds set last_update = now() - delay } );
965                    $res = rss_fetch_all( $kernel );
966            }
967    
968  POE::Component::IRC->new($IRC_ALIAS);          return $res;
969    }
970    
971  POE::Session->create( inline_states => {  POE::Session->create( inline_states => {
972          _start => sub {                _start => sub {      
973                  $_[KERNEL]->post($IRC_ALIAS => register => 'all');                  $_[KERNEL]->post( $irc => register => 'all' );
974                  $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);                  $_[KERNEL]->post( $irc => connect => {} );
     },  
     irc_255 => sub {    # server is done blabbing  
                 $_[KERNEL]->post($IRC_ALIAS => join => $CHANNEL);  
                 $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );  
975      },      },
976            irc_001 => sub {
977                    my ($kernel,$sender) = @_[KERNEL,SENDER];
978                    my $poco_object = $sender->get_heap();
979                    _log "connected to",$poco_object->server_name();
980                    $kernel->post( $sender => join => $_ ) for @channels;
981                    # seen RSS cache, so don't send out messages
982                    _log rss_fetch_all( $kernel, 0 );
983                    undef;
984            },
985    #       irc_255 => sub {        # server is done blabbing
986    #               $_[KERNEL]->post( $irc => join => $CHANNEL);
987    #       },
988      irc_public => sub {      irc_public => sub {
989                  my $kernel = $_[KERNEL];                  my $kernel = $_[KERNEL];
990                  my $nick = (split /!/, $_[ARG0])[0];                  my $nick = (split /!/, $_[ARG0])[0];
# Line 727  POE::Session->create( inline_states => { Line 993  POE::Session->create( inline_states => {
993    
994                  save_message( channel => $channel, me => 0, nick => $nick, message => $msg);                  save_message( channel => $channel, me => 0, nick => $nick, message => $msg);
995                  meta( $nick, $channel, 'last-msg', $msg );                  meta( $nick, $channel, 'last-msg', $msg );
996                    rss_check_updates( $kernel );
997      },      },
998      irc_ctcp_action => sub {      irc_ctcp_action => sub {
999                  my $kernel = $_[KERNEL];                  my $kernel = $_[KERNEL];
# Line 748  POE::Session->create( inline_states => { Line 1015  POE::Session->create( inline_states => {
1015      },      },
1016          irc_ping => sub {          irc_ping => sub {
1017                  _log( "pong ", $_[ARG0] );                  _log( "pong ", $_[ARG0] );
1018                  $ping->{ $_[ARG0] }++;                  $_stat->{ping}->{ $_[ARG0] }++;
1019                  rss_check_updates( $_[KERNEL] );                  rss_check_updates( $_[KERNEL] );
1020          },          },
1021          irc_invite => sub {          irc_invite => sub {
# Line 758  POE::Session->create( inline_states => { Line 1025  POE::Session->create( inline_states => {
1025    
1026                  _log "invited to $channel by $nick";                  _log "invited to $channel by $nick";
1027    
1028                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, "how nice of you to invite me to $channel, I'll be right there..." );                  $_[KERNEL]->post( $irc => privmsg => $nick, "how nice of you to invite me to $channel, I'll be right there..." );
1029                  $_[KERNEL]->post($IRC_ALIAS => join => $channel);                  $_[KERNEL]->post( $irc => 'join' => $channel );
1030    
1031          },          },
1032          irc_msg => sub {          irc_msg => sub {
1033                  my $kernel = $_[KERNEL];                  my $kernel = $_[KERNEL];
1034                  my $nick = (split /!/, $_[ARG0])[0];                  my $nick = (split /!/, $_[ARG0])[0];
                 my $msg = $_[ARG2];  
1035                  my $channel = $_[ARG1]->[0];                  my $channel = $_[ARG1]->[0];
1036                    my $msg = $_[ARG2];
1037                  my $res = "unknown command '$msg', try /msg $NICK help!";                  warn "# ARG = ",dump( @_[ARG0,ARG1,ARG2] ) if $debug;
                 my @out;  
1038    
1039                  _log "<< $msg";                  _log "<< $msg";
1040    
1041                  if ($msg =~ m/^help/i) {                  my $res = process_command( $_[KERNEL], $nick, $channel, $msg );
   
                         $res = "usage: /msg $NICK comand | commands: stat - user/message stat | last - show backtrace | grep foobar - find foobar";  
   
                 } elsif ($msg =~ m/^msg\s+(\S+)\s+(.*)$/i) {  
   
                         _log ">> /msg $1 $2";  
                         $_[KERNEL]->post( $IRC_ALIAS => privmsg => $1, $2 );  
                         $res = '';  
   
                 } elsif ($msg =~ m/^stat.*?\s*(\d*)/i) {  
   
                         my $nr = $1 || 10;  
   
                         my $sth = $dbh->prepare(qq{  
                                 select  
                                         trim(both '_' from nick) as nick,  
                                         count(*) as count,  
                                         sum(length(message)) as len  
                                 from log  
                                 group by trim(both '_' from nick)  
                                 order by len desc,count desc  
                                 limit $nr  
                         });  
                         $sth->execute();  
                         $res = "Top $nr users: ";  
                         my @users;  
                         while (my $row = $sth->fetchrow_hashref) {  
                                 push @users,$row->{nick} . ': ' . $row->{count} . '/' . $row->{len} . '=' . sprintf("%.2f", $row->{len}/$row->{count});  
                         }  
                         $res .= join(" | ", @users);  
                 } elsif ($msg =~ m/^last.*?\s*(\d*)/i) {  
   
                         my $limit = $1 || meta( $nick, $channel, 'last-size' ) || 10;  
   
                         foreach my $res (get_from_log( limit => $limit )) {  
                                 _log "last: $res";  
                                 $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );  
                         }  
   
                         $res = '';  
   
                 } elsif ($msg =~ m/^(search|grep)\s+(.*)\s*$/i) {  
   
                         my $what = $2;  
   
                         foreach my $res (get_from_log(  
                                         limit => 20,  
                                         search => $what,  
                                 )) {  
                                 _log "search [$what]: $res";  
                                 $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );  
                         }  
   
                         $res = '';  
   
                 } elsif ($msg =~ m/^(?:count|poll)\s+(.*)(?:\s+(\d+))?\s*$/i) {  
   
                         my ($what,$limit) = ($1,$2);  
                         $limit ||= 100;  
   
                         my $stat;  
   
                         foreach my $res (get_from_log(  
                                         limit => $limit,  
                                         search => $what,  
                                         full_rows => 1,  
                                 )) {  
                                 while ($res->{message} =~ s/\Q$what\E(\+|\-)//) {  
                                         $stat->{vote}->{$1}++;  
                                         $stat->{from}->{ $res->{nick} }++;  
                                 }  
                         }  
   
                         my @nicks;  
                         foreach my $nick (sort { $stat->{from}->{$a} <=> $stat->{from}->{$b} } keys %{ $stat->{from} }) {  
                                 push @nicks, $nick . ( $stat->{from}->{$nick} == 1 ? '' :  
                                         "(" . $stat->{from}->{$nick} . ")"  
                                 );  
                         }  
   
                         $res =  
                                 "$what ++ " . ( $stat->{vote}->{'+'} || 0 ) .  
                                 " : " . ( $stat->{vote}->{'-'} || 0 ) . " --" .  
                                 " from " . ( join(", ", @nicks) || 'nobody' );  
   
                         $_[KERNEL]->post( $IRC_ALIAS => notice => $nick, $res );  
   
                 } elsif ($msg =~ m/^ping/) {  
                         $res = "ping = " . dump( $ping );  
                 } elsif ($msg =~ m/^conf(?:ig)*\s*(last-size|twitter)*\s*(.*)/) {  
                         if ( ! defined( $1 ) ) {  
                                 my $sth = $dbh->prepare(qq{ select name,value,changed from meta where nick = ? and channel = ? });  
                                 $sth->execute( $nick, $channel );  
                                 $res = "config for $nick on $channel";  
                                 while ( my ($n,$v) = $sth->fetchrow_array ) {  
                                         $res .= " | $n = $v";  
                                 }  
                         } elsif ( ! $2 ) {  
                                 my $val = meta( $nick, $channel, $1 );  
                                 $res = "current $1 = " . ( $val ? $val : 'undefined' );  
                         } else {  
                                 my $validate = {  
                                         'last-size' => qr/^\d+/,  
                                         'twitter' => qr/^\w+\s+\w+/,  
                                 };  
   
                                 my ( $op, $val ) = ( $1, $2 );  
   
                                 if ( my $regex = $validate->{$op} ) {  
                                         if ( $val =~ $regex ) {  
                                                 meta( $nick, $channel, $op, $val );  
                                                 $res = "saved $op = $val";  
                                         } else {  
                                                 $res = "config option $op = $val doesn't validate against $regex";  
                                         }  
                                 } else {  
                                         $res = "config option $op doesn't exist";  
                                 }  
                         }  
                 } elsif ($msg =~ m/^rss-update/) {  
                         $res = rss_fetch_all( $_[KERNEL] );  
                 } elsif ($msg =~ m/^rss-clean/) {  
                         $_rss = undef;  
                         $dbh->do( qq{ update feeds set last_update = now() - delay } );  
                         $res = "OK, cleaned RSS cache";  
                 } elsif ($msg =~ m/^rss-list/) {  
                         my $sth = $dbh->prepare(qq{ select url,name,last_update,active from feeds });  
                         $sth->execute;  
                         while (my @row = $sth->fetchrow_array) {  
                                 $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, join(' | ',@row) );  
                         }  
                         $res = '';  
                 } elsif ($msg =~ m!^rss-(add|remove|stop|start)\s+(http://\S+)\s*(.*)!) {  
                         my $sql = {  
                                 add             => qq{ insert into feeds (url,name) values (?,?) },  
 #                               remove  => qq{ delete from feeds                                where url = ? and name = ? },  
                                 start   => qq{ update feeds set active = true   where url = ? },  
                                 stop    => qq{ update feeds set active = false  where url = ? },  
                                   
                         };  
                         if (my $q = $sql->{$1} ) {  
                                 my $sth = $dbh->prepare( $q );  
                                 my @data = ( $2 );  
                                 push @data, $3 if ( $q =~ s/\?//g == 2 );  
                                 warn "## $1 SQL $q with ",dump( @data ),"\n";  
                                 eval { $sth->execute( @data ) };  
                         }  
   
                         $res = "OK, RSS $1 : $2 - $3";  
                 }  
1042    
1043                  if ($res) {                  if ($res) {
1044                          _log ">> [$nick] $res";                          _log ">> [$nick] $res";
1045                          $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );                          $_[KERNEL]->post( $irc => privmsg => $nick, $res );
1046                  }                  }
1047    
1048                  rss_check_updates( $_[KERNEL] );                  rss_check_updates( $_[KERNEL] );
1049          },          },
1050            irc_372 => sub {
1051                    _log "<< motd",$_[ARG0],$_[ARG1];
1052            },
1053            irc_375 => sub {
1054                    _log "<< motd", $_[ARG0], "start";
1055            },
1056            irc_376 => sub {
1057                    _log "<< motd", $_[ARG0], "end";
1058            },
1059    #       irc_433 => sub {
1060    #               print "# irc_433: ",$_[ARG1], "\n";
1061    #               warn "## indetify $NICK\n";
1062    #               $_[KERNEL]->post( $irc => privmsg => 'nickserv', "IDENTIFY $NICK" );
1063    #       },
1064    #       irc_451 # please register
1065          irc_477 => sub {          irc_477 => sub {
1066                  _log "# irc_477: ",$_[ARG1];                  _log "<< irc_477: ",$_[ARG1];
1067                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "register $NICK" );                  _log ">> IDENTIFY $NICK";
1068                    $_[KERNEL]->post( $irc => privmsg => 'NickServ', "IDENTIFY $NICK" );
1069          },          },
1070          irc_505 => sub {          irc_505 => sub {
1071                  _log "# irc_505: ",$_[ARG1];                  _log "<< irc_505: ",$_[ARG1];
1072                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "register $NICK" );                  _log ">> register $NICK";
1073  #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "set hide email on" );                  $_[KERNEL]->post( $irc => privmsg => 'NickServ', "register $NICK" );
1074  #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "set email dpavlin\@rot13.org" );  #               $_[KERNEL]->post( $irc => privmsg => 'nickserv', "IDENTIFY $NICK" );
1075    #               $_[KERNEL]->post( $irc => privmsg => 'nickserv', "set hide email on" );
1076    #               $_[KERNEL]->post( $irc => privmsg => 'nickserv', "set email dpavlin\@rot13.org" );
1077          },          },
1078          irc_registered => sub {          irc_registered => sub {
1079                  _log "## registrated $NICK";                  _log "<< registered $NICK";
                 $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );  
1080          },          },
1081          irc_disconnected => sub {          irc_disconnected => sub {
1082                  _log "## disconnected, reconnecting again";                  _log "## disconnected.. sleeping for $sleep_on_error seconds and reconnecting again";
1083                  $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);                  sleep($sleep_on_error);
1084                    $_[KERNEL]->post( $irc => connect => {} );
1085          },          },
1086          irc_socketerr => sub {          irc_socketerr => sub {
1087                  _log "## socket error... sleeping for $sleep_on_error seconds and retry";                  _log "## socket error... sleeping for $sleep_on_error seconds and retry";
1088                  sleep($sleep_on_error);                  sleep($sleep_on_error);
1089                  $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);                  $_[KERNEL]->post( $irc => connect => {} );
1090            },
1091            irc_notice => sub {
1092                    _log "<< notice from ", $_[ARG0], $_[ARG1], $_[ARG2];
1093                    my $m = $_[ARG2];
1094                    if ( $m =~ m!/msg.*(NickServ).*(IDENTIFY)!i ) {
1095                            _log ">> suggested to $1 $2";
1096                            $_[KERNEL]->post( $irc => privmsg => $1, "$2 $NICK" );
1097                    } elsif ( $m =~ m!\Q$NICK\E.*registered!i ) {
1098                            _log ">> registreted, so IDENTIFY";
1099                            $_[KERNEL]->post( $irc => privmsg => 'nickserv', "IDENTIFY $NICK" );
1100                    } else {
1101                            warn "## ignore $m\n" if $debug;
1102                    }
1103            },
1104            irc_snotice => sub {
1105                    _log "<< snotice", $_[ARG0]; #dump( $_[ARG0],$_[ARG1], $_[ARG2] );
1106                    if ( $_[ARG0] =~ m!/(QUOTE)\s+(PASS\s+\d+)!i ) {
1107                            warn ">> $1 | $2\n";
1108                            $_[KERNEL]->post( $irc => lc($1) => $2);
1109                    }
1110          },          },
 #       irc_433 => sub {  
 #               print "# irc_433: ",$_[ARG1], "\n";  
 #               warn "## indetify $NICK\n";  
 #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );  
 #       },  
1111      _child => sub {},      _child => sub {},
1112      _default => sub {      _default => sub {
1113                  _log sprintf "sID:%s %s %s",                  _log '_default SID:', $_[SESSION]->ID, $_[ARG0], dump( $_[ARG1] );
1114                          $_[SESSION]->ID, $_[ARG0],                  0; # false for signals
                         ref($_[ARG1]) eq "ARRAY"        ?       join(",", map { ref($_) eq "ARRAY" ? join(";", @{$_}) : $_ } @{ $_[ARG1] })     :  
                         $_[ARG1]                                        ?       $_[ARG1]                                        :  
                         "";  
       0;                        # false for signals  
1115      },      },
1116            rss_response => sub {
1117                    my ($request_packet, $response_packet) = @_[ARG0, ARG1];
1118                    my $request_object  = $request_packet->[0];
1119                    my $response_object = $response_packet->[0];
1120    
1121                    my $row = delete( $_stat->{rss}->{fetch}->{ $request_object->uri } );
1122                    if ( $row ) {
1123                            $row->{xml} = $response_object->content;
1124                            rss_parse_xml( $_[KERNEL], $row );
1125                    } else {
1126                            warn "## can't find rss->fetch for ", $request_object->uri;
1127                    }
1128            },
1129     },     },
1130    );    );
1131    
1132  # http server  # http server
1133    
1134    _log "WEB archive at $url";
1135    
1136  my $httpd = POE::Component::Server::HTTP->new(  my $httpd = POE::Component::Server::HTTP->new(
1137          Port => $http_port,          Port => $http_port,
1138          PreHandler => {          PreHandler => {
# Line 1020  foreach my $c (@cols) { Line 1179  foreach my $c (@cols) {
1179          $style .= ".col-${max_color} { background: $c }\n";          $style .= ".col-${max_color} { background: $c }\n";
1180          $max_color++;          $max_color++;
1181  }  }
1182  warn "defined $max_color colors for users...\n";  _log "WEB defined $max_color colors for users...";
1183    
1184  sub root_handler {  sub root_handler {
1185          my ($request, $response) = @_;          my ($request, $response) = @_;
# Line 1031  sub root_handler { Line 1190  sub root_handler {
1190    
1191          return RC_OK if $request->uri =~ m/favicon.ico$/;          return RC_OK if $request->uri =~ m/favicon.ico$/;
1192    
1193            if ( $request->uri =~ m/robots.txt$/ ) {
1194                    $response->content_type( 'text/plain' );
1195                    $response->content( qq{
1196    
1197    User-Agent: *
1198    Disallow: /
1199    
1200                    });
1201                    return RC_OK;
1202            }
1203    
1204          my $q;          my $q;
1205    
1206          if ( $request->method eq 'POST' ) {          if ( $request->method eq 'POST' ) {
# Line 1042  sub root_handler { Line 1212  sub root_handler {
1212          }          }
1213    
1214          my $search = $q->param('search') || $q->param('grep') || '';          my $search = $q->param('search') || $q->param('grep') || '';
1215            my $r_url = $request->url;
1216    
1217            my @commands = qw( tags last-tag follow stat );
1218            my $commands_re = join('|',@commands);
1219    
1220          if ($request->url =~ m#/rss(?:/(tags|last-tag|follow.*)\w*(?:=(\d+))?)?#i) {          if ($r_url =~ m#/rss(?:/($commands_re.*)\w*(?:=(\d+))?)?#i) {
1221                  my $show = lc($1);                  my $show = lc($1);
1222                  my $nr = $2;                  my $nr = $2;
1223    
# Line 1052  sub root_handler { Line 1226  sub root_handler {
1226                  $response->content_type( 'application/' . lc($type) . '+xml' );                  $response->content_type( 'application/' . lc($type) . '+xml' );
1227    
1228                  my $html = '<!-- error -->';                  my $html = '<!-- error -->';
1229                  #warn "create $type feed from ",dump( @last_tags );                  #warn "create $type feed from ",dump( $cloud->last_tags );
1230    
1231                  my $feed = XML::Feed->new( $type );                  my $feed = XML::Feed->new( $type );
1232                  $feed->link( $url );                  $feed->link( $url );
1233    
1234                    my $rc = RC_OK;
1235    
1236                  if ( $show eq 'tags' ) {                  if ( $show eq 'tags' ) {
1237                          $nr ||= 50;                          $nr ||= 50;
1238                          $feed->title( "tags from $CHANNEL" );                          $feed->title( "tags from $CHANNEL" );
# Line 1084  sub root_handler { Line 1260  sub root_handler {
1260                          $feed->title( "last $nr tagged messages from $CHANNEL" );                          $feed->title( "last $nr tagged messages from $CHANNEL" );
1261                          $feed->description( "collects messages which have tags// in them" );                          $feed->description( "collects messages which have tags// in them" );
1262    
1263                          foreach my $m ( @last_tags ) {                          foreach my $m ( $cloud->last_tags ) {
1264  #                               warn dump( $m );  #                               warn dump( $m );
1265                                  #my $tags = join(' ', @{$m->{tags}} );                                  #my $tags = join(' ', @{$m->{tags}} );
1266                                  my $feed_entry = XML::Feed::Entry->new($type);                                  my $feed_entry = XML::Feed::Entry->new($type);
# Line 1126  sub root_handler { Line 1302  sub root_handler {
1302                                  $feed->add_entry( $feed_entry );                                  $feed->add_entry( $feed_entry );
1303                          }                          }
1304    
1305                    } elsif ( $show =~ m/^stat/ ) {
1306    
1307                            my $feed_entry = XML::Feed::Entry->new($type);
1308                            $feed_entry->title( "Internal stats" );
1309                            $feed_entry->content(
1310                                    '<![CDATA[<pre>' . dump( $_stat ) . '</pre>]]>'
1311                            );
1312                            $feed->add_entry( $feed_entry );
1313    
1314                  } else {                  } else {
1315                          _log "unknown rss request ",$request->url;                          _log "WEB unknown rss request $r_url";
1316                          return RC_DENY;                          $feed->title( "unknown $r_url" );
1317                            foreach my $c ( @commands ) {
1318                                    my $feed_entry = XML::Feed::Entry->new($type);
1319                                    $feed_entry->title( "rss/$c" );
1320                                    $feed_entry->link( "$url/rss/$c" );
1321                                    $feed->add_entry( $feed_entry );
1322                            }
1323                            $rc = RC_DENY;
1324                  }                  }
1325    
1326                  $response->content( $feed->as_xml );                  eval { $response->content( $feed->as_xml ); };
1327                  return RC_OK;                  $rc = RC_INTERNAL_SERVER_ERROR if $@;
1328                    return $rc;
1329          }          }
1330    
1331          if ( $@ ) {          if ( $@ ) {
# Line 1144  sub root_handler { Line 1337  sub root_handler {
1337          my $html =          my $html =
1338                  qq{<html><head><title>$NICK</title><style type="text/css">$style}                  qq{<html><head><title>$NICK</title><style type="text/css">$style}
1339                  . $cloud->css                  . $cloud->css
1340                  . qq{</style></head><body>}                  . qq{</style>
1341                    <meta name="google-site-verification" content="oe-LvUiNiQRPpc_uB-3rY4MWvFifkmLf276WzAvTL5U" />  
1342                    </head><body>}
1343                  . qq{                  . qq{
1344                  <form method="post" class="search" action="/">                  <form method="post" class="search" action="/">
1345                  <input type="text" name="search" value="$search" size="10">                  <input type="text" name="search" value="$search" size="10">
# Line 1198  sub root_handler { Line 1393  sub root_handler {
1393          } else {          } else {
1394                  $html .= join("</p><p>",                  $html .= join("</p><p>",
1395                          get_from_log(                          get_from_log(
1396                                  limit => ( $q->param('last') || $q->param('date') ) ? undef : 100,                                  limit => ( $q->param('date') ? undef : $q->param('last') || 100 ),
1397                                  search => $search || undef,                                  search => $search || undef,
1398                                  tag => $q->param('tag') || undef,                                  tag => $q->param('tag') || undef,
1399                                  date => $q->param('date') || undef,                                  date => $q->param('date') || undef,
# Line 1229  sub root_handler { Line 1424  sub root_handler {
1424  }  }
1425    
1426  POE::Kernel->run;  POE::Kernel->run;
1427    
1428    =head1 TagCloud
1429    
1430    Extended L<HTML::TagCloud>
1431    
1432    =cut
1433    
1434    package TagCloud;
1435    use warnings;
1436    use strict;
1437    use HTML::TagCloud;
1438    use base 'HTML::TagCloud';
1439    use Data::Dump qw/dump/;
1440    
1441    =head2 html
1442    
1443    Generate html with number of tags in title of link
1444    
1445    =cut
1446    
1447    sub html {
1448            my($self, $limit) = @_;
1449            my @tags=$self->tags($limit);
1450    
1451            my $ntags = scalar(@tags);
1452            if ($ntags == 0) {
1453                    return "";
1454    #       } elsif ($ntags == 1) {
1455    #               my $tag = $tags[0];
1456    #               return qq{<div id="htmltagcloud"><span class="tagcloud1"><a href="}.
1457    #               $tag->{url}.qq{">}.$tag->{name}.qq{</a></span></div>\n};
1458            }
1459    
1460      my $html = qq{<div id="htmltagcloud">};
1461      foreach my $tag ( sort { lc($a->{name}) cmp lc($b->{name}) } @tags) {
1462        $html .=  sprintf(qq{<span class="tag tagcloud%d"><a href="%s" title="%s">%s</a></span>\n},
1463                    $tag->{level}, $tag->{url}, $tag->{count}, $tag->{name}
1464            );
1465      }
1466      $html .= qq{</div>};
1467      return $html;
1468    }
1469    
1470    =head2 last_tags
1471    
1472      my @tags = $cloud->last_tags;
1473    
1474    =cut
1475    
1476    my @last_tags;
1477    sub last_tags {
1478            return @last_tags;
1479    }
1480    
1481    =head2 add_tag
1482    
1483     $cloud->add_tag( id => 42, message => 'irc message', nick => 'foobar' [, me => 1 ] );
1484    
1485    =cut
1486    
1487    
1488    sub add_tag {
1489            my $self = shift;
1490            my $arg = {@_};
1491    
1492            return unless ($arg->{id} && $arg->{message});
1493    
1494            my $m = $arg->{message};
1495    
1496            my @tags;
1497    
1498            while ($m =~ s#$tag_regex##s) {
1499                    my $tag = $1;
1500                    next if (! $tag || $tag =~ m/https?:/i);
1501                    push @{ $tags->{$tag} }, $arg->{id};
1502                    #warn "+tag $tag: $arg->{id}\n";
1503                    $self->add($tag, "$url?tag=$tag", scalar @{$tags->{$tag}});
1504                    push @tags, $tag;
1505    
1506            }
1507    
1508            if ( @tags ) {
1509                    pop @last_tags if $#last_tags == $last_x_tags;
1510                    unshift @last_tags, { tags => [ @tags ], %$arg };
1511            }
1512    
1513    }
1514    
1515    =head2 seed_tags
1516    
1517    Read all tags from database and create in-memory cache for tags
1518    
1519    =cut
1520    
1521    sub seed_tags {
1522            my $self = shift;
1523            my $sth = $dbh->prepare(qq{ select id,message,nick,me,time from log where message like '%//%' order by time asc });
1524            $sth->execute;
1525            while (my $row = $sth->fetchrow_hashref) {
1526                    $self->add_tag( %$row );
1527            }
1528    
1529            foreach my $tag (keys %$tags) {
1530                    $self->add($tag, "$url?tag=$tag", scalar @{$tags->{$tag}});
1531            }
1532    }
1533    
Legend:
Removed from v.92  
changed lines
  Added in v.150
  ViewVC Help
Powered by ViewVC 1.1.26