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

Properties

Name Value
svn:executable *

  ViewVC Help
Powered by ViewVC 1.1.26