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

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

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

trunk/irc-logger.pl revision 15 by dpavlin, Mon Mar 13 12:56:26 2006 UTC trunk/bin/irc-logger.pl revision 100 by dpavlin, Sat Mar 8 00:14:41 2008 UTC
# Line 10  irc-logger.pl Line 10  irc-logger.pl
10    
11  ./irc-logger.pl  ./irc-logger.pl
12    
13    =head2 Options
14    
15    =over 4
16    
17    =item --import-dircproxy=filename
18    
19    Import log from C<dircproxy> to C<irc-logger> database
20    
21    =item --log=irc-logger.log
22    
23    =back
24    
25  =head1 DESCRIPTION  =head1 DESCRIPTION
26    
27  log all conversation on irc channel  log all conversation on irc channel
# Line 18  log all conversation on irc channel Line 30  log all conversation on irc channel
30    
31  ## CONFIG  ## CONFIG
32    
33    my $HOSTNAME = `hostname -f`;
34    chomp($HOSTNAME);
35    
36  my $NICK = 'irc-logger';  my $NICK = 'irc-logger';
37    $NICK .= '-dev' if ($HOSTNAME =~ m/llin/);
38  my $CONNECT =  my $CONNECT =
39    {Server => 'irc.freenode.net',    {Server => 'irc.freenode.net',
40     Nick => $NICK,     Nick => $NICK,
41     Ircname => "try /msg $NICK help",     Ircname => "try /msg $NICK help",
42    };    };
43  my $CHANNEL = '#razmjenavjestina';  my $CHANNEL = '#razmjenavjestina';
44    $CHANNEL = '#irc-logger' if ($HOSTNAME =~ m/llin/);
45  my $IRC_ALIAS = "log";  my $IRC_ALIAS = "log";
46    
47  my %FOLLOWS =  my $DSN = 'DBI:Pg:dbname=' . $NICK;
   (  
    ACCESS => "/var/log/apache/access.log",  
    ERROR => "/var/log/apache/error.log",  
   );  
48    
49  my $DSN = 'DBI:Pg:dbname=irc-logger';  my $TIMESTAMP = '%Y-%m-%d %H:%M:%S';
50    
51  my $ENCODING = 'ISO-8859-2';  my $sleep_on_error = 5;
52    
53  ## END CONFIG  # number of last tags to keep in circular buffer
54    my $last_x_tags = 50;
55    
56    # don't pull rss feeds more often than this
57    my $rss_min_delay = 60;
58    
59    my $http_port = $NICK =~ m/-dev/ ? 8001 : 8000;
60    
61    my $url = "http://$HOSTNAME:$http_port";
62    
63  use POE qw(Component::IRC Wheel::FollowTail Component::Server::HTTP);  ## END CONFIG
64    
65    use POE qw(Component::IRC Component::Server::HTTP);
66  use HTTP::Status;  use HTTP::Status;
67  use DBI;  use DBI;
 use Encode qw/from_to/;  
