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

Properties

Name Value
svn:executable *

  ViewVC Help
Powered by ViewVC 1.1.26