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

Properties

Name Value
svn:executable *

  ViewVC Help
Powered by ViewVC 1.1.26