Cache::Benchmark - Tests the quality and speed of a cache module to compare cachemodules and algorithms.

 use Cache::Benchmark();
 use Cache::MemoryCache();
 use Cache::SizeAwareMemoryCache();

 my $cache_1 = new Cache::MemoryCache({
 	namespace => 'my',
 	default_expires_in => 1,
 });
 my $cache_2 = new Cache::SizeAwareMemoryCache({
 	namespace => 'my',
 	default_expires_in => 1,
 	max_size => 400,
 });

 my $test = new Cache::Benchmark();
 $test->init( access_counter => 10_000 );

 $test->run($cache_1);
 print $test->get_printable_result();

 $test->run($cache_2);
 print $test->get_printable_result();

    perldoc Cache::Benchmark

package Cache::Benchmark;

use warnings;
use strict;

use Time::HiRes();
use Carp();

my $KEY = 0;
my $PROB = 1;
my $STANDARD_VALUES = {
	keys				=> 1_000,
	min_key_length		=> 30,
	access_counter		=> 100_000,
	value				=> ('x' x 500),
	test_type			=> 'weighted',
	sleep_time			=> 0,
	weighted_key_config	=> {
			1.5	=> 15,
			10	=> 10,
			35	=> 7,
			50	=> 5,
			65	=> 3,
			85	=> 2,
			99	=> 1,
		},
};

our $VERSION = '0.011';

sub new {
	my $package = $_[0];
	
	my $self = bless({}, ref($package) || $package);
	$self->{'_keylist_length'} = 0;
	$self->{'_access_counter'} = 0;
	$self->{'_cache_value'} = '';
	$self->{'_result'} = {};
	$self->{'_is_init'} = 0;
	$self->{'_test_type'} = '';
	$self->{'_key_length'} = 0;
	$self->{'_supported_types'} = [qw(plain random weighted)];
	$self->{'_weighted_key_config'} = {};
	$self->{'_accesslist'} = [];
	$self->{'_sleep_time'} = 0;
	return $self;
}

sub init {
	my $self = shift(@_);
	my %config = @_;
	
	$self->{'_is_init'} = 0;
	
	my $keylist_length = exists($config{'keys'}) ? int(delete($config{'keys'})) : $STANDARD_VALUES->{'keys'};
	my $key_length = exists($config{'min_key_length'}) ? int(delete($config{'min_key_length'})) : $STANDARD_VALUES->{'min_key_length'};
	my $access_counter = exists($config{'access_counter'}) ? int(delete($config{'access_counter'})) : $STANDARD_VALUES->{'access_counter'};
	my $cache_value = exists($config{'value'}) ? delete($config{'value'}) : $STANDARD_VALUES->{'value'};
	my $test_type = exists($config{'test_type'}) ? delete($config{'test_type'}) : $STANDARD_VALUES->{'test_type'};
	my $weighted_key_config = exists($config{'weighted_key_config'}) ? delete($config{'weighted_key_config'}) : $STANDARD_VALUES->{'weighted_key_config'};
	my $sleep_time = exists($config{'sleep_time'}) ? delete($config{'sleep_time'}) : $STANDARD_VALUES->{'sleep_time'};
	my $accesslist = exists($config{'accesslist'}) ? delete($config{'accesslist'}) : undef;
	
	foreach(keys %config) {
		Carp::carp("init-parameter '$_' is unknown!");
		return 0;
	}
	if($keylist_length < 10) {
		Carp::carp("keylist length has to be bigger than 9");
		return 0;
	}
	if($access_counter < 1) {
		Carp::carp("access_counter has to be bigger than 0");
		return 0;
	}
	if($access_counter <= $keylist_length) {
		Carp::carp("for usable results the access_counter ($access_counter) has to be MUCH bigger than the keylist length ($keylist_length)");
	}
	if(!defined($cache_value)) {
		Carp::carp("undefined cache-value is not allowed");
		return 0;
	}
	my $type_ok = 0;
	foreach my $type (@{$self->{'_supported_types'}}) {
		$type_ok = 1 if($test_type eq $type);
	}
	if(!$type_ok) {
		Carp::carp("test-type '$test_type' is not supported");
		return 0;
	}
	if(ref($weighted_key_config) ne 'HASH') {
		Carp::carp("weighted_key_config ($weighted_key_config) must be an hahsref");
	}
	if(defined($accesslist) && ref($accesslist) ne 'ARRAY') {
		Carp::carp("parameter 'accesslist' has to be an arrayref of INT");
		return 0;
	}
	if(defined($accesslist) && $#$accesslist == -1) {
		Carp::carp("the 'accesslist' has no content");
		return 0;
	}
	$self->{'_keylist_length'} = int($keylist_length);
	$self->{'_access_counter'} = int($access_counter);
	$self->{'_cache_value'} = $cache_value;
	$self->{'_test_type'} = $test_type;
	$self->{'_key_length'} = ($key_length > 0) ? int($key_length) : 0;
	$self->{'_weighted_key_config'} = $weighted_key_config;
	if(defined($accesslist)) {
		$self->{'_accesslist'} = $accesslist;
	} else {
		$self->{'_accesslist'} = $self->_create_accesslist($self->{'_test_type'}, $self->{'_keylist_length'}, $self->{'_key_length'}, $self->{'_access_counter'}, $self->{'_weighted_key_config'});
	}
	$self->{'_sleep_time'} = $sleep_time;

	$self->{'_is_init'} = 1;
	return 1;
}

