--- trunk/bin/irc-logger.pl 2008/03/10 21:52:49 114 +++ trunk/bin/irc-logger.pl 2009/02/06 14:12:00 141 @@ -2,12 +2,11 @@ use strict; $|++; -use POE qw(Component::IRC Component::Server::HTTP); +use POE qw(Component::IRC Component::Server::HTTP Component::Client::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; @@ -18,6 +17,7 @@ use Carp qw/confess/; use XML::Feed; use DateTime::Format::Flexible; +use Encode; =head1 NAME @@ -47,6 +47,8 @@ ## CONFIG +my $debug = 0; + my $irc_config = { nick => 'irc-logger', server => 'irc.freenode.net', @@ -75,7 +77,7 @@ my @channels = ( $CHANNEL ); -warn "# config = ", dump( $irc_config ), $/; +warn "## config = ", dump( $irc_config ) if $debug; my $NICK = $irc_config->{nick} or die "no nick?"; @@ -106,24 +108,26 @@ GetOptions( 'import-dircproxy:s' => \$import_dircproxy, 'log:s' => \$log_path, + 'debug!' => \$debug, ); #$SIG{__DIE__} = sub { # confess "fatal error"; #}; -open(STDOUT, '>', $log_path) || warn "can't redirect log to $log_path: $!"; - sub _log { - print strftime($TIMESTAMP,localtime()) . ' ' . join(" ",@_) . $/; + print strftime($TIMESTAMP,localtime()) . ' ' . join(" ",map { ref($_) ? dump( $_ ) : $_ } @_) . $/; } +open(STDOUT, '>', $log_path) && warn "log to $log_path: $!\n"; + + # HTML formatters my %escape = ('<'=>'<', '>'=>'>', '&'=>'&', '"'=>'"'); my $escape_re = join '|' => keys %escape; -my $tag_regex = '\b([\w-_]+)//'; +my $tag_regex = '\b([\w\-_]+)//'; my %nick_enumerator; my $max_color = 0; @@ -135,7 +139,8 @@ # protect HTML from wiki modifications sub e { my $t = shift; - return 'uri_unescape{' . uri_escape($t, '^a-zA-Z0-9') . '}'; + eval { $t = 'uri_unescape{' . uri_escape($t, '^a-zA-Z0-9') . '}'; }; + return $t; } $m =~ s/($escape_re)/$escape{$1}/gs; @@ -251,13 +256,20 @@ eval { $sth->execute( $value, $nick, $channel, $name ) }; - # error or no result - if ( $@ || ! $sth->rows ) { + if ( $@ ) { + # error + _log("META ERROR: $@"); + } elsif ( ! $sth->rows ) { + # no result -> add new $sth = $dbh->prepare(qq{ insert into meta (value,nick,channel,name,changed) values (?,?,?,?,now()) }); - $sth->execute( $value, $nick, $channel, $name ); - warn "## created $nick/$channel/$name = $value\n"; + eval { $sth->execute( $value, $nick, $channel, $name ); }; + if ( $@ ) { + _log "META ERROR: $@"; + } else { + _log "META: created $nick/$channel/$name = $value\n"; + } } else { - warn "## updated $nick/$channel/$name = $value\n"; + _log "META: updated $nick/$channel/$name = $value\n"; } return $value; @@ -521,62 +533,8 @@ # tags support -my $cloud = HTML::TagCloud->new; - -=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; - +my $cloud = TagCloud->new; +$cloud->seed_tags; =head2 save_message @@ -600,13 +558,17 @@ $a->{me} ||= 0; $a->{time} ||= strftime($TIMESTAMP,localtime()); - _log + _log "ARCHIVE", $a->{channel}, " ", $a->{me} ? "***" . $a->{nick} : "<" . $a->{nick} . ">", " " . $a->{message}; - $sth_insert_log->execute($a->{channel}, $a->{me}, $a->{nick}, $a->{message}, $a->{time}); - add_tag( id => $dbh->last_insert_id(undef,undef,"log",undef), %$a ); + eval { $sth_insert_log->execute($a->{channel}, $a->{me}, $a->{nick}, $a->{message}, $a->{time}); }; + if ( $@ ) { + _log "ERROR: can't archive ", $a->{message}; + } else { + $cloud->add_tag( id => $dbh->last_insert_id(undef,undef,"log",undef), %$a ); + } } @@ -650,27 +612,48 @@ my $_stat; +POE::Component::Client::HTTP->spawn( + Alias => 'rss-fetch', + Timeout => 30, +); + +=head2 rss_parse_xml -sub rss_fetch { - my ($args) = @_; + rss_parse_xml({ + url => 'http://www.example.com/rss', + send_rss_msgs => 42, + }); + +=cut + +sub rss_parse_xml { + my ($kernel,$args) = @_; + + warn "## rss_parse_xml ",dump( $args ) if $debug; # how many messages to send out when feed is seen for the first time? - my $send_rss_msgs = 1; + my $send_rss_msgs = $args->{send_rss_msgs}; + $send_rss_msgs = 1 if ! defined $send_rss_msgs; - _log "RSS fetch", $args->{url}; + warn "## RSS fetch first $send_rss_msgs items from", $args->{url} if $debug; - my $feed = XML::Feed->parse(URI->new( $args->{url} )); + my $feed; + eval { $feed = XML::Feed->parse( \$args->{xml} ) }; if ( ! $feed ) { - _log("can't fetch RSS ", $args->{url}); + _log "can't fetch RSS ", $args->{url}, XML::Feed->errstr; return; } + $_stat->{rss}->{url2link}->{ $args->{url} } = $feed->link; + my ( $total, $updates ) = ( 0, 0 ); for my $entry ($feed->entries) { $total++; + my $seen_times = $_stat->{rss}->{seen}->{$args->{channel}}->{$feed->link}->{$entry->id}++; # seen allready? - next if $_stat->{rss}->{seen}->{$args->{channel}}->{$feed->link}->{$entry->id}++ > 0; + warn "## $seen_times ",$entry->id if $debug; + next if $seen_times > 0; sub prefix { my ($txt,$var) = @_; @@ -696,24 +679,29 @@ $msg .= prefix( ' | ' , $entry->title ); $msg .= prefix( ' | ' , $link ); # $msg .= prefix( ' id ' , $entry->id ); + my @categories = $entry->category; + warn "## category = ", dump( @categories ) if $debug; if ( my $tags = $entry->category ) { + $tags = join(' ', @$tags) if ref($tags) eq 'ARRAY'; $tags =~ s!^\s+!!; $tags =~ s!\s*$! !; - $tags =~ s!\s+!// !g; + $tags =~ s!,?\s+!// !g; $msg .= prefix( ' ' , $tags ); } - if ( $args->{kernel} && $send_rss_msgs ) { + if ( $seen_times == 0 && $send_rss_msgs ) { $send_rss_msgs--; if ( ! $args->{private} ) { # FIXME bug! should be save_message -# save_message( channel => $args->{channel}, me => 1, nick => $NICK, message => $msg ); - $sth_insert_log->execute( $args->{channel}, 1, $NICK, $msg, 'now()' ); + save_message( channel => $args->{channel}, me => 1, nick => $NICK, message => $msg ); +# $sth_insert_log->execute( $args->{channel}, 1, $NICK, $msg, 'now()' ); } my ( $type, $to ) = ( 'notice', $args->{channel} ); ( $type, $to ) = ( 'privmsg', $args->{nick} ) if $args->{private}; - _log(">> $type $to", $msg); - $args->{kernel}->post( $irc => $type => $to, $msg ); + + _log(">> RSS $type to $to:", $msg); + $kernel->post( $irc => $type => $to => $msg ); + $updates++; } } @@ -723,29 +711,37 @@ $sql .= qq{where id = } . $args->{id}; eval { $dbh->do( $sql ) }; - _log "RSS got $total items of which $updates new"; + _log "RSS $updates/$total new items from", $args->{url}; return $updates; } sub rss_fetch_all { - my $kernel = shift; + my ( $kernel, $send_rss_msgs ) = @_; + warn "## rss_fetch_all -- send_rss_msgs: $send_rss_msgs\n" if $debug; my $sql = qq{ select id, url, name, channel, nick, private from feeds where active is true }; # limit to newer feeds only if we are not sending messages out - $sql .= qq{ and last_update + delay < now() } if $kernel; + $sql .= qq{ and last_update + delay < now() } if defined ( $_stat->{rss}->{fetch} ); my $sth = $dbh->prepare( $sql ); $sth->execute(); warn "# ",$sth->rows," active RSS feeds\n"; my $count = 0; while (my $row = $sth->fetchrow_hashref) { - $row->{kernel} = $kernel if $kernel; - $count += rss_fetch( $row ); + $row->{send_rss_msgs} = $send_rss_msgs if defined $send_rss_msgs; + $_stat->{rss}->{fetch}->{ $row->{url} } = $row; + $kernel->post( + 'rss-fetch', + 'request', + 'rss_response', + HTTP::Request->new( GET => $row->{url} ), + ); + warn "## queued rss-fetch ", dump( $row ) if $debug; } - return "OK, fetched $count posts from " . $sth->rows . " feeds"; + return "OK, scheduled " . $sth->rows . " feeds for refresh"; } @@ -753,15 +749,207 @@ my $kernel = shift; $_stat->{rss}->{last_poll} ||= time(); my $dt = time() - $_stat->{rss}->{last_poll}; - warn "## rss_check_updates $dt > $rss_min_delay\n"; if ( $dt > $rss_min_delay ) { + warn "## rss_check_updates $dt > $rss_min_delay\n"; $_stat->{rss}->{last_poll} = time(); _log rss_fetch_all( $kernel ); } } -# seed rss seen cache so we won't send out all items on startup -_log rss_fetch_all; +sub process_command { + my ( $kernel, $nick, $channel, $msg ) = @_; + + my $res = "unknown command '$msg', try /msg $NICK help!"; + + if ($msg =~ m/^help/i) { + + $res = "usage: /msg $NICK comand | commands: stat - user/message stat | last - show backtrace | grep foobar - find foobar"; + + } elsif ($msg =~ m/^(privmsg|notice)\s+(\S+)\s+(.*)$/i) { + + _log ">> /$1 $2 $3"; + $kernel->post( $irc => $1 => $2, $3 ); + $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 => 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 => 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 => notice => $nick, $res ); + + } elsif ($msg =~ m/^ping/) { + $res = "ping = " . dump( $_stat->{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-list/) { + my $sth = $dbh->prepare(qq{ select url,name,last_update,active,channel,nick,private from feeds }); + $sth->execute; + while (my @row = $sth->fetchrow_array) { + $kernel->post( $irc => privmsg => $nick, join(' | ',@row) ); + } + $res = ''; + } elsif ($msg =~ m!^rss-(add|remove|stop|start|clean)(?:-(private))?\s+(http://\S+)\s*(.*)!) { + my ( $command, $sub, $url, $arg ) = ( $1,$2,$3,$4 ); + + my $channel = $1 if ( $arg =~ s/\s*(#\S+)\s*// ); + $channel = $nick if $sub eq 'private'; + + my $sql = { + add => qq{ insert into feeds (url,name,channel,nick,private) values (?,?,?,?,?) }, + remove => qq{ delete from feeds where url = ? and nick = ? }, + start => qq{ update feeds set active = true where url = ? }, + stop => qq{ update feeds set active = false where url = ? }, + clean => qq{ update feeds set last_update = now() - delay where url = ? }, + }; + + if ( $command eq 'add' && ! $channel ) { + $res = "ERROR: got '$msg' which doesn't have #channel in it, ignoring!"; + } elsif (my $q = $sql->{$command} ) { + my $sth = $dbh->prepare( $q ); + my @data = ( $url ); + if ( $command eq 'add' ) { + push @data, ( $arg, $channel, $nick, $sub eq 'private' ? 1 : 0 ); + } elsif ( $command eq 'remove' ) { + push @data, $nick; + } + warn "## $command SQL $q with ",dump( @data ),"\n"; + eval { $sth->execute( @data ) }; + if ($@) { + $res = "ERROR: $@"; + } else { + $res = "OK, RSS executed $command" . + ( $sub ? "-$sub " : ' ' ) . + ( $channel ? "on $channel " : '' ) . + "url $url"; + if ( $command eq 'clean' ) { + my $seen = $_stat->{rss}->{seen} || die "no seen?"; + my $want_link = $_stat->{rss}->{url2link}->{$url} || warn "no url2link($url)"; + foreach my $c ( keys %$seen ) { + my $c_hash = $seen->{$c} || die "no seen->{$c}"; + die "not HASH with rss links but ", dump($c_hash) unless ref($c_hash) eq 'HASH'; + foreach my $link ( keys %$c_hash ) { + next unless $link eq $want_link; + _log "RSS removed seen $c $url $link"; + } + } + } elsif ( $command eq 'add' ) { + rss_fetch_all( $kernel ); + } + } + } else { + $res = "ERROR: don't know what to do with: $msg"; + } + } elsif ($msg =~ m/^rss-clean/) { + # this makes sense because we didn't catch rss-clean http://... before! + $_stat->{rss} = undef; + $dbh->do( qq{ update feeds set last_update = now() - delay } ); + $res = rss_fetch_all( $kernel ); + } + + return $res; +} POE::Session->create( inline_states => { _start => sub { @@ -773,11 +961,13 @@ my $poco_object = $sender->get_heap(); _log "connected to",$poco_object->server_name(); $kernel->post( $sender => join => $_ ) for @channels; + # seen RSS cache, so don't send out messages + _log rss_fetch_all( $kernel, 0 ); undef; }, - irc_255 => sub { # server is done blabbing - $_[KERNEL]->post( $irc => join => $CHANNEL); - }, +# irc_255 => sub { # server is done blabbing +# $_[KERNEL]->post( $irc => join => $CHANNEL); +# }, irc_public => sub { my $kernel = $_[KERNEL]; my $nick = (split /!/, $_[ARG0])[0]; @@ -825,179 +1015,13 @@ irc_msg => sub { my $kernel = $_[KERNEL]; my $nick = (split /!/, $_[ARG0])[0]; - my $msg = $_[ARG2]; my $channel = $_[ARG1]->[0]; - - my $res = "unknown command '$msg', try /msg $NICK help!"; - my @out; + my $msg = $_[ARG2]; + warn "# ARG = ",dump( @_[ARG0,ARG1,ARG2] ) if $debug; _log "<< $msg"; - if ($msg =~ m/^help/i) { - - $res = "usage: /msg $NICK comand | commands: stat - user/message stat | last - show backtrace | grep foobar - find foobar"; - - } elsif ($msg =~ m/^(privmsg|notice)\s+(\S+)\s+(.*)$/i) { - - _log ">> /$1 $2 $3"; - $_[KERNEL]->post( $irc => $1 => $2, $3 ); - $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 => 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 => 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 => notice => $nick, $res ); - - } elsif ($msg =~ m/^ping/) { - $res = "ping = " . dump( $_stat->{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/) { - $_stat->{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,channel,nick,private from feeds }); - $sth->execute; - while (my @row = $sth->fetchrow_array) { - $_[KERNEL]->post( $irc => privmsg => $nick, join(' | ',@row) ); - } - $res = ''; - } elsif ($msg =~ m!^rss-(add|remove|stop|start)(?:-(private))?\s+(http://\S+)\s*(.*)!) { - my ( $command, $sub, $url, $arg ) = ( $1,$2,$3,$4 ); - - my $channel = $1 if ( $arg =~ s/\s*(#\S+)\s*// ); - $channel = $nick if $sub eq 'private'; - - my $sql = { - add => qq{ insert into feeds (url,name,channel,nick,private) 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 ( $command eq 'add' && ! $channel ) { - $res = "ERROR: got '$msg' which doesn't have #channel in it, ignoring!"; - } elsif (my $q = $sql->{$command} ) { - my $sth = $dbh->prepare( $q ); - my @data = ( $url ); - if ( $command eq 'add' ) { - push @data, ( $arg, $channel, $nick, $sub eq 'private' ? 1 : 0 ); - } - warn "## $command SQL $q with ",dump( @data ),"\n"; - eval { $sth->execute( @data ) }; - if ($@) { - $res = "ERROR: $@"; - } else { - $res = "OK, RSS [$command|$sub|$url|$arg]"; - } - } else { - $res = "ERROR: don't know what to do with: $msg"; - } - } + my $res = process_command( $_[KERNEL], $nick, $channel, $msg ); if ($res) { _log ">> [$nick] $res"; @@ -1048,14 +1072,20 @@ $_[KERNEL]->post( $irc => connect => {} ); }, irc_notice => sub { - _log "<< notice",$_[ARG0],dump($_[ARG1]); - if ( $_[ARG0] =~ m!/msg\s+NickServ\s+IDENTIFY!i ) { - _log ">> IDENTIFY"; + _log "<< notice from ", $_[ARG0], $_[ARG1], $_[ARG2]; + my $m = $_[ARG2]; + if ( $m =~ m!/msg.*(NickServ).*(IDENTIFY)!i ) { + _log ">> suggested to $1 $2"; + $_[KERNEL]->post( $irc => privmsg => $1, "$2 $NICK" ); + } elsif ( $m =~ m!\Q$NICK\E.*registered!i ) { + _log ">> registreted, so IDENTIFY"; $_[KERNEL]->post( $irc => privmsg => 'nickserv', "IDENTIFY $NICK" ); + } else { + warn "## ignore $m\n" if $debug; } }, irc_snotice => sub { - _log "<< snotice",$_[ARG0]; + _log "<< snotice", $_[ARG0]; #dump( $_[ARG0],$_[ARG1], $_[ARG2] ); if ( $_[ARG0] =~ m!/(QUOTE)\s+(PASS\s+\d+)!i ) { warn ">> $1 | $2\n"; $_[KERNEL]->post( $irc => lc($1) => $2); @@ -1063,13 +1093,22 @@ }, _child => sub {}, _default => sub { - _log sprintf "sID:%s %s %s", - $_[SESSION]->ID, $_[ARG0], - ref($_[ARG1]) eq "ARRAY" ? join(",", map { ref($_) eq "ARRAY" ? join(";", @{$_}) : $_ } @{ $_[ARG1] }) : - $_[ARG1] ? $_[ARG1] : - ""; - 0; # false for signals + _log '_default SID:', $_[SESSION]->ID, $_[ARG0], dump( $_[ARG1] ); + 0; # false for signals }, + rss_response => sub { + my ($request_packet, $response_packet) = @_[ARG0, ARG1]; + my $request_object = $request_packet->[0]; + my $response_object = $response_packet->[0]; + + my $row = delete( $_stat->{rss}->{fetch}->{ $request_object->uri } ); + if ( $row ) { + $row->{xml} = $response_object->content; + rss_parse_xml( $_[KERNEL], $row ); + } else { + warn "## can't find rss->fetch for ", $request_object->uri; + } + }, }, ); @@ -1159,7 +1198,7 @@ $response->content_type( 'application/' . lc($type) . '+xml' ); my $html = ''; - #warn "create $type feed from ",dump( @last_tags ); + #warn "create $type feed from ",dump( $cloud->last_tags ); my $feed = XML::Feed->new( $type ); $feed->link( $url ); @@ -1193,7 +1232,7 @@ $feed->title( "last $nr tagged messages from $CHANNEL" ); $feed->description( "collects messages which have tags// in them" ); - foreach my $m ( @last_tags ) { + foreach my $m ( $cloud->last_tags ) { # warn dump( $m ); #my $tags = join(' ', @{$m->{tags}} ); my $feed_entry = XML::Feed::Entry->new($type); @@ -1256,7 +1295,8 @@ $rc = RC_DENY; } - $response->content( $feed->as_xml ); + eval { $response->content( $feed->as_xml ); }; + $rc = RC_INTERNAL_SERVER_ERROR if $@; return $rc; } @@ -1323,7 +1363,7 @@ } else { $html .= join("

", get_from_log( - limit => ( $q->param('last') || $q->param('date') ) ? undef : 100, + limit => ( $q->param('date') ? undef : $q->param('last') || 100 ), search => $search || undef, tag => $q->param('tag') || undef, date => $q->param('date') || undef, @@ -1354,3 +1394,110 @@ } POE::Kernel->run; + +=head1 TagCloud + +Extended L + +=cut + +package TagCloud; +use warnings; +use strict; +use HTML::TagCloud; +use base 'HTML::TagCloud'; +use Data::Dump qw/dump/; + +=head2 html + +Generate html with number of tags in title of link + +=cut + +sub html { + my($self, $limit) = @_; + my @tags=$self->tags($limit); + + my $ntags = scalar(@tags); + if ($ntags == 0) { + return ""; +# } elsif ($ntags == 1) { +# my $tag = $tags[0]; +# return qq{

}.$tag->{name}.qq{
\n}; + } + + my $html = qq{
}; + foreach my $tag ( sort { lc($a->{name}) cmp lc($b->{name}) } @tags) { + $html .= sprintf(qq{%s\n}, + $tag->{level}, $tag->{url}, $tag->{count}, $tag->{name} + ); + } + $html .= qq{
}; + return $html; +} + +=head2 last_tags + + my @tags = $cloud->last_tags; + +=cut + +my @last_tags; +sub last_tags { + return @last_tags; +} + +=head2 add_tag + + $cloud->add_tag( id => 42, message => 'irc message', nick => 'foobar' [, me => 1 ] ); + +=cut + + +sub add_tag { + my $self = shift; + 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"; + $self->add($tag, "$url?tag=$tag", scalar @{$tags->{$tag}}); + 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 $self = shift; + 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) { + $self->add_tag( %$row ); + } + + foreach my $tag (keys %$tags) { + $self->add($tag, "$url?tag=$tag", scalar @{$tags->{$tag}}); + } +} +