/[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 86 by dpavlin, Thu Mar 6 22:57:16 2008 UTC revision 119 by dpavlin, Fri Mar 14 00:17:49 2008 UTC
# Line 2  Line 2 
2  use strict;  use strict;
3  $|++;  $|++;
4    
5    use POE qw(Component::IRC Component::Server::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 IPC::DirQueue;
22    use File::Slurp;
23    
24  =head1 NAME  =head1 NAME
25    
26  irc-logger.pl  irc-logger.pl
# Line 20  Import log from C<dircproxy> to C<irc-lo Line 39  Import log from C<dircproxy> to C<irc-lo
39    
40  =item --log=irc-logger.log  =item --log=irc-logger.log
41    
 Name of log file  
   
 =item --follow=file.log  
   
 Follows new messages in file  
   
42  =back  =back
43    
44  =head1 DESCRIPTION  =head1 DESCRIPTION
# Line 36  log all conversation on irc channel Line 49  log all conversation on irc channel
49    
50  ## CONFIG  ## CONFIG
51    
52    my $debug = 0;
53    
54    my $irc_config = {
55            nick => 'irc-logger',
56            server => 'irc.freenode.net',
57            port => 6667,
58            ircname => 'Anna the bot: try /msg irc-logger help',
59    };
60    
61    my $queue_dir = './queue';
62    
63  my $HOSTNAME = `hostname -f`;  my $HOSTNAME = `hostname -f`;
64  chomp($HOSTNAME);  chomp($HOSTNAME);
65    
66  my $NICK = 'irc-logger';  
 $NICK .= '-dev' if ($HOSTNAME =~ m/llin/);  
 my $CONNECT =  
   {Server => 'irc.freenode.net',  
    Nick => $NICK,  
    Ircname => "try /msg $NICK help",  
   };  
67  my $CHANNEL = '#razmjenavjestina';  my $CHANNEL = '#razmjenavjestina';
 $CHANNEL = '#irc-logger' if ($HOSTNAME =~ m/llin/);  
 my $IRC_ALIAS = "log";  
68    
69  # default log to follow and announce messages  if ( $HOSTNAME =~ m/llin/ ) {
70  my $follows_path = 'follows.log';          $irc_config->{nick} = 'irc-logger-llin';
71    #       $irc_config = {
72    #               nick => 'irc-logger-llin',
73    #               server => 'localhost',
74    #               port => 6668,
75    #       };
76            $CHANNEL = '#irc-logger';
77    } elsif ( $HOSTNAME =~ m/lugarin/ ) {
78            $irc_config->{server} = 'irc.carnet.hr';
79            $CHANNEL = '#riss';
80    }
81    
82    my @channels = ( $CHANNEL );
83    
84    warn "# config = ", dump( $irc_config ), $/;
85    
86    my $NICK = $irc_config->{nick} or die "no nick?";
87    
88  my $DSN = 'DBI:Pg:dbname=' . $NICK;  my $DSN = 'DBI:Pg:dbname=' . $NICK;
89    
 # log output encoding  
 my $ENCODING = 'ISO-8859-2';  
90  my $TIMESTAMP = '%Y-%m-%d %H:%M:%S';  my $TIMESTAMP = '%Y-%m-%d %H:%M:%S';
91    
92  my $sleep_on_error = 5;  my $sleep_on_error = 5;
# Line 66  my $last_x_tags = 50; Line 96  my $last_x_tags = 50;
96    
97  # don't pull rss feeds more often than this  # don't pull rss feeds more often than this
98  my $rss_min_delay = 60;  my $rss_min_delay = 60;
 $rss_min_delay = 15;  
99    
100  my $http_port = $NICK =~ m/-dev/ ? 8001 : 8000;  my $http_port = $NICK =~ m/-dev/ ? 8001 : 8000;
101    
# Line 74  my $url = "http://$HOSTNAME:$http_port"; Line 103  my $url = "http://$HOSTNAME:$http_port";
103    
104  ## END CONFIG  ## END CONFIG
105    
 use POE qw(Component::IRC Wheel::FollowTail Component::Server::HTTP);  
 use HTTP::Status;  
 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;  
 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;  
   
106  my $use_twitter = 1;  my $use_twitter = 1;
107  eval { require Net::Twitter; };  eval { require Net::Twitter; };
108  $use_twitter = 0 if ($@);  $use_twitter = 0 if ($@);
# Line 100  my $import_dircproxy; Line 111  my $import_dircproxy;
111  my $log_path;  my $log_path;
112  GetOptions(  GetOptions(
113          'import-dircproxy:s' => \$import_dircproxy,          'import-dircproxy:s' => \$import_dircproxy,
         'follows:s' => \$follows_path,  
114          'log:s' => \$log_path,          'log:s' => \$log_path,
115            'queue:s' => \$queue_dir,
116  );  );
117    
118  $SIG{__DIE__} = sub {  #$SIG{__DIE__} = sub {
119          confess "fatal error";  #       confess "fatal error";
120  };  #};
   
 open(STDOUT, '>', $log_path) || warn "can't redirect log to $log_path: $!";  
121    
122  sub _log {  sub _log {
123          my $out = strftime($TIMESTAMP,localtime()) . ' ' . join(" ",@_) . $/;          print strftime($TIMESTAMP,localtime()) . ' ' . join(" ",map { ref($_) ? dump( $_ ) : $_ } @_) . $/;
         from_to( $out, 'UTF-8', $ENCODING );  
         print $out;  
124  }  }
125    
126  # LOG following  open(STDOUT, '>', $log_path) && warn "log to $log_path: $!\n";
127    
128  my %FOLLOWS =  # queue
   (  
 #   ACCESS => "/var/log/apache/access.log",  
 #   ERROR => "/var/log/apache/error.log",  
   );  
129    
130  sub add_follow_path {  if ( ! -d $queue_dir ) {
131          my $path = shift;          warn "## creating queue directory $queue_dir";
132          my $name = $path;          mkdir $queue_dir or die "can't create queue directory $queue_dir: $!";
         $name =~ s/\..*$//;  
         warn "# using $path to announce messages from $name\n";  
         $FOLLOWS{$name} = $path;  
133  }  }
134    
135  add_follow_path( $follows_path ) if ( -e $follows_path );  my $dq = IPC::DirQueue->new({ dir => $queue_dir });
136    
137  # HTML formatters  # HTML formatters
138    
# Line 151  my $filter = { Line 151  my $filter = {
151                  # protect HTML from wiki modifications                  # protect HTML from wiki modifications
152                  sub e {                  sub e {
153                          my $t = shift;                          my $t = shift;
154                          return 'uri_unescape{' . uri_escape($t) . '}';                          return 'uri_unescape{' . uri_escape($t, '^a-zA-Z0-9') . '}';
155                  }                  }
156    
157                  $m =~ s/($escape_re)/$escape{$1}/gs;                  $m =~ s/($escape_re)/$escape{$1}/gs;
158                  $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;
159                  $m =~ s#\/(\w+)\/#<i>$1</i>#gs;                  $m =~ s#\/(\w+)\/#<i>$1</i>#gs;
160                  $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;
161                  $m =~ s#\*(\w+)\*#<b>$1</b>#gs;                  $m =~ s#\*(\w+)\*#<b>$1</b>#gs;
# Line 176  my $filter = { Line 176  my $filter = {
176          },          },
177  };  };
178    
179    # POE IRC
180    my $poe_irc = POE::Component::IRC->spawn( %$irc_config ) or
181            die "can't start ", dump( $irc_config ), ": $!";
182    
183    my $irc = $poe_irc->session_id();
184    _log "IRC session_id $irc";
185    
186  my $dbh = DBI->connect($DSN,"","", { RaiseError => 1, AutoCommit => 1 }) || die $DBI::errstr;  my $dbh = DBI->connect($DSN,"","", { RaiseError => 1, AutoCommit => 1 }) || die $DBI::errstr;
187  $dbh->do( qq{ set client_encoding = 'UTF-8' } );  $dbh->do( qq{ set client_encoding = 'UTF-8' } );
188    
# Line 212  create table feeds ( Line 219  create table feeds (
219          name text,          name text,
220          delay interval not null default '5 min',          delay interval not null default '5 min',
221          active boolean default true,          active boolean default true,
222            channel text not null,
223            nick text not null,
224            private boolean default false,
225          last_update timestamp default 'now()',          last_update timestamp default 'now()',
226          polls int default 0,          polls int default 0,
227          updates int default 0          updates int default 0
228  );  );
229  create unique index feeds_url on feeds(url);  create unique index feeds_url on feeds(url);
230  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');
231          },          },
232  };  };
233    
# Line 261  sub meta { Line 271  sub meta {
271                  if ( $@ || ! $sth->rows ) {                  if ( $@ || ! $sth->rows ) {
272                          $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()) });
273                          $sth->execute( $value, $nick, $channel, $name );                          $sth->execute( $value, $nick, $channel, $name );
274                          _log "created $nick/$channel/$name = $value";                          warn "## created $nick/$channel/$name = $value\n";
275                  } else {                  } else {
276                          _log "updated $nick/$channel/$name = $value ";                          warn "## updated $nick/$channel/$name = $value\n";
277                  }                  }
278    
279                  return $value;                  return $value;
# Line 273  sub meta { Line 283  sub meta {
283                  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 = ? });
284                  $sth->execute( $nick, $channel, $name );                  $sth->execute( $nick, $channel, $name );
285                  my ($v,$c) = $sth->fetchrow_array;                  my ($v,$c) = $sth->fetchrow_array;
286                  _log "fetched $nick/$channel/$name = $v [$c]";                  warn "## fetched $nick/$channel/$name = $v [$c]\n";
287                  return ($v,$c) if wantarray;                  return ($v,$c) if wantarray;
288                  return $v;                  return $v;
289    
# Line 282  sub meta { Line 292  sub meta {
292    
293    
294    
295  my $sth = $dbh->prepare(qq{  my $sth_insert_log = $dbh->prepare(qq{
296  insert into log  insert into log
297          (channel, me, nick, message, time)          (channel, me, nick, message, time)
298  values (?,?,?,?,?)  values (?,?,?,?,?)
# Line 370  sub get_from_log { Line 380  sub get_from_log {
380    
381          my @where;          my @where;
382          my @args;          my @args;
383            my $msg;
384    
385          if (my $search = $args->{search}) {          if (my $search = $args->{search}) {
386                  $search =~ s/^\s+//;                  $search =~ s/^\s+//;
387                  $search =~ s/\s+$//;                  $search =~ s/\s+$//;
388                  push @where, 'message ilike ? or nick ilike ?';                  push @where, 'message ilike ? or nick ilike ?';
389                  push @args, ( ( '%' . $search . '%' ) x 2 );                  push @args, ( ( '%' . $search . '%' ) x 2 );
390                  _log "search for '$search'";                  $msg = "Search for '$search'";
391          }          }
392    
393          if ($args->{tag} && $tags->{ $args->{tag} }) {          if ($args->{tag} && $tags->{ $args->{tag} }) {
394                  push @where, 'id in (' . join(',', @{ $tags->{ $args->{tag} } }) . ')';                  push @where, 'id in (' . join(',', @{ $tags->{ $args->{tag} } }) . ')';
395                  _log "search for tags $args->{tag}";                  $msg = "Search for tags $args->{tag}";
396          }          }
397    
398          if (my $date = $args->{date} ) {          if (my $date = $args->{date} ) {
399                  $date = check_date( $date );                  $date = check_date( $date );
400                  push @where, 'date(time) = ?';                  push @where, 'date(time) = ?';
401                  push @args, $date;                  push @args, $date;
402                  _log "search for date $date";                  $msg = "search for date $date";
403          }          }
404    
405          $sql .= " where " . join(" and ", @where) if @where;          $sql .= " where " . join(" and ", @where) if @where;
# Line 402  sub get_from_log { Line 413  sub get_from_log {
413          eval { $sth->execute( @args ) };          eval { $sth->execute( @args ) };
414          return if $@;          return if $@;
415    
416            my $nr_results = $sth->rows;
417    
418          my $last_row = {          my $last_row = {
419                  date => '',                  date => '',
420                  time => '',                  time => '',
# Line 422  sub get_from_log { Line 435  sub get_from_log {
435    
436          return @rows if ($args->{full_rows});          return @rows if ($args->{full_rows});
437    
438          my @msgs = (          $msg .= ' produced ' . (
439                  "Showing " . ($#rows + 1) . " messages..."                  $nr_results == 0 ? 'no results' :
440                    $nr_results == 0 ? 'one result' :
441                            $nr_results . ' results'
442          );          );
443    
444            my @msgs = ( $msg );
445    
446          if ($context) {          if ($context) {
447                  my @ids = @rows;                  my @ids = @rows;
448                  @rows = ();                  @rows = ();
# Line 482  sub get_from_log { Line 499  sub get_from_log {
499  #                       $row->{nick} = $nick;  #                       $row->{nick} = $nick;
500  #               }  #               }
501    
502                    $append = 0 if $row->{me};
503    
504                  if ($last_row->{nick} ne $nick) {                  if ($last_row->{nick} ne $nick) {
505                          # 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
506                          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 534  sub add_tag { Line 553  sub add_tag {
553          return unless ($arg->{id} && $arg->{message});          return unless ($arg->{id} && $arg->{message});
554    
555          my $m = $arg->{message};          my $m = $arg->{message};
         from_to('UTF-8', 'iso-8859-2', $m) if (is_utf8($m));  
556    
557          my @tags;          my @tags;
558    
# Line 603  sub save_message { Line 621  sub save_message {
621                  $a->{me} ? "***" . $a->{nick} : "<" . $a->{nick} . ">",                  $a->{me} ? "***" . $a->{nick} : "<" . $a->{nick} . ">",
622                  " " . $a->{message};                  " " . $a->{message};
623    
624          $sth->execute($a->{channel}, $a->{me}, $a->{nick}, $a->{message}, $a->{time});          $sth_insert_log->execute($a->{channel}, $a->{me}, $a->{nick}, $a->{message}, $a->{time});
625          add_tag( id => $dbh->last_insert_id(undef,undef,"log",undef), %$a );          add_tag( id => $dbh->last_insert_id(undef,undef,"log",undef), %$a );
626  }  }
627    
# Line 646  if ($import_dircproxy) { Line 664  if ($import_dircproxy) {
664  # RSS follow  # RSS follow
665  #  #
666    
667  my $_rss;  my $_stat;
668    
669    
670  sub rss_fetch {  sub rss_fetch {
671          my ($args) = @_;          my ($args) = @_;
672    
673    
674          # 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?
675          my $send_rss_msgs = 1;          my $send_rss_msgs = 1;
676    
677            _log "RSS fetch", $args->{url};
678    
679          my $feed = XML::Feed->parse(URI->new( $args->{url} ));          my $feed = XML::Feed->parse(URI->new( $args->{url} ));
680          if ( ! $feed ) {          if ( ! $feed ) {
681                  _log("can't fetch RSS ", $args->{url});                  _log("can't fetch RSS ", $args->{url});
682                  return;                  return;
683          }          }
684          my $updates = 0;  
685            $_stat->{rss}->{url2link}->{ $args->{url} } = $feed->link;
686    
687            my ( $total, $updates ) = ( 0, 0 );
688          for my $entry ($feed->entries) {          for my $entry ($feed->entries) {
689                    $total++;
690    
691                  # seen allready?                  # seen allready?
692                  return if $_rss->{$feed->link}->{seen}->{$entry->id}++ > 0;                  next if $_stat->{rss}->{seen}->{$args->{channel}}->{$feed->link}->{$entry->id}++ > 0;
693    
694                  sub prefix {                  sub prefix {
695                          my ($txt,$var) = @_;                          my ($txt,$var) = @_;
696                            $var =~ s/\s+/ /gs;
697                          $var =~ s/^\s+//g;                          $var =~ s/^\s+//g;
698                            $var =~ s/\s+$//g;
699                          return $txt . $var if $var;                          return $txt . $var if $var;
700                  }                  }
701    
702                    # fix absolute and relative links to feed entries
703                    my $link = $entry->link;
704                    if ( $link =~ m!^/! ) {
705                            my $host = $args->{url};
706                            $host =~ s!^(http://[^/]+).*$!$1!;      #!vim
707                            $link = "$host/$link";
708                    } elsif ( $link !~ m!^http! ) {
709                            $link = $args->{url} . $link;
710                    }
711    
712                  my $msg;                  my $msg;
713                  $msg .= prefix( 'From: ' , $feed->title );                  $msg .= prefix( 'From: ' , $args->{name} || $feed->title );
714                  $msg .= prefix( ' by ' , $entry->author );                  $msg .= prefix( ' by ' , $entry->author );
715                  $msg .= prefix( ' -- ' , $entry->link );                  $msg .= prefix( ' | ' , $entry->title );
716                    $msg .= prefix( ' | ' , $link );
717  #               $msg .= prefix( ' id ' , $entry->id );  #               $msg .= prefix( ' id ' , $entry->id );
718                    if ( my $tags = $entry->category ) {
719                            $tags =~ s!^\s+!!;
720                            $tags =~ s!\s*$! !;
721                            $tags =~ s!,?\s+!// !g;
722                            $msg .= prefix( ' ' , $tags );
723                    }
724    
725                  if ( $args->{kernel} && $send_rss_msgs ) {                  if ( $args->{kernel} && $send_rss_msgs ) {
                         warn "# sending to $CHANNEL\n";  
726                          $send_rss_msgs--;                          $send_rss_msgs--;
727                          $args->{kernel}->post( $IRC_ALIAS => notice => $CHANNEL, $msg );                          if ( ! $args->{private} ) {
728                                    # FIXME bug! should be save_message
729                                    save_message( channel => $args->{channel}, me => 1, nick => $NICK, message => $msg );
730    #                               $sth_insert_log->execute( $args->{channel}, 1, $NICK, $msg, 'now()' );
731                            }
732                            my ( $type, $to ) = ( 'notice', $args->{channel} );
733                            ( $type, $to ) = ( 'privmsg', $args->{nick} ) if $args->{private};
734    
735                            _log(">> $type $to", $msg);
736    #                       $args->{kernel}->post( $irc => $type => $to, $msg );
737                            # XXX enqueue message to send later
738                            sub enqueue_post {
739                                    my $post = dump( @_ );
740                                    warn "## queue_post $post\n" if $debug;
741                                    $dq->enqueue_string( $post );
742                            }
743                            enqueue_post( $type => $to => $msg );
744    
745                          $updates++;                          $updates++;
                         save_message( channel => $CHANNEL, me => 1, nick => $NICK, message => $msg );  
                         _log('RSS', $msg);  
746                  }                  }
747          }          }
748    
# Line 693  sub rss_fetch { Line 751  sub rss_fetch {
751          $sql .= qq{where id = } . $args->{id};          $sql .= qq{where id = } . $args->{id};
752          eval { $dbh->do( $sql ) };          eval { $dbh->do( $sql ) };
753    
754            _log "RSS got $total items of which $updates new";
755    
756          return $updates;          return $updates;
757  }  }
758    
759  sub rss_fetch_all {  sub rss_fetch_all {
760          my $kernel = shift;          my $kernel = shift;
761          my $sql = qq{          my $sql = qq{
762                  select id, url, name                  select id, url, name, channel, nick, private
763                  from feeds                  from feeds
764                  where active is true                  where active is true
765          };          };
# Line 710  sub rss_fetch_all { Line 770  sub rss_fetch_all {
770          warn "# ",$sth->rows," active RSS feeds\n";          warn "# ",$sth->rows," active RSS feeds\n";
771          my $count = 0;          my $count = 0;
772          while (my $row = $sth->fetchrow_hashref) {          while (my $row = $sth->fetchrow_hashref) {
                 warn "+++ fetch RSS feed: ",dump( $row );  
773                  $row->{kernel} = $kernel if $kernel;                  $row->{kernel} = $kernel if $kernel;
774                  $count += rss_fetch( $row );                  $count += rss_fetch( $row );
775          }          }
776          return "OK, fetched $count posts from " . $sth->rows . " feeds";          return "OK, fetched $count posts from " . $sth->rows . " feeds";
777  }  }
778    
 my $rss_last_poll = time();  
779    
780  sub rss_check_updates {  sub rss_check_updates {
781          my $kernel = shift;          my $kernel = shift;
782          my $t = time();          $_stat->{rss}->{last_poll} ||= time();
783          if ( $rss_last_poll - $t > $rss_min_delay ) {          my $dt = time() - $_stat->{rss}->{last_poll};
784                  $rss_last_poll = $t;          if ( $dt > $rss_min_delay ) {
785                    warn "## rss_check_updates $dt > $rss_min_delay\n";
786                    $_stat->{rss}->{last_poll} = time();
787                  _log rss_fetch_all( $kernel );                  _log rss_fetch_all( $kernel );
788          }          }
789            # XXX send queue messages
790            while ( my $job = $dq->pickup_queued_job() ) {
791                    my $data = read_file( $job->get_data_path ) || die "can't load ", $job->get_data_path, ": $!";
792    #               $kernel->post( $irc => $type => $to, $msg );
793                    my @data = eval $data;
794                    _log ">> post from queue ", $irc, @data;
795                    $kernel->post( $irc => @data );
796                    $job->finish;
797                    warn "## done queued job: ",dump( @data ) if $debug;
798            }
799  }  }
800    
801  # seed rss seen cache so we won't send out all items on startup  # seed rss seen cache so we won't send out all items on startup
802  _log rss_fetch_all;  _log rss_fetch_all if ! $debug;
   
 #  
 # POE handing part  
 #  
   
 my $SKIPPING = 0;               # if skipping, how many we've done  
 my $SEND_QUEUE;                 # cache  
 my $ping;                                               # ping stats  
   
 POE::Component::IRC->new($IRC_ALIAS);  
803    
804  POE::Session->create( inline_states => {  POE::Session->create( inline_states => {
805          _start => sub {                _start => sub {      
806                  $_[KERNEL]->post($IRC_ALIAS => register => 'all');                  $_[KERNEL]->post( $irc => register => 'all' );
807                  $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);                  $_[KERNEL]->post( $irc => connect => {} );
808      },      },
809            irc_001 => sub {
810                    my ($kernel,$sender) = @_[KERNEL,SENDER];
811                    my $poco_object = $sender->get_heap();
812                    _log "connected to",$poco_object->server_name();
813                    $kernel->post( $sender => join => $_ ) for @channels;
814                    undef;
815            },
816      irc_255 => sub {    # server is done blabbing      irc_255 => sub {    # server is done blabbing
817                  $_[KERNEL]->post($IRC_ALIAS => join => $CHANNEL);                  $_[KERNEL]->post( $irc => join => $CHANNEL);
                 $_[KERNEL]->post($IRC_ALIAS => join => '#logger');  
                 $_[KERNEL]->yield("heartbeat"); # start heartbeat  
                 $_[KERNEL]->yield("my_add", $_) for keys %FOLLOWS;  
                 $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );  
818      },      },
819      irc_public => sub {      irc_public => sub {
820                  my $kernel = $_[KERNEL];                  my $kernel = $_[KERNEL];
# Line 761  POE::Session->create( inline_states => { Line 824  POE::Session->create( inline_states => {
824    
825                  save_message( channel => $channel, me => 0, nick => $nick, message => $msg);                  save_message( channel => $channel, me => 0, nick => $nick, message => $msg);
826                  meta( $nick, $channel, 'last-msg', $msg );                  meta( $nick, $channel, 'last-msg', $msg );
827                    rss_check_updates( $kernel );
828      },      },
829      irc_ctcp_action => sub {      irc_ctcp_action => sub {
830                  my $kernel = $_[KERNEL];                  my $kernel = $_[KERNEL];
# Line 782  POE::Session->create( inline_states => { Line 846  POE::Session->create( inline_states => {
846      },      },
847          irc_ping => sub {          irc_ping => sub {
848                  _log( "pong ", $_[ARG0] );                  _log( "pong ", $_[ARG0] );
849                  $ping->{ $_[ARG0] }++;                  $_stat->{ping}->{ $_[ARG0] }++;
850                  rss_check_updates( $_[KERNEL] );                  rss_check_updates( $_[KERNEL] );
851          },          },
852          irc_invite => sub {          irc_invite => sub {
# Line 792  POE::Session->create( inline_states => { Line 856  POE::Session->create( inline_states => {
856    
857                  _log "invited to $channel by $nick";                  _log "invited to $channel by $nick";
858    
859                  $_[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..." );
860                  $_[KERNEL]->post($IRC_ALIAS => join => $channel);                  $_[KERNEL]->post( $irc => 'join' => $channel );
861    
862          },          },
863          irc_msg => sub {          irc_msg => sub {
# Line 801  POE::Session->create( inline_states => { Line 865  POE::Session->create( inline_states => {
865                  my $nick = (split /!/, $_[ARG0])[0];                  my $nick = (split /!/, $_[ARG0])[0];
866                  my $msg = $_[ARG2];                  my $msg = $_[ARG2];
867                  my $channel = $_[ARG1]->[0];                  my $channel = $_[ARG1]->[0];
868                    warn "# ARG = ",dump( @_[ARG0,ARG1,ARG2] ) if $debug;
869    
870                  my $res = "unknown command '$msg', try /msg $NICK help!";                  my $res = "unknown command '$msg', try /msg $NICK help!";
871                  my @out;                  my @out;
# Line 811  POE::Session->create( inline_states => { Line 876  POE::Session->create( inline_states => {
876    
877                          $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";
878    
879                  } elsif ($msg =~ m/^msg\s+(\S+)\s+(.*)$/i) {                  } elsif ($msg =~ m/^(privmsg|notice)\s+(\S+)\s+(.*)$/i) {
880    
881                          _log ">> /msg $1 $2";                          _log ">> /$1 $2 $3";
882                          $_[KERNEL]->post( $IRC_ALIAS => privmsg => $1, $2 );                          $_[KERNEL]->post( $irc => $1 => $2, $3 );
883                          $res = '';                          $res = '';
884    
885                  } elsif ($msg =~ m/^stat.*?\s*(\d*)/i) {                  } elsif ($msg =~ m/^stat.*?\s*(\d*)/i) {
# Line 844  POE::Session->create( inline_states => { Line 909  POE::Session->create( inline_states => {
909    
910                          foreach my $res (get_from_log( limit => $limit )) {                          foreach my $res (get_from_log( limit => $limit )) {
911                                  _log "last: $res";                                  _log "last: $res";
912                                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );                                  $_[KERNEL]->post( $irc => privmsg => $nick, $res );
913                          }                          }
914    
915                          $res = '';                          $res = '';
# Line 858  POE::Session->create( inline_states => { Line 923  POE::Session->create( inline_states => {
923                                          search => $what,                                          search => $what,
924                                  )) {                                  )) {
925                                  _log "search [$what]: $res";                                  _log "search [$what]: $res";
926                                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );                                  $_[KERNEL]->post( $irc => privmsg => $nick, $res );
927                          }                          }
928    
929                          $res = '';                          $res = '';
# Line 893  POE::Session->create( inline_states => { Line 958  POE::Session->create( inline_states => {
958                                  " : " . ( $stat->{vote}->{'-'} || 0 ) . " --" .                                  " : " . ( $stat->{vote}->{'-'} || 0 ) . " --" .
959                                  " from " . ( join(", ", @nicks) || 'nobody' );                                  " from " . ( join(", ", @nicks) || 'nobody' );
960    
961                          $_[KERNEL]->post( $IRC_ALIAS => notice => $nick, $res );                          $_[KERNEL]->post( $irc => notice => $nick, $res );
962    
963                  } elsif ($msg =~ m/^ping/) {                  } elsif ($msg =~ m/^ping/) {
964                          $res = "ping = " . dump( $ping );                          $res = "ping = " . dump( $_stat->{ping} );
965                  } elsif ($msg =~ m/^conf(?:ig)*\s*(last-size|twitter)*\s*(.*)/) {                  } elsif ($msg =~ m/^conf(?:ig)*\s*(last-size|twitter)*\s*(.*)/) {
966                          if ( ! defined( $1 ) ) {                          if ( ! defined( $1 ) ) {
967                                  my $sth = $dbh->prepare(qq{ select name,value,changed from meta where nick = ? and channel = ? });                                  my $sth = $dbh->prepare(qq{ select name,value,changed from meta where nick = ? and channel = ? });
# Line 929  POE::Session->create( inline_states => { Line 994  POE::Session->create( inline_states => {
994                          }                          }
995                  } elsif ($msg =~ m/^rss-update/) {                  } elsif ($msg =~ m/^rss-update/) {
996                          $res = rss_fetch_all( $_[KERNEL] );                          $res = rss_fetch_all( $_[KERNEL] );
997                  } elsif ($msg =~ m/^rss-clean/) {                  } elsif ($msg =~ m/^rss-list/) {
998                          $_rss = undef;                          my $sth = $dbh->prepare(qq{ select url,name,last_update,active,channel,nick,private from feeds });
999                          $res = "OK, cleaned RSS cache";                          $sth->execute;
1000                  } elsif ($msg =~ m!^rss-(add|remove|stop|start)\s+(http://\S+)\s*(.*)!) {                          while (my @row = $sth->fetchrow_array) {
1001                                    $_[KERNEL]->post( $irc => privmsg => $nick, join(' | ',@row) );
1002                            }
1003                            $res = '';
1004                    } elsif ($msg =~ m!^rss-(add|remove|stop|start|clean)(?:-(private))?\s+(http://\S+)\s*(.*)!) {
1005                            my ( $command, $sub, $url, $arg ) = ( $1,$2,$3,$4 );
1006    
1007                            my $channel = $1 if ( $arg =~ s/\s*(#\S+)\s*// );
1008                            $channel = $nick if $sub eq 'private';
1009    
1010                          my $sql = {                          my $sql = {
1011                                  add             => qq{ insert into feeds (url,name) values (?,?) },                                  add     => qq{ insert into feeds (url,name,channel,nick,private) values (?,?,?,?,?) },
1012  #                               remove  => qq{ delete from feeds                                where url = ? and name = ? },  #                               remove  => qq{ delete from feeds                                where url = ? and name = ? },
1013                                  start   => qq{ update feeds set active = true   where url = ? -- ? },                                  start   => qq{ update feeds set active = true   where url = ? },
1014                                  stop    => qq{ update feeds set active = false  where url = ? -- ? },                                  stop    => qq{ update feeds set active = false  where url = ? },
1015                                                                    clean   => qq{ update feeds set last_update = now() - delay where url = ? },
1016                          };                          };
1017                          if (my $q = $sql->{$1} ) {  
1018                            if ( $command eq 'add' && ! $channel ) {
1019                                    $res = "ERROR: got '$msg' which doesn't have #channel in it, ignoring!";
1020                            } elsif (my $q = $sql->{$command} ) {
1021                                  my $sth = $dbh->prepare( $q );                                  my $sth = $dbh->prepare( $q );
1022                                  warn "## SQL $q ( $2 | $3 )\n";                                  my @data = ( $url );
1023                                  eval { $sth->execute( $2, $3 ) };                                  if ( $command eq 'add' ) {
1024                                            push @data, ( $arg, $channel, $nick, $sub eq 'private' ? 1 : 0 );
1025                                    }
1026                                    warn "## $command SQL $q with ",dump( @data ),"\n";
1027                                    eval { $sth->execute( @data ) };
1028                                    if ($@) {
1029                                            $res = "ERROR: $@";
1030                                    } else {
1031                                            $res = "OK, RSS executed $command " . ( $sub ? "-$sub" : '' ) ."on $channel url $url";
1032                                            if ( $command eq 'clean' ) {
1033                                                    my $seen = $_stat->{rss}->{seen} || die "no seen?";
1034                                                    my $want_link = $_stat->{rss}->{url2link}->{$url} || warn "no url2link($url)";
1035                                                    foreach my $c ( keys %$seen ) {
1036                                                            my $c_hash = $seen->{$c} || die "no seen->{$c}";
1037                                                            die "not HASH with rss links but ", dump($c_hash) unless ref($c_hash) eq 'HASH';
1038                                                            foreach my $link ( keys %$c_hash ) {
1039                                                                    next unless $link eq $want_link;
1040                                                                    _log "RSS removed seen $c $url $link";
1041                                                            }
1042                                                    }
1043                                            }
1044                                    }
1045                            } else {
1046                                    $res = "ERROR: don't know what to do with: $msg";
1047                          }                          }
1048                    } elsif ($msg =~ m/^rss-clean/) {
1049                          $res ||= "OK, RSS $1 : $2 - $3";                          # this makes sense because we didn't catch rss-clean http://... before!
1050                            $_stat->{rss} = undef;
1051                            $dbh->do( qq{ update feeds set last_update = now() - delay } );
1052                            $res = "OK, cleaned RSS cache";
1053                  }                  }
1054    
1055                  if ($res) {                  if ($res) {
1056                          _log ">> [$nick] $res";                          _log ">> [$nick] $res";
1057                          $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );                          $_[KERNEL]->post( $irc => privmsg => $nick, $res );
1058                  }                  }
1059    
1060                  rss_check_updates( $_[KERNEL] );                  rss_check_updates( $_[KERNEL] );
1061          },          },
1062            irc_372 => sub {
1063                    _log "<< motd",$_[ARG0],$_[ARG1];
1064            },
1065            irc_375 => sub {
1066                    _log "<< motd", $_[ARG0], "start";
1067            },
1068            irc_376 => sub {
1069                    _log "<< motd", $_[ARG0], "end";
1070            },
1071    #       irc_433 => sub {
1072    #               print "# irc_433: ",$_[ARG1], "\n";
1073    #               warn "## indetify $NICK\n";
1074    #               $_[KERNEL]->post( $irc => privmsg => 'nickserv', "IDENTIFY $NICK" );
1075    #       },
1076    #       irc_451 # please register
1077          irc_477 => sub {          irc_477 => sub {
1078                  _log "# irc_477: ",$_[ARG1];                  _log "<< irc_477: ",$_[ARG1];
1079                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "register $NICK" );                  _log ">> IDENTIFY $NICK";
1080                    $_[KERNEL]->post( $irc => privmsg => 'NickServ', "IDENTIFY $NICK" );
1081          },          },
1082          irc_505 => sub {          irc_505 => sub {
1083                  _log "# irc_505: ",$_[ARG1];                  _log "<< irc_505: ",$_[ARG1];
1084                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "register $NICK" );                  _log ">> register $NICK";
1085  #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "set hide email on" );                  $_[KERNEL]->post( $irc => privmsg => 'NickServ', "register $NICK" );
1086  #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "set email dpavlin\@rot13.org" );  #               $_[KERNEL]->post( $irc => privmsg => 'nickserv', "IDENTIFY $NICK" );
1087    #               $_[KERNEL]->post( $irc => privmsg => 'nickserv', "set hide email on" );
1088    #               $_[KERNEL]->post( $irc => privmsg => 'nickserv', "set email dpavlin\@rot13.org" );
1089          },          },
1090          irc_registered => sub {          irc_registered => sub {
1091                  _log "## registrated $NICK";                  _log "<< registered $NICK";
                 $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );  
1092          },          },
1093          irc_disconnected => sub {          irc_disconnected => sub {
1094                  _log "## disconnected, reconnecting again";                  _log "## disconnected.. sleeping for $sleep_on_error seconds and reconnecting again";
1095                  $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);                  sleep($sleep_on_error);
1096                    $_[KERNEL]->post( $irc => connect => {} );
1097          },          },
1098          irc_socketerr => sub {          irc_socketerr => sub {
1099                  _log "## socket error... sleeping for $sleep_on_error seconds and retry";                  _log "## socket error... sleeping for $sleep_on_error seconds and retry";
1100                  sleep($sleep_on_error);                  sleep($sleep_on_error);
1101                  $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);                  $_[KERNEL]->post( $irc => connect => {} );
1102            },
1103            irc_notice => sub {
1104                    _log "<< notice from ", $_[ARG0], $_[ARG1], $_[ARG2];
1105                    my $m = $_[ARG2];
1106                    if ( $m =~ m!/msg.*(NickServ).*(IDENTIFY)!i ) {
1107                            _log ">> suggested to $1 $2";
1108                            $_[KERNEL]->post( $irc => privmsg => $1, "$2 $NICK" );
1109                    } elsif ( $m =~ m!\Q$NICK\E.*registered!i ) {
1110                            _log ">> registreted, so IDENTIFY";
1111                            $_[KERNEL]->post( $irc => privmsg => 'nickserv', "IDENTIFY $NICK" );
1112                    } else {
1113                            warn "## ignore $m\n" if $debug;
1114                    }
1115            },
1116            irc_snotice => sub {
1117                    _log "<< snotice", $_[ARG0]; #dump( $_[ARG0],$_[ARG1], $_[ARG2] );
1118                    if ( $_[ARG0] =~ m!/(QUOTE)\s+(PASS\s+\d+)!i ) {
1119                            warn ">> $1 | $2\n";
1120                            $_[KERNEL]->post( $irc => lc($1) => $2);
1121                    }
1122          },          },
 #       irc_433 => sub {  
 #               print "# irc_433: ",$_[ARG1], "\n";  
 #               warn "## indetify $NICK\n";  
 #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );  
 #       },  
1123      _child => sub {},      _child => sub {},
1124      _default => sub {      _default => sub {
1125                  _log sprintf "sID:%s %s %s",                  _log sprintf "sID:%s %s %s",
# Line 993  POE::Session->create( inline_states => { Line 1129  POE::Session->create( inline_states => {
1129                          "";                          "";
1130        0;                        # false for signals        0;                        # false for signals
1131      },      },
     my_add => sub {  
       my $trailing = $_[ARG0];  
       my $session = $_[SESSION];  
       POE::Session->create  
           (inline_states =>  
            {_start => sub {  
               $_[HEAP]->{wheel} =  
                 POE::Wheel::FollowTail->new  
                     (  
                      Filename => $FOLLOWS{$trailing},  
                      InputEvent => 'got_line',  
                     );  
                                 warn "+++ following $trailing at $FOLLOWS{$trailing}\n";  
             },  
             got_line => sub {  
                                 warn "+++ $trailing : $_[ARG0]\n";  
                                 $_[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);  
     }  
1132     },     },
1133    );    );
1134    
1135  # http server  # http server
1136    
1137    _log "WEB archive at $url";
1138    
1139  my $httpd = POE::Component::Server::HTTP->new(  my $httpd = POE::Component::Server::HTTP->new(
1140          Port => $http_port,          Port => $http_port,
1141          PreHandler => {          PreHandler => {
# Line 1105  foreach my $c (@cols) { Line 1182  foreach my $c (@cols) {
1182          $style .= ".col-${max_color} { background: $c }\n";          $style .= ".col-${max_color} { background: $c }\n";
1183          $max_color++;          $max_color++;
1184  }  }
1185  warn "defined $max_color colors for users...\n";  _log "WEB defined $max_color colors for users...";
1186    
1187  sub root_handler {  sub root_handler {
1188          my ($request, $response) = @_;          my ($request, $response) = @_;
# Line 1127  sub root_handler { Line 1204  sub root_handler {
1204          }          }
1205    
1206          my $search = $q->param('search') || $q->param('grep') || '';          my $search = $q->param('search') || $q->param('grep') || '';
1207            my $r_url = $request->url;
1208    
1209          if ($request->url =~ m#/rss(?:/(tags|last-tag|follow.*)\w*(?:=(\d+))?)?#i) {          my @commands = qw( tags last-tag follow stat );
1210            my $commands_re = join('|',@commands);
1211    
1212            if ($r_url =~ m#/rss(?:/($commands_re.*)\w*(?:=(\d+))?)?#i) {
1213                  my $show = lc($1);                  my $show = lc($1);
1214                  my $nr = $2;                  my $nr = $2;
1215    
# Line 1142  sub root_handler { Line 1223  sub root_handler {
1223                  my $feed = XML::Feed->new( $type );                  my $feed = XML::Feed->new( $type );
1224                  $feed->link( $url );                  $feed->link( $url );
1225    
1226                    my $rc = RC_OK;
1227    
1228                  if ( $show eq 'tags' ) {                  if ( $show eq 'tags' ) {
1229                          $nr ||= 50;                          $nr ||= 50;
1230                          $feed->title( "tags from $CHANNEL" );                          $feed->title( "tags from $CHANNEL" );
# Line 1211  sub root_handler { Line 1294  sub root_handler {
1294                                  $feed->add_entry( $feed_entry );                                  $feed->add_entry( $feed_entry );
1295                          }                          }
1296    
1297                    } elsif ( $show =~ m/^stat/ ) {
1298    
1299                            my $feed_entry = XML::Feed::Entry->new($type);
1300                            $feed_entry->title( "Internal stats" );
1301                            $feed_entry->content(
1302                                    '<![CDATA[<pre>' . dump( $_stat ) . '</pre>]]>'
1303                            );
1304                            $feed->add_entry( $feed_entry );
1305    
1306                  } else {                  } else {
1307                          _log "unknown rss request ",$request->url;                          _log "WEB unknown rss request $r_url";
1308                          return RC_DENY;                          $feed->title( "unknown $r_url" );
1309                            foreach my $c ( @commands ) {
1310                                    my $feed_entry = XML::Feed::Entry->new($type);
1311                                    $feed_entry->title( "rss/$c" );
1312                                    $feed_entry->link( "$url/rss/$c" );
1313                                    $feed->add_entry( $feed_entry );
1314                            }
1315                            $rc = RC_DENY;
1316                  }                  }
1317    
1318                  $response->content( $feed->as_xml );                  $response->content( $feed->as_xml );
1319                  return RC_OK;                  return $rc;
1320          }          }
1321    
1322          if ( $@ ) {          if ( $@ ) {
# Line 1275  sub root_handler { Line 1374  sub root_handler {
1374                          }                          }
1375                          $cal->setcontent($dd, qq[                          $cal->setcontent($dd, qq[
1376                                  <a href="$url?date=$row->{date}">$row->{nr}</a><br/>$row->{len}                                  <a href="$url?date=$row->{date}">$row->{nr}</a><br/>$row->{len}
1377                          ]);                          ]) if $cal;
1378                                                    
1379                  }                  }
1380                  $html .= qq{<td valign="top">} . $cal->as_HTML() . qq{</td></tr></table>};                  $html .= qq{<td valign="top">} . $cal->as_HTML() . qq{</td></tr></table>};
Legend:
Removed from v.86  
changed lines
  Added in v.119
  ViewVC Help
Powered by ViewVC 1.1.26