Cache-2.11000755000764000764 012473073254 12744 5ustar00shlomifshlomif000000000000Cache-2.11/TODO000444000764000764 30312473073254 13545 0ustar00shlomifshlomif000000000000TODO 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 Cache-2.11/Changes000444000764000764 666612473073254 14412 0ustar00shlomifshlomif0000000000002015-02-24 - Make sure t/file_lru.t skips all tests if Time::HiRes isn't installed. - See https://rt.cpan.org/Ticket/Display.html?id=102316 - Thanks to Otto J. Makela for the report. - Bugfix/maintenance release (2.11) 2014-05-13 - Fix a small grammar in the docs (double "as") reported by pink_mist. - Thanks, pink_mist! - Another fix for a small typo by pink_mist. - Thanks again. - Add Cache category of warnings to make sure warnings do not emit an error. - See https://rt.cpan.org/Public/Bug/Display.html?id=95608 - Thanks to Gabor Szabo for the report. - Bugfix/maintenance release (2.10) 2014-02-02 - Use Digest::SHA instead of Digest::SHA1 - Digest::SHA is core and preferred by Debian. - https://rt.cpan.org/Ticket/Display.html?id=92658 - Bugfix/maintenance release (2.09) 2014-01-26 - Convert from use "warnings::register;" to "use warnings;". - Bugfix/maintenance release (2.08) 2014-01-26 - Add perl to the prereq in META.yml/META.json - Kwalitee / CPANTS - Bugfix/maintenance release (2.07) 2013-09-13 - Increase the delay of the cache invalidation in the tests by default to avoid test failures due to high load. - https://rt.cpan.org/Public/Bug/Display.html?id=27280 - One can set the PERL_CACHE_PM_TESTING environment variable to a true value to set it back at a quicker-to-run 1 second delay. - Thanks to ANDK for reporting it. - Fix Bug in Cache::Memory regarding Namespaces - https://rt.cpan.org/Ticket/Display.html?id=32339 . - ->set after ->set_namespace failed. - Thanks to justin@techadvise.com for the report and for a proposed fix. - Get rid of trailing space. - Add t/style-trailing-space.t - Bugfix/maintenance release (2.06) 2013-09-05 - Add t/pod.t and got the embedded PODs to validate. - Convert the Build system to Module-Build. - Fix https://rt.cpan.org/Ticket/Display.html?id=78817 - Fix a warning for lc called with undef value when "-w" is specified - during some tests. - Tests fail or get stuck on Windows - use Devel::AssertOS to make sure we don't build there. - https://rt.cpan.org/Ticket/Display.html?id=81386 - if a kind soul will fix the tests and/or the code on MSWin, we will remove it. - Bugfix/maintenance release (2.05) 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) Cache-2.11/LICENSE000444000764000764 23612473073254 14067 0ustar00shlomifshlomif000000000000Cache 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. Cache-2.11/MANIFEST000444000764000764 307412473073254 14236 0ustar00shlomifshlomif000000000000Build.PL Changes design.dia inc/Devel/AssertOS.pm inc/Devel/AssertOS/AIX.pm inc/Devel/AssertOS/BSDOS.pm inc/Devel/AssertOS/DGUX.pm inc/Devel/AssertOS/DragonflyBSD.pm inc/Devel/AssertOS/Dynix.pm inc/Devel/AssertOS/FreeBSD.pm inc/Devel/AssertOS/HPUX.pm inc/Devel/AssertOS/Interix.pm inc/Devel/AssertOS/Irix.pm inc/Devel/AssertOS/Linux.pm inc/Devel/AssertOS/MachTen.pm inc/Devel/AssertOS/MacOSX.pm inc/Devel/AssertOS/MidnightBSD.pm inc/Devel/AssertOS/MirOSBSD.pm inc/Devel/AssertOS/NetBSD.pm inc/Devel/AssertOS/OpenBSD.pm inc/Devel/AssertOS/OSF.pm inc/Devel/AssertOS/QNX.pm inc/Devel/AssertOS/QNX/Neutrino.pm inc/Devel/AssertOS/QNX/v4.pm inc/Devel/AssertOS/SCO.pm inc/Devel/AssertOS/Solaris.pm inc/Devel/AssertOS/SunOS.pm inc/Devel/AssertOS/SysVr4.pm inc/Devel/AssertOS/SysVr5.pm inc/Devel/AssertOS/Unicos.pm inc/Devel/AssertOS/Unix.pm inc/Devel/CheckOS.pm inc/Test/Run/Builder.pm 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 LICENSE MANIFEST MANIFEST.SKIP META.json META.yml Module meta-data (added by MakeMaker) README scripts/bump-version-number.pl 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_set_namespace_rt32339.t t/memory_tie.t t/null.t t/pod.t t/style-trailing-space.t TODO Cache-2.11/Build.PL000444000764000764 273512473073254 14404 0ustar00shlomifshlomif000000000000use strict; use warnings; use lib "./inc"; use Devel::AssertOS qw(Unix); use Test::Run::Builder; my $builder = Test::Run::Builder->new( module_name => 'Cache', license => 'perl', dist_author => 'Chris Leishman ', dist_version_from => 'lib/Cache.pm', dist_abstract => "Provide a generic Cache mechanism.", requires => { 'DB_File' => '1.72', 'Date::Parse' => '2.24', 'Digest::SHA' => '0', 'Fcntl' => '1.03', 'File::Find' => '0', 'File::NFSLock' => '1.20', 'File::Path' => '1.00', 'File::Spec' => '0.8', 'Heap::Fibonacci' => '0.01', 'IO::File' => '1.08', 'IO::Handle' => '1.21', 'IO::String' => '1.02', 'Storable' => '1.00', 'Symbol' => '1.02', 'Test::More' => '0.45', 'perl' => '5.006', }, configure_requires => { 'Module::Build' => 0, }, add_to_cleanup => [ 'Cache-*' ], meta_merge => { resources => { repository => "http://bitbucket.org/shlomif/web-cpan", }, keywords => [ 'cache', 'caching', 'file', 'generic', 'memory', 'optimisation', 'optimise', 'optimization', 'optimize', 'speed', ], }, ); $builder->create_build_script(); Cache-2.11/META.yml000444000764000764 402112473073254 14347 0ustar00shlomifshlomif000000000000--- abstract: 'Provide a generic Cache mechanism.' author: - 'Chris Leishman ' build_requires: {} configure_requires: Module::Build: '0' dynamic_config: 1 generated_by: 'Module::Build version 0.421, CPAN::Meta::Converter version 2.142060' keywords: - cache - caching - file - generic - memory - optimisation - optimise - optimization - optimize - speed license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: Cache provides: Cache: file: lib/Cache.pm version: '2.11' Cache::Entry: file: lib/Cache/Entry.pm version: '2.11' Cache::File: file: lib/Cache/File.pm version: '2.11' Cache::File::Entry: file: lib/Cache/File/Entry.pm version: '2.11' Cache::File::Handle: file: lib/Cache/File/Handle.pm Cache::File::Heap: file: lib/Cache/File/Heap.pm version: '2.11' Cache::IOString: file: lib/Cache/IOString.pm Cache::Memory: file: lib/Cache/Memory.pm version: '2.11' Cache::Memory::Entry: file: lib/Cache/Memory/Entry.pm version: '2.11' Cache::Memory::HeapElem: file: lib/Cache/Memory/HeapElem.pm Cache::Null: file: lib/Cache/Null.pm version: '2.11' Cache::Null::Entry: file: lib/Cache/Null/Entry.pm version: '2.11' Cache::RemovalStrategy: file: lib/Cache/RemovalStrategy.pm version: '2.11' Cache::RemovalStrategy::FIFO: file: lib/Cache/RemovalStrategy/FIFO.pm Cache::RemovalStrategy::LRU: file: lib/Cache/RemovalStrategy/LRU.pm Cache::Tester: file: lib/Cache/Tester.pm version: '2.11' requires: DB_File: '1.72' Date::Parse: '2.24' Digest::SHA: '0' Fcntl: '1.03' File::Find: '0' File::NFSLock: '1.20' File::Path: '1.00' File::Spec: '0.8' Heap::Fibonacci: '0.01' IO::File: '1.08' IO::Handle: '1.21' IO::String: '1.02' Storable: '1.00' Symbol: '1.02' Test::More: '0.45' perl: '5.006' resources: license: http://dev.perl.org/licenses/ repository: http://bitbucket.org/shlomif/web-cpan version: '2.11' Cache-2.11/design.dia000444000764000764 730012473073254 15031 0ustar00shlomifshlomif000000000000][s۶~ϯ(oglvOiδg %kTIʎ~H)7\,$0rjH2p\~5Oûfs!Cg9WjhtOȉxD|yH4 ? ^v0sbG~|qN1Β_ 'vk6ܶJM/ww5|nF;rV㦧\wKq=gD҈f>xY+ɮ M8sPl R@\C7v)g=ڸ- ſbGW4z2G`,onG?#`q@;ͧ gr3:G:KivC>y\.s,LF- m-hGG$x==Zv0|qLAZC߹/^,_Lq{ KNvS ǟy=Z)ze5?@M10t nBοcP;/,\c Nٹ9%o8˕ļ:G/KvE*t.ZpnCQeZ`. jF,Kj|Ű0^7Ҕ1N58ihR ty8MӖSTw3W]ӺwdQ4] hȨ.^z4CJw2 1`Dd2t5sAD5) M2hW/StFl#AbM]P%4n* M. u m.6RhsbR*E("DrW rocD[AWCa*.pI[X?H\-z V)nQ m e T'L-{%tU]lla3} lk3vn}JV90ʴ&KS*$i+L95sŶjFi76 l`?JXt$#|1SPȪBVp 4b'"ahch)~c]qkcy1Qexf'+ &ZB$ "Qj$-x4oЊ_9 ܡ)";,8 vOj]AnToQJ8 nj7tAW9P VE.9V Bz+{֍E9$$tƩ+Ձ½j(M'<.xz bݫ8tc3\9\eK{sG;p֠;}}Ы+ލ3'vzQ?q[5܂W6?p&($IpxO mYc]*Q Sl" ], "dynamic_config" : 1, "generated_by" : "Module::Build version 0.421", "keywords" : [ "cache", "caching", "file", "generic", "memory", "optimisation", "optimise", "optimization", "optimize", "speed" ], "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "Cache", "prereqs" : { "configure" : { "requires" : { "Module::Build" : "0" } }, "runtime" : { "requires" : { "DB_File" : "1.72", "Date::Parse" : "2.24", "Digest::SHA" : "0", "Fcntl" : "1.03", "File::Find" : "0", "File::NFSLock" : "1.20", "File::Path" : "1.00", "File::Spec" : "0.8", "Heap::Fibonacci" : "0.01", "IO::File" : "1.08", "IO::Handle" : "1.21", "IO::String" : "1.02", "Storable" : "1.00", "Symbol" : "1.02", "Test::More" : "0.45", "perl" : "5.006" } } }, "provides" : { "Cache" : { "file" : "lib/Cache.pm", "version" : "2.11" }, "Cache::Entry" : { "file" : "lib/Cache/Entry.pm", "version" : "2.11" }, "Cache::File" : { "file" : "lib/Cache/File.pm", "version" : "2.11" }, "Cache::File::Entry" : { "file" : "lib/Cache/File/Entry.pm", "version" : "2.11" }, "Cache::File::Handle" : { "file" : "lib/Cache/File/Handle.pm" }, "Cache::File::Heap" : { "file" : "lib/Cache/File/Heap.pm", "version" : "2.11" }, "Cache::IOString" : { "file" : "lib/Cache/IOString.pm" }, "Cache::Memory" : { "file" : "lib/Cache/Memory.pm", "version" : "2.11" }, "Cache::Memory::Entry" : { "file" : "lib/Cache/Memory/Entry.pm", "version" : "2.11" }, "Cache::Memory::HeapElem" : { "file" : "lib/Cache/Memory/HeapElem.pm" }, "Cache::Null" : { "file" : "lib/Cache/Null.pm", "version" : "2.11" }, "Cache::Null::Entry" : { "file" : "lib/Cache/Null/Entry.pm", "version" : "2.11" }, "Cache::RemovalStrategy" : { "file" : "lib/Cache/RemovalStrategy.pm", "version" : "2.11" }, "Cache::RemovalStrategy::FIFO" : { "file" : "lib/Cache/RemovalStrategy/FIFO.pm" }, "Cache::RemovalStrategy::LRU" : { "file" : "lib/Cache/RemovalStrategy/LRU.pm" }, "Cache::Tester" : { "file" : "lib/Cache/Tester.pm", "version" : "2.11" } }, "release_status" : "stable", "resources" : { "license" : [ "http://dev.perl.org/licenses/" ], "repository" : { "url" : "http://bitbucket.org/shlomif/web-cpan" } }, "version" : "2.11" } Cache-2.11/README000444000764000764 202012473073254 13753 0ustar00shlomifshlomif000000000000Readme 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 the rt.cpan.org queue at https://rt.cpan.org/Dist/Display.html?Name=Cache . This module was originally created by Chris Leishman and is now maintained by Shlomi Fish ( http://www.shlomifish.org/ ). Messages of thanks can be sent by E-mail. :) Enjoy! Cache-2.11/lib000755000764000764 012473073254 13512 5ustar00shlomifshlomif000000000000Cache-2.11/lib/Cache.pm000444000764000764 3452412473073254 15240 0ustar00shlomifshlomif000000000000=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 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; use Carp; use Date::Parse; # For registering the 'Cache' category. See: # https://rt.cpan.org/Public/Bug/Display.html?id=95608 use warnings::register; use base qw(Tie::Hash); use fields qw( default_expires removal_strategy size_limit load_callback validate_callback); our $VERSION = '2.11'; 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. =back =cut sub Canonicalize_Expiration_Time { my $timespec; my $timespec_param = shift(@_); if (! $timespec_param) { return undef; } $timespec = lc($timespec_param); 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 deprecated. There is still some work to be done to ensure cache consistency between accesses by different users. =back =head1 AUTHOR Chris Leishman Based on work by DeWitt Clinton =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 Cache-2.11/lib/Cache000755000764000764 012473073254 14515 5ustar00shlomifshlomif000000000000Cache-2.11/lib/Cache/File.pm000444000764000764 4134412473073254 16115 0ustar00shlomifshlomif000000000000=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::SHA 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.11'; 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: =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 Based on work by DeWitt Clinton =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 Cache-2.11/lib/Cache/Memory.pm000444000764000764 2321312473073254 16501 0ustar00shlomifshlomif000000000000=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.11'; # 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 _init_ns_heaps { my ($self, $ns) = @_; $Age_Heaps{$ns} ||= Heap::Fibonacci->new(); $Use_Heaps{$ns} ||= Heap::Fibonacci->new(); return; } 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; $self->_init_ns_heaps($ns); 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) $self->_init_ns_heaps($ns); return; } 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->_init_ns_heaps($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 Based on work by DeWitt Clinton =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 Cache-2.11/lib/Cache/Null.pm000444000764000764 442412473073254 16126 0ustar00shlomifshlomif000000000000=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.11'; =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 Based on work by DeWitt Clinton =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 Cache-2.11/lib/Cache/Entry.pm000444000764000764 2057312473073254 16340 0ustar00shlomifshlomif000000000000=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.11'; 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 Based on work by DeWitt Clinton =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 Cache-2.11/lib/Cache/IOString.pm000444000764000764 637012473073254 16714 0ustar00shlomifshlomif000000000000=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 Based on work by DeWitt Clinton =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 Cache-2.11/lib/Cache/RemovalStrategy.pm000444000764000764 203312473073254 20336 0ustar00shlomifshlomif000000000000=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.11'; 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__ =back =head1 SEE ALSO Cache =head1 AUTHOR Chris Leishman Based on work by DeWitt Clinton =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 Cache-2.11/lib/Cache/Tester.pm000444000764000764 3267612473073254 16514 0ustar00shlomifshlomif000000000000=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.11'; @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'); # This is to fix/workaround the test failures by high load. See: # https://rt.cpan.org/Public/Bug/Display.html?id=27280 my $delay = $ENV{PERL_CACHE_PM_TESTING} ? 1 : 3; $entry->set('test data', "$delay sec"); _ok($entry->exists(), "entry with $delay sec timeout added"); sleep($delay+1); _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 Based on work by DeWitt Clinton =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 Cache-2.11/lib/Cache/File000755000764000764 012473073254 15374 5ustar00shlomifshlomif000000000000Cache-2.11/lib/Cache/File/Heap.pm000444000764000764 1322412473073254 16766 0ustar00shlomifshlomif000000000000=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.11'; # 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 Based on work by DeWitt Clinton =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 Cache-2.11/lib/Cache/File/Entry.pm000444000764000764 3322412473073254 17214 0ustar00shlomifshlomif000000000000=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.11'; # 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 Based on work by DeWitt Clinton =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 Cache-2.11/lib/Cache/File/Handle.pm000444000764000764 334212473073254 17264 0ustar00shlomifshlomif000000000000=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 Based on work by DeWitt Clinton =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 Cache-2.11/lib/Cache/Null000755000764000764 012473073254 15427 5ustar00shlomifshlomif000000000000Cache-2.11/lib/Cache/Null/Entry.pm000444000764000764 404612473073254 17227 0ustar00shlomifshlomif000000000000=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.11'; 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 Based on work by DeWitt Clinton =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 Cache-2.11/lib/Cache/Memory000755000764000764 012473073254 15765 5ustar00shlomifshlomif000000000000Cache-2.11/lib/Cache/Memory/HeapElem.pm000444000764000764 242412473073254 20142 0ustar00shlomifshlomif000000000000=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 Based on work by DeWitt Clinton =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 Cache-2.11/lib/Cache/Memory/Entry.pm000444000764000764 1570612473073254 17612 0ustar00shlomifshlomif000000000000=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.11'; 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 Based on work by DeWitt Clinton =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 Cache-2.11/lib/Cache/RemovalStrategy000755000764000764 012473073254 17645 5ustar00shlomifshlomif000000000000Cache-2.11/lib/Cache/RemovalStrategy/LRU.pm000444000764000764 245712473073254 21012 0ustar00shlomifshlomif000000000000=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 Based on work by DeWitt Clinton =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 Cache-2.11/lib/Cache/RemovalStrategy/FIFO.pm000444000764000764 246212473073254 21067 0ustar00shlomifshlomif000000000000=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 Based on work by DeWitt Clinton =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 Cache-2.11/inc000755000764000764 012473073254 13515 5ustar00shlomifshlomif000000000000Cache-2.11/inc/Devel000755000764000764 012473073254 14554 5ustar00shlomifshlomif000000000000Cache-2.11/inc/Devel/AssertOS.pm000444000764000764 472012473073254 16755 0ustar00shlomifshlomif000000000000package # Devel::AssertOS; use Devel::CheckOS; use strict; use vars qw($VERSION); $VERSION = '1.21'; # localising prevents the warningness leaking out of this module local $^W = 1; # use warnings is a 5.6-ism =head1 NAME Devel::AssertOS - require that we are running on a particular OS =head1 DESCRIPTION Devel::AssertOS is a utility module for Devel::CheckOS and Devel::AssertOS::*. It is nothing but a magic C that lets you do this: use Devel::AssertOS qw(Linux FreeBSD Cygwin); which will die unless the platform the code is running on is Linux, FreeBSD or Cygwin. To assert that the OS is B a specific platform, prepend the platform name with a minus sign. For example, to run on anything but Amiga, do: use Devel::AssertOS qw(-Amiga); =cut sub import { shift; die("Devel::AssertOS needs at least one parameter\n") unless(@_); my @oses = @_; my ( @must, @must_not ); for my $os ( @oses ) { if ( $os =~ s/^-// ) { push @must_not, $os; } else { push @must, $os; } } Devel::CheckOS::die_if_os_is(@must_not) if @must_not; Devel::CheckOS::die_if_os_isnt(@must) if @must; } =head1 BUGS and FEEDBACK I welcome feedback about my code, including constructive criticism. Bug reports should be made using L or by email. You will need to include in your bug report the exact value of $^O, what the OS is called (eg Windows Vista 64 bit Ultimate Home Edition), and, if relevant, what "OS family" it should be in and who wrote it. If you are feeling particularly generous you can encourage me in my open source endeavours by buying me something from my wishlist: L =head1 SEE ALSO $^O in L L L L The use-devel-assertos script L =head1 AUTHOR David Cantrell EFE Thanks to David Golden for suggesting that I add this utility module. =head1 COPYRIGHT and LICENCE Copyright 2007 David Cantrell This software is free-as-in-speech software, and may be used, distributed, and modified under the terms of either the GNU General Public Licence version 2 or the Artistic Licence. It's up to you which one you use. The full text of the licences can be found in the files GPL2.txt and ARTISTIC.txt, respectively. =head1 CONSPIRACY This module is also free-as-in-mason software. =cut $^O; Cache-2.11/inc/Devel/CheckOS.pm000444000764000764 2272612473073254 16557 0ustar00shlomifshlomif000000000000package # Devel::CheckOS; use strict; use Exporter; use vars qw($VERSION @ISA @EXPORT_OK %EXPORT_TAGS); $VERSION = '1.71'; # localising prevents the warningness leaking out of this module local $^W = 1; # use warnings is a 5.6-ism @ISA = qw(Exporter); @EXPORT_OK = qw(os_is os_isnt die_if_os_is die_if_os_isnt die_unsupported list_platforms list_family_members); %EXPORT_TAGS = ( all => \@EXPORT_OK, booleans => [qw(os_is os_isnt die_unsupported)], fatal => [qw(die_if_os_is die_if_os_isnt)] ); =head1 NAME Devel::CheckOS - check what OS we're running on =head1 DESCRIPTION A learned sage once wrote on IRC: $^O is stupid and ugly, it wears its pants as a hat Devel::CheckOS provides a more friendly interface to $^O, and also lets you check for various OS "families" such as "Unix", which includes things like Linux, Solaris, AIX etc. It spares perl the embarrassment of wearing its pants on its head by covering them with a splendid Fedora. =head1 SYNOPSIS use Devel::CheckOS qw(os_is); print "Hey, I know this, it's a Unix system\n" if(os_is('Unix')); print "You've got Linux 2.6\n" if(os_is('Linux::v2_6')); =head1 USING IT IN Makefile.PL or Build.PL If you want to use this from Makefile.PL or Build.PL, do not simply copy the module into your distribution as this may cause problems when PAUSE and search.cpan.org index the distro. Instead, use the use-devel-assertos script. =head1 FUNCTIONS Devel::CheckOS implements the following functions, which load subsidiary OS-specific modules on demand to do the real work. They can be exported by listing their names after C. You can also export groups of functions thus: use Devel::CheckOS qw(:booleans); # export the boolean functions # and 'die_unsupported' use Devel::CheckOS qw(:fatal); # export those that die on no match use Devel::CheckOS qw(:all); # export everything =head2 Boolean functions =head3 os_is Takes a list of OS names. If the current platform matches any of them, it returns true, otherwise it returns false. The names can be a mixture of OSes and OS families, eg ... os_is(qw(Unix VMS)); # Unix is a family, VMS is an OS =cut sub os_is { my @targets = @_; my $rval = 0; foreach my $target (@targets) { die("Devel::CheckOS: $target isn't a legal OS name\n") unless($target =~ /^\w+(::\w+)*$/); eval "use Devel::AssertOS::$target"; if(!$@) { no strict 'refs'; $rval = 1 if(&{"Devel::AssertOS::${target}::os_is"}()); } } return $rval; } =head3 os_isnt If the current platform matches any of the parameters it returns false, otherwise it returns true. =cut sub os_isnt { my @targets = @_; my $rval = 1; foreach my $target (@targets) { $rval = 0 if(os_is($target)); } return $rval; } =head2 Fatal functions =head3 die_if_os_isnt As C, except that it dies instead of returning false. The die() message matches what the CPAN-testers look for to determine if a module doesn't support a particular platform. =cut sub die_if_os_isnt { os_is(@_) ? 1 : die_unsupported(); } =head3 die_if_os_is As C, except that it dies instead of returning false. =cut sub die_if_os_is { os_isnt(@_) ? 1 : die_unsupported(); } =head2 And some utility functions ... =head3 die_unsupported This function simply dies with the message "OS unsupported", which is what the CPAN testers look for to figure out whether a platform is supported or not. =cut sub die_unsupported { die("OS unsupported\n"); } =head3 list_platforms When called in list context, return a list of all the platforms for which the corresponding Devel::AssertOS::* module is available. This includes both OSes and OS families, and both those bundled with this module and any third-party add-ons you have installed. In scalar context, returns a hashref keyed by platform with the filename of the most recent version of the supporting module that is available to you. This is to make sure that the use-devel-assertos script Does The Right Thing in the case where you have installed the module in one version of perl, then upgraded perl, and installed it again in the new version. Sometimes the old version of perl and all its modules will still be hanging around and perl "helpfully" includes the old perl's search path in its own. Unfortunately, on some platforms this list may have file case broken. eg, some platforms might return 'freebsd' instead of 'FreeBSD'. This is because they have case-insensitive filesystems so things should Just Work anyway. =cut my ($re_Devel, $re_AssertOS); sub list_platforms { eval " # only load these if needed use File::Find::Rule; use File::Spec; "; die($@) if($@); if (!$re_Devel) { my $case_flag = File::Spec->case_tolerant ? '(?i)' : ''; $re_Devel = qr/$case_flag ^Devel$/x; $re_AssertOS = qr/$case_flag ^AssertOS$/x; } # sort by mtime, so oldest last my @modules = sort { (stat($a->{file}))[9] <=> (stat($b->{file}))[9] } map { my (undef, $dir_part, $file_part) = File::Spec->splitpath($_); $file_part =~ s/\.pm$//; my (@dirs) = grep {+length} File::Spec->splitdir($dir_part); foreach my $i (reverse 1..$#dirs) { next unless $dirs[$i] =~ $re_AssertOS && $dirs[$i - 1] =~ $re_Devel; splice @dirs, 0, $i + 1; last; } { module => join('::', @dirs, $file_part), file => File::Spec->canonpath($_) } } File::Find::Rule->file()->name('*.pm')->in( grep { -d } map { File::Spec->catdir($_, qw(Devel AssertOS)) } @INC ); my %modules = map { $_->{module} => $_->{file} } @modules; if(wantarray()) { return sort keys %modules; } else { return \%modules; } } =head3 list_family_members Takes the name of an OS 'family' and returns a list of all its members. In list context, you get a list, in scalar context you get an arrayref. If called on something that isn't a family, you get an empty list (or a ref to an empty array). =cut sub list_family_members { my $family = shift() || die(__PACKAGE__."::list_family_members needs a parameter\n"); # this will die if it's the wrong OS, but the module is loaded ... eval qq{use Devel::AssertOS::$family}; # ... so we can now query it my @members = eval qq{ no strict 'refs'; &{"Devel::AssertOS::${family}::matches"}() }; return wantarray() ? @members : \@members; } =head1 PLATFORMS SUPPORTED To see the list of platforms for which information is available, run this: perl -MDevel::CheckOS -e 'print join(", ", Devel::CheckOS::list_platforms())' Note that capitalisation is important. These are the names of the underlying Devel::AssertOS::* modules which do the actual platform detection, so they have to be 'legal' filenames and module names, which unfortunately precludes funny characters, so platforms like OS/2 are mis-spelt deliberately. Sorry. Also be aware that not all of them have been properly tested. I don't have access to most of them and have had to work from information gleaned from L and a few other places. For a complete list of OS families, see L. If you want to add your own OSes or families, see L and please feel free to upload the results to the CPAN. =head1 BUGS and FEEDBACK I welcome feedback about my code, including constructive criticism. Bug reports should be made using L or by email. You will need to include in your bug report the exact value of $^O, what the OS is called (eg Windows Vista 64 bit Ultimate Home Edition), and, if relevant, what "OS family" it should be in and who wrote it. If you are feeling particularly generous you can encourage me in my open source endeavours by buying me something from my wishlist: L =head1 SEE ALSO $^O in L L L L L The use-devel-assertos script L =head1 AUTHOR David Cantrell EFE Thanks to David Golden for the name and ideas about the interface, and to the cpan-testers-discuss mailing list for prompting me to write it in the first place. Thanks to Ken Williams, from whose L I lifted some of the information about what should be in the Unix family. Thanks to Billy Abbott for finding some bugs for me on VMS. Thanks to Matt Kraai for information about QNX. Thanks to Kenichi Ishigaki and Gabor Szabo for reporting a bug on Windows, and to the former for providing a patch. Thanks to Paul Green for some information about VOS. Thanks to Yanick Champoux for a patch to let Devel::AssertOS support negative assertions. =head1 SOURCE CODE REPOSITORY L =head1 COPYRIGHT and LICENCE Copyright 2007-2012 David Cantrell This software is free-as-in-speech software, and may be used, distributed, and modified under the terms of either the GNU General Public Licence version 2 or the Artistic Licence. It's up to you which one you use. The full text of the licences can be found in the files GPL2.txt and ARTISTIC.txt, respectively. =head1 HATS I recommend buying a Fedora from L. =head1 CONSPIRACY This module is also free-as-in-mason software. =cut 1; Cache-2.11/inc/Devel/AssertOS000755000764000764 012473073254 16257 5ustar00shlomifshlomif000000000000Cache-2.11/inc/Devel/AssertOS/Unicos.pm000444000764000764 115512473073254 20214 0ustar00shlomifshlomif000000000000# $Id: Unicos.pm,v 1.3 2008/10/27 20:31:21 drhyde Exp $ package # Devel::AssertOS::Unicos; use Devel::CheckOS; $VERSION = '1.1'; sub os_is { $^O =~ /^unicos(mk)?$/ ? 1 : 0; } Devel::CheckOS::die_unsupported() unless(os_is()); =head1 COPYRIGHT and LICENCE Copyright 2007 - 2008 David Cantrell This software is free-as-in-speech software, and may be used, distributed, and modified under the terms of either the GNU General Public Licence version 2 or the Artistic Licence. It's up to you which one you use. The full text of the licences can be found in the files GPL2.txt and ARTISTIC.txt, respectively. =cut 1; Cache-2.11/inc/Devel/AssertOS/AIX.pm000444000764000764 113512473073254 17373 0ustar00shlomifshlomif000000000000# $Id: AIX.pm,v 1.3 2008/10/27 20:31:21 drhyde Exp $ package # Devel::AssertOS::AIX; use Devel::CheckOS; $VERSION = '1.1'; sub os_is { $^O eq 'aix' ? 1 : 0; } Devel::CheckOS::die_unsupported() unless(os_is()); =head1 COPYRIGHT and LICENCE Copyright 2007 - 2008 David Cantrell This software is free-as-in-speech software, and may be used, distributed, and modified under the terms of either the GNU General Public Licence version 2 or the Artistic Licence. It's up to you which one you use. The full text of the licences can be found in the files GPL2.txt and ARTISTIC.txt, respectively. =cut 1; Cache-2.11/inc/Devel/AssertOS/MirOSBSD.pm000444000764000764 115212473073254 20273 0ustar00shlomifshlomif000000000000# $Id: MirOSBSD.pm,v 1.2 2008/10/27 20:31:21 drhyde Exp $ package # Devel::AssertOS::MirOSBSD; use Devel::CheckOS; $VERSION = '1.1'; sub os_is { $^O eq 'mirbsd' ? 1 : 0; } Devel::CheckOS::die_unsupported() unless(os_is()); =head1 COPYRIGHT and LICENCE Copyright 2007 - 2008 David Cantrell This software is free-as-in-speech software, and may be used, distributed, and modified under the terms of either the GNU General Public Licence version 2 or the Artistic Licence. It's up to you which one you use. The full text of the licences can be found in the files GPL2.txt and ARTISTIC.txt, respectively. =cut 1; Cache-2.11/inc/Devel/AssertOS/Unix.pm000444000764000764 231612473073254 17677 0ustar00shlomifshlomif000000000000# $Id: Unix.pm,v 1.9 2008/11/05 22:52:35 drhyde Exp $ package # Devel::AssertOS::Unix; use Devel::CheckOS; $VERSION = '1.4'; # list of OSes lifted from Module::Build 0.2808 # sub matches { return qw( AIX BSDOS DGUX DragonflyBSD Dynix FreeBSD HPUX Interix Irix Linux MachTen MacOSX MirOSBSD NetBSD OpenBSD OSF QNX SCO Solaris SunOS SysVr4 SysVr5 Unicos MidnightBSD ); } sub os_is { Devel::CheckOS::os_is(matches()); } Devel::CheckOS::die_unsupported() unless(os_is()); sub expn { join("\n", "The OS supports multiple concurrent users, devices are represented as", "pseudo-files in /dev, there is a single root to the filesystem, users", "are protected from interference from other users, and the API is POSIXy.", "It should be reasonably easy to port a simple text-mode C program", "between Unixes." ) } =head1 COPYRIGHT and LICENCE Copyright 2007 - 2008 David Cantrell This software is free-as-in-speech software, and may be used, distributed, and modified under the terms of either the GNU General Public Licence version 2 or the Artistic Licence. It's up to you which one you use. The full text of the licences can be found in the files GPL2.txt and ARTISTIC.txt, respectively. =cut 1; Cache-2.11/inc/Devel/AssertOS/OSF.pm000444000764000764 125212473073254 17401 0ustar00shlomifshlomif000000000000# $Id: OSF.pm,v 1.4 2008/11/05 22:52:34 drhyde Exp $ package # Devel::AssertOS::OSF; use Devel::CheckOS; $VERSION = '1.1'; sub os_is { $^O eq 'dec_osf' ? 1 : 0; } sub expn { "OSF is also known as OSF/1, Digital Unix, and Tru64 Unix" } Devel::CheckOS::die_unsupported() unless(os_is()); =head1 COPYRIGHT and LICENCE Copyright 2007 - 2008 David Cantrell This software is free-as-in-speech software, and may be used, distributed, and modified under the terms of either the GNU General Public Licence version 2 or the Artistic Licence. It's up to you which one you use. The full text of the licences can be found in the files GPL2.txt and ARTISTIC.txt, respectively. =cut 1; Cache-2.11/inc/Devel/AssertOS/DGUX.pm000444000764000764 114012473073254 17515 0ustar00shlomifshlomif000000000000# $Id: DGUX.pm,v 1.3 2008/10/27 20:31:21 drhyde Exp $ package # Devel::AssertOS::DGUX; use Devel::CheckOS; $VERSION = '1.1'; sub os_is { $^O eq 'dgux' ? 1 : 0; } Devel::CheckOS::die_unsupported() unless(os_is()); =head1 COPYRIGHT and LICENCE Copyright 2007 - 2008 David Cantrell This software is free-as-in-speech software, and may be used, distributed, and modified under the terms of either the GNU General Public Licence version 2 or the Artistic Licence. It's up to you which one you use. The full text of the licences can be found in the files GPL2.txt and ARTISTIC.txt, respectively. =cut 1; Cache-2.11/inc/Devel/AssertOS/MachTen.pm000444000764000764 137612473073254 20300 0ustar00shlomifshlomif000000000000# $Id: MachTen.pm,v 1.4 2008/11/05 22:52:34 drhyde Exp $ package # Devel::AssertOS::MachTen; use Devel::CheckOS; $VERSION = '1.1'; sub os_is { $^O eq 'machten' ? 1 : 0; } sub expn { join("\n", "You're using the Mach Ten BSD-compatible environment on top of", "Mac OS 'Classic' - ie, a pre-OS-X version of Mac OS.", ) } Devel::CheckOS::die_unsupported() unless(os_is()); =head1 COPYRIGHT and LICENCE Copyright 2007 - 2008 David Cantrell This software is free-as-in-speech software, and may be used, distributed, and modified under the terms of either the GNU General Public Licence version 2 or the Artistic Licence. It's up to you which one you use. The full text of the licences can be found in the files GPL2.txt and ARTISTIC.txt, respectively. =cut 1; Cache-2.11/inc/Devel/AssertOS/SunOS.pm000444000764000764 114312473073254 17760 0ustar00shlomifshlomif000000000000# $Id: SunOS.pm,v 1.3 2008/10/27 20:31:21 drhyde Exp $ package # Devel::AssertOS::SunOS; use Devel::CheckOS; $VERSION = '1.1'; sub os_is { $^O eq 'sunos' ? 1 : 0; } Devel::CheckOS::die_unsupported() unless(os_is()); =head1 COPYRIGHT and LICENCE Copyright 2007 - 2008 David Cantrell This software is free-as-in-speech software, and may be used, distributed, and modified under the terms of either the GNU General Public Licence version 2 or the Artistic Licence. It's up to you which one you use. The full text of the licences can be found in the files GPL2.txt and ARTISTIC.txt, respectively. =cut 1; Cache-2.11/inc/Devel/AssertOS/SysVr5.pm000444000764000764 114412473073254 20125 0ustar00shlomifshlomif000000000000# $Id: SysVr5.pm,v 1.3 2008/10/27 20:31:21 drhyde Exp $ package # Devel::AssertOS::SysVr5; use Devel::CheckOS; $VERSION = '1.1'; sub os_is { $^O eq 'svr5' ? 1 : 0; } Devel::CheckOS::die_unsupported() unless(os_is()); =head1 COPYRIGHT and LICENCE Copyright 2007 - 2008 David Cantrell This software is free-as-in-speech software, and may be used, distributed, and modified under the terms of either the GNU General Public Licence version 2 or the Artistic Licence. It's up to you which one you use. The full text of the licences can be found in the files GPL2.txt and ARTISTIC.txt, respectively. =cut 1; Cache-2.11/inc/Devel/AssertOS/QNX.pm000444000764000764 140512473073254 17420 0ustar00shlomifshlomif000000000000# $Id: QNX.pm,v 1.2 2008/10/27 20:31:21 drhyde Exp $ package # Devel::AssertOS::QNX; use Devel::CheckOS; $VERSION = '1.2'; sub matches { return qw(QNX::v4 QNX::Neutrino); } sub os_is { Devel::CheckOS::os_is(matches()); } sub expn { join("\n", "All versions of QNX match this, as well as (possibly) a more specific", "match" ) } Devel::CheckOS::die_unsupported() unless(os_is()); =head1 COPYRIGHT and LICENCE Copyright 2007 - 2008 David Cantrell This software is free-as-in-speech software, and may be used, distributed, and modified under the terms of either the GNU General Public Licence version 2 or the Artistic Licence. It's up to you which one you use. The full text of the licences can be found in the files GPL2.txt and ARTISTIC.txt, respectively. =cut 1; Cache-2.11/inc/Devel/AssertOS/HPUX.pm000444000764000764 114012473073254 17532 0ustar00shlomifshlomif000000000000# $Id: HPUX.pm,v 1.3 2008/10/27 20:31:21 drhyde Exp $ package # Devel::AssertOS::HPUX; use Devel::CheckOS; $VERSION = '1.1'; sub os_is { $^O eq 'hpux' ? 1 : 0; } Devel::CheckOS::die_unsupported() unless(os_is()); =head1 COPYRIGHT and LICENCE Copyright 2007 - 2008 David Cantrell This software is free-as-in-speech software, and may be used, distributed, and modified under the terms of either the GNU General Public Licence version 2 or the Artistic Licence. It's up to you which one you use. The full text of the licences can be found in the files GPL2.txt and ARTISTIC.txt, respectively. =cut 1; Cache-2.11/inc/Devel/AssertOS/SCO.pm000444000764000764 114012473073254 17372 0ustar00shlomifshlomif000000000000# $Id: SCO.pm,v 1.3 2008/10/27 20:31:21 drhyde Exp $ package # Devel::AssertOS::SCO; use Devel::CheckOS; $VERSION = '1.1'; sub os_is { $^O eq 'sco_sv' ? 1 : 0; } Devel::CheckOS::die_unsupported() unless(os_is()); =head1 COPYRIGHT and LICENCE Copyright 2007 - 2008 David Cantrell This software is free-as-in-speech software, and may be used, distributed, and modified under the terms of either the GNU General Public Licence version 2 or the Artistic Licence. It's up to you which one you use. The full text of the licences can be found in the files GPL2.txt and ARTISTIC.txt, respectively. =cut 1; Cache-2.11/inc/Devel/AssertOS/Linux.pm000444000764000764 114312473073254 20050 0ustar00shlomifshlomif000000000000# $Id: Linux.pm,v 1.5 2008/10/27 20:31:21 drhyde Exp $ package # Devel::AssertOS::Linux; use Devel::CheckOS; $VERSION = '1.1'; sub os_is { $^O eq 'linux' ? 1 : 0; } Devel::CheckOS::die_unsupported() unless(os_is()); =head1 COPYRIGHT and LICENCE Copyright 2007 - 2008 David Cantrell This software is free-as-in-speech software, and may be used, distributed, and modified under the terms of either the GNU General Public Licence version 2 or the Artistic Licence. It's up to you which one you use. The full text of the licences can be found in the files GPL2.txt and ARTISTIC.txt, respectively. =cut 1; Cache-2.11/inc/Devel/AssertOS/DragonflyBSD.pm000444000764000764 116512473073254 21233 0ustar00shlomifshlomif000000000000# $Id: DragonflyBSD.pm,v 1.3 2008/10/27 20:31:21 drhyde Exp $ package # Devel::AssertOS::DragonflyBSD; use Devel::CheckOS; $VERSION = '1.1'; sub os_is { $^O eq 'dragonfly' ? 1 : 0; } Devel::CheckOS::die_unsupported() unless(os_is()); =head1 COPYRIGHT and LICENCE Copyright 2007 - 2008 David Cantrell This software is free-as-in-speech software, and may be used, distributed, and modified under the terms of either the GNU General Public Licence version 2 or the Artistic Licence. It's up to you which one you use. The full text of the licences can be found in the files GPL2.txt and ARTISTIC.txt, respectively. =cut 1; Cache-2.11/inc/Devel/AssertOS/OpenBSD.pm000444000764000764 115112473073254 20202 0ustar00shlomifshlomif000000000000# $Id: OpenBSD.pm,v 1.3 2008/10/27 20:31:21 drhyde Exp $ package # Devel::AssertOS::OpenBSD; use Devel::CheckOS; $VERSION = '1.1'; sub os_is { $^O eq 'openbsd' ? 1 : 0; } Devel::CheckOS::die_unsupported() unless(os_is()); =head1 COPYRIGHT and LICENCE Copyright 2007 - 2008 David Cantrell This software is free-as-in-speech software, and may be used, distributed, and modified under the terms of either the GNU General Public Licence version 2 or the Artistic Licence. It's up to you which one you use. The full text of the licences can be found in the files GPL2.txt and ARTISTIC.txt, respectively. =cut 1; Cache-2.11/inc/Devel/AssertOS/FreeBSD.pm000444000764000764 116212473073254 20164 0ustar00shlomifshlomif000000000000# $Id: FreeBSD.pm,v 1.5 2008/10/27 20:31:21 drhyde Exp $ package # Devel::AssertOS::FreeBSD; use Devel::CheckOS; $VERSION = '1.1'; sub os_is { $^O =~ /^(gnuk)?freebsd$/ ? 1 : 0; } Devel::CheckOS::die_unsupported() unless(os_is()); =head1 COPYRIGHT and LICENCE Copyright 2007 - 2008 David Cantrell This software is free-as-in-speech software, and may be used, distributed, and modified under the terms of either the GNU General Public Licence version 2 or the Artistic Licence. It's up to you which one you use. The full text of the licences can be found in the files GPL2.txt and ARTISTIC.txt, respectively. =cut 1; Cache-2.11/inc/Devel/AssertOS/NetBSD.pm000444000764000764 114612473073254 20033 0ustar00shlomifshlomif000000000000# $Id: NetBSD.pm,v 1.3 2008/10/27 20:31:21 drhyde Exp $ package # Devel::AssertOS::NetBSD; use Devel::CheckOS; $VERSION = '1.1'; sub os_is { $^O eq 'netbsd' ? 1 : 0; } Devel::CheckOS::die_unsupported() unless(os_is()); =head1 COPYRIGHT and LICENCE Copyright 2007 - 2008 David Cantrell This software is free-as-in-speech software, and may be used, distributed, and modified under the terms of either the GNU General Public Licence version 2 or the Artistic Licence. It's up to you which one you use. The full text of the licences can be found in the files GPL2.txt and ARTISTIC.txt, respectively. =cut 1; Cache-2.11/inc/Devel/AssertOS/SysVr4.pm000444000764000764 114412473073254 20124 0ustar00shlomifshlomif000000000000# $Id: SysVr4.pm,v 1.3 2008/10/27 20:31:21 drhyde Exp $ package # Devel::AssertOS::SysVr4; use Devel::CheckOS; $VERSION = '1.1'; sub os_is { $^O eq 'svr4' ? 1 : 0; } Devel::CheckOS::die_unsupported() unless(os_is()); =head1 COPYRIGHT and LICENCE Copyright 2007 - 2008 David Cantrell This software is free-as-in-speech software, and may be used, distributed, and modified under the terms of either the GNU General Public Licence version 2 or the Artistic Licence. It's up to you which one you use. The full text of the licences can be found in the files GPL2.txt and ARTISTIC.txt, respectively. =cut 1; Cache-2.11/inc/Devel/AssertOS/Interix.pm000444000764000764 115112473073254 20372 0ustar00shlomifshlomif000000000000# $Id: Interix.pm,v 1.3 2008/10/27 20:31:21 drhyde Exp $ package # Devel::AssertOS::Interix; use Devel::CheckOS; $VERSION = '1.1'; sub os_is { $^O eq 'interix' ? 1 : 0; } Devel::CheckOS::die_unsupported() unless(os_is()); =head1 COPYRIGHT and LICENCE Copyright 2007 - 2008 David Cantrell This software is free-as-in-speech software, and may be used, distributed, and modified under the terms of either the GNU General Public Licence version 2 or the Artistic Licence. It's up to you which one you use. The full text of the licences can be found in the files GPL2.txt and ARTISTIC.txt, respectively. =cut 1; Cache-2.11/inc/Devel/AssertOS/MacOSX.pm000444000764000764 114612473073254 20046 0ustar00shlomifshlomif000000000000# $Id: MacOSX.pm,v 1.3 2008/10/27 20:31:21 drhyde Exp $ package # Devel::AssertOS::MacOSX; use Devel::CheckOS; $VERSION = '1.1'; sub os_is { $^O eq 'darwin' ? 1 : 0; } Devel::CheckOS::die_unsupported() unless(os_is()); =head1 COPYRIGHT and LICENCE Copyright 2007 - 2008 David Cantrell This software is free-as-in-speech software, and may be used, distributed, and modified under the terms of either the GNU General Public Licence version 2 or the Artistic Licence. It's up to you which one you use. The full text of the licences can be found in the files GPL2.txt and ARTISTIC.txt, respectively. =cut 1; Cache-2.11/inc/Devel/AssertOS/BSDOS.pm000444000764000764 114312473073254 17623 0ustar00shlomifshlomif000000000000# $Id: BSDOS.pm,v 1.3 2008/10/27 20:31:21 drhyde Exp $ package # Devel::AssertOS::BSDOS; use Devel::CheckOS; $VERSION = '1.1'; sub os_is { $^O eq 'bsdos' ? 1 : 0; } Devel::CheckOS::die_unsupported() unless(os_is()); =head1 COPYRIGHT and LICENCE Copyright 2007 - 2008 David Cantrell This software is free-as-in-speech software, and may be used, distributed, and modified under the terms of either the GNU General Public Licence version 2 or the Artistic Licence. It's up to you which one you use. The full text of the licences can be found in the files GPL2.txt and ARTISTIC.txt, respectively. =cut 1; Cache-2.11/inc/Devel/AssertOS/Solaris.pm000444000764000764 115112473073254 20364 0ustar00shlomifshlomif000000000000# $Id: Solaris.pm,v 1.3 2008/10/27 20:31:21 drhyde Exp $ package # Devel::AssertOS::Solaris; use Devel::CheckOS; $VERSION = '1.1'; sub os_is { $^O eq 'solaris' ? 1 : 0; } Devel::CheckOS::die_unsupported() unless(os_is()); =head1 COPYRIGHT and LICENCE Copyright 2007 - 2008 David Cantrell This software is free-as-in-speech software, and may be used, distributed, and modified under the terms of either the GNU General Public Licence version 2 or the Artistic Licence. It's up to you which one you use. The full text of the licences can be found in the files GPL2.txt and ARTISTIC.txt, respectively. =cut 1; Cache-2.11/inc/Devel/AssertOS/MidnightBSD.pm000444000764000764 106712473073254 21052 0ustar00shlomifshlomif000000000000package # Devel::AssertOS::MidnightBSD; use Devel::CheckOS; $VERSION = '1.0'; sub os_is { $^O eq 'midnightbsd' ? 1 : 0; } Devel::CheckOS::die_unsupported() unless(os_is()); =head1 COPYRIGHT and LICENCE Copyright 2007 - 2008 David Cantrell This software is free-as-in-speech software, and may be used, distributed, and modified under the terms of either the GNU General Public Licence version 2 or the Artistic Licence. It's up to you which one you use. The full text of the licences can be found in the files GPL2.txt and ARTISTIC.txt, respectively. =cut 1; Cache-2.11/inc/Devel/AssertOS/Irix.pm000444000764000764 114012473073254 17661 0ustar00shlomifshlomif000000000000# $Id: Irix.pm,v 1.3 2008/10/27 20:31:21 drhyde Exp $ package # Devel::AssertOS::Irix; use Devel::CheckOS; $VERSION = '1.1'; sub os_is { $^O eq 'irix' ? 1 : 0; } Devel::CheckOS::die_unsupported() unless(os_is()); =head1 COPYRIGHT and LICENCE Copyright 2007 - 2008 David Cantrell This software is free-as-in-speech software, and may be used, distributed, and modified under the terms of either the GNU General Public Licence version 2 or the Artistic Licence. It's up to you which one you use. The full text of the licences can be found in the files GPL2.txt and ARTISTIC.txt, respectively. =cut 1; Cache-2.11/inc/Devel/AssertOS/Dynix.pm000444000764000764 114612473073254 20047 0ustar00shlomifshlomif000000000000# $Id: Dynix.pm,v 1.3 2008/10/27 20:31:21 drhyde Exp $ package # Devel::AssertOS::Dynix; use Devel::CheckOS; $VERSION = '1.1'; sub os_is { $^O eq 'dynixptx' ? 1 : 0; } Devel::CheckOS::die_unsupported() unless(os_is()); =head1 COPYRIGHT and LICENCE Copyright 2007 - 2008 David Cantrell This software is free-as-in-speech software, and may be used, distributed, and modified under the terms of either the GNU General Public Licence version 2 or the Artistic Licence. It's up to you which one you use. The full text of the licences can be found in the files GPL2.txt and ARTISTIC.txt, respectively. =cut 1; Cache-2.11/inc/Devel/AssertOS/QNX000755000764000764 012473073254 16725 5ustar00shlomifshlomif000000000000Cache-2.11/inc/Devel/AssertOS/QNX/Neutrino.pm000444000764000764 127512473073254 21230 0ustar00shlomifshlomif000000000000# $Id: Neutrino.pm,v 1.3 2008/11/05 22:52:35 drhyde Exp $ package # Devel::AssertOS::QNX::Neutrino; use Devel::CheckOS; $VERSION = '1.1'; sub os_is { $^O eq 'nto' ? 1 : 0; } sub expn { "The operating system is version 6 of QNX, also known as Neutrino" } Devel::CheckOS::die_unsupported() unless(os_is()); =head1 COPYRIGHT and LICENCE Copyright 2007 - 2008 David Cantrell This software is free-as-in-speech software, and may be used, distributed, and modified under the terms of either the GNU General Public Licence version 2 or the Artistic Licence. It's up to you which one you use. The full text of the licences can be found in the files GPL2.txt and ARTISTIC.txt, respectively. =cut 1; Cache-2.11/inc/Devel/AssertOS/QNX/v4.pm000444000764000764 123112473073254 17746 0ustar00shlomifshlomif000000000000# $Id: v4.pm,v 1.3 2008/11/05 22:52:35 drhyde Exp $ package # Devel::AssertOS::QNX::v4; use Devel::CheckOS; $VERSION = '1.1'; sub os_is { $^O eq 'qnx' ? 1 : 0; } sub expn { "The operating system is version 4 of QNX" } Devel::CheckOS::die_unsupported() unless(os_is()); =head1 COPYRIGHT and LICENCE Copyright 2007 - 2008 David Cantrell This software is free-as-in-speech software, and may be used, distributed, and modified under the terms of either the GNU General Public Licence version 2 or the Artistic Licence. It's up to you which one you use. The full text of the licences can be found in the files GPL2.txt and ARTISTIC.txt, respectively. =cut 1; Cache-2.11/inc/Test000755000764000764 012473073254 14434 5ustar00shlomifshlomif000000000000Cache-2.11/inc/Test/Run000755000764000764 012473073254 15200 5ustar00shlomifshlomif000000000000Cache-2.11/inc/Test/Run/Builder.pm000444000764000764 316712473073254 17270 0ustar00shlomifshlomif000000000000package Test::Run::Builder; use strict; use warnings; use Module::Build; use vars qw(@ISA); @ISA = (qw(Module::Build)); sub ACTION_runtest { my ($self) = @_; my $p = $self->{properties}; $self->depends_on('code'); local @INC = @INC; # Make sure we test the module in blib/ unshift @INC, (File::Spec->catdir($p->{base_dir}, $self->blib, 'lib'), File::Spec->catdir($p->{base_dir}, $self->blib, 'arch')); $self->do_test_run_tests; } sub ACTION_distruntest { my ($self) = @_; $self->depends_on('distdir'); my $start_dir = $self->cwd; my $dist_dir = $self->dist_dir; chdir $dist_dir or die "Cannot chdir to $dist_dir: $!"; # XXX could be different names for scripts $self->run_perl_script('Build.PL') # XXX Should this be run w/ --nouse-rcfile or die "Error executing 'Build.PL' in dist directory: $!"; $self->run_perl_script('Build') or die "Error executing 'Build' in dist directory: $!"; $self->run_perl_script('Build', [], ['runtest']) or die "Error executing 'Build test' in dist directory"; chdir $start_dir; } sub do_test_run_tests { my $self = shift; require Test::Run::CmdLine::Iface; my $test_run = Test::Run::CmdLine::Iface->new( { 'test_files' => [glob("t/*.t")], } # 'backend_params' => $self->_get_backend_params(), ); return $test_run->run(); } sub ACTION_tags { return system(qw( ctags -f tags --recurse --totals --exclude=blib/** --exclude=t/lib/** --exclude=.svn --exclude='*~' --languages=Perl --langmap=Perl:+.t )); } 1; Cache-2.11/t000755000764000764 012473073254 13207 5ustar00shlomifshlomif000000000000Cache-2.11/t/null.t000444000764000764 317012473073254 14504 0ustar00shlomifshlomif000000000000use 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'); Cache-2.11/t/memory_tie.t000444000764000764 136312473073254 15705 0ustar00shlomifshlomif000000000000use 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'); } Cache-2.11/t/style-trailing-space.t000444000764000764 73012473073254 17551 0ustar00shlomifshlomif000000000000#!/usr/bin/perl use strict; use warnings; use Test::More; eval "use Test::TrailingSpace"; if ($@) { plan skip_all => "Test::TrailingSpace required for trailing space test."; } else { plan tests => 1; } my $finder = Test::TrailingSpace->new( { root => '.', filename_regex => qr/(?:(?:\.(?:t|pm|pl|PL|yml|json|arc|vim))|README|Changes|LICENSE|MANIFEST)\z/, }, ); # TEST $finder->no_trailing_space( "No trailing space was found." ); Cache-2.11/t/00basic.t000444000764000764 63112473073254 14732 0ustar00shlomifshlomif000000000000use 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'); Cache-2.11/t/file_fifo.t000444000764000764 467512473073254 15467 0ustar00shlomifshlomif000000000000use 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'); Cache-2.11/t/memory_lru.t000444000764000764 370312473073254 15726 0ustar00shlomifshlomif000000000000use 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'); Cache-2.11/t/file_tie.t000444000764000764 153412473073254 15314 0ustar00shlomifshlomif000000000000use 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'); } Cache-2.11/t/01fileheap.t000444000764000764 1101112473073254 15461 0ustar00shlomifshlomif000000000000use 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'); Cache-2.11/t/memory_fifo.t000444000764000764 377712473073254 16062 0ustar00shlomifshlomif000000000000use 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'); Cache-2.11/t/memory.t000444000764000764 43512473073254 15023 0ustar00shlomifshlomif000000000000use 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); Cache-2.11/t/pod.t000444000764000764 21412473073254 14270 0ustar00shlomifshlomif000000000000#!perl -T use Test::More; eval "use Test::Pod 1.14"; plan skip_all => "Test::Pod 1.14 required for testing POD" if $@; all_pod_files_ok(); Cache-2.11/t/file.t000444000764000764 332112473073254 14447 0ustar00shlomifshlomif000000000000#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 + 1 } 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); } { my $tempdir = tempdir(CLEANUP => 1); my $cache = Cache::File->new(cache_root => $tempdir,); { # See: # https://rt.cpan.org/Public/Bug/Display.html?id=95608 my $warning; { local $SIG{__WARN__} = sub { $warning = shift; }; $cache->set ('test', {x => 23}, '10 s'); } like ($warning, qr/\AReference passed to set/, "Got the right warning on passing a reference to set.") } } { # 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"); } Cache-2.11/t/memory_set_namespace_rt32339.t000444000764000764 61412473073254 21022 0ustar00shlomifshlomif000000000000#!/usr/bin/perl # Regression test for: # https://rt.cpan.org/Ticket/Display.html?id=32339 use strict; use warnings; use Cache::Memory; use Test::More tests => 1; { my $cache = Cache::Memory->new(); $cache->set('foo','bar'); $cache->set_namespace("OtherNameSpace"); # This used to die: $cache->set('foo','bar2'); # TEST ok (1, "Program finished successfully."); } Cache-2.11/t/file_lru.t000444000764000764 453612473073254 15342 0ustar00shlomifshlomif000000000000use 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 ); 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'); Cache-2.11/scripts000755000764000764 012473073254 14433 5ustar00shlomifshlomif000000000000Cache-2.11/scripts/bump-version-number.pl000444000764000764 121012473073254 21033 0ustar00shlomifshlomif000000000000#!/usr/bin/perl use strict; use warnings; use File::Find::Object; use IO::All; my $tree = File::Find::Object->new({}, 'lib/'); my $version_n = shift(@ARGV); if (!defined($version_n)) { die "Specify version number as an argument! bump-version-number.pl '0.0.1'"; } while (my $r = $tree->next()) { if ($r =~ m{/\.svn\z}) { $tree->prune(); } elsif ($r =~ m{\.pm\z}) { my @lines = io->file($r)->getlines(); foreach (@lines) { s#(\$VERSION = '|^Version )\d+\.\d+(?:\.\d+)?('|)#$1 . $version_n . $2#e; } io->file($r)->print( @lines ); } }