/[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

Diff of /trunk/bin/irc-logger.pl

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 18 by dpavlin, Mon Mar 13 17:07:40 2006 UTC revision 41 by dpavlin, Tue Oct 24 12:51:49 2006 UTC
# Line 10  irc-logger.pl Line 10  irc-logger.pl
10    
11  ./irc-logger.pl  ./irc-logger.pl
12    
13    =head2 Options
14    
15    =over 4
16    
17    =item --import-dircproxy=filename
18    
19    Import log from C<dircproxy> to C<irc-logger> database
20    
21  =head1 DESCRIPTION  =head1 DESCRIPTION
22    
23  log all conversation on irc channel  log all conversation on irc channel
# Line 18  log all conversation on irc channel Line 26  log all conversation on irc channel
26    
27  ## CONFIG  ## CONFIG
28    
29  my $NICK = 'irc-logger-dev';  my $HOSTNAME = `hostname`;
30    
31    my $NICK = 'irc-logger';
32    $NICK .= '-dev' if ($HOSTNAME =~ m/llin/);
33  my $CONNECT =  my $CONNECT =
34    {Server => 'irc.freenode.net',    {Server => 'irc.freenode.net',
35     Nick => $NICK,     Nick => $NICK,
36     Ircname => "try /msg $NICK help",     Ircname => "try /msg $NICK help",
37    };    };
38  my $CHANNEL = '#razmjenavjestina';  my $CHANNEL = '#razmjenavjestina';
39    $CHANNEL = '#irc-logger' if ($HOSTNAME =~ m/llin/);
40  my $IRC_ALIAS = "log";  my $IRC_ALIAS = "log";
41    
42  my %FOLLOWS =  my %FOLLOWS =
# Line 33  my %FOLLOWS = Line 45  my %FOLLOWS =
45     ERROR => "/var/log/apache/error.log",     ERROR => "/var/log/apache/error.log",
46    );    );
47    
48  my $DSN = 'DBI:Pg:dbname=irc-logger';  my $DSN = 'DBI:Pg:dbname=' . $NICK;
49    
50  my $ENCODING = 'ISO-8859-2';  my $ENCODING = 'ISO-8859-2';
51    my $TIMESTAMP = '%Y-%m-%d %H:%M:%S';
52    
53    my $sleep_on_error = 5;
54    
55  ## END CONFIG  ## END CONFIG
56    
# Line 44  my $ENCODING = 'ISO-8859-2'; Line 59  my $ENCODING = 'ISO-8859-2';
59  use POE qw(Component::IRC Wheel::FollowTail Component::Server::HTTP);  use POE qw(Component::IRC Wheel::FollowTail Component::Server::HTTP);
60  use HTTP::Status;  use HTTP::Status;
61  use DBI;  use DBI;
62  use Encode qw/from_to/;  use Encode qw/from_to is_utf8/;
63  use Regexp::Common qw /URI/;  use Regexp::Common qw /URI/;
64  use CGI::Simple;  use CGI::Simple;
65    use HTML::TagCloud;
66    use POSIX qw/strftime/;
67    use HTML::CalendarMonthSimple;
68    use Getopt::Long;
69    use DateTime;
70    
71    my $import_dircproxy;
72    GetOptions(
73            'import-dircproxy:s' => \$import_dircproxy,
74    );
75    
76  my $dbh = DBI->connect($DSN,"","", { RaiseError => 1, AutoCommit => 1 }) || die $DBI::errstr;  my $dbh = DBI->connect($DSN,"","", { RaiseError => 1, AutoCommit => 1 }) || die $DBI::errstr;
77    
78  =for SQL schema  eval {
79            $dbh->do(qq{ select count(*) from log });
80    };
81    
82    if ($@) {
83            warn "creating database table in $DSN\n";
84            $dbh->do(<<'_SQL_SCHEMA_');
85    
 $dbh->do(qq{  
86  create table log (  create table log (
87          id serial,          id serial,
88          time timestamp default now(),          time timestamp default now(),
89          channel text not null,          channel text not null,
90            me boolean default false,
91          nick text not null,          nick text not null,
92          message text not null,          message text not null,
93          primary key(id)          primary key(id)
# Line 67  create index log_time on log(time); Line 97  create index log_time on log(time);
97  create index log_channel on log(channel);  create index log_channel on log(channel);
98  create index log_nick on log(nick);  create index log_nick on log(nick);
99    
100  });  _SQL_SCHEMA_
101    }
 =cut  
102    
103  my $sth = $dbh->prepare(qq{  my $sth = $dbh->prepare(qq{
104  insert into log  insert into log
105          (channel, nick, message)          (channel, me, nick, message, time)
106  values (?,?,?)  values (?,?,?,?,?)
107  });  });
108    
109    my $tags;
110    my $tag_regex = '\b([\w-_]+)//';
111    
112  =head2 get_from_log  =head2 get_from_log
113    
114   my @messages = get_from_log(   my @messages = get_from_log(
# Line 86  values (?,?,?) Line 118  values (?,?,?)
118                  time => '{%s} ',                  time => '{%s} ',
119                  time_channel => '{%s %s} ',                  time_channel => '{%s %s} ',
120                  nick => '%s: ',                  nick => '%s: ',
121                    me_nick => '***%s ',
122                  message => '%s',                  message => '%s',
123          },          },
124          message_filter => sub {          filter => {
125                  # modify message content                  message => sub {
126                  return shift;                          # modify message content
127          }                          return shift;
128                    }
129            },
130            context => 5,
131   );   );
132    
133    Order is important. Fields are first passed through C<filter> (if available) and
134    then throgh C<< sprintf($fmt->{message}, $message >> if available.
135    
136    C<context> defines number of messages around each search hit for display.
137    
138  =cut  =cut
139    
140  sub get_from_log {  sub get_from_log {
141          my $args = {@_};          my $args = {@_};
142    
         $args->{limit} ||= 10;  
   
143          $args->{fmt} ||= {          $args->{fmt} ||= {
144                    date => '[%s] ',
145                  time => '{%s} ',                  time => '{%s} ',
146                  time_channel => '{%s %s} ',                  time_channel => '{%s %s} ',
147                  nick => '%s: ',                  nick => '%s: ',
148                    me_nick => '***%s ',
149                  message => '%s',                  message => '%s',
150          };          };
151    
152          my $sql = qq{          my $sql_message = qq{
153                  select                  select
154                          time::date as date,                          time::date as date,
155                          time::time as time,                          time::time as time,
156                          channel,                          channel,
157                            me,
158                          nick,                          nick,
159                          message                          message
160                  from log                  from log
161          };          };
162          $sql .= " where message ilike ? " if ($args->{search});  
163            my $sql_context = qq{
164                    select
165                            id
166                    from log
167            };
168    
169            my $context = $1 if ($args->{search} && $args->{search} =~ s/\s*\+(\d+)\s*/ /);
170    
171            my $sql = $context ? $sql_context : $sql_message;
172    
173            $sql .= " where message ilike ? or nick ilike ? " if ($args->{search});
174            $sql .= " where id in (" . join(",", @{ $tags->{ $args->{tag} } }) . ") " if ($args->{tag} && $tags->{ $args->{tag} });
175            $sql .= " where date(time) = ? " if ($args->{date});
176          $sql .= " order by log.time desc";          $sql .= " order by log.time desc";
177          $sql .= " limit " . $args->{limit};          $sql .= " limit " . $args->{limit} if ($args->{limit});
178    
179          my $sth = $dbh->prepare( $sql );          my $sth = $dbh->prepare( $sql );
180          if ($args->{search}) {          if (my $search = $args->{search}) {
181                  $sth->execute( '%' . $args->{search} . '%' );                  $search =~ s/^\s+//;
182                  warn "search for '$args->{search}' returned ", $sth->rows, " results\n";                  $search =~ s/\s+$//;
183                    $sth->execute( ( '%' . $search . '%' ) x 2 );
184                    warn "search for '$search' returned ", $sth->rows, " results ", $context || '', "\n";
185            } elsif (my $tag = $args->{tag}) {
186                    $sth->execute();
187                    warn "tag '$tag' returned ", $sth->rows, " results ", $context || '', "\n";
188            } elsif (my $date = $args->{date}) {
189                    $sth->execute($date);
190                    warn "found ", $sth->rows, " messages for date $date ", $context || '', "\n";
191          } else {          } else {
192                  $sth->execute();                  $sth->execute();
193          }          }
# Line 145  sub get_from_log { Line 208  sub get_from_log {
208                  "Showing " . ($#rows + 1) . " messages..."                  "Showing " . ($#rows + 1) . " messages..."
209          );          );
210    
211            if ($context) {
212                    my @ids = @rows;
213                    @rows = ();
214    
215                    my $last_to = 0;
216    
217                    my $sth = $dbh->prepare( $sql_message . qq{ where id >= ? and id < ? } );
218                    foreach my $row_id (sort { $a->{id} <=> $b->{id} } @ids) {
219                            my $id = $row_id->{id} || die "can't find id in row";
220            
221                            my ($from, $to) = ($id - $context, $id + $context);
222                            $from = $last_to if ($from < $last_to);
223                            $last_to = $to;
224                            $sth->execute( $from, $to );
225    
226                            #warn "## id: $id from: $from to: $to returned: ", $sth->rows, "\n";
227    
228                            while (my $row = $sth->fetchrow_hashref) {
229                                    push @rows, $row;
230                            }
231    
232                    }
233            }
234    
235            # sprintf which can take coderef as first parametar
236            sub cr_sprintf {
237                    my $fmt = shift || return;
238                    if (ref($fmt) eq 'CODE') {
239                            $fmt->(@_);
240                    } else {
241                            sprintf($fmt, @_);
242                    }
243            }
244    
245          foreach my $row (@rows) {          foreach my $row (@rows) {
246    
247                  $row->{time} =~ s#\.\d+##;                  $row->{time} =~ s#\.\d+##;
248    
                 my $t;  
                 $t = $row->{date} . ' ' if ($last_row->{date} ne $row->{date});  
                 $t .= $row->{time};  
   
249                  my $msg = '';                  my $msg = '';
250    
251                    $msg = cr_sprintf($args->{fmt}->{date}, $row->{date}) . ' ' if ($last_row->{date} ne $row->{date});
252                    my $t = $row->{time};
253    
254                  if ($last_row->{channel} ne $row->{channel}) {                  if ($last_row->{channel} ne $row->{channel}) {
255                          $msg .= sprintf($args->{fmt}->{time_channel}, $t, $row->{channel});                          $msg .= cr_sprintf($args->{fmt}->{time_channel}, $t, $row->{channel});
256                  } else {                  } else {
257                          $msg .= sprintf($args->{fmt}->{time}, $t);                          $msg .= cr_sprintf($args->{fmt}->{time}, $t);
258                  }                  }
259    
260                  my $append = 1;                  my $append = 1;
261    
262                  if ($last_row->{nick} ne $row->{nick}) {                  my $nick = $row->{nick};
263                          $msg .= sprintf($args->{fmt}->{nick}, $row->{nick});                  if ($nick =~ s/^_*(.*?)_*$/$1/) {
264                            $row->{nick} = $nick;
265                    }
266    
267                    if ($last_row->{nick} ne $nick) {
268                            # obfu way to find format for me_nick if needed or fallback to default
269                            my $fmt = $row->{me} ? ( $args->{fmt}->{me_nick} || $args->{fmt}->{nick} ) : $args->{fmt}->{nick};
270                            $fmt ||= '%s';
271    
272                            $nick = $args->{filter}->{nick}->($nick) if (ref($args->{filter}->{nick}) eq 'CODE');
273    
274                            $msg .= cr_sprintf( $fmt, $nick );
275                          $append = 0;                          $append = 0;
276                  }                  }
277    
278                  if (ref($args->{message_filter}) eq 'CODE') {                  $args->{fmt}->{message} ||= '%s';
279                          $msg .= sprintf($args->{fmt}->{message},                  if (ref($args->{filter}->{message}) eq 'CODE') {
280                                  $args->{message_filter}->(                          $msg .= cr_sprintf($args->{fmt}->{message},
281                                    $args->{filter}->{message}->(
282                                          $row->{message}                                          $row->{message}
283                                  )                                  )
284                          );                          );
285                  } else {                  } else {
286                          $msg .= sprintf($args->{fmt}->{message}, $row->{message});                          $msg .= cr_sprintf($args->{fmt}->{message}, $row->{message});
287                  }                  }
288    
289                  if ($append && @msgs) {                  if ($append && @msgs) {
# Line 190  sub get_from_log { Line 298  sub get_from_log {
298          return @msgs;          return @msgs;
299  }  }
300    
301    # tags support
302    
303    my $cloud = HTML::TagCloud->new;
304    
305    =head2 add_tag
306    
307     add_tag( id => 42, message => 'irc message' );
308    
309    =cut
310    
311    sub add_tag {
312            my $arg = {@_};
313    
314            return unless ($arg->{id} && $arg->{message});
315    
316            my $m = $arg->{message};
317            from_to('UTF-8', 'iso-8859-2', $m) if (is_utf8($m));
318    
319            while ($m =~ s#$tag_regex##s) {
320                    my $tag = $1;
321                    next if (! $tag || $tag =~ m/https?:/i);
322                    push @{ $tags->{$tag} }, $arg->{id};
323                    #warn "+tag $tag: $arg->{id}\n";
324                    $cloud->add($tag, "?tag=$tag", scalar @{$tags->{$tag}} + 1);
325            }
326    }
327    
328    =head2 seed_tags
329    
330    Read all tags from database and create in-memory cache for tags
331    
332    =cut
333    
334    sub seed_tags {
335            my $sth = $dbh->prepare(qq{ select id,message from log where message like '%//%' });
336            $sth->execute;
337            while (my $row = $sth->fetchrow_hashref) {
338                    add_tag( %$row );
339            }
340    
341            foreach my $tag (keys %$tags) {
342                    $cloud->add($tag, "?tag=$tag", scalar @{$tags->{$tag}} + 1);
343            }
344    }
345    
346    seed_tags;
347    
348    
349    =head2 save_message
350    
351      save_message(
352            channel => '#foobar',
353            me => 0,
354            nick => 'dpavlin',
355            msg => 'test message',
356            time => '2006-06-25 18:57:18',
357      );
358    
359    C<time> is optional, it will use C<< now() >> if it's not available.
360    
361    C<me> if not specified will be C<0> (not C</me> message)
362    
363    =cut
364    
365    sub save_message {
366            my $a = {@_};
367            $a->{me} ||= 0;
368            $a->{time} ||= strftime($TIMESTAMP,localtime());
369    
370            print
371                    $a->{time}, " ",
372                    $a->{channel}, " ",
373                    $a->{me} ? "***" . $a->{nick} : "<" . $a->{nick} . ">",
374                    " " . $a->{msg} . "\n";
375    
376            from_to($a->{msg}, 'UTF-8', $ENCODING);
377    
378            $sth->execute($a->{channel}, $a->{me}, $a->{nick}, $a->{msg}, $a->{time});
379            add_tag( id => $dbh->last_insert_id(undef,undef,"log",undef),
380                    message => $a->{msg});
381    }
382    
383    if ($import_dircproxy) {
384            open(my $l, $import_dircproxy) || die "can't open $import_dircproxy: $!";
385            warn "importing $import_dircproxy...\n";
386            my $tz_offset = 2 * 60 * 60;    # TZ GMT+2
387            while(<$l>) {
388                    chomp;
389                    if (/^@(\d+)\s(\S+)\s(.+)$/) {
390                            my ($time, $nick, $msg) = ($1,$2,$3);
391    
392                            my $dt = DateTime->from_epoch( epoch => $time + $tz_offset );
393    
394                            my $me = 0;
395                            $me = 1 if ($nick =~ m/^\[\S+]/);
396                            $nick =~ s/^[\[<]([^!]+).*$/$1/;
397    
398                            $msg =~ s/^ACTION\s+// if ($me);
399    
400                            save_message(
401                                    channel => $CHANNEL,
402                                    me => $me,
403                                    nick => $nick,
404                                    msg => $msg,
405                                    time => $dt->ymd . " " . $dt->hms,
406                            ) if ($nick !~ m/^-/);
407    
408                    } else {
409                            warn "can't parse: $_\n";
410                    }
411            }
412            close($l);
413            warn "import over\n";
414            exit;
415    }
416    
417    
418    #
419    # POE handing part
420    #
421    
422  my $SKIPPING = 0;               # if skipping, how many we've done  my $SKIPPING = 0;               # if skipping, how many we've done
423  my $SEND_QUEUE;                 # cache  my $SEND_QUEUE;                 # cache
424    
425  POE::Component::IRC->new($IRC_ALIAS);  POE::Component::IRC->new($IRC_ALIAS);
426    
427  POE::Session->create  POE::Session->create( inline_states =>
   (inline_states =>  
428     {_start => sub {           {_start => sub {      
429                  $_[KERNEL]->post($IRC_ALIAS => register => 'all');                  $_[KERNEL]->post($IRC_ALIAS => register => 'all');
430                  $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);                  $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);
# Line 215  POE::Session->create Line 442  POE::Session->create
442                  my $channel = $_[ARG1]->[0];                  my $channel = $_[ARG1]->[0];
443                  my $msg = $_[ARG2];                  my $msg = $_[ARG2];
444    
445                  from_to($msg, 'UTF-8', $ENCODING);                  save_message( channel => $channel, me => 0, nick => $nick, msg => $msg);
446        },
447        irc_ctcp_action => sub {
448                    my $kernel = $_[KERNEL];
449                    my $nick = (split /!/, $_[ARG0])[0];
450                    my $channel = $_[ARG1]->[0];
451                    my $msg = $_[ARG2];
452    
453                  print "$channel: <$nick> $msg\n";                  save_message( channel => $channel, me => 1, nick => $nick, msg => $msg);
                 $sth->execute($channel, $nick, $msg);  
454      },      },
455          irc_msg => sub {          irc_msg => sub {
456                  my $kernel = $_[KERNEL];                  my $kernel = $_[KERNEL];
# Line 246  POE::Session->create Line 478  POE::Session->create
478                          my $nr = $1 || 10;                          my $nr = $1 || 10;
479    
480                          my $sth = $dbh->prepare(qq{                          my $sth = $dbh->prepare(qq{
481                                  select nick,count(*) from log group by nick order by count desc limit $nr                                  select
482                                            nick,
483                                            count(*) as count,
484                                            sum(length(message)) as len
485                                    from log
486                                    group by nick
487                                    order by len desc,count desc
488                                    limit $nr
489                          });                          });
490                          $sth->execute();                          $sth->execute();
491                          $res = "Top $nr users: ";                          $res = "Top $nr users: ";
492                          my @users;                          my @users;
493                          while (my $row = $sth->fetchrow_hashref) {                          while (my $row = $sth->fetchrow_hashref) {
494                                  push @users,$row->{nick} . ': ' . $row->{count};                                  push @users,$row->{nick} . ': ' . $row->{count} . '/' . $row->{len} . '=' . sprintf("%.2f", $row->{len}/$row->{count});
495                          }                          }
496                          $res .= join(" | ", @users);                          $res .= join(" | ", @users);
497                  } elsif ($msg =~ m/^last.*?\s*(\d*)/i) {                  } elsif ($msg =~ m/^last.*?\s*(\d*)/i) {
498    
499                          foreach my $res (get_from_log( limit => $1 )) {                          foreach my $res (get_from_log( limit => ($1 || 100) )) {
500                                  print "last: $res\n";                                  print "last: $res\n";
501                                  from_to($res, $ENCODING, 'UTF-8');                                  from_to($res, $ENCODING, 'UTF-8');
502                                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );                                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );
# Line 265  POE::Session->create Line 504  POE::Session->create
504    
505                          $res = '';                          $res = '';
506    
507                  } elsif ($msg =~ m/^(search|grep)\s+(.*)$/i) {                  } elsif ($msg =~ m/^(search|grep)\s+(.*)\s*$/i) {
508    
509                          my $what = $2;                          my $what = $2;
510    
511                          foreach my $res (get_from_log( limit => 20, search => $what )) {                          foreach my $res (get_from_log(
512                                            limit => 20,
513                                            search => $what,
514                                    )) {
515                                  print "search [$what]: $res\n";                                  print "search [$what]: $res\n";
516                                  from_to($res, $ENCODING, 'UTF-8');                                  from_to($res, $ENCODING, 'UTF-8');
517                                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );                                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );
# Line 300  POE::Session->create Line 542  POE::Session->create
542                  warn "## indetify $NICK\n";                  warn "## indetify $NICK\n";
543                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );
544          },          },
545            irc_disconnected => sub {
546                    warn "## disconnected, reconnecting again\n";
547                    $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);
548            },
549            irc_socketerr => sub {
550                    warn "## socket error... sleeping for $sleep_on_error seconds and retry";
551                    sleep($sleep_on_error);
552                    $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);
553            },
554  #       irc_433 => sub {  #       irc_433 => sub {
555  #               print "# irc_433: ",$_[ARG1], "\n";  #               print "# irc_433: ",$_[ARG1], "\n";
556  #               warn "## indetify $NICK\n";  #               warn "## indetify $NICK\n";
557  #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );  #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );
558  #       },  #       },
         irc_372 => sub {  
                 print "MOTD: ", $_[ARG1], "\n";  
         },  
         irc_snotice => sub {  
                 print "(server notice): ", $_[ARG0], "\n";  
         },  
     (map  
      {  
        ;"irc_$_" => sub { }}  
      qw(  
                 )),  
 #       join  
 #       ctcp_version  
 #       connected snotice ctcp_action ping notice mode part quit  
 #       001 002 003 004 005  
 #       250 251 252 253 254 265 266  
 #       332 333 353 366 372 375 376  
 #       477  
559      _child => sub {},      _child => sub {},
560      _default => sub {      _default => sub {
561        printf "%s: session %s caught an unhandled %s event.\n",                  printf "%s #%s %s %s\n",
562          scalar localtime(), $_[SESSION]->ID, $_[ARG0];                          strftime($TIMESTAMP,localtime()), $_[SESSION]->ID, $_[ARG0],
563        print "The $_[ARG0] event was given these parameters: ",                          ref($_[ARG1]) eq "ARRAY"        ?       join(",", map { ref($_) eq "ARRAY" ? join(";", @{$_}) : $_ } @{ $_[ARG1] })     :
564          join(" ", map({"ARRAY" eq ref $_ ? "[@$_]" : "$_"} @{$_[ARG1]})), "\n";                          $_[ARG1]                                        ?       $_[ARG1]                                        :
565                            "";
566        0;                        # false for signals        0;                        # false for signals
567      },      },
568      my_add => sub {      my_add => sub {
# Line 408  my $escape_re  = join '|' => keys %escap Line 642  my $escape_re  = join '|' => keys %escap
642  my $style = <<'_END_OF_STYLE_';  my $style = <<'_END_OF_STYLE_';
643  p { margin: 0; padding: 0.1em; }  p { margin: 0; padding: 0.1em; }
644  .time, .channel { color: #808080; font-size: 60%; }  .time, .channel { color: #808080; font-size: 60%; }
645  .nick { color: #0000ff; font-size: 80%; }  .date { float: right; background: #e0e0e0; color: #404040; font-size: 120%; padding: 0.25em; border: 1px dashed #808080; }
646    .nick { color: #000000; font-size: 80%; padding: 2px; font-family: courier, courier new, monospace ; }
647  .message { color: #000000; font-size: 100%; }  .message { color: #000000; font-size: 100%; }
648  .search { float: right; }  .search { float: right; }
649    .col-0 { background: #ffff66 }
650    .col-1 { background: #a0ffff }
651    .col-2 { background: #99ff99 }
652    .col-3 { background: #ff9999 }
653    .col-4 { background: #ff66ff }
654    a:link.tag, a:visited.tag { border: 1px dashed #ccc; backgound: #ccc; text-decoration: none }
655    a:hover.tag { border: 1px solid #eee }
656    hr { border: 1px dashed #ccc; height: 1px; clear: both; }
657  _END_OF_STYLE_  _END_OF_STYLE_
658    
659    my $max_color = 4;
660    
661    my %nick_enumerator;
662    
663  sub root_handler {  sub root_handler {
664          my ($request, $response) = @_;          my ($request, $response) = @_;
665          $response->code(RC_OK);          $response->code(RC_OK);
# Line 430  sub root_handler { Line 677  sub root_handler {
677    
678          my $search = $q->param('search') || $q->param('grep') || '';          my $search = $q->param('search') || $q->param('grep') || '';
679    
680          $response->content(          my $html =
681                  qq{<html><head><title>$NICK</title><style type="text/css">$style</style></head><body>                  qq{<html><head><title>$NICK</title><style type="text/css">$style} .
682                  <form method="post" class="search">                  $cloud->css .
683                    qq{</style></head><body>} .
684                    qq{
685                    <form method="post" class="search" action="/">
686                  <input type="text" name="search" value="$search" size="10">                  <input type="text" name="search" value="$search" size="10">
687                  <input type="submit" value="search">                  <input type="submit" value="search">
688                  </form>                  </form>
                 <p>  
689                  } .                  } .
690                  join("</p><p>",                  $cloud->html(500) .
691                    qq{<p>};
692            if ($request->url =~ m#/history#) {
693                    my $sth = $dbh->prepare(qq{
694                            select date(time) as date,count(*) as nr
695                                    from log
696                                    group by date(time)
697                                    order by date(time) desc
698                    });
699                    $sth->execute();
700                    my ($l_yyyy,$l_mm) = (0,0);
701                    my $cal;
702                    while (my $row = $sth->fetchrow_hashref) {
703                            # this is probably PostgreSQL specific, expects ISO date
704                            my ($yyyy,$mm,$dd) = split(/-/, $row->{date});
705                            if ($yyyy != $l_yyyy || $mm != $l_mm) {
706                                    $html .= $cal->as_HTML() if ($cal);
707                                    $cal = new HTML::CalendarMonthSimple('month'=>$mm,'year'=>$yyyy);
708                                    $cal->border(2);
709                                    ($l_yyyy,$l_mm) = ($yyyy,$mm);
710                            }
711                            $cal->setcontent($dd, qq{
712                                    <a href="/?date=$row->{date}">$row->{nr}</a>
713                            });
714                    }
715                    $html .= $cal->as_HTML() if ($cal);
716    
717            } else {
718                    $html .= join("</p><p>",
719                          get_from_log(                          get_from_log(
720                                  limit => $q->param('limit') || 100,                                  limit => $q->param('last') || $q->param('date') ? undef : 100,
721                                  search => $q->param('search') || $q->param('grep') || undef,                                  search => $search || undef,
722                                    tag => $q->param('tag') || undef,
723                                    date => $q->param('date') || undef,
724                                  fmt => {                                  fmt => {
725                                            date => sub {
726                                                    my $date = shift || return;
727                                                    qq{<hr/><div class="date"><a href="/?date=$date">$date</a></div>};
728                                            },
729                                          time => '<span class="time">%s</span> ',                                          time => '<span class="time">%s</span> ',
730                                          time_channel => '<span class="channel">%s %s</span> ',                                          time_channel => '<span class="channel">%s %s</span> ',
731                                          nick => '<span class="nick">%s:</span> ',                                          nick => '%s:&nbsp;',
732                                            me_nick => '***%s&nbsp;',
733                                          message => '<span class="message">%s</span>',                                          message => '<span class="message">%s</span>',
734                                  },                                  },
735                                  message_filter => sub {                                  filter => {
736                                          my $m = shift || return;                                          message => sub {
737                                          $m =~ s/($escape_re)/$escape{$1}/gs;                                                  my $m = shift || return;
738                                          $m =~ s#($RE{URI}{HTTP})#<a href="$1">$1</a>#gs;                                                  $m =~ s/($escape_re)/$escape{$1}/gs;
739                                          return $m;                                                  $m =~ s#($RE{URI}{HTTP})#<a href="$1">$1</a>#gs;
740                                                    $m =~ s#$tag_regex#<a href="?tag=$1" class="tag">$1</a>#g;
741                                                    return $m;
742                                            },
743                                            nick => sub {
744                                                    my $n = shift || return;
745                                                    if (! $nick_enumerator{$n})  {
746                                                            my $max = scalar keys %nick_enumerator;
747                                                            $nick_enumerator{$n} = $max + 1;
748                                                    }
749                                                    return '<span class="nick col-' .
750                                                            ( $nick_enumerator{$n} % $max_color ) .
751                                                            '">' . $n . '</span>';
752                                            },
753                                  },                                  },
754                          )                          )
755                  ) .                  );
756                  qq{</p></body></html>}          }
757          );  
758            $html .= qq{</p>
759            <hr/>
760            <p>See <a href="/history">history</a> of all messages.</p>
761            </body></html>};
762    
763            $response->content( $html );
764          return RC_OK;          return RC_OK;
765  }  }
766    

Legend:
Removed from v.18  
changed lines
  Added in v.41

  ViewVC Help
Powered by ViewVC 1.1.26