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

Properties

Name Value
svn:executable *

  ViewVC Help
Powered by ViewVC 1.1.26