/[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 141 - (show annotations)
Fri Feb 6 14:12:00 2009 UTC (15 years, 1 month ago) by dpavlin
File MIME type: text/plain
File size: 37637 byte(s)
eval conversion
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 my $q;
1177
1178 if ( $request->method eq 'POST' ) {
1179 $q = new CGI::Simple( $request->content );
1180 } elsif ( $request->uri =~ /\?(.+)$/ ) {
1181 $q = new CGI::Simple( $1 );
1182 } else {
1183 $q = new CGI::Simple;
1184 }
1185
1186 my $search = $q->param('search') || $q->param('grep') || '';
1187 my $r_url = $request->url;
1188
1189 my @commands = qw( tags last-tag follow stat );
1190 my $commands_re = join('|',@commands);
1191
1192 if ($r_url =~ m#/rss(?:/($commands_re.*)\w*(?:=(\d+))?)?#i) {
1193 my $show = lc($1);
1194 my $nr = $2;
1195
1196 my $type = 'RSS'; # Atom
1197
1198 $response->content_type( 'application/' . lc($type) . '+xml' );
1199
1200 my $html = '<!-- error -->';
1201 #warn "create $type feed from ",dump( $cloud->last_tags );
1202
1203 my $feed = XML::Feed->new( $type );
1204 $feed->link( $url );
1205
1206 my $rc = RC_OK;
1207
1208 if ( $show eq 'tags' ) {
1209 $nr ||= 50;
1210 $feed->title( "tags from $CHANNEL" );
1211 $feed->link( "$url/tags" );
1212 $feed->description( "tag cloud created from messages on channel $CHANNEL which have tags// in them" );
1213 my $feed_entry = XML::Feed::Entry->new($type);
1214 $feed_entry->title( "$nr tags from $CHANNEL" );
1215 $feed_entry->author( $NICK );
1216 $feed_entry->link( '/#tags' );
1217
1218 $feed_entry->content(
1219 qq{<![CDATA[<style type="text/css">}
1220 . $cloud->css
1221 . qq{</style>}
1222 . $cloud->html( $nr )
1223 . qq{]]>}
1224 );
1225 $feed->add_entry( $feed_entry );
1226
1227 } elsif ( $show eq 'last-tag' ) {
1228
1229 $nr ||= $last_x_tags;
1230 $nr = $last_x_tags if $nr > $last_x_tags;
1231
1232 $feed->title( "last $nr tagged messages from $CHANNEL" );
1233 $feed->description( "collects messages which have tags// in them" );
1234
1235 foreach my $m ( $cloud->last_tags ) {
1236 # warn dump( $m );
1237 #my $tags = join(' ', @{$m->{tags}} );
1238 my $feed_entry = XML::Feed::Entry->new($type);
1239 $feed_entry->title( $m->{nick} . '@' . $m->{time} );
1240 $feed_entry->author( $m->{nick} );
1241 $feed_entry->link( '/#' . $m->{id} );
1242 $feed_entry->issued( DateTime::Format::Flexible->build( $m->{time} ) );
1243
1244 my $message = $filter->{message}->( $m->{message} );
1245 $message .= "<br/>\n" unless $message =~ m!<(/p|br/?)>!;
1246 # warn "## message = $message\n";
1247
1248 #$feed_entry->summary(
1249 $feed_entry->content(
1250 "<![CDATA[$message]]>"
1251 );
1252 $feed_entry->category( join(', ', @{$m->{tags}}) );
1253 $feed->add_entry( $feed_entry );
1254
1255 $nr--;
1256 last if $nr <= 0;
1257
1258 }
1259
1260 } elsif ( $show =~ m/^follow/ ) {
1261
1262 $feed->title( "Feeds which this bot follows" );
1263
1264 my $sth = $dbh->prepare( qq{ select * from feeds order by last_update desc } );
1265 $sth->execute;
1266 while (my $row = $sth->fetchrow_hashref) {
1267 my $feed_entry = XML::Feed::Entry->new($type);
1268 $feed_entry->title( $row->{name} );
1269 $feed_entry->link( $row->{url} );
1270 $feed_entry->issued( DateTime::Format::Flexible->build( $row->{last_update} ) );
1271 $feed_entry->content(
1272 '<![CDATA[<pre>' . dump( $row ) . '</pre>]]>'
1273 );
1274 $feed->add_entry( $feed_entry );
1275 }
1276
1277 } elsif ( $show =~ m/^stat/ ) {
1278
1279 my $feed_entry = XML::Feed::Entry->new($type);
1280 $feed_entry->title( "Internal stats" );
1281 $feed_entry->content(
1282 '<![CDATA[<pre>' . dump( $_stat ) . '</pre>]]>'
1283 );
1284 $feed->add_entry( $feed_entry );
1285
1286 } else {
1287 _log "WEB unknown rss request $r_url";
1288 $feed->title( "unknown $r_url" );
1289 foreach my $c ( @commands ) {
1290 my $feed_entry = XML::Feed::Entry->new($type);
1291 $feed_entry->title( "rss/$c" );
1292 $feed_entry->link( "$url/rss/$c" );
1293 $feed->add_entry( $feed_entry );
1294 }
1295 $rc = RC_DENY;
1296 }
1297
1298 eval { $response->content( $feed->as_xml ); };
1299 $rc = RC_INTERNAL_SERVER_ERROR if $@;
1300 return $rc;
1301 }
1302
1303 if ( $@ ) {
1304 warn "$@";
1305 }
1306
1307 $response->content_type("text/html; charset=UTF-8");
1308
1309 my $html =
1310 qq{<html><head><title>$NICK</title><style type="text/css">$style}
1311 . $cloud->css
1312 . qq{</style></head><body>}
1313 . qq{
1314 <form method="post" class="search" action="/">
1315 <input type="text" name="search" value="$search" size="10">
1316 <input type="submit" value="search">
1317 </form>
1318 }
1319 . $cloud->html(500)
1320 . qq{<p>};
1321
1322 if ($request->url =~ m#/tags?#) {
1323 # nop
1324 } elsif ($request->url =~ m#/history#) {
1325 my $sth = $dbh->prepare(qq{
1326 select date(time) as date,count(*) as nr,sum(length(message)) as len
1327 from log
1328 group by date(time)
1329 order by date(time) desc
1330 });
1331 $sth->execute();
1332 my ($l_yyyy,$l_mm) = (0,0);
1333 $html .= qq{<table class="calendar"><tr>};
1334 my $cal;
1335 my $ord = 0;
1336 while (my $row = $sth->fetchrow_hashref) {
1337 # this is probably PostgreSQL specific, expects ISO date
1338 my ($yyyy,$mm,$dd) = split(/-/, $row->{date});
1339 if ($yyyy != $l_yyyy || $mm != $l_mm) {
1340 if ( $cal ) {
1341 $html .= qq{<td valign="top">} . $cal->as_HTML() . qq{</td>};
1342 $ord++;
1343 $html .= qq{</tr><tr>} if ( $ord % 3 == 0 );
1344 }
1345 $cal = new HTML::CalendarMonthSimple('month'=>$mm,'year'=>$yyyy);
1346 $cal->border(1);
1347 $cal->width('30%');
1348 $cal->cellheight('5em');
1349 $cal->tableclass('month');
1350 #$cal->cellclass('day');
1351 $cal->sunday('SUN');
1352 $cal->saturday('SAT');
1353 $cal->weekdays('MON','TUE','WED','THU','FRI');
1354 ($l_yyyy,$l_mm) = ($yyyy,$mm);
1355 }
1356 $cal->setcontent($dd, qq[
1357 <a href="$url?date=$row->{date}">$row->{nr}</a><br/>$row->{len}
1358 ]) if $cal;
1359
1360 }
1361 $html .= qq{<td valign="top">} . $cal->as_HTML() . qq{</td></tr></table>};
1362
1363 } else {
1364 $html .= join("</p><p>",
1365 get_from_log(
1366 limit => ( $q->param('date') ? undef : $q->param('last') || 100 ),
1367 search => $search || undef,
1368 tag => $q->param('tag') || undef,
1369 date => $q->param('date') || undef,
1370 fmt => {
1371 date => sub {
1372 my $date = shift || return;
1373 qq{<hr/><div class="date"><a href="$url?date=$date">$date</a></div>};
1374 },
1375 time => '<span class="time">%s</span> ',
1376 time_channel => '<span class="channel">%s %s</span> ',
1377 nick => '%s:&nbsp;',
1378 me_nick => '***%s&nbsp;',
1379 message => '<span class="message">%s</span>',
1380 },
1381 filter => $filter,
1382 )
1383 );
1384 }
1385
1386 $html .= qq{</p>
1387 <hr/>
1388 <p>See <a href="/history">history</a> of all messages.</p>
1389 </body></html>};
1390
1391 $response->content( $html );
1392 warn "<< ", $request->method, " ", $request->uri, " created ", length($html), " bytes\n";
1393 return RC_OK;
1394 }
1395
1396 POE::Kernel->run;
1397
1398 =head1 TagCloud
1399
1400 Extended L<HTML::TagCloud>
1401
1402 =cut
1403
1404 package TagCloud;
1405 use warnings;
1406 use strict;
1407 use HTML::TagCloud;
1408 use base 'HTML::TagCloud';
1409 use Data::Dump qw/dump/;
1410
1411 =head2 html
1412
1413 Generate html with number of tags in title of link
1414
1415 =cut
1416
1417 sub html {
1418 my($self, $limit) = @_;
1419 my @tags=$self->tags($limit);
1420
1421 my $ntags = scalar(@tags);
1422 if ($ntags == 0) {
1423 return "";
1424 # } elsif ($ntags == 1) {
1425 # my $tag = $tags[0];
1426 # return qq{<div id="htmltagcloud"><span class="tagcloud1"><a href="}.
1427 # $tag->{url}.qq{">}.$tag->{name}.qq{</a></span></div>\n};
1428 }
1429
1430 my $html = qq{<div id="htmltagcloud">};
1431 foreach my $tag ( sort { lc($a->{name}) cmp lc($b->{name}) } @tags) {
1432 $html .= sprintf(qq{<span class="tag tagcloud%d"><a href="%s" title="%s">%s</a></span>\n},
1433 $tag->{level}, $tag->{url}, $tag->{count}, $tag->{name}
1434 );
1435 }
1436 $html .= qq{</div>};
1437 return $html;
1438 }
1439
1440 =head2 last_tags
1441
1442 my @tags = $cloud->last_tags;
1443
1444 =cut
1445
1446 my @last_tags;
1447 sub last_tags {
1448 return @last_tags;
1449 }
1450
1451 =head2 add_tag
1452
1453 $cloud->add_tag( id => 42, message => 'irc message', nick => 'foobar' [, me => 1 ] );
1454
1455 =cut
1456
1457
1458 sub add_tag {
1459 my $self = shift;
1460 my $arg = {@_};
1461
1462 return unless ($arg->{id} && $arg->{message});
1463
1464 my $m = $arg->{message};
1465
1466 my @tags;
1467
1468 while ($m =~ s#$tag_regex##s) {
1469 my $tag = $1;
1470 next if (! $tag || $tag =~ m/https?:/i);
1471 push @{ $tags->{$tag} }, $arg->{id};
1472 #warn "+tag $tag: $arg->{id}\n";
1473 $self->add($tag, "$url?tag=$tag", scalar @{$tags->{$tag}});
1474 push @tags, $tag;
1475
1476 }
1477
1478 if ( @tags ) {
1479 pop @last_tags if $#last_tags == $last_x_tags;
1480 unshift @last_tags, { tags => [ @tags ], %$arg };
1481 }
1482
1483 }
1484
1485 =head2 seed_tags
1486
1487 Read all tags from database and create in-memory cache for tags
1488
1489 =cut
1490
1491 sub seed_tags {
1492 my $self = shift;
1493 my $sth = $dbh->prepare(qq{ select id,message,nick,me,time from log where message like '%//%' order by time asc });
1494 $sth->execute;
1495 while (my $row = $sth->fetchrow_hashref) {
1496 $self->add_tag( %$row );
1497 }
1498
1499 foreach my $tag (keys %$tags) {
1500 $self->add($tag, "$url?tag=$tag", scalar @{$tags->{$tag}});
1501 }
1502 }
1503

Properties

Name Value
svn:executable *

  ViewVC Help
Powered by ViewVC 1.1.26