File-Cache-0.16/0040700000076400007640000000000007267334160012714 5ustar dewittdewittFile-Cache-0.16/DISCLAIMER0100644000076400007640000000232407076126364014266 0ustar dewittdewitt 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. File-Cache-0.16/CREDITS0100644000076400007640000000412107267333673013751 0ustar dewittdewitt- 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@fastmail.fm) added two great patches that made File::Cache taint safe, plus he's using it at fastmail.fm! - Randal L. Schwartz (merlyn@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@blakeley.com) caught the bug with .description files not being readable when the umask is restrictive and offered a patch. He also offered a patch to allow $sEXPIRES_NEVER to be passed as the $expires_in parameter to set. (Thanks Mike!) - Neil Conway (nconway@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!) - Jost Krieger and both pointed out that the tests would fail on machines with the perl binary not in "/usr/bin/perl". File-Cache-0.16/README0100644000076400007640000000337107267116726013615 0ustar dewittdewittCopyright (C) 2000, 2001 DeWitt Clinton , eZiba.com, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 1, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. NAME File::Cache DESCRIPTION File::Cache implements an object store where data is persisted across processes in the filesystem. It was written to compliment IPC::Cache. Where IPC::Cache is faster for small numbers of simple objects, File::Cache tends toward being more performant when caching large numbers of complex objects. REQUIREMENTS Storable (optional, if you have Data::Dumper) Digest::MD5. INSTALLATION perl Makefile.PL make make test make install USAGE see perldoc File::Cache SEE ALSO IPC::Cache NOTES AND CAVEATS Use of File::Cache is now discouraged in favor of the new Cache::Cache project, also available on CPAN. Cache::Cache offers all of the functionality of File::Cache, as well as integrating the functionality of IPC::Cache and a number of new features. You can view the Cache::Cache project page at: http://sourceforge.net/projects/perl-cache/ Version 0.13 breaks old caches. You will want to remove them when upgrading. File-Cache-0.16/COPYING0100644000076400007640000003030707076126364013764 0ustar dewittdewitt GNU GENERAL PUBLIC LICENSE Version 1, February 1989 Copyright (C) 1989 Free Software Foundation, Inc. 675 Mass Ave, Cambridge, MA 02139, USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The license agreements of most software companies try to keep users at the mercy of those companies. By contrast, our General Public License is intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. The General Public License applies to the Free Software Foundation's software and to any other program whose authors commit to using it. You can use it for your programs, too. When we speak of free software, we are referring to freedom, not price. Specifically, the General Public License is designed to make sure that you have the freedom to give away or sell copies of free software, that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs; and that you know you can do these things. To protect your rights, we need to make restrictions that forbid anyone to deny you these rights or to ask you to surrender the rights. These restrictions translate to certain responsibilities for you if you distribute copies of the software, or if you modify it. For example, if you distribute copies of a such a program, whether gratis or for a fee, you must give the recipients all the rights that you have. You must make sure that they, too, receive or can get the source code. And you must tell them their rights. We protect your rights with two steps: (1) copyright the software, and (2) offer you this license which gives you legal permission to copy, distribute and/or modify the software. Also, for each author's protection and ours, we want to make certain that everyone understands that there is no warranty for this free software. If the software is modified by someone else and passed on, we want its recipients to know that what they have is not the original, so that any problems introduced by others will not reflect on the original authors' reputations. The precise terms and conditions for copying, distribution and modification follow. GNU GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License Agreement applies to any program or other work which contains a notice placed by the copyright holder saying it may be distributed under the terms of this General Public License. The "Program", below, refers to any such program or work, and a "work based on the Program" means either the Program or any work containing the Program or a portion of it, either verbatim or with modifications. Each licensee is addressed as "you". 1. You may copy and distribute verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this General Public License and to the absence of any warranty; and give any other recipients of the Program a copy of this General Public License along with the Program. You may charge a fee for the physical act of transferring a copy. 2. You may modify your copy or copies of the Program or any portion of it, and copy and distribute such modifications under the terms of Paragraph 1 above, provided that you also do the following: a) cause the modified files to carry prominent notices stating that you changed the files and the date of any change; and b) cause the whole of any work that you distribute or publish, that in whole or in part contains the Program or any part thereof, either with or without modifications, to be licensed at no charge to all third parties under the terms of this General Public License (except that you may choose to grant warranty protection to some or all third parties, at your option). c) If the modified program normally reads commands interactively when run, you must cause it, when started running for such interactive use in the simplest and most usual way, to print or display an announcement including an appropriate copyright notice and a notice that there is no warranty (or else, saying that you provide a warranty) and that users may redistribute the program under these conditions, and telling the user how to view a copy of this General Public License. d) You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. Mere aggregation of another independent work with the Program (or its derivative) on a volume of a storage or distribution medium does not bring the other work under the scope of these terms. 3. You may copy and distribute the Program (or a portion or derivative of it, under Paragraph 2) in object code or executable form under the terms of Paragraphs 1 and 2 above provided that you also do one of the following: a) accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Paragraphs 1 and 2 above; or, b) accompany it with a written offer, valid for at least three years, to give any third party free (except for a nominal charge for the cost of distribution) a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Paragraphs 1 and 2 above; or, c) accompany it with the information you received as to where the corresponding source code may be obtained. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form alone.) Source code for a work means the preferred form of the work for making modifications to it. For an executable file, complete source code means all the source code for all modules it contains; but, as a special exception, it need not include source code for modules which are standard libraries that accompany the operating system on which the executable file runs, or for standard header files or definitions files that accompany that operating system. 4. You may not copy, modify, sublicense, distribute or transfer the Program except as expressly provided under this General Public License. Any attempt otherwise to copy, modify, sublicense, distribute or transfer the Program is void, and will automatically terminate your rights to use the Program under this License. However, parties who have received copies, or rights to use copies, from you under this General Public License will not have their licenses terminated so long as such parties remain in full compliance. 5. By copying, distributing or modifying the Program (or any work based on the Program) you indicate your acceptance of this license to do so, and all its terms and conditions. 6. Each time you redistribute the Program (or any work based on the Program), the recipient automatically receives a license from the original licensor to copy, distribute or modify the Program subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. 7. The Free Software Foundation may publish revised and/or new versions of the General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Program specifies a version number of the license which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of the license, you may choose any version ever published by the Free Software Foundation. 8. If you wish to incorporate parts of the Program into other free programs whose distribution conditions are different, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 9. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "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 PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 10. 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 PROGRAM 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 PROGRAM (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 PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS Appendix: How to Apply These Terms to Your New Programs If you develop a new program, and you want it to be of the greatest possible use to humanity, the best way to achieve this is to make it free software which everyone can redistribute and change under these terms. To do so, attach the following notices to the program. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) 19yy This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 1, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. Also add information on how to contact you by electronic and paper mail. If the program is interactive, make it output a short notice like this when it starts in an interactive mode: Gnomovision version 69, Copyright (C) 19xx name of author Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. This is free software, and you are welcome to redistribute it under certain conditions; type `show c' for details. The hypothetical commands `show w' and `show c' should show the appropriate parts of the General Public License. Of course, the commands you use may be called something other than `show w' and `show c'; they could even be mouse-clicks or menu items--whatever suits your program. You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the program, if necessary. Here a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the program `Gnomovision' (a program to direct compilers to make passes at assemblers) written by James Hacker. , 1 April 1989 Ty Coon, President of Vice That's all there is to it! File-Cache-0.16/MANIFEST0100644000076400007640000000012607267334041014051 0ustar dewittdewittCHANGES COPYING CREDITS Cache.pm DISCLAIMER MANIFEST Makefile.PL README test.pl TODO File-Cache-0.16/CHANGES0100644000076400007640000002110507267334130013712 0ustar dewittdewittRevision history for File::Cache 0.16 2001-04-18-11-52 - prepared version 0.16 for release - replaced the explicit system( ) call to invoke the subprocess get test with a fork( ) instead - changed email address to dewitt@unto.net - started version 0.16 0.15 2001-04-17-15-07 - prepared version 0.15 for release - added a note about the release of Cache::Cache - Updated documentation to indicate that $File::Cache::sNO_MAX_SIZE is the default cache size. (David Coppit ) - added a patch by Michael Blakely to allow for $sEXPIRES_NEVER to be used as the $expires_in parameter on a set - started version 0.15 0.14 2000-11-27-09-45 - prepared version 0.14 for release - documented the optional usage of Storable in the README - added requirement for File::Spec 0.82 - removed "use Data::Dumper" - the .description file now uses a global friendly umask - started version 0.14 0.13 2000-10-07-19-22 - binmode is now used to avoid problems with setting/getting binary data from the cache (This change probably means that the segfault above is no longer a problem. However, it's still a good idea to use a canonical format in case processes on different platforms are accessing the same cache over NFS.) - Removed unreferenced subroutine _purge_all - Minor formatting changes - Internal subroutines get_user_path() and get_namespace_path(), are now prefixed by an underscore - Names of non-method subroutines are now all consistently uppercase - File::Cache::REDUCE_SIZE was coded as a method, but documented as an object-independent function. Fixed it, and made _choose_victim_file an object-independent function - Added POD documentation for get_namespace(), set_namespace(), get_max_size(), set_max_size(), get_cache_depth(), and set_cache_depth() - "cache entry" changed to "cache object" for consistency in terminology - Cache size reduction is now done, if necessary, when set_max_size() called - Minor portability improvements - Improved error checking for REDUCE_SIZE - Added parameter checking to subroutines - Removed $sGET_STALE_ONLY and $sGET_FRESH_ONLY from @EXPORT_OK list (these are internal constants) - Internal subroutines get_username_path() and get_namespace_path() now build the path directly from the cache key, username, and namespace parameters. Internal subroutines set_username_path() and set_namespace_path() removed. - Improved directory verification so that it only happens when the cache key, user, or namespace change. - Modified some functions to return references instead of operating on reference parameters - Added cache metadata support (useful for checking that an existing cache is compatible with the current version of File::Cache) - Added $CACHE_OBJECT_VERSION, which describes the version of cache objects that the current version of File::Cache can work with. - Added support for choosing the persistence mechanism to be either Storable (the traditional and default mechanism) or Data::Dumper. (Data::Dumper is slower, but (1) is a standard Perl module, (2) is written entirely in Perl (no compilation difficulties), and (3) generates human-readable cache entries.) - minor formatting change to better fit 80 columns - changed _UNTAINT_STRING to take a untainted regex - added _UNTAINT_FILE_PATH to call _UNTAINT_STRING with the file path regex - Changed default cache key from $TMPDIR/File::Cache to $TMPDIR/FileCache on DOS/Windows platforms, since the former is illegal. - retroactively split version 0.13 from 0.12 - Corrupted cache objects stored using Data::Dumper are automatically detected and removed from the cache - Cache_Description.pl was changed to .description - .description files now use a proprietary format instead of Data::Dumper - changed test.pl to always quote the call to the subprocess - changed test/test_get.pl to strip quotes if needed - wrote _RECURSIVELY_REMOVE_DIRECTORY to avoid taint failures in File::Path - switched to finddepth() instead of find() in File::Find because finddepth() doesn't use Cwd, which in turn is not taint safe. - removed the unused _UNTAINT_CACHE_DESCRIPTION_CODE() and $sUNTAINTED_CACHE_DESCRIPTION_CODE_REGEX - updated the README to mention the cache upgrade issues - updated the CREDITS file - changed _WRITE_FILE to write to a temp file then rename to avoid corruption race (thanks Randal!) - better documentation for get, get_stale, and set (thanks Randal!) - added two tests for getting and setting blessed objects 0.12 2000-08-25-09-58 (not public) - fixed a typo in CHANGES - added a more generic taint check called _untaint_string, this is called everywhere tainting could occur - use File::Spec::Functions::tmpdir to remove OS dependency for temp directory (Bug ID 104869) - removed last TODO item - cache directories are now only created when needed (David Coppit ) - fixed the second test "21" in test.pl - switched to nfreeze() instead of freeze to avoid segfault (thanks David!) 0.11 2000-06-22-09-23 - updated the CREDITS file - updated Cache.pm for version 0.11 0.10 2000-06-22-09-07 - updated Cache.pm for version 0.10 - added the remove($identifier) method to allow keys to be selectively removed - added a test for remove - changed email address in the docs to - reformatted for 80 column displays - updated the _write_file routine to make it pass taint checking (jhoward@fastmail.fm) - updated the purge() routine to make it pass taint checking (jhoward@fastmail.fm) 0.09 2000-04-28-12-43 - perldoc updates for get and get_stale (Bug ID 104432) - added public constants to EXPORT_OK (Bug ID 104433) - modified test scripts to make use of EXPORT_OK'd vars - updated the TODO list 0.08 2000-04-12-10-31 - added get_creation_time() (David Coppit ) - added get_expiration_time() (David Coppit ) - updated the perldoc (David Coppit ) - updated the test.pl script to include tests for get_creation_time() and get_expiration_time() (David Coppit ) 0.07 2000-04-10-09-45 - added support for the "cache_depth" option that enables subdirectories in the cache to increase performance when caching large numbers of objects - rewrote the _recursive_find_nearest_expiration and _recursive_find_latest_accessed routines to actually work recursively (needed to support cache_depth) - added a routine that avoids a race when removing files from the cache (thanks to Jessica Mintz) 0.06 2000-03-06-11-12 - bug fixed where purge() didn't actually delete the cache file (David Coppit ) - auto_purge, username, max_size, and filemode options added (David Coppit ) - cache_path was renamed user_path - set/get methods added for auto_purge, username, max_size, expires_in and filemode, namespace_path, cache_key, cache_path, and user_path (David Coppit ) - automatic cache size reduction added to set() method, and reduce_size() method created (David Coppit ) - fixed the CHANGES file to reflect the version 0.05 changes - updated the perldoc (David Coppit ) - now using File::Spec for the path generation (thanks for David for the idea) - updated the test.pl and test/test_get.pl scripts to include tests for setting the username, filemode, and max_size 0.05 2000-02-22-16-23 - updated the requirements in the README - provided a default username if getpwuid is not available (MacOS) - fixed a problem where _purge failed on FreeBSD (thanks to Doug Steinwand) 0.04 2000-02-16-14-48 - create a per-user namespace to better deal with file permission problems when more than one user wants to use File::Cache - only create a globally read/write directory for the default root of the cache (i.e., /tmp/File::Cache/) - implemented size and SIZE - added the _verify_directory routine for better encapsulation of that functionality - updated documentation - first submitted to CPAN - modified test.pl to use "/tmp/TMPC" as a namespace - updated the requirements in Makefile.PL 0.03 2000-02-16-02-10 - set the default file and directory creation umask to 0000 as a *really* temporary fix 0.02 2000-02-14-16-52 - set the default file and directory creation umask to 0000 as a temporary fix to the file permission problem 0.01 2000-02-10-09-22 - original version, created by dclinton@eziba.com File-Cache-0.16/test.pl0100644000076400007640000002733407267333446014256 0ustar dewittdewitt#!/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.) Remember that all the tests # except the first are done twice--once with Storable, and once with # Data::Dumper. The $TEST_SET_SIZE is the number of unique tests, not # counting the trivial first test. @PERSISTENCE_MECHANISMS is an array # containing all the supported persistence mechanisms use vars qw($TEST_SET_SIZE @PERSISTENCE_MECHANISMS); BEGIN { $| = 1; $TEST_SET_SIZE = 25; @PERSISTENCE_MECHANISMS = qw(Data::Dumper Storable); # The test set is repeated once for each implementation, plus the # first test my $last_test_to_print = (($TEST_SET_SIZE) * ($#PERSISTENCE_MECHANISMS + 1)) + 1; print "1..$last_test_to_print\n"; } END {print "not ok 1\n" unless $loaded;} use File::Cache qw($sSUCCESS $sFAILURE); $loaded = 1; print "ok 1\n"; ######################### End of black magic. use strict; my $sTEST_CACHE_KEY = "/tmp/TSTC"; my $sTEST_NAMESPACE = "TestCache"; my $sMAX_SIZE = 1000; my $sTEST_USERNAME = "web"; my $sTEST_CACHE_DEPTH = 3; # Run all remaining tests for each implementation my $test_set_number = 0; foreach my $implementation (@PERSISTENCE_MECHANISMS) { $test_set_number++; my $test_set_start = $TEST_SET_SIZE * ($test_set_number - 1) + 2; my $test_set_end = $TEST_SET_SIZE * $test_set_number + 1; # Only do the tests if the persistence mechanism module is present if (eval "require $implementation") { do_tests($implementation, $test_set_start); } else { skip_tests($test_set_start, $test_set_end); } } sub skip_tests { my ($start,$end) = @_; for (my $i = $start; $i <= $end;$i++) { print "ok $i # skip\n"; } } sub do_tests { my ($implementation,$test_number_start) = @_; print "--> Testing $implementation implementation\n"; # Test creation of a cache object my $test = $test_number_start; my $cache1 = new File::Cache( { cache_key => $sTEST_CACHE_KEY, namespace => $sTEST_NAMESPACE, max_size => $sMAX_SIZE, auto_remove_stale => 0, username => $sTEST_USERNAME, filemode => 0770, implementation => $implementation, cache_depth => $sTEST_CACHE_DEPTH } ); if ($cache1) { print "ok $test\n"; } else { print "not ok $test\n"; } # Test the setting of a scalar in the cache $test++; my $seed_value = "Hello World"; my $key = 'key1'; my $status = $cache1->set($key, $seed_value); if ($status == $sSUCCESS) { print "ok $test\n"; } else { print "not ok $test\n"; } # Test the getting of a scalar from the cache $test++; my $val1_retrieved = $cache1->get($key); if ($val1_retrieved eq $seed_value) { print "ok $test\n"; } else { print "not ok $test\n"; } # Test the setting of a blessed object from the cache $test++; my $key2 = 'key2'; $status = $cache1->set($key2, $cache1); if ($status == $sSUCCESS) { print "ok $test\n"; } else { print "not ok $test\n"; } # Test the getting of a blessed object from the cache $test++; my $cache1_retrieved = $cache1->get($key2); $val1_retrieved = $cache1_retrieved->get($key); if ($val1_retrieved eq $seed_value) { print "ok $test\n"; } else { print "not ok $test\n"; } # Test the getting of the scalar from a subprocess $test++; my $pid = fork( ); if ( not defined $pid ) { die( "Error forking\n" ); } elsif ( $pid == 0 ) { test_subprocess_get( $sTEST_CACHE_KEY, $sTEST_NAMESPACE, $sTEST_USERNAME, $sTEST_CACHE_DEPTH, $implementation, $key, $seed_value, $test ); exit( 1 ); } else { sleep( 1 ); } # Test checking the memory consumption of the cache $test++; my $size = File::Cache::SIZE($sTEST_CACHE_KEY); if ($size > 0) { print "ok $test\n"; } else { print "not ok $test\n"; } # Test clearing the cache's namespace $test++; $status = $cache1->clear(); if ($status == $sSUCCESS) { print "ok $test\n"; } else { print "not ok $test\n"; } # Test the max_size limit # Intentionally add more data to the cache than fits in max_size $test++; my $string = 'abcdefghij'; my $start_size = $cache1->size(); $cache1->set('initial_value', $string); my $end_size = $cache1->size(); my $string_size = $end_size - $start_size; my $cache_item = 0; # This should take the cache to nearly the edge while (($cache1->size() + $string_size) < $sMAX_SIZE) { $cache1->set("item:$cache_item", $string); $cache_item++; } # This should put it over the top $cache1->set("item:$cache_item", $string); if ($cache1->size > $sMAX_SIZE) { print "not ok $test\n"; } else { print "ok $test\n"; } # Test the getting of a scalar after the clearing of a cache $test++; my $val2_retrieved = $cache1->get($key); if ($val2_retrieved) { print "not ok $test\n"; } else { print "ok $test\n"; } # Test the setting of a scalar in the cache with a immediate timeout $test++; $status = $cache1->set($key, $seed_value, 0); if ($status == $sSUCCESS) { print "ok $test\n"; } else { print "not ok $test\n"; } # Test the getting of a scalar from the cache that should have timed # out immediately $test++; my $val3_retrieved = $cache1->get($key); if ($val3_retrieved) { print "not ok $test\n"; } else { print "ok $test\n"; } # Test the getting of the expired scalar using get_stale $test++; my $val3_stale_retrieved = $cache1->get_stale($key); if ($val3_stale_retrieved) { print "ok $test\n"; } else { print "not ok $test\n"; } # Test the setting of a scalar in the cache with a timeout in the # near future $test++; $status = $cache1->set($key, $seed_value, 2); if ($status == $sSUCCESS) { print "ok $test\n"; } else { print "not ok $test\n"; } # Test the getting of a scalar from the cache that should not have # timed out yet (unless the system is *really* slow) $test++; my $val4_retrieved = $cache1->get($key); if ($val4_retrieved eq $seed_value) { print "ok $test\n"; } else { print "not ok $test\n"; } # Test the getting of a scalar from the cache that should have timed out $test++; sleep(3); my $val5_retrieved = $cache1->get($key); if ($val5_retrieved) { print "not ok $test\n"; } else { print "ok $test\n"; } # Test purging the cache's namespace $test++; $status = $cache1->purge(); if ($status == $sSUCCESS) { print "ok $test\n"; } else { print "not ok $test\n"; } # Test getting the creation time of the cache entry $test++; my $timed_key = 'timed key'; my $creation_time = time(); my $expires_in = 1000; $cache1->set($timed_key, $seed_value, $expires_in); # Delay a bit sleep(2); # Let's expect no more than 1 second delay between the creation of # the cache entry and our saving of the time. my $cached_creation_time = $cache1->get_creation_time($timed_key); my $creation_time_delta = $creation_time - $cached_creation_time; if ($creation_time_delta <= 1) { $status = 1; } else { $status = 0; } if ($status) { print "ok $test\n"; } else { print "not ok $test\n"; } # Test getting the expiration time of the cache entry $test++; my $expected_expiration_time = $cache1->get_creation_time($timed_key) + $expires_in; my $actual_expiration_time = $cache1->get_expiration_time($timed_key); $status = $expected_expiration_time == $actual_expiration_time; if ($status) { print "ok $test\n"; } else { print "not ok $test\n"; } # Test PURGING of a cache object $test++; $status = File::Cache::PURGE($sTEST_CACHE_KEY); if ($status == $sSUCCESS) { print "ok $test\n"; } else { print "not ok $test\n"; } # Test the removal of a cached file $test++; $status = $sSUCCESS; my $remove_key = "foo"; my $remove_value = "bar"; $cache1->set($remove_key, $remove_value); $cache1->get($remove_key) eq $remove_value or $status = $sFAILURE; $cache1->remove($remove_key) or $status = $sFAILURE; if (defined $cache1->get($remove_key)) { $status = $sFAILURE; } if ($status == $sSUCCESS) { print "ok $test\n"; } else { print "not ok $test\n"; } # Test CLEARING of a cache object $test++; $status = File::Cache::CLEAR($sTEST_CACHE_KEY); if ($status == $sSUCCESS) { print "ok $test\n"; } else { print "not ok $test\n"; } # Test directories not created unless needed $test++; File::Cache::CLEAR($sTEST_CACHE_KEY); if (-e $sTEST_CACHE_KEY) { print "not ok $test\n"; } $cache1 = new File::Cache( { cache_key => $sTEST_CACHE_KEY, implementation => $implementation, namespace => $sTEST_NAMESPACE } ); opendir(DIR, $sTEST_CACHE_KEY) or croak("Couldn't open directory $sTEST_CACHE_KEY: $!"); my @dirents = readdir(DIR); closedir DIR; my @files = grep { $_ !~ /^(\.|\.\.|.description)$/ } @dirents; if (!@files) { print "ok $test\n"; } else { print "not ok $test\n"; } File::Cache::CLEAR($sTEST_CACHE_KEY); # Test the setting of a binary scalar in the cache $test++; $cache1 = new File::Cache( { cache_key => $sTEST_CACHE_KEY, implementation => $implementation, namespace => $sTEST_NAMESPACE } ); # Make a string of all possible ASCII characters $seed_value = ''; for (my $i = 0; $i < 256 ; $i++) { $seed_value .= chr($i); } my $binary_key = 'key1'; $status = $cache1->set($binary_key, $seed_value); if ($status == $sSUCCESS) { print "ok $test\n"; } else { print "not ok $test\n"; } # Test the getting of a binary scalar from the cache $test++; my $val6_retrieved = $cache1->get($binary_key); if ($val6_retrieved eq $seed_value) { print "ok $test\n"; } else { print "not ok $test\n"; } File::Cache::CLEAR($sTEST_CACHE_KEY); } sub test_subprocess_get { my ( $cache_key, $namespace, $username, $cache_depth, $implementation, $key, $expected_value, $test ) = @_; $cache_key or die( 'cache_key required' ); $namespace or die( 'namespace required' ); $username or die( 'username required' ); $cache_depth or die( 'cache_depth required' ); $implementation or die( 'implementation required' ); $key or die( 'key required' ); $expected_value or die( 'expected_value required' ); $test or die( 'test required' ); my $cache = new File::Cache( { cache_key => $cache_key, namespace => $namespace, username => $username, implementation => $implementation, cache_depth => $cache_depth } ) or die("Couldn't create cache"); my $value = $cache->get($key) or die( "Couldn't get object at $key" ); if ( $value eq $expected_value ) { print "ok $test\n"; } else { print "not ok $test\n"; } } 1; File-Cache-0.16/Makefile.PL0100644000076400007640000000055107210471354014671 0ustar dewittdewittuse ExtUtils::MakeMaker; # See lib/ExtUtils/MakeMaker.pm for details of how to influence # the contents of the Makefile that is written. WriteMakefile( NAME => 'File::Cache', VERSION_FROM => 'Cache.pm', dist => {COMPRESS => 'gzip', SUFFIX => '.gz'}, PREREQ_PM => { Storable => '0.607', Digest::MD5 => '2.09', File::Spec => '0.82' } ); File-Cache-0.16/Cache.pm0100644000076400007640000020602407267116711014270 0ustar dewittdewitt#!/usr/bin/perl -w package File::Cache; use strict; use Carp; use Digest::MD5 qw(md5_hex); use File::Path; use File::Find; use File::Spec; use File::Spec::Functions qw(tmpdir splitdir splitpath catdir); use Exporter; use vars qw(@ISA @EXPORT_OK $VERSION $sSUCCESS $sFAILURE $sTRUE $sFALSE $sEXPIRES_NOW $sEXPIRES_NEVER $sNO_MAX_SIZE $sGET_STALE_ONLY $sGET_FRESH_ONLY $CACHE_OBJECT_VERSION); $VERSION = '0.16'; # Describes the caches created by this version of File::Cache. (Should # be incremented any time the cache file format changes in a way that # breaks backward compatibility.) $CACHE_OBJECT_VERSION = '0.01'; @ISA = qw(Exporter); @EXPORT_OK = qw($sSUCCESS $sFAILURE $sTRUE $sFALSE $sEXPIRES_NOW $sEXPIRES_NEVER $sNO_MAX_SIZE ); # ----------------------------------------------------------------------------- # Code notes: # Internal subroutines (helper routines not supposed to be called by # external clients) are preceded with an underscore ("_"). Subroutines # (both internal and external) that are called as functions, as # opposed to methods, are in ALL CAPS. The PURGE and CLEAR routines # are object-independent, which means that any subroutines they call # must also be object-independent. # ----------------------------------------------------------------------------- # Constants $sSUCCESS = 1; $sFAILURE = 0; $sTRUE = 1; $sFALSE = 0; $sEXPIRES_NOW = 0; $sEXPIRES_NEVER = -1; $sNO_MAX_SIZE = -1; $sGET_STALE_ONLY = 1; $sGET_FRESH_ONLY = 0; # The default cache key is used inside the tmp filesystem (as defined # by File::Spec) my $sDEFAULT_CACHE_KEY; $sDEFAULT_CACHE_KEY = ($^O eq 'dos' || $^O eq 'MSWin32') ? 'FileCache' : 'File::Cache'; # if a namespace is not specified, use this as a default my $sDEFAULT_NAMESPACE = "_default"; # by default, remove objects that have expired when then are requested my $sDEFAULT_AUTO_REMOVE_STALE = $sTRUE; # by default, the filemode is world read/writable my $sDEFAULT_FILEMODE = 0777; # by default, there is no max size to the cache my $sDEFAULT_MAX_SIZE = $sNO_MAX_SIZE; # if the OS does not support getpwuid, use this as a default username my $sDEFAULT_USERNAME = 'nobody'; # by default, the objects in the cache never expire my $sDEFAULT_GLOBAL_EXPIRES_IN = $sEXPIRES_NEVER; # default cache depth my $sDEFAULT_CACHE_DEPTH = 0; # File::Cache supports either Storable or Data::Dumper as the # persistence mechanism. The default persistence mechanism uses Storable my $sDEFAULT_PERSISTENCE_MECHANISM = 'Storable'; # cache description filename my $sCACHE_DESCRIPTION_FILENAME = '.description'; # Always use a global friendly umask for the .description files my $sCACHE_DESCRIPTION_UMASK = 022; # valid filepath characters for tainting. Be sure to accept DOS/Windows style # path specifiers (C:\path) also my $sUNTAINTED_FILE_PATH_REGEX = qr{^([-\@\w\\\\~./:]+|[\w]:[-\@\w\\\\~./]+)$}; # ----------------------------------------------------------------------------- # create a new Cache object that can be used to persist # data across processes sub new { my ($proto, $options) = @_; my $class = ref($proto) || $proto; my $self = {}; bless ($self, $class); # remove objects from the cache that have expired on retrieval # when this is set my $auto_remove_stale = defined $options->{auto_remove_stale} ? $options->{auto_remove_stale} : $sDEFAULT_AUTO_REMOVE_STALE; $self->set_auto_remove_stale($auto_remove_stale); # username is either specified or searched for in an OS # independent way my $username = defined $options->{username} ? $options->{username} : _FIND_USERNAME(); $self->set_username($username); # the user can specify the filemode my $filemode = defined $options->{filemode} ? $options->{filemode} : $sDEFAULT_FILEMODE; $self->set_filemode($filemode); # remember the expiration delta to be used for all objects if # specified my $global_expires_in = defined $options->{expires_in} ? $options->{expires_in} : $sDEFAULT_GLOBAL_EXPIRES_IN; $self->set_global_expires_in($global_expires_in); # set the cache key to either the user's value or the default my $cache_key = defined $options->{cache_key} ? $options->{cache_key} : _BUILD_DEFAULT_CACHE_KEY(); $self->set_cache_key($cache_key); # this instance will use the namespace specified or the default my $namespace = defined $options->{namespace} ? $options->{namespace} : $sDEFAULT_NAMESPACE; $self->set_namespace($namespace); # the cache will automatically create subdirectories to this depth my $cache_depth = defined $options->{cache_depth} ? $options->{cache_depth} : $sDEFAULT_CACHE_DEPTH; $self->set_cache_depth($cache_depth); # the max cache size is either specified by the user or by the # default cache size. Be sure to do this after the cache key, # user, and namespace are set up, because it invokes reduce_size. my $max_size = defined $options->{max_size} ? $options->{max_size} : $sDEFAULT_MAX_SIZE; $self->set_max_size($max_size); # verify that we can create the cache when necessary later _VERIFY_DIRECTORY( $self->_get_namespace_path() ) == $sSUCCESS or croak("Can not build cache at " . $self->_get_namespace_path() . ". Check directory permissions."); # set the persistence mechanism to the user specified one (or the # default), then load the necessary modules that correspond to # that persistence mechanism choice my $persistence_mechanism = defined $options->{persistence_mechanism} ? $options->{persistence_mechanism} : $sDEFAULT_PERSISTENCE_MECHANISM; $self->set_persistence_mechanism($persistence_mechanism); $self->_load_persistence_mechanism(); # could update a legacy cache here # check that any existing cache is compatible $self->_check_cache_compatibility(); # write the cache description, in case there isn't already one my $cache_description = $self->_get_cache_description(); _WRITE_CACHE_DESCRIPTION( $cache_key, $cache_description, $filemode ); return $self; } # ----------------------------------------------------------------------------- # Reads the cache description from the file system. Returns a reference to a # hash, or undef if no cache appears to be in location specified by the cache # key, or the cache has problems. A cache description is automatically # generated for older style caches that do not have cache description files. # (The presence of any directories in the cache key directory are taken to # mean that such a legacy cache exists.) sub _READ_CACHE_DESCRIPTION { my ($cache_key) = @_; defined($cache_key) or croak("cache key required"); my $cache_description_path = _BUILD_PATH($cache_key, $sCACHE_DESCRIPTION_FILENAME); # This is the name of the variable stored using Data::Dumper in # the cache description file. my $cache_description = {}; if (-f $cache_description_path) { my $serialized_cache_description_ref = _READ_FILE($cache_description_path); unless (defined $serialized_cache_description_ref and defined $$serialized_cache_description_ref) { warn "Could not read cache description file $cache_description_path"; return undef; } _UNSERIALIZE_HASH($$serialized_cache_description_ref, $cache_description); } elsif (_SUBDIRECTORIES_PRESENT($cache_key) eq $sTRUE) { # Older caches used Storable as the persistence mechanism $cache_description = { 'File::Cache Version' => undef, 'Cache Object Version' => 0.01, 'Persistence Mechanism' => 'Storable', }; } else { return undef; } return $cache_description; } # ----------------------------------------------------------------------------- # Determines if there are subdirectories in a given directory sub _SUBDIRECTORIES_PRESENT { my ($directory) = @_; defined($directory) or croak("directory required"); $directory = _UNTAINT_FILE_PATH($directory); return $sFALSE unless -d $directory; opendir(DIR, $directory) or croak("Couldn't open directory $directory: $!"); my @dirents = readdir(DIR); closedir DIR; foreach my $dirent (@dirents) { return $sTRUE if -d $dirent; } return $sFALSE; } # ----------------------------------------------------------------------------- # Writes a cache description to the file system. Takes a cache key, a # reference to a hash, and a file mode sub _WRITE_CACHE_DESCRIPTION { my ($cache_key, $cache_description, $filemode) = @_; defined($cache_key) or croak("cache_key required"); defined($cache_description) or croak("cache description required"); defined($filemode) or croak("filemode required"); my $cache_description_path = _BUILD_PATH($cache_key, $sCACHE_DESCRIPTION_FILENAME); my $serialized_cache_description = _SERIALIZE_HASH($cache_description); _CREATE_DIRECTORY($cache_key,0); # mike@blakeley.com: specifying the filemode is bad for .description, # since it's global for the whole cache. _WRITE_FILE($cache_description_path, \$serialized_cache_description, $filemode, $sCACHE_DESCRIPTION_UMASK); } sub _SERIALIZE_HASH { my ($hash_ref) = @_; my $serialized_hash; foreach my $key (keys %{$hash_ref}) { $serialized_hash .= "$key => $hash_ref->{$key}\n"; } return $serialized_hash; } sub _UNSERIALIZE_HASH { my ($string, $hash_ref) = @_; my @key_value_pair_list = split(/\n/, $string); foreach my $key_value_pair (@key_value_pair_list) { my ($key, $value) = $key_value_pair =~ m|(.*?) => (.*)|; next unless $key and $value; $hash_ref->{$key} = $value; } } # ----------------------------------------------------------------------------- # Check that any existing cache is compatible. For example, a cache # created using a later version of File::Cache with a new cached # object format is incompatible. sub _check_cache_compatibility { my ($self) = @_; my $existing_cache_description = _READ_CACHE_DESCRIPTION( $self->get_cache_key() ); # Not defined means that there is no existing cache, or there is a problem # with the cache. return unless defined $existing_cache_description; # Compare cache object versions. if ( ($existing_cache_description->{'Cache Object Version'} > $CACHE_OBJECT_VERSION) ) { warn "Incompatible cache object versions detected. " . "The cache will be cleared"; CLEAR( $self->get_cache_key() ); return; } # Check that the persistence mechanisms match. if ( $existing_cache_description->{'Persistence Mechanism'} ne $self->get_persistence_mechanism() ) { warn "Incompatible cache object persistence mechanisms detected. " . "The cache will be cleared"; CLEAR( $self->get_cache_key() ); return; } } # ----------------------------------------------------------------------------- # Gets the cache description for the cache, returning a reference to a # hash. The keys are: # - File::Cache Version: The version of File::Cache used to create the # cache. (May be undef for cache descriptions that are auto-generated # by _READ_CACHE_DESCRIPTION based on a legacy cache.) # - Cache Object Version: The version number of the format used to store # objects in the cache. # - Persistence Mechanism: The persistence mechanism used to store # objects in the cache. sub _get_cache_description { my ($self) = @_; my $cache_description = { 'File::Cache Version' => $VERSION, 'Cache Object Version' => $CACHE_OBJECT_VERSION, 'Persistence Mechanism' => $self->get_persistence_mechanism(), }; return $cache_description; } # ----------------------------------------------------------------------------- # store an object in the cache associated with the identifier sub set { my ($self, $identifier, $object, $expires_in) = @_; defined($identifier) or croak("identifier required"); my $unique_key = _BUILD_UNIQUE_KEY($identifier); # expiration time is based on a delta from the current time if # expires_in is defined, the object will expire in that number of # seconds from now else if expires_in is undefined, it will expire # based on the global_expires_in my $global_expires_in = $self->get_global_expires_in(); my $expires_at; my $created_at = time(); if (defined $expires_in) { $expires_at = ($expires_in eq $sEXPIRES_NEVER) ? $expires_in : ($created_at + $expires_in); } elsif ($global_expires_in ne $sEXPIRES_NEVER) { $expires_at = $created_at + $global_expires_in; } else { $expires_at = $sEXPIRES_NEVER; } # add the new object to the cache in this instance's namespace my %object_data = ( object => $object, expires_at => $expires_at, created_at => $created_at ); my $frozen_object_data = _SERIALIZE( \%object_data, $self->get_persistence_mechanism() ); # Figure out what the new size of the cache should be in order to # accomodate the new data and still be below the max_size. Then # reduce the size. my $max_size = $self->get_max_size(); if ($max_size != $sNO_MAX_SIZE) { my $new_size = $max_size - length $frozen_object_data; $new_size = 0 if $new_size < 0; $self->reduce_size($new_size); } my $filemode = $self->get_filemode(); my $cached_file_path = $self->_build_cached_file_path($unique_key); _WRITE_FILE($cached_file_path, \$frozen_object_data, $filemode); return $sSUCCESS; } # ----------------------------------------------------------------------------- # loads the module for serializing data sub _load_persistence_mechanism { my ($self) = @_; if ($self->get_persistence_mechanism() eq 'Storable') { require Storable; Storable->import( qw(nfreeze thaw dclone)); } # Should be already loaded. No harm done in doing it again elsif ($self->get_persistence_mechanism() eq 'Data::Dumper') { require Data::Dumper; Data::Dumper->import(); } # An invalid persistence mechanism choice by the user has already been # checked. If we see an invalid choice here it must be a bug in # the module. (die in this case instead of croaking) else { croak("Argument must be either \"Storable\" or \"Data::Dumper\""); } } # ------------------------------------------------------------------------------ # turns a hash reference into a serialized string using a method which # depends on the persistence mechanism choice sub _SERIALIZE { my ($data_reference, $persistence_mechanism) = @_; defined($data_reference) or croak("object reference required"); defined($persistence_mechanism) or croak("persistence mechanism required"); if ($persistence_mechanism eq 'Storable') { return nfreeze($data_reference); } else { return Data::Dumper->Dump([$data_reference], ['cache_object']); } } # ------------------------------------------------------------------------------ # turns a reference to a serialized string into a reference to data using # a method which depends on the persistence mechanism choice. Deletes the # cache key if the unserialization fails. sub _UNSERIALIZE { my ($data_reference, $persistence_mechanism, $cache_key) = @_; defined($data_reference) or croak("object reference required"); defined($persistence_mechanism) or croak("persistence mechanism required"); if ($persistence_mechanism eq 'Storable') { return thaw($$data_reference); } else { # This is what the serialize routine calls the cached object my $cache_object; my $errors; { local $SIG{__WARN__} = sub { $errors .= $_[0] }; eval $$data_reference; } if ($errors || $@) { warn "Cache object is corrupted and will be deleted"; unlink $cache_key; return undef; } return $cache_object; } } # ------------------------------------------------------------------------------ # return a copy of a serialized string (reference or non-reference) # using a method which depends on the persistence mechanism choice sub _CLONE { my ($data_reference, $persistence_mechanism) = @_; defined($data_reference) or croak("object reference required"); defined($persistence_mechanism) or croak("persistence mechanism required"); my $cloned_data; if ($persistence_mechanism eq 'Storable') { $cloned_data = (ref $data_reference) ? dclone($data_reference) : $data_reference; } else { if (ref $data_reference) { my $data = $$data_reference; $cloned_data = \$data; } else { $cloned_data = $data_reference; } } return $cloned_data; } # ------------------------------------------------------------------------------ # retrieve an object from the cache associated with the identifier, # and remove it from the cache if its expiration has elapsed and # auto_remove_stale is 1. sub get { my ($self, $identifier) = @_; defined($identifier) or croak("identifier required"); my $object = $self->_get($identifier, $sGET_FRESH_ONLY); return $object; } # ------------------------------------------------------------------------------ # retrieve an object from the cache associated with the identifier, # but only if it's stale sub get_stale { my ($self, $identifier) = @_; defined($identifier) or croak("identifier required"); my $object = $self->_get($identifier, $sGET_STALE_ONLY); return $object; } # ------------------------------------------------------------------------------ # Gets the stale or non-stale data from the cache, depending on the # second parameter ($sGET_STALE_ONLY or $sGET_FRESH_ONLY) sub _get { my ($self, $identifier, $freshness) = @_; defined($identifier) or croak("identifier required"); defined($freshness) or croak("freshness required"); my $unique_key = _BUILD_UNIQUE_KEY($identifier); my $cached_file_path = $self->_get_cached_file_path($unique_key); # check the cache for the specified object my $cloned_object = undef; my $object_data; $object_data = _READ_OBJECT_DATA($cached_file_path); if ($object_data) { my $object = $object_data->{object}; my $expires_at = $object_data->{expires_at}; # If we want non-stale data... if ($freshness eq $sGET_FRESH_ONLY) { # Check if the cache item has expired if (_S_SHOULD_EXPIRE($expires_at)) { # Remove the item from the cache if auto_remove_stale # is $sTRUE my $auto_remove_stale = $self->get_auto_remove_stale(); if ($auto_remove_stale eq $sTRUE) { _REMOVE_CACHED_FILE($cached_file_path) or croak("Couldn't remove cached file $cached_file_path"); } # otherwise fetch the object and return a copy } else { $cloned_object = _CLONE( $object, $self->get_persistence_mechanism() ); } # If we want stale data... } else { # and the cache item is indeed stale... if (_S_SHOULD_EXPIRE($expires_at)) { # fetch the object and return a copy $cloned_object = _CLONE( $object, $self->get_persistence_mechanism() ); } } } return $cloned_object; } # ------------------------------------------------------------------------------ # removes a key and value from the cache, it always succeeds, even if # the key or value doesn't exist sub remove { my ($self, $identifier) = @_; defined($identifier) or croak("identifier required"); my $unique_key = _BUILD_UNIQUE_KEY($identifier); my $cached_file_path = $self->_get_cached_file_path($unique_key); _REMOVE_CACHED_FILE($cached_file_path) or croak("couldn't remove cached file $cached_file_path"); return $sSUCCESS; } # ------------------------------------------------------------------------------ # take an human readable identifier, and create a unique key from it sub _BUILD_UNIQUE_KEY { my ($identifier) = @_; defined($identifier) or croak("identifier required"); my $unique_key = md5_hex($identifier) or croak("couldn't build unique key for identifier $identifier"); return $unique_key; } # ------------------------------------------------------------------------------ # Check to see if a directory exists and is writable, or if a prefix # directory exists and we can write to it in order to create # subdirectories. _VERIFY_DIRECTORY( $self->_get_namespace_path() ) # == $sSUCCESS should be checked every time the cache key, username, # or namespace is changed. sub _VERIFY_DIRECTORY { my ($directory) = @_; defined($directory) or croak("directory required"); # If the directory doesn't exist, crawl upwards until we find a file or # directory that exists while (defined $directory && !-e $directory) { $directory = _GET_PARENT_DIRECTORY($directory); } return $sFAILURE unless defined $directory; return $sSUCCESS if -d $directory && -w $directory; return $sFAILURE; } # ------------------------------------------------------------------------------ # find the parent directory of a directory. Returns undef if there is no # parent sub _GET_PARENT_DIRECTORY { my ($directory) = @_; defined($directory) or croak("directory required"); my @directories = splitdir($directory); pop @directories; return undef unless @directories; return catdir(@directories); } # ----------------------------------------------------------------------------- # create a directory with optional mask, building subdirectories as needed. be # sure to call _VERIFY_DIRECTORY before calling this function sub _CREATE_DIRECTORY { my ($directory, $mask) = @_; defined($directory) or croak("directory required"); my $old_mask; if (defined $mask) { $old_mask = umask; umask($mask); } $directory = _UNTAINT_FILE_PATH($directory); mkpath ($directory, 0, 0777); croak("Couldn't create directory: $directory: $!") unless -d $directory; umask($old_mask) if defined $mask; return $sSUCCESS; } # ----------------------------------------------------------------------------- # read in the object frozen in the specified file (absolute path). # returns a reference to the object, or undef if the object can not be # found or can not be unserialized sub _READ_OBJECT_DATA { my ($cached_file_path) = @_; defined($cached_file_path) or croak("cached file path required"); my $frozen_object_data = undef; if (-f $cached_file_path) { $frozen_object_data = _READ_FILE($cached_file_path); } else { return; } if (!$frozen_object_data) { return; } # Get the cache persistence mechanism. Searching upwards for the cache # description file is a bit of a hack, but it's much better than # passing the persistence mechanism value through the call chain. my $cache_key = _SEARCH_FOR_CACHE_KEY($cached_file_path); die "Couldn't find cache key directory" unless defined $cache_key; my $cache_description = _READ_CACHE_DESCRIPTION( $cache_key ); return undef unless defined $cache_description; # if the $frozed_object_data is corrupted, thaw will return undef my $thawed_data = _UNSERIALIZE( $frozen_object_data, $cache_description->{'Persistence Mechanism'}, $cache_key ); return $thawed_data; } # ----------------------------------------------------------------------------- # Look up the directory hierarchy for the cache description file, # which is in the cache key directory. sub _SEARCH_FOR_CACHE_KEY { my ($directory) = @_; defined($directory) or croak("directory required"); my $file = _BUILD_PATH($directory,$sCACHE_DESCRIPTION_FILENAME); # If the cache description file isn't in the current directory, # crawl upwards while (defined $directory && !-e $file) { $directory = _GET_PARENT_DIRECTORY($directory); $file = _BUILD_PATH($directory,$sCACHE_DESCRIPTION_FILENAME) if defined $directory; } return $directory; } # ----------------------------------------------------------------------------- # remove an object from the cache sub _REMOVE_CACHED_FILE { my ($cached_file_path) = @_; defined($cached_file_path) or croak("cached file path required"); # cached_file_path may be tainted $cached_file_path = _UNTAINT_FILE_PATH($cached_file_path); # Is there any way to do this atomically? if (-f $cached_file_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($cached_file_path); } return $sSUCCESS; } # ----------------------------------------------------------------------------- # clear all objects in this instance's namespace sub clear { my ($self) = @_; my $namespace_path = $self->_get_namespace_path(); $namespace_path = _UNTAINT_FILE_PATH($namespace_path); return $sSUCCESS unless -e $namespace_path; _RECURSIVELY_REMOVE_DIRECTORY($namespace_path) or croak("Couldn't clear namespace: $!"); return $sSUCCESS; } # ----------------------------------------------------------------------------- # iterate over all the objects in this instance's namespace and delete # those that have expired sub purge { my ($self) = @_; my $namespace_path = $self->_get_namespace_path(); finddepth(\&_PURGE_FILE_WRAPPER, $namespace_path); return $sSUCCESS; } # ----------------------------------------------------------------------------- # used with the Find::Find::find routine, this calls _PURGE_FILE on # each file found sub _PURGE_FILE_WRAPPER { my $file_path = $File::Find::name; $file_path = _UNTAINT_FILE_PATH($file_path); my $file = (splitpath($file_path))[2]; # Don't purge the cache description file if (-f $file && $file ne $sCACHE_DESCRIPTION_FILENAME) { _PURGE_FILE($file_path); } else { return; } } # ----------------------------------------------------------------------------- # if the file specified has expired, remove it from the cache. (path # is absolute) sub _PURGE_FILE { my ($cached_file_path) = @_; defined($cached_file_path) or croak("cached file path required"); my $object_data = _READ_OBJECT_DATA($cached_file_path); if ($object_data) { my $expires_at = $object_data->{expires_at}; if (_S_SHOULD_EXPIRE($expires_at)) { _REMOVE_CACHED_FILE($cached_file_path) or croak("Couldn't remove cached file $cached_file_path"); } } return $sSUCCESS; } # ----------------------------------------------------------------------------- # determine whether an object should expire sub _S_SHOULD_EXPIRE { my ($expires_at, $time) = @_; defined($expires_at) or croak("expires_at required"); # time is optional $time = $time || time(); if ($expires_at == $sEXPIRES_NOW) { return $sTRUE; } elsif ($expires_at == $sEXPIRES_NEVER) { return $sFALSE; } elsif ($time >= $expires_at) { return $sTRUE; } else { return $sFALSE; } } # ----------------------------------------------------------------------------- # reduce this namespace to a given size. (the size does not count the # space occupied by the cache description file.) sub reduce_size { my ($self, $new_size) = @_; $new_size >= 0 or croak("size >= 0 required"); my $namespace_path = $self->_get_namespace_path(); while ($self->size() > $new_size) { my $victim_file = _CHOOSE_VICTIM_FILE($namespace_path); if (!$victim_file) { warn("Couldn't reduce size to $new_size\n"); return $sFAILURE; } _REMOVE_CACHED_FILE($victim_file) or croak("Couldn't remove cached file $victim_file"); } return $sSUCCESS; } # ----------------------------------------------------------------------------- # reduce the entire cache size to a given size. (the size does not # count the space occupied by the cache description files.) sub REDUCE_SIZE { my ($new_size, $cache_key) = @_; $new_size >= 0 or croak("size >= 0 required"); $cache_key = $cache_key || _BUILD_DEFAULT_CACHE_KEY(); while (SIZE() > $new_size) { my $victim_file = _CHOOSE_VICTIM_FILE($cache_key); if (!defined($victim_file)) { warn("Couldn't reduce size to $new_size\n"); return $sFAILURE; } _REMOVE_CACHED_FILE($victim_file) or croak("Couldn't remove cached file $victim_file"); } return $sSUCCESS; } # ----------------------------------------------------------------------------- # Choose a "victim" cache object to remove starting from the argument # directory. (This directory should be either the cache key path or # some subdirectory of it.) The returned file is determined in this # order: (1) the one with the closest expiration, (2) the least recently # accessed one, (3) undef if there are no cache files. sub _CHOOSE_VICTIM_FILE { my ($root_directory) = @_; defined($root_directory) or croak("root directory required"); # Look for the file to delete with the nearest expiration my ($nearest_expiration_path, $nearest_expiration_time) = _RECURSIVE_FIND_NEAREST_EXPIRATION($root_directory); return $nearest_expiration_path if defined $nearest_expiration_path; # If there are no files with expirations, get the least recently # accessed one my ($latest_accessed_path, $latest_accessed_time) = _RECURSIVE_FIND_LATEST_ACCESSED($root_directory); return $latest_accessed_path if defined $latest_accessed_path; return undef; } # ----------------------------------------------------------------------------- # Recursively searches a cache namespace for the cache object with the # nearest expiration. Returns undef if no cache object with an # expiration time could be found. sub _RECURSIVE_FIND_NEAREST_EXPIRATION { my ($directory) = @_; defined($directory) or croak("directory required"); my $best_nearest_expiration_path = undef; my $best_nearest_expiration_time = undef; $directory = _UNTAINT_FILE_PATH($directory); opendir(DIR, $directory) or croak("Couldn't open directory $directory: $!"); my @dirents = readdir(DIR); foreach my $dirent (@dirents) { next if $dirent eq '.' or $dirent eq '..'; my $nearest_expiration_path_candidate = undef; my $nearest_expiration_time_candidate = undef; my $path = _BUILD_PATH($directory, $dirent); if (-d $path) { ($nearest_expiration_path_candidate, $nearest_expiration_time_candidate) = _RECURSIVE_FIND_NEAREST_EXPIRATION($path); } else { my $object_data; $object_data = _READ_OBJECT_DATA_WITHOUT_MODIFICATION($path); my $expires_at = $object_data->{expires_at}; $nearest_expiration_path_candidate = $path; $nearest_expiration_time_candidate = $expires_at; } next unless defined $nearest_expiration_path_candidate; next unless defined $nearest_expiration_time_candidate; # Skip this file if it doesn't have an expiration time. next if $nearest_expiration_time_candidate == $sEXPIRES_NEVER; # if this is the first candidate, they're automatically the # best, otherwise they have to beat the best if ((!defined $best_nearest_expiration_time) or ($best_nearest_expiration_time > $nearest_expiration_time_candidate)) { $best_nearest_expiration_path = $nearest_expiration_path_candidate; $best_nearest_expiration_time = $nearest_expiration_time_candidate; } } closedir(DIR); return ($best_nearest_expiration_path, $best_nearest_expiration_time); } # ----------------------------------------------------------------------------- # read in object data without modifying the access time. returns a # reference to the object, or undef if the object could not be read sub _READ_OBJECT_DATA_WITHOUT_MODIFICATION { my ($path) = @_; defined($path) or croak("path required"); $path = _UNTAINT_FILE_PATH($path); my ($file_access_time, $file_modified_time) = (stat($path))[8,9]; my $object_data_ref = _READ_OBJECT_DATA($path); utime($file_access_time, $file_modified_time, $path); return $object_data_ref; } # ----------------------------------------------------------------------------- # Recursively searches a cache namespace for the cache object with the # latest access time. Recursively searches for the file with the # latest access time, starting at the directory supplied as an # argument. Returns the path to the last accessed file and the last # accessed time. Returns (undef,undef) if there is not at least one # file in the directory hierarchy below and including the argument # directory. sub _RECURSIVE_FIND_LATEST_ACCESSED { my ($directory) = @_; defined($directory) or croak("directory required"); my $best_latest_accessed_path = undef; my $best_latest_accessed_time = undef; $directory = _UNTAINT_FILE_PATH($directory); opendir(DIR, $directory) or croak("Couldn't open directory $directory: $!"); my @dirents = readdir(DIR); foreach my $dirent (@dirents) { next if $dirent eq '.' or $dirent eq '..'; next if $dirent eq $sCACHE_DESCRIPTION_FILENAME; my $latest_accessed_path_candidate = undef; my $latest_accessed_time_candidate = undef; my $path = _BUILD_PATH($directory, $dirent); if (-d $path) { ($latest_accessed_path_candidate, $latest_accessed_time_candidate) = _RECURSIVE_FIND_LATEST_ACCESSED($path); } else { my $last_accessed_time = (stat($path))[8]; $latest_accessed_path_candidate = $path; $latest_accessed_time_candidate = $last_accessed_time; } next unless defined $latest_accessed_path_candidate; next unless defined $latest_accessed_time_candidate; # if this is the first candidate, they're automatically the # best, otherwise they have to beat the best if ((!defined $best_latest_accessed_time) or ($best_latest_accessed_time > $latest_accessed_time_candidate)) { $best_latest_accessed_path = $latest_accessed_path_candidate; $best_latest_accessed_time = $latest_accessed_time_candidate; } } closedir(DIR); return ($best_latest_accessed_path, $best_latest_accessed_time); } # ----------------------------------------------------------------------------- # recursively descend to get an estimate of the memory consumption for # this namespace, ignoring space occupied by the cache description # file. returns 0 if the cache doesn't appear to exist sub size { my ($self) = @_; my $namespace_path = $self->_get_namespace_path(); return 0 unless -e $namespace_path; return _RECURSIVE_DIRECTORY_SIZE($namespace_path); } # ----------------------------------------------------------------------------- # find the path to the cached file, taking into account the identifier and # namespace. sub _get_cached_file_path { my ($self,$unique_key) = @_; defined($unique_key) or croak("unique key required"); my $namespace_path = $self->_get_namespace_path(); my $cache_depth = $self->get_cache_depth(); my (@path_prefix) = _EXTRACT_PATH_PREFIX($unique_key, $cache_depth); my $cached_file_path = _BUILD_PATH($namespace_path); foreach my $path_element (@path_prefix) { $cached_file_path = _BUILD_PATH($cached_file_path, $path_element); } $cached_file_path = _BUILD_PATH($cached_file_path, $unique_key); return $cached_file_path; } # ----------------------------------------------------------------------------- # build the path to the cached file in the file system, taking into account # the identifier, namespace, and cache depth. sub _build_cached_file_path { my ($self,$unique_key) = @_; defined($unique_key) or croak("unique key required"); my $cached_file_path = $self->_get_cached_file_path($unique_key); # $cached_file_path has the directory & file. remove the file. my $cached_file_directory = _GET_PARENT_DIRECTORY($cached_file_path); _CREATE_DIRECTORY($cached_file_directory,0); return $cached_file_path; } # ----------------------------------------------------------------------------- # return a list of the first $cache_depth letters in the $identifier sub _EXTRACT_PATH_PREFIX { my ($unique_key, $cache_depth) = @_; defined($unique_key) or croak("unique key required"); defined($cache_depth) or croak("cache depth required"); my @path_prefix; for (my $i = 0; $i < $cache_depth; $i++) { push (@path_prefix, substr($unique_key, $i, 1)); } return @path_prefix; } # ----------------------------------------------------------------------------- # represent a path in canonical form, and check for illegal characters sub _BUILD_PATH { my (@elements) = @_; if (grep (/\.\./, @elements)) { croak("Illegal path characters .."); } my $path = File::Spec->catfile(@elements); return $path; } # ----------------------------------------------------------------------------- # read in a file. returns a reference to the data read sub _READ_FILE { my ($filename) = @_; my $data_ref; defined($filename) or croak("filename required"); $filename = _UNTAINT_FILE_PATH($filename); open(FILE, $filename) or croak("Couldn't open $filename for reading: $!"); # In case the user stores binary data binmode FILE; local $/ = undef; $$data_ref = ; close(FILE); return $data_ref; } # ----------------------------------------------------------------------------- # write a file atomically sub _WRITE_FILE { my ($filename, $data_ref, $mode, $new_umask) = @_; defined($filename) or croak("filename required"); defined($data_ref) or croak("data reference required"); defined($mode) or croak("mode required"); # Prepare the name for taint checking $filename = _UNTAINT_FILE_PATH($filename); # Change the umask if necessary my $old_umask = umask if $new_umask; umask($new_umask) if $new_umask; # Create a temp filename my $temp_filename = "$filename.tmp$$"; open(FILE, ">$temp_filename") or croak("Couldn't open $temp_filename for writing: $!\n"); # Use binmode in case the user stores binary data binmode(FILE); chmod($mode, $filename); print FILE $$data_ref; close(FILE); rename ($temp_filename, $filename) or croak("Couldn't rename $temp_filename to $filename"); umask($old_umask) if $old_umask; return $sSUCCESS; } # ----------------------------------------------------------------------------- # clear all objects in all namespaces sub CLEAR { my ($cache_key) = @_; $cache_key = $cache_key || _BUILD_DEFAULT_CACHE_KEY(); if (!-d $cache_key) { return $sSUCCESS; } # [Should this use the _UNTAINT_FILE_PATH routine?] $cache_key = _UNTAINT_FILE_PATH($cache_key); _RECURSIVELY_REMOVE_DIRECTORY($cache_key) or croak("Couldn't clear cache"); return $sSUCCESS; } # ----------------------------------------------------------------------------- # purge all objects in all namespaces that have expired sub PURGE { my ($cache_key) = @_; # [Should this use the _UNTAINT_FILE_PATH routine?] $cache_key = _UNTAINT_FILE_PATH($cache_key); $cache_key = $cache_key || _BUILD_DEFAULT_CACHE_KEY(); if (!-d $cache_key) { return $sSUCCESS; } finddepth(\&_PURGE_FILE_WRAPPER, $cache_key); return $sSUCCESS; } # ----------------------------------------------------------------------------- # get an estimate of the total memory consumption of the cache, # ignoring space occupied by cache description files. returns 0 if the # cache doesn't appear to exist sub SIZE { my ($cache_key) = @_; return 0 unless -e $cache_key; return _RECURSIVE_DIRECTORY_SIZE($cache_key); } # ----------------------------------------------------------------------------- # walk down a directory structure and total the size of the files # contained therein. Doesn't count the size of the cache description # file sub _RECURSIVE_DIRECTORY_SIZE { my ($directory) = @_; defined($directory) or croak("directory required"); my $size = 0; $directory = _UNTAINT_FILE_PATH($directory); opendir(DIR, $directory) or croak("Couldn't open directory $directory: $!"); my @dirents = readdir(DIR); foreach my $dirent (@dirents) { next if $dirent eq '.' or $dirent eq '..'; my $path = _BUILD_PATH($directory, $dirent); if (-d $path) { $size += _RECURSIVE_DIRECTORY_SIZE($path); } else { # Don't count the cache description file $size += -s $path if $dirent ne $sCACHE_DESCRIPTION_FILENAME; } } closedir(DIR); return $size; } # ----------------------------------------------------------------------------- # Find the username of the person running the process in an OS # independent way sub _FIND_USERNAME { my ($self) = @_; my $username; my $success = eval { my $effective_uid = $>; $username = getpwuid($effective_uid); }; if ($success and $username) { return $username; } else { return $sDEFAULT_USERNAME; } } # ----------------------------------------------------------------------------- # Untaint a path to a file sub _UNTAINT_FILE_PATH { my ($file_path) = @_; return _UNTAINT_STRING($file_path, $sUNTAINTED_FILE_PATH_REGEX); } # Untaint a string sub _UNTAINT_STRING { my ($string, $untainted_regex) = @_; defined($untainted_regex) or croak("untainted regex required"); defined($string) or croak("string required"); my ($untainted_string) = $string =~ /$untainted_regex/; if (!defined $untainted_string || $untainted_string ne $string) { warn("String $string contains possible taint"); } return $untainted_string; } # ----------------------------------------------------------------------------- # Returns the default root of the cache under the OS dependent temp dir sub _BUILD_DEFAULT_CACHE_KEY { my $tmpdir = tmpdir() or croak("No tmpdir on this system. Bugs to the authors of File::Spec"); my $default_cache_key = _BUILD_PATH($tmpdir, $sDEFAULT_CACHE_KEY); return $default_cache_key; } # ----------------------------------------------------------------------------- # Remove a directory starting at the root sub _RECURSIVELY_REMOVE_DIRECTORY { my ($root) = @_; -d $root or croak("$root is not a directory"); opendir(DIR, $root) or croak("Couldn't open directory $root: $!"); my @dirents = readdir(DIR); closedir(DIR) or croak("Couldn't close directory $root: $!"); foreach my $dirent (@dirents) { next if $dirent eq '.' or $dirent eq '..'; my $path_to_dirent = "$root/$dirent"; $path_to_dirent = _UNTAINT_FILE_PATH($path_to_dirent); if (-d $path_to_dirent) { _RECURSIVELY_REMOVE_DIRECTORY($path_to_dirent); } else { unlink($path_to_dirent) or croak("Couldn't unlink($path_to_dirent): $!\n"); } } rmdir($root) or croak("Couldn't rmdir $root: $!"); } # ----------------------------------------------------------------------------- # Get whether or not we automatically remove stale data from the cache # on retrieval sub get_auto_remove_stale { my ($self) = @_; return $self->{_auto_remove_stale}; } # ----------------------------------------------------------------------------- # Set whether or not we automatically remove stale data from the cache # on retrieval sub set_auto_remove_stale { my ($self, $auto_remove_stale) = @_; defined($auto_remove_stale) or croak("\$File::Cache::sTRUE (i.e. 1) or " . "\$File::Cache::sFALSE (i.e. 0) required"); $self->{_auto_remove_stale} = $auto_remove_stale; } # ----------------------------------------------------------------------------- # Get the root of this cache on the filesystem sub get_cache_key { my ($self) = @_; my $cache_key = $self->{_cache_key}; return $cache_key; } # ----------------------------------------------------------------------------- # Set the root of this cache on the filesystem sub set_cache_key { my ($self, $cache_key) = @_; defined($cache_key) or croak("cache key required"); $self->{_cache_key} = $cache_key; # We don't verify the new directory if this function is called # during cache creation if ( (caller(1))[3] ne 'File::Cache::new') { _VERIFY_DIRECTORY( $self->_get_namespace_path() ) == $sSUCCESS or croak("Can not build cache at " . $self->_get_namespace_path() . ". Check directory permissions."); } } # ----------------------------------------------------------------------------- # Get the root of this user's path sub _get_user_path { my ($self) = @_; my $cache_key = $self->get_cache_key(); my $username = $self->get_username(); my $user_path = _BUILD_PATH($cache_key, $username); return $user_path; } # ----------------------------------------------------------------------------- # Get the root of this namespace's path sub _get_namespace_path { my ($self) = @_; my $user_path = $self->_get_user_path(); my $namespace = $self->get_namespace(); my $namespace_path = _BUILD_PATH($user_path, $namespace); return $namespace_path; } # ----------------------------------------------------------------------------- # Get the namespace for this cache instance (within the entire cache) sub get_namespace { my ($self) = @_; return $self->{_namespace}; } # ----------------------------------------------------------------------------- # Set the namespace for this cache instance (within the entire cache) sub set_namespace { my ($self, $namespace) = @_; defined($namespace) or croak("namespace required"); $self->{_namespace} = $namespace; # We don't verify the new directory if this function is called # during cache creation if ( (caller(1))[3] ne 'File::Cache::new') { _VERIFY_DIRECTORY( $self->_get_namespace_path() ) == $sSUCCESS or croak("Can not build cache at " . $self->_get_namespace_path() . ". Check directory permissions."); } } # ----------------------------------------------------------------------------- # Get the global expiration value for the cache sub get_global_expires_in { my ($self) = @_; return $self->{_global_expires_in}; } # ----------------------------------------------------------------------------- # Set the global expiration value for the cache sub set_global_expires_in { my ($self, $global_expires_in) = @_; ($global_expires_in > 0) || ($global_expires_in == $sEXPIRES_NEVER) || ($global_expires_in == $sEXPIRES_NOW) or croak("\$global_expires_in must be > 0," . "\$sEXPIRES_NOW, or \$sEXPIRES_NEVER"); $self->{_global_expires_in} = $global_expires_in; } # ----------------------------------------------------------------------------- # Get the creation time for a cache object. Returns undef if the value # is not in the cache sub get_creation_time { my ($self, $identifier) = @_; my $unique_key = _BUILD_UNIQUE_KEY($identifier); my $cached_file_path = $self->_get_cached_file_path($unique_key); my $object_data; $object_data = _READ_OBJECT_DATA($cached_file_path); if ($object_data) { return $object_data->{created_at}; } else { return undef; } } # ----------------------------------------------------------------------------- # Get the expiration time for a cache object. Returns undef if the # value is not in the cache sub get_expiration_time { my ($self, $identifier) = @_; my $unique_key = _BUILD_UNIQUE_KEY($identifier); my $cached_file_path = $self->_get_cached_file_path($unique_key); my $object_data; $object_data = _READ_OBJECT_DATA($cached_file_path); if ($object_data) { return $object_data->{expires_at}; } else { return undef; } } # ----------------------------------------------------------------------------- # Get the username associated with this cache sub get_username { my ($self) = @_; return $self->{_username}; } # ----------------------------------------------------------------------------- # Set the username associated with this cache sub set_username { my ($self, $username) = @_; defined($username) or croak("username required"); $self->{_username} = $username; # We don't verify the new directory if this function is called # during cache creation if ( (caller(1))[3] ne 'File::Cache::new') { _VERIFY_DIRECTORY( $self->_get_namespace_path() ) == $sSUCCESS or croak("Can not build cache at " . $self->_get_namespace_path() . ". Check directory permissions."); } } # ----------------------------------------------------------------------------- # Gets the filemode for files created within the cache sub get_filemode { my ($self) = @_; return $self->{_filemode}; } # ----------------------------------------------------------------------------- # Sets the filemode for files created within the cache sub set_filemode { my ($self, $filemode) = @_; defined ($filemode) or croak("filemode required"); $self->{_filemode} = $filemode; } # ----------------------------------------------------------------------------- # Gets the max cache size. sub get_max_size { my ($self) = @_; return $self->{_max_size}; } # ----------------------------------------------------------------------------- # Sets the max cache size. sub set_max_size { my ($self, $max_size) = @_; ($max_size > 0) || ($max_size == $sNO_MAX_SIZE) or croak("Invalid cache size. " . "Must be either \$sNO_MAX_SIZE or greater than zero"); $self->{_max_size} = $max_size; # Reduce the size if necessary. if ($max_size != $sNO_MAX_SIZE) { $self->reduce_size($max_size); } } # ----------------------------------------------------------------------------- # Gets the cache depth sub get_cache_depth { my ($self) = @_; return $self->{_cache_depth}; } # ----------------------------------------------------------------------------- # Sets the cache depth sub set_cache_depth { my ($self, $cache_depth) = @_; ($cache_depth >= 0) or croak("Invalid cache depth. Must be greater than zero"); $self->{_cache_depth} = $cache_depth; } # ----------------------------------------------------------------------------- # Gets the persistence mechanism sub get_persistence_mechanism { my ($self) = @_; return $self->{_persistence_mechanism}; } # ----------------------------------------------------------------------------- # Sets the persistence mechanism. sub set_persistence_mechanism { my ($self, $persistence_mechanism) = @_; defined ($persistence_mechanism) or croak("persistence mechanism required"); # We don't clear the cache if this function is called during cache # creation if ( (caller(1))[3] ne 'File::Cache::new') { $self->clear(); } ($persistence_mechanism eq 'Storable') || ($persistence_mechanism eq 'Data::Dumper') or croak("Peristence mechanism must be either " . \"Storable\" or \"Data::Dumper\""); $self->{_persistence_mechanism} = $persistence_mechanism; } 1; __END__ =head1 NAME File::Cache - Share data between processes via filesystem =head1 NOTE Use of File::Cache is now discouraged in favor of the new Cache::Cache project, also available on CPAN. Cache::Cache offers all of the functionality of File::Cache, as well as integrating the functionality of IPC::Cache and a number of new features. You can view the Cache::Cache project page at: http://sourceforge.net/projects/perl-cache/ =head1 DESCRIPTION B is a perl module that implements an object storage space where data is persisted across process boundaries via the filesystem. File::Cache builds a cache in the file system using a multi-level directory structure that looks like this: ///[D1]/[D2]/.../ CACHE_KEY is the location of the root level of the cache. The cache key defaults to /File::Cache, where is the temporary directory on your system. USERNAME is the user identifier. This value defaults to the userid, if it can be determined from the system, or "nobody" if it can not. defaults to "_default". D1, D2, etc. are subdirectories that are created to hold the cache objects. The number subdirectories depends on the I value, which defaults to 0. Objects are stored in the cache using a method which depends on the I value. =head1 SYNOPSIS use File::Cache; # create a cache in the default namespace, where objects # do not expire my $cache = new File::Cache(); # create a user-private cache in the specified # namespace, where objects will expire in one day, and # will automatically be removed from the cache. my $cache = new File::Cache( { namespace => 'MyCache', expires_in => 86400, filemode => 0600 } ); # create a public cache in the specified namespace, # where objects will expire in one day, but will not be # removed from the cache automatically. my $cache = new File::Cache( { namespace => 'MyCache', expires_in => 86400, username => 'shared_user', auto_remove_stale => 0, filemode => 0666 } ); # create a cache readable by the user and the user's # group in the specified namespace, where objects will # expire in one day, but may be removed from the cache # earlier if the size becomes more than a megabyte. Also, # request that the cache use subdirectories to increase # performance of large number of objects my $cache = new File::Cache( { namespace => 'MyCache', expires_in => 86400, max_size => 1048576, username => 'shared_user', filemode => 0660, cache_depth => 3 } ); # store a value in the cache (will expire in one day) $cache->set("key1", "value1"); # retrieve a value from the cache $cache->get("key1"); # retrieve a stale value from the cache. # (Undefined behavior if auto_remove_stale is 1) $cache->get_stale("key1"); # store a value that expires in one hour $cache->set("key2", "value2", 3600); # reduce the cache size to 3600 bytes $cache->reduce_size(3600); # clear this cache's contents $cache->clear(); # delete all namespaces from the filesystem File::Cache::CLEAR(); =head2 TYPICAL USAGE A typical scenario for this would be a mod_perl or perl CGI application. In a multi-tier architecture, it is likely that a trip from the front-end to the database is the most expensive operation, and that data may not change frequently. Using this module will help keep that data on the front-end. Consider the following usage in a mod_perl application, where a mod_perl application serves out images that are retrieved from a database. Those images change infrequently, but we want to check them once an hour, just in case. my $imageCache = new Cache( { namespace => 'Images', expires_in => 3600 } ); my $image = $imageCache->get("the_requested_image"); if (!$image) { # $image = [expensive database call to get the image] $imageCache->set("the_requested_image", $image); } That bit of code, executed in any instance of the mod_perl/httpd process will first try the filesystem cache, and only perform the expensive database call if the image has not been fetched before, has timed out, or the cache has been cleared. The current implementation of this module automatically removes expired items from the cache when the get() method is called and the auto_remove_stale setting is true. Automatic removal does not occur when the set() method is called, which means that the cache can become polluted with expired items if many items are stored in the cache for short periods of time, and are rarely accessed. This is a design decision that favors efficiency in the common case, where items are accessed frequently. If you want to limit cache growth, see the max_size option, which will automatically shrink the cache when the set() method is called. (max_size is unaffected by the value of auto_remove_stale.) Be careful that you call the purge method periodically if auto_remove_stale is 0 and max_size has its default value of unlimited size. In this configuration, the cache size will be a function of the number of items inserted into the cache since the last purge. (i.e. It can grow extremely large if you put lots of different items in the cache.) =head2 METHODS =over 4 =item B Creates a new instance of the cache object. The constructor takes a reference to an options hash which can contain any or all of the following: =over 4 =item $options{namespace} Namespaces provide isolation between objects. Each cache refers to one and only one namespace. Multiple caches can refer to the same namespace, however. While specifying a namespace is not required, it is recommended so as not to have data collide. =item $options{expires_in} If the "expires_in" option is set, all objects in this cache will be cleared in that number of seconds. It can be overridden on a per-object basis. If expires_in is not set, the objects will never expire unless explicitly set. =item $options{cache_key} The "cache_key" is used to determine the underlying filesystem namespace to use. In typical usage, leaving this unset and relying on namespaces alone will be more than adequate. =item $options{username} The "username" is used to explicitely set the username. This is useful for cases where one wishes to share a cache among multiple users. If left unset, the value will be the current user's username. (Also see $options{filemode}.) Note that the username is not used to set ownership of the cache files -- the i.e. the username does not have to be a user of the system. =item $options{filemode} "filemode" specifies the permissions for cache files. This is useful for cases where one wishes to share a cache among multiple users. If left unset, the value will be "u", indicating that only the current user can read an write the cache files. See the filemode() method documentation for the specification syntax. =item $options{max_size} "max_size" specifies the maximum size of the cache, in bytes. Cache objects are removed during the set() operation in order to reduce the cache size before the new cache value is added. See the reduce_size() documentation for the cache object removal policy. The max_size will be maintained regardless of the value of auto_remove_stale. The default is $File::Cache::sNO_MAX_SIZE, which indicates that the cache has no maximum size. =item $options(auto_remove_stale} "auto_remove_stale" specifies that the cache should remove expired objects from the cache when they are requested. =item $options(cache_depth} "cache_depth" specifies the depth of the subdirectories that should be created. This is helpful when especially large numbers of objects are being cached (>1000) at once. The optimal number of files per directory is dependent on the type of filesystem, so some hand-tuning may be required. =back =item B Adds an object to the cache. set takes the following parameters: =over 4 =item $identifier The key the refers to this object. =item $object The object to be stored. This any Storable or Data::Dumper-able scalar or (optionally blessed) ref. Filehandles and database handles can not be stored, but most other references to objects can be. =item $expires_in I<(optional)> The object will be cleared from the cache in this number of seconds. Overrides the default expires_in value for the cache. =back =item B get retrieves an object from the cache. If the object referred to by the identifier exists in the cache and has not expired then then object will be returned. If the object does not exist then get will return undef. If the object does exist but has expired then get will return undef and, depending on the setting of auto_remove_stale, remove the expired object from the cache. =over 4 =item $identifier The key referring to the object to be retrieved. =back =item B get_stale retrieves objects that have expired from the cache. Normally, expired objects are removed automatically and can not be retrieved via get_stale, but if the auto_remove_stale option is set to false, then expired objects will be left in the cache. get_stale returns undef if the object does not exist at all or has not expired yet. =over 4 =item $identifier The key referring to the object to be retrieved. =back =item B Removes an object from the cache. =over 4 =item $identifier The key referring to the object to be removed. =back =item B Removes all objects from this cache. =item B Removes all objects that have expired =item B Return an estimate of the disk usage of the current namespace. =item B Reduces the size of the cache so that it is below $size. Note that the cache size is approximate, and may slightly exceed the value of $size. Cache objects are removed in order of nearest expiration time, or latest access time if there are no cache objects with expiration times. (If there are a mix of cache objects with expiration times and without, the ones with expiration times are removed first.) reduce_size takes the following parameter: =over 4 =item $size The new target cache size. =back =item B Gets the time at which the data associated with $identifier was stored in the cache. Returns undef if $identifier is not cached. =over 4 =item $identifier The key referring to the object to be retrieved. =back =item B Gets the time at which the data associated with $identifier will expire from the cache. Returns undef if $identifier is not cached. =over 4 =item $identifier The key referring to the object to be retrieved. =back =item B Returns the default number of seconds before an object in the cache expires. =item B Sets the default number of seconds before an object in the cache expires. set_global_expires_in takes the following parameter: =over 4 =item $global_expires_in The default number of seconds before an object in the cache expires. It should be a number greater than zero, $File::Cache::sEXPIRES_NEVER, or $File::Cache::sEXPIRES_NOW. =back =item B Returns whether or not the cache will automatically remove objects after they expire. =item B Sets whether or not the cache will automatically remove objects after they expire. set_auto_remove_stale takes the following parameter: =over 4 =item $auto_remove_stale The new auto_remove_stale value. If $auto_remove_stale is 1 or $File::Cache::sTRUE, then the cache will automatically remove items when they are being retrieved if they have expired. If $auto_remove_stale is 0 or $File::Cache::sFALSE, the cache will only remove expired items when the purge() method is called, or if max_size is set. Note that the behavior of get_stale is undefined if $auto_remove_stale is true. =back =item B Returns the username that is currently being used to define the location of this cache. =item B Sets the username that is currently being used to define the location of this cache. set_username takes the following parameter: =over 4 =item $username The username that is to be used to define the location of this cache. It is not directly used to determine the ownership of the cache files, but can be used to isolate sections of a cache for different permissions. =back =item B Returns the current cache namespace. =item B Sets the cache namespace. set_namespace takes the following parameter: =over 4 =item $namespace The namespace that is to be used by the cache. The namespace can be used to isolate sections of a cache. =back =item B Returns the current cache maximum size. $File::Cache::sNO_MAX_SIZE (the default) indicates no maximum size. =item B Sets the maximum cache size. The cache size is reduced as necessary. set_max_size takes the following parameter: =over 4 =item $max_size The maximum size of the cache. $File::Cache::sNO_MAX_SIZE indicates no maximum size. =back =item B Returns the current cache depth. =item B Sets the cache depth. Consider calling clear() before resetting the cache depth in order to prevent inaccessible cache objects from occupying disk space. set_cache_depth takes the following parameter: =over 4 =item $cache_depth The depth of subdirectories that are to be used by the cache when storing cache objects. =back =item B Returns the current cache persistence mechanism. =item B Sets the cache persistence mechanism. This method clears the cache in order to ensure consistent cache objects. set_persistence_mechanism takes the following parameter: =over 4 =item $persistence_mechanism The persistence mechanism that is to be used by the cache. This value can be either "Storable" or "Data::Dumper". =back =item B Returns the filemode specification for newly created cache objects. =item B Sets the filemode specification for newly created cache objects. set_filemode takes the following parameter: =over 4 =item $mode The file mode -- a numerical mode identical to that used by chmod(). See the chmod() documentation for more information. =back =item B Removes this cache and all the associated namespaces from the filesystem. CLEAR takes the following parameter: =over 4 =item $cache_key I<(optional)> Specifies the filesystem data to be cleared. Needed only if a cache was created with a non-standard cache key. =back =item B Removes all objects in all namespaces that have expired. PURGE takes the following parameter: =over 4 =item $cache_key I<(optional)> Specifies the filesystem data to be purged. Needed only if a cache was created with a non-standard cache key. =back =item B Roughly estimates the amount of memory in use. SIZE takes the following parameter: =over 4 =item $cache_key I<(optional)> Specifies the filesystem data to be examined. Needed only if a cache was created with a non-standard cache key. =back =item B Reduces the size of the cache so that it is below $size. Note that the cache size is approximate, and may slightly exceed the value of $size. Cache objects are removed in order of nearest expiration time, or latest access time if there are no cache objects with expiration times. (If there are a mix of cache objects with expiration times and without, the ones with expiration times are removed first.) REDUCE_SIZE takes the following parameters: =over 4 =item $size The new target cache size. =item $cache_key I<(optional)> Specifies the filesystem data to be examined. Needed only if a cache was created with a non-standard cache key. =back =back =head1 BUGS =over 4 =item * The root of the cache namespace is created with global read/write permissions. =back =head1 SEE ALSO IPC::Cache, Storable, Data::Dumper =head1 AUTHOR DeWitt Clinton , and please see the CREDITS file =cut File-Cache-0.16/TODO0100644000076400007640000000000107147053600013374 0ustar dewittdewitt