=head1 NAME

Cache::Tester - test utility for Cache implementations

=head1 SYNOPSIS

  use Cache::Tester;

  BEGIN { plan tests => 2 + $CACHE_TESTS }

  use_ok('Cache::Memory');

  my $cache = Cache::Memory->new();
  ok($cache, 'Cache created');

  run_cache_tests($cache);

=head1 DESCRIPTION

This module is used to run tests against an instance of a Cache implementation
to ensure that it operates as required by the Cache specification.

=cut
package Cache::Tester;

require 5.005;
use strict;
use warnings;
use Test::More;
use Exporter;
use vars qw(@ISA @EXPORT $VERSION $CACHE_TESTS);
use Carp;

@ISA = qw(Exporter Test::More);
$VERSION = "2.00";
@EXPORT = (qw(run_cache_tests $CACHE_TESTS), @Test::More::EXPORT);

$CACHE_TESTS = 75;

sub run_cache_tests {
    my ($cache) = @_;

    $cache or croak "Cache required";

    test_store_scalar($cache);
    test_entry_size($cache);
    test_store_complex($cache);
    test_cache_size($cache);
    test_cache_count($cache);
    test_expiry($cache);
    test_read_handle($cache);
    test_write_handle($cache);
    test_append_handle($cache);
    test_handle_async_read($cache);
    test_handle_async_remove($cache);
    test_handle_async_replace($cache);
    test_validity($cache);
    test_load_callback($cache);
    test_validate_callback($cache);
}

# Test storing, retrieving and removing simple scalars
sub test_store_scalar {
    my ($cache) = @_;

    my $key = 'testkey';
    my $entry = $cache->entry($key);
    _ok($entry, 'entry returned');
    _is($entry->key(), $key, 'entry key correct');
    _ok(!$entry->exists(), 'entry doesn\'t exist initially');
    _is($entry->get(), undef, '$entry->get() returns undef');

    $entry->set('test data');
    _ok($entry->exists(), 'entry exists');
    _is($entry->get(), 'test data', 'set/get worked');

    $entry->remove();
    _ok(!$entry->exists(), 'entry removed');

    $cache->set($key, 'more test data');
    _ok($cache->exists($key), 'key exists');
    _is($cache->get($key), 'more test data', 'cache set/get worked');

    $cache->remove($key);
    _ok(!$entry->exists(), 'entry removed via cache');
}

# Test size reporting of entries
sub test_entry_size {
    my ($cache) = @_;

    my $entry = $cache->entry('testsize');
    $entry->set('A'x1234);
    _ok($entry->exists(), 'entry created');
    _is($entry->size(), 1234, 'entry size is correct');

    $entry->remove();
}

# Test storing of complex entities
sub test_store_complex {
    my ($cache) = @_;

    my @array = (1, 2, { hi => 'there' });

    my $entry = $cache->entry('testcomplex');
    $entry->freeze(\@array);
    _ok($entry->exists(), 'frozen entry created');
    my $arrayref = $entry->thaw();
    _ok($array[0] == $$arrayref[0] &&
        $array[1] == $$arrayref[1] &&
        $array[2]->{hi} eq $$arrayref[2]->{hi}, 'entry thawed');

    $entry->remove();
}

# Test size tracking of cache
sub test_cache_size {
    my ($cache) = @_;

    $cache->clear();
    _is($cache->size(), 0, 'cache is empty after clear');
    $cache->set('testkey', 'A'x4000);
    _is($cache->size(), 4000, 'cache size is correct after set');
    $cache->set('testkey2', 'B'x200);
    _is($cache->size(), 4200, 'cache size is correct after 2 sets');
    $cache->set('testkey', 'C'x2800);
    _is($cache->size(), 3000, 'cache size is correct after replace');
    $cache->remove('testkey2');
    _is($cache->size(), 2800, 'cache size is correct after remove');

    $cache->clear();
    _is($cache->size(), 0, 'cache is empty after clear');

    # Add 100 entries of various lengths
    my $size = 0;
    my @keys = (1..100);
    foreach (@keys) {
        $cache->set("key$_", "D"x$_);
        $size += $_;
    }
    _is($cache->size(), $size, 'cache size is ok after multiple sets');

    shuffle(\@keys);
    foreach (@keys) {
        $cache->remove("key$_");
    }
    _is($cache->size(), 0, 'cache is empty after multiple removes');
}

