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 <d...@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 <ch...@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 <ch...@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 <ch...@leishman.org> + Based on work by DeWitt Clinton <dew...@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 <ch...@leishman.org> + Based on work by DeWitt Clinton <dew...@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 <ch...@leishman.org> + Based on work by DeWitt Clinton <dew...@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 <ch...@leishman.org> + Based on work by DeWitt Clinton <dew...@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 <ch...@leishman.org> + Based on work by DeWitt Clinton <dew...@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 <ch...@leishman.org> + Based on work by DeWitt Clinton <dew...@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 <ch...@leishman.org> + Based on work by DeWitt Clinton <dew...@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 <ch...@leishman.org> + Based on work by DeWitt Clinton <dew...@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 <ch...@leishman.org> + Based on work by DeWitt Clinton <dew...@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 <ch...@leishman.org> + Based on work by DeWitt Clinton <dew...@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 <ch...@leishman.org> + Based on work by DeWitt Clinton <dew...@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 <ch...@leishman.org> + Based on work by DeWitt Clinton <dew...@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 <ch...@leishman.org> + Based on work by DeWitt Clinton <dew...@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 <ch...@leishman.org> + Based on work by DeWitt Clinton <dew...@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 <ch...@leishman.org> + Based on work by DeWitt Clinton <dew...@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; + +@ISA = qw(Exporter Test::More); +$VERSION = "2.04"; +@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 <ch...@leishman.org> + Based on work by DeWitt Clinton <dew...@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 _______________________________________________ Pkg-perl-cvs-commits mailing list Pkg-perl-cvs-commits@lists.alioth.debian.org http://lists.alioth.debian.org/cgi-bin/mailman/listinfo/pkg-perl-cvs-commits