#!/usr/bin/env perl
#
# Copyright 2004 Jerome Quelin <jquelin@cpan.org>
# This program is distributed under the same terms as Parrot itself.
#

use strict;
use warnings;

use DBI;
use List::Util qw[ first ];
use RRDs;
use subs qw[ clean_rrds fetch_languages graphit process_data ];

##
## Configuration section.
##

my $db     = "./benchmark.db";
my $rrddir = "./rrds";
my $pngdir = "./png";
my $start  = time - 3600*24*30*2; # 2 months ago.
my $width  = 600;
my $height = 200;
$|++;  # no buffered output.


##
## Main program.
##

my $dbh = DBI->connect("dbi:SQLite2:dbname=$db","","");
my @languages = fetch_languages;
clean_rrds;
process_data;
graphit;
exit;


##
## Subs.
##

# Remove old rrd - I know it's not optimum, but quick &
# dirty. Moreover, I'm free of Joshua's implementation.
sub clean_rrds { unlink glob "$rrddir/*.rrd"; }

# Create the rrd of the tuple (language,test) if needed. This function
# can die if sthg unexpected happens.
sub create_rrd_if_needed {
    my $rrd = shift;

    # Standard rrd params.
    my $starttime = 1088672400;    # 2004/07/01
    my $heartbeat = 604800;        # one plot per week (3600*24*7)
    my $hb2       = 2*$heartbeat;

    # Data sources / arrays rrd params.
    my $ds  = "DS:val:GAUGE:$hb2:0:U";
    my $rra = "RRA:AVERAGE:0.5:1:520"; # keep all plots for 10 years (52*10)


    return if -f $rrd;
    RRDs::create
        ( $rrd,
          "--start=$starttime",
          "--step=$heartbeat",
          $ds, $rra
        );
    die RRDs::error if RRDs::error;
}

# Fetch languages list.
sub fetch_languages {
    my $sth = $dbh->prepare("SELECT name FROM sqlite_master");
    $sth->execute;
    my @lang;
    push @lang, $_ while $_ = $sth->fetchrow_array;
    return @lang;
}

# Draw graphs, one per test. Languages are aggregated.
sub graphit {
    print "-> Plotting graphs.\n";

    # Fetch test names.
    my %tests;
    @tests{ map { m!([^/]+)\+[^/]+$! } glob "$rrddir/*.rrd" } = ();

    # Fetch standard colors.
    my %data;
    while ( defined( my $line = <DATA> ) ) {
        chomp $line;
        my ($re,$color) = split /=/, $line;
        $data{$re} = $color;
    }

    # Compute random colors, for languages that do not have standard
    # color.
    my %color;
    foreach my $lang ( @languages ) {
        my $re = first { $lang =~ /$_/ } keys %data;
        $color{$lang} = defined $re ?
          $data{$re} : sprintf("%02x%02x%02x",
                               rand 255, rand 255, rand 255);
    }

    # 
    foreach my $t ( sort keys %tests ) {
        print "    $t\n";

        # Fetch rrds for this test - maybe not every language has ran
        # it.
        my @rrds = sort glob "$rrddir/$t+*.rrd";

        # Compute rrd graph params.
        my (@defs, @plots);
        foreach my $rrd ( @rrds ) {
            $rrd =~ m!^$rrddir/$t\+(.*)\.rrd$! or die "Uh?";
            my $lang = $1;
            push @defs, "DEF:$lang=$rrd:val:AVERAGE";
            my $type = scalar(@plots) ? "STACK" : "AREA";
            push @plots, "$type:$lang#$color{$lang}:$lang";
        }


        my $r = shift @rrds;
        #my @params = "AREA:;
        #DEF:vname=rrd:ds-name:CF

        RRDs::graph
            ( "$pngdir/$t.png",
              "--start=$start",
              "--width=$width",
              "--height=$height",
              "--imgformat=PNG",
              "--lower-limit=0",
              "--title=$t",
              @defs, @plots
            );
        die RRDs::error if RRDs::error;
    }
}

# Parse the whole database: Create on the fly new rrds, (one per
# language per test) and fill them.
#
# I know it's not optimum, but this way I'm ok even if:
#  - the language tests are not run with the same timestamp
#  - a test does not exist for a given language
#
# Note that I'm fetching the test names tahnx to DBI.
sub process_data {
    print "-> Processing database.\n";

    foreach my $lang (@languages) {
        print "    $lang:\n";

        # Fetch all data regarding a language.
        my $sth = $dbh->prepare("SELECT * FROM $lang ORDER BY time");
        $sth->execute;

        while ( my $row = $sth->fetchrow_hashref ) {
            # Get timestamp.
            my $timestamp = $row->{time};
            print "     - $timestamp: ";

            # Process all tests at a given timestamp.
            foreach my $t ( sort keys %$row ) {
                next if $t eq "time"; # time is not a test :-)
                print ".";

                my $rrd = "$rrddir/${t}+$lang.rrd";
                create_rrd_if_needed($rrd);
                my $value = $row->{$t} || "U";
                $value = "U" if $value =~ /[^\d.]/;
                #warn "[$timestamp:$value]\n";
                RRDs::update($rrd, "$timestamp:$value");
                die RRDs::error if RRDs::error;
            }
            print "\n";
        }
    }
}


__DATA__
parrot$=00ff00
perl.*th=0000ff
python=ffff00
ruby=ff0000
