/[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 93 - (hide annotations)
Fri Mar 7 10:35:04 2008 UTC (16 years ago) by dpavlin
File MIME type: text/plain
File size: 30200 byte(s)
make multi-line feed titles single line for irc
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 92
632 dpavlin 87 my ( $total, $updates ) = ( 0, 0 );
633 dpavlin 85 for my $entry ($feed->entries) {
634 dpavlin 87 $total++;
635 dpavlin 85
636     # seen allready?
637 dpavlin 92 next if $_rss->{$feed->link}->{seen}->{$entry->id}++ > 0;
638 dpavlin 85
639     sub prefix {
640     my ($txt,$var) = @_;
641 dpavlin 93 $var =~ s/\s+/ /gs;
642 dpavlin 85 $var =~ s/^\s+//g;
643 dpavlin 93 $var =~ s/\s+$//g;
644 dpavlin 85 return $txt . $var if $var;
645     }
646    
647     my $msg;
648 dpavlin 90 $msg .= prefix( 'From: ' , $args->{name} || $feed->title );
649 dpavlin 85 $msg .= prefix( ' by ' , $entry->author );
650 dpavlin 92 $msg .= prefix( ' | ' , $entry->title );
651     $msg .= prefix( ' | ' , $entry->link );
652 dpavlin 85 # $msg .= prefix( ' id ' , $entry->id );
653    
654     if ( $args->{kernel} && $send_rss_msgs ) {
655     $send_rss_msgs--;
656 dpavlin 92 _log('>>', $msg);
657     $sth_insert_log->execute( $CHANNEL, 1, $NICK, $msg, 'now()' );
658 dpavlin 85 $args->{kernel}->post( $IRC_ALIAS => notice => $CHANNEL, $msg );
659     $updates++;
660     }
661     }
662    
663     my $sql = qq{ update feeds set last_update = now(), polls = polls + 1 };
664     $sql .= qq{, updates = updates + $updates } if $updates;
665     $sql .= qq{where id = } . $args->{id};
666 dpavlin 86 eval { $dbh->do( $sql ) };
667 dpavlin 85
668 dpavlin 87 _log "RSS got $total items of which $updates new";
669    
670 dpavlin 85 return $updates;
671     }
672    
673     sub rss_fetch_all {
674     my $kernel = shift;
675     my $sql = qq{
676     select id, url, name
677     from feeds
678     where active is true
679     };
680     # limit to newer feeds only if we are not sending messages out
681     $sql .= qq{ and last_update + delay < now() } if $kernel;
682     my $sth = $dbh->prepare( $sql );
683     $sth->execute();
684     warn "# ",$sth->rows," active RSS feeds\n";
685     my $count = 0;
686     while (my $row = $sth->fetchrow_hashref) {
687     $row->{kernel} = $kernel if $kernel;
688     $count += rss_fetch( $row );
689     }
690     return "OK, fetched $count posts from " . $sth->rows . " feeds";
691     }
692    
693    
694     sub rss_check_updates {
695     my $kernel = shift;
696 dpavlin 87 my $last_t = $_rss->{last_poll} || time();
697 dpavlin 85 my $t = time();
698 dpavlin 90 if ( $t - $last_t > $rss_min_delay ) {
699 dpavlin 87 $_rss->{last_poll} = $t;
700 dpavlin 85 _log rss_fetch_all( $kernel );
701     }
702     }
703    
704     # seed rss seen cache so we won't send out all items on startup
705     _log rss_fetch_all;
706    
707 dpavlin 37 #
708     # POE handing part
709     #
710    
711 dpavlin 43 my $ping; # ping stats
712 dpavlin 37
713     POE::Component::IRC->new($IRC_ALIAS);
714    
715 dpavlin 85 POE::Session->create( inline_states => {
716     _start => sub {
717 dpavlin 7 $_[KERNEL]->post($IRC_ALIAS => register => 'all');
718     $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);
719 dpavlin 4 },
720 dpavlin 9 irc_255 => sub { # server is done blabbing
721 dpavlin 7 $_[KERNEL]->post($IRC_ALIAS => join => $CHANNEL);
722 dpavlin 11 $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );
723 dpavlin 4 },
724     irc_public => sub {
725 dpavlin 7 my $kernel = $_[KERNEL];
726     my $nick = (split /!/, $_[ARG0])[0];
727     my $channel = $_[ARG1]->[0];
728     my $msg = $_[ARG2];
729 dpavlin 4
730 dpavlin 70 save_message( channel => $channel, me => 0, nick => $nick, message => $msg);
731 dpavlin 50 meta( $nick, $channel, 'last-msg', $msg );
732 dpavlin 4 },
733 dpavlin 19 irc_ctcp_action => sub {
734     my $kernel = $_[KERNEL];
735     my $nick = (split /!/, $_[ARG0])[0];
736     my $channel = $_[ARG1]->[0];
737     my $msg = $_[ARG2];
738    
739 dpavlin 70 save_message( channel => $channel, me => 1, nick => $nick, message => $msg);
740 dpavlin 50
741 dpavlin 54 if ( $use_twitter ) {
742 dpavlin 58 if ( my $twitter = meta( $nick, $NICK, 'twitter' ) ) {
743 dpavlin 54 my ($login,$passwd) = split(/\s+/,$twitter,2);
744     _log("sending twitter for $nick/$login on $channel ");
745     my $bot = Net::Twitter->new( username=>$login, password=>$passwd );
746     $bot->update("<${channel}> $msg");
747     }
748 dpavlin 50 }
749    
750 dpavlin 19 },
751 dpavlin 43 irc_ping => sub {
752 dpavlin 84 _log( "pong ", $_[ARG0] );
753 dpavlin 48 $ping->{ $_[ARG0] }++;
754 dpavlin 85 rss_check_updates( $_[KERNEL] );
755 dpavlin 43 },
756     irc_invite => sub {
757     my $kernel = $_[KERNEL];
758     my $nick = (split /!/, $_[ARG0])[0];
759     my $channel = $_[ARG1];
760    
761 dpavlin 85 _log "invited to $channel by $nick";
762 dpavlin 43
763     $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, "how nice of you to invite me to $channel, I'll be right there..." );
764     $_[KERNEL]->post($IRC_ALIAS => join => $channel);
765    
766     },
767 dpavlin 7 irc_msg => sub {
768     my $kernel = $_[KERNEL];
769     my $nick = (split /!/, $_[ARG0])[0];
770     my $msg = $_[ARG2];
771 dpavlin 50 my $channel = $_[ARG1]->[0];
772 dpavlin 7
773 dpavlin 8 my $res = "unknown command '$msg', try /msg $NICK help!";
774 dpavlin 11 my @out;
775 dpavlin 7
776 dpavlin 45 _log "<< $msg";
777 dpavlin 7
778 dpavlin 8 if ($msg =~ m/^help/i) {
779 dpavlin 7
780 dpavlin 11 $res = "usage: /msg $NICK comand | commands: stat - user/message stat | last - show backtrace | grep foobar - find foobar";
781 dpavlin 8
782 dpavlin 10 } elsif ($msg =~ m/^msg\s+(\S+)\s+(.*)$/i) {
783    
784 dpavlin 45 _log ">> /msg $1 $2";
785 dpavlin 10 $_[KERNEL]->post( $IRC_ALIAS => privmsg => $1, $2 );
786     $res = '';
787    
788 dpavlin 8 } elsif ($msg =~ m/^stat.*?\s*(\d*)/i) {
789    
790 dpavlin 7 my $nr = $1 || 10;
791    
792     my $sth = $dbh->prepare(qq{
793 dpavlin 40 select
794 dpavlin 57 trim(both '_' from nick) as nick,
795 dpavlin 40 count(*) as count,
796     sum(length(message)) as len
797     from log
798 dpavlin 57 group by trim(both '_' from nick)
799 dpavlin 40 order by len desc,count desc
800     limit $nr
801 dpavlin 7 });
802     $sth->execute();
803     $res = "Top $nr users: ";
804 dpavlin 8 my @users;
805 dpavlin 7 while (my $row = $sth->fetchrow_hashref) {
806 dpavlin 40 push @users,$row->{nick} . ': ' . $row->{count} . '/' . $row->{len} . '=' . sprintf("%.2f", $row->{len}/$row->{count});
807 dpavlin 7 }
808 dpavlin 8 $res .= join(" | ", @users);
809     } elsif ($msg =~ m/^last.*?\s*(\d*)/i) {
810    
811 dpavlin 50 my $limit = $1 || meta( $nick, $channel, 'last-size' ) || 10;
812    
813     foreach my $res (get_from_log( limit => $limit )) {
814 dpavlin 45 _log "last: $res";
815 dpavlin 11 $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );
816 dpavlin 8 }
817    
818 dpavlin 11 $res = '';
819 dpavlin 8
820 dpavlin 21 } elsif ($msg =~ m/^(search|grep)\s+(.*)\s*$/i) {
821 dpavlin 8
822 dpavlin 11 my $what = $2;
823 dpavlin 8
824 dpavlin 21 foreach my $res (get_from_log(
825     limit => 20,
826     search => $what,
827     )) {
828 dpavlin 45 _log "search [$what]: $res";
829 dpavlin 8 $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );
830     }
831    
832     $res = '';
833 dpavlin 11
834 dpavlin 42 } elsif ($msg =~ m/^(?:count|poll)\s+(.*)(?:\s+(\d+))?\s*$/i) {
835    
836     my ($what,$limit) = ($1,$2);
837     $limit ||= 100;
838    
839     my $stat;
840    
841     foreach my $res (get_from_log(
842     limit => $limit,
843     search => $what,
844     full_rows => 1,
845     )) {
846     while ($res->{message} =~ s/\Q$what\E(\+|\-)//) {
847     $stat->{vote}->{$1}++;
848     $stat->{from}->{ $res->{nick} }++;
849     }
850     }
851    
852     my @nicks;
853 dpavlin 43 foreach my $nick (sort { $stat->{from}->{$a} <=> $stat->{from}->{$b} } keys %{ $stat->{from} }) {
854     push @nicks, $nick . ( $stat->{from}->{$nick} == 1 ? '' :
855     "(" . $stat->{from}->{$nick} . ")"
856     );
857 dpavlin 42 }
858    
859     $res =
860 dpavlin 43 "$what ++ " . ( $stat->{vote}->{'+'} || 0 ) .
861     " : " . ( $stat->{vote}->{'-'} || 0 ) . " --" .
862 dpavlin 42 " from " . ( join(", ", @nicks) || 'nobody' );
863    
864 dpavlin 43 $_[KERNEL]->post( $IRC_ALIAS => notice => $nick, $res );
865    
866     } elsif ($msg =~ m/^ping/) {
867     $res = "ping = " . dump( $ping );
868 dpavlin 51 } elsif ($msg =~ m/^conf(?:ig)*\s*(last-size|twitter)*\s*(.*)/) {
869 dpavlin 50 if ( ! defined( $1 ) ) {
870     my $sth = $dbh->prepare(qq{ select name,value,changed from meta where nick = ? and channel = ? });
871     $sth->execute( $nick, $channel );
872 dpavlin 52 $res = "config for $nick on $channel";
873 dpavlin 50 while ( my ($n,$v) = $sth->fetchrow_array ) {
874 dpavlin 52 $res .= " | $n = $v";
875 dpavlin 50 }
876 dpavlin 51 } elsif ( ! $2 ) {
877 dpavlin 50 my $val = meta( $nick, $channel, $1 );
878     $res = "current $1 = " . ( $val ? $val : 'undefined' );
879 dpavlin 51 } else {
880     my $validate = {
881     'last-size' => qr/^\d+/,
882     'twitter' => qr/^\w+\s+\w+/,
883     };
884    
885     my ( $op, $val ) = ( $1, $2 );
886    
887     if ( my $regex = $validate->{$op} ) {
888     if ( $val =~ $regex ) {
889     meta( $nick, $channel, $op, $val );
890     $res = "saved $op = $val";
891     } else {
892     $res = "config option $op = $val doesn't validate against $regex";
893     }
894     } else {
895     $res = "config option $op doesn't exist";
896     }
897 dpavlin 50 }
898 dpavlin 85 } elsif ($msg =~ m/^rss-update/) {
899     $res = rss_fetch_all( $_[KERNEL] );
900     } elsif ($msg =~ m/^rss-clean/) {
901     $_rss = undef;
902 dpavlin 90 $dbh->do( qq{ update feeds set last_update = now() - delay } );
903 dpavlin 85 $res = "OK, cleaned RSS cache";
904 dpavlin 91 } elsif ($msg =~ m/^rss-list/) {
905     my $sth = $dbh->prepare(qq{ select url,name,last_update,active from feeds });
906     $sth->execute;
907     while (my @row = $sth->fetchrow_array) {
908     $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, join(' | ',@row) );
909     }
910     $res = '';
911 dpavlin 85 } elsif ($msg =~ m!^rss-(add|remove|stop|start)\s+(http://\S+)\s*(.*)!) {
912     my $sql = {
913     add => qq{ insert into feeds (url,name) values (?,?) },
914     # remove => qq{ delete from feeds where url = ? and name = ? },
915 dpavlin 91 start => qq{ update feeds set active = true where url = ? },
916     stop => qq{ update feeds set active = false where url = ? },
917 dpavlin 85
918     };
919     if (my $q = $sql->{$1} ) {
920     my $sth = $dbh->prepare( $q );
921 dpavlin 91 my @data = ( $2 );
922     push @data, $3 if ( $q =~ s/\?//g == 2 );
923     warn "## $1 SQL $q with ",dump( @data ),"\n";
924     eval { $sth->execute( @data ) };
925 dpavlin 85 }
926    
927 dpavlin 90 $res = "OK, RSS $1 : $2 - $3";
928 dpavlin 7 }
929    
930 dpavlin 8 if ($res) {
931 dpavlin 45 _log ">> [$nick] $res";
932 dpavlin 8 $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );
933     }
934 dpavlin 7
935 dpavlin 85 rss_check_updates( $_[KERNEL] );
936 dpavlin 7 },
937 dpavlin 10 irc_477 => sub {
938 dpavlin 45 _log "# irc_477: ",$_[ARG1];
939 dpavlin 10 $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "register $NICK" );
940     },
941 dpavlin 7 irc_505 => sub {
942 dpavlin 45 _log "# irc_505: ",$_[ARG1];
943 dpavlin 7 $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "register $NICK" );
944 dpavlin 10 # $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "set hide email on" );
945     # $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "set email dpavlin\@rot13.org" );
946 dpavlin 8 },
947     irc_registered => sub {
948 dpavlin 45 _log "## registrated $NICK";
949 dpavlin 7 $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );
950 dpavlin 10 },
951 dpavlin 41 irc_disconnected => sub {
952 dpavlin 45 _log "## disconnected, reconnecting again";
953 dpavlin 41 $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);
954     },
955     irc_socketerr => sub {
956 dpavlin 45 _log "## socket error... sleeping for $sleep_on_error seconds and retry";
957 dpavlin 41 sleep($sleep_on_error);
958     $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);
959     },
960 dpavlin 11 # irc_433 => sub {
961     # print "# irc_433: ",$_[ARG1], "\n";
962     # warn "## indetify $NICK\n";
963     # $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );
964     # },
965 dpavlin 4 _child => sub {},
966     _default => sub {
967 dpavlin 45 _log sprintf "sID:%s %s %s",
968     $_[SESSION]->ID, $_[ARG0],
969 dpavlin 34 ref($_[ARG1]) eq "ARRAY" ? join(",", map { ref($_) eq "ARRAY" ? join(";", @{$_}) : $_ } @{ $_[ARG1] }) :
970     $_[ARG1] ? $_[ARG1] :
971     "";
972 dpavlin 4 0; # false for signals
973     },
974     },
975     );
976    
977 dpavlin 13 # http server
978    
979     my $httpd = POE::Component::Server::HTTP->new(
980 dpavlin 70 Port => $http_port,
981 dpavlin 83 PreHandler => {
982     '/' => sub {
983     $_[0]->header(Connection => 'close')
984     }
985     },
986 dpavlin 13 ContentHandler => { '/' => \&root_handler },
987     Headers => { Server => 'irc-logger' },
988     );
989    
990     my $style = <<'_END_OF_STYLE_';
991 dpavlin 16 p { margin: 0; padding: 0.1em; }
992 dpavlin 13 .time, .channel { color: #808080; font-size: 60%; }
993 dpavlin 28 .date { float: right; background: #e0e0e0; color: #404040; font-size: 120%; padding: 0.25em; border: 1px dashed #808080; }
994 dpavlin 20 .nick { color: #000000; font-size: 80%; padding: 2px; font-family: courier, courier new, monospace ; }
995 dpavlin 13 .message { color: #000000; font-size: 100%; }
996 dpavlin 16 .search { float: right; }
997 dpavlin 60 a:link.tag, a:visited.tag { border: 1px dashed #ccc; backgound: #ccc; text-decoration: none }
998     a:hover.tag { border: 1px solid #eee }
999     hr { border: 1px dashed #ccc; height: 1px; clear: both; }
1000     /*
1001 dpavlin 20 .col-0 { background: #ffff66 }
1002     .col-1 { background: #a0ffff }
1003     .col-2 { background: #99ff99 }
1004     .col-3 { background: #ff9999 }
1005     .col-4 { background: #ff66ff }
1006 dpavlin 60 */
1007 dpavlin 65 .calendar { border: 1px solid red; width: 100%; }
1008     .month { border: 0px; width: 100%; }
1009 dpavlin 13 _END_OF_STYLE_
1010    
1011 dpavlin 70 $max_color = 0;
1012 dpavlin 20
1013 dpavlin 60 my @cols = qw(
1014     #ffcccc #ccffe6 #ccccff #e6ccff #ffccff #ffcce6 #ff9999 #ffcc99 #ffff99
1015     #ccff99 #99ff99 #99ffcc #99ccff #9999ff #cc99ff #ff6666 #ffb366 #ffff66
1016     #66ff66 #66ffb3 #66b3ff #6666ff #ff3333 #33ff33 #3399ff #3333ff #ff3399
1017     #a0a0a0 #ff0000 #ffff00 #80ff00 #0000ff #8000ff #ff00ff #ff0080 #994d00
1018     #999900 #009900 #cc0066 #c0c0c0 #ccff99 #99ff33 #808080 #660033 #ffffff
1019     );
1020    
1021     foreach my $c (@cols) {
1022     $style .= ".col-${max_color} { background: $c }\n";
1023     $max_color++;
1024     }
1025     warn "defined $max_color colors for users...\n";
1026    
1027 dpavlin 13 sub root_handler {
1028     my ($request, $response) = @_;
1029     $response->code(RC_OK);
1030 dpavlin 16
1031 dpavlin 83 # this doesn't seem to work, so moved to PreHandler
1032     #$response->header(Connection => 'close');
1033    
1034 dpavlin 73 return RC_OK if $request->uri =~ m/favicon.ico$/;
1035    
1036 dpavlin 16 my $q;
1037    
1038     if ( $request->method eq 'POST' ) {
1039     $q = new CGI::Simple( $request->content );
1040     } elsif ( $request->uri =~ /\?(.+)$/ ) {
1041     $q = new CGI::Simple( $1 );
1042     } else {
1043     $q = new CGI::Simple;
1044     }
1045    
1046     my $search = $q->param('search') || $q->param('grep') || '';
1047    
1048 dpavlin 85 if ($request->url =~ m#/rss(?:/(tags|last-tag|follow.*)\w*(?:=(\d+))?)?#i) {
1049 dpavlin 77 my $show = lc($1);
1050 dpavlin 79 my $nr = $2;
1051 dpavlin 77
1052 dpavlin 71 my $type = 'RSS'; # Atom
1053 dpavlin 70
1054 dpavlin 72 $response->content_type( 'application/' . lc($type) . '+xml' );
1055 dpavlin 70
1056     my $html = '<!-- error -->';
1057 dpavlin 74 #warn "create $type feed from ",dump( @last_tags );
1058 dpavlin 70
1059     my $feed = XML::Feed->new( $type );
1060 dpavlin 85 $feed->link( $url );
1061 dpavlin 70
1062 dpavlin 77 if ( $show eq 'tags' ) {
1063 dpavlin 79 $nr ||= 50;
1064 dpavlin 77 $feed->title( "tags from $CHANNEL" );
1065     $feed->link( "$url/tags" );
1066     $feed->description( "tag cloud created from messages on channel $CHANNEL which have tags// in them" );
1067 dpavlin 70 my $feed_entry = XML::Feed::Entry->new($type);
1068 dpavlin 79 $feed_entry->title( "$nr tags from $CHANNEL" );
1069 dpavlin 77 $feed_entry->author( $NICK );
1070     $feed_entry->link( '/#tags' );
1071 dpavlin 75
1072 dpavlin 73 $feed_entry->content(
1073 dpavlin 77 qq{<![CDATA[<style type="text/css">}
1074     . $cloud->css
1075     . qq{</style>}
1076 dpavlin 79 . $cloud->html( $nr )
1077 dpavlin 77 . qq{]]>}
1078 dpavlin 70 );
1079     $feed->add_entry( $feed_entry );
1080 dpavlin 77
1081 dpavlin 79 } elsif ( $show eq 'last-tag' ) {
1082 dpavlin 77
1083 dpavlin 79 $nr ||= $last_x_tags;
1084 dpavlin 80 $nr = $last_x_tags if $nr > $last_x_tags;
1085 dpavlin 79
1086     $feed->title( "last $nr tagged messages from $CHANNEL" );
1087 dpavlin 77 $feed->description( "collects messages which have tags// in them" );
1088    
1089     foreach my $m ( @last_tags ) {
1090     # warn dump( $m );
1091     #my $tags = join(' ', @{$m->{tags}} );
1092     my $feed_entry = XML::Feed::Entry->new($type);
1093     $feed_entry->title( $m->{nick} . '@' . $m->{time} );
1094     $feed_entry->author( $m->{nick} );
1095     $feed_entry->link( '/#' . $m->{id} );
1096     $feed_entry->issued( DateTime::Format::Flexible->build( $m->{time} ) );
1097    
1098     my $message = $filter->{message}->( $m->{message} );
1099     $message .= "<br/>\n" unless $message =~ m!<(/p|br/?)>!;
1100 dpavlin 79 # warn "## message = $message\n";
1101 dpavlin 77
1102     #$feed_entry->summary(
1103     $feed_entry->content(
1104     "<![CDATA[$message]]>"
1105     );
1106     $feed_entry->category( join(', ', @{$m->{tags}}) );
1107     $feed->add_entry( $feed_entry );
1108 dpavlin 79
1109     $nr--;
1110     last if $nr <= 0;
1111    
1112 dpavlin 77 }
1113 dpavlin 79
1114 dpavlin 85 } elsif ( $show =~ m/^follow/ ) {
1115    
1116     $feed->title( "Feeds which this bot follows" );
1117    
1118     my $sth = $dbh->prepare( qq{ select * from feeds order by last_update desc } );
1119     $sth->execute;
1120     while (my $row = $sth->fetchrow_hashref) {
1121     my $feed_entry = XML::Feed::Entry->new($type);
1122     $feed_entry->title( $row->{name} );
1123     $feed_entry->link( $row->{url} );
1124     $feed_entry->issued( DateTime::Format::Flexible->build( $row->{last_update} ) );
1125     $feed_entry->content(
1126     '<![CDATA[<pre>' . dump( $row ) . '</pre>]]>'
1127     );
1128     $feed->add_entry( $feed_entry );
1129     }
1130    
1131 dpavlin 79 } else {
1132 dpavlin 85 _log "unknown rss request ",$request->url;
1133 dpavlin 79 return RC_DENY;
1134 dpavlin 70 }
1135    
1136     $response->content( $feed->as_xml );
1137     return RC_OK;
1138     }
1139    
1140     if ( $@ ) {
1141     warn "$@";
1142     }
1143    
1144 dpavlin 86 $response->content_type("text/html; charset=UTF-8");
1145 dpavlin 70
1146 dpavlin 35 my $html =
1147 dpavlin 77 qq{<html><head><title>$NICK</title><style type="text/css">$style}
1148     . $cloud->css
1149     . qq{</style></head><body>}
1150     . qq{
1151 dpavlin 32 <form method="post" class="search" action="/">
1152 dpavlin 16 <input type="text" name="search" value="$search" size="10">
1153     <input type="submit" value="search">
1154     </form>
1155 dpavlin 77 }
1156     . $cloud->html(500)
1157     . qq{<p>};
1158 dpavlin 76
1159     if ($request->url =~ m#/tags?#) {
1160     # nop
1161     } elsif ($request->url =~ m#/history#) {
1162 dpavlin 35 my $sth = $dbh->prepare(qq{
1163 dpavlin 65 select date(time) as date,count(*) as nr,sum(length(message)) as len
1164 dpavlin 35 from log
1165     group by date(time)
1166     order by date(time) desc
1167     });
1168     $sth->execute();
1169     my ($l_yyyy,$l_mm) = (0,0);
1170 dpavlin 65 $html .= qq{<table class="calendar"><tr>};
1171 dpavlin 35 my $cal;
1172 dpavlin 65 my $ord = 0;
1173 dpavlin 35 while (my $row = $sth->fetchrow_hashref) {
1174     # this is probably PostgreSQL specific, expects ISO date
1175     my ($yyyy,$mm,$dd) = split(/-/, $row->{date});
1176     if ($yyyy != $l_yyyy || $mm != $l_mm) {
1177 dpavlin 65 if ( $cal ) {
1178     $html .= qq{<td valign="top">} . $cal->as_HTML() . qq{</td>};
1179     $ord++;
1180     $html .= qq{</tr><tr>} if ( $ord % 3 == 0 );
1181     }
1182 dpavlin 35 $cal = new HTML::CalendarMonthSimple('month'=>$mm,'year'=>$yyyy);
1183 dpavlin 65 $cal->border(1);
1184     $cal->width('30%');
1185     $cal->cellheight('5em');
1186     $cal->tableclass('month');
1187     #$cal->cellclass('day');
1188     $cal->sunday('SUN');
1189     $cal->saturday('SAT');
1190     $cal->weekdays('MON','TUE','WED','THU','FRI');
1191 dpavlin 35 ($l_yyyy,$l_mm) = ($yyyy,$mm);
1192     }
1193 dpavlin 79 $cal->setcontent($dd, qq[
1194 dpavlin 73 <a href="$url?date=$row->{date}">$row->{nr}</a><br/>$row->{len}
1195 dpavlin 89 ]) if $cal;
1196 dpavlin 65
1197 dpavlin 35 }
1198 dpavlin 65 $html .= qq{<td valign="top">} . $cal->as_HTML() . qq{</td></tr></table>};
1199 dpavlin 35
1200     } else {
1201     $html .= join("</p><p>",
1202 dpavlin 13 get_from_log(
1203 dpavlin 68 limit => ( $q->param('last') || $q->param('date') ) ? undef : 100,
1204 dpavlin 28 search => $search || undef,
1205 dpavlin 29 tag => $q->param('tag') || undef,
1206 dpavlin 68 date => $q->param('date') || undef,
1207 dpavlin 13 fmt => {
1208 dpavlin 35 date => sub {
1209     my $date = shift || return;
1210 dpavlin 73 qq{<hr/><div class="date"><a href="$url?date=$date">$date</a></div>};
1211 dpavlin 35 },
1212 dpavlin 13 time => '<span class="time">%s</span> ',
1213     time_channel => '<span class="channel">%s %s</span> ',
1214 dpavlin 20 nick => '%s:&nbsp;',
1215     me_nick => '***%s&nbsp;',
1216 dpavlin 13 message => '<span class="message">%s</span>',
1217     },
1218 dpavlin 70 filter => $filter,
1219 dpavlin 13 )
1220 dpavlin 35 );
1221     }
1222    
1223     $html .= qq{</p>
1224     <hr/>
1225     <p>See <a href="/history">history</a> of all messages.</p>
1226     </body></html>};
1227    
1228     $response->content( $html );
1229 dpavlin 74 warn "<< ", $request->method, " ", $request->uri, " created ", length($html), " bytes\n";
1230 dpavlin 13 return RC_OK;
1231     }
1232    
1233 dpavlin 4 POE::Kernel->run;

Properties

Name Value
svn:executable *

  ViewVC Help
Powered by ViewVC 1.1.26