/[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 100 - (hide annotations)
Sat Mar 8 00:14:41 2008 UTC (16 years ago) by dpavlin
File MIME type: text/plain
File size: 31750 byte(s)
- better search results message
- don't mungle rss item url
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 dpavlin 100 my $msg;
343 dpavlin 68
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 dpavlin 100 $msg = "Search for '$search'";
350 dpavlin 63 }
351 dpavlin 68
352     if ($args->{tag} && $tags->{ $args->{tag} }) {
353     push @where, 'id in (' . join(',', @{ $tags->{ $args->{tag} } }) . ')';
354 dpavlin 100 $msg = "Search for tags $args->{tag}";
355 dpavlin 68 }
356    
357     if (my $date = $args->{date} ) {
358     $date = check_date( $date );
359     push @where, 'date(time) = ?';
360     push @args, $date;
361 dpavlin 100 $msg = "search for date $date";
362 dpavlin 68 }
363    
364     $sql .= " where " . join(" and ", @where) if @where;
365    
366 dpavlin 11 $sql .= " order by log.time desc";
367 dpavlin 35 $sql .= " limit " . $args->{limit} if ($args->{limit});
368 dpavlin 11
369 dpavlin 68 #warn "### sql: $sql ", dump( @args );
370    
371 dpavlin 11 my $sth = $dbh->prepare( $sql );
372 dpavlin 69 eval { $sth->execute( @args ) };
373     return if $@;
374 dpavlin 68
375 dpavlin 100 my $nr_results = $sth->rows;
376    
377 dpavlin 11 my $last_row = {
378     date => '',
379     time => '',
380     channel => '',
381     nick => '',
382     };
383    
384     my @rows;
385    
386     while (my $row = $sth->fetchrow_hashref) {
387     unshift @rows, $row;
388     }
389    
390 dpavlin 42 # normalize nick names
391     map {
392     $_->{nick} =~ s/^_*(.*?)_*$/$1/
393     } @rows;
394    
395     return @rows if ($args->{full_rows});
396    
397 dpavlin 100 $msg .= ' produced ' . (
398     $nr_results == 0 ? 'no results' :
399     $nr_results == 0 ? 'one result' :
400     $nr_results . ' results'
401 dpavlin 16 );
402 dpavlin 11
403 dpavlin 100 my @msgs = ( $msg );
404    
405 dpavlin 21 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 dpavlin 35 # 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 dpavlin 11 foreach my $row (@rows) {
440    
441     $row->{time} =~ s#\.\d+##;
442    
443     my $msg = '';
444    
445 dpavlin 35 $msg = cr_sprintf($args->{fmt}->{date}, $row->{date}) . ' ' if ($last_row->{date} ne $row->{date});
446 dpavlin 26 my $t = $row->{time};
447    
448 dpavlin 13 if ($last_row->{channel} ne $row->{channel}) {
449 dpavlin 35 $msg .= cr_sprintf($args->{fmt}->{time_channel}, $t, $row->{channel});
450 dpavlin 13 } else {
451 dpavlin 35 $msg .= cr_sprintf($args->{fmt}->{time}, $t);
452 dpavlin 13 }
453 dpavlin 11
454 dpavlin 12 my $append = 1;
455 dpavlin 11
456 dpavlin 22 my $nick = $row->{nick};
457 dpavlin 42 # if ($nick =~ s/^_*(.*?)_*$/$1/) {
458     # $row->{nick} = $nick;
459     # }
460 dpavlin 24
461 dpavlin 22 if ($last_row->{nick} ne $nick) {
462 dpavlin 20 # 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 dpavlin 35 $msg .= cr_sprintf( $fmt, $nick );
469 dpavlin 12 $append = 0;
470     }
471    
472 dpavlin 20 $args->{fmt}->{message} ||= '%s';
473     if (ref($args->{filter}->{message}) eq 'CODE') {
474 dpavlin 35 $msg .= cr_sprintf($args->{fmt}->{message},
475 dpavlin 20 $args->{filter}->{message}->(
476 dpavlin 15 $row->{message}
477     )
478     );
479     } else {
480 dpavlin 35 $msg .= cr_sprintf($args->{fmt}->{message}, $row->{message});
481 dpavlin 15 }
482 dpavlin 11
483 dpavlin 12 if ($append && @msgs) {
484     $msgs[$#msgs] .= " " . $msg;
485     } else {
486     push @msgs, $msg;
487     }
488 dpavlin 11
489     $last_row = $row;
490     }
491    
492     return @msgs;
493     }
494    
495 dpavlin 37 # tags support
496 dpavlin 11
497 dpavlin 37 my $cloud = HTML::TagCloud->new;
498 dpavlin 4
499 dpavlin 37 =head2 add_tag
500 dpavlin 4
501 dpavlin 70 add_tag( id => 42, message => 'irc message', nick => 'foobar' [, me => 1 ] );
502 dpavlin 37
503     =cut
504    
505 dpavlin 70 my @last_tags;
506    
507 dpavlin 37 sub add_tag {
508     my $arg = {@_};
509    
510     return unless ($arg->{id} && $arg->{message});
511    
512     my $m = $arg->{message};
513    
514 dpavlin 70 my @tags;
515    
516 dpavlin 37 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 dpavlin 73 $cloud->add($tag, "$url?tag=$tag", scalar @{$tags->{$tag}} + 1);
522 dpavlin 70 push @tags, $tag;
523    
524 dpavlin 37 }
525 dpavlin 70
526     if ( @tags ) {
527 dpavlin 74 pop @last_tags if $#last_tags == $last_x_tags;
528     unshift @last_tags, { tags => [ @tags ], %$arg };
529 dpavlin 70 }
530    
531 dpavlin 37 }
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 dpavlin 74 my $sth = $dbh->prepare(qq{ select id,message,nick,me,time from log where message like '%//%' order by time asc });
541 dpavlin 37 $sth->execute;
542     while (my $row = $sth->fetchrow_hashref) {
543     add_tag( %$row );
544     }
545    
546     foreach my $tag (keys %$tags) {
547 dpavlin 73 $cloud->add($tag, "$url?tag=$tag", scalar @{$tags->{$tag}} + 1);
548 dpavlin 37 }
549     }
550    
551     seed_tags;
552    
553    
554 dpavlin 36 =head2 save_message
555    
556 dpavlin 37 save_message(
557     channel => '#foobar',
558     me => 0,
559     nick => 'dpavlin',
560 dpavlin 70 message => 'test message',
561 dpavlin 37 time => '2006-06-25 18:57:18',
562     );
563 dpavlin 36
564 dpavlin 37 C<time> is optional, it will use C<< now() >> if it's not available.
565    
566     C<me> if not specified will be C<0> (not C</me> message)
567    
568 dpavlin 36 =cut
569    
570     sub save_message {
571 dpavlin 37 my $a = {@_};
572 dpavlin 70 confess "have msg" if $a->{msg};
573 dpavlin 37 $a->{me} ||= 0;
574 dpavlin 38 $a->{time} ||= strftime($TIMESTAMP,localtime());
575 dpavlin 37
576 dpavlin 45 _log
577 dpavlin 37 $a->{channel}, " ",
578     $a->{me} ? "***" . $a->{nick} : "<" . $a->{nick} . ">",
579 dpavlin 70 " " . $a->{message};
580 dpavlin 37
581 dpavlin 87 $sth_insert_log->execute($a->{channel}, $a->{me}, $a->{nick}, $a->{message}, $a->{time});
582 dpavlin 70 add_tag( id => $dbh->last_insert_id(undef,undef,"log",undef), %$a );
583 dpavlin 36 }
584    
585 dpavlin 50
586 dpavlin 37 if ($import_dircproxy) {
587     open(my $l, $import_dircproxy) || die "can't open $import_dircproxy: $!";
588     warn "importing $import_dircproxy...\n";
589 dpavlin 69 my $tz_offset = 1 * 60 * 60; # TZ GMT+2
590 dpavlin 37 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 dpavlin 70 message => $msg,
608 dpavlin 37 time => $dt->ymd . " " . $dt->hms,
609     ) if ($nick !~ m/^-/);
610    
611     } else {
612 dpavlin 45 _log "can't parse: $_";
613 dpavlin 37 }
614     }
615     close($l);
616     warn "import over\n";
617     exit;
618     }
619    
620 dpavlin 85 #
621     # RSS follow
622     #
623 dpavlin 37
624 dpavlin 85 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 dpavlin 87 _log "RSS fetch", $args->{url};
634    
635 dpavlin 85 my $feed = XML::Feed->parse(URI->new( $args->{url} ));
636     if ( ! $feed ) {
637     _log("can't fetch RSS ", $args->{url});
638     return;
639     }
640 dpavlin 92
641 dpavlin 87 my ( $total, $updates ) = ( 0, 0 );
642 dpavlin 85 for my $entry ($feed->entries) {
643 dpavlin 87 $total++;
644 dpavlin 85
645     # seen allready?
646 dpavlin 97 next if $_rss->{$args->{channel}}->{$feed->link}->{$entry->id}++ > 0;
647 dpavlin 85
648     sub prefix {
649     my ($txt,$var) = @_;
650 dpavlin 93 $var =~ s/\s+/ /gs;
651 dpavlin 85 $var =~ s/^\s+//g;
652 dpavlin 93 $var =~ s/\s+$//g;
653 dpavlin 85 return $txt . $var if $var;
654     }
655    
656 dpavlin 94 # 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 dpavlin 85 my $msg;
667 dpavlin 90 $msg .= prefix( 'From: ' , $args->{name} || $feed->title );
668 dpavlin 85 $msg .= prefix( ' by ' , $entry->author );
669 dpavlin 92 $msg .= prefix( ' | ' , $entry->title );
670 dpavlin 94 $msg .= prefix( ' | ' , $link );
671 dpavlin 85 # $msg .= prefix( ' id ' , $entry->id );
672    
673     if ( $args->{kernel} && $send_rss_msgs ) {
674     $send_rss_msgs--;
675 dpavlin 97 $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 dpavlin 85 $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 dpavlin 86 eval { $dbh->do( $sql ) };
688 dpavlin 85
689 dpavlin 87 _log "RSS got $total items of which $updates new";
690    
691 dpavlin 85 return $updates;
692     }
693    
694     sub rss_fetch_all {
695     my $kernel = shift;
696     my $sql = qq{
697 dpavlin 97 select id, url, name, channel, nick, private
698 dpavlin 85 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 dpavlin 95 $_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 dpavlin 85 _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 dpavlin 37 #
730     # POE handing part
731     #
732    
733 dpavlin 43 my $ping; # ping stats
734 dpavlin 37
735     POE::Component::IRC->new($IRC_ALIAS);
736    
737 dpavlin 85 POE::Session->create( inline_states => {
738     _start => sub {
739 dpavlin 7 $_[KERNEL]->post($IRC_ALIAS => register => 'all');
740     $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);
741 dpavlin 4 },
742 dpavlin 9 irc_255 => sub { # server is done blabbing
743 dpavlin 7 $_[KERNEL]->post($IRC_ALIAS => join => $CHANNEL);
744 dpavlin 11 $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );
745 dpavlin 4 },
746     irc_public => sub {
747 dpavlin 7 my $kernel = $_[KERNEL];
748     my $nick = (split /!/, $_[ARG0])[0];
749     my $channel = $_[ARG1]->[0];
750     my $msg = $_[ARG2];
751 dpavlin 4
752 dpavlin 70 save_message( channel => $channel, me => 0, nick => $nick, message => $msg);
753 dpavlin 50 meta( $nick, $channel, 'last-msg', $msg );
754 dpavlin 95 rss_check_updates( $kernel );
755 dpavlin 4 },
756 dpavlin 19 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 dpavlin 70 save_message( channel => $channel, me => 1, nick => $nick, message => $msg);
763 dpavlin 50
764 dpavlin 54 if ( $use_twitter ) {
765 dpavlin 58 if ( my $twitter = meta( $nick, $NICK, 'twitter' ) ) {
766 dpavlin 54 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 dpavlin 50 }
772    
773 dpavlin 19 },
774 dpavlin 43 irc_ping => sub {
775 dpavlin 84 _log( "pong ", $_[ARG0] );
776 dpavlin 48 $ping->{ $_[ARG0] }++;
777 dpavlin 85 rss_check_updates( $_[KERNEL] );
778 dpavlin 43 },
779     irc_invite => sub {
780     my $kernel = $_[KERNEL];
781     my $nick = (split /!/, $_[ARG0])[0];
782     my $channel = $_[ARG1];
783    
784 dpavlin 85 _log "invited to $channel by $nick";
785 dpavlin 43
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 dpavlin 7 irc_msg => sub {
791     my $kernel = $_[KERNEL];
792     my $nick = (split /!/, $_[ARG0])[0];
793     my $msg = $_[ARG2];
794 dpavlin 50 my $channel = $_[ARG1]->[0];
795 dpavlin 7
796 dpavlin 8 my $res = "unknown command '$msg', try /msg $NICK help!";
797 dpavlin 11 my @out;
798 dpavlin 7
799 dpavlin 45 _log "<< $msg";
800 dpavlin 7
801 dpavlin 8 if ($msg =~ m/^help/i) {
802 dpavlin 7
803 dpavlin 11 $res = "usage: /msg $NICK comand | commands: stat - user/message stat | last - show backtrace | grep foobar - find foobar";
804 dpavlin 8
805 dpavlin 10 } elsif ($msg =~ m/^msg\s+(\S+)\s+(.*)$/i) {
806    
807 dpavlin 45 _log ">> /msg $1 $2";
808 dpavlin 10 $_[KERNEL]->post( $IRC_ALIAS => privmsg => $1, $2 );
809     $res = '';
810    
811 dpavlin 8 } elsif ($msg =~ m/^stat.*?\s*(\d*)/i) {
812    
813 dpavlin 7 my $nr = $1 || 10;
814    
815     my $sth = $dbh->prepare(qq{
816 dpavlin 40 select
817 dpavlin 57 trim(both '_' from nick) as nick,
818 dpavlin 40 count(*) as count,
819     sum(length(message)) as len
820     from log
821 dpavlin 57 group by trim(both '_' from nick)
822 dpavlin 40 order by len desc,count desc
823     limit $nr
824 dpavlin 7 });
825     $sth->execute();
826     $res = "Top $nr users: ";
827 dpavlin 8 my @users;
828 dpavlin 7 while (my $row = $sth->fetchrow_hashref) {
829 dpavlin 40 push @users,$row->{nick} . ': ' . $row->{count} . '/' . $row->{len} . '=' . sprintf("%.2f", $row->{len}/$row->{count});
830 dpavlin 7 }
831 dpavlin 8 $res .= join(" | ", @users);
832     } elsif ($msg =~ m/^last.*?\s*(\d*)/i) {
833    
834 dpavlin 50 my $limit = $1 || meta( $nick, $channel, 'last-size' ) || 10;
835    
836     foreach my $res (get_from_log( limit => $limit )) {
837 dpavlin 45 _log "last: $res";
838 dpavlin 11 $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );
839 dpavlin 8 }
840    
841 dpavlin 11 $res = '';
842 dpavlin 8
843 dpavlin 21 } elsif ($msg =~ m/^(search|grep)\s+(.*)\s*$/i) {
844 dpavlin 8
845 dpavlin 11 my $what = $2;
846 dpavlin 8
847 dpavlin 21 foreach my $res (get_from_log(
848     limit => 20,
849     search => $what,
850     )) {
851 dpavlin 45 _log "search [$what]: $res";
852 dpavlin 8 $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );
853     }
854    
855     $res = '';
856 dpavlin 11
857 dpavlin 42 } 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 dpavlin 43 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 dpavlin 42 }
881    
882     $res =
883 dpavlin 43 "$what ++ " . ( $stat->{vote}->{'+'} || 0 ) .
884     " : " . ( $stat->{vote}->{'-'} || 0 ) . " --" .
885 dpavlin 42 " from " . ( join(", ", @nicks) || 'nobody' );
886    
887 dpavlin 43 $_[KERNEL]->post( $IRC_ALIAS => notice => $nick, $res );
888    
889     } elsif ($msg =~ m/^ping/) {
890     $res = "ping = " . dump( $ping );
891 dpavlin 51 } elsif ($msg =~ m/^conf(?:ig)*\s*(last-size|twitter)*\s*(.*)/) {
892 dpavlin 50 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 dpavlin 52 $res = "config for $nick on $channel";
896 dpavlin 50 while ( my ($n,$v) = $sth->fetchrow_array ) {
897 dpavlin 52 $res .= " | $n = $v";
898 dpavlin 50 }
899 dpavlin 51 } elsif ( ! $2 ) {
900 dpavlin 50 my $val = meta( $nick, $channel, $1 );
901     $res = "current $1 = " . ( $val ? $val : 'undefined' );
902 dpavlin 51 } 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 dpavlin 50 }
921 dpavlin 85 } elsif ($msg =~ m/^rss-update/) {
922     $res = rss_fetch_all( $_[KERNEL] );
923     } elsif ($msg =~ m/^rss-clean/) {
924     $_rss = undef;
925 dpavlin 90 $dbh->do( qq{ update feeds set last_update = now() - delay } );
926 dpavlin 85 $res = "OK, cleaned RSS cache";
927 dpavlin 91 } elsif ($msg =~ m/^rss-list/) {
928 dpavlin 97 my $sth = $dbh->prepare(qq{ select url,name,last_update,active,channel,nick,private from feeds });
929 dpavlin 91 $sth->execute;
930     while (my @row = $sth->fetchrow_array) {
931     $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, join(' | ',@row) );
932     }
933     $res = '';
934 dpavlin 97 } 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 dpavlin 85 my $sql = {
941 dpavlin 97 add => qq{ insert into feeds (url,name,channel,nick,private) values (?,?,?,?,?) },
942 dpavlin 85 # remove => qq{ delete from feeds where url = ? and name = ? },
943 dpavlin 91 start => qq{ update feeds set active = true where url = ? },
944     stop => qq{ update feeds set active = false where url = ? },
945 dpavlin 85 };
946 dpavlin 97
947 dpavlin 99 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 dpavlin 85 my $sth = $dbh->prepare( $q );
951 dpavlin 97 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 dpavlin 91 eval { $sth->execute( @data ) };
957 dpavlin 97 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 dpavlin 85 }
965 dpavlin 7 }
966    
967 dpavlin 8 if ($res) {
968 dpavlin 45 _log ">> [$nick] $res";
969 dpavlin 8 $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );
970     }
971 dpavlin 7
972 dpavlin 85 rss_check_updates( $_[KERNEL] );
973 dpavlin 7 },
974 dpavlin 10 irc_477 => sub {
975 dpavlin 45 _log "# irc_477: ",$_[ARG1];
976 dpavlin 10 $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "register $NICK" );
977     },
978 dpavlin 7 irc_505 => sub {
979 dpavlin 45 _log "# irc_505: ",$_[ARG1];
980 dpavlin 7 $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "register $NICK" );
981 dpavlin 10 # $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "set hide email on" );
982     # $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "set email dpavlin\@rot13.org" );
983 dpavlin 8 },
984     irc_registered => sub {
985 dpavlin 45 _log "## registrated $NICK";
986 dpavlin 7 $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );
987 dpavlin 10 },
988 dpavlin 41 irc_disconnected => sub {
989 dpavlin 45 _log "## disconnected, reconnecting again";
990 dpavlin 41 $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);
991     },
992     irc_socketerr => sub {
993 dpavlin 45 _log "## socket error... sleeping for $sleep_on_error seconds and retry";
994 dpavlin 41 sleep($sleep_on_error);
995     $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);
996     },
997 dpavlin 11 # irc_433 => sub {
998     # print "# irc_433: ",$_[ARG1], "\n";
999     # warn "## indetify $NICK\n";
1000     # $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );
1001     # },
1002 dpavlin 4 _child => sub {},
1003     _default => sub {
1004 dpavlin 45 _log sprintf "sID:%s %s %s",
1005     $_[SESSION]->ID, $_[ARG0],
1006 dpavlin 34 ref($_[ARG1]) eq "ARRAY" ? join(",", map { ref($_) eq "ARRAY" ? join(";", @{$_}) : $_ } @{ $_[ARG1] }) :
1007     $_[ARG1] ? $_[ARG1] :
1008     "";
1009 dpavlin 4 0; # false for signals
1010     },
1011     },
1012     );
1013    
1014 dpavlin 13 # http server
1015    
1016     my $httpd = POE::Component::Server::HTTP->new(
1017 dpavlin 70 Port => $http_port,
1018 dpavlin 83 PreHandler => {
1019     '/' => sub {
1020     $_[0]->header(Connection => 'close')
1021     }
1022     },
1023 dpavlin 13 ContentHandler => { '/' => \&root_handler },
1024     Headers => { Server => 'irc-logger' },
1025     );
1026    
1027     my $style = <<'_END_OF_STYLE_';
1028 dpavlin 16 p { margin: 0; padding: 0.1em; }
1029 dpavlin 13 .time, .channel { color: #808080; font-size: 60%; }
1030 dpavlin 28 .date { float: right; background: #e0e0e0; color: #404040; font-size: 120%; padding: 0.25em; border: 1px dashed #808080; }
1031 dpavlin 20 .nick { color: #000000; font-size: 80%; padding: 2px; font-family: courier, courier new, monospace ; }
1032 dpavlin 13 .message { color: #000000; font-size: 100%; }
1033 dpavlin 16 .search { float: right; }
1034 dpavlin 60 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 dpavlin 20 .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 dpavlin 60 */
1044 dpavlin 65 .calendar { border: 1px solid red; width: 100%; }
1045     .month { border: 0px; width: 100%; }
1046 dpavlin 13 _END_OF_STYLE_
1047    
1048 dpavlin 70 $max_color = 0;
1049 dpavlin 20
1050 dpavlin 60 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 dpavlin 13 sub root_handler {
1065     my ($request, $response) = @_;
1066     $response->code(RC_OK);
1067 dpavlin 16
1068 dpavlin 83 # this doesn't seem to work, so moved to PreHandler
1069     #$response->header(Connection => 'close');
1070    
1071 dpavlin 73 return RC_OK if $request->uri =~ m/favicon.ico$/;
1072    
1073 dpavlin 16 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 dpavlin 85 if ($request->url =~ m#/rss(?:/(tags|last-tag|follow.*)\w*(?:=(\d+))?)?#i) {
1086 dpavlin 77 my $show = lc($1);
1087 dpavlin 79 my $nr = $2;
1088 dpavlin 77
1089 dpavlin 71 my $type = 'RSS'; # Atom
1090 dpavlin 70
1091 dpavlin 72 $response->content_type( 'application/' . lc($type) . '+xml' );
1092 dpavlin 70
1093     my $html = '<!-- error -->';
1094 dpavlin 74 #warn "create $type feed from ",dump( @last_tags );
1095 dpavlin 70
1096     my $feed = XML::Feed->new( $type );
1097 dpavlin 85 $feed->link( $url );
1098 dpavlin 70
1099 dpavlin 77 if ( $show eq 'tags' ) {
1100 dpavlin 79 $nr ||= 50;
1101 dpavlin 77 $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 dpavlin 70 my $feed_entry = XML::Feed::Entry->new($type);
1105 dpavlin 79 $feed_entry->title( "$nr tags from $CHANNEL" );
1106 dpavlin 77 $feed_entry->author( $NICK );
1107     $feed_entry->link( '/#tags' );
1108 dpavlin 75
1109 dpavlin 73 $feed_entry->content(
1110 dpavlin 77 qq{<![CDATA[<style type="text/css">}
1111     . $cloud->css
1112     . qq{</style>}
1113 dpavlin 79 . $cloud->html( $nr )
1114 dpavlin 77 . qq{]]>}
1115 dpavlin 70 );
1116     $feed->add_entry( $feed_entry );
1117 dpavlin 77
1118 dpavlin 79 } elsif ( $show eq 'last-tag' ) {
1119 dpavlin 77
1120 dpavlin 79 $nr ||= $last_x_tags;
1121 dpavlin 80 $nr = $last_x_tags if $nr > $last_x_tags;
1122 dpavlin 79
1123     $feed->title( "last $nr tagged messages from $CHANNEL" );
1124 dpavlin 77 $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 dpavlin 79 # warn "## message = $message\n";
1138 dpavlin 77
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 dpavlin 79
1146     $nr--;
1147     last if $nr <= 0;
1148    
1149 dpavlin 77 }
1150 dpavlin 79
1151 dpavlin 85 } 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 dpavlin 97 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 dpavlin 79 } else {
1176 dpavlin 85 _log "unknown rss request ",$request->url;
1177 dpavlin 79 return RC_DENY;
1178 dpavlin 70 }
1179    
1180     $response->content( $feed->as_xml );
1181     return RC_OK;
1182     }
1183    
1184     if ( $@ ) {
1185     warn "$@";
1186     }
1187    
1188 dpavlin 86 $response->content_type("text/html; charset=UTF-8");
1189 dpavlin 70
1190 dpavlin 35 my $html =
1191 dpavlin 77 qq{<html><head><title>$NICK</title><style type="text/css">$style}
1192     . $cloud->css
1193     . qq{</style></head><body>}
1194     . qq{
1195 dpavlin 32 <form method="post" class="search" action="/">
1196 dpavlin 16 <input type="text" name="search" value="$search" size="10">
1197     <input type="submit" value="search">
1198     </form>
1199 dpavlin 77 }
1200     . $cloud->html(500)
1201     . qq{<p>};
1202 dpavlin 76
1203     if ($request->url =~ m#/tags?#) {
1204     # nop
1205     } elsif ($request->url =~ m#/history#) {
1206 dpavlin 35 my $sth = $dbh->prepare(qq{
1207 dpavlin 65 select date(time) as date,count(*) as nr,sum(length(message)) as len
1208 dpavlin 35 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 dpavlin 65 $html .= qq{<table class="calendar"><tr>};
1215 dpavlin 35 my $cal;
1216 dpavlin 65 my $ord = 0;
1217 dpavlin 35 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 dpavlin 65 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 dpavlin 35 $cal = new HTML::CalendarMonthSimple('month'=>$mm,'year'=>$yyyy);
1227 dpavlin 65 $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 dpavlin 35 ($l_yyyy,$l_mm) = ($yyyy,$mm);
1236     }
1237 dpavlin 79 $cal->setcontent($dd, qq[
1238 dpavlin 73 <a href="$url?date=$row->{date}">$row->{nr}</a><br/>$row->{len}
1239 dpavlin 89 ]) if $cal;
1240 dpavlin 65
1241 dpavlin 35 }
1242 dpavlin 65 $html .= qq{<td valign="top">} . $cal->as_HTML() . qq{</td></tr></table>};
1243 dpavlin 35
1244     } else {
1245     $html .= join("</p><p>",
1246 dpavlin 13 get_from_log(
1247 dpavlin 68 limit => ( $q->param('last') || $q->param('date') ) ? undef : 100,
1248 dpavlin 28 search => $search || undef,
1249 dpavlin 29 tag => $q->param('tag') || undef,
1250 dpavlin 68 date => $q->param('date') || undef,
1251 dpavlin 13 fmt => {
1252 dpavlin 35 date => sub {
1253     my $date = shift || return;
1254 dpavlin 73 qq{<hr/><div class="date"><a href="$url?date=$date">$date</a></div>};
1255 dpavlin 35 },
1256 dpavlin 13 time => '<span class="time">%s</span> ',
1257     time_channel => '<span class="channel">%s %s</span> ',
1258 dpavlin 20 nick => '%s:&nbsp;',
1259     me_nick => '***%s&nbsp;',
1260 dpavlin 13 message => '<span class="message">%s</span>',
1261     },
1262 dpavlin 70 filter => $filter,
1263 dpavlin 13 )
1264 dpavlin 35 );
1265     }
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 dpavlin 74 warn "<< ", $request->method, " ", $request->uri, " created ", length($html), " bytes\n";
1274 dpavlin 13 return RC_OK;
1275     }
1276    
1277 dpavlin 4 POE::Kernel->run;

Properties

Name Value
svn:executable *

  ViewVC Help
Powered by ViewVC 1.1.26