# Test count tracking of cache
sub test_cache_count {
    my ($cache) = @_;

    $cache->clear();
    _is($cache->count(), 0, 'cache is empty after clear');
    $cache->set('testkey', 'test');
    _is($cache->count(), 1, 'cache count correct after set');
    $cache->set('testkey2', 'test2');
    _is($cache->count(), 2, 'cache count correct after 2 sets');
    $cache->set('testkey', 'test3');
    _is($cache->count(), 2, 'cache count correct after replace');
    $cache->remove('testkey2');
    _is($cache->count(), 1, 'cache count correct after remove');

    $cache->clear();
    _is($cache->count(), 0, 'cache is empty after clear');

    # Add 100 entries
    my @keys = (1..100);
    foreach (@keys) {
        $cache->set("key$_", "test");
    }
    _is($cache->count(), 100, 'cache count correct after multiple sets');
    
    shuffle(\@keys);
    foreach(@keys) {
        $cache->remove("key$_");
    }
    _is($cache->size(), 0, 'cache empty after multiple removes');
}

# Test expiry
sub test_expiry {
    my ($cache) = @_;

    my $entry = $cache->entry('testexp');

    $entry->set('test data');
    $entry->set_expiry('100 minutes');
    _cmp_ok($entry->expiry(), '>', time(), 'expiry set correctly');
    _cmp_ok($entry->expiry(), '<=', time() + 100*60, 'expiry set correctly');
    $entry->remove();

    my $size = $cache->size();

    $entry->set('test data', 'now');
    _ok(!$entry->exists(), 'entry set with instant expiry not added');
    _is($cache->size(), $size, 'size is unchanged');

    $entry->set('test data', '1 sec');
    _ok($entry->exists(), 'entry with 1 sec timeout added');
    sleep(2);
    _ok(!$entry->exists, 'entry expired');
    _is($cache->size(), $size, 'size is unchanged');
}

# Test reading via a handle
sub test_read_handle {
    my ($cache) = @_;

    my $entry = $cache->entry('readhandle');
    $entry->remove();
    my $handle = $entry->handle('<');
    _ok(!$handle, 'read handle not available for empty entry');

    $entry->set('some test data');

    $handle = $entry->handle('<');
    _ok($handle, 'read handle created');
    $handle or diag("handle not created: $!");

    local $/;
    _is(<$handle>, 'some test data', 'read via <$handle> successful');

    {
        no warnings;
        print $handle 'this wont work';
    }
    $handle->close();
    _is($entry->get(), 'some test data', 'write to read only handle failed');

    $entry->remove();
}

# Test writing via a handle
sub test_write_handle {
    my ($cache) = @_;

    my $entry = $cache->entry('writehandle');
    $entry->remove();

    my $size = $cache->size();

    my $handle = $entry->handle('>');
    _ok($handle, 'write handle created');
    $handle or diag("handle not created: $!");

    print $handle 'A'x100;
    $handle->close();

    _is($entry->get(), 'A'x100, 'write to write only handle ok');
    _is($entry->size(), 100, 'entry size is correct');
    _is($cache->size(), $size + 100, 'cache size is correct');

    $entry->remove();
}

# Test append via a handle
sub test_append_handle {
    my ($cache) = @_;

    my $entry = $cache->entry('appendhandle');
    $entry->remove();
    $entry->set('hello ');

    my $size = $cache->size();

    my $handle = $entry->handle('>>');
    _ok($handle, 'append handle created');
    $handle or diag("handle not created: $!");

    $handle->print('world');
    $handle->close();

    _is($entry->get(), 'hello world', 'write to append handle ok');
    _is($entry->size(), 11, 'entry size is correct');
    _is($entry->size(), $size + 5, 'cache size is correct');

    $entry->remove();
}

# Test that a entry can be read while a handle is open for read
sub test_handle_async_read {
    my ($cache) = @_;

    my $entry = $cache->entry('readhandle');
    $entry->remove();

    my $size = $cache->size();

    my $data = 'test data';
    $entry->set($data);

    my $handle = $entry->handle('<') or diag("handle not created: $!");

    _ok($entry->exists(), 'entry exists after handle opened');
    _is(<$handle>, $data, 'handle returns correct data');
    _is($entry->get(), $data, '$entry->get() returns correct data');
    $handle->close();
    _ok($entry->exists(), 'entry exists after handle closed');
    _is($entry->get(), $data, '$entry->get() returns correct data');
}

# Test that a handle can be removed asynchronously with it being open
sub test_handle_async_remove {
    my ($cache) = @_;

    my $entry = $cache->entry('removehandle');
    $entry->remove();

    my $size = $cache->size();

    $entry->set('test data');

    my $handle = $entry->handle() or diag("handle not created: $!");

    # extend data by 5 bytes before removing the entry
    $handle->print('some more data');
    $handle->seek(0,0);

    $entry->remove();
    _ok(!$entry->exists(), 'entry removed whilst handle active');

    local $/;
    _is(<$handle>, 'some more data', 'read via <$handle> successful');

    # ensure we can still write to the handle
    $handle->seek(0,0);
    $handle->print('hello wide wide world');
    $handle->seek(0,0);
    _is(<$handle>, 'hello wide wide world', 'write via <$handle> successful');

    $handle->close();
    _ok(!$entry->exists(), 'entry still removed after handle closed');
    _is($entry->size(), undef, 'entry size is undefined');
    _is($cache->size(), $size, 'cache size is correct');
}

