examples/irclog2html.pl

   1 # This is a simple IRC log to HTML converter.
   2 # It accepts only logfiles in ilogger2 format, such as those provided by
   3 # http://colabti.de/irclogger/irclogger_logs/perl6 (click on "raw text").
   4 use v6;
   5
   6 # This is our class which calculates the colors of the nicks.
   7 class Chat {
   8   # 16 different colors should suffice.
   9   my $POOL_SIZE = 16;
  10
  11   has @.pool;
  12   has @.color;
  13
  14   # $id is the person id, $time is some kind of time, which is, in this class,
  15   # not necessary. But I plan to add a subclass, which does evaluate $time.
  16   method tick(Int $id, Int $time) {
  17     # As we don't have submethod BUILD support yet, we have to initialize
  18     # @.pool now.
  19     @.color //= precalc_colors($POOL_SIZE);
  20
  21     # If we haven't allocated a color for $id...
  22     unless defined @.color[$id]  {
  23       # Take one from the pool (pop), assign in to $id, and unshift it.
  24       @.pool.unshift(@.color[$id] = @.pool.pop);
  25     }
  26   }
  27
  28   # Precalculate the pool.
  29   sub precalc_colors(Int $num) {
  30     my @colors = 0..$num-1;
  31
  32     @colors .= map: { [calc_color($^i, $num)] };
  33
  34     return @colors;
  35   }
  36
  37   # calc_color copied from irclog2html.pl
  38   # (http://freshmeat.net/projects/irclog2html.pl/), Copyleft (C) 2000-2002 Jeff
  39   # Waugh, licensed under the Terms of the GNU General Public License, version 2
  40   # or higher.
  41   # calc_color expects the total number of colors to assign ($_[2]) and the color
  42   # id ($_[1]) and returns a HTML-("#foreground", "#background")-pair with nice
  43   # contrast etc.
  44   # Take calc_color as a sub w/o errors.
  45   sub calc_color(Int $i, Int $ncolors is copy) {
  46     $ncolors = 1 if $ncolors == 0; # No division /0.
  47
  48     my $a = 0.95;     # tune these for the starting and ending concentrations of R,G,B
  49     my $b = 0.5;
  50     my $rgb = [ [$a,$b,$b], [$b,$a,$b], [$b,$b,$a], [$a,$a,$b], [$a,$b,$a], [$b,$a,$a] ];
  51     my $rgbmax = 125;   # tune these two for the outmost ranges of colour depth
  52     my $rgbmin = 240;
  53
  54     my $n = $i % (+$rgb);
  55     my $m = $rgbmin + ($rgbmax - $rgbmin) * ($ncolors - $i) / $ncolors;
  56
  57     my @c = 0 .. 2;
  58     @c   .= map: { $rgb[$n][$_] * $m };
  59     my $g = @c[0] * 0.3 + @c[1] * 0.59 + @c[2] * 0.11;
  60     my $f = $g > 127 ?? "#000000" !! "#ffffff";
  61     my $h = sprintf "#%02x%02x%02x", @c;
  62
  63     return [$f, $h];
  64   }
  65 }
  66
  67 # Stop if we weren't given a logfile to process.
  68 @*ARGS or die "Usage: $*PROGRAM_NAME logfile\n";
  69
  70 my $chat = Chat.new;
  71 my ($i, %nick2num) = (1);
  72
  73 # Pass I
  74 my $fh = open @*ARGS[0] orelse die "Couldn't open \"@*ARGS[0]\": $!\n";
  75 my $total = 0;
  76
  77 # We read the input file in and populate %nick2num.
  78 # %nick2num is a Hash with nicknames as keys and IDs, suitable for $chat.tick,
  79 # as values.
  80 for $fh.lines {
  81   my ($time, $nick, $type, $text) = parse_ilogger2($_) or next;
  82   $time ~~ rx:Perl5/^(\d\d):(\d\d)$/;
  83   my $utime = $0 * 60 + $1;
  84
  85   # We allocate a color only if $nick has said something (e.g. not, if he has
  86   # only joined, etc.).
  87   if $type eq "PRIVMSG"|"NOTICE" {
  88     %nick2num{$nick} //= $i++;
  89     $chat.tick(%nick2num{$nick}, $utime);
  90   }
  91
  92   # If $nick has changes its nick, his color should stay.
  93   my $nid = %nick2num{$nick};
  94   %nick2num{$text} = %nick2num{$nick} if $type eq "NICK";
  95   $total++;
  96 }
  97
  98 close $fh;
  99
 100 # Pass I
 101 $fh = open @*ARGS[0] orelse die "Couldn't open \"@*ARGS[0]\": $!\n";
 102
 103 # This is the main coderef which processes a logline and returns HTML.
 104 my $process = -> $time, $nick, $type, $text {
 105   my $htext;
 106
 107   given $type {
 108     # PRIVMSG is the standard type of messages.
 109     when "PRIVMSG" {
 110       # If it was a /ME, we format it differently.
 111       $htext = $text ~~ m:Perl5/^\x01(?:ACTION (.*))\x01$/
 112         ?? "$nick {qhtml $0}"
 113         !! qhtml $text;
 114     }
 115
 116     # Somebody set the topic.
 117     when "TOPIC" {
 118       $htext = "TOPIC: {qhtml $text}";
 119     }
 120
 121     # It's some other event (JOIN, PART, etc.).
 122     default {
 123       $htext = chars $text ?? "$type: {qhtml $text}" !! $type;
 124     }
 125   }
 126
 127   # These are the colors of the nick.
 128   # If we don't have a ID for $nick, $nick has never said anything, so we
 129   # default to foreground #000 and background #fff.
 130   my @nickc = %nick2num{$nick} ?? $chat.color[%nick2num{$nick}] !! ("#000", "#fff");
 131
 132   # Now we give our variables to the template.
 133   tmpl_logline(
 134     # Global foreground/background color
 135     globfg => "black",
 136     globbg =>
 137       $type eq "PRIVMSG"
 138         ?? $text ~~ rx:Perl5/^\x01(?:ACTION)/ ?? "#eaeaea" !! "#f5f5f5"
 139         !! "#dddddd",
 140
 141     # Nick foreground/background color
 142     nickfg => @nickc[0],
 143     nickbg => @nickc[1],
 144
 145     # Nick, time, type of the event
 146     nick   => $nick,
 147     time   => $time,
 148     type   => $type,
 149
 150     # Text
 151     text   => $htext,
 152
 153     # Sigil: One of "<" (user has left), ">", (user has joined"), " " (normal
 154     # message), or "*" (/ME)
 155     sigil  =>
 156       $type eq "QUIT"    ?? qhtml "<" !!
 157       $type eq "PART"    ?? qhtml "<" !!
 158       $type eq "JOIN"    ?? qhtml ">" !!
 159       $type eq "PRIVMSG"
 160         ?? ($text ~~ rx:Perl5/^\x01(?:ACTION)/ ?? qhtml "*" !! "")
 161         !! qhtml "*",
 162   );
 163 };
 164
 165 # First, we output the header.
 166 print tmpl_header("Log of «@*ARGS[0]»");
 167 print tmpl_logstart();
 168
 169 # Then we iterate over $fh and process each logline.
 170 for $fh.lines {
 171   my ($time, $nick, $type, $text) = parse_ilogger2($_) or next;
 172
 173   print
 174     $process(time => $time, type => $type, nick => $nick, text => $text);
 175 }
 176
 177 # Finally, we output the footer.
 178 print tmpl_logend();
 179 print tmpl_end();
 180
 181 # This is the sub which expects a logline in ilogger2 format and returns
 182 # ($time, $type, $nick, $text).
 183 sub parse_ilogger2(Str $line is copy) {
 184   $line ~~ rx:Perl5/^\[(\d\d:\d\d)\] (.*)$/ or
 185     die "Couldn't parse line »{$line}«!";
 186   my ($time, $rest) = @$/;
 187   # We want to see if we progress.
 188   $*ERR.say($rest);
 189
 190   given $rest {
 191     when rx:Perl5/^\*\*\* ([^ ]+) has joined ([^ ]+)/ {
 192       return ($time, $0, "JOIN", $1);
 193     }
 194
 195     when rx:Perl5/^\*\*\* ([^ ]+) has left/ {
 196       return ($time, $0, "PART");
 197     }
 198
 199     when rx:Perl5/^\*\*\* ([^ ]+) has quit IRC \((.*)\)/ {
 200       return ($time, $0, "QUIT", $1);
 201     }
 202
 203     when rx:Perl5/^\*\*\* ([^ ]+) is now known as ([^ ]+)/ {
 204       return ($time, $0, "NICK", $1);
 205     }
 206
 207     when rx:Perl5/^<([^>]+)> (.*)/ {
 208       return ($time, $0, "PRIVMSG", $1);
 209     }
 210
 211     when rx:Perl5/^\* <([^>]+)> (.*)/ {
 212       # We reformat /MEs as CTCP ACTIONs.
 213       return ($time, $0, "PRIVMSG", "\x01(?:ACTION $1)\x01");
 214     }
 215   }
 216
 217   return;
 218 }
 219
 220 # Quote HTML
 221 # E.g. "a<b" → "a&lt;b"
 222 sub qhtml (Str $str is copy) returns Str {
 223   $str ~~ s:Perl5:g/([&<>"'-])/{ #"#--vim
 224     $0 eq "&" ?? "&amp;"  !!
 225     $0 eq "<" ?? "&lt;"   !!
 226     $0 eq ">" ?? "&gt;"   !!
 227     $0 eq '"' ?? "&quot;" !!
 228     $0 eq "'" ?? "&#39;"  !!
 229     $0 eq "-" ?? "&#45;"  !! die
 230   }/;
 231   $str;
 232 }
 233
 234 # Here-docs not yet implemented, so we have to use multi-line literals...
 235 sub tmpl_header($title) {"
 236 <?xml version=\"1.0\" encoding=\"utf-8\"?>
 237 <!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.1//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml11.dtd\">
 238 <html xmlns=\"http://www.w3.org/1999/xhtml\" xml:lang=\"de\">
 239 <head>
 240 <title>{qhtml $title}</title>
 241 <meta http-equiv=\"Content-Type\" content=\"text/html; charset=utf-8\" />
 242 <style>{'
 243   body { font-family: Sans; background-color: white; color: black; margin: 0; }
 244
 245   h1 { background-color: #41347B; color: #52fe3b; font-family: monospace; margin: 0; text-align: center; font-size: 200%; }
 246   h2 { background-color: #41347B; color: #52fe3b; font-family: monospace; margin: 0; text-align: center; font-size: 120%; }
 247   h3 { font-size: 150%; margin: 0; }
 248   h4 { font-size: 080%; margin: 0; }
 249
 250   a                { text-decoration: none; }
 251   a:hover          { text-decoration: underline; }
 252   h2 a             { color: #00dd00; }
 253   h2 a:hover       { color: #00ff00; }
 254   .sidebar a       { color: #00dd00; }
 255   .sidebar a:hover { color: #00ff00; }
 256   .footer a        { color: #00dd00; }
 257   .footer a:hover  { color: #00ff00; }
 258   .text a          { color: #0000dd; }
 259   .text a:hover    { color: #0000ff; }
 260
 261   .sidebar { display: none; position: absolute; right: 0; left: 85%; background-color: #41347B; color: white; }
 262   .text { padding: 10px; }
 263
 264   .abstract { background-color: #7B59DE; border: 1px solid black; color: white; padding: 3px; }
 265   pre       { background-color: #DEDEFF; border: 1px solid black; color: black; padding: 3px; font-family: monospace; }
 266   .footer   { background-color: #41347B; margin: 0; padding: 3px; color: white; font-size: 80%; }
 267
 268   ul.nav { list-style-type: none; margin: 0; padding: 0; }
 269
 270   th, td { vertical-align: top; }
 271   div.msg { overflow: auto; }
 272
 273   a.link_0, a.link_0:hover { color: gray; }
 274 '}</style>
 275 <link rel=\"stylesheet\" href=\"/style.css\" />
 276 <script type=\"text/javascript\" src=\"/info.js\"></script>
 277 </head>
 278 <body>
 279
 280 <h1>IRC Log</h1>
 281 <h2>generated by Pugs</h2>
 282
 283 <div class=\"text\">
 284   <h3>{qhtml $title}</h3>
 285 "}
 286
 287 sub tmpl_logstart() {'
 288   <table style="width: 100%;">
 289     <tr>
 290       <th>From/To</th>
 291       <th>@</th>
 292       <th>&nbsp;</th>
 293       <th style="width: 80%;">Text</th>
 294     </tr>
 295 '}
 296
 297 sub tmpl_logend() {'
 298   </table>
 299 '}
 300
 301 sub tmpl_logline(
 302   Str $globfg, Str $globbg,
 303   Str $nickbg, Str $nickfg,
 304   Str $time,
 305   Str $type,
 306   Str $sigil,
 307   Str $text,
 308   Str $nick,
 309 ) {"
 310     <tr style=\"color: $globfg; background-color: $globbg\">
 311       <td style=\"background-color: $nickbg; color: $nickfg; text-align: center;\">
 312         {qhtml $nick}
 313       </td>
 314       <td>{$time}</td>
 315       <td title=\"$type\">{$sigil}</td>
 316       <td>{$text}</td>
 317     </tr>
 318 "}
 319
 320 sub tmpl_end {'
 321 </div>
 322
 323 <div class="footer">
 324   Valid <a href="http://validator.w3.org/check/referer">XHTML 1.1</a>.<br />
 325   Created using <a href="http://www.pugscode.org/">Pugs</a>, a <a
 326   href="http://dev.perl.org/perl6/">Perl 6</a> compiler.
 327 </div>
 328
 329 </body>
 330 </html>
 331 '}