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

Properties

Name Value
svn:executable *

  ViewVC Help
Powered by ViewVC 1.1.26