/[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

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

Parent Directory Parent Directory | Revision Log Revision Log


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

Properties

Name Value
svn:executable *

  ViewVC Help
Powered by ViewVC 1.1.26