/[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

Contents of /trunk/bin/irc-logger.pl

Parent Directory Parent Directory | Revision Log Revision Log


Revision 150 - (show annotations)
Sat Oct 8 18:43:21 2011 UTC (7 years, 9 months ago) by dpavlin
File MIME type: text/plain
File size: 38339 byte(s)
import only messages newer than last message in log
1 #!/usr/bin/perl -w
2 use strict;
3 $|++;
4
5 use POE qw(Component::IRC Component::Server::HTTP Component::Client::HTTP);
6 use HTTP::Status;
7 use DBI;
8 use Regexp::Common qw /URI/;
9 use CGI::Simple;
10 use POSIX qw/strftime/;
11 use HTML::CalendarMonthSimple;
12 use Getopt::Long;
13 use DateTime;
14 use URI::Escape;
15 use Data::Dump qw/dump/;
16 use DateTime::Format::ISO8601;
17 use Carp qw/confess/;
18 use XML::Feed;
19 use DateTime::Format::Flexible;
20 use Encode;
21 #use Redis 2.0;
22
23 =head1 NAME
24
25 irc-logger.pl
26
27 =head1 SYNOPSIS
28
29 ./irc-logger.pl
30
31 =head2 Options
32
33 =over 4
34
35 =item --import-dircproxy=filename
36
37 Import log from C<dircproxy> to C<irc-logger> database
38
39 =item --log=irc-logger.log
40
41 =back
42
43 =head1 DESCRIPTION
44
45 log all conversation on irc channel
46
47 =cut
48
49 ## CONFIG
50
51 my $debug = 0;
52
53 my $irc_config = {
54 nick => 'irc-logger',
55 server => 'irc.freenode.net',
56 port => 6667,
57 ircname => 'Anna the bot: try /msg irc-logger help',
58 };
59
60 my $HOSTNAME = `hostname -f`;
61 chomp($HOSTNAME);
62
63
64 my $CHANNEL = '#razmjenavjestina';
65
66 if ( $HOSTNAME =~ m/llin/ ) {
67 $irc_config->{nick} = 'irc-logger-llin';
68 # $irc_config = {
69 # nick => 'irc-logger-llin',
70 # server => 'localhost',
71 # port => 6668,
72 # };
73 $CHANNEL = '#irc-logger';
74 } elsif ( $HOSTNAME =~ m/lugarin/ ) {
75 $irc_config->{server} = 'irc.carnet.hr';
76 $CHANNEL = '#riss';
77 }
78
79 my @channels = ( $CHANNEL );
80
81 warn "## config = ", dump( $irc_config ) if $debug;
82
83 my $NICK = $irc_config->{nick} or die "no nick?";
84
85 my $DSN = 'DBI:Pg:dbname=' . $NICK;
86
87 my $TIMESTAMP = '%Y-%m-%d %H:%M:%S';
88
89 my $sleep_on_error = 5;
90
91 # number of last tags to keep in circular buffer
92 my $last_x_tags = 50;
93
94 # don't pull rss feeds more often than this
95 my $rss_min_delay = 60;
96
97 my $http_port = $NICK =~ m/-dev/ ? 8001 : 8000;
98
99 my $url = "http://$HOSTNAME:$http_port";
100
101 ## END CONFIG
102
103 my $use_twitter = 1;
104 eval { require Net::Twitter; };
105 $use_twitter = 0 if ($@);
106
107 my $import_dircproxy;
108 my $log_path;
109 GetOptions(
110 'import-dircproxy:s' => \$import_dircproxy,
111 'log:s' => \$log_path,
112 'debug!' => \$debug,
113 );
114
115 #$SIG{__DIE__} = sub {
116 # confess "fatal error";
117 #};
118
119 sub _log {
120 print strftime($TIMESTAMP,localtime()) . ' ' . join(" ",map { ref($_) ? dump( $_ ) : $_ } @_) . $/;
121 }
122
123 open(STDOUT, '>', $log_path) && warn "log to $log_path: $!\n";
124
125
126 # HTML formatters
127
128 my %escape = ('<'=>'&lt;', '>'=>'&gt;', '&'=>'&amp;', '"'=>'&quot;');
129 my $escape_re = join '|' => keys %escape;
130
131 my $tag_regex = '\b([\w\-_]+)//';
132
133 my %nick_enumerator;
134 my $max_color = 0;
135
136 my $filter = {
137 message => sub {
138 my $m = shift || return;
139
140 # protect HTML from wiki modifications
141 sub e {
142 my $t = shift;
143 eval { $t = 'uri_unescape{' . uri_escape($t, '^a-zA-Z0-9') . '}'; };
144 return $t;
145 }
146
147 $m =~ s/($escape_re)/$escape{$1}/gs;
148 $m =~ s#($RE{URI}{HTTP})#e(qq{<a href="$1">$1</a>})#egs;
149 # $m =~ s#\/(\w+)\/#<i>$1</i>#gs;
150 $m =~ s#$tag_regex#e(qq{<a href="$url?tag=$1" class="tag">$1</a>})#egs;
151 $m =~ s#\*(\w+)\*#<b>$1</b>#gs;
152 $m =~ s#_(\w+)_#<u>$1</u>#gs;
153
154 $m =~ s#uri_unescape{([^}]+)}#uri_unescape($1)#egs;
155 return $m;
156 },
157 nick => sub {
158 my $n = shift || return;
159 if (! $nick_enumerator{$n}) {
160 my $max = scalar keys %nick_enumerator;
161 $nick_enumerator{$n} = $max + 1;
162 }
163 return '<span class="nick col-' .
164 ( $nick_enumerator{$n} % $max_color ) .
165 '">' . $n . '</span>';
166 },
167 };
168
169 # POE IRC
170 my $poe_irc = POE::Component::IRC->spawn( %$irc_config ) or
171 die "can't start ", dump( $irc_config ), ": $!";
172
173 my $irc = $poe_irc->session_id();
174 _log "IRC session_id $irc";
175
176 my $dbh = DBI->connect($DSN,"","", { RaiseError => 1, AutoCommit => 1 }) || die $DBI::errstr;
177 $dbh->do( qq{ set client_encoding = 'UTF-8' } );
178
179 my $sql_schema = {
180 log => qq{
181 create table log (
182 id serial,
183 time timestamp default now(),
184 channel text not null,
185 me boolean default false,
186 nick text not null,
187 message text not null,
188 primary key(id)
189 );
190
191 create index log_time on log(time);
192 create index log_channel on log(channel);
193 create index log_nick on log(nick);
194 },
195 meta => q{
196 create table meta (
197 nick text not null,
198 channel text not null,
199 name text not null,
200 value text,
201 changed timestamp default 'now()',
202 primary key(nick,channel,name)
203 );
204 },
205 feeds => qq{
206 create table feeds (
207 id serial,
208 url text not null,
209 name text,
210 delay interval not null default '5 min',
211 active boolean default true,
212 channel text not null,
213 nick text not null,
214 private boolean default false,
215 last_update timestamp default 'now()',
216 polls int default 0,
217 updates int default 0
218 );
219 create unique index feeds_url on feeds(url);
220 insert into feeds (url,name,channel,nick) values ('http://wiki.razmjenavjestina.org/feed/workspace/razmjenavjestina?category=Recent%20Changes','wiki','$CHANNEL','dpavlin');
221 },
222 };
223
224 foreach my $table ( keys %$sql_schema ) {
225
226 eval {
227 $dbh->do(qq{ select count(*) from $table });
228 };
229
230 if ($@) {
231 warn "creating database table $table in $DSN\n";
232 $dbh->do( $sql_schema->{ $table } );
233 }
234 }
235
236
237 =head2 meta
238
239 Set or get some meta data into database
240
241 meta('nick','channel','var_name', $var_value );
242
243 $var_value = meta('nick','channel','var_name');
244 ( $var_value, $changed ) = meta('nick','channel','var_name');
245
246 =cut
247
248 sub meta {
249 my ($nick,$channel,$name,$value) = @_;
250
251 # normalize channel name
252 $channel =~ s/^#//;
253
254 if (defined($value)) {
255
256 my $sth = $dbh->prepare(qq{ update meta set value = ?, changed = now() where nick = ? and channel = ? and name = ? });
257
258 eval { $sth->execute( $value, $nick, $channel, $name ) };
259
260 if ( $@ ) {
261 # error
262 _log("META ERROR: $@");
263 } elsif ( ! $sth->rows ) {
264 # no result -> add new
265 $sth = $dbh->prepare(qq{ insert into meta (value,nick,channel,name,changed) values (?,?,?,?,now()) });
266 eval { $sth->execute( $value, $nick, $channel, $name ); };
267 if ( $@ ) {
268 _log "META ERROR: $@";
269 } else {
270 _log "META: created $nick/$channel/$name = $value\n";
271 }
272 } else {
273 _log "META: updated $nick/$channel/$name = $value\n";
274 }
275
276 return $value;
277
278 } else {
279
280 my $sth = $dbh->prepare(qq{ select value,changed from meta where nick = ? and channel = ? and name = ? });
281 $sth->execute( $nick, $channel, $name );
282 my ($v,$c) = $sth->fetchrow_array;
283 warn "## fetched $nick/$channel/$name = $v [$c]\n";
284 return ($v,$c) if wantarray;
285 return $v;
286
287 }
288 }
289
290
291
292 my $sth_insert_log = $dbh->prepare(qq{
293 insert into log
294 (channel, me, nick, message, time)
295 values (?,?,?,?,?)
296 });
297
298
299 my $tags;
300
301 =head2 get_from_log
302
303 my @messages = get_from_log(
304 limit => 42,
305 search => '%what to stuff in ilike%',
306 fmt => {
307 time => '{%s} ',
308 time_channel => '{%s %s} ',
309 nick => '%s: ',
310 me_nick => '***%s ',
311 message => '%s',
312 },
313 filter => {
314 message => sub {
315 # modify message content
316 return shift;
317 }
318 },
319 context => 5,
320 full_rows => 1,
321 );
322
323 Order is important. Fields are first passed through C<filter> (if available) and
324 then throgh C<< sprintf($fmt->{message}, $message >> if available.
325
326 C<context> defines number of messages around each search hit for display.
327
328 C<full_rows> will return database rows for each result with C<date>, C<time>, C<channel>,
329 C<me>, C<nick> and C<message> keys.
330
331 =cut
332
333 sub get_from_log {
334 my $args = {@_};
335
336 if ( ! $args->{fmt} ) {
337 $args->{fmt} = {
338 date => '[%s] ',
339 time => '{%s} ',
340 time_channel => '{%s %s} ',
341 nick => '%s: ',
342 me_nick => '***%s ',
343 message => '%s',
344 };
345 }
346
347 my $sql_message = qq{
348 select
349 time::date as date,
350 time::time as time,
351 channel,
352 me,
353 nick,
354 message
355 from log
356 };
357
358 my $sql_context = qq{
359 select
360 id
361 from log
362 };
363
364 my $context = $1 if ($args->{search} && $args->{search} =~ s/\s*\+(\d+)\s*/ /);
365
366 my $sql = $context ? $sql_context : $sql_message;
367
368 sub check_date {
369 my $date = shift || return;
370 my $new_date = eval { DateTime::Format::ISO8601->parse_datetime( $date )->ymd; };
371 if ( $@ ) {
372 warn "invalid date $date\n";
373 $new_date = DateTime->now->ymd;
374 }
375 return $new_date;
376 }
377
378 my @where;
379 my @args;
380 my $msg;
381
382 if (my $search = $args->{search}) {
383 $search =~ s/^\s+//;
384 $search =~ s/\s+$//;
385 push @where, 'message ilike ? or nick ilike ?';
386 push @args, ( ( '%' . $search . '%' ) x 2 );
387 $msg = "Search for '$search'";
388 }
389
390 if ($args->{tag} && $tags->{ $args->{tag} }) {
391 push @where, 'id in (' . join(',', @{ $tags->{ $args->{tag} } }) . ')';
392 $msg = "Search for tags $args->{tag}";
393 }
394
395 if (my $date = $args->{date} ) {
396 $date = check_date( $date );
397 push @where, 'date(time) = ?';
398 push @args, $date;
399 $msg = "search for date $date";
400 }
401
402 $sql .= " where " . join(" and ", @where) if @where;
403
404 $sql .= " order by log.time desc";
405 $sql .= " limit " . $args->{limit} if ($args->{limit});
406
407 #warn "### sql: $sql ", dump( @args );
408
409 my $sth = $dbh->prepare( $sql );
410 eval { $sth->execute( @args ) };
411 return if $@;
412
413 my $nr_results = $sth->rows;
414
415 my $last_row = {
416 date => '',
417 time => '',
418 channel => '',
419 nick => '',
420 };
421
422 my @rows;
423
424 while (my $row = $sth->fetchrow_hashref) {
425 unshift @rows, $row;
426 }
427
428 # normalize nick names
429 map {
430 $_->{nick} =~ s/^_*(.*?)_*$/$1/
431 } @rows;
432
433 return @rows if ($args->{full_rows});
434
435 $msg .= ' produced ' . (
436 $nr_results == 0 ? 'no results' :
437 $nr_results == 0 ? 'one result' :
438 $nr_results . ' results'
439 );
440
441 my @msgs = ( $msg );
442
443 if ($context) {
444 my @ids = @rows;
445 @rows = ();
446
447 my $last_to = 0;
448
449 my $sth = $dbh->prepare( $sql_message . qq{ where id >= ? and id < ? } );
450 foreach my $row_id (sort { $a->{id} <=> $b->{id} } @ids) {
451 my $id = $row_id->{id} || die "can't find id in row";
452
453 my ($from, $to) = ($id - $context, $id + $context);
454 $from = $last_to if ($from < $last_to);
455 $last_to = $to;
456 $sth->execute( $from, $to );
457
458 #warn "## id: $id from: $from to: $to returned: ", $sth->rows, "\n";
459
460 while (my $row = $sth->fetchrow_hashref) {
461 push @rows, $row;
462 }
463
464 }
465 }
466
467 # sprintf which can take coderef as first parametar
468 sub cr_sprintf {
469 my $fmt = shift || return;
470 if (ref($fmt) eq 'CODE') {
471 $fmt->(@_);
472 } else {
473 sprintf($fmt, @_);
474 }
475 }
476
477 foreach my $row (@rows) {
478
479 $row->{time} =~ s#\.\d+##;
480
481 my $msg = '';
482
483 $msg = cr_sprintf($args->{fmt}->{date}, $row->{date}) . ' ' if ($last_row->{date} ne $row->{date});
484 my $t = $row->{time};
485
486 if ($last_row->{channel} ne $row->{channel}) {
487 $msg .= cr_sprintf($args->{fmt}->{time_channel}, $t, $row->{channel});
488 } else {
489 $msg .= cr_sprintf($args->{fmt}->{time}, $t);
490 }
491
492 my $append = 1;
493
494 my $nick = $row->{nick};
495 # if ($nick =~ s/^_*(.*?)_*$/$1/) {
496 # $row->{nick} = $nick;
497 # }
498
499 $append = 0 if $row->{me};
500
501 if ($last_row->{nick} ne $nick) {
502 # obfu way to find format for me_nick if needed or fallback to default
503 my $fmt = $row->{me} ? ( $args->{fmt}->{me_nick} || $args->{fmt}->{nick} ) : $args->{fmt}->{nick};
504 $fmt ||= '%s';
505
506 $nick = $args->{filter}->{nick}->($nick) if (ref($args->{filter}->{nick}) eq 'CODE');
507
508 $msg .= cr_sprintf( $fmt, $nick );
509 $append = 0;
510 }
511
512 $args->{fmt}->{message} ||= '%s';
513 if (ref($args->{filter}->{message}) eq 'CODE') {
514 $msg .= cr_sprintf($args->{fmt}->{message},
515 $args->{filter}->{message}->(
516 $row->{message}
517 )
518 );
519 } else {
520 $msg .= cr_sprintf($args->{fmt}->{message}, $row->{message});
521 }
522
523 if ($append && @msgs) {
524 $msgs[$#msgs] .= " " . $msg;
525 } else {
526 push @msgs, $msg;
527 }
528
529 $last_row = $row;
530 }
531
532 return @msgs;
533 }
534
535 # tags support
536
537 my $cloud = TagCloud->new;
538 $cloud->seed_tags;
539
540 =head2 save_message
541
542 save_message(
543 channel => '#foobar',
544 me => 0,
545 nick => 'dpavlin',
546 message => 'test message',
547 time => '2006-06-25 18:57:18',
548 );
549
550 C<time> is optional, it will use C<< now() >> if it's not available.
551
552 C<me> if not specified will be C<0> (not C</me> message)
553
554 =cut
555
556 sub save_message {
557 my $a = {@_};
558 confess "have msg" if $a->{msg};
559 $a->{me} ||= 0;
560 $a->{time} ||= strftime($TIMESTAMP,localtime());
561
562 _log "ARCHIVE",
563 $a->{channel}, " ",
564 $a->{me} ? "***" . $a->{nick} : "<" . $a->{nick} . ">",
565 " " . $a->{message};
566
567 eval { $sth_insert_log->execute($a->{channel}, $a->{me}, $a->{nick}, $a->{message}, $a->{time}); };
568
569 eval {
570 my @channel = ( 'channel' , $a->{channel}, $a->{nick} );
571 push @channel, 'me' if $a->{me};
572 # my $redis = Redis->new( server => '192.168.1.61:6379' );
573 # $redis->publish( join(' ',@channel), $a->{message} );
574 };
575
576 if ( $@ ) {
577 _log "ERROR: can't archive ", $a->{message};
578 } else {
579 $cloud->add_tag( id => $dbh->last_insert_id(undef,undef,"log",undef), %$a );
580 }
581 }
582
583
584 if ($import_dircproxy) {
585 my ( $from_time, $date_time ) = $dbh->selectrow_array(qq{
586 select date_part('epoch',max(time)),max(time) from log
587 });
588
589 warn "IMPORT $date_time [$from_time]\n";
590
591 open(my $l, $import_dircproxy) || die "can't open $import_dircproxy: $!";
592 warn "importing $import_dircproxy...\n";
593 my $tz_offset = 1 * 60 * 60; # TZ GMT+2
594 while(<$l>) {
595 chomp;
596 if (/^@(\d+)\s(\S+)\s(.+)$/) {
597 my ($time, $nick, $msg) = ($1,$2,$3);
598
599 next if $time <= $from_time;
600
601 my $dt = DateTime->from_epoch( epoch => $time + $tz_offset );
602
603 my $me = 0;
604 $me = 1 if ($nick =~ m/^\[\S+]/);
605 $nick =~ s/^[\[<]([^!]+).*$/$1/;
606
607 $msg =~ s/^ACTION\s+// if ($me);
608
609 save_message(
610 channel => $CHANNEL,
611 me => $me,
612 nick => $nick,
613 message => $msg,
614 time => $dt->ymd . " " . $dt->hms,
615 ) if ($nick !~ m/^-/);
616
617 } else {
618 _log "can't parse: $_";
619 }
620 }
621 close($l);
622 warn "import over\n";
623 exit;
624 }
625
626 #
627 # RSS follow
628 #
629
630 my $_stat;
631
632 POE::Component::Client::HTTP->spawn(
633 Alias => 'rss-fetch',
634 Timeout => 30,
635 );
636
637 =head2 rss_parse_xml
638
639 rss_parse_xml({
640 url => 'http://www.example.com/rss',
641 send_rss_msgs => 42,
642 });
643
644 =cut
645
646 sub rss_parse_xml {
647 my ($kernel,$args) = @_;
648
649 warn "## rss_parse_xml ",dump( $args ) if $debug;
650
651 # how many messages to send out when feed is seen for the first time?
652 my $send_rss_msgs = $args->{send_rss_msgs};
653 $send_rss_msgs = 1 if ! defined $send_rss_msgs;
654
655 warn "## RSS fetch first $send_rss_msgs items from", $args->{url} if $debug;
656
657 my $feed;
658 eval { $feed = XML::Feed->parse( \$args->{xml} ) };
659 if ( ! $feed ) {
660 _log "can't fetch RSS ", $args->{url}, XML::Feed->errstr;
661 return;
662 }
663
664 $_stat->{rss}->{url2link}->{ $args->{url} } = $feed->link;
665
666 my ( $total, $updates ) = ( 0, 0 );
667 for my $entry ($feed->entries) {
668 $total++;
669
670 my $seen_times = $_stat->{rss}->{seen}->{$args->{channel}}->{$feed->link}->{$entry->id}++;
671 # seen allready?
672 warn "## $seen_times ",$entry->id if $debug;
673 next if $seen_times > 0;
674
675 sub prefix {
676 my ($txt,$var) = @_;
677 $var =~ s/\s+/ /gs;
678 $var =~ s/^\s+//g;
679 $var =~ s/\s+$//g;
680 return $txt . $var if $var;
681 }
682
683 # fix absolute and relative links to feed entries
684 my $link = $entry->link;
685 if ( $link =~ m!^/! ) {
686 my $host = $args->{url};
687 $host =~ s!^(http://[^/]+).*$!$1!; #!vim
688 $link = "$host/$link";
689 } elsif ( $link !~ m!^http! ) {
690 $link = $args->{url} . $link;
691 }
692
693 my $msg;
694 $msg .= prefix( 'From: ' , $args->{name} || $feed->title );
695 $msg .= prefix( ' by ' , $entry->author );
696 $msg .= prefix( ' | ' , $entry->title );
697 $msg .= prefix( ' | ' , $link );
698 # $msg .= prefix( ' id ' , $entry->id );
699 my @categories = $entry->category;
700 warn "## category = ", dump( @categories ) if $debug;
701 if ( my $tags = $entry->category ) {
702 $tags = join(' ', @$tags) if ref($tags) eq 'ARRAY';
703 $tags =~ s!^\s+!!;
704 $tags =~ s!\s*$! !;
705 $tags =~ s!,?\s+!// !g;
706 $msg .= prefix( ' ' , $tags );
707 }
708
709 if ( $seen_times == 0 && $send_rss_msgs ) {
710 $send_rss_msgs--;
711 if ( ! $args->{private} ) {
712 # FIXME bug! should be save_message
713 save_message( channel => $args->{channel}, me => 1, nick => $NICK, message => $msg );
714 # $sth_insert_log->execute( $args->{channel}, 1, $NICK, $msg, 'now()' );
715 }
716 my ( $type, $to ) = ( 'notice', $args->{channel} );
717 ( $type, $to ) = ( 'privmsg', $args->{nick} ) if $args->{private};
718
719 _log(">> RSS $type to $to:", $msg);
720 $kernel->post( $irc => $type => $to => $msg );
721
722 $updates++;
723 }
724 }
725
726 my $sql = qq{ update feeds set last_update = now(), polls = polls + 1 };
727 $sql .= qq{, updates = updates + $updates } if $updates;
728 $sql .= qq{where id = } . $args->{id};
729 eval { $dbh->do( $sql ) };
730
731 _log "RSS $updates/$total new items from", $args->{url};
732
733 return $updates;
734 }
735
736 sub rss_fetch_all {
737 my ( $kernel, $send_rss_msgs ) = @_;
738 warn "## rss_fetch_all -- send_rss_msgs: $send_rss_msgs\n" if $debug;
739 my $sql = qq{
740 select id, url, name, channel, nick, private
741 from feeds
742 where active is true
743 };
744 # limit to newer feeds only if we are not sending messages out
745 $sql .= qq{ and last_update + delay < now() } if defined ( $_stat->{rss}->{fetch} );
746 my $sth = $dbh->prepare( $sql );
747 $sth->execute();
748 warn "# ",$sth->rows," active RSS feeds\n";
749 my $count = 0;
750 while (my $row = $sth->fetchrow_hashref) {
751 $row->{send_rss_msgs} = $send_rss_msgs if defined $send_rss_msgs;
752 $_stat->{rss}->{fetch}->{ $row->{url} } = $row;
753 $kernel->post(
754 'rss-fetch',
755 'request',
756 'rss_response',
757 HTTP::Request->new( GET => $row->{url} ),
758 );
759 warn "## queued rss-fetch ", dump( $row ) if $debug;
760 }
761 return "OK, scheduled " . $sth->rows . " feeds for refresh";
762 }
763
764
765 sub rss_check_updates {
766 my $kernel = shift;
767 $_stat->{rss}->{last_poll} ||= time();
768 my $dt = time() - $_stat->{rss}->{last_poll};
769 if ( $dt > $rss_min_delay ) {
770 warn "## rss_check_updates $dt > $rss_min_delay\n";
771 $_stat->{rss}->{last_poll} = time();
772 _log rss_fetch_all( $kernel );
773 }
774 }
775
776 sub process_command {
777 my ( $kernel, $nick, $channel, $msg ) = @_;
778
779 my $res = "unknown command '$msg', try /msg $NICK help!";
780
781 if ($msg =~ m/^help/i) {
782
783 $res = "usage: /msg $NICK comand | commands: stat - user/message stat | last - show backtrace | grep foobar - find foobar";
784
785 } elsif ($msg =~ m/^(privmsg|notice)\s+(\S+)\s+(.*)$/i) {
786
787 _log ">> /$1 $2 $3";
788 $kernel->post( $irc => $1 => $2, $3 );
789 $res = '';
790
791 } elsif ($msg =~ m/^stat.*?\s*(\d*)/i) {
792
793 my $nr = $1 || 10;
794
795 my $sth = $dbh->prepare(qq{
796 select
797 trim(both '_' from nick) as nick,
798 count(*) as count,
799 sum(length(message)) as len
800 from log
801 group by trim(both '_' from nick)
802 order by len desc,count desc
803 limit $nr
804 });
805 $sth->execute();
806 $res = "Top $nr users: ";
807 my @users;
808 while (my $row = $sth->fetchrow_hashref) {
809 push @users,$row->{nick} . ': ' . $row->{count} . '/' . $row->{len} . '=' . sprintf("%.2f", $row->{len}/$row->{count});
810 }
811 $res .= join(" | ", @users);
812 } elsif ($msg =~ m/^last.*?\s*(\d*)/i) {
813
814 my $limit = $1 || meta( $nick, $channel, 'last-size' ) || 10;
815
816 foreach my $res (get_from_log( limit => $limit )) {
817 _log "last: $res";
818 $kernel->post( $irc => privmsg => $nick, $res );
819 }
820
821 $res = '';
822
823 } elsif ($msg =~ m/^(search|grep)\s+(.*)\s*$/i) {
824
825 my $what = $2;
826
827 foreach my $res (get_from_log(
828 limit => 20,
829 search => $what,
830 )) {
831 _log "search [$what]: $res";
832 $kernel->post( $irc => privmsg => $nick, $res );
833 }
834
835 $res = '';
836
837 } elsif ($msg =~ m/^(?:count|poll)\s+(.*)(?:\s+(\d+))?\s*$/i) {
838
839 my ($what,$limit) = ($1,$2);
840 $limit ||= 100;
841
842 my $stat;
843
844 foreach my $res (get_from_log(
845 limit => $limit,
846 search => $what,
847 full_rows => 1,
848 )) {
849 while ($res->{message} =~ s/\Q$what\E(\+|\-)//) {
850 $stat->{vote}->{$1}++;
851 $stat->{from}->{ $res->{nick} }++;
852 }
853 }
854
855 my @nicks;
856 foreach my $nick (sort { $stat->{from}->{$a} <=> $stat->{from}->{$b} } keys %{ $stat->{from} }) {
857 push @nicks, $nick . ( $stat->{from}->{$nick} == 1 ? '' :
858 "(" . $stat->{from}->{$nick} . ")"
859 );
860 }
861
862 $res =
863 "$what ++ " . ( $stat->{vote}->{'+'} || 0 ) .
864 " : " . ( $stat->{vote}->{'-'} || 0 ) . " --" .
865 " from " . ( join(", ", @nicks) || 'nobody' );
866
867 $kernel->post( $irc => notice => $nick, $res );
868
869 } elsif ($msg =~ m/^ping/) {
870 $res = "ping = " . dump( $_stat->{ping} );
871 } elsif ($msg =~ m/^conf(?:ig)*\s*(last-size|twitter)*\s*(.*)/) {
872 if ( ! defined( $1 ) ) {
873 my $sth = $dbh->prepare(qq{ select name,value,changed from meta where nick = ? and channel = ? });
874 $sth->execute( $nick, $channel );
875 $res = "config for $nick on $channel";
876 while ( my ($n,$v) = $sth->fetchrow_array ) {
877 $res .= " | $n = $v";
878 }
879 } elsif ( ! $2 ) {
880 my $val = meta( $nick, $channel, $1 );
881 $res = "current $1 = " . ( $val ? $val : 'undefined' );
882 } else {
883 my $validate = {
884 'last-size' => qr/^\d+/,
885 'twitter' => qr/^\w+\s+\w+/,
886 };
887
888 my ( $op, $val ) = ( $1, $2 );
889
890 if ( my $regex = $validate->{$op} ) {
891 if ( $val =~ $regex ) {
892 meta( $nick, $channel, $op, $val );
893 $res = "saved $op = $val";
894 } else {
895 $res = "config option $op = $val doesn't validate against $regex";
896 }
897 } else {
898 $res = "config option $op doesn't exist";
899 }
900 }
901 } elsif ($msg =~ m/^rss-update/) {
902 $res = rss_fetch_all( $kernel );
903 } elsif ($msg =~ m/^rss-list/) {
904 my $sth = $dbh->prepare(qq{ select url,name,last_update,active,channel,nick,private from feeds });
905 $sth->execute;
906 while (my @row = $sth->fetchrow_array) {
907 $kernel->post( $irc => privmsg => $nick, join(' | ',@row) );
908 }
909 $res = '';
910 } elsif ($msg =~ m!^rss-(add|remove|stop|start|clean)(?:-(private))?\s+(http://\S+)\s*(.*)!) {
911 my ( $command, $sub, $url, $arg ) = ( $1,$2,$3,$4 );
912
913 my $channel = $1 if ( $arg =~ s/\s*(#\S+)\s*// );
914 $channel = $nick if $sub eq 'private';
915
916 my $sql = {
917 add => qq{ insert into feeds (url,name,channel,nick,private) values (?,?,?,?,?) },
918 remove => qq{ delete from feeds where url = ? and nick = ? },
919 start => qq{ update feeds set active = true where url = ? },
920 stop => qq{ update feeds set active = false where url = ? },
921 clean => qq{ update feeds set last_update = now() - delay where url = ? },
922 };
923
924 if ( $command eq 'add' && ! $channel ) {
925 $res = "ERROR: got '$msg' which doesn't have #channel in it, ignoring!";
926 } elsif (my $q = $sql->{$command} ) {
927 my $sth = $dbh->prepare( $q );
928 my @data = ( $url );
929 if ( $command eq 'add' ) {
930 push @data, ( $arg, $channel, $nick, $sub eq 'private' ? 1 : 0 );
931 } elsif ( $command eq 'remove' ) {
932 push @data, $nick;
933 }
934 warn "## $command SQL $q with ",dump( @data ),"\n";
935 eval { $sth->execute( @data ) };
936 if ($@) {
937 $res = "ERROR: $@";
938 } else {
939 $res = "OK, RSS executed $command" .
940 ( $sub ? "-$sub " : ' ' ) .
941 ( $channel ? "on $channel " : '' ) .
942 "url $url";
943 if ( $command eq 'clean' ) {
944 my $seen = $_stat->{rss}->{seen} || die "no seen?";
945 my $want_link = $_stat->{rss}->{url2link}->{$url} || warn "no url2link($url)";
946 foreach my $c ( keys %$seen ) {
947 my $c_hash = $seen->{$c} || die "no seen->{$c}";
948 die "not HASH with rss links but ", dump($c_hash) unless ref($c_hash) eq 'HASH';
949 foreach my $link ( keys %$c_hash ) {
950 next unless $link eq $want_link;
951 _log "RSS removed seen $c $url $link";
952 }
953 }
954 } elsif ( $command eq 'add' ) {
955 rss_fetch_all( $kernel );
956 }
957 }
958 } else {
959 $res = "ERROR: don't know what to do with: $msg";
960 }
961 } elsif ($msg =~ m/^rss-clean/) {
962 # this makes sense because we didn't catch rss-clean http://... before!
963 $_stat->{rss} = undef;
964 $dbh->do( qq{ update feeds set last_update = now() - delay } );
965 $res = rss_fetch_all( $kernel );
966 }
967
968 return $res;
969 }
970
971 POE::Session->create( inline_states => {
972 _start => sub {
973 $_[KERNEL]->post( $irc => register => 'all' );
974 $_[KERNEL]->post( $irc => connect => {} );
975 },
976 irc_001 => sub {
977 my ($kernel,$sender) = @_[KERNEL,SENDER];
978 my $poco_object = $sender->get_heap();
979 _log "connected to",$poco_object->server_name();
980 $kernel->post( $sender => join => $_ ) for @channels;
981 # seen RSS cache, so don't send out messages
982 _log rss_fetch_all( $kernel, 0 );
983 undef;
984 },
985 # irc_255 => sub { # server is done blabbing
986 # $_[KERNEL]->post( $irc => join => $CHANNEL);
987 # },
988 irc_public => sub {
989 my $kernel = $_[KERNEL];
990 my $nick = (split /!/, $_[ARG0])[0];
991 my $channel = $_[ARG1]->[0];
992 my $msg = $_[ARG2];
993
994 save_message( channel => $channel, me => 0, nick => $nick, message => $msg);
995 meta( $nick, $channel, 'last-msg', $msg );
996 rss_check_updates( $kernel );
997 },
998 irc_ctcp_action => sub {
999 my $kernel = $_[KERNEL];
1000 my $nick = (split /!/, $_[ARG0])[0];
1001 my $channel = $_[ARG1]->[0];
1002 my $msg = $_[ARG2];
1003
1004 save_message( channel => $channel, me => 1, nick => $nick, message => $msg);
1005
1006 if ( $use_twitter ) {
1007 if ( my $twitter = meta( $nick, $NICK, 'twitter' ) ) {
1008 my ($login,$passwd) = split(/\s+/,$twitter,2);
1009 _log("sending twitter for $nick/$login on $channel ");
1010 my $bot = Net::Twitter->new( username=>$login, password=>$passwd );
1011 $bot->update("<${channel}> $msg");
1012 }
1013 }
1014
1015 },
1016 irc_ping => sub {
1017 _log( "pong ", $_[ARG0] );
1018 $_stat->{ping}->{ $_[ARG0] }++;
1019 rss_check_updates( $_[KERNEL] );
1020 },
1021 irc_invite => sub {
1022 my $kernel = $_[KERNEL];
1023 my $nick = (split /!/, $_[ARG0])[0];
1024 my $channel = $_[ARG1];
1025
1026 _log "invited to $channel by $nick";
1027
1028 $_[KERNEL]->post( $irc => privmsg => $nick, "how nice of you to invite me to $channel, I'll be right there..." );
1029 $_[KERNEL]->post( $irc => 'join' => $channel );
1030
1031 },
1032 irc_msg => sub {
1033 my $kernel = $_[KERNEL];
1034 my $nick = (split /!/, $_[ARG0])[0];
1035 my $channel = $_[ARG1]->[0];
1036 my $msg = $_[ARG2];
1037 warn "# ARG = ",dump( @_[ARG0,ARG1,ARG2] ) if $debug;
1038
1039 _log "<< $msg";
1040
1041 my $res = process_command( $_[KERNEL], $nick, $channel, $msg );
1042
1043 if ($res) {
1044 _log ">> [$nick] $res";
1045 $_[KERNEL]->post( $irc => privmsg => $nick, $res );
1046 }
1047
1048 rss_check_updates( $_[KERNEL] );
1049 },
1050 irc_372 => sub {
1051 _log "<< motd",$_[ARG0],$_[ARG1];
1052 },
1053 irc_375 => sub {
1054 _log "<< motd", $_[ARG0], "start";
1055 },
1056 irc_376 => sub {
1057 _log "<< motd", $_[ARG0], "end";
1058 },
1059 # irc_433 => sub {
1060 # print "# irc_433: ",$_[ARG1], "\n";
1061 # warn "## indetify $NICK\n";
1062 # $_[KERNEL]->post( $irc => privmsg => 'nickserv', "IDENTIFY $NICK" );
1063 # },
1064 # irc_451 # please register
1065 irc_477 => sub {
1066 _log "<< irc_477: ",$_[ARG1];
1067 _log ">> IDENTIFY $NICK";
1068 $_[KERNEL]->post( $irc => privmsg => 'NickServ', "IDENTIFY $NICK" );
1069 },
1070 irc_505 => sub {
1071 _log "<< irc_505: ",$_[ARG1];
1072 _log ">> register $NICK";
1073 $_[KERNEL]->post( $irc => privmsg => 'NickServ', "register $NICK" );
1074 # $_[KERNEL]->post( $irc => privmsg => 'nickserv', "IDENTIFY $NICK" );
1075 # $_[KERNEL]->post( $irc => privmsg => 'nickserv', "set hide email on" );
1076 # $_[KERNEL]->post( $irc => privmsg => 'nickserv', "set email dpavlin\@rot13.org" );
1077 },
1078 irc_registered => sub {
1079 _log "<< registered $NICK";
1080 },
1081 irc_disconnected => sub {
1082 _log "## disconnected.. sleeping for $sleep_on_error seconds and reconnecting again";
1083 sleep($sleep_on_error);
1084 $_[KERNEL]->post( $irc => connect => {} );
1085 },
1086 irc_socketerr => sub {
1087 _log "## socket error... sleeping for $sleep_on_error seconds and retry";
1088 sleep($sleep_on_error);
1089 $_[KERNEL]->post( $irc => connect => {} );
1090 },
1091 irc_notice => sub {
1092 _log "<< notice from ", $_[ARG0], $_[ARG1], $_[ARG2];
1093 my $m = $_[ARG2];
1094 if ( $m =~ m!/msg.*(NickServ).*(IDENTIFY)!i ) {
1095 _log ">> suggested to $1 $2";
1096 $_[KERNEL]->post( $irc => privmsg => $1, "$2 $NICK" );
1097 } elsif ( $m =~ m!\Q$NICK\E.*registered!i ) {
1098 _log ">> registreted, so IDENTIFY";
1099 $_[KERNEL]->post( $irc => privmsg => 'nickserv', "IDENTIFY $NICK" );
1100 } else {
1101 warn "## ignore $m\n" if $debug;
1102 }
1103 },
1104 irc_snotice => sub {
1105 _log "<< snotice", $_[ARG0]; #dump( $_[ARG0],$_[ARG1], $_[ARG2] );
1106 if ( $_[ARG0] =~ m!/(QUOTE)\s+(PASS\s+\d+)!i ) {
1107 warn ">> $1 | $2\n";
1108 $_[KERNEL]->post( $irc => lc($1) => $2);
1109 }
1110 },
1111 _child => sub {},
1112 _default => sub {
1113 _log '_default SID:', $_[SESSION]->ID, $_[ARG0], dump( $_[ARG1] );
1114 0; # false for signals
1115 },
1116 rss_response => sub {
1117 my ($request_packet, $response_packet) = @_[ARG0, ARG1];
1118 my $request_object = $request_packet->[0];
1119 my $response_object = $response_packet->[0];
1120
1121 my $row = delete( $_stat->{rss}->{fetch}->{ $request_object->uri } );
1122 if ( $row ) {
1123 $row->{xml} = $response_object->content;
1124 rss_parse_xml( $_[KERNEL], $row );
1125 } else {
1126 warn "## can't find rss->fetch for ", $request_object->uri;
1127 }
1128 },
1129 },
1130 );
1131
1132 # http server
1133
1134 _log "WEB archive at $url";
1135
1136 my $httpd = POE::Component::Server::HTTP->new(
1137 Port => $http_port,
1138 PreHandler => {
1139 '/' => sub {
1140 $_[0]->header(Connection => 'close')
1141 }
1142 },
1143 ContentHandler => { '/' => \&root_handler },
1144 Headers => { Server => 'irc-logger' },
1145 );
1146
1147 my $style = <<'_END_OF_STYLE_';
1148 p { margin: 0; padding: 0.1em; }
1149 .time, .channel { color: #808080; font-size: 60%; }
1150 .date { float: right; background: #e0e0e0; color: #404040; font-size: 120%; padding: 0.25em; border: 1px dashed #808080; }
1151 .nick { color: #000000; font-size: 80%; padding: 2px; font-family: courier, courier new, monospace ; }
1152 .message { color: #000000; font-size: 100%; }
1153 .search { float: right; }
1154 a:link.tag, a:visited.tag { border: 1px dashed #ccc; backgound: #ccc; text-decoration: none }
1155 a:hover.tag { border: 1px solid #eee }
1156 hr { border: 1px dashed #ccc; height: 1px; clear: both; }
1157 /*
1158 .col-0 { background: #ffff66 }
1159 .col-1 { background: #a0ffff }
1160 .col-2 { background: #99ff99 }
1161 .col-3 { background: #ff9999 }
1162 .col-4 { background: #ff66ff }
1163 */
1164 .calendar { border: 1px solid red; width: 100%; }
1165 .month { border: 0px; width: 100%; }
1166 _END_OF_STYLE_
1167
1168 $max_color = 0;
1169
1170 my @cols = qw(
1171 #ffcccc #ccffe6 #ccccff #e6ccff #ffccff #ffcce6 #ff9999 #ffcc99 #ffff99
1172 #ccff99 #99ff99 #99ffcc #99ccff #9999ff #cc99ff #ff6666 #ffb366 #ffff66
1173 #66ff66 #66ffb3 #66b3ff #6666ff #ff3333 #33ff33 #3399ff #3333ff #ff3399
1174 #a0a0a0 #ff0000 #ffff00 #80ff00 #0000ff #8000ff #ff00ff #ff0080 #994d00
1175 #999900 #009900 #cc0066 #c0c0c0 #ccff99 #99ff33 #808080 #660033 #ffffff
1176 );
1177
1178 foreach my $c (@cols) {
1179 $style .= ".col-${max_color} { background: $c }\n";
1180 $max_color++;
1181 }
1182 _log "WEB defined $max_color colors for users...";
1183
1184 sub root_handler {
1185 my ($request, $response) = @_;
1186 $response->code(RC_OK);
1187
1188 # this doesn't seem to work, so moved to PreHandler
1189 #$response->header(Connection => 'close');
1190
1191 return RC_OK if $request->uri =~ m/favicon.ico$/;
1192
1193 if ( $request->uri =~ m/robots.txt$/ ) {
1194 $response->content_type( 'text/plain' );
1195 $response->content( qq{
1196
1197 User-Agent: *
1198 Disallow: /
1199
1200 });
1201 return RC_OK;
1202 }
1203
1204 my $q;
1205
1206 if ( $request->method eq 'POST' ) {
1207 $q = new CGI::Simple( $request->content );
1208 } elsif ( $request->uri =~ /\?(.+)$/ ) {
1209 $q = new CGI::Simple( $1 );
1210 } else {
1211 $q = new CGI::Simple;
1212 }
1213
1214 my $search = $q->param('search') || $q->param('grep') || '';
1215 my $r_url = $request->url;
1216
1217 my @commands = qw( tags last-tag follow stat );
1218 my $commands_re = join('|',@commands);
1219
1220 if ($r_url =~ m#/rss(?:/($commands_re.*)\w*(?:=(\d+))?)?#i) {
1221 my $show = lc($1);
1222 my $nr = $2;
1223
1224 my $type = 'RSS'; # Atom
1225
1226 $response->content_type( 'application/' . lc($type) . '+xml' );
1227
1228 my $html = '<!-- error -->';
1229 #warn "create $type feed from ",dump( $cloud->last_tags );
1230
1231 my $feed = XML::Feed->new( $type );
1232 $feed->link( $url );
1233
1234 my $rc = RC_OK;
1235
1236 if ( $show eq 'tags' ) {
1237 $nr ||= 50;
1238 $feed->title( "tags from $CHANNEL" );
1239 $feed->link( "$url/tags" );
1240 $feed->description( "tag cloud created from messages on channel $CHANNEL which have tags// in them" );
1241 my $feed_entry = XML::Feed::Entry->new($type);
1242 $feed_entry->title( "$nr tags from $CHANNEL" );
1243 $feed_entry->author( $NICK );
1244 $feed_entry->link( '/#tags' );
1245
1246 $feed_entry->content(
1247 qq{<![CDATA[<style type="text/css">}
1248 . $cloud->css
1249 . qq{</style>}
1250 . $cloud->html( $nr )
1251 . qq{]]>}
1252 );
1253 $feed->add_entry( $feed_entry );
1254
1255 } elsif ( $show eq 'last-tag' ) {
1256
1257 $nr ||= $last_x_tags;
1258 $nr = $last_x_tags if $nr > $last_x_tags;
1259
1260 $feed->title( "last $nr tagged messages from $CHANNEL" );
1261 $feed->description( "collects messages which have tags// in them" );
1262
1263 foreach my $m ( $cloud->last_tags ) {
1264 # warn dump( $m );
1265 #my $tags = join(' ', @{$m->{tags}} );
1266 my $feed_entry = XML::Feed::Entry->new($type);
1267 $feed_entry->title( $m->{nick} . '@' . $m->{time} );
1268 $feed_entry->author( $m->{nick} );
1269 $feed_entry->link( '/#' . $m->{id} );
1270 $feed_entry->issued( DateTime::Format::Flexible->build( $m->{time} ) );
1271
1272 my $message = $filter->{message}->( $m->{message} );
1273 $message .= "<br/>\n" unless $message =~ m!<(/p|br/?)>!;
1274 # warn "## message = $message\n";
1275
1276 #$feed_entry->summary(
1277 $feed_entry->content(
1278 "<![CDATA[$message]]>"
1279 );
1280 $feed_entry->category( join(', ', @{$m->{tags}}) );
1281 $feed->add_entry( $feed_entry );
1282
1283 $nr--;
1284 last if $nr <= 0;
1285
1286 }
1287
1288 } elsif ( $show =~ m/^follow/ ) {
1289
1290 $feed->title( "Feeds which this bot follows" );
1291
1292 my $sth = $dbh->prepare( qq{ select * from feeds order by last_update desc } );
1293 $sth->execute;
1294 while (my $row = $sth->fetchrow_hashref) {
1295 my $feed_entry = XML::Feed::Entry->new($type);
1296 $feed_entry->title( $row->{name} );
1297 $feed_entry->link( $row->{url} );
1298 $feed_entry->issued( DateTime::Format::Flexible->build( $row->{last_update} ) );
1299 $feed_entry->content(
1300 '<![CDATA[<pre>' . dump( $row ) . '</pre>]]>'
1301 );
1302 $feed->add_entry( $feed_entry );
1303 }
1304
1305 } elsif ( $show =~ m/^stat/ ) {
1306
1307 my $feed_entry = XML::Feed::Entry->new($type);
1308 $feed_entry->title( "Internal stats" );
1309 $feed_entry->content(
1310 '<![CDATA[<pre>' . dump( $_stat ) . '</pre>]]>'
1311 );
1312 $feed->add_entry( $feed_entry );
1313
1314 } else {
1315 _log "WEB unknown rss request $r_url";
1316 $feed->title( "unknown $r_url" );
1317 foreach my $c ( @commands ) {
1318 my $feed_entry = XML::Feed::Entry->new($type);
1319 $feed_entry->title( "rss/$c" );
1320 $feed_entry->link( "$url/rss/$c" );
1321 $feed->add_entry( $feed_entry );
1322 }
1323 $rc = RC_DENY;
1324 }
1325
1326 eval { $response->content( $feed->as_xml ); };
1327 $rc = RC_INTERNAL_SERVER_ERROR if $@;
1328 return $rc;
1329 }
1330
1331 if ( $@ ) {
1332 warn "$@";
1333 }
1334
1335 $response->content_type("text/html; charset=UTF-8");
1336
1337 my $html =
1338 qq{<html><head><title>$NICK</title><style type="text/css">$style}
1339 . $cloud->css
1340 . qq{</style>
1341 <meta name="google-site-verification" content="oe-LvUiNiQRPpc_uB-3rY4MWvFifkmLf276WzAvTL5U" />
1342 </head><body>}
1343 . qq{
1344 <form method="post" class="search" action="/">
1345 <input type="text" name="search" value="$search" size="10">
1346 <input type="submit" value="search">
1347 </form>
1348 }
1349 . $cloud->html(500)
1350 . qq{<p>};
1351
1352 if ($request->url =~ m#/tags?#) {
1353 # nop
1354 } elsif ($request->url =~ m#/history#) {
1355 my $sth = $dbh->prepare(qq{
1356 select date(time) as date,count(*) as nr,sum(length(message)) as len
1357 from log
1358 group by date(time)
1359 order by date(time) desc
1360 });
1361 $sth->execute();
1362 my ($l_yyyy,$l_mm) = (0,0);
1363 $html .= qq{<table class="calendar"><tr>};
1364 my $cal;
1365 my $ord = 0;
1366 while (my $row = $sth->fetchrow_hashref) {
1367 # this is probably PostgreSQL specific, expects ISO date
1368 my ($yyyy,$mm,$dd) = split(/-/, $row->{date});
1369 if ($yyyy != $l_yyyy || $mm != $l_mm) {
1370 if ( $cal ) {
1371 $html .= qq{<td valign="top">} . $cal->as_HTML() . qq{</td>};
1372 $ord++;
1373 $html .= qq{</tr><tr>} if ( $ord % 3 == 0 );
1374 }
1375 $cal = new HTML::CalendarMonthSimple('month'=>$mm,'year'=>$yyyy);
1376 $cal->border(1);
1377 $cal->width('30%');
1378 $cal->cellheight('5em');
1379 $cal->tableclass('month');
1380 #$cal->cellclass('day');
1381 $cal->sunday('SUN');
1382 $cal->saturday('SAT');
1383 $cal->weekdays('MON','TUE','WED','THU','FRI');
1384 ($l_yyyy,$l_mm) = ($yyyy,$mm);
1385 }
1386 $cal->setcontent($dd, qq[
1387 <a href="$url?date=$row->{date}">$row->{nr}</a><br/>$row->{len}
1388 ]) if $cal;
1389
1390 }
1391 $html .= qq{<td valign="top">} . $cal->as_HTML() . qq{</td></tr></table>};
1392
1393 } else {
1394 $html .= join("</p><p>",
1395 get_from_log(
1396 limit => ( $q->param('date') ? undef : $q->param('last') || 100 ),
1397 search => $search || undef,
1398 tag => $q->param('tag') || undef,
1399 date => $q->param('date') || undef,
1400 fmt => {
1401 date => sub {
1402 my $date = shift || return;
1403 qq{<hr/><div class="date"><a href="$url?date=$date">$date</a></div>};
1404 },
1405 time => '<span class="time">%s</span> ',
1406 time_channel => '<span class="channel">%s %s</span> ',
1407 nick => '%s:&nbsp;',
1408 me_nick => '***%s&nbsp;',
1409 message => '<span class="message">%s</span>',
1410 },
1411 filter => $filter,
1412 )
1413 );
1414 }
1415
1416 $html .= qq{</p>
1417 <hr/>
1418 <p>See <a href="/history">history</a> of all messages.</p>
1419 </body></html>};
1420
1421 $response->content( $html );
1422 warn "<< ", $request->method, " ", $request->uri, " created ", length($html), " bytes\n";
1423 return RC_OK;
1424 }
1425
1426 POE::Kernel->run;
1427
1428 =head1 TagCloud
1429
1430 Extended L<HTML::TagCloud>
1431
1432 =cut
1433
1434 package TagCloud;
1435 use warnings;
1436 use strict;
1437 use HTML::TagCloud;
1438 use base 'HTML::TagCloud';
1439 use Data::Dump qw/dump/;
1440
1441 =head2 html
1442
1443 Generate html with number of tags in title of link
1444
1445 =cut
1446
1447 sub html {
1448 my($self, $limit) = @_;
1449 my @tags=$self->tags($limit);
1450
1451 my $ntags = scalar(@tags);
1452 if ($ntags == 0) {
1453 return "";
1454 # } elsif ($ntags == 1) {
1455 # my $tag = $tags[0];
1456 # return qq{<div id="htmltagcloud"><span class="tagcloud1"><a href="}.
1457 # $tag->{url}.qq{">}.$tag->{name}.qq{</a></span></div>\n};
1458 }
1459
1460 my $html = qq{<div id="htmltagcloud">};
1461 foreach my $tag ( sort { lc($a->{name}) cmp lc($b->{name}) } @tags) {
1462 $html .= sprintf(qq{<span class="tag tagcloud%d"><a href="%s" title="%s">%s</a></span>\n},
1463 $tag->{level}, $tag->{url}, $tag->{count}, $tag->{name}
1464 );
1465 }
1466 $html .= qq{</div>};
1467 return $html;
1468 }
1469
1470 =head2 last_tags
1471
1472 my @tags = $cloud->last_tags;
1473
1474 =cut
1475
1476 my @last_tags;
1477 sub last_tags {
1478 return @last_tags;
1479 }
1480
1481 =head2 add_tag
1482
1483 $cloud->add_tag( id => 42, message => 'irc message', nick => 'foobar' [, me => 1 ] );
1484
1485 =cut
1486
1487
1488 sub add_tag {
1489 my $self = shift;
1490 my $arg = {@_};
1491
1492 return unless ($arg->{id} && $arg->{message});
1493
1494 my $m = $arg->{message};
1495
1496 my @tags;
1497
1498 while ($m =~ s#$tag_regex##s) {
1499 my $tag = $1;
1500 next if (! $tag || $tag =~ m/https?:/i);
1501 push @{ $tags->{$tag} }, $arg->{id};
1502 #warn "+tag $tag: $arg->{id}\n";
1503 $self->add($tag, "$url?tag=$tag", scalar @{$tags->{$tag}});
1504 push @tags, $tag;
1505
1506 }
1507
1508 if ( @tags ) {
1509 pop @last_tags if $#last_tags == $last_x_tags;
1510 unshift @last_tags, { tags => [ @tags ], %$arg };
1511 }
1512
1513 }
1514
1515 =head2 seed_tags
1516
1517 Read all tags from database and create in-memory cache for tags
1518
1519 =cut
1520
1521 sub seed_tags {
1522 my $self = shift;
1523 my $sth = $dbh->prepare(qq{ select id,message,nick,me,time from log where message like '%//%' order by time asc });
1524 $sth->execute;
1525 while (my $row = $sth->fetchrow_hashref) {
1526 $self->add_tag( %$row );
1527 }
1528
1529 foreach my $tag (keys %$tags) {
1530 $self->add($tag, "$url?tag=$tag", scalar @{$tags->{$tag}});
1531 }
1532 }
1533

Properties

Name Value
svn:executable *

  ViewVC Help
Powered by ViewVC 1.1.26