68  use Regexp::Common qw /URI/;  use Regexp::Common qw /URI/;
69    use CGI::Simple;
70    use HTML::TagCloud;
71    use POSIX qw/strftime/;
72    use HTML::CalendarMonthSimple;
73    use Getopt::Long;
74    use DateTime;
75    use URI::Escape;
76    use Data::Dump qw/dump/;
77    use DateTime::Format::ISO8601;
78    use Carp qw/confess/;
79    use XML::Feed;
80    use DateTime::Format::Flexible;
81    
82    my $use_twitter = 1;
83    eval { require Net::Twitter; };
84    $use_twitter = 0 if ($@);
85    
86    my $import_dircproxy;
87    my $log_path;
88    GetOptions(
89            'import-dircproxy:s' => \$import_dircproxy,
90            'log:s' => \$log_path,
91    );
92    
93    #$SIG{__DIE__} = sub {
94    #       confess "fatal error";
95    #};
96    
97  my $dbh = DBI->connect($DSN,"","", { RaiseError => 1, AutoCommit => 1 }) || die $DBI::errstr;  open(STDOUT, '>', $log_path) || warn "can't redirect log to $log_path: $!";
98    
99    sub _log {
100            print strftime($TIMESTAMP,localtime()) . ' ' . join(" ",@_) . $/;
101    }
102    
103    # HTML formatters
104    
105    my %escape = ('<'=>'&lt;', '>'=>'&gt;', '&'=>'&amp;', '"'=>'&quot;');
106    my $escape_re  = join '|' => keys %escape;
107    
108    my $tag_regex = '\b([\w-_]+)//';
109    
110  =for SQL schema  my %nick_enumerator;
111    my $max_color = 0;
112    
113  $dbh->do(qq{  my $filter = {
114            message => sub {
115                    my $m = shift || return;
116    
117                    # protect HTML from wiki modifications
118                    sub e {
119                            my $t = shift;
120                            return 'uri_unescape{' . uri_escape($t, '^a-zA-Z0-9') . '}';
121                    }
122    
123                    $m =~ s/($escape_re)/$escape{$1}/gs;
124                    $m =~ s#($RE{URI}{HTTP})#e(qq{<a href="$1">$1</a>})#egs;
125                    $m =~ s#\/(\w+)\/#<i>$1</i>#gs;
126                    $m =~ s#$tag_regex#e(qq{<a href="$url?tag=$1" class="tag">$1</a>})#egs;
127                    $m =~ s#\*(\w+)\*#<b>$1</b>#gs;
128                    $m =~ s#_(\w+)_#<u>$1</u>#gs;
129    
130                    $m =~ s#uri_unescape{([^}]+)}#uri_unescape($1)#egs;
131                    return $m;
132            },
133            nick => sub {
134                    my $n = shift || return;
135                    if (! $nick_enumerator{$n})  {
136                            my $max = scalar keys %nick_enumerator;
137                            $nick_enumerator{$n} = $max + 1;
138                    }
139                    return '<span class="nick col-' .
140                            ( $nick_enumerator{$n} % $max_color ) .
141                            '">' . $n . '</span>';
142            },
143    };
144    
145    my $dbh = DBI->connect($DSN,"","", { RaiseError => 1, AutoCommit => 1 }) || die $DBI::errstr;
146    $dbh->do( qq{ set client_encoding = 'UTF-8' } );
147    
148    my $sql_schema = {
149            log => qq{
150  create table log (  create table log (
151          id serial,          id serial,
152          time timestamp default now(),          time timestamp default now(),
153          channel text not null,          channel text not null,
154            me boolean default false,
155          nick text not null,          nick text not null,
156          message text not null,          message text not null,
157          primary key(id)          primary key(id)
# Line 65  create table log ( Line 160  create table log (
160  create index log_time on log(time);  create index log_time on log(time);
161  create index log_channel on log(channel);  create index log_channel on log(channel);
162  create index log_nick on log(nick);  create index log_nick on log(nick);
163            },
164            meta => q{
165    create table meta (
166            nick text not null,
167            channel text not null,
168            name text not null,
169            value text,
170            changed timestamp default 'now()',
171            primary key(nick,channel,name)
172    );
173            },
174            feeds => qq{
175    create table feeds (
176            id serial,
177            url text not null,
178            name text,
179            delay interval not null default '5 min',
180            active boolean default true,
181            channel text not null,
182            nick text not null,
183            private boolean default false,
184            last_update timestamp default 'now()',
185            polls int default 0,
186            updates int default 0
187    );
188    create unique index feeds_url on feeds(url);
189    insert into feeds (url,name,channel,nick) values ('http://wiki.razmjenavjestina.org/feed/workspace/razmjenavjestina?category=Recent%20Changes','wiki','$CHANNEL','dpavlin');
190            },
191    };
192    
193    foreach my $table ( keys %$sql_schema ) {
194    
195            eval {
196                    $dbh->do(qq{ select count(*) from $table });
197            };
198    
199            if ($@) {
200                    warn "creating database table $table in $DSN\n";
201                    $dbh->do( $sql_schema->{ $table } );
202            }
203    }
204    
205  });  
206    =head2 meta
207    
208    Set or get some meta data into database
209    
210            meta('nick','channel','var_name', $var_value );
211    
212            $var_value = meta('nick','channel','var_name');
213            ( $var_value, $changed ) = meta('nick','channel','var_name');
214    
215  =cut  =cut
216    
217  my $sth = $dbh->prepare(qq{  sub meta {
218            my ($nick,$channel,$name,$value) = @_;
219    
220            # normalize channel name
221            $channel =~ s/^#//;
222    
223            if (defined($value)) {
224    
225                    my $sth = $dbh->prepare(qq{ update meta set value = ?, changed = now() where nick = ? and channel = ? and name = ? });
226    
227                    eval { $sth->execute( $value, $nick, $channel, $name ) };
228    
229                    # error or no result
230                    if ( $@ || ! $sth->rows ) {
231                            $sth = $dbh->prepare(qq{ insert into meta (value,nick,channel,name,changed) values (?,?,?,?,now()) });
232                            $sth->execute( $value, $nick, $channel, $name );
233                            warn "## created $nick/$channel/$name = $value\n";
234                    } else {
235                            warn "## updated $nick/$channel/$name = $value\n";
236                    }
237    
238                    return $value;
239    
240            } else {
241    
242                    my $sth = $dbh->prepare(qq{ select value,changed from meta where nick = ? and channel = ? and name = ? });
243                    $sth->execute( $nick, $channel, $name );
244                    my ($v,$c) = $sth->fetchrow_array;
245                    warn "## fetched $nick/$channel/$name = $v [$c]\n";
246                    return ($v,$c) if wantarray;
247                    return $v;
248    
249            }
250    }
251    
252    
253    
254    my $sth_insert_log = $dbh->prepare(qq{
255  insert into log  insert into log
256          (channel, nick, message)          (channel, me, nick, message, time)
257  values (?,?,?)  values (?,?,?,?,?)
258  });  });
259    
260    
261    my $tags;
262    
263  =head2 get_from_log  =head2 get_from_log
264    
265   my @messages = get_from_log(   my @messages = get_from_log(
# Line 85  values (?,?,?) Line 269  values (?,?,?)
269                  time => '{%s} ',                  time => '{%s} ',
270                  time_channel => '{%s %s} ',                  time_channel => '{%s %s} ',
271                  nick => '%s: ',                  nick => '%s: ',
272                    me_nick => '***%s ',
273                  message => '%s',                  message => '%s',
274          },          },
275          message_filter => sub {          filter => {
276                  # modify message content                  message => sub {
277                  return shift;                          # modify message content
278          }                          return shift;
279                    }
280            },
281            context => 5,
282            full_rows => 1,
283   );   );
284    
285    Order is important. Fields are first passed through C<filter> (if available) and
286    then throgh C<< sprintf($fmt->{message}, $message >> if available.
287    
288    C<context> defines number of messages around each search hit for display.
289    
290    C<full_rows> will return database rows for each result with C<date>, C<time>, C<channel>,
291    C<me>, C<nick> and C<message> keys.
292    
293  =cut  =cut
294    
295  sub get_from_log {  sub get_from_log {
296          my $args = {@_};          my $args = {@_};
297    
298          $args->{limit} ||= 10;          if ( ! $args->{fmt} ) {
299                    $args->{fmt} = {
300          $args->{fmt} ||= {                          date => '[%s] ',
301                  time => '{%s} ',                          time => '{%s} ',
302                  time_channel => '{%s %s} ',                          time_channel => '{%s %s} ',
303                  nick => '%s: ',                          nick => '%s: ',
304                  message => '%s',                          me_nick => '***%s ',
305          };                          message => '%s',
306                    };
307            }
308    
309          my $sql = qq{          my $sql_message = qq{
310                  select                  select
311                          time::date as date,                          time::date as date,
312                          time::time as time,                          time::time as time,
313                          channel,                          channel,
314                            me,
315                          nick,                          nick,
316                          message                          message
317                  from log                  from log
318          };          };
319          $sql .= " where message ilike ? " if ($args->{search});  
320            my $sql_context = qq{
321                    select
322                            id
323                    from log
324            };
325    
326            my $context = $1 if ($args->{search} && $args->{search} =~ s/\s*\+(\d+)\s*/ /);
327    
328            my $sql = $context ? $sql_context : $sql_message;
329    
330            sub check_date {
331                    my $date = shift || return;
332                    my $new_date = eval { DateTime::Format::ISO8601->parse_datetime( $date )->ymd; };
333                    if ( $@ ) {
334                            warn "invalid date $date\n";
335                            $new_date = DateTime->now->ymd;
336                    }
337                    return $new_date;
338            }
339    
340            my @where;
341            my @args;
342            my $msg;
343    
344            if (my $search = $args->{search}) {
345                    $search =~ s/^\s+//;
346                    $search =~ s/\s+$//;
347                    push @where, 'message ilike ? or nick ilike ?';
348                    push @args, ( ( '%' . $search . '%' ) x 2 );
349                    $msg = "Search for '$search'";
350            }
351    
352            if ($args->{tag} && $tags->{ $args->{tag} }) {
353                    push @where, 'id in (' . join(',', @{ $tags->{ $args->{tag} } }) . ')';
354                    $msg = "Search for tags $args->{tag}";
355            }
356    
357            if (my $date = $args->{date} ) {
358                    $date = check_date( $date );
359                    push @where, 'date(time) = ?';
360                    push @args, $date;
361                    $msg = "search for date $date";
362            }
363    
364            $sql .= " where " . join(" and ", @where) if @where;
365    
366          $sql .= " order by log.time desc";          $sql .= " order by log.time desc";
367          $sql .= " limit " . $args->{limit};          $sql .= " limit " . $args->{limit} if ($args->{limit});
368    
369            #warn "### sql: $sql ", dump( @args );
370    
371          my $sth = $dbh->prepare( $sql );          my $sth = $dbh->prepare( $sql );
372          if ($args->{search}) {          eval { $sth->execute( @args ) };
373                  $sth->execute( $args->{search} );          return if $@;
374          } else {  
375                  $sth->execute();          my $nr_results = $sth->rows;
376          }  
377          my $last_row = {          my $last_row = {
378                  date => '',                  date => '',
379                  time => '',                  time => '',
# Line 139  sub get_from_log { Line 387  sub get_from_log {
387                  unshift @rows, $row;                  unshift @rows, $row;
388          }          }
389    
390          my @msgs;          # normalize nick names
391            map {
392                    $_->{nick} =~ s/^_*(.*?)_*$/$1/
393            } @rows;
394    
395            return @rows if ($args->{full_rows});
396    
397            $msg .= ' produced ' . (
398                    $nr_results == 0 ? 'no results' :
399                    $nr_results == 0 ? 'one result' :
400                            $nr_results . ' results'
401            );
402    
403            my @msgs = ( $msg );
404    
405            if ($context) {
406                    my @ids = @rows;
407                    @rows = ();
408    
409                    my $last_to = 0;
410    
411                    my $sth = $dbh->prepare( $sql_message . qq{ where id >= ? and id < ? } );
412                    foreach my $row_id (sort { $a->{id} <=> $b->{id} } @ids) {
413                            my $id = $row_id->{id} || die "can't find id in row";
414            
415                            my ($from, $to) = ($id - $context, $id + $context);
416                            $from = $last_to if ($from < $last_to);
417                            $last_to = $to;
418                            $sth->execute( $from, $to );
419    
420                            #warn "## id: $id from: $from to: $to returned: ", $sth->rows, "\n";
421    
422                            while (my $row = $sth->fetchrow_hashref) {
423                                    push @rows, $row;
424                            }
425    
426                    }
427            }
428    
429            # sprintf which can take coderef as first parametar
430            sub cr_sprintf {
431                    my $fmt = shift || return;
432                    if (ref($fmt) eq 'CODE') {
433                            $fmt->(@_);
434                    } else {
435                            sprintf($fmt, @_);
436                    }
437            }
438    
439          foreach my $row (@rows) {          foreach my $row (@rows) {
440    
441                  $row->{time} =~ s#\.\d+##;                  $row->{time} =~ s#\.\d+##;
442    
                 my $t;  
                 $t = $row->{date} . ' ' if ($last_row->{date} ne $row->{date});  
                 $t .= $row->{time};  
   
443                  my $msg = '';                  my $msg = '';
444    
445                    $msg = cr_sprintf($args->{fmt}->{date}, $row->{date}) . ' ' if ($last_row->{date} ne $row->{date});
446                    my $t = $row->{time};
447    
448                  if ($last_row->{channel} ne $row->{channel}) {                  if ($last_row->{channel} ne $row->{channel}) {
449                          $msg .= sprintf($args->{fmt}->{time_channel}, $t, $row->{channel});                          $msg .= cr_sprintf($args->{fmt}->{time_channel}, $t, $row->{channel});
450                  } else {                  } else {
451                          $msg .= sprintf($args->{fmt}->{time}, $t);                          $msg .= cr_sprintf($args->{fmt}->{time}, $t);
452                  }                  }
453    
454                  my $append = 1;                  my $append = 1;
455    
456                  if ($last_row->{nick} ne $row->{nick}) {                  my $nick = $row->{nick};
457                          $msg .= sprintf($args->{fmt}->{nick}, $row->{nick});  #               if ($nick =~ s/^_*(.*?)_*$/$1/) {
458    #                       $row->{nick} = $nick;
459    #               }
460    
461                    if ($last_row->{nick} ne $nick) {
462                            # obfu way to find format for me_nick if needed or fallback to default
463                            my $fmt = $row->{me} ? ( $args->{fmt}->{me_nick} || $args->{fmt}->{nick} ) : $args->{fmt}->{nick};
464                            $fmt ||= '%s';
465    
466                            $nick = $args->{filter}->{nick}->($nick) if (ref($args->{filter}->{nick}) eq 'CODE');
467    
468                            $msg .= cr_sprintf( $fmt, $nick );
469                          $append = 0;                          $append = 0;
470                  }                  }
471    
472                  if (ref($args->{message_filter}) eq 'CODE') {                  $args->{fmt}->{message} ||= '%s';
473                          $msg .= sprintf($args->{fmt}->{message},                  if (ref($args->{filter}->{message}) eq 'CODE') {
474                                  $args->{message_filter}->(                          $msg .= cr_sprintf($args->{fmt}->{message},
475                                    $args->{filter}->{message}->(
476                                          $row->{message}                                          $row->{message}
477                                  )                                  )
478                          );                          );
479                  } else {                  } else {
480                          $msg .= sprintf($args->{fmt}->{message}, $row->{message});                          $msg .= cr_sprintf($args->{fmt}->{message}, $row->{message});
481                  }                  }
482    
483                  if ($append && @msgs) {                  if ($append && @msgs) {
# Line 186  sub get_from_log { Line 492  sub get_from_log {
492          return @msgs;          return @msgs;
493  }  }
494    
495    # tags support
496    
497    my $cloud = HTML::TagCloud->new;
498    
499    =head2 add_tag
500    
501     add_tag( id => 42, message => 'irc message', nick => 'foobar' [, me => 1 ] );
502    
503    =cut
504    
505    my @last_tags;
506    
507    sub add_tag {
508            my $arg = {@_};
509    
510            return unless ($arg->{id} && $arg->{message});
511    
512            my $m = $arg->{message};
513    
514            my @tags;
515    
516            while ($m =~ s#$tag_regex##s) {
517                    my $tag = $1;
518                    next if (! $tag || $tag =~ m/https?:/i);
519                    push @{ $tags->{$tag} }, $arg->{id};
520                    #warn "+tag $tag: $arg->{id}\n";
521                    $cloud->add($tag, "$url?tag=$tag", scalar @{$tags->{$tag}} + 1);
522                    push @tags, $tag;
523    
524            }
525    
526            if ( @tags ) {
527                    pop @last_tags if $#last_tags == $last_x_tags;
528                    unshift @last_tags, { tags => [ @tags ], %$arg };
529            }
530    
531    }
532    
533    =head2 seed_tags
534    
535    Read all tags from database and create in-memory cache for tags
536    
537    =cut
538    
539    sub seed_tags {
540            my $sth = $dbh->prepare(qq{ select id,message,nick,me,time from log where message like '%//%' order by time asc });
541            $sth->execute;
542            while (my $row = $sth->fetchrow_hashref) {
543                    add_tag( %$row );
544            }
545    
546            foreach my $tag (keys %$tags) {
547                    $cloud->add($tag, "$url?tag=$tag", scalar @{$tags->{$tag}} + 1);
548            }
549    }
550    
551    seed_tags;
552    
553    
554    =head2 save_message
555    
556      save_message(
557            channel => '#foobar',
558            me => 0,
559            nick => 'dpavlin',
560            message => 'test message',
561            time => '2006-06-25 18:57:18',
562      );
563    
564  my $SKIPPING = 0;               # if skipping, how many we've done  C<time> is optional, it will use C<< now() >> if it's not available.
565  my $SEND_QUEUE;                 # cache  
566    C<me> if not specified will be C<0> (not C</me> message)
567    
568    =cut
569    
570    sub save_message {
571            my $a = {@_};
572            confess "have msg" if $a->{msg};
573            $a->{me} ||= 0;
574            $a->{time} ||= strftime($TIMESTAMP,localtime());
575    
576            _log
577                    $a->{channel}, " ",
578                    $a->{me} ? "***" . $a->{nick} : "<" . $a->{nick} . ">",
579                    " " . $a->{message};
580    
581            $sth_insert_log->execute($a->{channel}, $a->{me}, $a->{nick}, $a->{message}, $a->{time});
582            add_tag( id => $dbh->last_insert_id(undef,undef,"log",undef), %$a );
583    }
584    
585    
586    if ($import_dircproxy) {
587            open(my $l, $import_dircproxy) || die "can't open $import_dircproxy: $!";
588            warn "importing $import_dircproxy...\n";
589            my $tz_offset = 1 * 60 * 60;    # TZ GMT+2
590            while(<$l>) {
591                    chomp;
592                    if (/^@(\d+)\s(\S+)\s(.+)$/) {
593                            my ($time, $nick, $msg) = ($1,$2,$3);
594    
595                            my $dt = DateTime->from_epoch( epoch => $time + $tz_offset );
596    
597                            my $me = 0;
598                            $me = 1 if ($nick =~ m/^\[\S+]/);
599                            $nick =~ s/^[\[<]([^!]+).*$/$1/;
600    
601                            $msg =~ s/^ACTION\s+// if ($me);
602    
603                            save_message(
604                                    channel => $CHANNEL,
605                                    me => $me,
606                                    nick => $nick,
607                                    message => $msg,
608                                    time => $dt->ymd . " " . $dt->hms,
609                            ) if ($nick !~ m/^-/);
610    
611                    } else {
612                            _log "can't parse: $_";
613                    }
614            }
615            close($l);
616            warn "import over\n";
617            exit;
618    }
619    
620    #
621    # RSS follow
622    #
623    
624    my $_rss;
625    
626    
627    sub rss_fetch {
628            my ($args) = @_;
629    
630            # how many messages to send out when feed is seen for the first time?
631            my $send_rss_msgs = 1;
632    
633            _log "RSS fetch", $args->{url};
634    
635            my $feed = XML::Feed->parse(URI->new( $args->{url} ));
636            if ( ! $feed ) {
637                    _log("can't fetch RSS ", $args->{url});
638                    return;
639            }
640    
641            my ( $total, $updates ) = ( 0, 0 );
642            for my $entry ($feed->entries) {
643                    $total++;
644    
645                    # seen allready?
646                    next if $_rss->{$args->{channel}}->{$feed->link}->{$entry->id}++ > 0;
647    
648                    sub prefix {
649                            my ($txt,$var) = @_;
650                            $var =~ s/\s+/ /gs;
651                            $var =~ s/^\s+//g;
652                            $var =~ s/\s+$//g;
653                            return $txt . $var if $var;
654                    }
655    
656                    # fix absolute and relative links to feed entries
657                    my $link = $entry->link;
658                    if ( $link =~ m!^/! ) {
659                            my $host = $args->{url};
660                            $host =~ s!^(http://[^/]+).*$!$1!;      #!vim
661                            $link = "$host/$link";
662                    } elsif ( $link !~ m!^http! ) {
663                            $link = $args->{url} . $link;
664                    }
665    
666                    my $msg;
667                    $msg .= prefix( 'From: ' , $args->{name} || $feed->title );
668                    $msg .= prefix( ' by ' , $entry->author );
669                    $msg .= prefix( ' | ' , $entry->title );
670                    $msg .= prefix( ' | ' , $link );
671    #               $msg .= prefix( ' id ' , $entry->id );
672    
673                    if ( $args->{kernel} && $send_rss_msgs ) {
674                            $send_rss_msgs--;
675                            $sth_insert_log->execute( $args->{channel}, 1, $NICK, $msg, 'now()' );
676                            my ( $type, $to ) = ( 'notice', $args->{channel} );
677                            ( $type, $to ) = ( 'privmsg', $args->{nick} ) if $args->{private};
678                            _log(">> $type $to |", $msg);
679                            $args->{kernel}->post( $IRC_ALIAS => $type => $to, $msg );
680                            $updates++;
681                    }
682            }
683    
684            my $sql = qq{ update feeds set last_update = now(), polls = polls + 1 };
685            $sql .= qq{, updates = updates + $updates } if $updates;
686            $sql .= qq{where id = } . $args->{id};
687            eval { $dbh->do( $sql ) };
688    
689            _log "RSS got $total items of which $updates new";
690    
691            return $updates;
692    }
693    
694    sub rss_fetch_all {
695            my $kernel = shift;
696            my $sql = qq{
697                    select id, url, name, channel, nick, private
698                    from feeds
699                    where active is true
700            };
701            # limit to newer feeds only if we are not sending messages out
702            $sql .= qq{     and last_update + delay < now() } if $kernel;
703            my $sth = $dbh->prepare( $sql );
704            $sth->execute();
705            warn "# ",$sth->rows," active RSS feeds\n";
706            my $count = 0;
707            while (my $row = $sth->fetchrow_hashref) {
708                    $row->{kernel} = $kernel if $kernel;
709                    $count += rss_fetch( $row );
710            }
711            return "OK, fetched $count posts from " . $sth->rows . " feeds";
712    }
713    
714    
715    sub rss_check_updates {
716            my $kernel = shift;
717            $_rss->{last_poll} ||= time();
718            my $dt = time() - $_rss->{last_poll};
719            warn "## rss_check_updates $dt > $rss_min_delay\n";
720            if ( $dt > $rss_min_delay ) {
721                    $_rss->{last_poll} = time();
722                    _log rss_fetch_all( $kernel );
723            }
724    }
725    
726    # seed rss seen cache so we won't send out all items on startup
727    _log rss_fetch_all;
728    
729    #
730    # POE handing part
731    #
732    
733    my $ping;                                               # ping stats
734    
735  POE::Component::IRC->new($IRC_ALIAS);  POE::Component::IRC->new($IRC_ALIAS);
736    
737  POE::Session->create  POE::Session->create( inline_states => {
738    (inline_states =>          _start => sub {      
    {_start => sub {        
739                  $_[KERNEL]->post($IRC_ALIAS => register => 'all');                  $_[KERNEL]->post($IRC_ALIAS => register => 'all');
740                  $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);                  $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);
741      },      },
742      irc_255 => sub {    # server is done blabbing      irc_255 => sub {    # server is done blabbing
743                  $_[KERNEL]->post($IRC_ALIAS => join => $CHANNEL);                  $_[KERNEL]->post($IRC_ALIAS => join => $CHANNEL);
                 $_[KERNEL]->post($IRC_ALIAS => join => '#logger');  
                 $_[KERNEL]->yield("heartbeat"); # start heartbeat  
 #               $_[KERNEL]->yield("my_add", $_) for keys %FOLLOWS;  
744                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );
745      },      },
746      irc_public => sub {      irc_public => sub {
# Line 211  POE::Session->create Line 749  POE::Session->create
749                  my $channel = $_[ARG1]->[0];                  my $channel = $_[ARG1]->[0];
750                  my $msg = $_[ARG2];                  my $msg = $_[ARG2];
751    
752                  from_to($msg, 'UTF-8', $ENCODING);                  save_message( channel => $channel, me => 0, nick => $nick, message => $msg);
753                    meta( $nick, $channel, 'last-msg', $msg );
754                    rss_check_updates( $kernel );
755        },
756        irc_ctcp_action => sub {
757                    my $kernel = $_[KERNEL];
758                    my $nick = (split /!/, $_[ARG0])[0];
759                    my $channel = $_[ARG1]->[0];
760                    my $msg = $_[ARG2];
761    
762                    save_message( channel => $channel, me => 1, nick => $nick, message => $msg);
763    
764                    if ( $use_twitter ) {
765                            if ( my $twitter = meta( $nick, $NICK, 'twitter' ) ) {
766                                    my ($login,$passwd) = split(/\s+/,$twitter,2);
767                                    _log("sending twitter for $nick/$login on $channel ");
768                                    my $bot = Net::Twitter->new( username=>$login, password=>$passwd );
769                                    $bot->update("<${channel}> $msg");
770                            }
771                    }
772    
                 print "$channel: <$nick> $msg\n";  
                 $sth->execute($channel, $nick, $msg);  
773      },      },
774            irc_ping => sub {
775                    _log( "pong ", $_[ARG0] );
776                    $ping->{ $_[ARG0] }++;
777                    rss_check_updates( $_[KERNEL] );
778            },
779            irc_invite => sub {
780                    my $kernel = $_[KERNEL];
781                    my $nick = (split /!/, $_[ARG0])[0];
782                    my $channel = $_[ARG1];
783    
784                    _log "invited to $channel by $nick";
785    
786                    $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, "how nice of you to invite me to $channel, I'll be right there..." );
787                    $_[KERNEL]->post($IRC_ALIAS => join => $channel);
788    
789            },
790          irc_msg => sub {          irc_msg => sub {
791                  my $kernel = $_[KERNEL];                  my $kernel = $_[KERNEL];
792                  my $nick = (split /!/, $_[ARG0])[0];                  my $nick = (split /!/, $_[ARG0])[0];
793                  my $msg = $_[ARG2];                  my $msg = $_[ARG2];
794                  from_to($msg, 'UTF-8', $ENCODING);                  my $channel = $_[ARG1]->[0];
795    
796                  my $res = "unknown command '$msg', try /msg $NICK help!";                  my $res = "unknown command '$msg', try /msg $NICK help!";
797                  my @out;                  my @out;
798    
799                  print "<< $msg\n";                  _log "<< $msg";
800    
801                  if ($msg =~ m/^help/i) {                  if ($msg =~ m/^help/i) {
802    
# Line 233  POE::Session->create Line 804  POE::Session->create
804    
805                  } elsif ($msg =~ m/^msg\s+(\S+)\s+(.*)$/i) {                  } elsif ($msg =~ m/^msg\s+(\S+)\s+(.*)$/i) {
806    
807                          print ">> /msg $1 $2\n";                          _log ">> /msg $1 $2";
808                          $_[KERNEL]->post( $IRC_ALIAS => privmsg => $1, $2 );                          $_[KERNEL]->post( $IRC_ALIAS => privmsg => $1, $2 );
809                          $res = '';                          $res = '';
810    
# Line 242  POE::Session->create Line 813  POE::Session->create
813                          my $nr = $1 || 10;                          my $nr = $1 || 10;
814    
815                          my $sth = $dbh->prepare(qq{                          my $sth = $dbh->prepare(qq{
816                                  select nick,count(*) from log group by nick order by count desc limit $nr                                  select
817                                            trim(both '_' from nick) as nick,
818                                            count(*) as count,
819                                            sum(length(message)) as len
820                                    from log
821                                    group by trim(both '_' from nick)
822                                    order by len desc,count desc
823                                    limit $nr
824                          });                          });
825                          $sth->execute();                          $sth->execute();
826                          $res = "Top $nr users: ";                          $res = "Top $nr users: ";
827                          my @users;                          my @users;
828                          while (my $row = $sth->fetchrow_hashref) {                          while (my $row = $sth->fetchrow_hashref) {
829                                  push @users,$row->{nick} . ': ' . $row->{count};                                  push @users,$row->{nick} . ': ' . $row->{count} . '/' . $row->{len} . '=' . sprintf("%.2f", $row->{len}/$row->{count});
830                          }                          }
831                          $res .= join(" | ", @users);                          $res .= join(" | ", @users);
832                  } elsif ($msg =~ m/^last.*?\s*(\d*)/i) {                  } elsif ($msg =~ m/^last.*?\s*(\d*)/i) {
833    
834                          foreach my $res (get_from_log( limit => $1 )) {                          my $limit = $1 || meta( $nick, $channel, 'last-size' ) || 10;
835                                  print "last: $res\n";  
836                                  from_to($res, $ENCODING, 'UTF-8');                          foreach my $res (get_from_log( limit => $limit )) {
837                                    _log "last: $res";
838                                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );                                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );
839                          }                          }
840    
841                          $res = '';                          $res = '';
842    
843                  } elsif ($msg =~ m/^(search|grep)\s+(.*)$/i) {                  } elsif ($msg =~ m/^(search|grep)\s+(.*)\s*$/i) {
844    
845                          my $what = $2;                          my $what = $2;
846    
847                          foreach my $res (get_from_log( limit => 20, search => "%${what}%" )) {                          foreach my $res (get_from_log(
848                                  print "search [$what]: $res\n";                                          limit => 20,
849                                  from_to($res, $ENCODING, 'UTF-8');                                          search => $what,
850                                    )) {
851                                    _log "search [$what]: $res";
852                                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );                                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );
853                          }                          }
854    
855                          $res = '';                          $res = '';
856    
857                    } elsif ($msg =~ m/^(?:count|poll)\s+(.*)(?:\s+(\d+))?\s*$/i) {
858    
859                            my ($what,$limit) = ($1,$2);
860                            $limit ||= 100;
861    
862                            my $stat;
863    
864                            foreach my $res (get_from_log(
865                                            limit => $limit,
866                                            search => $what,
867                                            full_rows => 1,
868                                    )) {
869                                    while ($res->{message} =~ s/\Q$what\E(\+|\-)//) {
870                                            $stat->{vote}->{$1}++;
871                                            $stat->{from}->{ $res->{nick} }++;
872                                    }
873                            }
874    
875                            my @nicks;
876                            foreach my $nick (sort { $stat->{from}->{$a} <=> $stat->{from}->{$b} } keys %{ $stat->{from} }) {
877                                    push @nicks, $nick . ( $stat->{from}->{$nick} == 1 ? '' :
878                                            "(" . $stat->{from}->{$nick} . ")"
879                                    );
880                            }
881    
882                            $res =
883                                    "$what ++ " . ( $stat->{vote}->{'+'} || 0 ) .
884                                    " : " . ( $stat->{vote}->{'-'} || 0 ) . " --" .
885                                    " from " . ( join(", ", @nicks) || 'nobody' );
886    
887                            $_[KERNEL]->post( $IRC_ALIAS => notice => $nick, $res );
888    
889                    } elsif ($msg =~ m/^ping/) {
890                            $res = "ping = " . dump( $ping );
891                    } elsif ($msg =~ m/^conf(?:ig)*\s*(last-size|twitter)*\s*(.*)/) {
892                            if ( ! defined( $1 ) ) {
893                                    my $sth = $dbh->prepare(qq{ select name,value,changed from meta where nick = ? and channel = ? });
894                                    $sth->execute( $nick, $channel );
895                                    $res = "config for $nick on $channel";
896                                    while ( my ($n,$v) = $sth->fetchrow_array ) {
897                                            $res .= " | $n = $v";
898                                    }
899                            } elsif ( ! $2 ) {
900                                    my $val = meta( $nick, $channel, $1 );
901                                    $res = "current $1 = " . ( $val ? $val : 'undefined' );
902                            } else {
903                                    my $validate = {
904                                            'last-size' => qr/^\d+/,
905                                            'twitter' => qr/^\w+\s+\w+/,
906                                    };
907    
908                                    my ( $op, $val ) = ( $1, $2 );
909    
910                                    if ( my $regex = $validate->{$op} ) {
911                                            if ( $val =~ $regex ) {
912                                                    meta( $nick, $channel, $op, $val );
913                                                    $res = "saved $op = $val";
914                                            } else {
915                                                    $res = "config option $op = $val doesn't validate against $regex";
916                                            }
917                                    } else {
918                                            $res = "config option $op doesn't exist";
919                                    }
920                            }
921                    } elsif ($msg =~ m/^rss-update/) {
922                            $res = rss_fetch_all( $_[KERNEL] );
923                    } elsif ($msg =~ m/^rss-clean/) {
924                            $_rss = undef;
925                            $dbh->do( qq{ update feeds set last_update = now() - delay } );
926                            $res = "OK, cleaned RSS cache";
927                    } elsif ($msg =~ m/^rss-list/) {
928                            my $sth = $dbh->prepare(qq{ select url,name,last_update,active,channel,nick,private from feeds });
929                            $sth->execute;
930                            while (my @row = $sth->fetchrow_array) {
931                                    $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, join(' | ',@row) );
932                            }
933                            $res = '';
934                    } elsif ($msg =~ m!^rss-(add|remove|stop|start)(?:-(private))?\s+(http://\S+)\s*(.*)!) {
935                            my ( $command, $sub, $url, $arg ) = ( $1,$2,$3,$4 );
936    
937                            my $channel = $1 if ( $arg =~ s/\s*(#\S+)\s*// );
938                            $channel = $nick if $sub eq 'private';
939    
940                            my $sql = {
941                                    add             => qq{ insert into feeds (url,name,channel,nick,private) values (?,?,?,?,?) },
942    #                               remove  => qq{ delete from feeds                                where url = ? and name = ? },
943                                    start   => qq{ update feeds set active = true   where url = ? },
944                                    stop    => qq{ update feeds set active = false  where url = ? },
945                            };
946    
947                            if ( $command eq 'add' && ! $channel ) {
948                                    $res = "ERROR: got '$msg' which doesn't have #channel in it, ignoring!";
949                            } elsif (my $q = $sql->{$command} ) {
950                                    my $sth = $dbh->prepare( $q );
951                                    my @data = ( $url );
952                                    if ( $command eq 'add' ) {
953                                            push @data, ( $arg, $channel, $nick, $sub eq 'private' ? 1 : 0 );
954                                    }
955                                    warn "## $command SQL $q with ",dump( @data ),"\n";
956                                    eval { $sth->execute( @data ) };
957                                    if ($@) {
958                                            $res = "ERROR: $@";
959                                    } else {
960                                            $res = "OK, RSS [$command|$sub|$url|$arg]";
961                                    }
962                            } else {
963                                    $res = "ERROR: don't know what to do with: $msg";
964                            }
965                  }                  }
966    
967                  if ($res) {                  if ($res) {
968                          print ">> [$nick] $res\n";                          _log ">> [$nick] $res";
                         from_to($res, $ENCODING, 'UTF-8');  
969                          $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );                          $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );
970                  }                  }
971    
972                    rss_check_updates( $_[KERNEL] );
973          },          },
974          irc_477 => sub {          irc_477 => sub {
975                  print "# irc_477: ",$_[ARG1], "\n";                  _log "# irc_477: ",$_[ARG1];
976                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "register $NICK" );                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "register $NICK" );
977          },          },
978          irc_505 => sub {          irc_505 => sub {
979                  print "# irc_505: ",$_[ARG1], "\n";                  _log "# irc_505: ",$_[ARG1];
980                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "register $NICK" );                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "register $NICK" );
981  #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "set hide email on" );  #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "set hide email on" );
982  #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "set email dpavlin\@rot13.org" );  #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "set email dpavlin\@rot13.org" );
983          },          },
984          irc_registered => sub {          irc_registered => sub {
985                  warn "## indetify $NICK\n";                  _log "## registrated $NICK";
986                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );
987          },          },
988            irc_disconnected => sub {
989                    _log "## disconnected, reconnecting again";
990                    $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);
991            },
992            irc_socketerr => sub {
993                    _log "## socket error... sleeping for $sleep_on_error seconds and retry";
994                    sleep($sleep_on_error);
995                    $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);
996            },
997  #       irc_433 => sub {  #       irc_433 => sub {
998  #               print "# irc_433: ",$_[ARG1], "\n";  #               print "# irc_433: ",$_[ARG1], "\n";
999  #               warn "## indetify $NICK\n";  #               warn "## indetify $NICK\n";
1000  #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );  #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );
1001  #       },  #       },
         irc_372 => sub {  
                 print "MOTD: ", $_[ARG1], "\n";  
         },  
         irc_snotice => sub {  
                 print "(server notice): ", $_[ARG0], "\n";  
         },  
     (map  
      {  
        ;"irc_$_" => sub { }}  
      qw(  
                 )),  
 #       join  
 #       ctcp_version  
 #       connected snotice ctcp_action ping notice mode part quit  
 #       001 002 003 004 005  
 #       250 251 252 253 254 265 266  
 #       332 333 353 366 372 375 376  
 #       477  