sub run {
	my $self = $_[0];
	my $cache = $_[1];
	my $auto_purge = $_[2];
	
	if(!$self->{'_is_init'}) {
		Carp::carp('try to use uninitialised cache-test');
		return 0;
	}
	return 0 if(!$self->_check_cache_class($cache));
	$self->{'_result'} = $self->_run_benchmark($cache, $self->{'_accesslist'}, $self->{'_sleep_time'}, \$self->{'_cache_value'}, ($auto_purge ? 1 : 0), $self->{'_keylist_length'});
	return 1;
}

sub get_accesslist {
	my $self = $_[0];
	
	return [] if(!$self->{'_is_init'});
	return $self->{'_accesslist'};
}

sub get_raw_result {
	my $self = $_[0];
	if(!$self->{'_is_init'}) {
		Carp::carp('try to use uninitialised object');
		return {};
	}
	return $self->{'_result'};
}

sub get_printable_result {
	my $self = $_[0];
	
	if(!$self->{'_is_init'}) {
		Carp::carp('try to use uninitialised object');
		return '';
	}
	return <<HERE;
CONCLUSION FOR $self->{'_result'}->{'class'}:
--------------------------------------------------------------
Quality: $self->{'_result'}->{'quality'} (bigger is better)
Hint:    $self->{'_result'}->{'quality_extra'}
Runtime: $self->{'_result'}->{'runtime'} s

CONFIG:
-------
Accesses:       $self->{'_result'}->{'access_counter'}
Keylist length: $self->{'_result'}->{'keylist_length'}
Sleep time:	$self->{'_result'}->{'sleep_time'}s

SINGLE VALUES:
--------------
Cache-keys read:    $self->{'_result'}->{'reads'}
Cache-keys rewrite: $self->{'_result'}->{'rewrites'}
Cache-keys write:   $self->{'_result'}->{'writes'}
Cache purged:       $self->{'_result'}->{'purged'}

Get-time:   $self->{'_result'}->{'get_time'}
Set-time:   $self->{'_result'}->{'set_time'}
Purge-time: $self->{'_result'}->{'purge_time'}
Runtime:    $self->{'_result'}->{'runtime'}

HERE
}

# Protected: generates a random number from 0 to the given value 
# int
sub _generate_random_number {
	my $self = $_[0];
	my $max_val = $_[1];
	
	return sprintf("%.0f", rand(1) * $max_val);
}

# Protected: fill a given key with 'x' till the min-length is reached
# string
sub _fill_key {
	my $self = $_[0];
	my $key = $_[1];
	my $min_length = $_[2];
	
	my $fill_length = $min_length - length($key);
	return $key if($fill_length <= 0);
	return ('0' x $fill_length) . $key; 
}

