# This is a simple IRC log to HTML converter. # It accepts only logfiles in ilogger2 format, such as those provided by # http://colabti.de/irclogger/irclogger_logs/perl6 (click on "raw text"). use v6-alpha; # This is our class which calculates the colors of the nicks. class Chat { # 16 different colors should suffice. my $POOL_SIZE = 16; has @.pool; has @.color; # $id is the person id, $time is some kind of time, which is, in this class, # not necessary. But I plan to add a subclass, which does evaluate $time. method tick(Int $id, Int $time) { # As we don't have submethod BUILD support yet, we have to initialize # @.pool now. @.color //= precalc_colors($POOL_SIZE); # If we haven't allocated a color for $id... unless defined @.color[$id] { # Take one from the pool (pop), assign in to $id, and unshift it. @.pool.unshift(@.color[$id] = @.pool.pop); } } # Precalculate the pool. sub precalc_colors(Int $num) { my @colors = 0..$num-1; @colors .= map:{ [calc_color($^i, $num)] }; return @colors; } # calc_color copied from irclog2html.pl # (http://freshmeat.net/projects/irclog2html.pl/), Copyleft (C) 2000-2002 Jeff # Waugh, licensed under the Terms of the GNU General Public License, version 2 # or higher. # calc_color expects the total number of colors to assign ($_[2]) and the color # id ($_[1]) and returns a HTML-("#foreground", "#background")-pair with nice # contrast etc. # Take calc_color as a sub w/o errors. sub calc_color(Int $i, Int $ncolors is copy) { $ncolors = 1 if $ncolors == 0; # No division /0. my $a = 0.95; # tune these for the starting and ending concentrations of R,G,B my $b = 0.5; my $rgb = [ [$a,$b,$b], [$b,$a,$b], [$b,$b,$a], [$a,$a,$b], [$a,$b,$a], [$b,$a,$a] ]; my $rgbmax = 125; # tune these two for the outmost ranges of colour depth my $rgbmin = 240; my $n = $i % (+$rgb); my $m = $rgbmin + ($rgbmax - $rgbmin) * ($ncolors - $i) / $ncolors; my @c = 0 .. 2; @c .= map:{ $rgb[$n][$_] * $m }; my $g = @c[0] * 0.3 + @c[1] * 0.59 + @c[2] * 0.11; my $f = $g > 127 ?? "#000000" !! "#ffffff"; my $h = sprintf "#%02x%02x%02x", @c; return [$f, $h]; } } # Stop if we weren't given a logfile to process. @*ARGS or die "Usage: $*PROGRAM_NAME logfile\n"; my $chat = Chat.new; my ($i, %nick2num) = (1); # Pass I my $fh = open @*ARGS[0] err die "Couldn't open \"@*ARGS[0]\": $!\n"; my $total = 0; # We read the input file in and populate %nick2num. # %nick2num is a Hash with nicknames as keys and IDs, suitable for $chat.tick, # as values. for =$fh -> { my ($time, $nick, $type, $text) = parse_ilogger2($_) or next; $time ~~ rx:Perl5/^(\d\d):(\d\d)$/; my $utime = $0 * 60 + $1; # We allocate a color only if $nick has said something (e.g. not, if he has # only joined, etc.). if $type eq "PRIVMSG"|"NOTICE" { %nick2num{$nick} //= $i++; $chat.tick(%nick2num{$nick}, $utime); } # If $nick has changes its nick, his color should stay. my $nid = %nick2num{$nick}; %nick2num{$text} = %nick2num{$nick} if $type eq "NICK"; $total++; } close $fh; # Pass I $fh = open @*ARGS[0] err die "Couldn't open \"@*ARGS[0]\": $!\n"; # This is the main coderef which processes a logline and returns HTML. my $process = -> $time, $nick, $type, $text { my $htext; given $type { # PRIVMSG is the standard type of messages. when "PRIVMSG" { # If it was a /ME, we format it differently. $htext = $text ~~ m:Perl5/^\x01(?:ACTION (.*))\x01$/ ?? "$nick {qhtml $0}" !! qhtml $text; } # Somebody set the topic. when "TOPIC" { $htext = "TOPIC: {qhtml $text}"; } # It's some other event (JOIN, PART, etc.). default { $htext = chars $text ?? "$type: {qhtml $text}" !! $type; } } # These are the colors of the nick. # If we don't have a ID for $nick, $nick has never said anything, so we # default to foreground #000 and background #fff. my @nickc = %nick2num{$nick} ?? $chat.color[%nick2num{$nick}] !! ("#000", "#fff"); # Now we give our variables to the template. tmpl_logline( # Global foreground/background color globfg => "black", globbg => $type eq "PRIVMSG" ?? $text ~~ rx:Perl5/^\x01(?:ACTION)/ ?? "#eaeaea" !! "#f5f5f5" !! "#dddddd", # Nick foreground/background color nickfg => @nickc[0], nickbg => @nickc[1], # Nick, time, type of the event nick => $nick, time => $time, type => $type, # Text text => $htext, # Sigil: One of "<" (user has left), ">", (user has joined"), " " (normal # message), or "*" (/ME) sigil => $type eq "QUIT" ?? qhtml "<" !! $type eq "PART" ?? qhtml "<" !! $type eq "JOIN" ?? qhtml ">" !! $type eq "PRIVMSG" ?? ($text ~~ rx:Perl5/^\x01(?:ACTION)/ ?? qhtml "*" !! "") !! qhtml "*", ); }; # First, we output the header. print tmpl_header("Log of «@*ARGS[0]»"); print tmpl_logstart(); # Then we iterate over $fh and process each logline. for =$fh { my ($time, $nick, $type, $text) = parse_ilogger2($_) or next; print $process(time => $time, type => $type, nick => $nick, text => $text); } # Finally, we output the footer. print tmpl_logend(); print tmpl_end(); # This is the sub which expects a logline in ilogger2 format and returns # ($time, $type, $nick, $text). sub parse_ilogger2(Str $line is copy) { $line ~~ rx:Perl5/^\[(\d\d:\d\d)\] (.*)$/ or die "Couldn't parse line »$line«!"; my ($time, $rest) = @$/; # We want to see if we progress. $*ERR.say($rest); given $rest { when rx:Perl5/^\*\*\* ([^ ]+) has joined ([^ ]+)/ { return ($time, $0, "JOIN", $1); } when rx:Perl5/^\*\*\* ([^ ]+) has left/ { return ($time, $0, "PART"); } when rx:Perl5/^\*\*\* ([^ ]+) has quit IRC \((.*)\)/ { return ($time, $0, "QUIT", $1); } when rx:Perl5/^\*\*\* ([^ ]+) is now known as ([^ ]+)/ { return ($time, $0, "NICK", $1); } when rx:Perl5/^<([^>]+)> (.*)/ { return ($time, $0, "PRIVMSG", $1); } when rx:Perl5/^\* <([^>]+)> (.*)/ { # We reformat /MEs as CTCP ACTIONs. return ($time, $0, "PRIVMSG", "\x01(?:ACTION $1)\x01"); } } return; } # Quote HTML # E.g. "a"'-])/{ #"#--vim $0 eq "&" ?? "&" !! $0 eq "<" ?? "<" !! $0 eq ">" ?? ">" !! $0 eq '"' ?? """ !! $0 eq "'" ?? "'" !! $0 eq "-" ?? "-" !! die }/; $str; } # Here-docs not yet implemented, so we have to use multi-line literals... sub tmpl_header($title) {" {qhtml $title}

IRC Log

generated by Pugs

{qhtml $title}

"} sub tmpl_logstart() {' '} sub tmpl_logend() {'
From/To @   Text
'} sub tmpl_logline( Str $globfg, Str $globbg, Str $nickbg, Str $nickfg, Str $time, Str $type, Str $sigil, Str $text, Str $nick, ) {" {qhtml $nick} {$time} {$sigil} {$text} "} sub tmpl_end {'
'}