1002      _child => sub {},      _child => sub {},
1003      _default => sub {      _default => sub {
1004        printf "%s: session %s caught an unhandled %s event.\n",                  _log sprintf "sID:%s %s %s",
1005          scalar localtime(), $_[SESSION]->ID, $_[ARG0];                          $_[SESSION]->ID, $_[ARG0],
1006        print "The $_[ARG0] event was given these parameters: ",                          ref($_[ARG1]) eq "ARRAY"        ?       join(",", map { ref($_) eq "ARRAY" ? join(";", @{$_}) : $_ } @{ $_[ARG1] })     :
1007          join(" ", map({"ARRAY" eq ref $_ ? "[@$_]" : "$_"} @{$_[ARG1]})), "\n";                          $_[ARG1]                                        ?       $_[ARG1]                                        :
1008                            "";
1009        0;                        # false for signals        0;                        # false for signals
1010      },      },
     my_add => sub {  
       my $trailing = $_[ARG0];  
       my $session = $_[SESSION];  
       POE::Session->create  
           (inline_states =>  
            {_start => sub {  
               $_[HEAP]->{wheel} =  
                 POE::Wheel::FollowTail->new  
                     (  
                      Filename => $FOLLOWS{$trailing},  
                      InputEvent => 'got_line',  
                     );  
             },  
             got_line => sub {  
               $_[KERNEL]->post($session => my_tailed =>  
                                time, $trailing, $_[ARG0]);  
             },  
            },  
           );  
       
     },  
     my_tailed => sub {  
       my ($time, $file, $line) = @_[ARG0..ARG2];  
       ## $time will be undef on a probe, or a time value if a real line  
   
       ## PoCo::IRC has throttling built in, but no external visibility  
       ## so this is reaching "under the hood"  
       $SEND_QUEUE ||=  
         $_[KERNEL]->alias_resolve($IRC_ALIAS)->get_heap->{send_queue};  
   
       ## handle "no need to keep skipping" transition  
       if ($SKIPPING and @$SEND_QUEUE < 1) {  
         $_[KERNEL]->post($IRC_ALIAS => privmsg => $CHANNEL =>  
                          "[discarded $SKIPPING messages]");  
         $SKIPPING = 0;  
       }  
   
       ## handle potential message display  
       if ($time) {  
         if ($SKIPPING or @$SEND_QUEUE > 3) { # 3 msgs per 10 seconds  
           $SKIPPING++;  
         } else {  
           my @time = localtime $time;  
           $_[KERNEL]->post($IRC_ALIAS => privmsg => $CHANNEL =>  
                            sprintf "%02d:%02d:%02d: %s: %s",  
                            ($time[2] + 11) % 12 + 1, $time[1], $time[0],  
                            $file, $line);  
         }  
       }  
   
       ## handle re-probe/flush if skipping  
       if ($SKIPPING) {  
         $_[KERNEL]->delay($_[STATE] => 0.5); # $time will be undef  
       }  
   
     },  
     my_heartbeat => sub {  
       $_[KERNEL]->yield(my_tailed => time, "heartbeat", "beep");  
       $_[KERNEL]->delay($_[STATE] => 10);  
     }  
