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

Properties

Name Value
svn:executable *

  ViewVC Help
Powered by ViewVC 1.1.26