#!perl

use strict;

use Benchmark qw(cmpthese);

my $str = "17:43:33:21:23:19:27:6";

my $setup_codehash = {
    origCode => sub {
        my @ary;
        my %hash = split /:/, $str;
        foreach my $k ( keys %hash ) {
            push( @ary, map { $hash{$k} } ( 1 .. $k ) );
        }
        \@ary;
    },

    ccn => sub {
        my %hash = split /:/, $str;
        \%hash,
    },

    "L~R" => sub {
        my $lookup;
        my %hash = reverse split /:/, $str;
        while ( my ( $key, $val ) = each %hash ) {
            $lookup .= pack( "C*", ($key) x $val );
        }
        $lookup;
    },

    duff => sub {
        my @ary;
        my @a = split /:/, $str;
        @a % 2 && die;    # not an even number of items
        while ( my ( $p, $ad ) = splice @a, 0, 2 ) {
            push @ary, ($ad) x $p;
        }
        \@ary;
    },
};

my $codehash = {
    origCode => sub {
        my $adId = $_[0]->[ int( rand(100) ) ];
    },

    ccn => sub {
        my $adno;

        my $rand = rand 100;

        my $sum = 0;
        for ( keys %{$_[0]} ) {    # there is no need of sorted keys
            $adno = $_[0]->{$_};
            last if ( $sum += $_ ) > $rand;
        }
        $adno;
    },

    "L~R" => sub {
        my $addid = unpack( "C", substr( $_[0], rand 100, 1 ) );
    },

    duff => sub {
        my $adId = $_[0]->[ int( rand(100) ) ];
    },

    fizbin => sub {
        my @a = split /:/, $str;
        my $r = int( rand(100) );
        my ( $adId, $p );
        while ( ( $p, $adId ) = splice @a, 0, 2 ) {
            if ( $r < $p ) { last; }
            $r -= $p;
        }
        $adId;
    },

    ccn_fast => sub {
        my $rand = rand 100;
        my $mystr = $str; # this line is needed for repetitive test on
+ly
        1 while $mystr =~ /([^:]+):([^:]+):?/g and (($rand -= $1) > 0)
+;
        $2;
    },

    ccn_faster => sub {
        my $rand = rand 100;
        pos($str)=0; # this line is needed for repetitive test only
        1 while $str =~ /([^:]+):([^:]+):?/g and (($rand -= $1) > 0);
        $2;
    },
};

sub phash (%) {
    my %h = @_;
    return "{"
      . join( ", ",
        map { sprintf( '%s => %3.3f', $_, $h{$_} ); }
          sort { $a <=> $b } keys(%h) )
      . "}";
}


sub make_cgistyle_routine ($) {
    my $subname = shift;
    if ($setup_codehash->{$subname}) {
        return sub {$codehash->{$subname}->($setup_codehash->{$subname
+}->());};
    }
    else
    {
        return sub {$codehash->{$subname}->();};
    }
}

sub make_mpstyle_routine ($) {
    my $subname = shift;
    if ($setup_codehash->{$subname}) {
        my @setupvals = $setup_codehash->{$subname}->();
        return sub {$codehash->{$subname}->(@setupvals);};
    }
    else
    {
        return sub {$codehash->{$subname}->();};
    }
}


print "==== Correctness tests ==== \n\n";
my %strhash = reverse split( /:/, $str );

print "Probabilities are: ", phash(%strhash), "\n";

foreach my $subname ( keys %$codehash ) {
    my %resultshash = map { $_ => 0 } keys %strhash;
    my $routine = make_mpstyle_routine($subname);
    do { $resultshash{ $routine->() } += 0.001; }
      for ( 1 .. 100000 );

    print "$subname yielded ", phash(%resultshash), "\n";
    do {
        print "$subname failed\n" and last
          if ( abs( $resultshash{$_} - $strhash{$_} ) > 0.3 );
      }
      for keys(%strhash);
}

print "\n==== Speed tests ====\n";

print "\nAs cgi: (from scratch each time):\n";

cmpthese( -5,
    {map {$_ => make_cgistyle_routine($_)} keys %$codehash });

print "\nAs mod_perl: (NOT from scratch each time):\n";

cmpthese( -5,
    {map {$_ => make_mpstyle_routine($_)  } keys %$codehash });
[download]