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

Properties

Name Value
svn:executable *

  ViewVC Help
Powered by ViewVC 1.1.26