[libcache-perl] 01/28: [svn-inject] Installing original source of libcache-perl
dom at earth.li
dom at earth.li
Sat Oct 4 17:27:41 UTC 2014
This is an automated email from the git hooks/post-receive script.
dom pushed a commit to branch master
in repository libcache-perl.
commit ad7f6dd3627df00409d86591b9a79174026fda55
Author: Dominic Hargreaves <dom at earth.li>
Date: Tue Oct 23 22:19:39 2007 +0000
[svn-inject] Installing original source of libcache-perl
---
Changes | 34 ++
LICENSE | 4 +
MANIFEST | 36 +++
MANIFEST.SKIP | 8 +
META.yml | 25 ++
Makefile.PL | 25 ++
README | 29 ++
TODO | 5 +
design.dia | Bin 0 -> 3776 bytes
lib/Cache.pm | 630 ++++++++++++++++++++++++++++++++++++
lib/Cache/Entry.pm | 361 +++++++++++++++++++++
lib/Cache/File.pm | 653 ++++++++++++++++++++++++++++++++++++++
lib/Cache/File/Entry.pm | 557 ++++++++++++++++++++++++++++++++
lib/Cache/File/Handle.pm | 80 +++++
lib/Cache/File/Heap.pm | 261 +++++++++++++++
lib/Cache/IOString.pm | 152 +++++++++
lib/Cache/Memory.pm | 372 ++++++++++++++++++++++
lib/Cache/Memory/Entry.pm | 288 +++++++++++++++++
lib/Cache/Memory/HeapElem.pm | 73 +++++
lib/Cache/Null.pm | 124 ++++++++
lib/Cache/Null/Entry.pm | 116 +++++++
lib/Cache/RemovalStrategy.pm | 62 ++++
lib/Cache/RemovalStrategy/FIFO.pm | 69 ++++
lib/Cache/RemovalStrategy/LRU.pm | 69 ++++
lib/Cache/Tester.pm | 511 +++++++++++++++++++++++++++++
t/00basic.t | 19 ++
t/01fileheap.t | 226 +++++++++++++
t/file.t | 48 +++
t/file_fifo.t | 81 +++++
t/file_lru.t | 77 +++++
t/file_tie.t | 47 +++
t/memory.t | 17 +
t/memory_fifo.t | 67 ++++
t/memory_lru.t | 64 ++++
t/memory_tie.t | 44 +++
t/null.t | 59 ++++
36 files changed, 5293 insertions(+)
diff --git a/Changes b/Changes
new file mode 100644
index 0000000..802cbb3
--- /dev/null
+++ b/Changes
@@ -0,0 +1,34 @@
+2006-02-01
+ - Bugfix release (2.04)
+ - Fix for failure to call load_callback when verify_callback
+ fails the result (credit to Chris Fletcher).
+
+2005-11-08
+ - Fix for set_expiry in Cache::Memory (credit to Sean M. Egan).
+
+2005-10-20
+ - Bugfix release (2.03)
+ - Fix for cache_umask: individual files were not created with correct
+ permissions (credit to Chris Huegle).
+
+2004-03-23
+ - Bugfix release (2.02)
+ - Update require to 5.006 since 'use warnings' depends on it
+ (credit to Adam Kennedy).
+ - Fixed a comparison issue with DB_File, where it can compare undef's.
+
+2003-12-15
+ - Fixed the Cache::freeze() shortcut method which wasn't passing
+ arguments to Cache::Entry::freeze() (credit to Ingo Blechschmidt).
+
+2003-08-18
+ - Bugfix release (2.01)
+ o Fixed parsing of all digit expiry times
+ o Fixed use of scalar validity in Cache::Memory
+ o Allowed validity to be set on non-existant entry
+ (sets entry data to zero length)
+ o Fixed package name for Cache::Memory::HeapElem
+ o Documentation fixes
+
+2003-07-07
+ - Initial release (2.00)
diff --git a/LICENSE b/LICENSE
new file mode 100644
index 0000000..2077b3a
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,4 @@
+Cache is dual licensed under the same terms as Perl itself.
+
+This means at your choice, either the Perl Artistic License, or
+the GNU GPL version 1 or higher.
diff --git a/MANIFEST b/MANIFEST
new file mode 100644
index 0000000..4f22ce0
--- /dev/null
+++ b/MANIFEST
@@ -0,0 +1,36 @@
+Changes
+LICENSE
+MANIFEST
+MANIFEST.SKIP
+Makefile.PL
+README
+TODO
+design.dia
+lib/Cache.pm
+lib/Cache/Entry.pm
+lib/Cache/File.pm
+lib/Cache/File/Entry.pm
+lib/Cache/File/Handle.pm
+lib/Cache/File/Heap.pm
+lib/Cache/IOString.pm
+lib/Cache/Memory.pm
+lib/Cache/Memory/Entry.pm
+lib/Cache/Memory/HeapElem.pm
+lib/Cache/Null.pm
+lib/Cache/Null/Entry.pm
+lib/Cache/RemovalStrategy.pm
+lib/Cache/RemovalStrategy/FIFO.pm
+lib/Cache/RemovalStrategy/LRU.pm
+lib/Cache/Tester.pm
+t/00basic.t
+t/01fileheap.t
+t/file.t
+t/file_fifo.t
+t/file_lru.t
+t/file_tie.t
+t/memory.t
+t/memory_fifo.t
+t/memory_lru.t
+t/memory_tie.t
+t/null.t
+META.yml Module meta-data (added by MakeMaker)
diff --git a/MANIFEST.SKIP b/MANIFEST.SKIP
new file mode 100644
index 0000000..9b291f0
--- /dev/null
+++ b/MANIFEST.SKIP
@@ -0,0 +1,8 @@
+\bCVS\b
+^Makefile$
+^Makefile.old$
+^MANIFEST.bak$
+^blib/
+pm_to_blib
+.cvsignore
+.swp$
diff --git a/META.yml b/META.yml
new file mode 100644
index 0000000..7395986
--- /dev/null
+++ b/META.yml
@@ -0,0 +1,25 @@
+# http://module-build.sourceforge.net/META-spec.html
+#XXXXXXX This is a prototype!!! It will change in the future!!! XXXXX#
+name: Cache
+version: 2.04
+version_from: lib/Cache.pm
+installdirs: site
+requires:
+ Date::Parse: 2.24
+ DB_File: 1.72
+ Digest::SHA1: 2.01
+ Fcntl: 1.03
+ File::Find: 0
+ File::NFSLock: 1.2
+ File::Path: 1
+ File::Spec: 0.8
+ Heap::Fibonacci: 0.01
+ IO::File: 1.08
+ IO::Handle: 1.21
+ IO::String: 1.02
+ Storable: 1
+ Symbol: 1.02
+ Test::More: 0.45
+
+distribution_type: module
+generated_by: ExtUtils::MakeMaker version 6.17
diff --git a/Makefile.PL b/Makefile.PL
new file mode 100644
index 0000000..519ac8d
--- /dev/null
+++ b/Makefile.PL
@@ -0,0 +1,25 @@
+use ExtUtils::MakeMaker;
+# See lib/ExtUtils/MakeMaker.pm for details of how to influence
+# the contents of the Makefile that is written.
+WriteMakefile(
+ 'NAME' => 'Cache',
+ 'VERSION_FROM' => 'lib/Cache.pm', # finds $VERSION
+ 'AUTHOR' => 'Chris Leishman <chris at leishman.org>',
+ 'PREREQ_PM' => {
+ Storable => 1.00,
+ Date::Parse => 2.24,
+ Test::More => 0.45,
+ Heap::Fibonacci => 0.01,
+ IO::String => 1.02,
+ File::Find => 0, # any version
+ File::Spec => 0.8,
+ File::Path => 1.00,
+ File::NFSLock => 1.20,
+ Digest::SHA1 => 2.01,
+ Symbol => 1.02,
+ IO::Handle => 1.21,
+ IO::File => 1.08,
+ Fcntl => 1.03,
+ DB_File => 1.72,
+ },
+);
diff --git a/README b/README
new file mode 100644
index 0000000..8b19f2f
--- /dev/null
+++ b/README
@@ -0,0 +1,29 @@
+Readme for Cache
+
+The Cache modules are designed to assist a developer in persisting data for a
+specified period of time. Often these modules are used in web applications to
+store data locally to save repeated and redundant expensive calls to remote
+machines or databases.
+
+The Cache package provides the 'Cache' module, a generic interface for
+creating persistent data stores. The interface is implemented by the
+Cache::Memory and Cache::File modules.
+
+This work aggregates and extends the original Cache::Cache modules.
+
+For more details, see the pod documentation in Cache.pm.
+
+For licensing, see the LICENSE file in this distribution.
+To install:
+
+ perl Makefile.PL
+ make
+ make test
+ sudo make install
+
+will probably do it.
+
+Please send any bug reports to Chris Leishman <chris at leishman.org>.
+Messages of thanks are also appreciated :)
+
+Enjoy!
diff --git a/TODO b/TODO
new file mode 100644
index 0000000..9026cd9
--- /dev/null
+++ b/TODO
@@ -0,0 +1,5 @@
+TODO for Cache
+
+* See the 'CAVEATS' section in the pod documentation of Cache::File
+* Fix issues in taint mode for Cache::File
+* Add better handling of corrupted cache directories in Cache::File
diff --git a/design.dia b/design.dia
new file mode 100644
index 0000000..c74b59d
Binary files /dev/null and b/design.dia differ
diff --git a/lib/Cache.pm b/lib/Cache.pm
new file mode 100644
index 0000000..6c0c4bb
--- /dev/null
+++ b/lib/Cache.pm
@@ -0,0 +1,630 @@
+=head1 NAME
+
+Cache - the Cache interface
+
+=head1 DESCRIPTION
+
+The Cache modules are designed to assist a developer in persisting data for a
+specified period of time. Often these modules are used in web applications to
+store data locally to save repeated and redundant expensive calls to remote
+machines or databases.
+
+The Cache interface is implemented by derived classes that store cached data
+in different manners (such as as files on a filesystem, or in memory).
+
+=head1 USAGE
+
+To use the Cache system, a cache implementation must be chosen to suit your
+needs. The most common is Cache::File, which is suitable for sharing data
+between multiple invocations and even between concurrent processes.
+
+Using a cache is simple. Here is some very simple sample code for
+instantiating and using a file system based cache.
+
+ use Cache::File;
+
+ my $cache = Cache::File->new( cache_root => '/tmp/cacheroot' );
+ my $customer = $cache->get( $name );
+
+ unless ($customer) {
+ $customer = get_customer_from_db( $name );
+ $cache->set( $name, $customer, '10 minutes' );
+ }
+
+ return $customer;
+
+Of course, far more powerful methods are available for accessing cached data.
+Also see the TIE INTERFACE below.
+
+=head1 METHODS
+
+=over
+
+=cut
+package Cache;
+
+require 5.006;
+use strict;
+use warnings::register;
+use Carp;
+use Date::Parse;
+
+use base qw(Tie::Hash);
+use fields qw(
+ default_expires removal_strategy size_limit
+ load_callback validate_callback);
+
+our $VERSION = '2.04';
+
+our $EXPIRES_NOW = 'now';
+our $EXPIRES_NEVER = 'never';
+
+# map of expiration formats to their respective time in seconds
+my %_Expiration_Units = ( map(($_, 1), qw(s second seconds sec)),
+ map(($_, 60), qw(m minute minutes min)),
+ map(($_, 60*60), qw(h hour hours)),
+ map(($_, 60*60*24), qw(d day days)),
+ map(($_, 60*60*24*7), qw(w week weeks)),
+ map(($_, 60*60*24*30), qw(M month months)),
+ map(($_, 60*60*24*365), qw(y year years)) );
+
+
+sub new {
+ my Cache $self = shift;
+ my $args = $#_? { @_ } : shift;
+
+ ref $self or croak 'Must use a subclass of Cache';
+
+ $self->set_default_expires($args->{default_expires});
+
+ # set removal strategy
+ my $strategy = $args->{removal_strategy} || 'Cache::RemovalStrategy::LRU';
+ unless (ref($strategy)) {
+ eval "require $strategy" or die @_;
+ $strategy = $strategy->new();
+ }
+ $self->{removal_strategy} = $strategy;
+
+ # set size limit
+ $self->{size_limit} = $args->{size_limit};
+
+ # set load callback
+ $self->set_load_callback($args->{load_callback});
+
+ # set load callback
+ $self->set_validate_callback($args->{validate_callback});
+
+ return $self;
+}
+
+=item my $cache_entry = $c->entry( $key )
+
+Return a 'Cache::Entry' object for the given key. This object can then be
+used to manipulate the cache entry in various ways. The key can be any scalar
+string that will uniquely identify an entry in the cache.
+
+=cut
+
+sub entry;
+
+=item $c->purge()
+
+Remove all expired data from the cache.
+
+=cut
+
+sub purge;
+
+=item $c->clear()
+
+Remove all entries from the cache - regardless of their expiry time.
+
+=cut
+
+sub clear;
+
+=item my $num = $c->count()
+
+Returns the number of entries in the cache.
+
+=cut
+
+sub count;
+
+=item my $size = $c->size()
+
+Returns the size (in bytes) of the cache.
+
+=cut
+
+# if an argument is provided, then the target is the 'shortcut' method set($key)
+sub size {
+ my Cache $self = shift;
+ return @_? $self->entry_size(@_) : $self->cache_size();
+}
+
+# implement this method instead
+sub cache_size;
+
+
+=back
+
+=head1 PROPERTIES
+
+When a cache is constructed these properties can be supplied as options to the
+new() method.
+
+=over
+
+=item default_expires
+
+The current default expiry time for new entries into the cache. This property
+can also be reset at any time.
+
+ my $time = $c->default_expires();
+ $c->set_default_expires( $expiry );
+
+=cut
+
+sub default_expires {
+ my Cache $self = shift;
+ return Canonicalize_Expiration_Time($self->{default_expires});
+}
+
+sub set_default_expires {
+ my Cache $self = shift;
+ my ($time) = @_;
+ # This could be made more efficient by converting to unix time here,
+ # except that special handling would be required for relative times.
+ # For now default_expires() does all the conversion.
+ $self->{default_expires} = $time;
+}
+
+=item removal_strategy
+
+The removal strategy object for the cache. This is used to remove
+object from the cache in order to maintain the cache size limit.
+
+When setting the removal strategy in new(), the name of a strategy package or
+a blessed strategy object reference should be provided (in the former case an
+object is constructed by calling the new() method of the named package).
+
+The strategies 'Cache::RemovalStrategy::LRU' and
+'Cache::RemovalStrategy::FIFO' are available by default.
+
+ my $strategy = $c->removal_strategy();
+
+=cut
+
+sub removal_strategy {
+ my Cache $self = shift;
+ return $self->{removal_strategy};
+}
+
+=item size_limit
+
+The size limit for the cache.
+
+ my $limit = $c->size_limit();
+
+=cut
+
+sub size_limit {
+ my Cache $self = shift;
+ return $self->{size_limit};
+}
+
+=item load_callback
+
+The load callback for the cache. This may be set to a function that will get
+called anytime a 'get' is issued for data that does not exist in the cache.
+
+ my $limit = $c->load_callback();
+ $c->set_load_callback($callback_func);
+
+=cut
+
+sub load_callback {
+ my Cache $self = shift;
+ return $self->{load_callback};
+}
+
+sub set_load_callback {
+ my Cache $self = shift;
+ my ($load_callback) = @_;
+ $self->{load_callback} = $load_callback;
+}
+
+=item validate_callback
+
+The validate callback for the cache. This may be set to a function that will
+get called anytime a 'get' is issued for data that does not exist in the
+cache.
+
+ my $limit = $c->validate_callback();
+ $c->set_validate_callback($callback_func);
+
+=cut
+
+sub validate_callback {
+ my Cache $self = shift;
+ return $self->{validate_callback};
+}
+
+sub set_validate_callback {
+ my Cache $self = shift;
+ my ($validate_callback) = @_;
+ $self->{validate_callback} = $validate_callback;
+}
+
+
+=back
+
+=head1 SHORTCUT METHODS
+
+These methods all have counterparts in the Cache::Entry package, but are
+provided here as shortcuts. They all default to just wrappers that do
+'$c->entry($key)->method_name()'. For documentation, please refer to
+Cache::Entry.
+
+=over
+
+=item my $bool = $c->exists( $key )
+
+=cut
+
+sub exists {
+ my Cache $self = shift;
+ my $key = shift;
+ return $self->entry($key)->exists();
+}
+
+=item $c->set( $key, $data, [ $expiry ] )
+
+=cut
+
+sub set {
+ my Cache $self = shift;
+ my $key = shift;
+ return $self->entry($key)->set(@_);
+}
+
+=item my $data = $c->get( $key )
+
+=cut
+
+sub get {
+ my Cache $self = shift;
+ my $key = shift;
+ return $self->entry($key)->get();
+}
+
+=item my $data = $c->size( $key )
+
+=cut
+
+# method is called 'entry_size' as the size() method is also a normal Cache
+# method for returning the size of the entire cache. It calls this instead if
+# given an argument.
+sub entry_size {
+ my Cache $self = shift;
+ my $key = shift;
+ return $self->entry($key)->size();
+}
+
+=item $c->remove( $key )
+
+=cut
+
+sub remove {
+ my Cache $self = shift;
+ my $key = shift;
+ return $self->entry($key)->remove();
+}
+
+=item $c->expiry( $key )
+
+=cut
+
+sub expiry {
+ my Cache $self = shift;
+ my $key = shift;
+ return $self->entry($key)->expiry();
+}
+sub get_expiry { shift->expiry(@_); }
+
+=item $c->set_expiry( $key, $time )
+
+=cut
+
+sub set_expiry {
+ my Cache $self = shift;
+ my $key = shift;
+ return $self->entry($key)->set_expiry(@_);
+}
+
+=item $c->handle( $key, [$mode, [$expiry] ] )
+
+=cut
+
+sub handle {
+ my Cache $self = shift;
+ my $key = shift;
+ return $self->entry($key)->handle();
+}
+
+=item $c->validity( $key )
+
+=cut
+
+sub validity {
+ my Cache $self = shift;
+ my $key = shift;
+ return $self->entry($key)->validity();
+}
+sub get_validity { shift->validity(@_); }
+
+=item $c->set_validity( $key, $data )
+
+=cut
+
+sub set_validity {
+ my Cache $self = shift;
+ my $key = shift;
+ return $self->entry($key)->set_validity(@_);
+}
+
+=item $c->freeze( $key, $data, [ $expiry ] )
+
+=cut
+
+sub freeze {
+ my Cache $self = shift;
+ my $key = shift;
+ return $self->entry($key)->freeze(@_);
+}
+
+=item $c->thaw( $key )
+
+=cut
+
+sub thaw {
+ my Cache $self = shift;
+ my $key = shift;
+ return $self->entry($key)->thaw();
+}
+
+
+=back
+
+=head1 TIE INTERFACE
+
+ tie %hash, 'Cache::File', { cache_root => $tempdir };
+
+ $hash{'key'} = 'some data';
+ $data = $hash{'key'};
+
+The Cache classes can be used via the tie interface, as shown in the synopsis.
+This allows the cache to be accessed via a hash. All the standard methods
+for accessing the hash are supported , with the exception of the 'keys' or
+'each' call.
+
+The tie interface is especially useful with the load_callback to automatically
+populate the hash.
+
+=head1 REMOVAL STRATEGY METHODS
+
+These methods are only for use internally (by concrete Cache implementations).
+
+These methods define the interface by which the removal strategy object can
+manipulate the cache (the Cache is the 'context' of the strategy). By
+default, methods need to be provided to remove the oldest or stalest objects
+in the cache - thus allowing support for the default FIFO and LRU removal
+strategies. All derived Cache implementations should support these methods
+and may also introduce additional methods (and additional removal strategies
+to match).
+
+=over
+
+=item my $size = $c->remove_oldest()
+
+Removes the oldest entry in the cache and returns its size.
+
+=cut
+
+sub remove_oldest;
+
+=item my $size = $c->remove_stalest()
+
+Removes the 'stalest' (least used) object in the cache and returns its
+size.
+
+=cut
+
+sub stalest;
+
+=item $c->check_size( $size )
+
+This method isn't actually part of the strategy interface, nor does it need
+to be defined by Cache implementations. Instead it should be called by
+implementations whenever the size of the cache increases. It will take care
+of checking the size limit and invoking the removal strategy if required. The
+size argument should be the new size of the cache.
+
+=cut
+
+sub check_size {
+ my Cache $self = shift;
+ my ($size) = @_;
+
+ defined $self->{size_limit} or return;
+
+ if ($size > $self->{size_limit}) {
+ $self->{removal_strategy}->remove_size(
+ $self, $size - $self->{size_limit});
+ }
+}
+
+
+=back
+
+=head1 UTILITY METHODS
+
+These methods are only for use internally (by concrete Cache implementations).
+
+=over
+
+=item my $time = Cache::Canonicalize_Expiration_Time($timespec)
+
+Converts a timespec as described for Cache::Entry::set_expiry() into a unix
+time.
+
+=cut
+
+sub Canonicalize_Expiration_Time {
+ my $timespec = lc($_[0])
+ or return undef;
+
+ my $time;
+
+ if ($timespec =~ /^\s*\d+\s*$/) {
+ $time = $timespec;
+ }
+ elsif ($timespec eq $EXPIRES_NOW) {
+ $time = 0;
+ }
+ elsif ($timespec eq $EXPIRES_NEVER) {
+ $time = undef;
+ }
+ elsif ($timespec =~ /^\s*-/) {
+ # negative time?
+ $time = 0;
+ }
+ elsif ($timespec =~ /^\s*\+(\d+)\s*$/) {
+ $time = $1 + time();
+ }
+ elsif ($timespec =~ /^\s*(\+?\d+)\s*(\w*)\s*$/
+ and exists($_Expiration_Units{$2}))
+ {
+ $time = $_Expiration_Units{$2} * $1 + time();
+ }
+ else {
+ $time = str2time($timespec)
+ or croak "invalid expiration time '$timespec'";
+ }
+
+ return $time;
+}
+
+
+# Hash tie methods
+
+sub TIEHASH {
+ my Cache $class = shift;
+ return $class->new(@_);
+}
+
+sub STORE {
+ my Cache $self = shift;
+ my ($key, $value) = @_;
+ return $self->set($key, $value);
+}
+
+sub FETCH {
+ my Cache $self = shift;
+ my ($key) = @_;
+ return $self->get($key);
+}
+
+# NOT SUPPORTED
+sub FIRSTKEY {
+ my Cache $self = shift;
+ return undef;
+}
+
+# NOT SUPPORTED
+sub NEXTKEY {
+ my Cache $self = shift;
+ #my ($lastkey) = @_;
+ return undef;
+}
+
+sub EXISTS {
+ my Cache $self = shift;
+ my ($key) = @_;
+ return $self->exists($key);
+}
+
+sub DELETE {
+ my Cache $self = shift;
+ my ($key) = @_;
+ return $self->remove($key);
+}
+
+sub CLEAR {
+ my Cache $self = shift;
+ return $self->clear();
+}
+
+
+1;
+__END__
+
+=head1 SEE ALSO
+
+Cache::Entry, Cache::File, Cache::RemovalStrategy
+
+=head1 DIFFERENCES FROM CACHE::CACHE
+
+The Cache modules are a total redesign and reimplementation of Cache::Cache
+and thus not directly compatible. It would be, however, quite possible to
+write a wrapper module that provides an identical interface to Cache::Cache.
+
+The semantics of use are very similar to Cache::Cache, with the following
+exceptions:
+
+=over
+
+=item The get/set methods DO NOT serialize complex data types. Use
+freeze/thaw instead (but read the notes in Cache::Entry).
+
+=item The get_object / set_object methods are not available, but have been
+superseded by the more flexible entry method and Cache::Entry class.
+
+=item There is no concept of 'namespace' in the basic cache interface,
+although implementations (eg. Cache::Memory) may choose to provide them. For
+instance, File::Cache does not provide this - but different namespaces can be
+created by varying cache_root.
+
+=item In the current Cache implementations purging is done automatically -
+there is no need to explicitly enable auto purge on get/set. The purging
+algorithm is no longer implemented in the base Cache class, but is left up to
+the implementations and may thus be implemented in the most efficient way for
+the storage medium.
+
+=item Cache::SharedMemory is not yet available.
+
+=item Cache::File no longer supports separate masks for entries and
+directories. It is not a very secure configuration and presents numerous
+issues for cache consistency and is hence depricated. There is still some
+work to be done to ensure cache consistency between accesses by different
+users.
+
+=back
+
+=head1 AUTHOR
+
+ Chris Leishman <chris at leishman.org>
+ Based on work by DeWitt Clinton <dewitt at unto.net>
+
+=head1 COPYRIGHT
+
+ Copyright (C) 2003-2006 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: Cache.pm,v 1.7 2006/01/31 15:23:58 caleishm Exp $
+
+=cut
diff --git a/lib/Cache/Entry.pm b/lib/Cache/Entry.pm
new file mode 100644
index 0000000..ee4de22
--- /dev/null
+++ b/lib/Cache/Entry.pm
@@ -0,0 +1,361 @@
+=head1 NAME
+
+Cache::Entry - interface for a cache entry
+
+=head1 SYNOPSIS
+
+ my Cache::Entry $entry = $cache->entry( $key )
+ my $data;
+ if ($entry->exists()) {
+ $data = $entry->get();
+ }
+ else {
+ $data = get_some_data($key);
+ $entry->set($data, '10 minutes');
+ }
+
+=head1 DESCRIPTION
+
+Objects derived from Cache::Entry represent an entry in a Cache. Methods are
+provided that act upon the data in the entry, and allow you to set things like
+the expiry time.
+
+Users should not create instances of Cache::Entry directly, but instead use
+the entry($key) method of a Cache instance.
+
+=head1 METHODS
+
+=over
+
+=cut
+package Cache::Entry;
+
+require 5.006;
+use strict;
+use warnings;
+use Cache;
+use Storable;
+use Carp;
+
+use fields qw(cache key);
+
+our $VERSION = '2.04';
+
+
+sub new {
+ my Cache::Entry $self = shift;
+ my ($cache, $key) = @_;
+
+ ref $self or croak 'Must use a subclass of Cache::Entry';
+
+ $self->{cache} = $cache;
+ $self->{key} = $key;
+
+ return $self;
+}
+
+=item my $cache = $e->cache()
+
+Returns a reference to the cache object this entry is from.
+
+=cut
+
+sub cache {
+ my Cache::Entry $self = shift;
+ return $self->{cache};
+}
+
+=item my $key = $e->key()
+
+Returns the cache key this entry is associated with.
+
+=cut
+
+sub key {
+ my Cache::Entry $self = shift;
+ return $self->{key};
+}
+
+=item my $bool = $e->exists()
+
+Returns a boolean value (1 or 0) to indicate whether there is any data
+present in the cache for this entry.
+
+=cut
+
+sub exists;
+
+=item $e->set( $data, [ $expiry ] )
+
+Stores the data into the cache. The data must be a scalar (if you want to
+store more complex data types, see freeze and thaw below).
+
+The expiry time may be provided as an optional 2nd argument and is in the same
+form as for 'set_expiry($time)'.
+
+=cut
+
+# ensure expiry is normalized then call _set
+sub set {
+ my Cache::Entry $self = shift;
+ my ($data, $expiry) = @_;
+
+ unless (defined $data) {
+ return $self->remove();
+ }
+
+ ref($data) and warnings::warnif('Cache','Reference passed to set');
+
+ if ($#_ < 1) {
+ $expiry = $self->{cache}->default_expires();
+ }
+ else {
+ $expiry = Cache::Canonicalize_Expiration_Time($expiry);
+ }
+
+ if (defined $expiry and $expiry == 0) {
+ return $self->remove();
+ }
+
+ return $self->_set($data, $expiry);
+}
+
+# Implement this method instead of set
+sub _set;
+
+=item my $data = $e->get()
+
+Returns the data from the cache, or undef if the entry doesn't exist.
+
+=cut
+
+# ensure load_callback and validity callback is issued
+sub get {
+ my Cache::Entry $self = shift;
+ my Cache $cache = $self->{cache};
+
+ my $result = $self->_get(@_);
+
+ if (defined $result) {
+ my $validate_callback = $cache->{validate_callback};
+ $validate_callback or return $result;
+ $validate_callback->($self) and return $result;
+ }
+
+ my $load_callback = $cache->{load_callback}
+ or return undef;
+ my @options;
+ ($result, @options) = $load_callback->($self);
+ $self->set($result, @options) if defined $result;
+
+ return $result;
+}
+
+# Implement this method instead of get
+sub _get;
+
+=item my $size = $e->size()
+
+Returns the size of the entry data, or undef if the entry doesn't exist.
+
+=cut
+
+sub size;
+
+=item $e->remove()
+
+Clear the data for this entry from the cache.
+
+=cut
+
+sub remove;
+
+=item my $expiry = $e->expiry()
+
+Returns the expiry time of the entry, in seconds since the epoch.
+
+=cut
+
+sub expiry;
+sub get_expiry { shift->expiry(@_); }
+
+=item $e->set_expiry( $time )
+
+Set the expiry time in seconds since the epoch, or alternatively using a
+string like '10 minutes'. Valid units are s, second, seconds, sec, m, minute,
+minutes, min, h, hour, hours, w, week, weeks, M, month, months, y, year and
+years. You can also specify an absolute time, such as '16 Nov 94 22:28:20' or
+any other time that Date::Parse can understand. Finally, the strings 'now'
+and 'never' may also be used.
+
+=cut
+
+# ensure time is normalized then call _set_expiry
+sub set_expiry {
+ my Cache::Entry $self = shift;
+ my ($time) = @_;
+
+ my $expiry = Cache::Canonicalize_Expiration_Time($time);
+
+ if (defined $expiry and $expiry == 0) {
+ return $self->remove();
+ }
+
+ $self->_set_expiry($expiry);
+}
+
+# Implement this method instead of set_expiry
+sub _set_expiry;
+
+=item my $fh = $e->handle( [$mode, [$expiry] ] )
+
+Returns an IO::Handle by which data can be read, or written, to the cache.
+This is useful if you are caching a large amount of data - although it should
+be noted that only some cache implementations (such as Cache::File) provide an
+efficient mechanism for implementing this.
+
+The optional mode argument can be any of the perl mode strings as used for the
+open function '<', '+<', '>', '+>', '>>' and '+>>'. Alternatively it can be
+the corresponding fopen(3) modes of 'r', 'r+', 'w', 'w+', 'a' and 'a+'. The
+default mode is '+<' (or 'r+') indicating reading and writing.
+
+The second argument is used to set the expiry time for the entry if it doesn't
+exist already and the handle is opened for writing. It is also used to reset
+the expiry time if the entry is truncated by opening in the '>' or '+>' modes.
+If the expiry is not provided in these situations then the default expiry time
+for the cache is applied.
+
+Cache implementations will typically provide locking around cache entries, so
+that writers will have have an exclusive lock and readers a shared one. Thus
+the method get() (or obtaining another handle) should be avoided whilst a
+write handle is held. Using set() or remove(), however, should be supported.
+These clear the current entry and whilst they do not invalidate open handles,
+those handle will from then on refer to old data and any changes to the data
+will be discarded.
+
+=cut
+
+# ensure mode and expiry are normalized then call _handle
+sub handle {
+ my Cache::Entry $self = shift;
+ my ($mode, $expiry) = @_;
+
+ # normalize mode
+ if ($mode) {
+ require IO::Handle;
+ $mode = IO::Handle::_open_mode_string($mode);
+ }
+ else {
+ $mode = '+<';
+ }
+
+ if ($#_ < 1) {
+ $self->_handle($mode, $self->{cache}->default_expires());
+ }
+ else {
+ $self->_handle($mode, Cache::Canonicalize_Expiration_Time($expiry));
+ }
+}
+
+# Implement this method instead of handle
+sub _handle;
+
+
+=back
+
+=head1 STORING VALIDITY OBJECTS
+
+There are two additional set & get methods that can be used to store a
+validity object that is associated with the data in question. Typically this
+is useful in conjunction with a validate_callback, and may be used to store a
+timestamp or similar to validate against. The validity data stored may be any
+complex data that can be serialized via Storable.
+
+=over
+
+=item $e->validity()
+
+=cut
+
+sub validity;
+sub get_validity { shift->validity(@_); }
+
+=item $e->set_validity( $data )
+
+=cut
+
+sub set_validity;
+
+
+=back
+
+=head1 STORING COMPLEX OBJECTS
+
+The set and get methods only allow for working with simple scalar types, but
+if you want to store more complex types they need to be serialized first. To
+assist with this, the freeze and thaw methods are provided. They are simple
+wrappers to get & set that use Storable to do the serialization and
+de-serialization of the data.
+
+Note, however, that you must be careful to ONLY use 'thaw' on data that was
+stored via 'freeze'. Otherwise the stored data wont actually be in Storable
+format and it will complain loudly.
+
+=over
+
+=item $e->freeze( $data, [ $expiry ] )
+
+Identical to 'set', except that data may be any complex data type that can be
+serialized via Storable.
+
+=cut
+
+sub freeze {
+ my Cache::Entry $self = shift;
+ my ($data, @args) = @_;
+ ref($data) or warnings::warnif('Cache','Non-reference passed to freeze');
+ return $self->set(Storable::nfreeze($data), @args);
+}
+
+=item $e->thaw()
+
+Identical to 'get', except that it will return a complex data type that was
+set via 'freeze'.
+
+=cut
+
+sub thaw {
+ my Cache::Entry $self = shift;
+ my $data = $self->get(@_);
+ defined $data or return undef;
+ return Storable::thaw($data);
+}
+
+=back
+
+=cut
+
+
+1;
+__END__
+
+=head1 SEE ALSO
+
+Cache, Cache::File
+
+=head1 AUTHOR
+
+ Chris Leishman <chris at leishman.org>
+ Based on work by DeWitt Clinton <dewitt at unto.net>
+
+=head1 COPYRIGHT
+
+ Copyright (C) 2003-2006 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: Entry.pm,v 1.8 2006/01/31 15:23:58 caleishm Exp $
+
+=cut
diff --git a/lib/Cache/File.pm b/lib/Cache/File.pm
new file mode 100644
index 0000000..11d7978
--- /dev/null
+++ b/lib/Cache/File.pm
@@ -0,0 +1,653 @@
+=head1 NAME
+
+Cache::File - Filesystem based implementation of the Cache interface
+
+=head1 SYNOPSIS
+
+ use Cache::File;
+
+ my $cache = Cache::File->new( cache_root => '/tmp/mycache',
+ default_expires => '600 sec' );
+
+See Cache for the usage synopsis.
+
+=head1 DESCRIPTION
+
+The Cache::File class implements the Cache interface. This cache stores
+data in the filesystem so that it can be shared between processes and persists
+between process invocations.
+
+=cut
+package Cache::File;
+
+require 5.006;
+use strict;
+use warnings;
+use Cache::File::Heap;
+use Cache::File::Entry;
+use Digest::SHA1 qw(sha1_hex);
+use Fcntl qw(LOCK_EX LOCK_NB);
+use Symbol ();
+use File::Spec;
+use File::Path;
+use File::NFSLock;
+use DB_File;
+use Storable;
+use Carp;
+
+use base qw(Cache);
+use fields qw(
+ root depth umask locklevel
+ expheap ageheap useheap index lockfile
+ lock lockcount openexp openage openuse openidx);
+
+our $VERSION = '2.04';
+
+sub LOCK_NONE () { 0 }
+sub LOCK_LOCAL () { 1 }
+sub LOCK_NFS () { 2 }
+
+
+my $DEFAULT_DEPTH = 2;
+my $DEFAULT_UMASK = 077;
+my $DEFAULT_LOCKLEVEL = LOCK_NFS;
+
+my $INDEX = 'index.db';
+my $EXPIRY_HEAP = 'expheap.db';
+my $AGE_HEAP = 'ageheap.db';
+my $USE_HEAP = 'useheap.db';
+my $LOCKFILE = 'lock';
+
+our $STALE_LOCK_TIMEOUT = 30; # 30 second timeout on lockfiles
+our $LOCK_EXT = '.lock';
+
+# keys to store count and size in the index
+my $SIZE_KEY = '__cache_size';
+my $COUNT_KEY = '__cache_count';
+
+
+=head1 CONSTRUCTOR
+
+ my $cache = Cache::File->new( %options )
+
+The constructor takes cache properties as named arguments, for example:
+
+ my $cache = Cache::File->new( cache_root => '/tmp/mycache',
+ lock_level => Cache::File::LOCK_LOCAL(),
+ default_expires => '600 sec' );
+
+Note that you MUST provide a cache_root property.
+
+See 'PROPERTIES' below and in the Cache documentation for a list of all
+available properties that can be set.
+
+=cut
+
+sub new {
+ my Cache::File $self = shift;
+ my $args = $#_? { @_ } : shift;
+
+ $self = fields::new($self) unless ref $self;
+ $self->SUPER::new($args);
+
+ $self->_set_cache_lock_level($args->{lock_level});
+ $self->_set_cache_umask($args->{cache_umask});
+ $self->_set_cache_depth($args->{cache_depth});
+ $self->_set_cache_root($args->{cache_root});
+
+ return $self;
+}
+
+=head1 METHODS
+
+See 'Cache' for the API documentation.
+
+=cut
+
+sub entry {
+ my Cache::File $self = shift;
+ my ($key) = @_;
+ return Cache::File::Entry->new($self, $key);
+}
+
+sub purge {
+ my Cache::File $self = shift;
+ my $time = time();
+
+ # if it's locked, someone else will probably be doing a purge already
+ $self->trylock() or return;
+
+ # open expiry index
+ my $expheap = $self->get_exp_heap();
+
+ # check for expiry
+ my $minimum = $expheap->minimum();
+ if ($minimum and $minimum <= $time) {
+ # open other indexes
+ my $ageheap = $self->get_age_heap();
+ my $useheap = $self->get_use_heap();
+ my $index = $self->get_index();
+
+ # loop removing minimums
+ do {
+ my $keys;
+ ($minimum, $keys) = $expheap->extract_minimum_dup();
+
+ foreach (@$keys) {
+ # update all the indexes (remove references to this key)
+ my $path = $self->cache_file_path($_);
+
+ my $index_entries = $self->get_index_entries($_)
+ or warnings::warnif('Cache', "missing index entry for $_");
+ delete $$index{$_};
+
+ $ageheap->delete($$index_entries{age}, $_)
+ if $$index_entries{age};
+ $useheap->delete($$index_entries{lastuse}, $_)
+ if $$index_entries{lastuse};
+
+ # reduce the cache size and count
+ $$index{$COUNT_KEY}--;
+ $$index{$SIZE_KEY} -= (-s $path);
+
+ # remove data file
+ unlink($path);
+ }
+
+ $minimum = $expheap->minimum();
+
+ } while ($minimum and $minimum <= $time);
+ }
+
+ $self->unlock();
+}
+
+sub clear {
+ my Cache::File $self = shift;
+ my $fh = Symbol::gensym();
+
+ $self->lock();
+
+ # Find each directory entries are stored in and remove them
+ opendir($fh, $self->{root})
+ or die "Can't opendir ".$self->{root}.": $!";
+ my @stores =
+ grep { -d $_ }
+ map { File::Spec->catdir($self->{root}, $_) }
+ File::Spec->no_upwards(readdir($fh));
+ closedir($fh);
+
+ rmtree(\@stores,0,1);
+
+ # remove the index files
+ unlink($self->{expheap});
+ unlink($self->{ageheap});
+ unlink($self->{useheap});
+ unlink($self->{index});
+
+ $self->unlock();
+}
+
+sub count {
+ my Cache::File $self = shift;
+
+ my $count;
+ $self->lock();
+ my $index = $self->get_index();
+ $count = $$index{$COUNT_KEY};
+ $self->unlock();
+
+ return $count || 0;
+}
+
+sub size {
+ my Cache::File $self = shift;
+
+ my $size;
+ $self->lock();
+ my $index = $self->get_index();
+ $size = $$index{$SIZE_KEY};
+ $self->unlock();
+
+ return $size || 0;
+}
+
+sub sync {
+ my Cache::File $self = shift;
+ # TODO: check entries in cache root and rebuild heaps
+}
+
+
+=head1 PROPERTIES
+
+Cache::File adds the following properties in addition to those discussed in
+the 'Cache' documentation.
+
+=over
+
+=item cache_root
+
+Used to specify the location of the cache store directory. All methods will
+work ONLY data stored within this directory. This parameter is REQUIRED when
+creating a Cache::File instance.
+
+ my $ns = $c->cache_root();
+
+=cut
+
+sub cache_root {
+ my Cache::File $self = shift;
+ return $self->{root};
+}
+
+sub _set_cache_root {
+ my Cache::File $self = shift;
+ my ($cache_root) = @_;
+ $cache_root or croak 'A cache root directory MUST be provided';
+ $self->{root} = File::Spec->canonpath(
+ File::Spec->rel2abs($cache_root, File::Spec->tmpdir()));
+
+ # create root
+ unless (-d $self->{root}) {
+ my $oldmask = umask $self->cache_umask();
+ eval { mkpath($self->{root}) }
+ or die 'Failed to create cache root '.$self->{root}.": $@";
+ umask $oldmask;
+ }
+
+ # set required file paths
+ $self->{expheap} = File::Spec->catfile($self->{root}, $EXPIRY_HEAP);
+ $self->{ageheap} = File::Spec->catfile($self->{root}, $AGE_HEAP);
+ $self->{useheap} = File::Spec->catfile($self->{root}, $USE_HEAP);
+ $self->{index} = File::Spec->catfile($self->{root}, $INDEX);
+ $self->{lockfile} = File::Spec->catfile($self->{root}, $LOCKFILE);
+}
+
+=item cache_depth
+
+The number of subdirectories deep to store cache entires. This should be
+large enough that no cache directory has more than a few hundred object.
+Defaults to 2 unless explicitly set.
+
+ my $depth = $c->cache_depth();
+
+=cut
+
+sub cache_depth {
+ my Cache::File $self = shift;
+ return $self->{depth};
+}
+
+sub _set_cache_depth {
+ my Cache::File $self = shift;
+ my ($cache_depth) = @_;
+ $self->{depth} = (defined $cache_depth)? $cache_depth : $DEFAULT_DEPTH;
+}
+
+=item cache_umask
+
+Specifies the umask to use when creating entries in the cache directory. By
+default the umask is '077', indicating that only the same user may access
+the cache files.
+
+ my $umask = $c->cache_umask();
+
+=cut
+
+sub cache_umask {
+ my Cache::File $self = shift;
+ return $self->{umask};
+}
+
+sub _set_cache_umask {
+ my Cache::File $self = shift;
+ my ($cache_umask) = @_;
+ $self->{umask} = (defined $cache_umask)? $cache_umask : $DEFAULT_UMASK;
+}
+
+=item lock_level
+
+Specify the level of locking to be used. There are three different levels
+available:
+
+=over
+
+=item Cache::File::LOCK_NONE()
+
+No locking is performed. Useful when you can guarantee only one process will
+be accessing the cache at a time.
+
+=item Cache::File::LOCK_LOCAL()
+
+Locking is performed, but it is not suitable for use over NFS filesystems.
+However it is more efficient.
+
+=item Cache::File::LOCK_NFS()
+
+Locking is performed in a way that is suitable for use on NFS filesystems.
+
+=back
+
+ my $level = $c->cache_lock_level();
+
+=cut
+
+sub cache_lock_level {
+ my Cache::File $self = shift;
+ return $self->{locklevel};
+}
+
+sub _set_cache_lock_level {
+ my Cache::File $self = shift;
+ my ($locklevel) = @_;
+
+ if (defined $locklevel) {
+ croak "Unknown lock level requested"
+ unless ($locklevel =~ /^[0-9]+$/ &&
+ ($locklevel == LOCK_NONE ||
+ $locklevel == LOCK_LOCAL ||
+ $locklevel == LOCK_NFS));
+ } else {
+ $locklevel = $DEFAULT_LOCKLEVEL;
+ }
+
+ $self->{locklevel} = $locklevel;
+}
+
+
+# REMOVAL STRATEGY METHODS
+
+sub remove_oldest {
+ my Cache::File $self = shift;
+
+ # Only called from check_size (via change_size) when the lock is set
+ #$self->lock();
+ my $ageheap = $self->get_age_heap();
+
+ my ($minimum, $key) = $ageheap->extract_minimum();
+ $key or return undef;
+ my $size = $self->remove($key);
+ #$self->unlock();
+ return $size;
+}
+
+sub remove_stalest {
+ my Cache::File $self = shift;
+
+ # Only called from check_size (via change_size) when the lock is set
+ #$self->lock();
+ my $useheap = $self->get_use_heap();
+
+ my ($minimum, $key) = $useheap->extract_minimum();
+ $key or return undef;
+ my $size = $self->remove($key);
+ #$self->unlock();
+ return $size;
+}
+
+
+# UTILITY METHODS
+
+sub cache_file_path {
+ my Cache::File $self = shift;
+ my ($key) = @_;
+
+ my $shakey = sha1_hex($key);
+ my (@path) = unpack('A2'x$self->{depth}.'A*', $shakey);
+
+ if (wantarray) {
+ my $file = pop(@path);
+ return (File::Spec->catdir($self->{root}, @path), $file);
+ } else {
+ return File::Spec->catfile($self->{root}, @path);
+ }
+}
+
+sub lock {
+ my Cache::File $self = shift;
+ my ($tryonly) = @_;
+
+ # already have the lock?
+ if ($self->{lock}) {
+ $self->{lockcount}++;
+ return 1;
+ }
+
+ if ($self->{locklevel} == LOCK_NONE) {
+ $self->{lock} = 1;
+ }
+ else {
+ # TODO: implement LOCK_LOCAL
+
+ my $oldmask = umask $self->cache_umask();
+ my $lock = File::NFSLock->new({
+ file => $self->{lockfile},
+ lock_type => LOCK_EX | ($tryonly? LOCK_NB : 0),
+ stale_lock_timeout => $STALE_LOCK_TIMEOUT,
+ });
+ umask $oldmask;
+
+ unless ($lock) {
+ $tryonly and return 0;
+ die "Failed to obtain lock on lockfile '".$self->{lockfile}."': ".
+ $File::NFSLock::errstr."\n";
+ }
+ $self->{lock} = $lock;
+ }
+
+ $self->{lockcount} = 1;
+ return 1;
+}
+
+sub trylock {
+ my Cache::File $self = shift;
+ return $self->lock(1);
+}
+
+sub unlock {
+ my Cache::File $self = shift;
+ $self->{lock} or croak "not locked";
+ return unless --$self->{lockcount} == 0;
+
+ # close heaps and save counts
+ $self->{openexp} = undef;
+ $self->{openage} = undef;
+ $self->{openuse} = undef;
+ $self->{openidx} = undef;
+
+ # unlock
+ $self->{lock}->unlock unless $self->{locklevel} == LOCK_NONE;
+ $self->{lock} = undef;
+}
+
+sub create_entry {
+ my Cache::File $self = shift;
+ my ($key, $time) = @_;
+
+ my $ageheap = $self->get_age_heap();
+ $ageheap->add($time, $key);
+ my $useheap = $self->get_use_heap();
+ $useheap->add($time, $key);
+
+ $self->set_index_entries($key, { age => $time, lastuse => $time });
+}
+
+sub update_last_use {
+ my Cache::File $self = shift;
+ my ($key, $time) = @_;
+
+ my $index_entries = $self->get_index_entries($key)
+ or warnings::warnif('Cache', "missing index entry for $key");
+
+ my $useheap = $self->get_use_heap();
+ $useheap->delete($$index_entries{lastuse}, $key);
+ $useheap->add($time, $key);
+
+ $$index_entries{lastuse} = $time;
+ $self->set_index_entries($key, $index_entries);
+}
+
+sub change_count {
+ my Cache::File $self = shift;
+ my ($count) = @_;
+ my $index = $self->get_index();
+ my $oldcount = $$index{$COUNT_KEY};
+ $$index{$COUNT_KEY} = $oldcount? $oldcount + $count : $count;
+}
+
+sub change_size {
+ my Cache::File $self = shift;
+ my ($size) = @_;
+ my $index = $self->get_index();
+ my $oldsize = $$index{$SIZE_KEY};
+ $$index{$SIZE_KEY} = $oldsize? $oldsize + $size : $size;
+ $self->check_size($$index{$SIZE_KEY}) if $size > 0;
+}
+
+sub get_index_entries {
+ my Cache::File $self = shift;
+ my ($key) = @_;
+
+ my $index = $self->get_index();
+ my $index_entry = $$index{$key}
+ or return undef;
+
+ my $index_entries = Storable::thaw($index_entry);
+ $$index_entries{age} and $$index_entries{lastuse}
+ or warnings::warnif('Cache', "invalid index entry for $_");
+
+ return $index_entries;
+}
+
+sub set_index_entries {
+ my Cache::File $self = shift;
+ my $key = shift;
+ my $index_entries = $#_? { @_ } : shift;
+
+ $$index_entries{age} and $$index_entries{lastuse}
+ or croak "failed to supply age and lastuse for index update on $key";
+
+ my $index = $self->get_index();
+ $$index{$key} = Storable::nfreeze($index_entries);
+}
+
+sub get_index {
+ my Cache::File $self = shift;
+ unless ($self->{openidx}) {
+ $self->{lock} or croak "not locked";
+
+ my $indexfile = $self->{index};
+ File::NFSLock::uncache($indexfile) if $self->{locklevel} == LOCK_NFS;
+
+ my $oldmask = umask $self->cache_umask();
+ my %indexhash;
+ my $index =
+ tie %indexhash, 'DB_File', $indexfile,O_CREAT|O_RDWR,0666,$DB_HASH;
+ umask $oldmask;
+
+ $index or die "Failed to open index $indexfile: $!";
+
+ $self->{openidx} = \%indexhash;
+ }
+ return $self->{openidx};
+}
+
+sub get_exp_heap {
+ my Cache::File $self = shift;
+ return $self->{openexp} ||= $self->_open_heap($self->{expheap});
+}
+
+sub get_age_heap {
+ my Cache::File $self = shift;
+ return $self->{openage} ||= $self->_open_heap($self->{ageheap});
+}
+
+sub get_use_heap {
+ my Cache::File $self = shift;
+ return $self->{openuse} ||= $self->_open_heap($self->{useheap});
+}
+
+sub _open_heap {
+ my Cache::File $self = shift;
+ my ($heapfile) = @_;
+ $self->{lock} or croak "not locked";
+
+ File::NFSLock::uncache($heapfile) if $self->{locklevel} == LOCK_NFS;
+
+ my $oldmask = umask $self->cache_umask();
+ my $heap = Cache::File::Heap->new($heapfile);
+ umask $oldmask;
+ $heap or die "Failed to open heap $heapfile: $!";
+ return $heap;
+}
+
+
+1;
+__END__
+
+=head1 CAVEATS
+
+There are a couple of caveats in the current implementation of Cache::File.
+None of these will present a problem in using the class, it's more of a TODO
+list of things that could be done better.
+
+=over
+
+=item external cache modification (and re-syncronization)
+
+Cache::File maintains indexes of entries in the cache, including the number of
+entries and the total size. Currently there is no process of checking that
+the count or size are in syncronization with the actual data on disk, and thus
+any modifications to the cache store by another program (eg. a user shell)
+will result in an inconsitency in the index. A better process would be for
+Cache::File to resyncronize at an appropriate time (eg whenever the size or
+count is initially requested - this would only need happen once per instance).
+This resyncronization would involve calculating the total size and count as
+well as checking that entries in the index accurately reflect what is on the
+disk (and removing any entries that have dissapeared or adding any new ones).
+
+=item index efficiency
+
+Currently Berkeley DB's are used for indexes of expiry time, last use and entry
+age. They use the BTREE variant in order to implement a heap (see
+Cache::File::Heap). This is probably not the most efficient format and having
+3 separate index files adds overhead. These are also cross-referenced with
+a fourth index file that uses a normal hash db and contains all these time
+stamps (frozen together with the validity object to a single scalar via
+Storable) indexed by key. Needless to say, all this could be done more
+efficiently - probably by using a single index in a custom format.
+
+=item locking efficiency
+
+Currently LOCK_LOCAL is not implemented (if uses the same code as LOCK_NFS).
+
+There are two points of locking in Cache::File, index locking and entry
+locking. The index locking is always exclusive and the lock is required
+briefly during most operations. The entry locking is either shared or
+exclusive and is also required during most operations. When locking is
+enabled, File::NFSLock is used to provide the locking for both situations.
+This is not overly efficient, especially as the entry lock is only ever
+grabbed whilst the index lock is held.
+
+=back
+
+=head1 SEE ALSO
+
+Cache
+
+=head1 AUTHOR
+
+ Chris Leishman <chris at leishman.org>
+ Based on work by DeWitt Clinton <dewitt at unto.net>
+
+=head1 COPYRIGHT
+
+ Copyright (C) 2003-2006 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: File.pm,v 1.7 2006/01/31 15:23:58 caleishm Exp $
+
+=cut
diff --git a/lib/Cache/File/Entry.pm b/lib/Cache/File/Entry.pm
new file mode 100644
index 0000000..9d2ed1e
--- /dev/null
+++ b/lib/Cache/File/Entry.pm
@@ -0,0 +1,557 @@
+=head1 NAME
+
+Cache::File::Entry - An entry in the file based implementation of Cache
+
+=head1 SYNOPSIS
+
+ See 'Cache::Entry' for a synopsis.
+
+=head1 DESCRIPTION
+
+This module implements a version of Cache::Entry for the Cache::File variant
+of Cache. It should not be created or used directly, please see
+'Cache::File' or 'Cache::Entry' instead.
+
+=cut
+package Cache::File::Entry;
+
+require 5.006;
+use strict;
+use warnings;
+use Cache::File;
+use File::Spec;
+use File::Path;
+use File::Temp qw(tempfile);
+use Fcntl qw(LOCK_EX LOCK_SH LOCK_NB);
+use File::NFSLock;
+use Symbol ();
+use Carp;
+
+use base qw(Cache::Entry);
+use fields qw(dir path lockdetails);
+
+our $VERSION = '2.04';
+
+# hash of locks held my the process, keyed on path. This is useful for
+# catching potential deadlocks and warning the user, and for implementing
+# LOCK_NONE (which still needs to do some synchronization). Each entry will
+# be an hash of { lock, type, count, lock, lockfh, linkcount }. The
+# filehandle and link count is for checking when the lock has been released by
+# another process.
+my %PROCESS_LOCKS;
+
+
+sub new {
+ my Cache::File::Entry $self = shift;
+
+ $self = fields::new($self) unless ref $self;
+ $self->SUPER::new(@_);
+
+ # get file path and store full path and containing directory
+ my ($dir, $file) = $self->{cache}->cache_file_path($self->{key});
+
+ $self->{dir} = $dir;
+ $self->{path} = File::Spec->catfile($dir, $file);
+
+ return $self;
+}
+
+sub exists {
+ my Cache::File::Entry $self = shift;
+
+ # ensure pending expiries are removed
+ $self->{cache}->purge();
+
+ return -e $self->{path};
+}
+
+sub _set {
+ my Cache::File::Entry $self = shift;
+ my ($data, $expiry) = @_;
+
+ $self->_make_path() or return;
+
+ my ($fh, $filename) = tempfile('.XXXXXXXX', DIR => $self->{dir});
+ binmode $fh;
+ print $fh $data;
+ close($fh);
+
+ my $time = time();
+ my $cache = $self->{cache};
+ my $key = $self->{key};
+
+ # lock indexes
+ $cache->lock();
+
+ my $exists = -e $self->{path};
+ my $orig_size;
+
+ unless ($exists) {
+ # we're creating the entry
+ $cache->create_entry($key, $time);
+ $cache->change_count(1);
+ $orig_size = 0;
+ }
+ # only remove current size if there is no active write handle
+ elsif ($self->_trylock(LOCK_SH)) {
+ $orig_size = $self->size();
+ $self->_unlock();
+ }
+ else {
+ $orig_size = 0;
+ }
+
+ # replace existing data
+ rename($filename, $self->{path});
+
+ # fix permissions of tempfile
+ my $mode = 0666 & ~($self->{cache}->cache_umask());
+ chmod $mode, $self->{path};
+
+ # invalidate any active handle locks
+ unlink($self->{path} . $Cache::File::LOCK_EXT);
+ delete $PROCESS_LOCKS{$self->{path}};
+
+ $self->_set_expiry($expiry) if $expiry or $exists;
+ $cache->update_last_use($key, $time) if $exists;
+
+ $cache->change_size($self->size() - $orig_size);
+ # ensure pending expiries are removed
+ $cache->purge();
+
+ $cache->unlock();
+}
+
+sub _get {
+ my Cache::File::Entry $self = shift;
+
+ my $cache = $self->{cache};
+ my $key = $self->{key};
+ my $exists;
+ my $time = time();
+
+ $cache->lock();
+
+ if ($exists = $self->exists()) {
+ # update last used
+ $cache->update_last_use($key, $time);
+
+ # lock entry for reading
+ $self->_lock(LOCK_SH);
+ }
+
+ $cache->unlock();
+
+ return undef unless $exists;
+
+ File::NFSLock::uncache($self->{path})
+ if $cache->cache_lock_level() == Cache::File::LOCK_NFS();
+
+ my $fh = Symbol::gensym();
+ my $data;
+ my $oldmask = umask $self->{cache}->cache_umask();
+ if (open($fh, $self->{path})) {
+ binmode $fh;
+
+ # slurp mode
+ local $/;
+ $data = <$fh>;
+
+ close($fh);
+ }
+ umask $oldmask;
+
+ # shared locks can be unlocked without holding cache lock
+ $self->_unlock();
+ return $data;
+}
+
+sub size {
+ my Cache::File::Entry $self = shift;
+ return -s $self->{path};
+}
+
+sub remove {
+ my Cache::File::Entry $self = shift;
+
+ my $cache = $self->{cache};
+ my $key = $self->{key};
+
+ $cache->lock();
+
+ unless (-r $self->{path}) {
+ $cache->unlock();
+ return;
+ }
+
+ my $index = $cache->get_index();
+ my $index_entries = $cache->get_index_entries($key)
+ or warnings::warnif('Cache', "missing index entry for $key");
+ delete $$index{$key};
+
+ if ($$index_entries{age}) {
+ my $ageheap = $cache->get_age_heap();
+ $ageheap->delete($$index_entries{age}, $key);
+ }
+
+ if ($$index_entries{lastuse}) {
+ my $useheap = $cache->get_use_heap();
+ $useheap->delete($$index_entries{lastuse}, $key);
+ }
+
+ if ($$index_entries{expiry}) {
+ my $expheap = $cache->get_exp_heap();
+ $expheap->delete($$index_entries{expiry}, $key)
+ }
+
+ my $size = 0;
+ if ($self->_trylock(LOCK_SH)) {
+ $size = (-s $self->{path});
+ $cache->change_size(-$size);
+ $self->_unlock();
+ }
+ $cache->change_count(-1);
+
+ unlink($self->{path});
+
+ # obliterate any entry lockfile
+ unlink($self->{path} . $Cache::File::LOCK_EXT);
+ delete $PROCESS_LOCKS{$self->{path}};
+
+ $cache->unlock();
+
+ return $size;
+}
+
+sub expiry {
+ my Cache::File::Entry $self = shift;
+ my $cache = $self->{cache};
+
+ $cache->lock();
+ my $index_entries = $cache->get_index_entries($self->{key});
+ $cache->unlock();
+ return $index_entries? $$index_entries{expiry} : undef;
+}
+
+sub _set_expiry {
+ my Cache::File::Entry $self = shift;
+ my ($time) = @_;
+
+ my $cache = $self->{cache};
+ my $key = $self->{key};
+
+ $cache->lock();
+
+ my $index_entries = $cache->get_index_entries($key);
+
+ unless ($index_entries) {
+ $cache->unlock();
+ croak "Cannot set expiry on non-existant entry: $key";
+ }
+
+ my $expheap = $cache->get_exp_heap();
+ $expheap->delete($$index_entries{expiry}, $key)
+ if $$index_entries{expiry};
+ $expheap->add($time, $key) if $time;
+
+ $$index_entries{expiry} = $time;
+ $cache->set_index_entries($key, $index_entries);
+
+ $cache->unlock();
+}
+
+sub _handle {
+ my Cache::File::Entry $self = shift;
+ my ($mode, $expiry) = @_;
+
+ # a bit of magic! Since handles hold a lock indefinitely, and the entry
+ # lock code doesn't do recursion (its not necessary) we could get into
+ # trouble. So instead we just ensure that every handle has it's own entry
+ # associated with it.
+ $self = $self->{cache}->entry($self->{key});
+
+ require Cache::File::Handle;
+
+ my $exists = -e $self->{path};
+ my $writing = $mode =~ />|\+/;
+
+ unless ($exists) {
+ # return undef unless we're writing a new entry
+ $writing or return undef;
+
+ # make the path
+ $self->_make_path();
+ }
+
+ my $time = time();
+ my $cache = $self->{cache};
+ my $key = $self->{key};
+
+ # lock indexes
+ $cache->lock();
+
+ # grab entry lock
+ $self->_lock($writing? LOCK_EX : LOCK_SH);
+
+ # create the attributes if the entry doesn't exist
+ unless ($exists) {
+ # we're creating the entry
+ $cache->create_entry($key, $time);
+ $cache->change_count(1);
+ }
+
+ # if truncating, reset expiry (or set it creating and its specified)
+ $cache->set_expiry($key, $expiry)
+ if ($expiry and not $exists) or ($mode =~/\+?>/);
+ $cache->update_last_use($key, $time) if $exists;
+
+ my $orig_size = $writing? ($exists? $self->size() : 0) : undef;
+
+ # open handle - entry lock will be held as self persists in the closure
+ my $oldmask = umask $cache->cache_umask();
+ my $handle = Cache::File::Handle->new($self->{path}, $mode, undef,
+ sub { $self->_handle_closed(shift, $orig_size); } );
+ umask $oldmask;
+
+ $handle or warnings::warnif('io', 'Failed to open '.$self->{path}.": $!");
+
+ $cache->unlock();
+
+ return $handle;
+}
+
+
+sub validity {
+ my Cache::File::Entry $self = shift;
+
+ my $cache = $self->{cache};
+ $cache->lock();
+
+ my $index_entries = $cache->get_index_entries($self->{key});
+
+ $cache->unlock();
+
+ return $index_entries? $$index_entries{validity} : undef;
+}
+
+sub set_validity {
+ my Cache::File::Entry $self = shift;
+ my ($data) = @_;
+
+ my $key = $self->{key};
+ my $cache = $self->{cache};
+ $cache->lock();
+
+ my $index_entries = $cache->get_index_entries($key);
+
+ unless ($index_entries) {
+ $self->set('');
+ $index_entries = $cache->get_index_entries($key);
+ }
+
+ $$index_entries{validity} = $data;
+ $cache->set_index_entries($key, $index_entries);
+
+ $cache->unlock();
+}
+
+
+# UTILITY METHODS
+
+sub _handle_closed {
+ my Cache::File::Entry $self = shift;
+ my ($handle, $orig_size) = @_;
+
+ unless (defined $orig_size) {
+ # shared locks can be unlocked without holding cache lock
+ $self->_unlock();
+ return;
+ }
+
+ my $cache = $self->{cache};
+
+ $cache->lock();
+
+ # check if file still exists and our lock is still valid. this order is
+ # used to prevent a race between checking lock and getting size
+ my $new_size = $self->size();
+ (defined $new_size and $self->_check_lock()) or $new_size = 0;
+
+ # release entry lock
+ $self->_unlock();
+
+ # update sizes
+ if (defined $orig_size and $orig_size != $new_size) {
+ $cache->change_size($new_size - $orig_size);
+ }
+
+ $cache->unlock();
+}
+
+sub _make_path {
+ my Cache::File::Entry $self = shift;
+
+ unless (-d $self->{dir}) {
+ my $oldmask = umask $self->{cache}->cache_umask();
+
+ eval { mkpath($self->{dir}); };
+ if ($@) {
+ warnings::warnif('io',
+ 'Failed to create path '.$self->{dir}.": $@");
+ return 0;
+ }
+
+ umask $oldmask;
+ }
+
+ return 1;
+}
+
+sub _lock {
+ my Cache::File::Entry $self = shift;
+ my ($type, $tryonly) = @_;
+ $type ||= LOCK_EX;
+
+ # entry already has the lock?
+ $self->{lockdetails} and die "entry already holding a lock";
+
+ my $path = $self->{path};
+ my $lock_details = $PROCESS_LOCKS{$path};
+
+ if ($lock_details) {
+ if ($$lock_details{type} != $type) {
+ $tryonly and return 0;
+ croak "process already holding entry lock of different type";
+ }
+ $$lock_details{count}++;
+ $self->{lockdetails} = $lock_details;
+ return 1;
+ }
+
+ # create new entry
+ $lock_details = $PROCESS_LOCKS{$path} = {};
+
+ # no need for any locking with LOCK_NONE
+ if ($self->{cache}->cache_lock_level() != Cache::File::LOCK_NONE()) {
+ local $File::NFSLock::LOCK_EXTENSION = $Cache::File::LOCK_EXT;
+ my $oldmask = umask $self->{cache}->cache_umask();
+
+ my $lock = File::NFSLock->new({
+ file => $path,
+ lock_type => $type | ($tryonly? LOCK_NB : 0),
+ stale_lock_timeout => $Cache::File::STALE_LOCK_TIMEOUT,
+ });
+
+ unless ($lock) {
+ umask $oldmask;
+ $tryonly and return 0;
+ die "Failed to obtain lock on lockfile on '$path': ".
+ $File::NFSLock::errstr."\n";
+ }
+
+ # count the number of hard links to the lockfile and open it
+ # if we can't reopen the lockfile then it has already been removed...
+ # we do the stat on the file rather than the filehandle, as otherwise
+ # there would be a race between opening the file and getting the link
+ # count (such that we could end up with a link count that is already 0).
+ my $fh = Symbol::gensym;
+ my $linkcount;
+ my $lockfile = $path . $Cache::File::LOCK_EXT;
+ if (($linkcount = (stat $lockfile)[3]) and open($fh, $lockfile)) {
+ $$lock_details{lock} = $lock;
+ $$lock_details{lockfh} = $fh;
+ $$lock_details{linkcount} = $linkcount;
+ }
+ else {
+ # lock failed - remove lock details
+ delete $PROCESS_LOCKS{$path};
+ }
+ umask $oldmask;
+ }
+
+ # lock obtained
+
+ $$lock_details{type} = $type;
+ $$lock_details{count} = 1;
+
+ # use lock details reference as an internal lock check
+ $self->{lockdetails} = $lock_details;
+
+ return 1;
+}
+
+sub _trylock {
+ my Cache::File::Entry $self = shift;
+ my ($type) = @_;
+ return $self->_lock($type, 1);
+}
+
+sub _unlock {
+ my Cache::File::Entry $self = shift;
+
+ $self->{lockdetails} or die 'not locked';
+
+ # is our lock still valid?
+ $self->_check_lock() or return;
+
+ $self->{lockdetails} = undef;
+
+ my $lock_details = $PROCESS_LOCKS{$self->{path}};
+ --$$lock_details{count} == 0
+ or return;
+
+ if ($self->{cache}->cache_lock_level() != Cache::File::LOCK_NONE()) {
+ $$lock_details{lock}->unlock;
+ }
+ delete $PROCESS_LOCKS{$self->{path}};
+}
+
+# check that we still hold our lock
+sub _check_lock {
+ my Cache::File::Entry $self = shift;
+
+ $self->{lockdetails} or return 0;
+ my $lock_details = $PROCESS_LOCKS{$self->{path}}
+ or return 0;
+
+ # check lock details reference still matches global
+ $self->{lockdetails} == $lock_details
+ or return 0;
+
+ if ($self->{cache}->cache_lock_level() != Cache::File::LOCK_NONE()) {
+ # check filehandle is still connected to filesystem
+ my $lockfh = $$lock_details{lockfh};
+ if (((stat $lockfh)[3] || 0) < $$lock_details{linkcount}) {
+ # lock is gone
+ delete $PROCESS_LOCKS{$self->{path}};
+ return 0;
+ }
+ }
+
+ return 1;
+}
+
+
+1;
+__END__
+
+=head1 SEE ALSO
+
+Cache::Entry, Cache::File
+
+=head1 AUTHOR
+
+ Chris Leishman <chris at leishman.org>
+ Based on work by DeWitt Clinton <dewitt at unto.net>
+
+=head1 COPYRIGHT
+
+ Copyright (C) 2003-2006 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: Entry.pm,v 1.8 2006/01/31 15:23:58 caleishm Exp $
+
+=cut
diff --git a/lib/Cache/File/Handle.pm b/lib/Cache/File/Handle.pm
new file mode 100644
index 0000000..0a3eda3
--- /dev/null
+++ b/lib/Cache/File/Handle.pm
@@ -0,0 +1,80 @@
+=head1 NAME
+
+Cache::File::Handle - wrapper for IO::File to use in Cache::File implementation
+
+=head1 DESCRIPTION
+
+This module implements a derived class of IO::File that allows callback on
+close. It is for use by Cache::File and should not be used directly.
+
+=cut
+package Cache::File::Handle;
+
+require 5.006;
+use strict;
+use warnings;
+use IO::File;
+
+our @ISA = qw(IO::File);
+
+
+sub new {
+ my $proto = shift;
+ my $class = ref($proto) || $proto;
+ my ($filename, $mode, $perms, $close_callback) = @_;
+
+ my $self = $class->SUPER::new($filename, $mode, $perms)
+ or return undef;
+ bless $self, $class;
+ *$self->{_cache_close_callback} = $close_callback;
+
+ return $self;
+}
+
+sub open {
+ my $self = shift;
+ my ($filename, $mode, $perms, $close_callback) = @_;
+
+ *$self->{_cache_close_callback} = $close_callback;
+
+ return $self->SUPER::open($filename, $mode, $perms);
+}
+
+sub close {
+ my $self = shift;
+ $self->flush;
+ *$self->{_cache_close_callback}->($self) if *$self->{_cache_close_callback};
+ delete *$self->{_cache_close_callback};
+ $self->SUPER::close(@_);
+}
+
+sub DESTROY {
+ my $self = shift;
+ *$self->{_cache_close_callback}->($self) if *$self->{_cache_close_callback};
+ #$self->SUPER::DESTROY();
+}
+
+
+1;
+__END__
+
+=head1 SEE ALSO
+
+Cache::File
+
+=head1 AUTHOR
+
+ Chris Leishman <chris at leishman.org>
+ Based on work by DeWitt Clinton <dewitt at unto.net>
+
+=head1 COPYRIGHT
+
+ Copyright (C) 2003-2006 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: Handle.pm,v 1.4 2006/01/31 15:23:58 caleishm Exp $
+
+=cut
diff --git a/lib/Cache/File/Heap.pm b/lib/Cache/File/Heap.pm
new file mode 100644
index 0000000..1a5d9d5
--- /dev/null
+++ b/lib/Cache/File/Heap.pm
@@ -0,0 +1,261 @@
+=head1 NAME
+
+Cache::File::Heap - A file based heap for use by Cache::File
+
+=head1 SYNOPSIS
+
+ use Cache::File::Heap;
+
+ $heap = Cache::File::Heap->new('/path/to/some/heap/file');
+ $heap->add($key, $val);
+ ($key, $val) = $heap->minimum;
+ ($key, $val) = $heap->extract_minimum;
+ $heap->delete($key, $val);
+
+=head1 DESCRIPTION
+
+This module is a wrapper around a Berkeley DB using a btree structure to
+implement a heap. It is specifically for use by Cache::File for storing
+expiry times (although with a bit of work it could be made more general).
+
+See LIMITATIONS below.
+
+=cut
+package Cache::File::Heap;
+
+require 5.006;
+use strict;
+use warnings;
+use DB_File;
+use Carp;
+
+use fields qw(db dbhash);
+
+our $VERSION = '2.04';
+
+# common info object
+my $BTREEINFO = new DB_File::BTREEINFO;
+$BTREEINFO->{compare} = \&_Num_Compare;
+$BTREEINFO->{flags} = R_DUP;
+
+
+=head1 CONSTRUCTOR
+
+ my $heap = Cache::File::Heap->new( [$dbfile] );
+
+The heap constructor takes an optional argument which is the name of the
+database file to open. If specified, it will attempt to open the database
+during construction. A new Cache::File::Heap blessed reference will be
+returned, or undef if the open failed.
+
+=cut
+
+sub new {
+ my Cache::File::Heap $self = shift;
+
+ $self = fields::new($self) unless ref $self;
+
+ if (@_) {
+ $self->open(@_) or return undef;
+ }
+
+ return $self;
+}
+
+
+=head1 METHODS
+
+=over
+
+=item $h->open($dbfile)
+
+Opens the specified database file.
+
+=cut
+
+sub open {
+ my Cache::File::Heap $self = shift;
+ my ($dbfile) = @_;
+
+ $self->close();
+
+ my %dbhash;
+ my $db = tie %dbhash, 'DB_File', $dbfile, O_CREAT|O_RDWR, 0666, $BTREEINFO
+ or return undef;
+
+ $self->{db} = $db;
+ $self->{dbhash} = \%dbhash;
+
+ return 1;
+}
+
+=item $h->close()
+
+Closes a previously opened heap database. Note that the database will be
+automatically closed when the heap reference is destroyed.
+
+=cut
+
+sub close {
+ my Cache::File::Heap $self = shift;
+ $self->{db} = undef;
+ untie %{$self->{dbhash}};
+ $self->{dbhash} = undef;
+}
+
+=item $h->add($key, $val)
+
+Adds a key and value pair to the heap. Currently the key should be a number,
+whilst the value may be any scalar. Invokes 'die' on failure (use eval to
+catch it).
+
+=cut
+
+sub add {
+ my Cache::File::Heap $self = shift;
+ my ($key, $val) = @_;
+ defined $key or croak "key undefined";
+ defined $val or croak "value undefined";
+ # return code from DB_File is 0 on success.....
+ $self->_db->put($key, $val) and die "Heap add failed: $@";
+}
+
+=item $h->delete($key, $val)
+
+Removes a key and value pair from the heap. Returns 1 if the pair was found
+and removed, or 0 otherwise.
+
+=cut
+
+sub delete {
+ my Cache::File::Heap $self = shift;
+ my ($key, $val) = @_;
+ defined $key or croak "key undefined";
+ defined $val or croak "value undefined";
+ # return code from DB_File is 0 on success.....
+ $self->_db->del_dup($key, $val) and return 0;
+ return 1;
+}
+
+=item ($key, $val) = $h->minimum()
+
+In list context, returns the smallest key and value pair from the heap. In
+scalar context only the key is returned. Note smallest is defined via a
+numerical comparison (hence keys should always be numbers).
+
+=cut
+
+sub minimum {
+ my Cache::File::Heap $self = shift;
+ my ($key, $val) = (0,0);
+ $self->_db->seq($key, $val, R_FIRST)
+ and return undef;
+ return wantarray? ($key, $val) : $key;
+}
+
+=item ($key, $vals) = $h->minimum_dup()
+
+In list context, returns the smallest key and an array reference containing
+all the values for that key from the heap. In scalar context only the key is
+returned.
+
+=cut
+
+sub minimum_dup {
+ my Cache::File::Heap $self = shift;
+ my $db = $self->_db;
+ my ($key, $val) = (0,0);
+ $db->seq($key, $val, R_FIRST)
+ and return undef;
+ return wantarray? ($key, [ $db->get_dup($key) ]) : $key;
+}
+
+=item ($key, $val) = $h->extract_minimum()
+
+As for $h->minimum(), but the key and value pair is removed from the heap.
+
+=cut
+
+sub extract_minimum {
+ my Cache::File::Heap $self = shift;
+ my $db = $self->_db;
+ my ($key, $val) = (0,0);
+ $db->seq($key, $val, R_FIRST)
+ and return undef;
+ $db->del_dup($key, $val);
+ return wantarray? ($key, $val) : $key;
+}
+
+=item ($key, $vals) = $h->extract_minimum_dup()
+
+As for $h->minimum_dup(), but all the values are removed from the heap.
+
+=cut
+
+sub extract_minimum_dup {
+ my Cache::File::Heap $self = shift;
+ my $db = $self->_db;
+ my ($key, $val) = (0,0);
+ $db->seq($key, $val, R_FIRST)
+ and return undef;
+ my @values = $db->get_dup($key) if wantarray;
+ $db->del($key);
+ # bugfix for broken db1 - not all values are removed the first time
+ $db->del($key);
+ return wantarray? ($key, \@values) : $key;
+}
+
+=back
+
+=cut
+
+
+sub _db {
+ my Cache::File::Heap $self = shift;
+ my $db = $self->{db};
+ croak "Heap not opened" unless $db;
+}
+
+sub _Num_Compare {
+ my ($key1, $key2) = @_;
+
+ # somehow we can get undefined keys here? Probably a db bug.
+
+ if (not defined $key1 and not defined $key2) {
+ return 0
+ }
+ elsif (defined $key1 and not defined $key2) {
+ return 1;
+ }
+ elsif (not defined $key1 and defined $key2) {
+ return -1;
+ }
+ else {
+ return $key1 <=> $key2;
+ }
+}
+
+
+1;
+__END__
+
+=head1 SEE ALSO
+
+Cache::File
+
+=head1 AUTHOR
+
+ Chris Leishman <chris at leishman.org>
+ Based on work by DeWitt Clinton <dewitt at unto.net>
+
+=head1 COPYRIGHT
+
+ Copyright (C) 2003-2006 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: Heap.pm,v 1.6 2006/01/31 15:23:58 caleishm Exp $
+
+=cut
diff --git a/lib/Cache/IOString.pm b/lib/Cache/IOString.pm
new file mode 100644
index 0000000..ceeda7b
--- /dev/null
+++ b/lib/Cache/IOString.pm
@@ -0,0 +1,152 @@
+=head1 NAME
+
+Cache::IOString - wrapper for IO::String to use in Cache implementations
+
+=head1 DESCRIPTION
+
+This module implements a derived class of IO::String that handles access
+modes and allows callback on close. It is for use by Cache implementations
+and should not be used directly.
+
+=cut
+package Cache::IOString;
+
+require 5.006;
+use strict;
+use warnings;
+use IO::String;
+
+our @ISA = qw(IO::String);
+
+
+sub open {
+ my $self = shift;
+ my ($dataref, $mode, $close_callback) = @_;
+ return $self->new(@_) unless ref($self);
+
+ # check mode
+ my $read;
+ my $write;
+ if ($mode =~ /^\+?>>?$/) {
+ $write = 1;
+ $read = 1 if $mode =~ /^\+/;
+ }
+ elsif ($mode =~ /^\+?<$/) {
+ $read = 1;
+ $write = 1 if $mode =~ /^\+/;
+ }
+
+ $self->SUPER::open($dataref);
+
+ *$self->{_cache_read} = $read;
+ *$self->{_cache_write} = $write;
+ *$self->{_cache_close_callback} = $close_callback;
+
+ if ($write) {
+ if ($mode =~ /^\+?>>$/) {
+ # append
+ $self->seek(0, 2);
+ }
+ elsif ($mode =~ /^\+?>$/) {
+ # truncate
+ $self->truncate(0);
+ }
+ }
+
+ return $self;
+}
+
+sub close {
+ my $self = shift;
+ delete *$self->{_cache_read};
+ delete *$self->{_cache_write};
+ *$self->{_cache_close_callback}->($self) if *$self->{_cache_close_callback};
+ delete *$self->{_cache_close_callback};
+ $self->SUPER::close(@_);
+}
+
+sub DESTROY {
+ my $self = shift;
+ *$self->{_cache_close_callback}->($self) if *$self->{_cache_close_callback};
+}
+
+sub pad {
+ my $self = shift;
+ return undef unless *$self->{_cache_write};
+ return $self->SUPER::pad(@_);
+}
+
+sub getc {
+ my $self = shift;
+ return undef unless *$self->{_cache_read};
+ return $self->SUPER::getc(@_);
+}
+
+sub ungetc {
+ my $self = shift;
+ return undef unless *$self->{_cache_read};
+ return $self->SUPER::ungetc(@_);
+}
+
+sub seek {
+ my $self = shift;
+ # call setpos if not writing to ensure a seek past the end doesn't extend
+ # the string. Probably should really return undef in that situation.
+ return $self->SUPER::setpos(@_) unless *$self->{_cache_write};
+ return $self->SUPER::seek(@_);
+}
+
+sub getline {
+ my $self = shift;
+ return undef unless *$self->{_cache_read};
+ return $self->SUPER::getline(@_);
+}
+
+sub truncate {
+ my $self = shift;
+ return undef unless *$self->{_cache_write};
+ return $self->SUPER::truncate(@_);
+}
+
+sub read {
+ my $self = shift;
+ return undef unless *$self->{_cache_read};
+ return $self->SUPER::read(@_);
+}
+
+sub write {
+ my $self = shift;
+ return undef unless *$self->{_cache_write};
+ return $self->SUPER::write(@_);
+}
+
+*GETC = \&getc;
+*READ = \&read;
+*WRITE = \&write;
+*SEEK = \&seek;
+*CLOSE = \&close;
+
+
+1;
+__END__
+
+=head1 SEE ALSO
+
+Cache::Entry, Cache::File, Cache::RemovalStrategy
+
+=head1 AUTHOR
+
+ Chris Leishman <chris at leishman.org>
+ Based on work by DeWitt Clinton <dewitt at unto.net>
+
+=head1 COPYRIGHT
+
+ Copyright (C) 2003-2006 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: IOString.pm,v 1.3 2006/01/31 15:23:58 caleishm Exp $
+
+=cut
diff --git a/lib/Cache/Memory.pm b/lib/Cache/Memory.pm
new file mode 100644
index 0000000..192c2ab
--- /dev/null
+++ b/lib/Cache/Memory.pm
@@ -0,0 +1,372 @@
+=head1 NAME
+
+Cache::Memory - Memory based implementation of the Cache interface
+
+=head1 SYNOPSIS
+
+ use Cache::Memory;
+
+ my $cache = Cache::Memory->new( namespace => 'MyNamespace',
+ default_expires => '600 sec' );
+
+See Cache for the usage synopsis.
+
+=head1 DESCRIPTION
+
+The Cache::Memory class implements the Cache interface. This cache stores
+data on a per-process basis. This is the fastest of the cache
+implementations, but is memory intensive and data can not be shared between
+processes. It also does not persist after the process dies. However data will
+remain in the cache until cleared or it expires. The data will be shared
+between instances of the cache object, a cache object going out of scope will
+not destroy the data.
+
+=cut
+package Cache::Memory;
+
+require 5.006;
+use strict;
+use warnings;
+use Heap::Fibonacci;
+use Cache::Memory::HeapElem;
+use Cache::Memory::Entry;
+
+use base qw(Cache);
+use fields qw(namespace);
+
+our $VERSION = '2.04';
+
+
+# storage for all data
+# data is stored in the form:
+# $Store{ns}{key}{data,exp_elem,age_elem,use_elem,rc,validity,handlelock}
+#
+# Cache::Memory::Entry elements will be passed the final hash as a reference
+# when they are constructed. This reference MUST point to the SAME hash for
+# all entries (and also must be the hash in Store{ns}{key}) or data
+# inconsistency will occur. However this means that the key has to persist in
+# the store whilst entries exist - regardless of whether there is data stored
+# in it or not. In order to allow the Store{ns}{key} to be safely removed, a
+# 'rc' field is used to track the number of entries that have been created for
+# the key.
+my %Store;
+
+# store sizes
+my %Store_Sizes;
+
+# heaps for all the different orderings
+# Expiry_Heap is shared between all namespaces
+my Heap $Expiry_Heap = Heap::Fibonacci->new();
+# In the form $Age_Heaps{namespace} and $Use_Heaps{namespace}
+my %Age_Heaps;
+my %Use_Heaps;
+
+
+my $DEFAULT_NAMESPACE = '_';
+
+
+=head1 CONSTRUCTOR
+
+ my $cache = Cache::Memory->new( %options )
+
+The constructor takes cache properties as named arguments, for example:
+
+ my $cache = Cache::Memory->new( namespace => 'MyNamespace',
+ default_expires => '600 sec' );
+
+See 'PROPERTIES' below and in the Cache documentation for a list of all
+available properties that can be set.
+
+=cut
+
+sub new {
+ my Cache::Memory $self = shift;
+ my $args = $#_? { @_ } : shift;
+
+ $self = fields::new($self) unless ref $self;
+ $self->SUPER::new($args);
+
+ my $ns = $args->{namespace} || $DEFAULT_NAMESPACE;
+ $self->{namespace} = $ns;
+
+ # init heaps
+ $Age_Heaps{$ns} ||= Heap::Fibonacci->new();
+ $Use_Heaps{$ns} ||= Heap::Fibonacci->new();
+
+ return $self;
+}
+
+=head1 METHODS
+
+See 'Cache' for the API documentation.
+
+=cut
+
+sub entry {
+ my Cache::Memory $self = shift;
+ my ($key) = @_;
+ my $ns = $self->{namespace};
+
+ $Store{$ns}{$key} ||= {};
+ return Cache::Memory::Entry->new($self, $key, $Store{$ns}{$key});
+}
+
+sub purge {
+ #my Cache::Memory $self = shift;
+ my $time = time();
+ while (my $minimum = $Expiry_Heap->minimum) {
+ $minimum->val() <= $time
+ or last;
+ $Expiry_Heap->extract_minimum;
+
+ my $min_key = $minimum->key();
+ my $min_ns = $minimum->namespace();
+
+ my $store_entry = $Store{$min_ns}{$min_key};
+
+ $minimum == delete $store_entry->{exp_elem}
+ or die 'Cache::Memory data structure(s) corrupted';
+
+ # there should always be an age element
+ my $age_elem = delete $store_entry->{age_elem}
+ or die 'Cache::Memory data structure(s) corrupted';
+ $Age_Heaps{$min_ns}->delete($age_elem);
+
+ # there should always be a last use element
+ my $use_elem = delete $store_entry->{use_elem}
+ or die 'Cache::Memory data structure(s) corrupted';
+ $Use_Heaps{$min_ns}->delete($use_elem);
+
+ # remove data & decrease store size
+ $Store_Sizes{$min_ns} -= length(${delete $store_entry->{data}});
+
+ # remove entire entry if there are no active Entry objects
+ delete $Store{$min_ns}{$min_key} unless $store_entry->{rc};
+ }
+}
+
+sub clear {
+ my Cache::Memory $self = shift;
+ my $ns = $self->{namespace};
+
+ # empty store & remove elements from expiry heap
+ my $nsstore = $Store{$ns};
+ foreach my $key (keys %$nsstore) {
+ my $store_entry = $nsstore->{$key};
+
+ # simplified form of remove (doesn't deal with heaps)
+ my $exp_elem = delete $store_entry->{exp_elem};
+ $Expiry_Heap->delete($exp_elem) if $exp_elem;
+ delete $store_entry->{age_elem};
+ delete $store_entry->{use_elem};
+ delete $store_entry->{data};
+
+ # remove entire entry if there are no active Entry objects
+ delete $nsstore->{$key} unless $store_entry->{rc};
+ }
+
+ # reset store size
+ $Store_Sizes{$ns} = 0;
+
+ # recreate age and used heaps (thus emptying them)
+ $Age_Heaps{$ns} = Heap::Fibonacci->new();
+ $Use_Heaps{$ns} = Heap::Fibonacci->new();
+}
+
+sub count {
+ my Cache::Memory $self = shift;
+ my $count = 0;
+ my $nsstore = $Store{$self->{namespace}};
+ foreach my $key (keys %$nsstore) {
+ $count++ if defined $nsstore->{$key}->{data};
+ }
+ return $count;
+}
+
+sub size {
+ my Cache::Memory $self = shift;
+ return $Store_Sizes{$self->{namespace}} || 0;
+}
+
+
+=head1 PROPERTIES
+
+Cache::Memory adds the property 'namespace', which allows you to specify a
+different caching store area to use from the default. All methods will work
+ONLY on the namespace specified.
+
+ my $ns = $c->namespace();
+ $c->set_namespace( $namespace );
+
+For additional properties, see the 'Cache' documentation.
+
+=cut
+
+sub namespace {
+ my Cache::Memory $self = shift;
+ return $self->{namespace};
+}
+
+sub set_namespace {
+ my Cache::Memory $self = shift;
+ my ($namespace) = @_;
+ $self->{namespace} = $namespace;
+}
+
+
+# REMOVAL STRATEGY METHODS
+
+sub remove_oldest {
+ my Cache::Memory $self = shift;
+ my $minimum = $Age_Heaps{$self->{namespace}}->minimum
+ or return undef;
+ $minimum == $Store{$minimum->namespace()}{$minimum->key()}{age_elem}
+ or die 'Cache::Memory data structure(s) corrupted';
+ return $self->remove($minimum->key());
+}
+
+sub remove_stalest {
+ my Cache::Memory $self = shift;
+ my $minimum = $Use_Heaps{$self->{namespace}}->minimum
+ or return undef;
+ $minimum == $Store{$minimum->namespace()}{$minimum->key()}{use_elem}
+ or die 'Cache::Memory data structure(s) corrupted';
+ return $self->remove($minimum->key());
+}
+
+
+# SHORTCUT METHODS
+
+sub remove {
+ my Cache::Memory $self = shift;
+ my ($key) = @_;
+
+ my $ns = $self->{namespace};
+
+ my $store_entry = $Store{$ns}{$key}
+ or return undef;
+
+ defined $store_entry->{data}
+ or return undef;
+
+ # remove from heap
+ my $exp_elem = delete $store_entry->{exp_elem};
+ $Expiry_Heap->delete($exp_elem) if $exp_elem;
+
+ my $age_elem = delete $store_entry->{age_elem}
+ or die 'Cache::Memory data structure(s) corrupted';
+ $Age_Heaps{$ns}->delete($age_elem);
+
+ my $use_elem = delete $store_entry->{use_elem}
+ or die 'Cache::Memory data structure(s) corrupted';
+ $Use_Heaps{$ns}->delete($use_elem);
+
+ # reduce size of cache iff there is no active handle
+ my $size = 0;
+ my $dataref = delete $store_entry->{data};
+ unless (exists $store_entry->{handlelock}) {
+ $size = length($$dataref);
+ $Store_Sizes{$ns} -= $size;
+ }
+
+ delete $store_entry->{handlelock};
+
+ # remove entire entry if there are no active Entry objects
+ delete $Store{$ns}{$key} unless $store_entry->{rc};
+
+ return $size;
+}
+
+
+# UTILITY METHODS
+
+sub add_expiry_to_heap {
+ my Cache::Memory $self = shift;
+ my ($key, $time) = @_;
+
+ my $exp_elem = Cache::Memory::HeapElem->new($self->{namespace},$key,$time);
+ $Expiry_Heap->add($exp_elem);
+ return $exp_elem;
+}
+
+sub del_expiry_from_heap {
+ my Cache::Memory $self = shift;
+ my ($key, $exp_elem) = @_;
+
+ $Expiry_Heap->delete($exp_elem);
+}
+
+sub add_age_to_heap {
+ my Cache::Memory $self = shift;
+ my ($key, $time) = @_;
+ my $ns = $self->{namespace};
+
+ my $age_elem = Cache::Memory::HeapElem->new($ns,$key,$time);
+ $Age_Heaps{$ns}->add($age_elem);
+ return $age_elem;
+}
+
+sub add_use_to_heap {
+ my Cache::Memory $self = shift;
+ my ($key, $time) = @_;
+ my $ns = $self->{namespace};
+
+ my $use_elem = Cache::Memory::HeapElem->new($ns,$key,$time);
+ $Use_Heaps{$ns}->add($use_elem);
+ return $use_elem;
+}
+
+sub update_last_used {
+ my Cache::Memory $self = shift;
+ my ($key) = @_;
+ my $ns = $self->{namespace};
+
+ my $use_elem = $Store{$ns}{$key}{use_elem}
+ or die 'Cache::Memory data structure(s) corrupted';
+
+ $Use_Heaps{$ns}->delete($use_elem);
+ $use_elem->val(time());
+ $Use_Heaps{$ns}->add($use_elem);
+}
+
+sub change_size {
+ my Cache::Memory $self = shift;
+ my ($size) = @_;
+ my $ns = $self->{namespace};
+
+ $Store_Sizes{$ns} += $size;
+ $self->check_size($Store_Sizes{$ns}) if $size > 0;
+}
+
+sub entry_dropped_final_rc {
+ my Cache::Memory $self = shift;
+ my ($key) = @_;
+ my $ns = $self->{namespace};
+
+ delete $Store{$ns}{$key} unless defined $Store{$ns}{$key}{data};
+}
+
+
+1;
+__END__
+
+=head1 SEE ALSO
+
+Cache
+
+=head1 AUTHOR
+
+ Chris Leishman <chris at leishman.org>
+ Based on work by DeWitt Clinton <dewitt at unto.net>
+
+=head1 COPYRIGHT
+
+ Copyright (C) 2003-2006 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: Memory.pm,v 1.9 2006/01/31 15:23:58 caleishm Exp $
+
+=cut
diff --git a/lib/Cache/Memory/Entry.pm b/lib/Cache/Memory/Entry.pm
new file mode 100644
index 0000000..7e0f5e7
--- /dev/null
+++ b/lib/Cache/Memory/Entry.pm
@@ -0,0 +1,288 @@
+=head1 NAME
+
+Cache::Memory::Entry - An entry in the memory based implementation of Cache
+
+=head1 SYNOPSIS
+
+ See 'Cache::Entry' for a synopsis.
+
+=head1 DESCRIPTION
+
+This module implements a version of Cache::Entry for the Cache::Memory variant
+of Cache. It should not be created or used directly, please see
+'Cache::Memory' or 'Cache::Entry' instead.
+
+=cut
+package Cache::Memory::Entry;
+
+require 5.006;
+use strict;
+use warnings;
+use Cache::Memory;
+use Storable;
+use Carp;
+
+use base qw(Cache::Entry);
+use fields qw(store_entry);
+
+our $VERSION = '2.04';
+
+
+sub new {
+ my Cache::Memory::Entry $self = shift;
+ my ($cache, $key, $entry) = @_;
+
+ $self = fields::new($self) unless ref $self;
+ $self->SUPER::new($cache, $key);
+
+ $self->{store_entry} = $entry;
+
+ # increment the reference count for the entry
+ $entry->{rc}++;
+
+ return $self;
+}
+
+sub DESTROY {
+ my Cache::Memory::Entry $self = shift;
+
+ # drop the reference count and signal the cache if required
+ unless (--$self->{store_entry}->{rc}) {
+ $self->{cache}->entry_dropped_final_rc($self->{key});
+ }
+}
+
+sub exists {
+ my Cache::Memory::Entry $self = shift;
+
+ # ensure pending expiries are removed
+ $self->{cache}->purge();
+
+ return defined $self->{store_entry}->{data};
+}
+
+sub _set {
+ my Cache::Memory::Entry $self = shift;
+ my ($data, $expiry) = @_;
+
+ my $cache = $self->{cache};
+ my $key = $self->{key};
+ my $entry = $self->{store_entry};
+
+ my $exists = defined $entry->{data};
+ my $orig_size;
+
+ unless ($exists) {
+ # we're creating the element
+ my $time = time();
+
+ $entry->{age_elem} = $cache->add_age_to_heap($key, $time);
+ $entry->{use_elem} = $cache->add_use_to_heap($key, $time);
+ $orig_size = 0;
+ }
+ elsif (not exists $entry->{handlelock}) {
+ # only remove current size if there is no active handle
+ $orig_size = length(${$entry->{data}});
+ }
+ else {
+ $orig_size = 0;
+ }
+
+ $entry->{data} = \$data;
+
+ # invalidate any active handles
+ delete $entry->{handlelock};
+
+ $self->_set_expiry($expiry) if $expiry or $exists;
+ $cache->update_last_used($key) if $exists;
+
+ $cache->change_size(length($data) - $orig_size);
+ # ensure pending expiries are removed;
+ $cache->purge();
+}
+
+sub _get {
+ my Cache::Memory::Entry $self = shift;
+
+ $self->exists() or return undef;
+
+ my $entry = $self->{store_entry};
+
+ $entry->{handlelock}
+ and warnings::warnif('Cache', 'get called whilst write handle is open');
+
+ $self->{cache}->update_last_used($self->{key});
+
+ return ${$self->{store_entry}->{data}};
+}
+
+sub size {
+ my Cache::Memory::Entry $self = shift;
+ defined $self->{store_entry}->{data}
+ or return undef;
+ return length(${$self->{store_entry}->{data}});
+}
+
+sub remove {
+ my Cache::Memory::Entry $self = shift;
+ # send remove request directly to cache object
+ return $self->{cache}->remove($self->{key});
+}
+
+sub expiry {
+ my Cache::Memory::Entry $self = shift;
+ $self->exists() or return undef;
+ my $exp_elem = $self->{store_entry}->{exp_elem}
+ or return undef;
+ return $exp_elem->val();
+}
+
+sub _set_expiry {
+ my Cache::Memory::Entry $self = shift;
+ my ($time) = @_;
+
+ my $cache = $self->{cache};
+ my $entry = $self->{store_entry};
+
+ defined $entry->{data}
+ or croak "Cannot set expiry on non-existant entry: $self->{key}";
+
+ my $exp_elem = $entry->{exp_elem};
+
+ if ($exp_elem) {
+ $cache->del_expiry_from_heap($self->{key}, $exp_elem);
+ $entry->{exp_elem} = undef;
+ }
+
+ return unless $time;
+ $entry->{exp_elem} = $cache->add_expiry_to_heap($self->{key}, $time);
+}
+
+# create a handle. The entry is 'locked' via the use of a 'handlelock'
+# element. The current data reference is reset to an empty string whilst the
+# handle is active to allow set and remove to work correctly without
+# corrupting size tracking. If set or remove are used to change the entry,
+# this is detected when the handle is closed again and the size is adjusted
+# (downwards) and the original data discarded.
+sub _handle {
+ my Cache::Memory::Entry $self = shift;
+ my ($mode, $expiry) = @_;
+
+ require Cache::IOString;
+
+ my $writing = $mode =~ />|\+/;
+ my $entry = $self->{store_entry};
+
+ # set the entry to a empty string if the entry doesn't exist or
+ # should be truncated
+ if (not defined $entry->{data} or $mode =~ /^\+?>$/) {
+ # return undef unless we're writing to the string
+ $writing or return undef;
+ $self->_set('', $expiry);
+ }
+ else {
+ $self->{cache}->update_last_used($self->{key});
+ }
+
+ my $dataref = $entry->{data};
+
+ if ($writing) {
+ exists $entry->{handlelock}
+ and croak "Write handle already active for this entry";
+
+ my $orig_size = length($$dataref);
+
+ # replace data with empty string whilst handle is active
+ $entry->{handlelock} = $dataref;
+
+ return Cache::IOString->new($dataref, $mode,
+ sub { $self->_handle_closed(shift, $orig_size); });
+ }
+ else {
+ return Cache::IOString->new($dataref, $mode);
+ }
+}
+
+sub validity {
+ my Cache::Memory::Entry $self = shift;
+ $self->exists() or return undef;
+ my $validity = $self->{store_entry}->{validity};
+ # return a clone of the validity if it's a reference
+ return Storable::dclone($validity) if ref($validity);
+ return $validity;
+}
+
+sub set_validity {
+ my Cache::Memory::Entry $self = shift;
+ my ($data) = @_;
+
+ my $entry = $self->{store_entry};
+
+ # ensure data is not undefined
+ unless (defined $entry->{data}) {
+ $self->set('');
+ }
+
+ $entry->{validity} = $data;
+}
+
+
+# UTILITY METHODS
+
+sub _handle_closed {
+ my Cache::Memory::Entry $self = shift;
+ my ($iostring, $orig_size) = @_;
+ $orig_size ||= 0;
+
+ my $dataref = $iostring->sref();
+ my $entry = $self->{store_entry};
+
+ # ensure the data hasn't been removed or been replaced
+ my $removed = !$self->exists();
+
+ # check our handle marker
+ if (defined $entry->{handlelock} and $entry->{handlelock} == $dataref) {
+ delete $entry->{handlelock};
+ }
+ else {
+ $removed = 1;
+ }
+
+ if ($removed) {
+ # remove original size and discard dataref
+ $self->{cache}->change_size(-$orig_size) if $orig_size;
+ return;
+ }
+
+ # reinsert data
+ $entry->{data} = $dataref;
+ my $new_size = length(${$entry->{data}});
+ if ($orig_size != $new_size) {
+ $self->{cache}->change_size($new_size - $orig_size);
+ }
+}
+
+
+1;
+__END__
+
+=head1 SEE ALSO
+
+Cache::Entry, Cache::Memory
+
+=head1 AUTHOR
+
+ Chris Leishman <chris at leishman.org>
+ Based on work by DeWitt Clinton <dewitt at unto.net>
+
+=head1 COPYRIGHT
+
+ Copyright (C) 2003-2006 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: Entry.pm,v 1.8 2006/01/31 15:23:58 caleishm Exp $
+
+=cut
diff --git a/lib/Cache/Memory/HeapElem.pm b/lib/Cache/Memory/HeapElem.pm
new file mode 100644
index 0000000..abf7555
--- /dev/null
+++ b/lib/Cache/Memory/HeapElem.pm
@@ -0,0 +1,73 @@
+=head1 NAME
+
+Cache::Memory::HeapElem - wrapper for Heap::Elem that stores keys
+
+=head1 DESCRIPTION
+
+For internal use by Cache::Memory only.
+
+=cut
+package Cache::Memory::HeapElem;
+
+require 5.006;
+use strict;
+use warnings;
+use Heap::Elem;
+our @ISA = qw(Heap::Elem);
+
+sub new {
+ my $class = shift;
+ my ($namespace, $key, $value) = @_;
+ return bless [ $value, $namespace, $key, undef ], $class;
+}
+
+sub val {
+ my $self = shift;
+ return @_ ? ($self->[0] = shift) : $self->[0];
+}
+
+sub namespace {
+ my $self = shift;
+ return $self->[1];
+}
+
+sub key {
+ my $self = shift;
+ return $self->[2];
+}
+
+sub heap {
+ my $self = shift;
+ return @_ ? ($self->[3] = shift) : $self->[3];
+}
+
+sub cmp {
+ my $self = shift;
+ my $other = shift;
+ return $self->[0] <=> $other->[0];
+}
+
+
+1;
+__END__
+
+=head1 SEE ALSO
+
+Cache::Memory
+
+=head1 AUTHOR
+
+ Chris Leishman <chris at leishman.org>
+ Based on work by DeWitt Clinton <dewitt at unto.net>
+
+=head1 COPYRIGHT
+
+ Copyright (C) 2003-2006 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: HeapElem.pm,v 1.4 2006/01/31 15:23:58 caleishm Exp $
+
+=cut
diff --git a/lib/Cache/Null.pm b/lib/Cache/Null.pm
new file mode 100644
index 0000000..d55426b
--- /dev/null
+++ b/lib/Cache/Null.pm
@@ -0,0 +1,124 @@
+=head1 NAME
+
+Cache::Null - Null implementation of the Cache interface
+
+=head1 SYNOPSIS
+
+ use Cache::Null;
+
+ my $cache = Cache::Null->new();
+
+See Cache for the usage synopsis.
+
+=head1 DESCRIPTION
+
+The Cache::Null class implements the Cache interface, but does not actually
+persist data. This is useful when developing and debugging a system and you
+wish to easily turn off caching. As a result, all calls return results
+indicating that there is no data stored.
+
+=cut
+package Cache::Null;
+
+require 5.006;
+use strict;
+use warnings;
+use Cache::Null::Entry;
+
+use base qw(Cache);
+use fields qw(cache_root);
+
+our $VERSION = '2.04';
+
+=head1 CONSTRUCTOR
+
+ my $cache = Cache::Null->new( %options )
+
+The constructor takes cache properties as named arguments, for example:
+
+ my $cache = Cache::Null->new( default_expires => '600 sec' );
+
+See 'PROPERTIES' below and in the Cache documentation for a list of all
+available properties that can be set. However it should be noted that all the
+existing properties, such as default_expires, have no effect in a Null cache.
+
+=cut
+
+sub new {
+ my Cache::Null $self = shift;
+ my $args = $#_? { @_ } : shift;
+
+ $self = fields::new($self) unless ref $self;
+ $self->SUPER::new($args);
+
+ return $self;
+}
+
+=head1 METHODS
+
+See 'Cache' for the API documentation.
+
+=cut
+
+sub entry {
+ my Cache::Null $self = shift;
+ my ($key) = @_;
+ return Cache::Null::Entry->new($self, $key);
+}
+
+sub purge {
+ #my Cache::Null $self = shift;
+}
+
+sub clear {
+ #my Cache::Null $self = shift;
+}
+
+sub count {
+ #my Cache::Null $self = shift;
+ return 0;
+}
+
+sub size {
+ #my Cache::Null $self = shift;
+ return 0;
+}
+
+
+# UTILITY METHODS
+
+sub remove_oldest {
+ #my Cache::Null $self = shift;
+ return undef;
+}
+
+sub remove_stalest {
+ #my Cache::Null $self = shift;
+ return undef;
+}
+
+
+
+1;
+__END__
+
+=head1 SEE ALSO
+
+Cache
+
+=head1 AUTHOR
+
+ Chris Leishman <chris at leishman.org>
+ Based on work by DeWitt Clinton <dewitt at unto.net>
+
+=head1 COPYRIGHT
+
+ Copyright (C) 2003-2006 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: Null.pm,v 1.4 2006/01/31 15:23:58 caleishm Exp $
+
+=cut
diff --git a/lib/Cache/Null/Entry.pm b/lib/Cache/Null/Entry.pm
new file mode 100644
index 0000000..b2c982b
--- /dev/null
+++ b/lib/Cache/Null/Entry.pm
@@ -0,0 +1,116 @@
+=head1 NAME
+
+Cache::Null::Entry - An entry in the Null implementation of Cache
+
+=head1 SYNOPSIS
+
+ See 'Cache::Entry' for a synopsis.
+
+=head1 DESCRIPTION
+
+This module implements a version of Cache::Entry for the Cache::Null variant
+of Cache. It should not be created or used directly, please see
+'Cache::Null' or 'Cache::Entry' instead.
+
+=cut
+package Cache::Null::Entry;
+
+require 5.006;
+use strict;
+use warnings;
+use Cache::IOString;
+
+use base qw(Cache::Entry);
+use fields qw();
+
+our $VERSION = '2.04';
+
+
+sub new {
+ my Cache::Null::Entry $self = shift;
+
+ $self = fields::new($self) unless ref $self;
+ $self->SUPER::new(@_);
+
+ return $self;
+}
+
+sub exists {
+ #my Cache::Null::Entry $self = shift;
+ return 0;
+}
+
+sub set {
+ #my Cache::Null::Entry $self = shift;
+ return;
+}
+
+sub get {
+ #my Cache::Null::Entry $self = shift;
+ return undef;
+}
+
+sub size {
+ #my Cache::Null::Entry $self = shift;
+ return undef;
+}
+
+sub remove {
+ #my Cache::Null::Entry $self = shift;
+ return;
+}
+
+sub expiry {
+ #my Cache::Null::Entry $self = shift;
+ return undef;
+}
+
+sub set_expiry {
+ #my Cache::Null::Entry $self = shift;
+ return;
+}
+
+sub _handle {
+ my Cache::Null::Entry $self = shift;
+ my ($mode) = @_;
+
+ # return undef unless writing - otherwise return a dummy handle
+ return undef unless $mode =~ />|\+/;
+ my $data = '';
+ return Cache::IOString->new(\$data, $mode);
+}
+
+sub validity {
+ #my Cache::Null::Entry $self = shift;
+ return undef;
+}
+
+sub set_validity {
+ #my Cache::Null::Entry $self = shift;
+ return;
+}
+
+
+1;
+__END__
+
+=head1 SEE ALSO
+
+Cache::Entry, Cache::Null
+
+=head1 AUTHOR
+
+ Chris Leishman <chris at leishman.org>
+ Based on work by DeWitt Clinton <dewitt at unto.net>
+
+=head1 COPYRIGHT
+
+ Copyright (C) 2003-2006 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: Entry.pm,v 1.5 2006/01/31 15:23:58 caleishm Exp $
+
+=cut
diff --git a/lib/Cache/RemovalStrategy.pm b/lib/Cache/RemovalStrategy.pm
new file mode 100644
index 0000000..229ab28
--- /dev/null
+++ b/lib/Cache/RemovalStrategy.pm
@@ -0,0 +1,62 @@
+=head1 NAME
+
+Cache::RemovalStrategy - abstract Removal Strategy interface for a Cache
+
+=head1 DESCRIPTION
+
+=head1 METHODS
+
+=over
+
+=cut
+package Cache::RemovalStrategy;
+
+require 5.006;
+use strict;
+use warnings;
+use Carp;
+
+our $VERSION = '2.04';
+
+
+sub new {
+ my Cache::RemovalStrategy $self = shift;
+
+ ref $self or croak 'Must use a subclass of Cache::RemovalStrategy';
+ return $self;
+}
+
+
+=item $r->remove_size( $cache, $size )
+
+When invoked, removes entries from the cache that total at least $size in
+size.
+
+=cut
+
+sub remove_size;
+
+
+1;
+__END__
+
+=head1 SEE ALSO
+
+Cache
+
+=head1 AUTHOR
+
+ Chris Leishman <chris at leishman.org>
+ Based on work by DeWitt Clinton <dewitt at unto.net>
+
+=head1 COPYRIGHT
+
+ Copyright (C) 2003-2006 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: RemovalStrategy.pm,v 1.4 2006/01/31 15:23:58 caleishm Exp $
+
+=cut
diff --git a/lib/Cache/RemovalStrategy/FIFO.pm b/lib/Cache/RemovalStrategy/FIFO.pm
new file mode 100644
index 0000000..db79908
--- /dev/null
+++ b/lib/Cache/RemovalStrategy/FIFO.pm
@@ -0,0 +1,69 @@
+=head1 NAME
+
+Cache::RemovalStrategy::FIFO - FIFO Removal Strategy for a Cache
+
+=head1 DESCRIPTION
+
+Implements a First In First Out removal strategy for a Cache. When removing
+entries from the cache, the 'oldest' will be removed first.
+
+=head1 METHODS
+
+See Cache::RemovalStrategy for details.
+
+=cut
+package Cache::RemovalStrategy::FIFO;
+
+require 5.006;
+use strict;
+use warnings;
+
+use base qw(Cache::RemovalStrategy);
+use fields qw();
+
+
+sub new {
+ my Cache::RemovalStrategy::FIFO $self = shift;
+
+ $self = fields::new($self) unless ref $self;
+ $self->SUPER::new(@_);
+
+ return $self;
+}
+
+
+sub remove_size {
+ my Cache::RemovalStrategy::FIFO $self = shift;
+ my ($cache, $size) = @_;
+
+ while ($size > 0) {
+ my $removed = $cache->remove_oldest();
+ defined $removed or last;
+ $size -= $removed;
+ }
+}
+
+
+1;
+__END__
+
+=head1 SEE ALSO
+
+Cache
+
+=head1 AUTHOR
+
+ Chris Leishman <chris at leishman.org>
+ Based on work by DeWitt Clinton <dewitt at unto.net>
+
+=head1 COPYRIGHT
+
+ Copyright (C) 2003-2006 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: FIFO.pm,v 1.4 2006/01/31 15:23:58 caleishm Exp $
+
+=cut
diff --git a/lib/Cache/RemovalStrategy/LRU.pm b/lib/Cache/RemovalStrategy/LRU.pm
new file mode 100644
index 0000000..d62e7a4
--- /dev/null
+++ b/lib/Cache/RemovalStrategy/LRU.pm
@@ -0,0 +1,69 @@
+=head1 NAME
+
+Cache::RemovalStrategy::LRU - LRU Removal Strategy for a Cache
+
+=head1 DESCRIPTION
+
+Implements a Least Recently Used removal strategy for a Cache. When removing
+entries from the cache, the 'stalest' will be removed first.
+
+=head1 METHODS
+
+See Cache::RemovalStrategy for details.
+
+=cut
+package Cache::RemovalStrategy::LRU;
+
+require 5.006;
+use strict;
+use warnings;
+
+use base qw(Cache::RemovalStrategy);
+use fields qw();
+
+
+sub new {
+ my Cache::RemovalStrategy::LRU $self = shift;
+
+ $self = fields::new($self) unless ref $self;
+ $self->SUPER::new(@_);
+
+ return $self;
+}
+
+
+sub remove_size {
+ my Cache::RemovalStrategy::LRU $self = shift;
+ my ($cache, $size) = @_;
+
+ while ($size > 0) {
+ my $removed = $cache->remove_stalest();
+ defined $removed or last;
+ $size -= $removed;
+ }
+}
+
+
+1;
+__END__
+
+=head1 SEE ALSO
+
+Cache
+
+=head1 AUTHOR
+
+ Chris Leishman <chris at leishman.org>
+ Based on work by DeWitt Clinton <dewitt at unto.net>
+
+=head1 COPYRIGHT
+
+ Copyright (C) 2003-2006 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: LRU.pm,v 1.4 2006/01/31 15:23:58 caleishm Exp $
+
+=cut
diff --git a/lib/Cache/Tester.pm b/lib/Cache/Tester.pm
new file mode 100644
index 0000000..4b19473
--- /dev/null
+++ b/lib/Cache/Tester.pm
@@ -0,0 +1,511 @@
+=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.006;
+use strict;
+use warnings;
+use Test::More;
+use Exporter;
+use vars qw(@ISA @EXPORT $VERSION $CACHE_TESTS);
+use Carp;
+
+ at ISA = qw(Exporter Test::More);
+$VERSION = "2.04";
+ at EXPORT = (qw(run_cache_tests $CACHE_TESTS), @Test::More::EXPORT);
+
+$CACHE_TESTS = 79;
+
+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');
+
+ $entry->set('test data', '1 minute');
+ _ok($entry->exists(), 'entry with 1 min timeout added');
+ sleep(2);
+ _ok($entry->exists(), 'entry with 1 min timeout remains');
+ $entry->set_expiry('now');
+ _ok(!$entry->exists(), 'entry expired after change to instant timeout');
+ _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);
+ _is($result, "result $key", "validate_callback ok");
+ $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 at leishman.org>
+ Based on work by DeWitt Clinton <dewitt at unto.net>
+
+=head1 COPYRIGHT
+
+ Copyright (C) 2003-2006 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.8 2006/01/31 15:23:58 caleishm Exp $
+
+=cut
diff --git a/t/00basic.t b/t/00basic.t
new file mode 100644
index 0000000..d3f3d0f
--- /dev/null
+++ b/t/00basic.t
@@ -0,0 +1,19 @@
+use strict;
+use warnings;
+use Test::More;
+BEGIN { plan tests => 12 }
+
+use_ok('Cache');
+use_ok('Cache::Entry');
+use_ok('Cache::RemovalStrategy');
+use_ok('Cache::RemovalStrategy::LRU');
+use_ok('Cache::RemovalStrategy::FIFO');
+use_ok('Cache::IOString');
+use_ok('Cache::Tester');
+
+use_ok('Cache::Null');
+use_ok('Cache::Memory');
+use_ok('Cache::File');
+
+use_ok('Cache::File::Heap');
+use_ok('Cache::File::Handle');
diff --git a/t/01fileheap.t b/t/01fileheap.t
new file mode 100644
index 0000000..db08561
--- /dev/null
+++ b/t/01fileheap.t
@@ -0,0 +1,226 @@
+use strict;
+use warnings;
+use Test::More;
+use File::Temp qw(tempdir);
+use File::Spec;
+use Carp;
+
+$SIG{__DIE__} = sub { confess @_; };
+
+my $add_tests;
+my $overlap_tests;
+my $mixed_tests;
+my $remove_tests;
+my $mixed_dup_tests;
+
+BEGIN {
+ $add_tests = 5;
+ $overlap_tests = 5;
+ $mixed_tests = 5;
+ $remove_tests = 5;
+ $mixed_dup_tests = 5;
+
+ plan tests => 20 +
+ 2 * $add_tests +
+ 2 * $overlap_tests +
+ 20 * $mixed_tests +
+ 10 * $remove_tests +
+ 20 * $mixed_dup_tests;
+}
+
+use_ok('Cache::File::Heap');
+
+my $tempdir = tempdir(CLEANUP => 1);
+
+my $dbfile = File::Spec->catfile($tempdir, 'test.db');
+my $heap = Cache::File::Heap->new($dbfile);
+ok($heap, "Heap created ($dbfile)");
+
+# Test basic add and extract
+my $val = 'Some data to go in the heap';
+my $key = 1053523491;
+eval { $heap->add($key, $val) };
+ok(!$@, 'Entry added');
+
+my $mkey = $heap->minimum;
+ok($mkey, 'Minimum returned');
+is($mkey, $key, 'Minimum key correct');
+
+my ($okey, $oval) = $heap->extract_minimum();
+is($okey, $key, 'Key of entry extracted');
+is($oval, $val, 'Value of entry extracted');
+
+
+# Test multiple add and extract
+
+for (1..$add_tests) {
+ $heap->add($_, "Test entry $_");
+}
+
+$mkey = $heap->minimum;
+is($mkey, 1, 'Minimum key correct');
+
+undef $heap;
+$heap = Cache::File::Heap->new($dbfile);
+ok($heap, "Heap reopened ($dbfile)");
+
+my $i = 1;
+for (1..$add_tests) {
+ ($okey, $oval) = $heap->extract_minimum();
+ is($okey, $_, "Key of min entry $_ correct ($i)");
+ is($oval, "Test entry $_", "Value of min entry $_ correct ($i)");
+ $i++;
+}
+
+is($heap->minimum, undef, 'Heap empty');
+
+
+# Test multiple identical keys
+
+for (1..$overlap_tests) {
+ $heap->add($key, "Test overlap entry $_");
+}
+
+$heap->close();
+ok($heap->open($dbfile), "Heap reopened ($dbfile)");
+
+$mkey = $heap->minimum;
+is($mkey, $key, 'Minimum key correct');
+
+$i = 1;
+for (1..$overlap_tests) {
+ ($okey, $oval) = $heap->extract_minimum();
+ is($okey, $key, "Key of min overlap entry $_ correct ($i)");
+ like($oval, qr/^Test overlap entry \d+$/,
+ "Value of min overlap entry $_ correct ($i)");
+ $i++;
+}
+
+is($heap->minimum, undef, 'Heap empty');
+
+
+# Test mixed keys
+
+for (1..$mixed_tests) {
+ $heap->add($_, "Test entry $_ : 1");
+}
+for (1..$mixed_tests) {
+ my $skey = $_;
+ for (2..5) {
+ $heap->add($skey, "Test entry $skey : $_");
+ }
+}
+for (1..$mixed_tests) {
+ my $skey = $_;
+ for (6..10) {
+ $heap->add($skey, "Test entry $skey : $_");
+ }
+}
+
+$mkey = $heap->minimum;
+is($mkey, 1, 'Minimum key correct');
+
+undef $heap;
+$heap = Cache::File::Heap->new($dbfile);
+ok($heap, "Heap reopened ($dbfile)");
+
+$i = 1;
+for my $skey (1..$mixed_tests) {
+ for (1..10) {
+ ($okey, $oval) = $heap->extract_minimum();
+ is($okey, $skey,
+ "Key of min mixed entry $skey: $_ correct ($i)");
+ like($oval, qr/^Test entry $skey : \d+$/,
+ "Value of min mixed entry $skey : $_ correct ($i)");
+ $i++;
+ }
+}
+
+is($heap->minimum, undef, 'Heap empty');
+
+
+# Test remove of items
+
+my @data;
+for (1..$remove_tests) {
+ my $skey = $_;
+ my $sval = "Test entry $skey : 1";
+ $heap->add($skey, $sval);
+ push(@data, [$skey, $sval]);
+}
+for (1..$remove_tests) {
+ my $skey = $_;
+ for (2..5) {
+ my $sval = "Test entry $skey : $_";
+ $heap->add($skey, $sval);
+ push(@data, [$skey, $sval]);
+ }
+}
+for (1..$remove_tests) {
+ my $skey = $_;
+ for (6..10) {
+ my $sval = "Test entry $skey : $_";
+ $heap->add($skey, $sval);
+ push(@data, [$skey, $sval]);
+ }
+}
+
+undef $heap;
+$heap = Cache::File::Heap->new($dbfile);
+ok($heap, "Heap reopened ($dbfile)");
+
+# shuffle data
+$i = @data;
+while ($i--) {
+ my $j = int rand ($i+1);
+ @data[$i,$j] = @data[$j,$i];
+}
+
+$i = 1;
+foreach (@data) {
+ my ($skey, $sval) = @$_;
+ ok($heap->delete($skey, $sval), "Entry removed for $skey ($i)");
+ $i++;
+}
+
+is($heap->minimum, undef, 'Heap empty');
+
+
+# Test extraction of dups
+
+for (1..$mixed_dup_tests) {
+ $heap->add($_, "Test entry $_ : 1");
+}
+for (1..$mixed_dup_tests) {
+ my $skey = $_;
+ for (2..5) {
+ $heap->add($skey, "Test entry $skey : $_");
+ }
+}
+for (1..$mixed_dup_tests) {
+ my $skey = $_;
+ for (6..9) {
+ $heap->add($skey, "Test entry $skey : $_");
+ }
+}
+
+$mkey = $heap->minimum;
+is($mkey, 1, 'Minimum key correct');
+
+$i = 1;
+for my $skey (1..$mixed_dup_tests) {
+ my ($okey, $ovals) = $heap->extract_minimum_dup();
+ is($okey, $skey, "Key for extracted entries $skey correct");
+ is(scalar @$ovals, 9, "Correct number of records extracted for $skey");
+ @$ovals = sort @$ovals;
+ for (1..9) {
+ my $oval = shift @$ovals;
+ is($okey, $skey,
+ "Key of min dup entry $skey: $_ correct ($i)");
+ like($oval, qr/^Test\ entry\ $skey\ :\ $_ $/x,
+ "Value of min dup entry $skey : $_ correct ($i)");
+ $i++;
+ }
+}
+
+is($heap->minimum, undef, 'Heap empty');
diff --git a/t/file.t b/t/file.t
new file mode 100644
index 0000000..0c10ab1
--- /dev/null
+++ b/t/file.t
@@ -0,0 +1,48 @@
+#use strict;
+use warnings;
+use Cache::Tester;
+use File::Temp qw(tempdir);
+use File::Find;
+use Carp;
+
+$SIG{__DIE__} = sub { confess @_; };
+
+BEGIN { plan tests => 2 + $CACHE_TESTS + 3 }
+
+use_ok('Cache::File');
+
+{
+ # Test basic get/set and remove
+
+ my $tempdir = tempdir(CLEANUP => 1);
+ my $cache = Cache::File->new(cache_root => $tempdir,
+ lock_level => Cache::File::LOCK_NFS());
+ ok($cache, 'Cache created');
+
+ run_cache_tests($cache);
+}
+
+{
+ # Test setting of umask
+ umask 077;
+ my $tempdir = tempdir(CLEANUP => 1);
+ my $cache = Cache::File->new(cache_root => $tempdir, cache_umask => 070);
+ ok($cache, 'Cache created');
+
+ my $entry = $cache->set('key1', 'data1');
+ is($cache->count(), 1, 'Added entry');
+
+ my $valid = 0;
+
+ sub wanted {
+ return if $_ eq $tempdir;
+ my (undef, undef, $mode) = lstat($_) or die "lstat failed";
+ $mode &= 0777;
+ (-d and $mode == 0707) or (not -d and $mode == 0606)
+ or die 'bad permissions ('.sprintf('%04o', $mode).") on $_";
+ }
+ eval { File::Find::find({ wanted => \&wanted, no_chdir => 1 }, $tempdir) };
+ die if ($@ and $@ !~ /^bad permissions/);
+ warn $@ if $@;
+ ok((not $@), "Permissions are good");
+}
diff --git a/t/file_fifo.t b/t/file_fifo.t
new file mode 100644
index 0000000..0e3a410
--- /dev/null
+++ b/t/file_fifo.t
@@ -0,0 +1,81 @@
+use strict;
+use warnings;
+use Test::More;
+use File::Temp qw(tempdir);
+use Carp;
+
+$SIG{__DIE__} = sub { confess @_; };
+
+# This test suite requires total accuracy in ordering of removals over a short
+# time period, so a higher resolution timer is required.
+eval { require Time::HiRes }
+ or plan skip_all => 'Time::HiRes is required for this test.';
+Time::HiRes->export('Cache::File', 'time');
+Time::HiRes->export('Cache::File::Entry', 'time');
+
+plan tests => 22;
+
+require_ok('Cache::File');
+
+my $tempdir = tempdir(CLEANUP => 1);
+my $cache = Cache::File->new(
+ cache_root => $tempdir,
+ size_limit => 10,
+ removal_strategy => 'Cache::RemovalStrategy::FIFO',
+ );
+
+is(ref($cache->removal_strategy()), 'Cache::RemovalStrategy::FIFO',
+ 'Removal strategy set to FIFO');
+
+my $entry1 = $cache->entry('testkey');
+my $entry2 = $cache->entry('testkey2');
+my $entry3 = $cache->entry('testkey3');
+
+# Test that entry1 is removed when entry2 overfills cache
+$entry1->set('012345678'); # 9 bytes
+ok($entry1->exists(), 'Entry added');
+is($cache->size(), 9, 'Cache size correct');
+sleep(1);
+$entry2->set('0123456'); # 7 bytes
+ok($entry2->exists(), 'Second entry added');
+ok(!$entry1->exists(), 'First entry removed');
+is($cache->size(), 7, 'Cache size correct');
+
+# Test that readding entry1 overfills cache and removes entry2
+$entry1->set('012345678'); # 9 bytes
+ok($entry1->exists(), 'First entry added');
+ok(!$entry2->exists(), 'Second entry removed');
+is($cache->size(), 9, 'Cache size correct');
+
+# Test that entry1 is removed after entry2 & entry3 are added and overfill cache
+$entry1->remove();
+is($cache->size(), 0, 'Cache size correct');
+
+$entry1->set('0123'); # 4 bytes
+ok($entry1->exists(), 'First entry added');
+$entry2->set('0123'); # 4 bytes
+ok($entry1->exists(), 'Second entry added');
+is($cache->size(), 8, 'Cache size correct');
+$entry3->set('01234'); # 5 bytes
+ok($entry3->exists(), 'Third entry added');
+ok(!$entry1->exists(), 'First entry removed');
+ok($entry2->exists(), 'Second entry remains');
+is($cache->size(), 9, 'Cache size correct');
+
+# Test that entry1 is removed even after entry1 is used (FIFO)
+$entry1->remove();
+$entry2->remove();
+$entry3->remove();
+
+$entry1->set('0123'); # 4 bytes
+sleep(2);
+$entry2->set('0123'); # 4 bytes
+sleep(2);
+$entry1->get();
+sleep(2);
+
+$entry3->set('0123'); # 4 bytes
+ok($entry3->exists(), 'Third entry added');
+ok(!$entry1->exists(), 'First entry removed');
+ok($entry2->exists(), 'Second entry remains');
+is($cache->size(), 8, 'Cache size correct');
diff --git a/t/file_lru.t b/t/file_lru.t
new file mode 100644
index 0000000..fdda4be
--- /dev/null
+++ b/t/file_lru.t
@@ -0,0 +1,77 @@
+use strict;
+use warnings;
+use Test::More;
+use File::Temp qw(tempdir);
+use Time::HiRes;
+use Carp;
+
+$SIG{__DIE__} = sub { confess @_; };
+
+# This test suite requires total accuracy in ordering of removals over a short
+# time period, so a higher resolution timer is required.
+eval { require Time::HiRes }
+ or plan skip_all => 'Time::HiRes is required for this test.';
+Time::HiRes->export('Cache::File', 'time');
+Time::HiRes->export('Cache::File::Entry', 'time');
+
+plan tests => 22;
+
+require_ok('Cache::File');
+
+my $tempdir = tempdir(CLEANUP => 1);
+my $cache = Cache::File->new(
+ cache_root => $tempdir,
+ size_limit => 10
+ );
+
+is(ref($cache->removal_strategy()), 'Cache::RemovalStrategy::LRU',
+ 'Default removal strategy set to LRU');
+
+my $entry1 = $cache->entry('testkey');
+my $entry2 = $cache->entry('testkey2');
+my $entry3 = $cache->entry('testkey3');
+
+# Test that entry1 is removed when entry2 overfills cache
+$entry1->set('012345678'); # 9 bytes
+ok($entry1->exists(), 'Entry added');
+is($cache->size(), 9, 'Cache size correct');
+$entry2->set('0123456'); # 7 bytes
+ok($entry2->exists(), 'Second entry added');
+ok(!$entry1->exists(), 'First entry removed');
+is($cache->size(), 7, 'Cache size correct');
+
+# Test that readding entry1 overfills cache and removes entry2
+$entry1->set('012345678'); # 9 bytes
+ok($entry1->exists(), 'First entry added');
+ok(!$entry2->exists(), 'Second entry removed');
+is($cache->size(), 9, 'Cache size correct');
+
+# Test that entry1 is removed after entry2 & entry3 are added and overfill cache
+$entry1->remove();
+is($cache->size(), 0, 'Cache size correct');
+
+$entry1->set('0123'); # 4 bytes
+ok($entry1->exists(), 'First entry added');
+$entry2->set('0123'); # 4 bytes
+ok($entry1->exists(), 'Second entry added');
+is($cache->size(), 8, 'Cache size correct');
+$entry3->set('01234'); # 5 bytes
+ok($entry3->exists(), 'Third entry added');
+ok(!$entry1->exists(), 'First entry removed');
+ok($entry2->exists(), 'Second entry remains');
+is($cache->size(), 9, 'Cache size correct');
+
+# Test that entry2 is removed after entry1 is used (LRU)
+$entry1->remove();
+$entry2->remove();
+$entry3->remove();
+
+$entry1->set('0123'); # 4 bytes
+$entry2->set('0123'); # 4 bytes
+$entry1->get();
+
+$entry3->set('0123'); # 4 bytes
+ok($entry3->exists(), 'Third entry added');
+ok($entry1->exists(), 'First entry remains');
+ok(!$entry2->exists(), 'Second entry removed');
+is($cache->size(), 8, 'Cache size correct');
diff --git a/t/file_tie.t b/t/file_tie.t
new file mode 100644
index 0000000..92eb762
--- /dev/null
+++ b/t/file_tie.t
@@ -0,0 +1,47 @@
+use strict;
+use warnings;
+use Test::More;
+use File::Temp qw(tempdir);
+use Carp;
+
+$SIG{__DIE__} = sub { confess @_ };
+
+BEGIN { plan tests => 7 }
+
+use_ok('Cache::File');
+
+my $tempdir = tempdir(CLEANUP => 1);
+
+my %hash;
+my $cache = tie %hash, 'Cache::File', { cache_root => $tempdir };
+
+my $key = 'testkey';
+
+$hash{$key} = 'test data';
+
+ok($cache->exists($key), 'store worked');
+is($hash{$key}, 'test data', 'fetch worked');
+
+delete $hash{$key};
+
+ok(!$cache->exists($key), 'delete worked');
+
+
+{
+ sub load_func {
+ return "You requested ".$_[0]->key();
+ }
+
+ my %hash;
+ my $cache = tie %hash, 'Cache::File',
+ { cache_root => $tempdir, load_callback => \&load_func };
+
+ my $key = 'testkey';
+
+ ok(!$cache->exists($key), 'key doesnt exist');
+ is($hash{$key}, "You requested $key", 'load worked');
+
+ delete $hash{$key};
+
+ ok(!$cache->exists($key), 'delete worked');
+}
diff --git a/t/memory.t b/t/memory.t
new file mode 100644
index 0000000..7979f5f
--- /dev/null
+++ b/t/memory.t
@@ -0,0 +1,17 @@
+use strict;
+use warnings;
+use Cache::Tester;
+use Carp;
+
+$SIG{__DIE__} = sub { confess @_; };
+
+BEGIN { plan tests => 2 + $CACHE_TESTS }
+
+use_ok('Cache::Memory');
+
+# Test basic get/set and remove
+
+my $cache = Cache::Memory->new();
+ok($cache, 'Cache returned');
+
+run_cache_tests($cache);
diff --git a/t/memory_fifo.t b/t/memory_fifo.t
new file mode 100644
index 0000000..e773b6d
--- /dev/null
+++ b/t/memory_fifo.t
@@ -0,0 +1,67 @@
+use strict;
+use warnings;
+use Test::More;
+use Carp;
+
+$SIG{__DIE__} = sub { confess @_; };
+
+BEGIN { plan tests => 22 }
+
+use_ok('Cache::Memory');
+
+my $cache = Cache::Memory->new(
+ size_limit => 10,
+ removal_strategy => 'Cache::RemovalStrategy::FIFO',
+ );
+
+is(ref($cache->removal_strategy()), 'Cache::RemovalStrategy::FIFO',
+ 'Removal strategy set to FIFO');
+
+my $entry1 = $cache->entry('testkey');
+my $entry2 = $cache->entry('testkey2');
+my $entry3 = $cache->entry('testkey3');
+
+# Test that entry1 is removed when entry2 overfills cache
+$entry1->set('012345678'); # 9 bytes
+ok($entry1->exists(), 'Entry added');
+is($cache->size(), 9, 'Cache size correct');
+$entry2->set('0123456'); # 7 bytes
+ok($entry2->exists(), 'Second entry added');
+ok(!$entry1->exists(), 'First entry removed');
+is($cache->size(), 7, 'Cache size correct');
+
+# Test that readding entry1 overfills cache and removes entry2
+$entry1->set('012345678'); # 9 bytes
+ok($entry1->exists(), 'First entry added');
+ok(!$entry2->exists(), 'Second entry removed');
+is($cache->size(), 9, 'Cache size correct');
+
+# Test that entry1 is removed after entry2 & entry3 are added and overfill cache
+$entry1->remove();
+is($cache->size(), 0, 'Cache size correct');
+
+$entry1->set('0123'); # 4 bytes
+ok($entry1->exists(), 'First entry added');
+$entry2->set('0123'); # 4 bytes
+ok($entry1->exists(), 'Second entry added');
+is($cache->size(), 8, 'Cache size correct');
+$entry3->set('01234'); # 5 bytes
+ok($entry3->exists(), 'Third entry added');
+ok(!$entry1->exists(), 'First entry removed');
+ok($entry2->exists(), 'Second entry remains');
+is($cache->size(), 9, 'Cache size correct');
+
+# Test that entry1 is removed even after entry1 is used (FIFO)
+$entry1->remove();
+$entry2->remove();
+$entry3->remove();
+
+$entry1->set('0123'); # 4 bytes
+$entry2->set('0123'); # 4 bytes
+$entry1->get();
+
+$entry3->set('0123'); # 4 bytes
+ok($entry3->exists(), 'Third entry added');
+ok(!$entry1->exists(), 'First entry removed');
+ok($entry2->exists(), 'Second entry remains');
+is($cache->size(), 8, 'Cache size correct');
diff --git a/t/memory_lru.t b/t/memory_lru.t
new file mode 100644
index 0000000..3e705a5
--- /dev/null
+++ b/t/memory_lru.t
@@ -0,0 +1,64 @@
+use strict;
+use warnings;
+use Test::More;
+use Carp;
+
+$SIG{__DIE__} = sub { confess @_; };
+
+BEGIN { plan tests => 22 }
+
+use_ok('Cache::Memory');
+
+my $cache = Cache::Memory->new(size_limit => 10);
+
+is(ref($cache->removal_strategy()), 'Cache::RemovalStrategy::LRU',
+ 'Default removal strategy set to LRU');
+
+my $entry1 = $cache->entry('testkey');
+my $entry2 = $cache->entry('testkey2');
+my $entry3 = $cache->entry('testkey3');
+
+# Test that entry1 is removed when entry2 overfills cache
+$entry1->set('012345678'); # 9 bytes
+ok($entry1->exists(), 'Entry added');
+is($cache->size(), 9, 'Cache size correct');
+$entry2->set('0123456'); # 7 bytes
+ok($entry2->exists(), 'Second entry added');
+ok(!$entry1->exists(), 'First entry removed');
+is($cache->size(), 7, 'Cache size correct');
+
+# Test that readding entry1 overfills cache and removes entry2
+$entry1->set('012345678'); # 9 bytes
+ok($entry1->exists(), 'First entry added');
+ok(!$entry2->exists(), 'Second entry removed');
+is($cache->size(), 9, 'Cache size correct');
+
+# Test that entry1 is removed after entry2 & entry3 are added and overfill cache
+$entry1->remove();
+is($cache->size(), 0, 'Cache size correct');
+
+$entry1->set('0123'); # 4 bytes
+ok($entry1->exists(), 'First entry added');
+$entry2->set('0123'); # 4 bytes
+ok($entry1->exists(), 'Second entry added');
+is($cache->size(), 8, 'Cache size correct');
+$entry3->set('01234'); # 5 bytes
+ok($entry3->exists(), 'Third entry added');
+ok(!$entry1->exists(), 'First entry removed');
+ok($entry2->exists(), 'Second entry remains');
+is($cache->size(), 9, 'Cache size correct');
+
+# Test that entry2 is removed after entry1 is used (LRU)
+$entry1->remove();
+$entry2->remove();
+$entry3->remove();
+
+$entry1->set('0123'); # 4 bytes
+$entry2->set('0123'); # 4 bytes
+$entry1->get();
+
+$entry3->set('0123'); # 4 bytes
+ok($entry3->exists(), 'Third entry added');
+ok($entry1->exists(), 'First entry remains');
+ok(!$entry2->exists(), 'Second entry removed');
+is($cache->size(), 8, 'Cache size correct');
diff --git a/t/memory_tie.t b/t/memory_tie.t
new file mode 100644
index 0000000..94a9e5f
--- /dev/null
+++ b/t/memory_tie.t
@@ -0,0 +1,44 @@
+use strict;
+use warnings;
+use Test::More;
+use Carp;
+
+$SIG{__DIE__} = sub { confess @_ };
+
+BEGIN { plan tests => 7 }
+
+use_ok('Cache::Memory');
+
+{
+ my %hash;
+ my $cache = tie %hash, 'Cache::Memory';
+
+ my $key = 'testkey';
+
+ $hash{$key} = 'test data';
+
+ ok($cache->exists($key), 'store worked');
+ is($hash{$key}, 'test data', 'fetch worked');
+
+ delete $hash{$key};
+
+ ok(!$cache->exists($key), 'delete worked');
+}
+
+{
+ sub load_func {
+ return "You requested ".$_[0]->key();
+ }
+
+ my %hash;
+ my $cache = tie %hash, 'Cache::Memory', {load_callback => \&load_func};
+
+ my $key = 'testkey';
+
+ ok(!$cache->exists($key), 'key doesnt exist');
+ is($hash{$key}, "You requested $key", 'load worked');
+
+ delete $hash{$key};
+
+ ok(!$cache->exists($key), 'delete worked');
+}
diff --git a/t/null.t b/t/null.t
new file mode 100644
index 0000000..70751ea
--- /dev/null
+++ b/t/null.t
@@ -0,0 +1,59 @@
+use strict;
+use warnings;
+use Test::More;
+use Carp;
+
+$SIG{__DIE__} = sub { confess @_; };
+
+BEGIN { plan tests => 21 }
+
+use_ok('Cache::Null');
+
+# Test basic get/set and remove
+
+my $cache = Cache::Null->new();
+ok($cache, 'Cache returned');
+
+my $entry = $cache->entry('testkey');
+ok($entry, 'Entry returned');
+is($entry->key(), 'testkey', 'Entry key correct');
+ok(!$entry->exists(), 'Entry doesnt exist initally');
+is($entry->get(), undef, '$entry->get() returns undef');
+
+$entry->set('test data');
+ok(!$entry->exists(), 'Entry still doesnt exist after set');
+is($entry->size(), undef, 'Data size is undef');
+is($cache->size(), 0, 'Cache size is zero');
+
+$entry->remove();
+ok(!$entry->exists(), 'Entry doesnt exist after remove');
+
+
+# Test handle write
+my $handle = $entry->handle();
+ok($handle, 'Handle created');
+print $handle 'more test data';
+close $handle;
+ok(!$entry->exists(), 'Entry doesnt exist after handle write');
+is($entry->get(), undef, '$entry->get() returns undef');
+
+# Test handle read
+$handle = $entry->handle('<');
+is($handle, undef, 'Read handle not created');
+
+# Test handle write only
+$handle = $entry->handle('>');
+ok($handle, 'Write handle created');
+is(<$handle>, undef, 'Read from write only handle fails');
+print $handle 'this should work';
+undef $handle;
+is($entry->get(), undef, 'Entry doesnt exist after handle write');
+
+# Test append handle
+$handle = $entry->handle('>>');
+ok($handle, 'Append handle created');
+$handle->print(' and it does');
+$handle->close();
+is($entry->get(), undef, 'Entry doesnt exist after handle append');
+is($entry->size(), undef, 'Data size is correct');
+is($cache->size(), 0, 'Cache size is correct');
--
Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/pkg-perl/packages/libcache-perl.git
More information about the Pkg-perl-cvs-commits
mailing list