sub test_handle_async_replace {
    my ($cache) = @_;

    my $entry = $cache->entry('replacehandle');
    $entry->remove();

    my $size = $cache->size();

    $entry->set('test data');

    my $handle = $entry->handle();

    $entry->set('A'x20);
    _is($entry->get(), 'A'x20, 'entry replaced whilst handle active');

    local $/;
    _is(<$handle>, 'test data', 'read via <$handle> successful');
    $handle->seek(0,0);
    $handle->print('hello world');
    $handle->seek(0,0);
    _is(<$handle>, 'hello world', 'write via <$handle> successful');

    $handle->close();
    _ok($entry->exists(), 'entry still exists after handle closed');
    _is($entry->get(), 'A'x20, 'entry still correct after handle closed');
    _is($entry->size(), 20, 'entry size is correct');
    _is($cache->size(), $size+20, 'cache size is correct');
}

sub test_validity {
    my ($cache) = @_;

    my $entry = $cache->entry('validityentry');
    $entry->remove();

    # create an entry with validity
    $entry->set('test data');
    $entry->set_validity({ tester => 'test string' });

    undef $entry;
    $entry = $cache->entry('validityentry');
    my $validity = $entry->validity();
    _ok($validity, 'validity retrieved');
    _is($validity->{tester}, 'test string', 'validity correct');

    $entry->remove();

    # create an entry with only validity
    $entry->set_validity({ tester => 'test string' });

    undef $entry;
    $entry = $cache->entry('validityentry');
    $validity = $entry->validity();
    _ok($validity, 'validity retrieved');
    _is($validity->{tester}, 'test string', 'validity correct');

    $entry->remove();

    # create an entry with scalar validity
    $entry->set('test data');
    $entry->set_validity('test string');

    undef $entry;
    $entry = $cache->entry('validityentry');
    $validity = $entry->validity();
    _ok($validity, 'validity retrieved');
    _is($validity, 'test string', 'validity correct');
}

sub test_load_callback {
    my ($cache) = @_;

    my $key = 'testloadcallback';
    $cache->remove($key);

    my $old_callback = $cache->load_callback();
    $cache->set_load_callback(sub { return "result ".$_[0]->key() });

    _ok($cache->get($key), "result $key");
    $cache->set_load_callback($old_callback);
}

sub test_validate_callback {
    my ($cache) = @_;

    my $key = 'testvalidatecallback';
    my $result;
    my $old_callback = $cache->validate_callback();
    $cache->set_validate_callback(sub { $result = "result ".$_[0]->key() });

    $cache->set($key, 'somedata');
    $cache->get($key);
    # The caller func in _is doesn't work for some strange reason....
    is($result, "result $key");
    $cache->set_validate_callback($old_callback);
}


### Wrappers for test methods to add function name

sub _ok ($$) {
    my($test, $name) = @_;
    ok($test, (caller(1))[3].': '.$name);
}

sub _is ($$$) {
    my($x, $y, $name) = @_;
    is($x, $y, (caller(1))[3].': '.$name);
}

sub _isnt ($$$) {
    my($x, $y, $name) = @_;
    isnt($x, $y, (caller(1))[3].': '.$name);
}

sub _like ($$$) {
    my($x, $y, $name) = @_;
    like($x, $y, (caller(1))[3].': '.$name);
}

sub _unlike ($$$) {
    my($x, $y, $name) = @_;
    unlike($x, $y, (caller(1))[3].': '.$name);
}

sub _cmp_ok ($$$$) {
    my ($x, $c, $y, $name) = @_;
    cmp_ok($x, $c, $y, (caller(1))[3].': '.$name);
}


# Taken from perlfaq4
sub shuffle {
    my $deck = shift;  # $deck is a reference to an array
    my $i = @$deck;
    while ($i--) {
        my $j = int rand ($i+1);
        @$deck[$i,$j] = @$deck[$j,$i];
    }
}


1;
__END__

=head1 SEE ALSO

Cache

=head1 AUTHOR

 Chris Leishman <chris@leishman.org>
 Based on work by DeWitt Clinton <dewitt@unto.net>

=head1 COPYRIGHT

 Copyright (C) 2003 Chris Leishman.  All Rights Reserved.

This module is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY KIND,
either expressed or implied. This program is free software; you can
redistribute or modify it under the same terms as Perl itself.

$Id: Tester.pm,v 1.3 2003/08/14 13:49:57 caleishm Exp $

=cut