1011     },     },
1012    );    );
1013    
1014  # http server  # http server
1015    
1016  my $httpd = POE::Component::Server::HTTP->new(  my $httpd = POE::Component::Server::HTTP->new(
1017          Port => $NICK =~ m/-dev/ ? 8001 : 8000,          Port => $http_port,
1018            PreHandler => {
1019                    '/' => sub {
1020                            $_[0]->header(Connection => 'close')
1021                    }
1022            },
1023          ContentHandler => { '/' => \&root_handler },          ContentHandler => { '/' => \&root_handler },
1024          Headers        => { Server => 'irc-logger' },          Headers        => { Server => 'irc-logger' },
1025  );  );
1026    
1027  my $style = <<'_END_OF_STYLE_';  my $style = <<'_END_OF_STYLE_';
1028    p { margin: 0; padding: 0.1em; }
1029  .time, .channel { color: #808080; font-size: 60%; }  .time, .channel { color: #808080; font-size: 60%; }
1030  .nick { color: #0000ff; font-size: 80%; }  .date { float: right; background: #e0e0e0; color: #404040; font-size: 120%; padding: 0.25em; border: 1px dashed #808080; }
1031    .nick { color: #000000; font-size: 80%; padding: 2px; font-family: courier, courier new, monospace ; }
1032  .message { color: #000000; font-size: 100%; }  .message { color: #000000; font-size: 100%; }
1033    .search { float: right; }
1034    a:link.tag, a:visited.tag { border: 1px dashed #ccc; backgound: #ccc; text-decoration: none }
1035    a:hover.tag { border: 1px solid #eee }
1036    hr { border: 1px dashed #ccc; height: 1px; clear: both; }
1037    /*
1038    .col-0 { background: #ffff66 }
1039    .col-1 { background: #a0ffff }
1040    .col-2 { background: #99ff99 }
1041    .col-3 { background: #ff9999 }
1042    .col-4 { background: #ff66ff }
1043    */
1044    .calendar { border: 1px solid red; width: 100%; }
1045    .month { border: 0px; width: 100%; }
1046  _END_OF_STYLE_  _END_OF_STYLE_
1047    
1048    $max_color = 0;
1049    
1050    my @cols = qw(
1051            #ffcccc #ccffe6 #ccccff #e6ccff #ffccff #ffcce6 #ff9999 #ffcc99 #ffff99
1052            #ccff99 #99ff99 #99ffcc #99ccff #9999ff #cc99ff #ff6666 #ffb366 #ffff66
1053            #66ff66 #66ffb3 #66b3ff #6666ff #ff3333 #33ff33 #3399ff #3333ff #ff3399
1054            #a0a0a0 #ff0000 #ffff00 #80ff00 #0000ff #8000ff #ff00ff #ff0080 #994d00
1055            #999900 #009900 #cc0066 #c0c0c0 #ccff99 #99ff33 #808080 #660033 #ffffff
1056    );
1057    
1058    foreach my $c (@cols) {
1059            $style .= ".col-${max_color} { background: $c }\n";
1060            $max_color++;
1061    }
1062    warn "defined $max_color colors for users...\n";
1063    
1064  sub root_handler {  sub root_handler {
1065          my ($request, $response) = @_;          my ($request, $response) = @_;
1066          $response->code(RC_OK);          $response->code(RC_OK);
1067          $response->content_type("text/html; charset=$ENCODING");  
1068          $response->content(          # this doesn't seem to work, so moved to PreHandler
1069                  qq{<html><head><title>$NICK</title><style type="text/css">$style</style></head><body>} .          #$response->header(Connection => 'close');
1070                  "irc-logger url: " . $request->uri . '<br/>' .  
1071                  join("<br/>",          return RC_OK if $request->uri =~ m/favicon.ico$/;
1072    
1073            my $q;
1074    
1075            if ( $request->method eq 'POST' ) {
1076                    $q = new CGI::Simple( $request->content );
1077            } elsif ( $request->uri =~ /\?(.+)$/ ) {
1078                    $q = new CGI::Simple( $1 );
1079            } else {
1080                    $q = new CGI::Simple;
1081            }
1082    
1083            my $search = $q->param('search') || $q->param('grep') || '';
1084    
1085            if ($request->url =~ m#/rss(?:/(tags|last-tag|follow.*)\w*(?:=(\d+))?)?#i) {
1086                    my $show = lc($1);
1087                    my $nr = $2;
1088    
1089                    my $type = 'RSS';       # Atom
1090    
1091                    $response->content_type( 'application/' . lc($type) . '+xml' );
1092    
1093                    my $html = '<!-- error -->';
1094                    #warn "create $type feed from ",dump( @last_tags );
1095    
1096                    my $feed = XML::Feed->new( $type );
1097                    $feed->link( $url );
1098    
1099                    if ( $show eq 'tags' ) {
1100                            $nr ||= 50;
1101                            $feed->title( "tags from $CHANNEL" );
1102                            $feed->link( "$url/tags" );
1103                            $feed->description( "tag cloud created from messages on channel $CHANNEL which have tags// in them" );
1104                            my $feed_entry = XML::Feed::Entry->new($type);
1105                            $feed_entry->title( "$nr tags from $CHANNEL" );
1106                            $feed_entry->author( $NICK );
1107                            $feed_entry->link( '/#tags'  );
1108    
1109                            $feed_entry->content(
1110                                    qq{<![CDATA[<style type="text/css">}
1111                                    . $cloud->css
1112                                    . qq{</style>}
1113                                    . $cloud->html( $nr )
1114                                    . qq{]]>}
1115                            );
1116                            $feed->add_entry( $feed_entry );
1117    
1118                    } elsif ( $show eq 'last-tag' ) {
1119    
1120                            $nr ||= $last_x_tags;
1121                            $nr = $last_x_tags if $nr > $last_x_tags;
1122    
1123                            $feed->title( "last $nr tagged messages from $CHANNEL" );
1124                            $feed->description( "collects messages which have tags// in them" );
1125    
1126                            foreach my $m ( @last_tags ) {
1127    #                               warn dump( $m );
1128                                    #my $tags = join(' ', @{$m->{tags}} );
1129                                    my $feed_entry = XML::Feed::Entry->new($type);
1130                                    $feed_entry->title( $m->{nick} . '@' . $m->{time} );
1131                                    $feed_entry->author( $m->{nick} );
1132                                    $feed_entry->link( '/#' . $m->{id}  );
1133                                    $feed_entry->issued( DateTime::Format::Flexible->build( $m->{time} ) );
1134    
1135                                    my $message = $filter->{message}->( $m->{message} );
1136                                    $message .= "<br/>\n" unless $message =~ m!<(/p|br/?)>!;
1137    #                               warn "## message = $message\n";
1138    
1139                                    #$feed_entry->summary(
1140                                    $feed_entry->content(
1141                                            "<![CDATA[$message]]>"
1142                                    );
1143                                    $feed_entry->category( join(', ', @{$m->{tags}}) );
1144                                    $feed->add_entry( $feed_entry );
1145    
1146                                    $nr--;
1147                                    last if $nr <= 0;
1148    
1149                            }
1150    
1151                    } elsif ( $show =~ m/^follow/ ) {
1152    
1153                            $feed->title( "Feeds which this bot follows" );
1154    
1155                            my $sth = $dbh->prepare( qq{ select * from feeds order by last_update desc } );
1156                            $sth->execute;
1157                            while (my $row = $sth->fetchrow_hashref) {
1158                                    my $feed_entry = XML::Feed::Entry->new($type);
1159                                    $feed_entry->title( $row->{name} );
1160                                    $feed_entry->link( $row->{url}  );
1161                                    $feed_entry->issued( DateTime::Format::Flexible->build( $row->{last_update} ) );
1162                                    $feed_entry->content(
1163                                            '<![CDATA[<pre>' . dump( $row ) . '</pre>]]>'
1164                                    );
1165                                    $feed->add_entry( $feed_entry );
1166                            }
1167    
1168                            my $feed_entry = XML::Feed::Entry->new($type);
1169                            $feed_entry->title( "Internal stats" );
1170                            $feed_entry->content(
1171                                    '<![CDATA[<pre>' . dump( $_rss ) . '</pre>]]>'
1172                            );
1173                            $feed->add_entry( $feed_entry );
1174    
1175                    } else {
1176                            _log "unknown rss request ",$request->url;
1177                            return RC_DENY;
1178                    }
1179    
1180                    $response->content( $feed->as_xml );
1181                    return RC_OK;
1182            }
1183    
1184            if ( $@ ) {
1185                    warn "$@";
1186            }
1187    
1188            $response->content_type("text/html; charset=UTF-8");
1189    
1190            my $html =
1191                    qq{<html><head><title>$NICK</title><style type="text/css">$style}
1192                    . $cloud->css
1193                    . qq{</style></head><body>}
1194                    . qq{
1195                    <form method="post" class="search" action="/">
1196                    <input type="text" name="search" value="$search" size="10">
1197                    <input type="submit" value="search">
1198                    </form>
1199                    }
1200                    . $cloud->html(500)
1201                    . qq{<p>};
1202    
1203            if ($request->url =~ m#/tags?#) {
1204                    # nop
1205            } elsif ($request->url =~ m#/history#) {
1206                    my $sth = $dbh->prepare(qq{
1207                            select date(time) as date,count(*) as nr,sum(length(message)) as len
1208                                    from log
1209                                    group by date(time)
1210                                    order by date(time) desc
1211                    });
1212                    $sth->execute();
1213                    my ($l_yyyy,$l_mm) = (0,0);
1214                    $html .= qq{<table class="calendar"><tr>};
1215                    my $cal;
1216                    my $ord = 0;
1217                    while (my $row = $sth->fetchrow_hashref) {
1218                            # this is probably PostgreSQL specific, expects ISO date
1219                            my ($yyyy,$mm,$dd) = split(/-/, $row->{date});
1220                            if ($yyyy != $l_yyyy || $mm != $l_mm) {
1221                                    if ( $cal ) {
1222                                            $html .= qq{<td valign="top">} . $cal->as_HTML() . qq{</td>};
1223                                            $ord++;
1224                                            $html .= qq{</tr><tr>} if ( $ord % 3 == 0 );
1225                                    }
1226                                    $cal = new HTML::CalendarMonthSimple('month'=>$mm,'year'=>$yyyy);
1227                                    $cal->border(1);
1228                                    $cal->width('30%');
1229                                    $cal->cellheight('5em');
1230                                    $cal->tableclass('month');
1231                                    #$cal->cellclass('day');
1232                                    $cal->sunday('SUN');
1233                                    $cal->saturday('SAT');
1234                                    $cal->weekdays('MON','TUE','WED','THU','FRI');
1235                                    ($l_yyyy,$l_mm) = ($yyyy,$mm);
1236                            }
1237                            $cal->setcontent($dd, qq[
1238                                    <a href="$url?date=$row->{date}">$row->{nr}</a><br/>$row->{len}
1239                            ]) if $cal;
1240                            
1241                    }
1242                    $html .= qq{<td valign="top">} . $cal->as_HTML() . qq{</td></tr></table>};
1243    
1244            } else {
1245                    $html .= join("</p><p>",
1246                          get_from_log(                          get_from_log(
1247                                  limit => 100,                                  limit => ( $q->param('last') || $q->param('date') ) ? undef : 100,
1248                                    search => $search || undef,
1249                                    tag => $q->param('tag') || undef,
1250                                    date => $q->param('date') || undef,
1251                                  fmt => {                                  fmt => {
1252                                            date => sub {
1253                                                    my $date = shift || return;
1254                                                    qq{<hr/><div class="date"><a href="$url?date=$date">$date</a></div>};
1255                                            },
1256                                          time => '<span class="time">%s</span> ',                                          time => '<span class="time">%s</span> ',
1257                                          time_channel => '<span class="channel">%s %s</span> ',                                          time_channel => '<span class="channel">%s %s</span> ',
1258                                          nick => '<span class="nick">%s:</span> ',                                          nick => '%s:&nbsp;',
1259                                            me_nick => '***%s&nbsp;',
1260                                          message => '<span class="message">%s</span>',                                          message => '<span class="message">%s</span>',
1261                                  },                                  },
1262                                  message_filter => sub {                                  filter => $filter,
                                         my $m = shift || return;  
                                         $m =~ s#($RE{URI}{HTTP})#<a href="$1">$1</a>#gs;  
                                         return $m;  
                                 },  
1263                          )                          )
1264                  ) .                  );
1265                  qq{</body></html>}          }
1266          );  
1267            $html .= qq{</p>
1268            <hr/>
1269            <p>See <a href="/history">history</a> of all messages.</p>
1270            </body></html>};
1271    
1272            $response->content( $html );
1273            warn "<< ", $request->method, " ", $request->uri, " created ", length($html), " bytes\n";
1274          return RC_OK;          return RC_OK;
1275  }  }
1276    
Legend:
Removed from v.15  
changed lines
  Added in v.100
  ViewVC Help
Powered by ViewVC 1.1.26