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

Properties

Name Value
svn:executable *

  ViewVC Help
Powered by ViewVC 1.1.26