# Protected: generate all cache-keys for the bell-curve
# array( array( int, int ))
sub _create_accesslist {
	my $self = $_[0];
	my $test_type = $_[1];
	my $keylist_length = $_[2];
	my $key_length = $_[3];
	my $access_counter = $_[4];
	my $weighted_config = $_[5];
	
	my $list = [];
	if($test_type eq 'plain') {
		my $plain_list = [ 0..($keylist_length - 1) ];
		my $i = 0;
		foreach(1..$access_counter) {
			$i = 0 if($i > $#$plain_list);
			push(@$list, $self->_fill_key($plain_list->[$i++], $key_length));
		}
	} elsif($test_type eq 'random') {
		foreach(1..$access_counter) {
			push(@$list, $self->_fill_key($self->_generate_random_number($keylist_length - 1), $key_length) );
		}
	} elsif($test_type eq 'weighted') {
		my @sorted_percents = sort({ $a <=> $b } keys(%$weighted_config));
		my $actual_step = shift(@sorted_percents);
		my $plain_keylist = [];
		foreach my $key ( 0..($keylist_length - 1) ) {
			my $weight = 1;
			if(defined($actual_step)) {
				my $percent = (($key + 1) / $keylist_length) * 100;
				$actual_step = shift(@sorted_percents) if($actual_step < $percent);
				$weight = int($weighted_config->{$actual_step}) if(defined($actual_step));
			}
			foreach(1..$weight) {
				push(@$plain_keylist, $self->_fill_key($key, $key_length));
			}
		}
		my $length = $#$plain_keylist;
		foreach(1..$access_counter) {
			push(@$list, $plain_keylist->[$self->_generate_random_number($length)]);
		}
	}
	return $list;
}

# Protected: check the object-interface of the given cache-object
# boolean
sub _check_cache_class {
	my $self = $_[0];
	my $cache = $_[1];
	
	foreach my $method (qw/set get purge/) {
		if(!UNIVERSAL::can($cache, $method)) {
			Carp::carp("You need to implement method $method in Class '" . ref($cache) . "'");
			return 0;
		}
	}
	return 1;
}

# Protected: run the benchmark test
# hashref
sub _run_benchmark {
	my $self = $_[0];
	my $cache = $_[1];
	my $access_list = $_[2];
	my $sleep_time = $_[3];
	my $cache_value = $_[4];
	my $auto_purge = $_[5];
	my $keylist_length = $_[6];

	my $cached_keys = {};
	my ($cached, $not_cached, $cache_deleted, $cache_purged) = (0, 0, 0, 0);
	my ($set_time, $get_time, $purge_time) = (0, 0, 0);
	foreach my $key (@$access_list) {
		if($sleep_time > 0) {
			Time::HiRes::nanosleep($sleep_time);
		}
		if($cached_keys->{$key}) {
			my $start_time = Time::HiRes::time();
			my $val = $cache->get($key);
			$get_time += Time::HiRes::time() - $start_time;
			if(defined($val)) {
				++$cached;
			} else {
				++$cache_deleted;
				my $start_time = Time::HiRes::time();
				$cache->set($key, $$cache_value);
				$set_time += Time::HiRes::time() - $start_time;
			}
		} else {
			++$not_cached;
			my $start_time = Time::HiRes::time();
			$cache->set($key, $$cache_value);
			$set_time += Time::HiRes::time() - $start_time;
		}
		$cached_keys->{$key} = 1;
		my $start_time = Time::HiRes::time();
		if($auto_purge) {
			++$cache_purged if($cache->purge());
			$purge_time += Time::HiRes::time() - $start_time;
		}
	}
	my $cache_written = $not_cached + $cache_deleted;
	my $quality = $cache_deleted ? sprintf("%0.4f", $cached / $cache_deleted) : 9_999_999_999_999;
	return {
		class			=> ref($cache),
		runtime			=> sprintf("%0.6f", $set_time + $get_time + $purge_time),
		set_time		=> sprintf("%0.6f", $set_time),
		get_time		=> sprintf("%0.6f", $get_time),
		purge_time		=> sprintf("%0.6f", $purge_time),
		keylist_length	=> $keylist_length,
		quality			=> $quality,
		quality_extra	=> ($cache_deleted ? '-' : 'no cachedata was cleared'),
		access_counter	=> scalar(@$access_list),
		reads			=> $cached,
		rewrites		=> $cache_deleted,
		writes			=> $not_cached,
		purged			=> $cache_purged,
		sleep_time		=> $sleep_time,

	};
}

1; # End of Cache::Benchmark