Cache-Cache-1.08/000755 000766 000024 00000000000 12460220542 013547 5ustar00rjbsstaff000000 000000 Cache-Cache-1.08/CHANGES000644 000766 000024 00000017520 12460220300 014537 0ustar00rjbsstaff000000 000000 Revision history for Cache 1.08 2015-01-22 - try to avoid some race conditions (thanks, Petr Písař) - typo fixes (thanks, David Steinbrunner) 1.07 2014-09-17 - fix a bug where we checked @$ instead of $@ after eval 1.06 2009-02-28 - updated the project homepage and added notes about the CHI project - fixed extra "use vars" in CacheUtils 1.05 2006-05-26 - fixed infinite loop with auto_purge_on_get - fixed directory paths on Windows partitions - NullCache uses BaseCache 1.04 2005-03-17-11-23 - release version 1.04 - repair permissions on temp cache files 1.03 2004-10-04-11-23 - release version 1.03 - modified the FileBackend to use the more robust File::Temp - "officially" recommend FileCache over SharedMemoryCache - added more robust error checking for shared memory caches - added a check for invalid frozen data - added $1 to all error messages 1.02 2003-04-15-10-41 - released version 1.02 - require Digest::SHA1 2.02, optionally IPC::ShareLite 0.09 - use Storable's "nfreeze" instead of "freeze" - added notes on locking and Storable to the README - updated documentation on expiration units - modified the quoting of the untainted path regex - fixed the duplicated get_keys in NullCache - applied patch to ensure consistent state if the filesystem fills up - applied patch to ensure initialization of the memory cache hash 1.01 2002-04-14-01-30 - released version 1.01 - switched to Digest::SHA1 - updated copyright dates 1.0 2002-04-06-18-51 - released version 1.0 - localized scope of global file and directory handles (FILE and DIR) - applied Jonathan Swartz's patch for a much better untainting regex - changed _Untaint_String to throw an exception on a taint - further improved the fix to prevent race conditions that caused the tests to fail - exposed the get_namespaces method on Cache - fixed the failing Win32 tests caused by fileglobs in Makefile.PL - applied Yves Orton's patch in _Make_Path to fix warnings on Win32 0.99 2001-12-09-18-45 - released version 0.99 - major refactoring of code - replaced non-standard usage of SUCCESS and FAILURE with Error.pm - replaced non-standard usage of TRUE and FALSE with 1 and 0 - migrated from the term "identifier" to the more standard term "key" and marked the old public methods with identifier as deprecated - broke out the MemoryBackend, FileBackend, SharedMemoryBackend into distinct and reusable classes - fixed a long outstanding bug in the unit tests that made working caches appear to fail - changed the meaning of object and cache size for file system based caches to consistently reflect the total size of the objects on disk, but not including the directory overhead - changed format of persisted data in the FileBackend - major rewrite of documentation 0.09 2001-09-10-12-10 - released version 0.09 - applied Axel Beckert patch to fix the expiration units - applied Ken Williams's directory creation patch to pass all tests - changed the license to be either the GPL or the Artistic license - added Jay Sachs' implementation of NullCache - modified the remove methods to avoid croaking if two cache instances are both purging or limiting at the same time - migrated to a factory-like model with private constructors to fix the auto_purge_interval functionality - updated the documentation to better reflect that size means size in bytes - started version 0.09 0.08 2001-04-26-08-53 - released version 0.08 - renamed the auto_purge option to auto_purge_interval - added the auto_purge_on_set and auto_purge_on_get options - moved the Auto_Purge and Reset_Auto_Purge methods to BaseCache as the instance methods _auto_purge and _reset_auto_purge - added the auto_purge option and property to the base cache interface and implementations. This option will call the purge method on the cache after the specified interval expires - renamed _set_namespace to set_namespace (i.e., made it public) - added the set_object method to the cache interface - updated the test scripts and CREDITS file - updated the perldoc formatting to look better in HTML - removed the $VERSION from SizeAwareCache - started version 0.08 0.07 2001-03-27-08-55 - released version 0.07 - prepared for initial CPAN release - improved Cache::Cache documentation - removed last "use IPC::Shareable" - added support in the Makefile.PL to conditionally build the SharedMemoryCache, which requires IPC::ShareLite, and thus runs only on certain architectures. Also broke out the IPC related routines into the SharedCacheUtils package. - started version 0.07 0.06 2001-03-23-08-36 - release version 0.06 - added the get_identifiers method to the Cache interface, implemented the method for all classes, added a new test, and updated the test scripts - added the size property to Object - added the _freeze and _thaw methods to the BaseCache class and modified all children classes to use them - revert to separate freeze and thaws on the memory based caches to ensure that cached data isn't modified at any time - major rewrite of the size aware cache logic - added the CacheMetaData class, which is used to efficiently keep track of a size aware cache state - refactored the instance specific limit_size routines into the generic Limit_Size method in CacheUtils - updated the size aware cache implementations to use the CacheMetaData and Limit_Size methods - improved the SizeAwareCacheTester and updated the test scripts - removed unnecessary clone call from the SharedMemoryCache and the SizeAwareSharedMemoryCache - added exclusive locking on the shared cache for operations that will both read and write to the cache - replaced the cache_hash_ref instance property in MemoryCache with a class property and updated the SharedMemoryCache and SizeAwareSharedMemoryCache modules accordingly - started version 0.06 0.05 2001-03-20-10-25 - released version 0.05 - updated Storable dependency to 1.011 - replaced the IPC::Shareable backend with IPC::ShareLite - started version 0.05 0.04 2001-03-17-10-43 - released version 0.04 - replaced Data::Dumper with Storable, which is now a requirement - implemented the SizeAwareMemoryCache and associated tests - implemented the SizeAwareSharedMemoryCache and associated tests - added the SizeAwareCache interface - moved max_size logic from the _store method to the set method - started version 0.04 0.03 2001-03-10-12-40 - released version 0.03 - made the FileCache more multi-user friendly by allowing a more permissive default directory umask, which can also be optionally overridden - updated documentation and code style - completely rewrote and improved the limit_size method for a major performance gain - updated the syntax for expiration times to include the [number] [unit] format, e.g. "10 seconds" - added the get_object method to the Cache interface, which allows access to the underlying cache object (without potentially expiring the object) - added the get_namespace and get_default_expires_in methods to the Cache interface definition - updated the MANIFEST - checked in preliminary cache benchmarking code - fixed bug fixed bug #406030 -- default_expires_in never invoked - refactored common code into BaseCache - use Static_Params method - fixed default_expires_in bug - added coding guidelines to STYLE - started version 0.03 0.02 2001-02-15-21-12 - released version 0.02 - added perldoc to SizeAwareFileCache - created SizeAwareFileCache - added the SizeAwareCacheTester module - refactored common test code into the AbstractCacheTester module - added the Recursively_List_Files_With_Paths routine to CacheUtils - marked the FileCache and MemoryCache as ISA Cache::Cache - updated the MANIFEST - started version 0.02 0.01 2001-02-13-16-16 - released version 0.01 - implemented Get_Temp_Dir to make the FileCache root more OS independent - started version 0.01 Cache-Cache-1.08/COPYING000644 000766 000024 00000000222 12406310064 014575 0ustar00rjbsstaff000000 000000 You may distribute under the terms of either the GNU General Public License or the Artistic License, as specified in the Perl README file. Cache-Cache-1.08/CREDITS000644 000766 000024 00000013764 12406310064 014601 0ustar00rjbsstaff000000 000000 - Stefano Rodighiero for catching the extra "use vars" in CacheUtils - dwright at cpan.org for the fix on the infinite loop for auto_purge_on_get - thanks to for catching the windows directory path bug - worked with andrew velikoredchanin to fix a bug with file permissions at File::Temp - thomas.acunzo at ubs.com identified some issues with SharedMemoryCache which led to better error checking - siracusa at mindspring.com suggested using $1 on all error messages - Stephen Edmonds caught a bug where invalid frozen data could be returned. - Shailen Bellare assisted in the work required to migrated to Storable's "nfreeze" instead of "freeze" - Simran submitted a patch to correctly initialize the MemoryBackend hash - Rob Mueller and Jeremy Howard provided a patch to ensure consistent state if the filesystem fills up - Glady.Junsay noticed that get_keys was defined twice in NullCache - Sterling Swartwout helped track down an issue with the regex quoting in older versions of perl - Yves Orton , a CPAN tester, submitted a patch to _Make_Path to fix warnings on Win32 - Adam Tricket and helped debug the make test failure (due to fileglobs in Makefile.PL) on Windows - Christian Gilmore suggested that I expose the get_namespaces method through the Cache interface - Jonathan Swartz submitted a patch for a much better untainting regex - Richard Chen informed me of a better way to call static methods without knowing the type of the class until runtime - Christophe Marcant offered a patch to allow spaces to be used in the filenames - Eric Cholet offered a patch to fix the missing import in Cache::CacheUtils and is helping debug using a Backend on its own - Axel Beckert submitted a patch to fix a bug in the expiration units - Ken Williams submitted a patch to workaround a File::Path bug that was causing make test to fail - Randal Schwartz discovered a nasty bug on the construction of cache instances that use the auto_purge_interval - Chris Fairbanks helped think through the factory-like model for construction using private constructors that allow for the proper initialization of child classes - Rob Bloodgood discovered that the documentation should better reflect that size means size in bytes - Bjorn Jacobsen suggested that I use the OO interface to File::Spec to avoid inadvertently importing those methods into the global namespace - Jay Sachs for suggesting and writing the NullCache implementation - Randal Schwartz wrote about an automatic purging mechanism for the cache in Web Techniques, and helped me implement that feature as part of the framework - Matt Sly for catching a bug with erroneously importing an unused module - Dave Rolsky for helping me rewrite the Makefile.PL to do conditional installation and testing based on dependency detection - Greg Cope suggested that I switch to IPC::ShareLite, and helped debug version 0.05 - Daniel Little suggested that I write the SizeAwareMemoryCache module - Jonathan Swartz , a Perl Cache project developer, for the expanded expiration format code and all of the great dialog in the list server, continued testing, and a million good ideas! A big thanks, Jonathan. - Sergey Polyakov for numerous bug reports and for being an early adopter of Perl Cache # The follow credits were copied from File::Cache, the previous # incarnation of this library - David Coppit added: max_size, auto_purge, get_stale(), reduce_size(), username, and filemode, fixed a bug that prevented expired cache items from being unlinked by purge(), and added the get_creation_time() and get_expiration_time() routines. (a big thanks David!) Also, David added the Data::Dumper persistence format for cross-OS operability and greatly improved the documentation, and many many other things - Larry Moore , a cpan tester, noticed that version 0.04 failed to compile on MacOS (thanks Larry!) - Frey Kuo pointed out that the example in the README was rather buggy. (thanks Frey!) - Doug Steinwand found that on FreeBSD, the _purge routine failed due to an issue with File::Find and even provided a fix. (thanks Doug!) - Chris Winters needed the cache_depth code, so I added it, and he was gracious enough to help test it - Jessica Mintz provided valuable debugging information that tracked down the unlink file race - Jeremy Howard (jhoward at fastmail.fm) added two great patches that made File::Cache taint safe, plus he's using it at fastmail.fm! - Randal L. Schwartz (merlyn at stonehenge.com) caught a version dependency on the File::Path, which led to some major changes to the entire library finally passing taint checking. Also, he suggested the temp->rename change to _WRITE_FILE. (Thanks Randal!) - Michael Blakeley (mike at blakeley.com) caught the bug with .description files not being readable when the umask is restrictive and offered a patch. (Thanks Mike!) - Neil Conway (nconway at klamath.dyndns.org) suggested documenting the optional dependency on Storable, adding a dependency for File::Spec 0.82, and removing the "use Data::Dumper" line. (Thanks Neil!) Cache-Cache-1.08/DISCLAIMER000644 000766 000024 00000002324 12406310064 015106 0ustar00rjbsstaff000000 000000 NO WARRANTY BECAUSE THE SOFTWARE IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE SOFTWARE, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE SOFTWARE "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE SOFTWARE IS WITH YOU. SHOULD THE SOFTWARE PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE SOFTWARE AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE SOFTWARE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE SOFTWARE TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. Cache-Cache-1.08/lib/000755 000766 000024 00000000000 12460220541 014314 5ustar00rjbsstaff000000 000000 Cache-Cache-1.08/Makefile.PL000644 000766 000024 00000004345 12406311423 015526 0ustar00rjbsstaff000000 000000 use strict; use ExtUtils::MakeMaker; ## # Constants ## my $NAME = 'Cache::Cache'; my $VERSION_FROM = 'lib/Cache/Cache.pm'; my $COMPRESS = 'gzip'; my $SUFFIX = '.gz'; my $DEFAULT_PREREQ_PM = { 'Digest::SHA1' => '2.02', 'File::Spec' => '0.82', 'Storable' => '1.014', 'IPC::ShareLite' => '0.09', 'Error' => '0.15' }; my @NON_IPC_TESTS = ( 't/1_test_cache_interface.t', 't/2_test_memory_cache.t', 't/3_test_file_cache.t', 't/5_test_size_aware_file_cache.t', 't/6_test_size_aware_memory_cache.t' ); ## # Main ## Main( ); ## # Subroutines ## sub Main { my %options; $options{NAME} = $NAME; $options{VERSION_FROM} = $VERSION_FROM; $options{dist} = { COMPRESS => $COMPRESS, SUFFIX => $SUFFIX }; $options{PREREQ_PM} = $DEFAULT_PREREQ_PM; if ( not Has_Module( 'IPC::ShareLite' ) ) { Print_ShareLite_Missing_Message( ); $options{test} = { TESTS => join( ' ', @NON_IPC_TESTS ) }; delete $options{PREREQ_PM}->{'IPC::ShareLite'}; } WriteMakefile( %options ); Print_Make_Test_Message( ); } sub Has_Module { my ( $module ) = @_; print "Checking for $module... "; my $has_module = ( eval "require $module" && ! $@ ); print ( $has_module ? "found\n" : "not found\n" ); return $has_module; } sub Print_ShareLite_Missing_Message { print < is the successor to Cache::Cache. It adheres to the basic Cache::Cache API but adds new features and drivers (e.g. FastMmap and Memcached), improves performance, and addresses limitations in the Cache::Cache implementation. The authors recommend the use of CHI going forward. Questions about Cache::Cache and CHI may be directed to the perl-cache mailing list at http://groups.google.com/group/perl-cache-discuss. REQUIREMENTS Digest::SHA1 Error File::Spec File::Path Storable OPTIONAL IPC::ShareLite INSTALLATION perl Makefile.PL make make test make install USAGE First, choose the best type of cache implementation for your needs. The simplest cache is the MemoryCache, which is suitable for applications that are serving multiple sequential requests, and wish to avoid making redundant expensive queries, such as an Apache/mod_perl application talking to a database. If you wish to share that data between processes, then perhaps the SharedMemoryCache is appropriate, although its behavior is tightly bound to the underlying IPC mechanism, which varies from system to system, and is unsuitable for large objects or large numbers of objects. When the SharedMemoryCache is not acceptable, then FileCache offers all of the same functionality with similar performance metrics, and it is not limited in terms of the number of objects or their size. If you wish to maintain a strict limit on the size of a file system based cache, then the SizeAwareFileCache is the way to go. Similarly, the SizeAwareMemoryCache and the SizeAwareSharedMemoryCache add size management functionality to the MemoryCache and SharedMemoryCache classes respectively. Using a cache is simple. Here is some sample code for instantiating and using a file system based cache. use Cache::FileCache; my $cache = new Cache::FileCache( ); my $customer = $cache->get( $name ); if ( not defined $customer ) { $customer = get_customer_from_db( $name ); $cache->set( $name, $customer, "10 minutes" ); } return $customer; Please refer to the perldoc for Cache::Cache and the related implementations for complete documentation. INCOMPATIBLE CHANGES Cache::Cache 0.99 contains the following incompatible changes: * Error::Simple is thrown on exceptions * the get_identifiers method has been deprecated in favor of the get_keys method * the internal format of object in a FileCache has been modified, necessitating a clearing of the cache while upgrading (make test does this for the standard cache root) Also note that Storable is not forward compatible between all releases. That is, older versions of the Cache will not always be able to read objects written by newer versions. This is unlikely to ever be an issue in production scenarios. ON LOCKING: The FileCache backend uses an temp file and an atomic rename to avoid requiring a lock during the write. This has been demonstrated to be safe across all platforms to date. The MemoryCache backend relies on Perl's atomic write to a hash to ensure that a lock is not required. The SharedMemoryCache backend uses ShareLite's locking mechanism for safety during the write. SEE ALSO The project homepage at http://perl-cache.googlecode.com/. The discussion list at http://groups.google.com/group/perl-cache-discuss. The CHI project. AUTHOR Original author: DeWitt Clinton Copyright (C) 2001-2009 DeWitt Clinton Cache-Cache-1.08/STYLE000644 000766 000024 00000024411 12406310064 014373 0ustar00rjbsstaff000000 000000 =========================== Coding style guidelines =========================== While there is no one ideal style in which to code, there are some advantages to adopting a common coding style. This guide helps outline the style for this project. ----------------------------- Tabs, spaces, and columns ----------------------------- Avoid tabs. Instead, use exactly 2 spaces to indent code. Lines should break at 80 columns. Whitespace greatly increases readability, and should be used between adjacent statements. The exceptions to the newline between statements rule include blocks of "use" statements and blocks of variable assignments. An example subroutine: sub build_something_else { my ( $self, $p_param ) = @_; Assert_Defined( $p_param ); return $self->calculate_something( $p_param + 1 ); } ----------------- Return Values ----------------- [Initially I advocated using a temporary variable to store the return value to increase code readability, but since reading and rereading (and re-rereading) Fowler's _Refactoring_, I am inclined to agree with him and now support the Remove Temp with Query refactoring, which also implies returning the result of a calculation directly] ---------- Naming ---------- The following naming conventions should be used: * Variables Inside routines, variables should be named "variable_name", all lowercase alphanumeric characters, with underscores separating the words. my $variable_name; Additionally, it is often a good idea to describe the type of the variable (other than scalars and object instances) in the name. Some examples follow: my $foo = 'foo'; my @number_list = ( 1, 2, 3 ); my $number_list_ref = [ 1, 2, 3 ]; my $number_list_ref = \@number_list; my %alphabet_hash = ( 'a' => 1, 'b' => 2 ); my $alphabet_hash_ref = { 'a' => 1, 'b' => 2 }; my $alphabet_hash_ref = \%alphabet_hash; my $file_cache = new Cache::FileCache( ); * Parameters Parameters should be prefixed with 'p_' to assist in readability. Note that I typically leave off the p_ for the $self parameter, and the $proto parameter in the constructor. For example: sub add { my ( $self, $p_value_one, $p_value_two ) = @_; return $p_value_one + $p_value_two; } * Public static class variables This type of variable is written "Public_Static_Class_Variable" and is accessible publicly, and can be updated at runtime. These variables are global for the scope of the module. Note that there are very few cases in which this type of variable should not be exposed via a class property (see below). my $Public_Static_Class_Variable; * Private static class variables This type of variable is written "_Private_Static_Class_Variable" and is accessible only to the module itself, and can be updated at runtime. Note that there are very few cases in which this type of variable should not be exposed via a class property (see below). my $_Private_Static_Class_Variable * Public static class constants This type of "variable" is written "PUBLIC_STATIC_CONSTANT" and it accessible publicly, and can not be modified at runtime. These constants are global for the scope of the module. It is often a good idea to make these constants available via Exporter as @EXPORT_OK. my $PUBLIC_STATIC_CONSTANT = 'foo'; * Private static class constants This type of "variable" is written "_PRIVATE_STATIC_CONSTANT" and is accessible only to the module itself, and can not be modified at runtime. These constants are global for the scope of the module. $_PRIVATE_STATIC_CONSTANT = 'foo'; * Public instance methods This type of subroutine is written as "public_instance_method" and takes $self as the first parameter. This is part of the public interface for a module, and should be documented with pod (see below for details about documentation). sub public_instance_method { my ( $self, $p_parameter ) = @_; } * Private instance methods This type of subroutine is written as "_private_instance_method" and takes $self as the first parameter. This is not part of the public interface, and can be documented inline with perl comments. sub _private_instance_method { my ( $self, $p_parameter ) = @_; } * Public class methods This type of subroutine is written "Public_Class_Method" and does not take $self as a parameter. This is part of the public interface for a module, and should be documented with pod (see below for details about documentation). You can optionally make use of the Static_Params method in CacheUtils to automatically shift the parameters if it is called via the class dereference operator rather that explicitly via the package's namespace. (i.e. it is called via Class->Public_Class_Method( ) vs. Class::Public_Class_Method( ) ). sub Public_Class_Method { my ( $p_parameter ) = Static_Params( @_ ); } * Private class methods This type of subroutine is written "_Private_Class_Method" and does not take $self as a parameter. This is not part of the public interface, and can be documented inline with perl comments. You can optionally make use of the Static_Params method in CacheUtils to automatically shift the parameters if it is called via the class dereference operator rather that explicitly via the package's namespace. (i.e. it is called via Class->Public_Class_Method( ) vs. Class::Public_Class_Method( ) ). sub _Private_Class_Method { my ( $p_parameter ) = Static_Params( @_ ); } -------------- Properties -------------- Properties and property accessor methods should be used to provide a consistent abstracted interface to certain types of data. In general, properties accessors are methods that take the form of get_property and set_property. Private getters or setters are written _get_property and _set_property respectively. Additionally, static class properties are written Get_Property and Set_Property as a method on the class itself. The properties are stored in the $self hash (assuming the object is a blessed hash) with a key that corresponds to the first letter uppercase name of the property, preceded by an underscore. An example of writing a scalar instance property "foo" with a public getter and a private setter: sub get_foo { my ( $self ) = @_; return $self->{_Foo}; } sub _set_foo { my ( $self, $foo ) = @_; $self->{_Foo} = $foo; } An example of writing a list instance property "bar_list" with a public getter and a public setter. sub get_bar_list { my ( $self ) = @_; return @{$self->{_Bar_List}}; } sub set_bar_list { my ( $self, @bar_list ) = @_; @{$self->{_Bar_List}} = @bar_list; } ----------------------------- Statement and brace style ----------------------------- * if/elsif/else statements if ( $condition ) { # ... } elsif ( $condition ) { # ... } else { # ... } * for loops for ( my $i; $i < 1000; $i++ ) { # ... } * foreach loops foreach my $foo ( @foo_list ) { # ... } * subroutines sub do_something { my ( $self ) = @_; #... return $foo; } * error handling my $foo = $self->get_foo( ) or throw Error( "Couldn't get foo" ); -------------------- Module structure -------------------- A the top of each module there should be a copyright disclaimer as follows: ###################################################################### # $ Id: $ # Copyright (C) 2002 John Smith All Rights Reserved # # Software distributed under the License is distributed on an "AS # IS" basis, WITHOUT WARRANTY OF ANY KIND, either expressed or # implied. See the License for the specific language governing # rights and limitations under the License. ###################################################################### The "Id" keyword is optional, though highly recommended if the code is being managed with CVS. After the copyright disclaimer, there should be a blank line, and then the package declaration: package Cache::FileCache; The "use" statements should be listed in alphabetical order, with the lowercase modules listed first. (This is so that "use strict" is the next line after the package declaration) use strict; use vars qw( @ISA @EXPORT_OK $PUBLIC_STATIC_CONSTANT ); use Cache::Cache qw( $EXPIRES_NEVER ); use Error; use Exporter; Next, list the @ISA and @EXPORT or @EXPORT_OK lists: @ISA = qw( Cache::Cache Exporter ); @EXPORT_OK = qw( $PUBLIC_STATIC_CONSTANT ); Followed by any variables in the "use vars" section: $PUBLIC_STATIC_CONSTANT = 'foo'; And any non exported, non "use vars" variables: my $_PRIVATE_STATIC_CONSTANT = 'bar'; my $_Private_Static_Class_Variable; Write the methods in the following order: * public class methods * private class methods * class properties ( first Get, then Set ) * new ( if the class is to be instantiated ) * public instance methods * private instance methods * instance properties ( first get, then set ) Finally, the class should be documented according to this template: __END__ =pod =head1 NAME Class -- short description with no line breaks =head1 DESCRIPTION Verbose description and overview of the class =head1 SYNOPSIS Example of the usage of the class =head1 METHODS =over 4 =item B Description of the method =over 4 =item $p_parameter Description of the $p_parameter =item Returns Description of the return value =back =back =head1 PROPERTIES =over 4 =item B<(get|set)_foo> Description of foo =back =head1 SEE ALSO Related modules or documentation =head1 AUTHOR Original author: John Smith Last author: $ Author: $ Copyright (C) 2002 John Smith =cut Cache-Cache-1.08/t/000755 000766 000024 00000000000 12460220541 014011 5ustar00rjbsstaff000000 000000 Cache-Cache-1.08/t/1_test_cache_interface.t000644 000766 000024 00000001110 12406310064 020531 0ustar00rjbsstaff000000 000000 #!/usr/bin/perl -w # Before `make install' is performed this script should be runnable with # `make test'. After `make install' it should work as `perl test.pl' ######################### We start with some black magic to print on failure. # Change 1..1 below to 1..last_test_to_print . # (It may become useful if the test is moved to ./t subdirectory.) BEGIN { $| = 1; print "1..1\n"; } END {print "not ok 1\n" unless $loaded;} use Cache::Cache qw( $EXPIRES_NOW $EXPIRES_NEVER ); $loaded = 1; print "ok 1\n"; ######################### End of black magic. Cache-Cache-1.08/t/2_test_memory_cache.t000644 000766 000024 00000002250 12460207077 020121 0ustar00rjbsstaff000000 000000 #!/usr/bin/perl -w # Before `make install' is performed this script should be runnable with # `make test'. After `make install' it should work as `perl test.pl' ######################### We start with some black magic to print on failure. # Change 1..1 below to 1..last_test_to_print . # (It may become useful if the test is moved to ./t subdirectory.) BEGIN { $| = 1; print "1..35\n"; } END {print "not ok 1\n" unless $loaded;} use Cache::Cache qw( $EXPIRES_NOW $EXPIRES_NEVER ); use Cache::CacheTester; use Cache::MemoryCache; $loaded = 1; print "ok 1\n"; ######################### End of black magic. use vars qw( $TEST_COUNT ); $TEST_COUNT = 2; my $cache = new Cache::MemoryCache( ) or not_ok( "Couldn't create new MemoryCache" ); ok( ); my $cache_tester = new Cache::CacheTester( $TEST_COUNT ) or not_ok( "Couldn't create new CacheTester" ); $cache_tester->test( $cache ); sub ok { print "ok $TEST_COUNT\n"; $TEST_COUNT++; } sub not_ok { my ( $message ) = @_; print "not ok $TEST_COUNT # $message\n"; $TEST_COUNT++; } sub skip { my ( $message ) = @_; print "ok $TEST_COUNT # skipped: $message\n"; $TEST_COUNT++; } Cache-Cache-1.08/t/3_test_file_cache.t000644 000766 000024 00000002241 12460216053 017523 0ustar00rjbsstaff000000 000000 #!/usr/bin/perl -w # Before `make install' is performed this script should be runnable with # `make test'. After `make install' it should work as `perl test.pl' ######################### We start with some black magic to print on failure. # Change 1..1 below to 1..last_test_to_print . # (It may become useful if the test is moved to ./t subdirectory.) BEGIN { $| = 1; print "1..35\n"; } END {print "not ok 1\n" unless $loaded;} use Cache::Cache qw( $EXPIRES_NOW $EXPIRES_NEVER ); use Cache::CacheTester; use Cache::FileCache; $loaded = 1; print "ok 1\n"; ######################### End of black magic. use vars qw( $TEST_COUNT ); $TEST_COUNT = 2; my $cache = new Cache::FileCache( ) or not_ok( "Couldn't create new FileCache" ); ok( ); my $cache_tester = new Cache::CacheTester( $TEST_COUNT ) or not_ok( "Couldn't create new CacheTester" ); $cache_tester->test( $cache ); sub ok { print "ok $TEST_COUNT\n"; $TEST_COUNT++; } sub not_ok { my ( $message ) = @_; print "not ok $TEST_COUNT # $message\n"; $TEST_COUNT++; } sub skip { my ( $message ) = @_; print "ok $TEST_COUNT # skipped: $message\n"; $TEST_COUNT++; } Cache-Cache-1.08/t/4_test_shared_memory_cache.t000644 000766 000024 00000002271 12406310064 021443 0ustar00rjbsstaff000000 000000 #!/usr/bin/perl -w # Before `make install' is performed this script should be runnable with # `make test'. After `make install' it should work as `perl test.pl' ######################### We start with some black magic to print on failure. # Change 1..1 below to 1..last_test_to_print . # (It may become useful if the test is moved to ./t subdirectory.) BEGIN { $| = 1; print "1..35\n"; } END {print "not ok 1\n" unless $loaded;} use Cache::Cache qw( $EXPIRES_NOW $EXPIRES_NEVER ); use Cache::CacheTester; use Cache::SharedMemoryCache; $loaded = 1; print "ok 1\n"; ######################### End of black magic. use vars qw( $TEST_COUNT ); $TEST_COUNT = 2; my $cache = new Cache::SharedMemoryCache( ) or not_ok( "Couldn't create new SharedMemoryCache" ); ok( ); my $cache_tester = new Cache::CacheTester( $TEST_COUNT ) or not_ok( "Couldn't create new CacheTester" ); $cache_tester->test( $cache ); sub ok { print "ok $TEST_COUNT\n"; $TEST_COUNT++; } sub not_ok { my ( $message ) = @_; print "not ok $TEST_COUNT # $message\n"; $TEST_COUNT++; } sub skip { my ( $message ) = @_; print "ok $TEST_COUNT # skipped: $message\n"; $TEST_COUNT++; } Cache-Cache-1.08/t/5_test_size_aware_file_cache.t000644 000766 000024 00000002670 12460216041 021741 0ustar00rjbsstaff000000 000000 #!/usr/bin/perl -w # Before `make install' is performed this script should be runnable with # `make test'. After `make install' it should work as `perl test.pl' ######################### We start with some black magic to print on failure. # Change 1..1 below to 1..last_test_to_print . # (It may become useful if the test is moved to ./t subdirectory.) BEGIN { $| = 1; print "1..48\n"; } END {print "not ok 1\n" unless $loaded;} use Cache::Cache qw( $EXPIRES_NOW $EXPIRES_NEVER ); use Cache::CacheTester; use Cache::SizeAwareCacheTester; use Cache::SizeAwareFileCache; $loaded = 1; print "ok 1\n"; ######################### End of black magic. use vars qw( $TEST_COUNT ); $TEST_COUNT = 2; my $cache = new Cache::SizeAwareFileCache( ) or not_ok( "Couldn't create new SizeAwareFileCache" ); ok( ); my $cache_tester = new Cache::CacheTester( $TEST_COUNT ) or not_ok( "Couldn't create new CacheTester" ); $cache_tester->test( $cache ); $TEST_COUNT = $cache_tester->_get_test_count( ); my $size_aware_cache_tester = new Cache::SizeAwareCacheTester( $TEST_COUNT ) or not_ok( "Couldn't create new CacheTester" ); $size_aware_cache_tester->test( $cache ); sub ok { print "ok $TEST_COUNT\n"; $TEST_COUNT++; } sub not_ok { my ( $message ) = @_; print "not ok $TEST_COUNT # $message\n"; $TEST_COUNT++; } sub skip { my ( $message ) = @_; print "ok $TEST_COUNT # skipped: $message\n"; $TEST_COUNT++; } Cache-Cache-1.08/t/6_test_size_aware_memory_cache.t000644 000766 000024 00000002676 12406310064 022341 0ustar00rjbsstaff000000 000000 #!/usr/bin/perl -w # Before `make install' is performed this script should be runnable with # `make test'. After `make install' it should work as `perl test.pl' ######################### We start with some black magic to print on failure. # Change 1..1 below to 1..last_test_to_print . # (It may become useful if the test is moved to ./t subdirectory.) BEGIN { $| = 1; print "1..48\n"; } END {print "not ok 1\n" unless $loaded;} use Cache::Cache qw( $EXPIRES_NOW $EXPIRES_NEVER ); use Cache::CacheTester; use Cache::SizeAwareCacheTester; use Cache::SizeAwareMemoryCache; $loaded = 1; print "ok 1\n"; ######################### End of black magic. use vars qw( $TEST_COUNT ); $TEST_COUNT = 2; my $cache = new Cache::SizeAwareMemoryCache( ) or not_ok( "Couldn't create new SizeAwareMemoryCache" ); ok( ); my $cache_tester = new Cache::CacheTester( $TEST_COUNT ) or not_ok( "Couldn't create new CacheTester" ); $cache_tester->test( $cache ); $TEST_COUNT = $cache_tester->_get_test_count( ); my $size_aware_cache_tester = new Cache::SizeAwareCacheTester( $TEST_COUNT ) or not_ok( "Couldn't create new CacheTester" ); $size_aware_cache_tester->test( $cache ); sub ok { print "ok $TEST_COUNT\n"; $TEST_COUNT++; } sub not_ok { my ( $message ) = @_; print "not ok $TEST_COUNT # $message\n"; $TEST_COUNT++; } sub skip { my ( $message ) = @_; print "ok $TEST_COUNT # skipped: $message\n"; $TEST_COUNT++; } Cache-Cache-1.08/t/7_test_size_aware_shared_memory_cache.t000644 000766 000024 00000002720 12406310064 023656 0ustar00rjbsstaff000000 000000 #!/usr/bin/perl -w # Before `make install' is performed this script should be runnable with # `make test'. After `make install' it should work as `perl test.pl' ######################### We start with some black magic to print on failure. # Change 1..1 below to 1..last_test_to_print . # (It may become useful if the test is moved to ./t subdirectory.) BEGIN { $| = 1; print "1..48\n"; } END {print "not ok 1\n" unless $loaded;} use Cache::Cache qw( $EXPIRES_NOW $EXPIRES_NEVER ); use Cache::CacheTester; use Cache::SizeAwareCacheTester; use Cache::SizeAwareSharedMemoryCache; $loaded = 1; print "ok 1\n"; ######################### End of black magic. use vars qw( $TEST_COUNT ); $TEST_COUNT = 2; my $cache = new Cache::SizeAwareSharedMemoryCache( ) or not_ok( "Couldn't create new SizeAwareSharedMemoryCache" ); ok( ); my $cache_tester = new Cache::CacheTester( $TEST_COUNT ) or not_ok( "Couldn't create new CacheTester" ); $cache_tester->test( $cache ); $TEST_COUNT = $cache_tester->_get_test_count( ); my $size_aware_cache_tester = new Cache::SizeAwareCacheTester( $TEST_COUNT ) or not_ok( "Couldn't create new CacheTester" ); $size_aware_cache_tester->test( $cache ); sub ok { print "ok $TEST_COUNT\n"; $TEST_COUNT++; } sub not_ok { my ( $message ) = @_; print "not ok $TEST_COUNT # $message\n"; $TEST_COUNT++; } sub skip { my ( $message ) = @_; print "ok $TEST_COUNT # skipped: $message\n"; $TEST_COUNT++; } Cache-Cache-1.08/lib/Cache/000755 000766 000024 00000000000 12460220541 015317 5ustar00rjbsstaff000000 000000 Cache-Cache-1.08/lib/Cache/BaseCache.pm000644 000766 000024 00000035351 12460217035 017466 0ustar00rjbsstaff000000 000000 ###################################################################### # $Id: BaseCache.pm,v 1.25 2003/04/15 14:46:14 dclinton Exp $ # Copyright (C) 2001-2003 DeWitt Clinton All Rights Reserved # # Software distributed under the License is distributed on an "AS # IS" basis, WITHOUT WARRANTY OF ANY KIND, either expressed or # implied. See the License for the specific language governing # rights and limitations under the License. ###################################################################### package Cache::BaseCache; use strict; use vars qw( @ISA ); use Cache::Cache qw( $EXPIRES_NEVER $EXPIRES_NOW ); use Cache::CacheUtils qw( Assert_Defined Clone_Data ); use Cache::Object; use Error; @ISA = qw( Cache::Cache ); my $DEFAULT_EXPIRES_IN = $EXPIRES_NEVER; my $DEFAULT_NAMESPACE = "Default"; my $DEFAULT_AUTO_PURGE_ON_SET = 0; my $DEFAULT_AUTO_PURGE_ON_GET = 0; # namespace that stores the keys used for the auto purge functionality my $AUTO_PURGE_NAMESPACE = "__AUTO_PURGE__"; # 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)) ); # Takes the time the object was created, the default_expires_in and # optionally the explicitly set expires_in and returns the time the # object will expire. Calls _canonicalize_expiration to convert # strings like "5m" into second values. sub Build_Expires_At { my ( $p_created_at, $p_default_expires_in, $p_explicit_expires_in ) = @_; my $expires_in = defined $p_explicit_expires_in ? $p_explicit_expires_in : $p_default_expires_in; return Sum_Expiration_Time( $p_created_at, $expires_in ); } # Return a Cache::Object object sub Build_Object { my ( $p_key, $p_data, $p_default_expires_in, $p_expires_in ) = @_; Assert_Defined( $p_key ); Assert_Defined( $p_default_expires_in ); my $now = time( ); my $object = new Cache::Object( ); $object->set_key( $p_key ); $object->set_data( $p_data ); $object->set_created_at( $now ); $object->set_accessed_at( $now ); $object->set_expires_at( Build_Expires_At( $now, $p_default_expires_in, $p_expires_in ) ); return $object; } # Compare the expires_at to the current time to determine whether or # not an object has expired (the time parameter is optional) sub Object_Has_Expired { my ( $p_object, $p_time ) = @_; if ( not defined $p_object ) { return 1; } $p_time = $p_time || time( ); if ( $p_object->get_expires_at( ) eq $EXPIRES_NOW ) { return 1; } elsif ( $p_object->get_expires_at( ) eq $EXPIRES_NEVER ) { return 0; } elsif ( $p_time >= $p_object->get_expires_at( ) ) { return 1; } else { return 0; } } # Returns the sum of the base created_at time (in seconds since the epoch) # and the canonical form of the expires_at string sub Sum_Expiration_Time { my ( $p_created_at, $p_expires_in ) = @_; Assert_Defined( $p_created_at ); Assert_Defined( $p_expires_in ); if ( $p_expires_in eq $EXPIRES_NEVER ) { return $EXPIRES_NEVER; } else { return $p_created_at + Canonicalize_Expiration_Time( $p_expires_in ); } } # turn a string in the form "[number] [unit]" into an explicit number # of seconds from the present. E.g, "10 minutes" returns "600" sub Canonicalize_Expiration_Time { my ( $p_expires_in ) = @_; Assert_Defined( $p_expires_in ); my $secs; if ( uc( $p_expires_in ) eq uc( $EXPIRES_NOW ) ) { $secs = 0; } elsif ( uc( $p_expires_in ) eq uc( $EXPIRES_NEVER ) ) { throw Error::Simple( "Internal error. expires_in eq $EXPIRES_NEVER" ); } elsif ( $p_expires_in =~ /^\s*([+-]?(?:\d+|\d*\.\d*))\s*$/ ) { $secs = $p_expires_in; } elsif ( $p_expires_in =~ /^\s*([+-]?(?:\d+|\d*\.\d*))\s*(\w*)\s*$/ and exists( $_Expiration_Units{ $2 } )) { $secs = ( $_Expiration_Units{ $2 } ) * $1; } else { throw Error::Simple( "invalid expiration time '$p_expires_in'" ); } return $secs; } sub clear { my ( $self ) = @_; $self->_get_backend( )->delete_namespace( $self->get_namespace( ) ); } sub get { my ( $self, $p_key ) = @_; Assert_Defined( $p_key ); $self->_conditionally_auto_purge_on_get( ) unless $self->get_namespace( ) eq $AUTO_PURGE_NAMESPACE; my $object = $self->get_object( $p_key ) or return undef; if ( Object_Has_Expired( $object ) ) { $self->remove( $p_key ); return undef; } return $object->get_data( ); } sub get_keys { my ( $self ) = @_; return $self->_get_backend( )->get_keys( $self->get_namespace( ) ); } sub get_identifiers { my ( $self ) = @_; warn( "get_identifiers has been marked deprepricated. use get_keys" ); return $self->get_keys( ); } sub get_object { my ( $self, $p_key ) = @_; Assert_Defined( $p_key ); my $object = $self->_get_backend( )->restore( $self->get_namespace( ), $p_key ) or return undef; $object->set_size( $self->_get_backend( )-> get_size( $self->get_namespace( ), $p_key ) ); $object->set_key( $p_key ); return $object; } sub purge { my ( $self ) = @_; foreach my $key ( $self->get_keys( ) ) { $self->get( $key ); } } sub remove { my ( $self, $p_key ) = @_; Assert_Defined( $p_key ); $self->_get_backend( )->delete_key( $self->get_namespace( ), $p_key ); } sub set { my ( $self, $p_key, $p_data, $p_expires_in ) = @_; Assert_Defined( $p_key ); $self->_conditionally_auto_purge_on_set( ); $self->set_object( $p_key, Build_Object( $p_key, $p_data, $self->get_default_expires_in( ), $p_expires_in ) ); } sub set_object { my ( $self, $p_key, $p_object ) = @_; my $object = Clone_Data( $p_object ); $object->set_size( undef ); $object->set_key( undef ); $self->_get_backend( )->store( $self->get_namespace( ), $p_key, $object ); } sub size { my ( $self ) = @_; my $size = 0; foreach my $key ( $self->get_keys( ) ) { $size += $self->_get_backend( )->get_size( $self->get_namespace( ), $key ); } return $size; } sub get_namespaces { my ( $self ) = @_; return grep {!/$AUTO_PURGE_NAMESPACE/} $self->_get_backend( )->get_namespaces( ); } sub _new { my ( $proto, $p_options_hash_ref ) = @_; my $class = ref( $proto ) || $proto; my $self = {}; bless( $self, $class ); $self->_initialize_base_cache( $p_options_hash_ref ); return $self; } sub _complete_initialization { my ( $self ) = @_; $self->_initialize_auto_purge_interval( ); } sub _initialize_base_cache { my ( $self, $p_options_hash_ref ) = @_; $self->_initialize_options_hash_ref( $p_options_hash_ref ); $self->_initialize_namespace( ); $self->_initialize_default_expires_in( ); $self->_initialize_auto_purge_on_set( ); $self->_initialize_auto_purge_on_get( ); } sub _initialize_options_hash_ref { my ( $self, $p_options_hash_ref ) = @_; $self->_set_options_hash_ref( defined $p_options_hash_ref ? $p_options_hash_ref : { } ); } sub _initialize_namespace { my ( $self ) = @_; my $namespace = $self->_read_option( 'namespace', $DEFAULT_NAMESPACE ); $self->set_namespace( $namespace ); } sub _initialize_default_expires_in { my ( $self ) = @_; my $default_expires_in = $self->_read_option( 'default_expires_in', $DEFAULT_EXPIRES_IN ); $self->_set_default_expires_in( $default_expires_in ); } sub _initialize_auto_purge_interval { my ( $self ) = @_; my $auto_purge_interval = $self->_read_option( 'auto_purge_interval' ); if ( defined $auto_purge_interval ) { $self->set_auto_purge_interval( $auto_purge_interval ); $self->_auto_purge( ); } } sub _initialize_auto_purge_on_set { my ( $self ) = @_; my $auto_purge_on_set = $self->_read_option( 'auto_purge_on_set', $DEFAULT_AUTO_PURGE_ON_SET ); $self->set_auto_purge_on_set( $auto_purge_on_set ); } sub _initialize_auto_purge_on_get { my ( $self ) = @_; my $auto_purge_on_get = $self->_read_option( 'auto_purge_on_get', $DEFAULT_AUTO_PURGE_ON_GET ); $self->set_auto_purge_on_get( $auto_purge_on_get ); } # _read_option looks for an option named 'option_name' in the # option_hash associated with this instance. If it is not found, then # 'default_value' will be returned instead sub _read_option { my ( $self, $p_option_name, $p_default_value ) = @_; my $options_hash_ref = $self->_get_options_hash_ref( ); if ( defined $options_hash_ref->{ $p_option_name } ) { return $options_hash_ref->{ $p_option_name }; } else { return $p_default_value; } } # this method checks to see if the auto_purge property is set for a # particular cache. If it is, then it switches the cache to the # $AUTO_PURGE_NAMESPACE and stores that value under the name of the # current cache namespace sub _reset_auto_purge_interval { my ( $self ) = @_; return if not $self->_should_auto_purge( ); my $real_namespace = $self->get_namespace( ); $self->set_namespace( $AUTO_PURGE_NAMESPACE ); if ( not defined $self->get( $real_namespace ) ) { $self->_insert_auto_purge_object( $real_namespace ); } $self->set_namespace( $real_namespace ); } sub _should_auto_purge { my ( $self ) = @_; return ( defined $self->get_auto_purge_interval( ) && $self->get_auto_purge_interval( ) ne $EXPIRES_NEVER ); } sub _insert_auto_purge_object { my ( $self, $p_real_namespace ) = @_; my $object = Build_Object( $p_real_namespace, 1, $self->get_auto_purge_interval( ), undef ); $self->set_object( $p_real_namespace, $object ); } # this method checks to see if the auto_purge property is set, and if # it is, switches to the $AUTO_PURGE_NAMESPACE and sees if a value # exists at the location specified by a key named for the current # namespace. If that key doesn't exist, then the purge method is # called on the cache sub _auto_purge { my ( $self ) = @_; if ( $self->_needs_auto_purge( ) ) { $self->purge( ); $self->_reset_auto_purge_interval( ); } } sub _get_auto_purge_object { my ( $self ) = @_; my $real_namespace = $self->get_namespace( ); $self->set_namespace( $AUTO_PURGE_NAMESPACE ); my $auto_purge_object = $self->get_object( $real_namespace ); $self->set_namespace( $real_namespace ); return $auto_purge_object; } sub _needs_auto_purge { my ( $self ) = @_; return ( $self->_should_auto_purge( ) && Object_Has_Expired( $self->_get_auto_purge_object( ) ) ); } # call auto_purge if the auto_purge_on_set option is true sub _conditionally_auto_purge_on_set { my ( $self ) = @_; if ( $self->get_auto_purge_on_set( ) ) { $self->_auto_purge( ); } } # call auto_purge if the auto_purge_on_get option is true sub _conditionally_auto_purge_on_get { my ( $self ) = @_; if ( $self->get_auto_purge_on_get( ) ) { $self->_auto_purge( ); } } sub _get_options_hash_ref { my ( $self ) = @_; return $self->{_Options_Hash_Ref}; } sub _set_options_hash_ref { my ( $self, $options_hash_ref ) = @_; $self->{_Options_Hash_Ref} = $options_hash_ref; } sub get_namespace { my ( $self ) = @_; return $self->{_Namespace}; } sub set_namespace { my ( $self, $namespace ) = @_; $self->{_Namespace} = $namespace; } sub get_default_expires_in { my ( $self ) = @_; return $self->{_Default_Expires_In}; } sub _set_default_expires_in { my ( $self, $default_expires_in ) = @_; $self->{_Default_Expires_In} = $default_expires_in; } sub get_auto_purge_interval { my ( $self ) = @_; return $self->{_Auto_Purge_Interval}; } sub set_auto_purge_interval { my ( $self, $auto_purge_interval ) = @_; $self->{_Auto_Purge_Interval} = $auto_purge_interval; $self->_reset_auto_purge_interval( ); } sub get_auto_purge_on_set { my ( $self ) = @_; return $self->{_Auto_Purge_On_Set}; } sub set_auto_purge_on_set { my ( $self, $auto_purge_on_set ) = @_; $self->{_Auto_Purge_On_Set} = $auto_purge_on_set; } sub get_auto_purge_on_get { my ( $self ) = @_; return $self->{_Auto_Purge_On_Get}; } sub set_auto_purge_on_get { my ( $self, $auto_purge_on_get ) = @_; $self->{_Auto_Purge_On_Get} = $auto_purge_on_get; } sub _get_backend { my ( $self ) = @_; return $self->{ _Backend }; } sub _set_backend { my ( $self, $p_backend ) = @_; $self->{ _Backend } = $p_backend; } 1; __END__ =pod =head1 NAME Cache::BaseCache -- abstract cache base class =head1 DESCRIPTION BaseCache provides functionality common to all instances of a cache. It differs from the CacheUtils package insofar as it is designed to be used as superclass for cache implementations. =head1 SYNOPSIS Cache::BaseCache is to be used as a superclass for cache implementations. The most effective way to use BaseCache is to use the protected _set_backend method, which will be used to retrieve the persistence mechanism. The subclass can then inherit the BaseCache's implementation of get, set, etc. However, due to the difficulty inheriting static methods in Perl, the subclass will likely need to explicitly implement Clear, Purge, and Size. Also, a factory pattern should be used to invoke the _complete_initialization routine after the object is constructed. package Cache::MyCache; use vars qw( @ISA ); use Cache::BaseCache; use Cache::MyBackend; @ISA = qw( Cache::BaseCache ); sub new { my ( $self ) = _new( @_ ); $self->_complete_initialization( ); return $self; } sub _new { my ( $proto, $p_options_hash_ref ) = @_; my $class = ref( $proto ) || $proto; my $self = $class->SUPER::_new( $p_options_hash_ref ); $self->_set_backend( new Cache::MyBackend( ) ); return $self; } sub Clear { foreach my $namespace ( _Namespaces( ) ) { _Get_Backend( )->delete_namespace( $namespace ); } } sub Purge { foreach my $namespace ( _Namespaces( ) ) { _Get_Cache( $namespace )->purge( ); } } sub Size { my $size = 0; foreach my $namespace ( _Namespaces( ) ) { $size += _Get_Cache( $namespace )->size( ); } return $size; } =head1 SEE ALSO Cache::Cache, Cache::FileCache, Cache::MemoryCache =head1 AUTHOR Original author: DeWitt Clinton Last author: $Author: dclinton $ Copyright (C) 2001-2003 DeWitt Clinton =cut Cache-Cache-1.08/lib/Cache/BaseCacheTester.pm000644 000766 000024 00000005412 12460217060 020646 0ustar00rjbsstaff000000 000000 ###################################################################### # $Id: BaseCacheTester.pm,v 1.7 2002/04/07 17:04:46 dclinton Exp $ # Copyright (C) 2001-2003 DeWitt Clinton All Rights Reserved # # Software distributed under the License is distributed on an "AS # IS" basis, WITHOUT WARRANTY OF ANY KIND, either expressed or # implied. See the License for the specific language governing # rights and limitations under the License. ###################################################################### package Cache::BaseCacheTester; use strict; sub new { my ( $proto, $base_test_count ) = @_; my $class = ref( $proto ) || $proto; my $self = {}; bless ( $self, $class ); $base_test_count = defined $base_test_count ? $base_test_count : 0 ; $self->_set_test_count( $base_test_count ); return $self; } sub ok { my ( $self ) = @_; my $test_count = $self->_get_test_count( ); print "ok $test_count\n"; $self->_increment_test_count( ); } sub not_ok { my ( $self, $message ) = @_; my $test_count = $self->_get_test_count( ); print "not ok $test_count # failed '$message'\n"; $self->_increment_test_count( ); } sub skip { my ( $self, $message ) = @_; my $test_count = $self->_get_test_count( ); print "ok $test_count # skipped $message \n"; $self->_increment_test_count( ); } sub _set_test_count { my ( $self, $test_count ) = @_; $self->{_Test_Count} = $test_count; } sub _get_test_count { my ( $self ) = @_; return $self->{_Test_Count}; } sub _increment_test_count { my ( $self ) = @_; $self->{_Test_Count}++; } 1; __END__ =pod =head1 NAME Cache::BaseCacheTester -- abstract cache tester base class =head1 DESCRIPTION BaseCacheTester provides functionality common to all instances of a class that will test cache implementations. =head1 SYNOPSIS BaseCacheTester provides functionality common to all instances of a class that will test cache implementations. package Cache::MyCacheTester; use vars qw( @ISA ); use Cache::BaseCacheTester; @ISA = qw( Cache::BaseCacheTester ); =head1 METHODS =over =item B Construct a new BaseCacheTester and initialize the test count to I<$base_test_count>. =item B Print a message to stdout in the form "ok $test_count" and increments the test count. =item B Print a message to stdout in the form "not ok $test_count # I<$message> " and increments the test count. =item B Print a message to stdout in the form "ok $test_count # skipped I<$message> " and increments the test count. =back =head1 SEE ALSO Cache::CacheTester, Cache::SizeAwareCacheTester =head1 AUTHOR Original author: DeWitt Clinton Last author: $Author: dclinton $ Copyright (C) 2001-2003 DeWitt Clinton =cut Cache-Cache-1.08/lib/Cache/Cache.pm000644 000766 000024 00000020343 12460220230 016655 0ustar00rjbsstaff000000 000000 ##################################################################### # $Id: Cache.pm,v 1.43 2005/07/13 22:29:33 dclinton Exp $ # Copyright (C) 2001-2003 DeWitt Clinton All Rights Reserved # # Software distributed under the License is distributed on an "AS # IS" basis, WITHOUT WARRANTY OF ANY KIND, either expressed or # implied. See the License for the specific language governing # rights and limitations under the License. ###################################################################### package Cache::Cache; use strict; use vars qw( @ISA @EXPORT_OK $VERSION $EXPIRES_NOW $EXPIRES_NEVER ); use Exporter; @ISA = qw( Exporter ); @EXPORT_OK = qw( $VERSION $EXPIRES_NOW $EXPIRES_NEVER ); $VERSION = "1.08"; $EXPIRES_NOW = 'now'; $EXPIRES_NEVER = 'never'; sub Clear; sub Purge; sub Size; sub new; sub clear; sub get; sub get_object; sub purge; sub remove; sub set; sub set_object; sub size; sub get_default_expires_in; sub get_namespace; sub set_namespace; sub get_keys; sub get_auto_purge_interval; sub set_auto_purge_interval; sub get_auto_purge_on_set; sub set_auto_purge_on_set; sub get_namespaces; sub get_identifiers; # deprecated 1; __END__ =pod =head1 NAME Cache::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. People have also been known to use Cache::Cache for its straightforward interface in sharing data between runs of an application or invocations of a CGI-style script or simply as an easy to use abstraction of the filesystem or shared memory. The Cache::Cache interface is implemented by classes that support the get, set, remove, size, purge, and clear instance methods and their corresponding static methods for persisting data across method calls. =head1 CACHE::CACHE VERSUS CHI Cache::Cache is in wide use and very stable, but has not changed in years and is no longer actively developed. L is the successor to Cache::Cache. It adheres to the basic Cache::Cache API but adds new features and drivers (e.g. FastMmap and Memcached), improves performance, and addresses limitations in the Cache::Cache implementation. The authors recommend the use of CHI going forward. Questions about Cache::Cache and CHI may be directed to the perl-cache mailing list at http://groups.google.com/group/perl-cache-discuss. =head1 USAGE First, choose the best type of cache implementation for your needs. The simplest cache is the MemoryCache, which is suitable for applications that are serving multiple sequential requests, and wish to avoid making redundant expensive queries, such as an Apache/mod_perl application talking to a database. If you wish to share that data between processes, then perhaps the SharedMemoryCache is appropriate, although its behavior is tightly bound to the underlying IPC mechanism, which varies from system to system, and is unsuitable for large objects or large numbers of objects. When the SharedMemoryCache is not acceptable, then FileCache offers all of the same functionality with similar performance metrics, and it is not limited in terms of the number of objects or their size. If you wish to maintain a strict limit on the size of a file system based cache, then the SizeAwareFileCache is the way to go. Similarly, the SizeAwareMemoryCache and the SizeAwareSharedMemoryCache add size management functionality to the MemoryCache and SharedMemoryCache classes respectively. Using a cache is simple. Here is some sample code for instantiating and using a file system based cache. use Cache::FileCache; my $cache = new Cache::FileCache( ); my $customer = $cache->get( $name ); if ( not defined $customer ) { $customer = get_customer_from_db( $name ); $cache->set( $name, $customer, "10 minutes" ); } return $customer; =head1 CONSTANTS =over =item I<$EXPIRES_NEVER> The item being set in the cache will never expire. =item I<$EXPIRES_NOW> The item being set in the cache will expire immediately. =back =head1 METHODS =over =item B Remove all objects from all caches of this type. =item B Remove all objects that have expired from all caches of this type. =item B Returns the total size of all objects in all caches of this type. =item B Construct a new instance of a Cache::Cache. I<$options_hash_ref> is a reference to a hash containing configuration options; see the section OPTIONS below. =item B Remove all objects from the namespace associated with this cache instance. =item B Returns the data associated with I<$key>. =item B Returns the underlying Cache::Object object used to store the cached data associated with I<$key>. This will not trigger a removal of the cached object even if the object has expired. =item B Remove all objects that have expired from the namespace associated with this cache instance. =item B Delete the data associated with the I<$key> from the cache. =item B Associates I<$data> with I<$key> in the cache. I<$expires_in> indicates the time in seconds until this data should be erased, or the constant $EXPIRES_NOW, or the constant $EXPIRES_NEVER. Defaults to $EXPIRES_NEVER. This variable can also be in the extended format of "[number] [unit]", e.g., "10 minutes". The valid units are s, second, seconds, sec, m, minute, minutes, min, h, hour, hours, d, day, days, w, week, weeks, M, month, months, y, year, and years. Additionally, $EXPIRES_NOW can be represented as "now" and $EXPIRES_NEVER can be represented as "never". =item B Associates I<$key> with Cache::Object I<$object>. Using set_object (as opposed to set) does not trigger an automatic removal of expired objects. =item B Returns the total size of all objects in the namespace associated with this cache instance. =item B Returns all the namespaces associated with this type of cache. =back =head1 OPTIONS The options are set by passing in a reference to a hash containing any of the following keys: =over =item I The namespace associated with this cache. Defaults to "Default" if not explicitly set. =item I The default expiration time for objects place in the cache. Defaults to $EXPIRES_NEVER if not explicitly set. =item I Sets the auto purge interval. If this option is set to a particular time ( in the same format as the expires_in ), then the purge( ) routine will be called during the first set after the interval expires. The interval will then be reset. =item I If this option is true, then the auto purge interval routine will be checked on every set. =item I If this option is true, then the auto purge interval routine will be checked on every get. =back =head1 PROPERTIES =over =item B<(get|set)_namespace( )> The namespace of this cache instance =item B The default expiration time for objects placed in this cache instance =item B The list of keys specifying objects in the namespace associated with this cache instance =item B This method has been deprecated in favor of B. =item B<(get|set)_auto_purge_interval( )> Accesses the auto purge interval. If this option is set to a particular time ( in the same format as the expires_in ), then the purge( ) routine will be called during the first get after the interval expires. The interval will then be reset. =item B<(get|set)_auto_purge_on_set( )> If this property is true, then the auto purge interval routine will be checked on every set. =item B<(get|set)_auto_purge_on_get( )> If this property is true, then the auto purge interval routine will be checked on every get. =back =head1 SEE ALSO CHI - the successor to Cache::Cache Cache::Object, Cache::MemoryCache, Cache::FileCache, Cache::SharedMemoryCache, and Cache::SizeAwareFileCache =head1 AUTHOR Original author: DeWitt Clinton Last author: $Author: dclinton $ Copyright (C) 2001-2003 DeWitt Clinton =cut Cache-Cache-1.08/lib/Cache/CacheMetaData.pm000644 000766 000024 00000013351 12460217101 020262 0ustar00rjbsstaff000000 000000 ###################################################################### # $Id: CacheMetaData.pm,v 1.12 2002/04/07 17:04:46 dclinton Exp $ # Copyright (C) 2001-2003 DeWitt Clinton All Rights Reserved # # Software distributed under the License is distributed on an "AS # IS" basis, WITHOUT WARRANTY OF ANY KIND, either expressed or # implied. See the License for the specific language governing # rights and limitations under the License. ###################################################################### package Cache::CacheMetaData; use strict; use Cache::Cache qw( $EXPIRES_NOW $EXPIRES_NEVER ); # # the cache meta data structure looks something like the following: # # %meta_data_hash = # ( # $key_1 => [ $expires_at, $accessed_at, $object_size ], # $key_2 => [ $expires_at, $accessed_at, $object_size ], # ... # ) # my $_EXPIRES_AT_OFFSET = 0; my $_ACCESS_AT_OFFSET = 1; my $_SIZE_OFFSET = 2; sub new { my ( $proto ) = @_; my $class = ref( $proto ) || $proto; my $self = {}; bless( $self, $class ); $self->_set_meta_data_hash_ref( { } ); $self->_set_cache_size( 0 ); return $self; } sub insert { my ( $self, $p_object ) = @_; $self->_insert_object_expires_at( $p_object ); $self->_insert_object_accessed_at( $p_object ); $self->_insert_object_size( $p_object ); $self->_set_cache_size( $self->get_cache_size( ) + $p_object->get_size( ) ); } sub remove { my ( $self, $p_key ) = @_; $self->_set_cache_size( $self->get_cache_size( ) - $self->build_object_size( $p_key ) ); delete $self->_get_meta_data_hash_ref( )->{ $p_key }; } sub build_removal_list { my ( $self ) = @_; my $meta_data_hash_ref = $self->_get_meta_data_hash_ref( ); return sort { my $a_expires_at = $meta_data_hash_ref->{ $a }->[ $_EXPIRES_AT_OFFSET ]; my $b_expires_at = $meta_data_hash_ref->{ $b }->[ $_EXPIRES_AT_OFFSET ]; my $a_accessed_at = $meta_data_hash_ref->{ $a }->[ $_ACCESS_AT_OFFSET ]; my $b_accessed_at = $meta_data_hash_ref->{ $b }->[ $_ACCESS_AT_OFFSET ]; if ( $a_expires_at eq $b_expires_at ) { return ( $a_accessed_at <=> $b_accessed_at ); } return -1 if $a_expires_at eq $EXPIRES_NOW; return 1 if $b_expires_at eq $EXPIRES_NOW; return 1 if $a_expires_at eq $EXPIRES_NEVER; return -1 if $b_expires_at eq $EXPIRES_NEVER; return ( $a_expires_at <=> $b_expires_at ); } keys %$meta_data_hash_ref; } sub build_object_size { my ( $self, $p_key ) = @_; return $self->_get_meta_data_hash_ref( )->{ $p_key }->[ $_SIZE_OFFSET ]; } sub _insert_object_meta_data { my ( $self, $p_object, $p_offset, $p_value ) = @_; $self->_get_meta_data_hash_ref( )->{ $p_object->get_key( ) }->[ $p_offset ] = $p_value; } sub _insert_object_expires_at { my ( $self, $p_object ) = @_; $self->_insert_object_meta_data( $p_object, $_EXPIRES_AT_OFFSET, $p_object->get_expires_at( ) ); } sub _insert_object_accessed_at { my ( $self, $p_object ) = @_; $self->_insert_object_meta_data( $p_object, $_ACCESS_AT_OFFSET, $p_object->get_accessed_at( ) ); } sub _insert_object_size { my ( $self, $p_object ) = @_; $self->_insert_object_meta_data( $p_object, $_SIZE_OFFSET, $p_object->get_size( ) ); } sub get_cache_size { my ( $self ) = @_; return $self->{_Cache_Size}; } sub _set_cache_size { my ( $self, $cache_size ) = @_; $self->{_Cache_Size} = $cache_size; } sub _get_meta_data_hash_ref { my ( $self ) = @_; return $self->{_Meta_Data_Hash_Ref}; } sub _set_meta_data_hash_ref { my ( $self, $meta_data_hash_ref ) = @_; $self->{_Meta_Data_Hash_Ref} = $meta_data_hash_ref; } 1; __END__ =pod =head1 NAME Cache::CacheMetaData -- data about objects in the cache =head1 DESCRIPTION The CacheMetaData object is used by size aware caches to keep track of the state of the cache and efficiently return information such as an objects size or an ordered list of identifiers to be removed when a cache size is being limited. End users will not normally use CacheMetaData directly. =head1 SYNOPSIS use Cache::CacheMetaData; my $cache_meta_data = new Cache::CacheMetaData( ); foreach my $key ( $cache->get_keys( ) ) { my $object = $cache->get_object( $key ) or next; $cache_meta_data->insert( $object ); } my $current_size = $cache_meta_data->get_cache_size( ); my @removal_list = $cache_meta_data->build_removal_list( ); =head1 METHODS =over =item B Construct a new Cache::CacheMetaData object =item B Inform the CacheMetaData about the object I<$object> in the cache. =item B Inform the CacheMetaData that the object specified by I<$key> is no longer in the cache. =item B Create a list of the keys in the cache, ordered as follows: 1) objects that expire now 2) objects expiring at a particular time, with ties broken by the time at which they were least recently accessed 3) objects that never expire, sub ordered by the time at which they were least recently accessed NOTE: This could be improved further by taking the size into account on accessed_at ties. However, this type of tie is unlikely in normal usage. =item B Return the size of an object specified by I<$key>. =back =head1 PROPERTIES =over =item B The total size of the objects in the cache =back =head1 SEE ALSO Cache::Cache, Cache::CacheSizer, Cache::SizeAwareCache =head1 AUTHOR Original author: DeWitt Clinton Last author: $Author: dclinton $ Copyright (C) 2001-2003 DeWitt Clinton =cut Cache-Cache-1.08/lib/Cache/CacheSizer.pm000644 000766 000024 00000007707 12460217120 017707 0ustar00rjbsstaff000000 000000 ###################################################################### # $Id: CacheSizer.pm,v 1.4 2002/04/07 17:04:46 dclinton Exp $ # Copyright (C) 2001-2003 DeWitt Clinton All Rights Reserved # # Software distributed under the License is distributed on an "AS # IS" basis, WITHOUT WARRANTY OF ANY KIND, either expressed or # implied. See the License for the specific language governing # rights and limitations under the License. ###################################################################### package Cache::CacheSizer; use strict; use Cache::Cache; use Cache::CacheMetaData; use Cache::CacheUtils qw ( Assert_Defined ); use Cache::SizeAwareCache qw ( $NO_MAX_SIZE ); sub new { my ( $proto, $p_cache, $p_max_size ) = @_; my $class = ref( $proto ) || $proto; my $self = {}; bless( $self, $class ); Assert_Defined( $p_cache ); Assert_Defined( $p_max_size ); $self->_set_cache( $p_cache ); $self->set_max_size( $p_max_size ); return $self; } sub update_access_time { my ( $self, $p_key ) = @_; Assert_Defined( $p_key ); my $object = $self->_get_cache( )->get_object( $p_key ); if ( defined $object ) { $object->set_accessed_at( time( ) ); $self->_get_cache( )->set_object( $p_key, $object ); } } sub limit_size { my ( $self, $p_new_size ) = @_; Assert_Defined( $p_new_size ); return if $p_new_size == $NO_MAX_SIZE; _Limit_Size( $self->_get_cache( ), $self->_build_cache_meta_data( ), $p_new_size ); } # take a Cache reference and a CacheMetaData reference and # limit the cache's size to new_size sub _Limit_Size { my ( $p_cache, $p_cache_meta_data, $p_new_size ) = @_; Assert_Defined( $p_cache ); Assert_Defined( $p_cache_meta_data ); Assert_Defined( $p_new_size ); $p_new_size >= 0 or throw Error::Simple( "p_new_size >= 0 required" ); my $size_estimate = $p_cache_meta_data->get_cache_size( ); return if $size_estimate <= $p_new_size; foreach my $key ( $p_cache_meta_data->build_removal_list( ) ) { return if $size_estimate <= $p_new_size; $size_estimate -= $p_cache_meta_data->build_object_size( $key ); $p_cache->remove( $key ); $p_cache_meta_data->remove( $key ); } warn( "Couldn't limit size to $p_new_size" ); } sub _build_cache_meta_data { my ( $self ) = @_; my $cache_meta_data = new Cache::CacheMetaData( ); foreach my $key ( $self->_get_cache( )->get_keys( ) ) { my $object = $self->_get_cache( )->get_object( $key ) or next; $cache_meta_data->insert( $object ); } return $cache_meta_data; } sub _get_cache { my ( $self ) = @_; return $self->{_Cache}; } sub _set_cache { my ( $self, $p_cache ) = @_; $self->{_Cache} = $p_cache; } sub get_max_size { my ( $self ) = @_; return $self->{_Max_Size}; } sub set_max_size { my ( $self, $p_max_size ) = @_; $self->{_Max_Size} = $p_max_size; } 1; __END__ =pod =head1 NAME Cache::CacheSizer -- component object for managing the size of caches =head1 DESCRIPTION The CacheSizer class is used internally in SizeAware caches such as SizeAwareFileCache to encapsulate the logic of limiting cache size. =head1 SYNOPSIS use Cache::CacheSizer; my $sizer = new Cache::CacheSizer( $cache, $max_size ); $sizer->limit_size( $new_size ); =head1 METHODS =over =item B Construct a new Cache::CacheSizer object for the cache I<$cache> with a maximum size of I<$max_size>. =item B Inform the cache that the object specified by I<$key> has been accessed. =item B Use the sizing algorithms to get the cache down under I<$new_size> if possible. =back =head1 PROPERTIES =over =item B The desired size limit for the cache under control. =back =head1 SEE ALSO Cache::Cache, Cache::CacheMetaData, Cache::SizeAwareCache =head1 AUTHOR Original author: DeWitt Clinton Last author: $Author: dclinton $ Copyright (C) 2001-2003 DeWitt Clinton =cut Cache-Cache-1.08/lib/Cache/CacheTester.pm000644 000766 000024 00000032067 12460205570 020064 0ustar00rjbsstaff000000 000000 ###################################################################### # $Id: CacheTester.pm,v 1.20 2002/04/07 17:04:46 dclinton Exp $ # Copyright (C) 2001-2003 DeWitt Clinton All Rights Reserved # # Software distributed under the License is distributed on an "AS # IS" basis, WITHOUT WARRANTY OF ANY KIND, either expressed or # implied. See the License for the specific language governing # rights and limitations under the License. ###################################################################### package Cache::CacheTester; use strict; use Cache::BaseCacheTester; use Cache::Cache; use Error qw( :try ); use vars qw( @ISA $EXPIRES_DELAY ); @ISA = qw ( Cache::BaseCacheTester ); $EXPIRES_DELAY = 2; $Error::Debug = 1; sub test { my ( $self, $cache ) = @_; try { $cache->Clear( ); $self->_test_one( $cache ); $self->_test_two( $cache ); $self->_test_three( $cache ); $self->_test_four( $cache ); $self->_test_five( $cache ); $self->_test_six( $cache ); $self->_test_seven( $cache ); $self->_test_eight( $cache ); $self->_test_nine( $cache ); $self->_test_ten( $cache ); $self->_test_eleven( $cache ); $self->_test_twelve( $cache ); $self->_test_thirteen( $cache ); $self->_test_fourteen( $cache ); $self->_test_fifteen( $cache ); $self->_test_sixteen( $cache ); $self->_test_seventeen( $cache ); } catch Error with { my $error = shift; print STDERR "\nError:\n"; print STDERR $error->stringify( ) . "\n"; print STDERR $error->stacktrace( ) . "\n"; print STDERR "\n"; } } # Test the getting, setting, and removal of a scalar sub _test_one { my ( $self, $cache ) = @_; $cache or croak( "cache required" ); my $key = 'Test Key'; my $value = 'Test Value'; $cache->set( $key, $value ); my $fetched_value = $cache->get( $key ); ( $fetched_value eq $value ) ? $self->ok( ) : $self->not_ok( '$fetched_value eq $value' ); $cache->remove( $key ); my $fetched_removed_value = $cache->get( $key ); ( not defined $fetched_removed_value ) ? $self->ok( ) : $self->not_ok( 'not defined $fetched_removed_value' ); } # Test the getting, setting, and removal of a list sub _test_two { my ( $self, $cache ) = @_; $cache or croak( "cache required" ); my $key = 'Test Key'; my @value_list = ( 'One', 'Two', 'Three' ); $cache->set( $key, \@value_list ); my $fetched_value_list_ref = $cache->get( $key ); if ( ( $fetched_value_list_ref->[0] eq 'One' ) and ( $fetched_value_list_ref->[1] eq 'Two' ) and ( $fetched_value_list_ref->[2] eq 'Three' ) ) { $self->ok( ); } else { $self->not_ok( 'fetched list does not match set list' ); } $cache->remove( $key ); my $fetched_removed_value = $cache->get( $key ); ( not defined $fetched_removed_value ) ? $self->ok( ) : $self->not_ok( 'not defined $fetched_removed_value' ); } # Test the getting, setting, and removal of a blessed object sub _test_three { my ( $self, $cache ) = @_; $cache or croak( "cache required" ); my $key = 'Test Key'; my $value = 'Test Value'; $cache->set( $key, $value ); my $cache_key = 'Cache Key'; $cache->set( $cache_key, $cache ); my $fetched_cache = $cache->get( $cache_key ); ( defined $fetched_cache ) ? $self->ok( ) : $self->not_ok( 'defined $fetched_cache' ); my $fetched_value = $fetched_cache->get( $key ); ( $fetched_value eq $value ) ? $self->ok( ) : $self->not_ok( '$fetched_value eq $value' ); } # Test the expiration of an object sub _test_four { my ( $self, $cache ) = @_; my $expires_in = $EXPIRES_DELAY; my $key = 'Test Key'; my $value = 'Test Value'; my $start = time; $cache->set( $key, $value, $expires_in ); my $fetched_value = $cache->get( $key ); if (time - $start < $expires_in) { ( $fetched_value eq $value ) ? $self->ok( ) : $self->not_ok( '$fetched_value eq $value' ); } else { $self->skip( '$fetched_value eq $value (not finished in ' . $expires_in . ' s)' ); } sleep( $EXPIRES_DELAY + 1 ); my $fetched_expired_value = $cache->get( $key ); ( not defined $fetched_expired_value ) ? $self->ok( ) : $self->not_ok( 'not defined $fetched_expired_value' ); } # Test that caches make deep copies of values sub _test_five { my ( $self, $cache ) = @_; $cache or croak( "cache required" ); my $key = 'Test Key'; my @value_list = ( 'One', 'Two', 'Three' ); $cache->set( $key, \@value_list ); @value_list = ( ); my $fetched_value_list_ref = $cache->get( $key ); if ( ( $fetched_value_list_ref->[0] eq 'One' ) and ( $fetched_value_list_ref->[1] eq 'Two' ) and ( $fetched_value_list_ref->[2] eq 'Three' ) ) { $self->ok( ); } else { $self->not_ok( 'fetched deep list does not match set deep list' ); } } # Test clearing a cache sub _test_six { my ( $self, $cache ) = @_; $cache or croak( "cache required" ); my $key = 'Test Key'; my $value = 'Test Value'; $cache->set( $key, $value ); $cache->clear( ); my $fetched_cleared_value = $cache->get( $key ); ( not defined $fetched_cleared_value ) ? $self->ok( ) : $self->not_ok( 'not defined $fetched_cleared_value' ); } # Test sizing of the cache sub _test_seven { my ( $self, $cache ) = @_; my $empty_size = $cache->size( ); ( $empty_size == 0 ) ? $self->ok( ) : $self->not_ok( '$empty_size == 0' ); my $first_key = 'First Test Key'; my $value = 'Test Value'; $cache->set( $first_key, $value ); my $first_size = $cache->size( ); ( $first_size > $empty_size ) ? $self->ok( ) : $self->not_ok( '$first_size > $empty_size' ); my $second_key = 'Second Test Key'; $cache->set( $second_key, $value ); my $second_size = $cache->size( ); ( $second_size > $first_size ) ? $self->ok( ) : $self->not_ok( '$second_size > $first_size' ); } # Test purging the cache sub _test_eight { my ( $self, $cache ) = @_; $cache->clear( ); my $empty_size = $cache->size( ); ( $empty_size == 0 ) ? $self->ok( ) : $self->not_ok( '$empty_size == 0' ); my $expires_in = $EXPIRES_DELAY; my $key = 'Test Key'; my $value = 'Test Value'; $cache->set( $key, $value, $expires_in ); my $pre_purge_size = $cache->size( ); ( $pre_purge_size > $empty_size ) ? $self->ok( ) : $self->not_ok( '$pre_purge_size > $empty_size' ); sleep( $EXPIRES_DELAY + 1 ); $cache->purge( ); my $post_purge_size = $cache->size( ); ( $post_purge_size == $empty_size ) ? $self->ok( ) : $self->not_ok( '$post_purge_size == $empty_size' ); } # Test the getting, setting, and removal of a scalar across cache instances sub _test_nine { my ( $self, $cache1 ) = @_; $cache1 or croak( "cache required" ); my $cache2 = $cache1->new( ) or croak( "Couldn't construct new cache" ); my $key = 'Test Key'; my $value = 'Test Value'; $cache1->set( $key, $value ); my $fetched_value = $cache2->get( $key ); ( $fetched_value eq $value ) ? $self->ok( ) : $self->not_ok( '$fetched_value eq $value' ); } # Test Clear() and Size() as instance methods sub _test_ten { my ( $self, $cache ) = @_; $cache or croak( "cache required" ); my $key = 'Test Key'; my $value = 'Test Value'; $cache->set( $key, $value ); my $full_size = $cache->Size( ); ( $full_size > 0 ) ? $self->ok( ) : $self->not_ok( '$full_size > 0' ); $cache->Clear( ); my $empty_size = $cache->Size( ); ( $empty_size == 0 ) ? $self->ok( ) : $self->not_ok( '$empty_size == 0' ); } # Test Purge(), Clear(), and Size() as instance methods sub _test_eleven { my ( $self, $cache ) = @_; $cache->Clear( ); my $empty_size = $cache->Size( ); ( $empty_size == 0 ) ? $self->ok( ) : $self->not_ok( '$empty_size == 0' ); my $expires_in = $EXPIRES_DELAY; my $key = 'Test Key'; my $value = 'Test Value'; $cache->set( $key, $value, $expires_in ); my $pre_purge_size = $cache->Size( ); ( $pre_purge_size > $empty_size ) ? $self->ok( ) : $self->not_ok( '$pre_purge_size > $empty_size' ); sleep( $EXPIRES_DELAY + 1 ); $cache->Purge( ); my $purged_object = $cache->get_object( $key ); ( not defined $purged_object ) ? $self->ok( ) : $self->not_ok( 'not defined $purged_object' ); } # Test Purge(), Clear(), and Size() as static methods sub _test_twelve { my ( $self, $cache ) = @_; my $class = ref $cache or croak( "Couldn't get ref \$cache" ); no strict 'refs'; &{"${class}::Clear"}( ); my $empty_size = &{"${class}::Size"}( ); ( $empty_size == 0 ) ? $self->ok( ) : $self->not_ok( '$empty_size == 0' ); my $expires_in = $EXPIRES_DELAY; my $key = 'Test Key'; my $value = 'Test Value'; $cache->set( $key, $value, $expires_in ); my $pre_purge_size = &{"${class}::Size"}( ); ( $pre_purge_size > $empty_size ) ? $self->ok( ) : $self->not_ok( '$pre_purge_size > $empty_size' ); sleep( $EXPIRES_DELAY + 1 ); &{"${class}::Purge"}( ); my $purged_object = $cache->get_object( $key ); ( not defined $purged_object ) ? $self->ok( ) : $self->not_ok( 'not defined $purged_object' ); use strict; } # Test the expiration of an object with extended syntax sub _test_thirteen { my ( $self, $cache ) = @_; my $expires_in = $EXPIRES_DELAY; my $key = 'Test Key'; my $value = 'Test Value'; my $start = time; $cache->set( $key, $value, $expires_in ); my $fetched_value = $cache->get( $key ); if (time - $start < $expires_in) { ( $fetched_value eq $value ) ? $self->ok( ) : $self->not_ok( '$fetched_value eq $value' ); } else { $self->skip( '$fetched_value eq $value (not finished in ' . $expires_in . ' s)' ); } sleep( $EXPIRES_DELAY + 1 ); my $fetched_expired_value = $cache->get( $key ); ( not defined $fetched_expired_value ) ? $self->ok( ) : $self->not_ok( 'not defined $fetched_expired_value' ); } # test the get_keys method sub _test_fourteen { my ( $self, $cache ) = @_; $cache->Clear( ); my $empty_size = $cache->Size( ); ( $empty_size == 0 ) ? $self->ok( ) : $self->not_ok( '$empty_size == 0' ); my @keys = sort ( 'John', 'Paul', 'Ringo', 'George' ); my $value = 'Test Value'; foreach my $key ( @keys ) { $cache->set( $key, $value ); } my @cached_keys = sort $cache->get_keys( ); my $arrays_equal = Arrays_Are_Equal( \@keys, \@cached_keys ); ( $arrays_equal == 1 ) ? $self->ok( ) : $self->not_ok( '$arrays_equal == 1' ); } # test the auto_purge on set functionality sub _test_fifteen { my ( $self, $cache ) = @_; $cache->Clear( ); my $expires_in = $EXPIRES_DELAY; $cache->set_auto_purge_interval( $expires_in ); $cache->set_auto_purge_on_set( 1 ); my $key = 'Test Key'; my $value = 'Test Value'; my $start = time; $cache->set( $key, $value, $expires_in ); my $fetched_value = $cache->get( $key ); if (time - $start < $expires_in) { ( $fetched_value eq $value ) ? $self->ok( ) : $self->not_ok( '$fetched_value eq $value' ); } else { $self->skip( '$fetched_value eq $value (not finished in ' . $expires_in . ' s)' ); } sleep( $EXPIRES_DELAY + 1 ); $cache->set( "Trigger auto_purge", "Empty" ); my $fetched_expired_object = $cache->get_object( $key ); ( not defined $fetched_expired_object ) ? $self->ok( ) : $self->not_ok( 'not defined $fetched_expired_object' ); $cache->Clear( ); } # test the auto_purge_interval functionality sub _test_sixteen { my ( $self, $cache ) = @_; my $expires_in = $EXPIRES_DELAY; my $ok = eval { $cache = $cache->new( { 'auto_purge_interval' => $expires_in } ); 1; }; $ok ? $self->ok( ) : $self->not_ok( "couldn't create autopurge cache" ); } # test the get_namespaces method sub _test_seventeen { my ( $self, $cache ) = @_; $cache->set( 'a', '1' ); $cache->set_namespace( 'namespace' ); $cache->set( 'b', '2' ); if ( Arrays_Are_Equal( [ sort( $cache->get_namespaces( ) ) ], [ sort( 'Default', 'namespace' ) ] ) ) { $self->ok( ); } else { $self->not_ok( "get_namespaces returned the wrong namespaces" ); } $cache->Clear( ); } sub Arrays_Are_Equal { my ( $first_array_ref, $second_array_ref ) = @_; local $^W = 0; # silence spurious -w undef complaints return 0 unless @$first_array_ref == @$second_array_ref; for (my $i = 0; $i < @$first_array_ref; $i++) { return 0 if $first_array_ref->[$i] ne $second_array_ref->[$i]; } return 1; } 1; __END__ =pod =head1 NAME Cache::CacheTester -- a class for regression testing caches =head1 DESCRIPTION The CacheTester is used to verify that a cache implementation honors its contract. =head1 SYNOPSIS use Cache::MemoryCache; use Cache::CacheTester; my $cache = new Cache::MemoryCache( ); my $cache_tester = new Cache::CacheTester( 1 ); $cache_tester->test( $cache ); =head1 METHODS =over =item B Construct a new CacheTester object, with the counter starting at I<$initial_count>. =item B Run the tests. =back =head1 SEE ALSO Cache::Cache, Cache::BaseCacheTester =head1 AUTHOR Original author: DeWitt Clinton Last author: $Author: dclinton $ Copyright (C) 2001-2003 DeWitt Clinton =cut Cache-Cache-1.08/lib/Cache/CacheUtils.pm000644 000766 000024 00000005551 12406310064 017707 0ustar00rjbsstaff000000 000000 ###################################################################### # $Id: CacheUtils.pm,v 1.39 2003/04/15 14:46:19 dclinton Exp $ # Copyright (C) 2001-2003 DeWitt Clinton All Rights Reserved # # Software distributed under the License is distributed on an "AS # IS" basis, WITHOUT WARRANTY OF ANY KIND, either expressed or # implied. See the License for the specific language governing # rights and limitations under the License. ###################################################################### package Cache::CacheUtils; use strict; use vars qw( @ISA @EXPORT_OK ); use Cache::Cache; use Error; use Exporter; use File::Spec; use Storable qw( nfreeze thaw dclone ); @ISA = qw( Exporter ); @EXPORT_OK = qw( Assert_Defined Build_Path Clone_Data Freeze_Data Static_Params Thaw_Data ); # throw an Exception if the Assertion fails sub Assert_Defined { if ( not defined $_[0] ) { my ( $package, $filename, $line ) = caller( ); throw Error::Simple( "Assert_Defined failed: $package line $line\n" ); } } # Take a list of directory components and create a valid path sub Build_Path { my ( @p_elements ) = @_; # TODO: add this to Untaint_Path or something # ( $p_unique_key !~ m|[0-9][a-f][A-F]| ) or # throw Error::Simple( "key '$p_unique_key' contains illegal characters'" ); if ( grep ( /\.\./, @p_elements ) ) { throw Error::Simple( "Illegal path characters '..'" ); } return File::Spec->catfile( @p_elements ); } # use Storable to clone an object sub Clone_Data { my ( $p_object ) = @_; return defined $p_object ? dclone( $p_object ) : undef; } # use Storable to freeze an object sub Freeze_Data { my ( $p_object ) = @_; return defined $p_object ? nfreeze( $p_object ) : undef; } # Take a parameter list and automatically shift it such that if # the method was called as a static method, then $self will be # undefined. This allows the use to write # # sub Static_Method # { # my ( $parameter ) = Static_Params( @_ ); # } # # and not worry about whether it is called as: # # Class->Static_Method( $param ); # # or # # Class::Static_Method( $param ); sub Static_Params { my $type = ref $_[0]; if ( $type and ( $type !~ /^(SCALAR|ARRAY|HASH|CODE|REF|GLOB|LVALUE)$/ ) ) { shift( @_ ); } return @_; } # use Storable to thaw an object sub Thaw_Data { my ( $p_frozen_object ) = @_; return defined $p_frozen_object ? thaw( $p_frozen_object ) : undef; } 1; __END__ =pod =head1 NAME Cache::CacheUtils -- miscellaneous utility routines =head1 DESCRIPTION The CacheUtils package is a collection of static methods that provide functionality useful to many different classes. =head1 AUTHOR Original author: DeWitt Clinton Last author: $Author: dclinton $ Copyright (C) 2001-2003 DeWitt Clinton =cut Cache-Cache-1.08/lib/Cache/FileBackend.pm000644 000766 000024 00000034100 12460217136 020010 0ustar00rjbsstaff000000 000000 ###################################################################### # $Id: FileBackend.pm,v 1.27 2005/03/17 19:31:27 dclinton Exp $ # Copyright (C) 2001-2003 DeWitt Clinton All Rights Reserved # # Software distributed under the License is distributed on an "AS # IS" basis, WITHOUT WARRANTY OF ANY KIND, either expressed or # implied. See the License for the specific language governing # rights and limitations under the License. ###################################################################### package Cache::FileBackend; use strict; use Cache::CacheUtils qw( Assert_Defined Build_Path Freeze_Data Thaw_Data ); use Digest::SHA1 qw( sha1_hex ); use Error; use File::Path qw( mkpath ); use File::Temp qw( tempfile ); # the file mode for new directories, which will be modified by the # current umask my $DIRECTORY_MODE = 0777; # regex for untainting directory and file paths. since all paths are # generated by us or come from user via API, a tautological regex # suffices. my $UNTAINTED_PATH_REGEX = '^(.*)$'; sub new { my ( $proto, $p_root, $p_depth, $p_directory_umask ) = @_; my $class = ref( $proto ) || $proto; my $self = {}; $self = bless( $self, $class ); $self->set_root( $p_root ); $self->set_depth( $p_depth ); $self->set_directory_umask( $p_directory_umask ); return $self; } sub delete_key { my ( $self, $p_namespace, $p_key ) = @_; Assert_Defined( $p_namespace ); Assert_Defined( $p_key ); _Remove_File( $self->_path_to_key( $p_namespace, $p_key ) ); } sub delete_namespace { my ( $self, $p_namespace ) = @_; Assert_Defined( $p_namespace ); _Recursively_Remove_Directory( Build_Path( $self->get_root( ), $p_namespace ) ); } sub get_keys { my ( $self, $p_namespace ) = @_; Assert_Defined( $p_namespace ); my @keys; foreach my $unique_key ( $self->_get_unique_keys( $p_namespace ) ) { my $key = $self->_get_key_for_unique_key( $p_namespace, $unique_key ) or next; push( @keys, $key ); } return @keys; } sub get_namespaces { my ( $self ) = @_; my @namespaces; _List_Subdirectories( $self->get_root( ), \@namespaces ); return @namespaces; } sub get_size { my ( $self, $p_namespace, $p_key ) = @_; Assert_Defined( $p_namespace ); Assert_Defined( $p_key ); if ( -e $self->_path_to_key( $p_namespace, $p_key ) ) { return -s $self->_path_to_key( $p_namespace, $p_key ); } else { return 0; } } sub restore { my ( $self, $p_namespace, $p_key ) = @_; Assert_Defined( $p_namespace ); Assert_Defined( $p_key ); return $self->_read_data( $self->_path_to_key($p_namespace, $p_key) )->[1]; } sub store { my ( $self, $p_namespace, $p_key, $p_data ) = @_; Assert_Defined( $p_namespace ); Assert_Defined( $p_key ); $self->_write_data( $self->_path_to_key( $p_namespace, $p_key ), [ $p_key, $p_data ] ); } sub get_depth { my ( $self ) = @_; return $self->{_Depth}; } sub set_depth { my ( $self, $depth ) = @_; $self->{_Depth} = $depth; } sub get_root { my ( $self ) = @_; return $self->{_Root}; } sub set_root { my ( $self, $root ) = @_; $self->{_Root} = $root; } sub get_directory_umask { my ( $self ) = @_; return $self->{_Directory_Umask}; } sub set_directory_umask { my ( $self, $directory_umask ) = @_; $self->{_Directory_Umask} = $directory_umask; } # Take an human readable key, and create a unique key from it sub _Build_Unique_Key { my ( $p_key ) = @_; Assert_Defined( $p_key ); return sha1_hex( $p_key ); } # create a directory with optional mask, building subdirectories as # needed. sub _Create_Directory { my ( $p_directory, $p_optional_new_umask ) = @_; Assert_Defined( $p_directory ); my $old_umask = umask( ) if defined $p_optional_new_umask; umask( $p_optional_new_umask ) if defined $p_optional_new_umask; my $directory = _Untaint_Path( $p_directory ); $directory =~ s|/$||; mkpath( $directory, 0, $DIRECTORY_MODE ); -d $directory or throw Error::Simple( "Couldn't create directory: $directory: $!" ); umask( $old_umask ) if defined $old_umask; } # list the names of the subdirectories in a given directory, without the # full path sub _List_Subdirectories { my ( $p_directory, $p_subdirectories_ref ) = @_; foreach my $dirent ( _Read_Dirents( $p_directory ) ) { next if $dirent eq '.' or $dirent eq '..'; my $path = Build_Path( $p_directory, $dirent ); next unless -d $path; push( @$p_subdirectories_ref, $dirent ); } } # read the dirents from a directory sub _Read_Dirents { my ( $p_directory ) = @_; Assert_Defined( $p_directory ); -d $p_directory or return ( ); local *Dir; opendir( Dir, _Untaint_Path( $p_directory ) ) or throw Error::Simple( "Couldn't open directory $p_directory: $!" ); my @dirents = readdir( Dir ); closedir( Dir ) or throw Error::Simple( "Couldn't close directory $p_directory: $!" ); return @dirents; } # read in a file. returns a reference to the data read sub _Read_File { my ( $p_path ) = @_; Assert_Defined( $p_path ); local *File; open( File, _Untaint_Path( $p_path ) ) or return undef; binmode( File ); local $/ = undef; my $data_ref; $$data_ref = ; close( File ); return $data_ref; } # read in a file. returns a reference to the data read, without # modifying the last accessed time sub _Read_File_Without_Time_Modification { my ( $p_path ) = @_; Assert_Defined( $p_path ); -e $p_path or return undef; my ( $file_access_time, $file_modified_time ) = ( stat( _Untaint_Path( $p_path ) ) )[8,9]; my $data_ref = _Read_File( $p_path ); utime( $file_access_time, $file_modified_time, _Untaint_Path( $p_path ) ); return $data_ref; } # remove a file sub _Remove_File { my ( $p_path ) = @_; Assert_Defined( $p_path ); if ( -f _Untaint_Path( $p_path ) ) { # We don't catch the error, because this may fail if two # processes are in a race and try to remove the object unlink( _Untaint_Path( $p_path ) ); } } # remove a directory sub _Remove_Directory { my ( $p_directory ) = @_; Assert_Defined( $p_directory ); if ( -d _Untaint_Path( $p_directory ) ) { # We don't catch the error, because this may fail if two # processes are in a race and try to remove the object rmdir( _Untaint_Path( $p_directory ) ); } } # recursively list the files of the subdirectories, without the full paths sub _Recursively_List_Files { my ( $p_directory, $p_files_ref ) = @_; return unless -d $p_directory; foreach my $dirent ( _Read_Dirents( $p_directory ) ) { next if $dirent eq '.' or $dirent eq '..'; my $path = Build_Path( $p_directory, $dirent ); if ( -d $path ) { _Recursively_List_Files( $path, $p_files_ref ); } else { push( @$p_files_ref, $dirent ); } } } # recursively list the files of the subdirectories, with the full paths sub _Recursively_List_Files_With_Paths { my ( $p_directory, $p_files_ref ) = @_; foreach my $dirent ( _Read_Dirents( $p_directory ) ) { next if $dirent eq '.' or $dirent eq '..'; my $path = Build_Path( $p_directory, $dirent ); if ( -d $path ) { _Recursively_List_Files_With_Paths( $path, $p_files_ref ); } else { push( @$p_files_ref, $path ); } } } # remove a directory and all subdirectories and files sub _Recursively_Remove_Directory { my ( $p_root ) = @_; return unless -d $p_root; foreach my $dirent ( _Read_Dirents( $p_root ) ) { next if $dirent eq '.' or $dirent eq '..'; my $path = Build_Path( $p_root, $dirent ); if ( -d $path ) { _Recursively_Remove_Directory( $path ); } else { _Remove_File( _Untaint_Path( $path ) ); } } _Remove_Directory( _Untaint_Path( $p_root ) ); } # walk down a directory structure and total the size of the files # contained therein. sub _Recursive_Directory_Size { my ( $p_directory ) = @_; Assert_Defined( $p_directory ); return 0 unless -d $p_directory; my $size = 0; foreach my $dirent ( _Read_Dirents( $p_directory ) ) { next if $dirent eq '.' or $dirent eq '..'; my $path = Build_Path( $p_directory, $dirent ); if ( -d $path ) { $size += _Recursive_Directory_Size( $path ); } else { $size += -s $path; } } return $size; } # Untaint a file path sub _Untaint_Path { my ( $p_path ) = @_; return _Untaint_String( $p_path, $UNTAINTED_PATH_REGEX ); } # Untaint a string sub _Untaint_String { my ( $p_string, $p_untainted_regex ) = @_; Assert_Defined( $p_string ); Assert_Defined( $p_untainted_regex ); my ( $untainted_string ) = $p_string =~ /$p_untainted_regex/; if ( not defined $untainted_string || $untainted_string ne $p_string ) { throw Error::Simple( "String $p_string contains possible taint" ); } return $untainted_string; } # create a directory with the optional umask if it doesn't already # exist sub _Make_Path { my ( $p_path, $p_optional_new_umask ) = @_; my ( $volume, $directory, $filename ) = File::Spec->splitpath( $p_path ); if ( defined $directory and defined $volume ) { $directory = File::Spec->catpath( $volume, $directory, "" ); } if ( defined $directory and not -d $directory ) { _Create_Directory( $directory, $p_optional_new_umask ); } } # return a list of the first $depth letters in the $word sub _Split_Word { my ( $p_word, $p_depth ) = @_; Assert_Defined( $p_word ); Assert_Defined( $p_depth ); my @split_word_list; for ( my $i = 0; $i < $p_depth; $i++ ) { push ( @split_word_list, substr( $p_word, $i, 1 ) ); } return @split_word_list; } # write a file atomically sub _Write_File { my ( $p_path, $p_data_ref, $p_optional_mode, $p_optional_umask ) = @_; Assert_Defined( $p_path ); Assert_Defined( $p_data_ref ); my $old_umask = umask if $p_optional_umask; umask( $p_optional_umask ) if $p_optional_umask; my ( $volume, $directory, $filename ) = File::Spec->splitpath( $p_path ); if ( defined $directory and defined $volume ) { $directory = File::Spec->catpath( $volume, $directory, "" ); } my ( $temp_fh, $temp_filename ) = tempfile( DIR => $directory ); binmode( $temp_fh ); print $temp_fh $$p_data_ref; close( $temp_fh ); -e $temp_filename or throw Error::Simple( "Temp file '$temp_filename' does not exist: $!" ); rename( $temp_filename, _Untaint_Path( $p_path ) ) or throw Error::Simple( "Couldn't rename $temp_filename to $p_path: $!" ); if ( -e $temp_filename ) { _Remove_File( $temp_filename ); warn( "Temp file '$temp_filename' shouldn't still exist" ); } $p_optional_mode ||= 0666 - umask( ); chmod( $p_optional_mode, _Untaint_Path($p_path) ); umask( $old_umask ) if $old_umask; } sub _get_key_for_unique_key { my ( $self, $p_namespace, $p_unique_key ) = @_; return $self->_read_data( $self->_path_to_unique_key( $p_namespace, $p_unique_key ) )->[0]; } sub _get_unique_keys { my ( $self, $p_namespace ) = @_; Assert_Defined( $p_namespace ); my @unique_keys; _Recursively_List_Files( Build_Path( $self->get_root( ), $p_namespace ), \@unique_keys ); return @unique_keys; } sub _path_to_key { my ( $self, $p_namespace, $p_key ) = @_; Assert_Defined( $p_namespace ); Assert_Defined( $p_key ); return $self->_path_to_unique_key( $p_namespace, _Build_Unique_Key( $p_key ) ); } sub _path_to_unique_key { my ( $self, $p_namespace, $p_unique_key ) = @_; Assert_Defined( $p_unique_key ); Assert_Defined( $p_namespace ); return Build_Path( $self->get_root( ), $p_namespace, _Split_Word( $p_unique_key, $self->get_depth( ) ), $p_unique_key ); } # the data is returned as reference to an array ( key, data ) sub _read_data { my ( $self, $p_path ) = @_; Assert_Defined( $p_path ); my $frozen_data_ref = _Read_File_Without_Time_Modification( $p_path ) or return [ undef, undef ]; my $data_ref = eval{ Thaw_Data( $$frozen_data_ref ) }; if ( $@ || ( ref( $data_ref ) ne 'ARRAY' ) ) { unlink _Untaint_Path( $p_path ); return [ undef, undef ]; } else { return $data_ref; } } # the data is passed as reference to an array ( key, data ) sub _write_data { my ( $self, $p_path, $p_data ) = @_; Assert_Defined( $p_path ); Assert_Defined( $p_data ); _Make_Path( $p_path, $self->get_directory_umask( ) ); my $frozen_file = Freeze_Data( $p_data ); _Write_File( $p_path, \$frozen_file ); } 1; __END__ =pod =head1 NAME Cache::FileBackend -- a filesystem based persistence mechanism =head1 DESCRIPTION The FileBackend class is used to persist data to the filesystem =head1 SYNOPSIS my $backend = new Cache::FileBackend( '/tmp/FileCache', 3, 000 ); See Cache::Backend for the usage synopsis. $backend->store( 'namespace', 'foo', 'bar' ); my $bar = $backend->restore( 'namespace', 'foo' ); my $size_of_bar = $backend->get_size( 'namespace', 'foo' ); foreach my $key ( $backend->get_keys( 'namespace' ) ) { $backend->delete_key( 'namespace', $key ); } foreach my $namespace ( $backend->get_namespaces( ) ) { $backend->delete_namespace( $namespace ); } =head1 METHODS See Cache::Backend for the API documentation. =over =item B Construct a new FileBackend that writes data to the I<$root> directory, automatically creates subdirectories I<$depth> levels deep, and uses the umask of I<$directory_umask> when creating directories. =back =head1 PROPERTIES =over =item B<(get|set)_root> The location of the parent directory in which to store the files =item B<(get|set)_depth> The branching factor of the subdirectories created to store the files =item B<(get|set)_directory_umask> The umask to be used when creating directories =back =head1 SEE ALSO Cache::Backend, Cache::MemoryBackend, Cache::SharedMemoryBackend =head1 AUTHOR Original author: DeWitt Clinton Last author: $Author: dclinton $ Copyright (C) 2001-2003 DeWitt Clinton =cut Cache-Cache-1.08/lib/Cache/FileCache.pm000644 000766 000024 00000016262 12460216053 017472 0ustar00rjbsstaff000000 000000 ###################################################################### # $Id: FileCache.pm,v 1.31 2002/04/07 17:04:46 dclinton Exp $ # Copyright (C) 2001-2003 DeWitt Clinton All Rights Reserved # # Software distributed under the License is distributed on an "AS # IS" basis, WITHOUT WARRANTY OF ANY KIND, either expressed or # implied. See the License for the specific language governing # rights and limitations under the License. ###################################################################### package Cache::FileCache; use strict; use vars qw( @ISA ); use Cache::BaseCache; use Cache::Cache; use Cache::CacheUtils qw ( Assert_Defined Build_Path Static_Params ); use Cache::FileBackend; use Cache::Object; use Error; use File::Spec::Functions; @ISA = qw ( Cache::BaseCache ); # by default, the cache nests all entries on the filesystem three # directories deep my $DEFAULT_CACHE_DEPTH = 3; # by default, the root of the cache is located in 'FileCache'. On a # UNIX system, this will appear in "/tmp/FileCache/" my $DEFAULT_CACHE_ROOT = "FileCache"; # by default, the directories in the cache on the filesystem should # be globally writable to allow for multiple users. While this is a # potential security concern, the actual cache entries are written # with the user's umask, thus reducing the risk of cache poisoning my $DEFAULT_DIRECTORY_UMASK = 000; sub Clear { my ( $p_optional_cache_root ) = Static_Params( @_ ); foreach my $namespace ( _Namespaces( $p_optional_cache_root ) ) { _Get_Cache( $namespace, $p_optional_cache_root )->clear( ); } } sub Purge { my ( $p_optional_cache_root ) = Static_Params( @_ ); foreach my $namespace ( _Namespaces( $p_optional_cache_root ) ) { _Get_Cache( $namespace, $p_optional_cache_root )->purge( ); } } sub Size { my ( $p_optional_cache_root ) = Static_Params( @_ ); my $size = 0; foreach my $namespace ( _Namespaces( $p_optional_cache_root ) ) { $size += _Get_Cache( $namespace, $p_optional_cache_root )->size( ); } return $size; } sub new { my ( $self ) = _new( @_ ); $self->_complete_initialization( ); return $self; } sub _Get_Backend { my ( $p_optional_cache_root ) = Static_Params( @_ ); return new Cache::FileBackend( _Build_Cache_Root( $p_optional_cache_root ) ); } # return the OS default temp directory sub _Get_Temp_Directory { my $tmpdir = File::Spec->tmpdir( ) or throw Error::Simple( "No tmpdir on this system. Upgrade File::Spec?" ); return $tmpdir; } sub _Build_Cache_Root { my ( $p_optional_cache_root ) = Static_Params( @_ ); if ( defined $p_optional_cache_root ) { return $p_optional_cache_root; } else { return Build_Path( _Get_Temp_Directory( ), $DEFAULT_CACHE_ROOT ); } } sub _Namespaces { my ( $p_optional_cache_root ) = Static_Params( @_ ); return _Get_Backend( $p_optional_cache_root )->get_namespaces( ); } sub _Get_Cache { my ( $p_namespace, $p_optional_cache_root ) = Static_Params( @_ ); Assert_Defined( $p_namespace ); if ( defined $p_optional_cache_root ) { return new Cache::FileCache( { 'namespace' => $p_namespace, 'cache_root' => $p_optional_cache_root } ); } else { return new Cache::FileCache( { 'namespace' => $p_namespace } ); } } sub _new { my ( $proto, $p_options_hash_ref ) = @_; my $class = ref( $proto ) || $proto; my $self = $class->SUPER::_new( $p_options_hash_ref ); $self->_initialize_file_backend( ); return $self; } sub _initialize_file_backend { my ( $self ) = @_; $self->_set_backend( new Cache::FileBackend( $self->_get_initial_root( ), $self->_get_initial_depth( ), $self->_get_initial_umask( ) )); } sub _get_initial_root { my ( $self ) = @_; if ( defined $self->_read_option( 'cache_root' ) ) { return $self->_read_option( 'cache_root' ); } else { return Build_Path( _Get_Temp_Directory( ), $DEFAULT_CACHE_ROOT ); } } sub _get_initial_depth { my ( $self ) = @_; return $self->_read_option( 'cache_depth', $DEFAULT_CACHE_DEPTH ); } sub _get_initial_umask { my ( $self ) = @_; return $self->_read_option( 'directory_umask', $DEFAULT_DIRECTORY_UMASK ); } sub get_cache_depth { my ( $self ) = @_; return $self->_get_backend( )->get_depth( ); } sub set_cache_depth { my ( $self, $p_cache_depth ) = @_; $self->_get_backend( )->set_depth( $p_cache_depth ); } sub get_cache_root { my ( $self ) = @_; return $self->_get_backend( )->get_root( ); } sub set_cache_root { my ( $self, $p_cache_root ) = @_; $self->_get_backend( )->set_root( $p_cache_root ); } sub get_directory_umask { my ( $self ) = @_; return $self->_get_backend( )->get_directory_umask( ); } sub set_directory_umask { my ( $self, $p_directory_umask ) = @_; $self->_get_backend( )->set_directory_umask( $p_directory_umask ); } 1; __END__ =pod =head1 NAME Cache::FileCache -- implements the Cache interface. =head1 DESCRIPTION The FileCache class implements the Cache interface. This cache stores data in the filesystem so that it can be shared between processes. =head1 SYNOPSIS use Cache::FileCache; my $cache = new Cache::FileCache( { 'namespace' => 'MyNamespace', 'default_expires_in' => 600 } ); See Cache::Cache for the usage synopsis. =head1 METHODS See Cache::Cache for the API documentation. =over =item B See Cache::Cache, with the optional I<$cache_root> parameter. =item B See Cache::Cache, with the optional I<$cache_root> parameter. =item B See Cache::Cache, with the optional I<$cache_root> parameter. =back =head1 OPTIONS See Cache::Cache for standard options. Additionally, options are set by passing in a reference to a hash containing any of the following keys: =over =item I The location in the filesystem that will hold the root of the cache. Defaults to the 'FileCache' under the OS default temp directory ( often '/tmp' on UNIXes ) unless explicitly set. =item I The number of subdirectories deep to cache object item. This should be large enough that no cache directory has more than a few hundred objects. Defaults to 3 unless explicitly set. =item I The directories in the cache on the filesystem should be globally writable to allow for multiple users. While this is a potential security concern, the actual cache entries are written with the user's umask, thus reducing the risk of cache poisoning. If you desire it to only be user writable, set the 'directory_umask' option to '077' or similar. Defaults to '000' unless explicitly set. =back =head1 PROPERTIES See Cache::Cache for default properties. =over =item B<(get|set)_cache_root> See the definition above for the option I =item B<(get|set)_cache_depth> See the definition above for the option I =item B<(get|set)_directory_umask> See the definition above for the option I =back =head1 SEE ALSO Cache::Cache =head1 AUTHOR Original author: DeWitt Clinton Last author: $Author: dclinton $ Copyright (C) 2001-2003 DeWitt Clinton =cut Cache-Cache-1.08/lib/Cache/MemoryBackend.pm000644 000766 000024 00000005104 12460217150 020377 0ustar00rjbsstaff000000 000000 ###################################################################### # $Id: MemoryBackend.pm,v 1.10 2003/01/16 18:10:16 dclinton Exp $ # Copyright (C) 2001-2003 DeWitt Clinton All Rights Reserved # # Software distributed under the License is distributed on an "AS # IS" basis, WITHOUT WARRANTY OF ANY KIND, either expressed or # implied. See the License for the specific language governing # rights and limitations under the License. ###################################################################### package Cache::MemoryBackend; use strict; use Cache::CacheUtils qw( Clone_Data ); my $Store_Ref = { }; sub new { my ( $proto ) = @_; my $class = ref( $proto ) || $proto; my $self = {}; $self = bless( $self, $class ); $self->_initialize_memory_backend( ); return $self; } sub delete_key { my ( $self, $p_namespace, $p_key ) = @_; delete $self->_get_store_ref( )->{ $p_namespace }{ $p_key }; } sub delete_namespace { my ( $self, $p_namespace ) = @_; delete $self->_get_store_ref( )->{ $p_namespace }; } sub get_keys { my ( $self, $p_namespace ) = @_; return keys %{ $self->_get_store_ref( )->{ $p_namespace } }; } sub get_namespaces { my ( $self ) = @_; return keys %{ $self->_get_store_ref( ) }; } sub get_size { my ( $self, $p_namespace, $p_key ) = @_; if ( exists $self->_get_store_ref( )->{ $p_namespace }{ $p_key } ) { return length $self->_get_store_ref( )->{ $p_namespace }{ $p_key }; } else { return 0; } } sub restore { my ( $self, $p_namespace, $p_key ) = @_; return Clone_Data( $self->_get_store_ref( )->{ $p_namespace }{ $p_key } ); } sub store { my ( $self, $p_namespace, $p_key, $p_data ) = @_; $self->_get_store_ref( )->{ $p_namespace }{ $p_key } = $p_data; } sub _initialize_memory_backend { my ( $self ) = @_; if ( not defined $self->_get_store_ref( ) ) { $self->_set_store_ref( { } ); } } sub _get_store_ref { return $Store_Ref; } sub _set_store_ref { my ( $self, $p_store_ref ) = @_; $Store_Ref = $p_store_ref; } 1; __END__ =pod =head1 NAME Cache::MemoryBackend -- a memory based persistence mechanism =head1 DESCRIPTION The MemoryBackend class is used to persist data to memory =head1 SYNOPSIS my $backend = new Cache::MemoryBackend( ); See Cache::Backend for the usage synopsis. =head1 METHODS See Cache::Backend for the API documentation. =head1 SEE ALSO Cache::Backend, Cache::FileBackend, Cache::ShareMemoryBackend =head1 AUTHOR Original author: DeWitt Clinton Last author: $Author: dclinton $ Copyright (C) 2001-2003 DeWitt Clinton =cut Cache-Cache-1.08/lib/Cache/MemoryCache.pm000644 000766 000024 00000005415 12406310064 020056 0ustar00rjbsstaff000000 000000 ###################################################################### # $Id: MemoryCache.pm,v 1.27 2002/04/07 17:04:46 dclinton Exp $ # Copyright (C) 2001-2003 DeWitt Clinton All Rights Reserved # # Software distributed under the License is distributed on an "AS # IS" basis, WITHOUT WARRANTY OF ANY KIND, either expressed or # implied. See the License for the specific language governing # rights and limitations under the License. ###################################################################### package Cache::MemoryCache; use strict; use vars qw( @ISA ); use Cache::BaseCache; use Cache::Cache qw( $EXPIRES_NEVER ); use Cache::CacheUtils qw( Assert_Defined Static_Params ); use Cache::MemoryBackend; @ISA = qw ( Cache::BaseCache ); sub Clear { foreach my $namespace ( _Namespaces( ) ) { _Get_Backend( )->delete_namespace( $namespace ); } } sub Purge { foreach my $namespace ( _Namespaces( ) ) { _Get_Cache( $namespace )->purge( ); } } sub Size { my $size = 0; foreach my $namespace ( _Namespaces( ) ) { $size += _Get_Cache( $namespace )->size( ); } return $size; } sub _Get_Backend { return new Cache::MemoryBackend( ); } sub _Namespaces { return _Get_Backend( )->get_namespaces( ); } sub _Get_Cache { my ( $p_namespace ) = Static_Params( @_ ); Assert_Defined( $p_namespace ); return new Cache::MemoryCache( { 'namespace' => $p_namespace } ); } sub new { my ( $self ) = _new( @_ ); $self->_complete_initialization( ); return $self; } sub _new { my ( $proto, $p_options_hash_ref ) = @_; my $class = ref( $proto ) || $proto; my $self = $class->SUPER::_new( $p_options_hash_ref ); $self->_set_backend( new Cache::MemoryBackend( ) ); return $self; } 1; __END__ =pod =head1 NAME Cache::MemoryCache -- implements the Cache interface. =head1 DESCRIPTION The MemoryCache class implements the Cache interface. This cache stores data on a per-process basis. This is the fastest of the cache implementations, but data can not be shared between processes with the MemoryCache. However, the data will remain in the cache until cleared, it expires, or the process dies. The cache object simply going out of scope will not destroy the data. =head1 SYNOPSIS use Cache::MemoryCache; my $cache = new Cache::MemoryCache( { 'namespace' => 'MyNamespace', 'default_expires_in' => 600 } ); See Cache::Cache for the usage synopsis. =head1 METHODS See Cache::Cache for the API documentation. =head1 OPTIONS See Cache::Cache for standard options. =head1 PROPERTIES See Cache::Cache for default properties. =head1 SEE ALSO Cache::Cache =head1 AUTHOR Original author: DeWitt Clinton Last author: $Author: dclinton $ Copyright (C) 2001-2003 DeWitt Clinton =cut Cache-Cache-1.08/lib/Cache/NullCache.pm000644 000766 000024 00000004322 12406310064 017514 0ustar00rjbsstaff000000 000000 ###################################################################### # $Id: NullCache.pm,v 1.7 2002/07/18 06:15:18 dclinton Exp $ # Copyright (C) 2001 Jay Sachs, 2002 DeWitt Clinton All Rights Reserved # # Software distributed under the License is distributed on an "AS # IS" basis, WITHOUT WARRANTY OF ANY KIND, either expressed or # implied. See the License for the specific language governing # rights and limitations under the License. ###################################################################### package Cache::NullCache; use strict; use vars qw( @ISA ); use Cache::BaseCache; use Cache::Cache qw( $EXPIRES_NOW ); @ISA = qw ( Cache::BaseCache ); sub Clear { } sub Purge { } sub Size { return 0; } sub new { my ( $proto ) = @_; return bless( {}, ref( $proto ) || $proto ); } sub clear { } sub get { return undef; } sub get_object { return undef; } sub purge { } sub remove { } sub set { } sub set_object { } sub size { return 0; } sub get_default_expires_in { return $EXPIRES_NOW; } sub get_keys { return ( ); } sub get_identifiers { warn( "get_identifiers has been marked deprepricated. use get_keys" ); return ( ); } sub get_auto_purge_interval { return 0; } sub set_auto_purge_interval { } sub get_auto_purge_on_set { return 0; } sub set_auto_purge_on_set { } sub get_auto_purge_on_get { return 0; } sub set_auto_purge_on_get { } __END__ =pod =head1 NAME Cache::NullCache -- implements the Cache interface. =head1 DESCRIPTION The NullCache class implements the Cache::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 to get and get_object will return undef. =head1 SYNOPSIS use Cache::NullCache; my $cache = new Cache::NullCache( ); See Cache::Cache for the usage synopsis. =head1 METHODS See Cache::Cache for the API documentation. =head1 OPTIONS See Cache::Cache for standard options. =head1 PROPERTIES See Cache::Cache for default properties. =head1 SEE ALSO Cache::Cache =head1 AUTHOR Original author: Jay Sachs Last author: $Author: dclinton $ Copyright (C) 2001 Jay Sachs, 2002 DeWitt Clinton =cut Cache-Cache-1.08/lib/Cache/Object.pm000644 000766 000024 00000006626 12460217162 017102 0ustar00rjbsstaff000000 000000 ###################################################################### # $Id: Object.pm,v 1.8 2002/04/07 17:04:46 dclinton Exp $ # Copyright (C) 2001-2003 DeWitt Clinton All Rights Reserved # # Software distributed under the License is distributed on an "AS # IS" basis, WITHOUT WARRANTY OF ANY KIND, either expressed or # implied. See the License for the specific language governing # rights and limitations under the License. ###################################################################### package Cache::Object; use strict; sub new { my ( $proto ) = @_; my $class = ref( $proto ) || $proto; my $self = {}; bless ( $self, $class ); return $self; } sub get_created_at { my ( $self ) = @_; return $self->{_Created_At}; } sub set_created_at { my ( $self, $p_created_at ) = @_; $self->{_Created_At} = $p_created_at; } sub get_accessed_at { my ( $self ) = @_; return $self->{_Accessed_At}; } sub set_accessed_at { my ( $self, $p_accessed_at ) = @_; $self->{_Accessed_At} = $p_accessed_at; } sub get_data { my ( $self ) = @_; return $self->{_Data}; } sub set_data { my ( $self, $p_data ) = @_; $self->{_Data} = $p_data; } sub get_expires_at { my ( $self ) = @_; return $self->{_Expires_At}; } sub set_expires_at { my ( $self, $p_expires_at ) = @_; $self->{_Expires_At} = $p_expires_at; } sub get_key { my ( $self ) = @_; return $self->{_Key}; } sub set_key { my ( $self, $p_key ) = @_; $self->{_Key} = $p_key; } sub get_size { my ( $self ) = @_; return $self->{_Size}; } sub set_size { my ( $self, $p_size ) = @_; $self->{_Size} = $p_size; } sub get_identifier { my ( $self ) = @_; warn( "get_identifier has been marked deprepricated. use get_key" ); return $self->get_key( ); } sub set_identifier { my ( $self, $p_identifier ) = @_; warn( "set_identifier has been marked deprepricated. use set_key" ); return $self->set_key( $p_identifier ); } 1; __END__ =pod =head1 NAME Cache::Object -- the data stored in a Cache. =head1 DESCRIPTION Object is used by classes implementing the Cache interface as an object oriented wrapper around the data. End users will not normally use Object directly, but it can be retrieved via the get_object method on the Cache::Cache interface. =head1 SYNOPSIS use Cache::Object; my $object = new Cache::Object( ); $object->set_key( $key ); $object->set_data( $data ); $object->set_expires_at( $expires_at ); $object->set_created_at( $created_at ); =head1 METHODS =over =item B Construct a new Cache::Object. =back =head1 PROPERTIES =over =item B<(get|set)_accessed_at> The time at which the object was last accessed. Various cache implementations will use the accessed_at property to store information for LRU algorithms. There is no guarantee that all caches will update this field, however. =item B<(get|set)_created_at> The time at which the object was created. =item B<(get|set)_data> A scalar containing or a reference pointing to the data to be stored. =item B<(get|set)_expires_at> The time at which the object should expire from the cache. =item B<(get|set)_key> The key under which the object was stored. =item B<(get|set)_size> The size of the frozen version of this object =back =head1 SEE ALSO Cache::Cache =head1 AUTHOR Original author: DeWitt Clinton Last author: $Author: dclinton $ Copyright (C) 2001-2003 DeWitt Clinton =cut Cache-Cache-1.08/lib/Cache/SharedMemoryBackend.pm000644 000766 000024 00000011335 12460217214 021532 0ustar00rjbsstaff000000 000000 ###################################################################### # $Id: SharedMemoryBackend.pm,v 1.7 2003/04/15 14:46:23 dclinton Exp $ # Copyright (C) 2001-2003 DeWitt Clinton All Rights Reserved # # Software distributed under the License is distributed on an "AS # IS" basis, WITHOUT WARRANTY OF ANY KIND, either expressed or # implied. See the License for the specific language governing # rights and limitations under the License. ###################################################################### package Cache::SharedMemoryBackend; use strict; use Cache::CacheUtils qw( Assert_Defined Freeze_Data Static_Params Thaw_Data ); use Cache::MemoryBackend; use IPC::ShareLite qw( LOCK_EX LOCK_UN ); use vars qw( @ISA ); @ISA = qw ( Cache::MemoryBackend ); my $IPC_IDENTIFIER = 'ipcc'; sub new { my ( $proto ) = @_; my $class = ref( $proto ) || $proto; return $class->SUPER::new( ); } sub delete_key { my ( $self, $p_namespace, $p_key ) = @_; my $store_ref = $self->_get_locked_store_ref( ); delete $store_ref->{ $p_namespace }{ $p_key }; $self->_set_locked_store_ref( $store_ref ); } sub delete_namespace { my ( $self, $p_namespace ) = @_; my $store_ref = $self->_get_locked_store_ref( ); delete $store_ref->{ $p_namespace }; $self->_set_locked_store_ref( $store_ref ); } sub store { my ( $self, $p_namespace, $p_key, $p_data ) = @_; my $store_ref = $self->_get_locked_store_ref( ); $store_ref->{ $p_namespace }{ $p_key } = $p_data; $self->_set_locked_store_ref( $store_ref ); } # create a IPC::ShareLite share under the ipc_identifier sub _Instantiate_Share { my ( $p_ipc_identifier ) = Static_Params( @_ ); Assert_Defined( $p_ipc_identifier ); my %ipc_options = ( -key => $p_ipc_identifier, -create => 'yes', -destroy => 'no', -exclusive => 'no' ); my $share = new IPC::ShareLite( %ipc_options ) or throw Error::Simple( "Couldn't instantiate IPC::ShareLite: $!" ); return $share; } # this method uses the shared created by Instantiate_Share to # transparently retrieve a reference to a shared hash structure sub _Restore_Shared_Hash_Ref { my ( $p_ipc_identifier ) = Static_Params( @_ ); Assert_Defined( $p_ipc_identifier ); my $frozen_hash_ref = _Instantiate_Share( $p_ipc_identifier )->fetch( ) or return { }; return Thaw_Data( $frozen_hash_ref ); } # this method uses the shared created by Instantiate_Share to # transparently retrieve a reference to a shared hash structure, and # additionally exclusively locks the share sub _Restore_Shared_Hash_Ref_With_Lock { my ( $p_ipc_identifier ) = Static_Params( @_ ); Assert_Defined( $p_ipc_identifier ); my $share = _Instantiate_Share( $p_ipc_identifier ); $share->lock( LOCK_EX ); my $frozen_hash_ref = $share->fetch( ) or return { }; return Thaw_Data( $frozen_hash_ref ); } # this method uses the shared created by Instantiate_Share to # transparently persist a reference to a shared hash structure sub _Store_Shared_Hash_Ref { my ( $p_ipc_identifier, $p_hash_ref ) = @_; Assert_Defined( $p_ipc_identifier ); Assert_Defined( $p_hash_ref ); _Instantiate_Share( $p_ipc_identifier )->store( Freeze_Data( $p_hash_ref ) ); } # this method uses the shared created by Instantiate_Share to # transparently persist a reference to a shared hash structure and # additionally unlocks the share sub _Store_Shared_Hash_Ref_And_Unlock { my ( $p_ipc_identifier, $p_hash_ref ) = @_; Assert_Defined( $p_ipc_identifier ); Assert_Defined( $p_hash_ref ); my $share = _Instantiate_Share( $p_ipc_identifier ); $share->store( Freeze_Data( $p_hash_ref ) ); $share->unlock( LOCK_UN ); } sub _get_locked_store_ref { return _Restore_Shared_Hash_Ref_With_Lock( $IPC_IDENTIFIER ); } sub _set_locked_store_ref { my ( $self, $p_store_ref ) = @_; _Store_Shared_Hash_Ref_And_Unlock( $IPC_IDENTIFIER, $p_store_ref ); } sub _get_store_ref { return _Restore_Shared_Hash_Ref( $IPC_IDENTIFIER ); } sub _set_store_ref { my ( $self, $p_store_ref ) = @_; _Store_Shared_Hash_Ref( $IPC_IDENTIFIER, $p_store_ref ); } 1; __END__ =pod =head1 NAME Cache::SharedMemoryBackend -- a shared memory based persistence mechanism =head1 DESCRIPTION The SharedMemoryBackend class is used to persist data to shared memory =head1 SYNOPSIS my $backend = new Cache::SharedMemoryBackend( ); See Cache::Backend for the usage synopsis. =head1 METHODS See Cache::Backend for the API documentation. =head1 SEE ALSO Cache::Backend, Cache::FileBackend, Cache::ShareMemoryBackend =head1 AUTHOR Original author: DeWitt Clinton Last author: $Author: dclinton $ Copyright (C) 2001-2003 DeWitt Clinton =cut Cache-Cache-1.08/lib/Cache/SharedMemoryCache.pm000644 000766 000024 00000006631 12406310064 021206 0ustar00rjbsstaff000000 000000 ###################################################################### # $Id: SharedMemoryCache.pm,v 1.24 2004/04/24 15:46:47 dclinton Exp $ # Copyright (C) 2001-2003 DeWitt Clinton All Rights Reserved # # Software distributed under the License is distributed on an "AS # IS" basis, WITHOUT WARRANTY OF ANY KIND, either expressed or # implied. See the License for the specific language governing # rights and limitations under the License. ###################################################################### package Cache::SharedMemoryCache; use strict; use vars qw( @ISA ); use Cache::Cache; use Cache::MemoryCache; use Cache::CacheUtils qw( Assert_Defined Static_Params ); use Cache::SharedMemoryBackend; use Error; @ISA = qw ( Cache::MemoryCache ); sub Clear { foreach my $namespace ( _Namespaces( ) ) { _Get_Backend( )->delete_namespace( $namespace ); } } sub Purge { foreach my $namespace ( _Namespaces( ) ) { _Get_Cache( $namespace )->purge( ); } } sub Size { my $size = 0; foreach my $namespace ( _Namespaces( ) ) { $size += _Get_Cache( $namespace )->size( ); } return $size; } sub _Namespaces { return _Get_Backend( )->get_namespaces( ); } sub _Get_Backend { return new Cache::SharedMemoryBackend( ); } sub _Get_Cache { my ( $p_namespace ) = Static_Params( @_ ); Assert_Defined( $p_namespace ); return new Cache::SharedMemoryCache( { 'namespace' => $p_namespace } ); } sub new { my ( $self ) = _new( @_ ); $self->_complete_initialization( ); return $self; } sub _new { my ( $proto, $p_options_hash_ref ) = @_; my $class = ref( $proto ) || $proto; my $self = $class->SUPER::_new( $p_options_hash_ref ); $self->_set_backend( new Cache::SharedMemoryBackend( ) ); return $self; } 1; =pod =head1 NAME Cache::SharedMemoryCache -- extends the MemoryCache. =head1 DESCRIPTION The SharedMemoryCache extends the MemoryCache class and binds the data store to shared memory so that separate process can use the same cache. The official recommendation is now to use FileCache instead of SharedMemoryCache. The reasons for this include: 1) FileCache provides equal or better performance in all cases that we've been able to test. This is due to all modern OS's ability to buffer and cache file system accesses very well. 2) FileCache has no real limits on cached object size or the number of cached objects, whereas the SharedMemoryCache has limits, and rather low ones at that. 3) FileCache works well on every OS, whereas the SharedMemoryCache works only on systems that support IPC::ShareLite. And IPC::ShareLite is an impressive effort -- but think about how hard it is to get shared memory working properly on *one* system. Now imagine writing a wrapper around shared memory for many operating systems. =head1 SYNOPSIS use Cache::SharedMemoryCache; my %cache_options_= ( 'namespace' => 'MyNamespace', 'default_expires_in' => 600 ); my $shared_memory_cache = new Cache::SharedMemoryCache( \%cache_options ) or croak( "Couldn't instantiate SharedMemoryCache" ); =head1 METHODS See Cache::Cache for the API documentation. =head1 OPTIONS See Cache::Cache for the standard options. =head1 PROPERTIES See Cache::Cache for the default properties. =head1 SEE ALSO Cache::Cache, Cache::MemoryCache =head1 AUTHOR Original author: DeWitt Clinton Last author: $Author: dclinton $ Copyright (C) 2001-2003 DeWitt Clinton =cut Cache-Cache-1.08/lib/Cache/SizeAwareCache.pm000644 000766 000024 00000006056 12460217241 020505 0ustar00rjbsstaff000000 000000 ###################################################################### # $Id: SizeAwareCache.pm,v 1.10 2002/04/07 17:04:46 dclinton Exp $ # Copyright (C) 2001-2003 DeWitt Clinton All Rights Reserved # # Software distributed under the License is distributed on an "AS # IS" basis, WITHOUT WARRANTY OF ANY KIND, either expressed or # implied. See the License for the specific language governing # rights and limitations under the License. ###################################################################### package Cache::SizeAwareCache; use strict; use Cache::Cache; use vars qw( @ISA @EXPORT_OK $EXPIRES_NOW $EXPIRES_NEVER $NO_MAX_SIZE ); use Exporter; @ISA = qw( Cache::Cache Exporter ); @EXPORT_OK = qw( $EXPIRES_NOW $EXPIRES_NEVER $NO_MAX_SIZE ); $EXPIRES_NOW = $Cache::Cache::EXPIRES_NOW; $EXPIRES_NEVER = $Cache::Cache::EXPIRES_NEVER; $NO_MAX_SIZE = -1; sub limit_size; sub get_max_size; sub set_max_size; 1; __END__ =pod =head1 NAME Cache::SizeAwareCache -- extends the Cache interface. =head1 DESCRIPTION The SizeAwareCache interface is implemented by classes that support all of the Cache::Cache interface in addition to the limit_size and max_size features of a size aware cache. The default cache size limiting algorithm works by removing cache objects in the following order until the desired limit is reached: 1) objects that have expired 2) objects that are least recently accessed 3) objects that expire next =head1 SYNOPSIS use Cache::SizeAwareCache; use vars qw( @ISA ); @ISA = qw( Cache::SizeAwareCache ); =head1 CONSTANTS Please see Cache::Cache for standard constants =over =item I<$NO_MAX_SIZE> The cache has no size restrictions =back =head1 METHODS Please see Cache::Cache for the standard methods =over =item B Attempt to resize the cache such that the total disk usage is under the I<$new_size> parameter. I<$new_size> represents t size (in bytes) that the cache should be limited to. Note that this is only a one time adjustment. To maintain the cache size, consider using the I option, although it is considered very expensive, and can often be better achieved by periodically calling I. =back =head1 OPTIONS Please see Cache::Cache for the standard options =over =item I Sets the max_size property (size in bytes), which is described in detail below. Defaults to I<$NO_MAX_SIZE>. =back =head1 PROPERTIES Please see Cache::Cache for standard properties =over =item B<(get|set)_max_size> If this property is set, then the cache will try not to exceed the max size value (in bytes) specified. NOTE: This causes the size of the cache to be checked on every set, and can be considered *very* expensive in some implementations. A good alternative approach is leave max_size as $NO_MAX_SIZE and to periodically limit the size of the cache by calling the limit_size( $size ) method. =back =head1 SEE ALSO Cache::Cache =head1 AUTHOR Original author: DeWitt Clinton Last author: $Author: dclinton $ Copyright (C) 2001-2003 DeWitt Clinton =cut Cache-Cache-1.08/lib/Cache/SizeAwareCacheTester.pm000644 000766 000024 00000013241 12460205570 021670 0ustar00rjbsstaff000000 000000 ###################################################################### # $Id: SizeAwareCacheTester.pm,v 1.11 2002/04/07 17:04:46 dclinton Exp $ # Copyright (C) 2001-2003 DeWitt Clinton All Rights Reserved # # Software distributed under the License is distributed on an "AS # IS" basis, WITHOUT WARRANTY OF ANY KIND, either expressed or # implied. See the License for the specific language governing # rights and limitations under the License. ###################################################################### package Cache::SizeAwareCacheTester; use strict; use Cache::BaseCacheTester; use Cache::Cache; use vars qw( @ISA ); @ISA = qw ( Cache::BaseCacheTester ); sub test { my ( $self, $cache ) = @_; $self->_test_one( $cache ); $self->_test_two( $cache ); $self->_test_three( $cache ); } # Test the limit_size( ) method, which should automatically purge the # first object added (with the closer expiration time) sub _test_one { my ( $self, $cache ) = @_; $cache or croak( "cache required" ); $cache->clear( ); my $empty_size = $cache->size( ); ( $empty_size == 0 ) ? $self->ok( ) : $self->not_ok( '$empty_size == 0' ); my $first_key = 'Key 1'; my $first_expires_in = '10'; my $value = $self; $cache->set( $first_key, $value, $first_expires_in ); my $first_size = $cache->size( ); ( $first_size > $empty_size ) ? $self->ok( ) : $self->not_ok( '$first_size > $empty_size' ); my $size_limit = $first_size; my $second_key = 'Key 2'; my $second_expires_in = $first_expires_in * 2; $cache->set( $second_key, $value, $second_expires_in ); my $second_size = $cache->size( ); ( $second_size > $first_size ) ? $self->ok( ) : $self->not_ok( '$second_size > $first_size' ); $cache->limit_size( $size_limit ); my $first_value = $cache->get( $first_key ); ( not defined $first_value ) ? $self->ok( ) : $self->not_ok( 'not defined $first_value' ); my $third_size = $cache->size( ); ( $third_size <= $size_limit ) ? $self->ok( ) : $self->not_ok( '$third_size <= $size_limit' ); } # Test the limit_size method when a number of objects can expire # simultaneously sub _test_two { my ( $self, $cache ) = @_; $cache or croak( "cache required" ); $cache->clear( ); my $empty_size = $cache->size( ); ( $empty_size == 0 ) ? $self->ok( ) : $self->not_ok( '$empty_size == 0' ); my $value = "A very short string"; my $first_key = 'Key 0'; my $first_expires_in = 20; my $start = time; $cache->set( $first_key, $value, $first_expires_in ); my $first_size = $cache->size( ); ( $first_size > $empty_size ) ? $self->ok( ) : $self->not_ok( '$first_size > $empty_size' ); my $second_expires_in = $first_expires_in / 2; my $num_keys = 5; for ( my $i = 1; $i <= $num_keys; $i++ ) { my $key = 'Key ' . $i; sleep ( 1 ); $cache->set( $key, $value, $second_expires_in ); } my $second_inserted = time; my $second_size = $cache->size( ); if (time - $start < $first_expires_in ) { ( $second_size > $first_size ) ? $self->ok( ) : $self->not_ok( '$second_size > $first_size' ); } else { $self->skip( '$second_size > $first_size (not finished in ' . $first_expires_in . ' s)'); } my $size_limit = $first_size; $cache->limit_size( $size_limit ); my $third_size = $cache->size( ); ( $third_size <= $size_limit ) ? $self->ok( ) : $self->not_ok( '$third_size <= $size_limit' ); my $first_value = $cache->get( $first_key ); if (time - $start >= $first_expires_in) { $self->skip( '$first_value eq $value (not finished in ' . $first_expires_in . ' s)'); } elsif ($second_inserted + $second_expires_in >= $start + $first_expires_in) { $self->skip( '$first_value eq $value (second key insterted to late, ' . 'so first key had expiration time before the second one, ' . 'thus the first key was removed when limit cache size'); } else { ( $first_value eq $value ) ? $self->ok( ) : $self->not_ok( '$first_value eq $value' ); } } # Test the max_size( ) method, which should keep the cache under # the given size sub _test_three { my ( $self, $cache ) = @_; $cache or croak( "cache required" ); $cache->clear( ); my $empty_size = $cache->size( ); ( $empty_size == 0 ) ? $self->ok( ) : $self->not_ok( '$empty_size == 0' ); my $first_key = 'Key 1'; my $value = $self; $cache->set( $first_key, $value ); my $first_size = $cache->size( ); ( $first_size > $empty_size ) ? $self->ok( ) : $self->not_ok( '$first_size > $empty_size' ); my $max_size = $first_size; $cache->set_max_size( $max_size ); my $second_key = 'Key 2'; $cache->set( $second_key, $value ); my $second_size = $cache->size( ); ( $second_size <= $max_size ) ? $self->ok( ) : $self->not_ok( '$second_size <= $max_size' ); } 1; __END__ =pod =head1 NAME Cache::SizeAwareCacheTester -- a class for regression testing size aware caches =head1 DESCRIPTION The SizeCacheTester is used to verify that a cache implementation honors its contract with respect to resizing capabilities =head1 SYNOPSIS use Cache::SizeAwareMemoryCache; use Cache::SizeAwareCacheTester; my $cache = new Cache::SizeAwareMemoryCache( ); my $cache_tester = new Cache::SizeAwareCacheTester( 1 ); $cache_tester->test( $cache ); =head1 METHODS =over =item B Construct a new SizeAwareCacheTester object, with the counter starting at I<$initial_count>. =item B Run the tests. =back =head1 SEE ALSO Cache::Cache, Cache::BaseCacheTester, Cache::CacheTester =head1 AUTHOR Original author: DeWitt Clinton Last author: $Author: dclinton $ Copyright (C) 2001-2003 DeWitt Clinton =cut Cache-Cache-1.08/lib/Cache/SizeAwareFileCache.pm000644 000766 000024 00000007265 12460217253 021313 0ustar00rjbsstaff000000 000000 ###################################################################### # $Id: SizeAwareFileCache.pm,v 1.28 2002/04/07 17:04:46 dclinton Exp $ # Copyright (C) 2001-2003 DeWitt Clinton All Rights Reserved # # Software distributed under the License is distributed on an "AS # IS" basis, WITHOUT WARRANTY OF ANY KIND, either expressed or # implied. See the License for the specific language governing # rights and limitations under the License. ###################################################################### package Cache::SizeAwareFileCache; use strict; use vars qw( @ISA ); use Cache::CacheSizer; use Cache::CacheUtils qw( Static_Params ); use Cache::FileCache; use Cache::SizeAwareCache qw( $NO_MAX_SIZE ); @ISA = qw ( Cache::FileCache Cache::SizeAwareCache ); my $DEFAULT_MAX_SIZE = $NO_MAX_SIZE; sub Clear { my ( $p_optional_cache_root ) = Static_Params( @_ ); Cache::FileCache::Clear( $p_optional_cache_root ); } sub Purge { my ( $p_optional_cache_root ) = Static_Params( @_ ); Cache::FileCache::Purge( $p_optional_cache_root ); } sub Size { my ( $p_optional_cache_root ) = Static_Params( @_ ); return Cache::FileCache::Size( $p_optional_cache_root ); } sub new { my ( $self ) = _new( @_ ); $self->_complete_initialization( ); return $self; } sub get { my ( $self, $p_key ) = @_; $self->_get_cache_sizer( )->update_access_time( $p_key ); return $self->SUPER::get( $p_key ); } sub limit_size { my ( $self, $p_new_size ) = @_; $self->_get_cache_sizer( )->limit_size( $p_new_size ); } sub set { my ( $self, $p_key, $p_data, $p_expires_in ) = @_; $self->SUPER::set( $p_key, $p_data, $p_expires_in ); $self->_get_cache_sizer( )->limit_size( $self->get_max_size( ) ); } sub _new { my ( $proto, $p_options_hash_ref ) = @_; my $class = ref( $proto ) || $proto; my $self = $class->SUPER::_new( $p_options_hash_ref ); $self->_initialize_cache_sizer( ); return $self; } sub _initialize_cache_sizer { my ( $self ) = @_; my $max_size = $self->_read_option( 'max_size', $DEFAULT_MAX_SIZE ); $self->_set_cache_sizer( new Cache::CacheSizer( $self, $max_size ) ); } sub get_max_size { my ( $self ) = @_; return $self->_get_cache_sizer( )->get_max_size( ); } sub set_max_size { my ( $self, $p_max_size ) = @_; $self->_get_cache_sizer( )->set_max_size( $p_max_size ); } sub _get_cache_sizer { my ( $self ) = @_; return $self->{_Cache_Sizer}; } sub _set_cache_sizer { my ( $self, $p_cache_sizer ) = @_; $self->{_Cache_Sizer} = $p_cache_sizer; } 1; __END__ =pod =head1 NAME Cache::SizeAwareFileCache -- extends Cache::FileCache =head1 DESCRIPTION The SizeAwareFileCache class adds the ability to dynamically limit the size (in bytes) of a file system based cache. This class also implements the SizeAwareCache interface, providing the 'max_size' option and the 'limit_size( $size )' method. =head1 SYNOPSIS use Cache::SizeAwareFileCache; my $cache = new Cache::SizeAwareFileCache( { 'namespace' => 'MyNamespace', 'default_expires_in' => 600, 'max_size' => 10000 } ); =head1 METHODS See Cache::Cache and Cache::SizeAwareCache for the API documentation. =head1 OPTIONS See Cache::Cache and Cache::SizeAwareCache for the standard options. =head1 PROPERTIES See Cache::Cache and Cache::SizeAwareCache for the default properties. =head1 SEE ALSO Cache::Cache, Cache::SizeAwareCache, Cache::FileCache =head1 AUTHOR Original author: DeWitt Clinton Also: Portions of this code are a rewrite of David Coppit's excellent extensions to the original File::Cache Last author: $Author: dclinton $ Copyright (C) 2001-2003 DeWitt Clinton =cut Cache-Cache-1.08/lib/Cache/SizeAwareMemoryCache.pm000644 000766 000024 00000006547 12406310064 021700 0ustar00rjbsstaff000000 000000 ###################################################################### # $Id: SizeAwareMemoryCache.pm,v 1.18 2002/04/07 17:04:46 dclinton Exp $ # Copyright (C) 2001-2003 DeWitt Clinton All Rights Reserved # # Software distributed under the License is distributed on an "AS # IS" basis, WITHOUT WARRANTY OF ANY KIND, either expressed or # implied. See the License for the specific language governing # rights and limitations under the License. ###################################################################### package Cache::SizeAwareMemoryCache; use strict; use vars qw( @ISA ); use Cache::Cache; use Cache::CacheSizer; use Cache::MemoryCache; use Cache::SizeAwareCache qw( $NO_MAX_SIZE ); @ISA = qw ( Cache::MemoryCache Cache::SizeAwareCache ); my $DEFAULT_MAX_SIZE = $NO_MAX_SIZE; sub Clear { return Cache::MemoryCache::Clear( ); } sub Purge { return Cache::MemoryCache::Purge( ); } sub Size { return Cache::MemoryCache::Size( ); } sub new { my ( $self ) = _new( @_ ); $self->_complete_initialization( ); return $self; } sub get { my ( $self, $p_key ) = @_; $self->_get_cache_sizer( )->update_access_time( $p_key ); return $self->SUPER::get( $p_key ); } sub limit_size { my ( $self, $p_new_size ) = @_; $self->_get_cache_sizer( )->limit_size( $p_new_size ); } sub set { my ( $self, $p_key, $p_data, $p_expires_in ) = @_; $self->SUPER::set( $p_key, $p_data, $p_expires_in ); $self->_get_cache_sizer( )->limit_size( $self->get_max_size( ) ); } sub _new { my ( $proto, $p_options_hash_ref ) = @_; my $class = ref( $proto ) || $proto; my $self = $class->SUPER::_new( $p_options_hash_ref ); $self->_initialize_cache_sizer( ); return $self; } sub _initialize_cache_sizer { my ( $self ) = @_; my $max_size = $self->_read_option( 'max_size', $DEFAULT_MAX_SIZE ); $self->_set_cache_sizer( new Cache::CacheSizer( $self, $max_size ) ); } sub get_max_size { my ( $self ) = @_; return $self->_get_cache_sizer( )->get_max_size( ); } sub set_max_size { my ( $self, $p_max_size ) = @_; $self->_get_cache_sizer( )->set_max_size( $p_max_size ); } sub _get_cache_sizer { my ( $self ) = @_; return $self->{_Cache_Sizer}; } sub _set_cache_sizer { my ( $self, $p_cache_sizer ) = @_; $self->{_Cache_Sizer} = $p_cache_sizer; } 1; __END__ =pod =head1 NAME Cache::SizeAwareMemoryCache -- extends Cache::MemoryCache =head1 DESCRIPTION The SizeAwareMemoryCache class adds the ability to dynamically limit the size (in bytes) of a memory based cache. This class also implements the SizeAwareCache interface, providing the 'max_size' option and the 'limit_size( $size )' method. =head1 SYNOPSIS use Cache::SizeAwareMemoryCache; my $cache = new Cache::SizeAwareMemoryCache( { 'namespace' => 'MyNamespace', 'default_expires_in' => 600, 'max_size' => 10000 } ); =head1 METHODS See Cache::Cache and Cache::SizeAwareCache for the API documentation. =head1 OPTIONS See Cache::Cache and Cache::SizeAwareCache for the standard options. =head1 PROPERTIES See Cache::Cache and Cache::SizeAwareCache for the default properties. =head1 SEE ALSO Cache::Cache, Cache::SizeAwareCache, Cache::MemoryCache =head1 AUTHOR Original author: DeWitt Clinton Last author: $Author: dclinton $ Copyright (C) 2001-2003 DeWitt Clinton =cut Cache-Cache-1.08/lib/Cache/SizeAwareSharedMemoryCache.pm000644 000766 000024 00000005060 12406310064 023014 0ustar00rjbsstaff000000 000000 ###################################################################### # $Id: SizeAwareSharedMemoryCache.pm,v 1.22 2002/04/07 17:04:46 dclinton Exp $ # Copyright (C) 2001-2003 DeWitt Clinton All Rights Reserved # # Software distributed under the License is distributed on an "AS # IS" basis, WITHOUT WARRANTY OF ANY KIND, either expressed or # implied. See the License for the specific language governing # rights and limitations under the License. ###################################################################### package Cache::SizeAwareSharedMemoryCache; use strict; use vars qw( @ISA @EXPORT_OK $NO_MAX_SIZE ); use Cache::Cache qw( $EXPIRES_NEVER ); use Cache::SharedMemoryBackend; use Cache::SizeAwareMemoryCache; use Cache::SharedMemoryCache; use Exporter; @ISA = qw ( Cache::SizeAwareMemoryCache Exporter ); @EXPORT_OK = qw( $NO_MAX_SIZE ); $NO_MAX_SIZE = $Cache::SizeAwareMemoryCache::NO_MAX_SIZE; sub Clear { return Cache::SharedMemoryCache::Clear( ); } sub Purge { return Cache::SharedMemoryCache::Purge( ); } sub Size { return Cache::SharedMemoryCache::Size( ); } sub new { my ( $self ) = _new( @_ ); $self->_complete_initialization( ); return $self; } sub _new { my ( $proto, $p_options_hash_ref ) = @_; my $class = ref( $proto ) || $proto; my $self = $class->SUPER::_new( $p_options_hash_ref ); $self->_set_backend( new Cache::SharedMemoryBackend( ) ); return $self; } 1; __END__ =pod =head1 NAME Cache::SizeAwareSharedMemoryCache -- extends Cache::SizeAwareMemoryCache =head1 DESCRIPTION The SizeAwareSharedMemoryCache class adds the ability to dynamically limit the size (in bytes) of a shared memory based cache. This class also implements the SizeAwareCache interface, providing the 'max_size' option and the 'limit_size( $size )' method. =head1 SYNOPSIS use Cache::SizeAwareSharedMemoryCache; my $cache = new Cache::SizeAwareSharedMemoryCache( { 'namespace' => 'MyNamespace', 'default_expires_in' => 600, 'max_size' => 10000 } ); =head1 METHODS See Cache::Cache and Cache::SizeAwareCache for the API documentation. =head1 OPTIONS See Cache::Cache and Cache::SizeAwareCache for the standard options. =head1 PROPERTIES See Cache::Cache and Cache::SizeAwareCache for the default properties. =head1 SEE ALSO Cache::Cache, Cache::SizeAwareCache, Cache::SharedMemoryCache =head1 AUTHOR Original author: DeWitt Clinton Last author: $Author: dclinton $ Copyright (C) 2001-2003 DeWitt Clinton =cut