CHI-0.60/0000775€ˆž«€q{Ì0000000000012535132431011533 5ustar jonswartCHI-0.60/Changes0000644€ˆž«€q{Ì0000003626512535132431013040 0ustar jonswartRevision history for CHI ** denotes an incompatible change 0.60 Jun 7, 2015 * Fixes - Switch JSON backends from JSON.pm to JSON::MaybeXS - https://github.com/jonswar/perl-chi/pull/20 (Karen Etheridge) 0.59 Jan 7, 2015 * Improvements - Pass driver to expire_if - https://github.com/jonswar/perl-chi/pull/19 (rouzier) * Fixes - Fix DiscardPolicy type - RT #95291 (Josh Rosenbaum) - Don't mandate that get_namespaces returns in same order - RT #89892 (nhorne) 0.58 May 18, 2014 * Implementation - Use Moo instead of Moose for object system. This should be fully compatible with existing code, including Moose drivers or other extensions. This reduces the startup time and memory overhead. * Improvements - The Memory and RawMemory drivers now support zero as a valid value for the global argument causing a new hashref datastore to be created. (Aran Deltac) * Fixes - Fix busted packaging - Fix the loading of additional roles or traits (jrouzierinverse) 0.57 Jan 26, 2014 * Improvements - Use nfreeze instead of freeze for network portability - RT #74188 (Jeffrey Fuller) 0.56 Oct 22, 2012 * Fixes - Mention testing_driver_class in CHI/Driver/Development.pm - RT #78921 (Nigel Horne) * Tests - Add test_multiple_processes for testing drivers under concurrent writes - RT #79132 (Nigel Horne) * Docs - Mention that driver tests are responsible for their own cleanup - RT #79100 (Nigel Horne) - Various spelling fixes thanks to Pod::Spell 0.55 Jul 3, 2012 * Improvements - Compute derived/aggregate stats in CHI::Stats::parse_stats_logs * Fixes - Eliminate "=for html" POD entries, which were mangling metacpan.org output (Pedro Melo) 0.54 May 30, 2012 ** Incompatible Changes ** - ** Switch CHI::Stats format to JSON for easier generation and parsing 0.53 May 30, 2012 * Improvements - Measure time elapsed in get, set, and compute; record in logs and stats. Only measure when debug logging or stats are enabled. - compute() now handles list or scalar caller context - The driver parameter now accepts full classes prefixed by '+', as is standard. driver_class is still accepted for backward compatibility but no longer documented. * Fixes - compute() no longer modifies passed-in options hashref - Fix get_multi_* with partially empty l1 cache - perl-chi/pull/12 (Mike Cartmell) - Fix get_keys when file_extension set on CHI::Driver::File - RT #76489 (Vitaliy Tokarev) - Have set_multi call store_multi underneath as documented in Development.pod - RT #76621 (Oliver Paukstadt) - Minor POD fixes (Alessandro Ghedini) 0.52 Mar 7, 2012 * Improvements - Subclasses inherit configuration from their parents unless they also call config() * Fixes - Fix Config test to not require memcached 0.51 Mar 4, 2012 * Improvements - Add CHI->config() to register storage types, and set core and per-namespace defaults * Fixes - Fix new test_max_key_length test to work on drivers that do not support get_keys 0.50 Nov 30, 2011 * Docs - Clarify busy_lock doc, add obj_ref doc (perlover) * Fixes - Override set() rather than set_object() in Role/HasSubcaches.pm so that keys are not double-transformed when set in l1 or mirror caches. This is simpler and should be more robust. - Remove htdocs which were accidentally added into dist 0.49 Jun 23, 2011 * Fixes - Go back to generating version numbers for all sub-modules again 0.48 Jun 15, 2011 * Fixes - Disregard default expires_at and expires_in if either are provided - RT #67970 (spjw) 0.47 Apr 28, 2011 * Improvements - Allow compute() to take get options - expire_if and busy_lock - Add atomic operations: add, append, replace (alpha) 0.46 Apr 22, 2011 * Other - Only generate version numbers for .pm files with documentation, to reduce inter-version churn 0.45 Apr 18, 2011 * Improvements - Add expires_on_backend parameter 0.44 Mar 17, 2011 * Fixes - Recreate tarball so that it can be read with older tars - Remove more unnecessary packages from CPAN index 0.43 Mar 17, 2011 * Improvements - Add compress_threshold parameter 0.42 Mar 3, 2011 * Fixes - Put parens around qw in various places to fix for perl 5.13+ * Improvements - Improve accuracy of benchmarks (nothingmuch) 0.41 Mar 1, 2011 * Improvements - Add RawMemory driver, a faster version of Memory that does not serialize/deserialize values - Add etc/bench/bench.pl for benchmarking CHI and non-CHI caches - Publish current benchmarking results in CHI::Benchmarks * Testing - Stop using test counts (http://stackoverflow.com/questions/690342/) 0.40 Feb 27, 2011 * Improvements - Reverse order of 2nd and 3rd arguments in compute() (old order will still work) - Throw error if arguments passed to clear() * Fixes - Fix CHI::Driver::Metacache::meta_cache to build lazily, eliminating intermittent bug and making compatible with Moose 1.99+ (autarch) - Check if get_object defined in purge - RT #63699 (forrest) 0.39 Feb 6, 2011 * Fixes - Put missing module names back in POD 0.38 Feb 6, 2011 * Fixes - Move some smoke tests back to author tests 0.37 Feb 6, 2011 * Fixes - Eliminate Module::Load::Conditional which was causing problems with version.pm - RT #64900 - reported by dgl@dgl.cx * Implementation - Switch to Dist::Zilla 0.36 Jun 9, 2010 * Fixes - Only encode keys with wide characters - In escape_for_filename, replace \w with A-Za-z0-9_ to avoid The Unicode Bug 0.35 Jun 4, 2010 * Improvements - Automatically serialize keys that are references - Automatically digest long keys, based on max_key_length and key_digester - Handle utf-8 characters in keys and values * Fixes - Add Test::Builder and Test::Log::Dispatch to dependencies - RT #57091 - reported by Doug Bell - Add line about installing Cache::FastMmap in CHI::Driver::FastMmap - RT #55920 - reported by RSAVAGE 0.34 Feb 9, 2010 * Improvements - Add statistics recording with CHI::Stats - Add max_build_depth to ward off accidental infinite subcache recursion * Fixes - Change unique_id so as not to seg fault with threads - RT #53591 - reported by Marc Tobias - Eliminate existence check in File remove(), as it is prone to race condition - RT #50104 - reported by Aran Deltac - In File clear(), rename directory before removing to reduce chance of conflict 0.33 Nov 29, 2009 * Fixes - In CacheContainer, ensure that fetch returns scalar - Include Role::IsSubcache attributes in CHI::Driver->non_common_constructor_params 0.32 Nov 24, 2009 * Fixes - get_keys not supported in File driver when key_digest is used, for now - Replace deprecated Class::MOP get_attribute_map with get_attribute_list - RT #52019 - reported by Todd Caine - Include Role::HasSubcaches and Role::IsSizeAware attributes in CHI::Driver->non_common_constructor_params 0.31 Nov 17, 2009 * Improvements - ** Rename file_digest to key_digest, so it can be made a generic driver feature later on - Allow key_digest to be passed as a string, hash or object - Create Digest object once per CHI object, rather than once per read/write 0.30 Nov 5, 2009 * Fixes - Fix bug with size-aware L1 cache not keeping track of size - Fix description of never-expiring set in logs and errors * Improvements - Add file_digest and file_extension options to File driver - Improve l1 cache performance by reusing packed CacheObject data - Document options that cannot be overriden by subcache, and warn if user tries to override these 0.29 Oct 14, 2009 * Fixes - Make sure Memory cache is cleared when multiple objects use the same datastore, or when datastore hash itself is emptied - Fix synopsis of Memory cache in main docs - RT #50360 - reported by zloyrusskiy - Fix get_namespaces when File root dir doesn't exist - Fix tests to use label for log matching 0.28 Aug 31, 2009 * Fixes - Add Test::Exception, Log::Any::Adapter::Dispatch to dependencies - Remove use of no-longer-existent CHI::Test::Logger from test modules - RT #49252 - Fix get_multi_* when $@ already contains an error - RT #48988 - reported by Sergey Panteleev - Fix docs to mention root_dir - RT #43409 - reported by anirvan * Implementation - Remove private debugging methods dp and dps 0.27 Aug 27, 2009 ** Incompatible Changes ** - ** Switch to using Log::Any for controlling logging, instead of custom CHI->logger() * Implementation - Move internal tests to xt/release, as per standard 0.26 Jul 14, 2009 * Fixes - Eliminate is_subcache redefinition of attribute (causes CHI to fail to load under latest Moose) * Implementation - Make sure that tests are only using keys from a particular list; this is necessary for memcached tests, which has to simulate get_keys by checking for all the possible ones 0.25 Jun 2, 2009 * Improvements - Non-Moose drivers should be fully functional again (reversing the change in 0.23) * Implementation - Moved role composition to CHI.pm factory (ala MooseX::Traits), so that each role can have its own attributes and initialization - Moved all Moose types to CHI::Types - Replaced require_dynamic with Class::MOP::load_class 0.241 May 26, 2009 * Fixes - Actually add Moose to requirements, in place of Any::Moose 0.24 May 26, 2009 * Fixes - Reverted test scripts to previous format, as they were causing problems with other driver distributions 0.23 May 24, 2009 ** Incompatible Changes ** - ** Drivers must now be Moose based to be fully functional, since we use Moose roles to implement various features. For backward compatibility, non-Moose drivers will still work at a basic level (for now). * Improvements - Added concepts of size awareness, maximum size, and discard policies for any driver. See "Size Awareness" section of docs. * Implementation - Added a metacache, which resides in a separate _CHI_META namespace and stores meta-information about caches. Initially for tracking size for size-aware caches. - Added dependency on Carp::Assert - Eliminate boilerplate in test scripts * Fixes - Croak if specify both 'global' and 'datastore' for memory driver 0.22 May 13, 2009 * Implementation - Switch from Mouse back to Moose - six week experiment over. Once we started using roles, Mouse became increasingly unattractive and the Moose community encouraged us not to go further with it. We can hope (or help ensure) that Moose installation and startup time improves. - Moved subcache code to a separate role, CHI::Driver::Role::HasSubcaches. API remains the same -- activated via l1_cache and mirror_cache options to CHI->new. 0.21 May 5, 2009 ** Incompatible Changes ** - ** Deprecate get_multi_array - silly to have this along with get_multi_arrayref - ** CHI::Driver::Memory will no longer use a global datastore by default - it was too easy to accidentally share the same datstore in unrelated code. Either a datastore or the 'global' flag must be specified. Right now the absence of either will issue a warning, eventually this may become an error. * Improvements - To implement get_multi_*, drivers now define the simpler fetch_multi_hashref - Made get_multi_* work optimally with l1 caches * Fixes - Eliminated t/Multilevel.t which was causing test failures on new installations - Fixed get_namespaces for File driver to ignore non-standard dir names * Docs - Tidied pod with Pod::Tidy - Added Features section and mention of Chris Leishman's Cache to docs 0.2 Apr 25, 2009 ** Incompatibile Changes ** - ** Removed CHI::Driver::Multilevel, replaced with subcaches - ** ref($driver) is no longer simply the driver class, it is an auto-generated wrapper class like CHI::Wrapped::CHI::Driver::Memory - this is so that certain driver methods can be automatically wrapped * Improvements - Added a more practical and intuitive multi-level cache mechanism: subcaches. l1_cache and mirror_cache are the first two supported subcaches - Added customizable cache label, used in logs and error messages 0.102 Mar 6, 2009 * Fixes - Skip get_namespaces in tests with drivers that don't support it - Eliminate unconditional use of Data::Serializer in tests; improve error when Data::Serializer not installed 0.101 Mar 2, 2009 * Fixes - Don't use Data::Serializer up front 0.10 Feb 28, 2009 - ** Deprecate expire_if method - this can easily be done manually, and it now differs deceptively from the expire_if option to get() - ** Change expire_if option to simply return undef, without actually expiring the item - Switch to Mouse instead of Moose, to reduce install dependencies and overhead. Eliminate Moose-isms as needed. Eventually may switch to Any::Moose but want to get comfortable with Mouse first. - Eliminate dependencies on Data::Serializer, File::Slurp, and Module::Find - Revert Memory driver implementation to more readable and illustrative form - Handle value-too-large errors in FastMmap driver - When serializer passed as a string, use raw=>1 so as not to hex-encode or insert token - Allow serializer to be passed as a hashref - Fix bug when specifying serializer with multilevel driver 0.091 Jan 2, 2009 - Ensure that unlink_on_exit=0 is being passed to FastMmap - Allow serializer to be passed as a simple string - Documentation fixes 0.09 Dec 30, 2008 - Moved source to git - Added Null driver - Fixed main docs regarding Memcached driver - Changed FastMmap driver to pass all unrecognized options onto Cache::FastMmap, to better handle future FastMmap versions - Fixed small get_keys bug in File driver - Added expires time to set logs - Added get_multi_array alongside get_multi_arrayref - Added test for get_namespaces 0.081 Sep 24, 2008 - Fix t/Driver/File.pm test so it does not depend on specific OS error message 0.08 Sep 23, 2008 - ** Move CHI::Driver::Memcached to its own distribution - Many internal changes to make greater use of Moose (Dave Rolsky). - Add serializer option, allowing control over how data is serialized/deserialized - The FastMmap driver was not actually making use of the init_file, cache_size, page_size, or num_pages options. Reported by Mike Astle. RT #35819. (Dave Rolsky) - Allow suppression of renames in CHI::Driver::File by overriding generate_temporary_filename 0.07 Mar 12, 2008 - Add Date::Parse to build dependencies 0.06 Feb 29, 2008 - Created separate manual for developing drivers (CHI::Driver::Development) - Made standard CHI driver tests easily available to external drivers - Fixed clear() in Memcached driver - RT #32859 - reported by Justin Ellison - Add size to set logs 0.05 Jan 30, 2008 - Switched to Moose - Added maximum full path length check to File driver, mainly for MSWin32 - Added TODO to pod 0.04 Jan 25, 2008 - Default unlink_on_exit to 0 for Cache::FastMmap to conform to the CHI API 0.03 Jan 23, 2008 - ** Eliminated automatic namespace selection based on caller; namespace now defaults to 'Default', as in Cache::Cache. - Added 5.6.0 requirement - Made Memcached test internal-only for now, since test success depends on presence and configuration of an external server - Changed README to generate from CHI.pm 0.02 Jan 19, 2008 - Changed Multilevel-Single test to use a temporary root dir - Eliminated non-portable file permissions test - Concealed use of test package name (Foo::Bar) from PAUSE indexer 0.01 Jan 15, 2008 - Initial version CHI-0.60/etc/0000775€ˆž«€q{Ì0000000000012535132431012306 5ustar jonswartCHI-0.60/etc/bench/0000775€ˆž«€q{Ì0000000000012535132431013365 5ustar jonswartCHI-0.60/etc/bench/bench.pl0000755€ˆž«€q{Ì0000002441212535132431015005 0ustar jonswart#!/usr/bin/perl # # Compare various cache backends # use Benchmark qw(:hireswallclock timethese); use Capture::Tiny qw(capture); use Cwd qw(realpath); use Data::Dump qw(dump); use DBI; use DBD::mysql; use File::Basename; use File::Path; use Getopt::Long; use Hash::MoreUtils qw(slice_def); use List::Util qw(sum); use List::MoreUtils qw(uniq); use Pod::Usage; use Text::Table; use Try::Tiny; use YAML::Any qw(DumpFile); use Module::Runtime qw(require_module); use warnings; use strict; my %cache_generators = cache_generators(); sub usage { pod2usage( -verbose => 1, -exitval => "NOEXIT" ); print "Valid drivers: " . join( ", ", sort keys(%cache_generators) ) . "\n"; print "To install all requirements:\n cpanm " . join( " ", sort( uniq( map { @{ $_->{req} || [] } } values(%cache_generators) ) ) ) . "\n"; exit(1); } my $time = 2; my ( $complex, $drivers_pattern, $help, $incs, $sort_by_name ); usage() if !@ARGV; GetOptions( 'd|drivers=s' => \$drivers_pattern, 'h|help' => \$help, 'n' => \$sort_by_name, 't|time=s' => \$time, 'x|complex' => \$complex, ) or usage(); usage() if $help || !$drivers_pattern; my $value = $complex ? { map { ( $_, scalar( $_ x 100 ) ) } qw(a b c d e) } : scalar( 'x' x 500 ); my $num_keys = 1000; require CHI; print "CHI version $CHI::VERSION\n" if $CHI::VERSION; my $cwd = dirname( realpath($0) ); my $data = "$cwd/data"; rmtree($data); mkpath( $data, 0, 0775 ); my %common_chi_opts = ( on_get_error => 'die', on_set_error => 'die' ); my %caches; foreach my $name ( grep { /$drivers_pattern/ } keys(%cache_generators) ) { try { if ( my $req = $cache_generators{$name}->{req} ) { require_module($_) foreach @$req; } $caches{$name} = $cache_generators{$name}->{code}->(); } catch { warn "error initializing '$name', will skip - $_"; }; } my @names = sort( keys(%caches) ); print "Drivers: " . join( ", ", @names ) . "\n"; my %counts; # Sets my $set_results; print "Benchmarking sets\n"; $set_results = timethese( -1 * $time, { map { my $name = $_; my $cache = $caches{$name}; my $key = 0; ( $name, sub { my $key = ( $counts{$name}++ % 100 ); $cache->set( $key, $value ); } ); } @names } ); # Gets my $get_results; print "Benchmarking gets\n"; $get_results = timethese( -1 * $time, { map { my $name = $_; my $cache = $caches{$name}; my $key = 0; ( $name, sub { my $key = ( $counts{$name}++ % 100 ); $cache->get($key); } ); } @names } ); my %colvalues; foreach my $name (@names) { my $generator = $cache_generators{$name}; my $get = ms_time( $get_results->{$name} ); my $set = ms_time( $set_results->{$name} ); my @colvalues = ( $name, $get . "ms", $set . "ms", $generator->{desc}, ); $colvalues{$name} = \@colvalues; } my $tb = Text::Table->new( 'Cache', "Get time\n&right", "Set time\n&right", 'Description' ); my $sort_field = $sort_by_name ? 0 : 1; my @rows = sort { $colvalues{$a}->[$sort_field] cmp $colvalues{$b}->[$sort_field] } keys(%colvalues); $tb->add( @{ $colvalues{$_} } ) for @rows; print $tb; sub ms_time { my $result = shift; return sprintf( "%0.3f", ( $result->[0] / $result->[5] ) * 1000 ); } sub cache_generators { return ( cache_cache_file => { req => ['Cache::FileCache'], desc => 'Cache::FileCache', code => sub { Cache::FileCache->new( { cache_root => "$data/cachecache/file", cache_depth => 2, } ); } }, cache_cache_memory => { req => ['Cache::MemoryCache'], desc => 'Cache::MemoryCache', code => sub { Cache::MemoryCache->new(); } }, cache_fastmmap => { req => ['Cache::FastMmap'], desc => 'Cache::FastMmap', code => sub { my $fastmmap_file = "$data/fastmmap.fm"; Cache::FastMmap->new( share_file => $fastmmap_file, ); } }, cache_memcached_lib => { req => ['Cache::Memcached::libmemcached'], desc => 'Cache::Memcached::libmemcached', code => sub { Cache::Memcached::libmemcached->new( { servers => ["localhost:11211"] }, ); } }, cache_memcached_fast => { req => ['Cache::Memcached::Fast'], desc => 'Cache::Memcached::Fast', code => sub { Cache::Memcached::Fast->new( { servers => ["localhost:11211"] } ); } }, cache_memcached_std => { req => ['Cache::Memcached'], desc => 'Cache::Memcached', code => sub { Cache::Memcached->new( { servers => ["localhost:11211"] } ); } }, cache_ref => { req => ['Cache::Ref::CART'], desc => 'Cache::Ref (CART)', code => sub { Cache::Ref::CART->new( size => 10000 ); } }, chi_berkeleydb => { req => ['CHI::Driver::BerkeleyDB'], desc => 'CHI::Driver::BerkeleyDB', code => sub { CHI->new( %common_chi_opts, driver => 'BerkeleyDB', root_dir => "$data/chi/berkeleydb", ); } }, chi_dbi_mysql => { req => [ 'CHI::Driver::DBI', 'DBD::mysql' ], desc => 'CHI::Driver::DBI (mysql)', code => sub { my $mysql_dbh = DBI->connect( "DBI:mysql:database=chibench;host=localhost", "chibench", "chibench" ); CHI->new( %common_chi_opts, driver => 'DBI', dbh => $mysql_dbh, create_table => 1, ); } }, chi_dbi_sqlite => { req => [ 'CHI::Driver::DBI', 'DBD::SQLite' ], desc => 'CHI::Driver::DBI (sqlite)', code => sub { my $sqlite_dbh = DBI->connect( "DBI:SQLite:dbname=$data/sqlite.db", "chibench", "chibench" ); CHI->new( %common_chi_opts, driver => 'DBI', dbh => $sqlite_dbh, create_table => 1, ); } }, chi_fastmmap => { desc => 'CHI::Driver::FastMmap', code => sub { CHI->new( %common_chi_opts, driver => 'FastMmap', root_dir => "$data/chi/fastmmap", ); } }, chi_file => { desc => 'CHI::Driver::File', code => sub { CHI->new( %common_chi_opts, driver => 'File', root_dir => "$data/chi/file", depth => 2 ); } }, chi_memcached_fast => { req => ['CHI::Driver::Memcached::Fast'], desc => 'CHI::Driver::Memcached::Fast', code => sub { CHI->new( %common_chi_opts, driver => 'Memcached::Fast', servers => ["localhost:11211"], ); } }, chi_memcached_lib => { req => ['CHI::Driver::Memcached::libmemcached'], desc => 'CHI::Driver::Memcached::libmemcached', code => sub { CHI->new( %common_chi_opts, driver => 'Memcached::libmemcached', servers => ["localhost:11211"], ); } }, chi_memcached_std => { req => ['CHI::Driver::Memcached'], desc => 'CHI::Driver::Memcached', code => sub { CHI->new( %common_chi_opts, driver => 'Memcached', servers => ["localhost:11211"], ); } }, chi_memory => { desc => 'CHI::Driver::Memory', code => sub { CHI->new( %common_chi_opts, driver => 'Memory', datastore => {}, ); } }, chi_memory_raw => { desc => 'CHI::Driver::RawMemory', code => sub { CHI->new( %common_chi_opts, driver => 'RawMemory', datastore => {}, ); }, }, ); } __END__ =head1 NAME bench.pl -- Benchmark cache modules against each other =head1 DESCRIPTION Uses L to compare a variety of CHI and non-CHI caches in terms of raw reading and writing speed. Sorts results by read performance. Does not attempt to test discard policies. =head1 SYNOPSIS bench.pl -d driver_regex [options] =head1 OPTIONS -d driver_regex Run drivers matching this regex (required) - use '.' for all -h --help Print help message -n Sort results by name instead of by read performance -t time Number of seconds to benchmark each operation (default 2) -x|--complex Use a complex data structure instead of a scalar Run bench.pl with no arguemnts to get a full list of available drivers. =head1 REQUIREMENTS =over =item * For the mysql drivers, run this as mysql root: create database chibench; grant all privileges on chibench.* to 'chibench'@'localhost' identified by 'chibench'; =item * For the memcached drivers, you'll need to start memcached on the default port (11211). =back =cut CHI-0.60/INSTALL0000644€ˆž«€q{Ì0000000156712535132431012573 0ustar jonswart This is the Perl distribution CHI. Installing CHI is straightforward. ## Installation with cpanm If you have cpanm, you only need one line: % cpanm CHI If you are installing into a system-wide directory, you may need to pass the "-S" flag to cpanm, which uses sudo to install the module: % cpanm -S CHI ## Installing with the CPAN shell Alternatively, if your CPAN shell is set up, you should just be able to do: % cpan CHI ## Manual installation As a last resort, you can manually install it. Download the tarball, untar it, then build it: % perl Makefile.PL % make && make test Then install it: % make install If you are installing into a system-wide directory, you may need to run: % sudo make install ## Documentation CHI documentation is available as POD. You can run perldoc from a shell to read the documentation: % perldoc CHI CHI-0.60/lib/0000775€ˆž«€q{Ì0000000000012535132431012301 5ustar jonswartCHI-0.60/lib/CHI/0000775€ˆž«€q{Ì0000000000012535132431012704 5ustar jonswartCHI-0.60/lib/CHI/Benchmarks.pod0000644€ˆž«€q{Ì0000000463012535132431015466 0ustar jonswart __END__ =pod =head1 NAME CHI::Benchmarks - Benchmarks of CHI and non-CHI drivers =head1 VERSION version 0.60 =head1 DESCRIPTION These benchmarks were created by running etc/bench/bench.pl -d . -t 10 -x for CHI 0.42, on OS X v10.6.6, 2.2 GHz Intel Core 2 Duo, Perl 5.12.2. For each cache, C does repeated gets and sets of a data structure for at least 10 seconds and measures the wallclock time per operation. These numbers should just be used as a rough guideline! Actual results will vary widely depending on system, get/set pattern, actual values being set, the proper tuning of memcached/mysql, etc. For best results run the benchmark script (available in this distribution) on your own system. Cache Get time Set time Description cache_ref 0.009ms 0.008ms Cache::Ref (CART) chi_memory_raw 0.019ms 0.036ms CHI::Driver::MemoryRaw cache_fastmmap 0.022ms 0.040ms Cache::FastMmap chi_memory 0.042ms 0.066ms CHI::Driver::Memory chi_berkeleydb 0.052ms 0.073ms CHI::Driver::BerkeleyDB chi_fastmmap 0.057ms 0.087ms CHI::Driver::FastMmap cache_cache_memory 0.065ms 0.070ms Cache::MemoryCache cache_memcached_fast 0.097ms 0.131ms Cache::Memcached::Fast chi_dbi_sqlite 0.112ms 1.659ms CHI::Driver::DBI (sqlite) cache_memcached_lib 0.118ms 0.156ms Cache::Memcached::libmemcached chi_file 0.118ms 1.138ms CHI::Driver::File chi_memcached_fast 0.138ms 0.178ms CHI::Driver::Memcached::Fast chi_memcached_lib 0.151ms 0.202ms CHI::Driver::Memcached::libmemcached chi_dbi_mysql 0.236ms 0.273ms CHI::Driver::DBI (mysql) cache_memcached_std 0.238ms 0.180ms Cache::Memcached chi_memcached_std 0.279ms 0.235ms CHI::Driver::Memcached cache_cache_file 0.481ms 1.391ms Cache::FileCache =head1 SEE ALSO L =head1 AUTHOR Jonathan Swartz =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2012 by Jonathan Swartz. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut CHI-0.60/lib/CHI/CacheObject.pm0000644€ˆž«€q{Ì0000001417612535132431015403 0ustar jonswartpackage CHI::CacheObject; $CHI::CacheObject::VERSION = '0.60'; use CHI::Constants qw(CHI_Max_Time); use Encode; use strict; use warnings; use constant f_key => 0; use constant f_raw_value => 1; use constant f_serializer => 2; use constant f_created_at => 3; use constant f_early_expires_at => 4; use constant f_expires_at => 5; use constant f_is_transformed => 6; use constant f_cache_version => 7; use constant f_value => 8; use constant f_packed_data => 9; use constant f_size => 10; use constant T_SERIALIZED => 1; use constant T_UTF8_ENCODED => 2; use constant T_COMPRESSED => 4; my $Metadata_Format = "LLLCC"; my $Metadata_Length = 14; # Eschewing Moose and hash-based objects for this class to get the extra speed. # Eventually will probably write in C anyway. sub key { $_[0]->[f_key] } sub created_at { $_[0]->[f_created_at] } sub early_expires_at { $_[0]->[f_early_expires_at] } sub expires_at { $_[0]->[f_expires_at] } sub serializer { $_[0]->[f_serializer] } sub _is_transformed { $_[0]->[f_is_transformed] } sub size { $_[0]->[f_size] } sub set_early_expires_at { $_[0]->[f_early_expires_at] = $_[1]; undef $_[0]->[f_packed_data]; } sub set_expires_at { $_[0]->[f_expires_at] = $_[1]; undef $_[0]->[f_packed_data]; } ## no critic (ProhibitManyArgs) sub new { my ( $class, $key, $value, $created_at, $early_expires_at, $expires_at, $serializer, $compress_threshold ) = @_; # Serialize/encode value if necessary - does this belong here, or in # Driver.pm? # my $is_transformed = 0; my $raw_value = $value; my $size; if ($serializer) { if ( ref($raw_value) ) { $raw_value = $serializer->serialize($raw_value); $is_transformed |= T_SERIALIZED; } elsif ( Encode::is_utf8($raw_value) ) { $raw_value = Encode::encode( utf8 => $raw_value ); $is_transformed |= T_UTF8_ENCODED; } if ( defined($compress_threshold) && length($raw_value) > $compress_threshold ) { require Compress::Zlib; $raw_value = Compress::Zlib::memGzip($raw_value); $is_transformed |= T_COMPRESSED; } $size = length($raw_value) + $Metadata_Length; } else { $size = 1; } # Not sure where this should be set and checked # my $cache_version = 1; return bless [ $key, $raw_value, $serializer, $created_at, $early_expires_at, $expires_at, $is_transformed, $cache_version, $value, undef, $size ], $class; } sub unpack_from_data { my ( $class, $key, $data, $serializer ) = @_; return $data if !$serializer; my $metadata = substr( $data, 0, $Metadata_Length ); my $raw_value = substr( $data, $Metadata_Length ); my $obj = bless [ $key, $raw_value, $serializer, unpack( $Metadata_Format, $metadata ) ], $class; $obj->[f_packed_data] = $data; $obj->[f_size] = length($data); return $obj; } sub pack_to_data { my ($self) = @_; return $self if !$self->serializer; if ( !defined( $self->[f_packed_data] ) ) { my $data = pack( $Metadata_Format, ( @{$self} )[ f_created_at .. f_cache_version ] ) . $self->[f_raw_value]; $self->[f_packed_data] = $data; } return $self->[f_packed_data]; } sub is_expired { my ($self) = @_; my $expires_at = $self->[f_expires_at]; return undef if $expires_at == CHI_Max_Time; my $time = $CHI::Driver::Test_Time || time(); my $early_expires_at = $self->[f_early_expires_at]; return $time >= $early_expires_at && ( $time >= $expires_at || ( rand() < ( ( $time - $early_expires_at ) / ( $expires_at - $early_expires_at ) ) ) ); } sub value { my ($self) = @_; if ( !defined $self->[f_value] ) { my $value = $self->[f_raw_value]; my $is_transformed = $self->[f_is_transformed]; if ( $is_transformed & T_COMPRESSED ) { require Compress::Zlib; $value = Compress::Zlib::memGunzip($value); } if ( $is_transformed & T_SERIALIZED ) { $value = $self->serializer->deserialize($value); } elsif ( $is_transformed & T_UTF8_ENCODED ) { $value = Encode::decode( utf8 => $value ); } $self->[f_value] = $value; } return $self->[f_value]; } # get_* aliases for backward compatibility with Cache::Cache # *get_created_at = \&created_at; *get_expires_at = \&expires_at; 1; __END__ =pod =head1 NAME CHI::CacheObject - Contains information about cache entries =head1 VERSION version 0.60 =head1 SYNOPSIS my $object = $cache->get_object($key); my $key = $object->key(); my $value = $object->value(); my $expires_at = $object->expires_at(); my $created_at = $object->created_at(); if ($object->is_expired()) { ... } =head1 DESCRIPTION The L method returns this object if the key exists. The object will be returned even if the entry has expired, as long as it has not been removed. There is currently no public API for creating one of these objects directly. =head1 METHODS All methods are read-only. The get_* methods are provided for backward compatibility with Cache::Cache's Cache::Object. =over =item key The key. =item value The value. =item expires_at =item get_expires_at Epoch time at which item expires. =item created_at =item get_created_at Epoch time at which item was last written to. =item is_expired Returns boolean indicating whether item has expired. This may be probabilistically determined if an L was used. =back =head1 SEE ALSO L =head1 AUTHOR Jonathan Swartz =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2012 by Jonathan Swartz. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut CHI-0.60/lib/CHI/Constants.pm0000644€ˆž«€q{Ì0000000153712535132431015222 0ustar jonswartpackage CHI::Constants; $CHI::Constants::VERSION = '0.60'; use strict; use warnings; use base qw(Exporter); my @all_constants = do { no strict 'refs'; grep { exists &$_ } keys %{ __PACKAGE__ . '::' }; }; our @EXPORT_OK = (@all_constants); our %EXPORT_TAGS = ( all => \@EXPORT_OK ); use constant CHI_Meta_Namespace => '_CHI_METACACHE'; use constant CHI_Max_Time => 0xffffffff; 1; __END__ =pod =head1 NAME CHI::Constants - Internal constants =head1 VERSION version 0.60 =head1 DESCRIPTION These are constants for internal CHI use. =head1 SEE ALSO L =head1 AUTHOR Jonathan Swartz =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2012 by Jonathan Swartz. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut CHI-0.60/lib/CHI/Driver/0000775€ˆž«€q{Ì0000000000012535132431014137 5ustar jonswartCHI-0.60/lib/CHI/Driver/Base/0000775€ˆž«€q{Ì0000000000012535132431015011 5ustar jonswartCHI-0.60/lib/CHI/Driver/Base/CacheContainer.pm0000644€ˆž«€q{Ì0000000255212535132431020217 0ustar jonswartpackage CHI::Driver::Base::CacheContainer; $CHI::Driver::Base::CacheContainer::VERSION = '0.60'; use Moo; use List::MoreUtils qw( all ); use strict; use warnings; extends 'CHI::Driver'; has '_contained_cache' => ( is => 'ro' ); sub fetch { my ( $self, $key ) = @_; return scalar( $self->_contained_cache->get($key) ); } sub store { my $self = shift; return $self->_contained_cache->set(@_); } sub remove { my ( $self, $key ) = @_; $self->_contained_cache->remove($key); } sub clear { my $self = shift; return $self->_contained_cache->clear(@_); } sub get_keys { my $self = shift; return $self->_contained_cache->get_keys(@_); } sub get_namespaces { my $self = shift; return $self->_contained_cache->get_namespaces(@_); } 1; __END__ =pod =head1 NAME CHI::Driver::Base::CacheContainer - Caches that delegate to a contained cache =head1 VERSION version 0.60 =head1 DESCRIPTION Role for CHI drivers with an internal '_contained_cache' slot that itself adheres to the Cache::Cache API, partially or completely. =head1 SEE ALSO L =head1 AUTHOR Jonathan Swartz =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2012 by Jonathan Swartz. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut CHI-0.60/lib/CHI/Driver/CacheCache.pm0000644€ˆž«€q{Ì0000000355012535132431016425 0ustar jonswartpackage CHI::Driver::CacheCache; $CHI::Driver::CacheCache::VERSION = '0.60'; use Cache::Cache; use Carp; use Moo; use MooX::Types::MooseLike::Base qw(:all); use Module::Runtime qw(require_module); use strict; use warnings; extends 'CHI::Driver::Base::CacheContainer'; has 'cc_class' => ( is => 'ro', isa => Str, required => 1 ); has 'cc_options' => ( is => 'ro', isa => HashRef, required => 1 ); sub BUILD { my ( $self, $params ) = @_; $self->{_contained_cache} = $self->_build_contained_cache; } sub _build_contained_cache { my ($self) = @_; my $cc_class = $self->{cc_class}; my $cc_options = $self->{cc_options}; my %subparams = ( namespace => $self->namespace ); require_module($cc_class); my %final_cc_params = ( %subparams, %{$cc_options} ); return $cc_class->new( \%final_cc_params ); } 1; __END__ =pod =head1 NAME CHI::Driver::CacheCache - CHI wrapper for Cache::Cache =head1 VERSION version 0.60 =head1 SYNOPSIS use CHI; my $cache = CHI->new( driver => 'CacheCache', cc_class => 'Cache::FileCache', cc_options => { cache_root => '/path/to/cache/root' }, ); =head1 DESCRIPTION This driver wraps any Cache::Cache cache. =head1 CONSTRUCTOR OPTIONS When using this driver, the following options can be passed to CHI->new() in addition to the L. =over =item cc_class Name of Cache::Cache class to create, e.g. Cache::FileCache. Required. =item cc_options Hashref of options to pass to Cache::Cache constructor. Required. =back =head1 SEE ALSO L =head1 AUTHOR Jonathan Swartz =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2012 by Jonathan Swartz. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut CHI-0.60/lib/CHI/Driver/Development.pod0000644€ˆž«€q{Ì0000001741012535132431017126 0ustar jonswart __END__ =pod =head1 NAME CHI::Driver::Development - Manual for developing new CHI drivers =head1 VERSION version 0.60 =head1 SYNOPSIS package CHI::Driver::MyDriver; use Moo; use strict; use warnings; extends 'CHI::Driver'; has ...; sub fetch { my ( $self, $key ) = @_; } sub store { my ( $self, $key, $data[, $expires_in] ) = @_; } sub remove { my ( $self, $key ) = @_; } sub clear { my ($self) = @_; } sub get_keys { my ($self) = @_; } sub get_namespaces { my ($self) = @_; } =head1 DESCRIPTION This document describes how to implement a new CHI driver. The easiest way to start is to look at existing drivers, such as L and L. =head1 NAMING If you are going to publicly release your driver, call it 'CHI::Driver::I' so that users can create it with CHI->new(driver => 'I'); If it's an internal driver, you can call it whatever you like and create it like CHI->new(driver => '+My::Internal::CHI::Driver'); =head1 MOO / MOOSE CHI driver classes must be L or L based to be fully functional, since we use Moose roles to implement various features. For backward compatibility, non-Moo/Moose drivers will still work at a basic level, but you will see an error if using any feature requiring a role. All drivers must directly or indirectly extend L. =head1 NAMESPACE All cache handles have an assigned namespace that you can access with C<$self-Enamespace>. You should use the namespace to partition your data store. That is, two cache objects with different namespaces should be able to access the same key without any collision. Examples: =over =item * The Memory driver uses a separate sub-hash inside its main memory hash for each namespace. =item * The File driver uses a separate top-level directory for each namespace. =item * The FastMmap driver uses a separate Cache::FastMmap file for each namespace. =back =head1 METHODS =head2 Required methods The following methods have no default implementation, and MUST be defined by your subclass: =over =item store ( $self, $key, $data[, $expires_in] ) Associate I<$data> with I<$key> in the namespace, overwriting any existing entry. Called by L. I<$data> will contain any necessary metadata, including expiration options, so you can just store it as a single block. I<$expires_in> is optionally the number of seconds from now when the entry will expire. This will only be passed if L is set. If your driver does not support expiration, or if you'd rather just let CHI manage expiration, you can ignore this. =item fetch ( $self, $key ) Returns the data associated with I<$key> in the namespace. Called by L. The main CHI::Driver superclass will take care of extracting out metadata like expiration options and determining if the value has expired. =item remove ( $self, $key ) Remove the data associated with the I<$key> in the namespace. =item clear ( $self ) Remove all data associated with the namespace. (Technically not required, but the default implementation, which iterates over all keys and calls L for each, is very inefficient). =back =head2 Overridable methods The following methods have a default implementation, but MAY be overridden by your subclass: =over =item BUILD ( $self, $options ) Define the BUILD method if you want to process any options specific to your driver. This is a standard Moo/Moose feature. =item fetch_multi_hashref ( $keys ) Override this if you want to efficiently process multiple fetches. Return a hash reference from keys to fetched data. If a key is not available, it may be left out of the hash or paired with undef. The default method will iterate over I<$keys> and call fetch for each. This method is called by L and L. =item store_multi ( $key_data, $options ) Override this if you want to efficiently process multiple stores. I<$key_data> is a hash of keys and data that should be stored. The default will iterate over I<$key_data> and call store for each pair. This method is called by L. =back =head2 Optional methods The following methods have no default implementation, and MAY be defined by your subclass, but are not required for basic cache operations. =over =item get_keys ( $self ) Return all keys in the namespace. It is acceptable to either include or omit expired keys. =item get_namespaces ( $self ) Return namespaces associated with the cache. It is acceptable to either include or omit namespaces with no valid keys. =back =head1 DISCARD POLICIES You can create new discard policies for L caches, to choose items to discard when the cache gets full. For example, the Memory driver implements an LRU policy. To implement a discard policy I, define a subroutine I, which takes a driver object and returns a closure that returns one key each time it is called. The closure should maintain state so that each key is only returned once. For example, here's the Memory driver's LRU implementation. It utilizes a hash containing the last used time for each key. sub discard_policy_lru { my ($self) = @_; my $last_used_time = $self->{metadata_for_namespace}->{last_used_time}; my @keys_in_lru_order = sort { $last_used_time->{$a} <=> $last_used_time->{$b} } $self->get_keys; return sub { shift(@keys_in_lru_order); }; } You can set the default discard policy for your driver by overriding default_discard_policy; otherwise the default is 'arbitrary'. sub default_discard_policy { 'lru' } =head1 TESTING CHI has a standard set of unit tests that should be used to ensure your driver is fully implementing the CHI API. To use CHI's tests (replacing I with the name of your driver): =over =item * Install L and add it to the build dependencies for your distribution. =item * Add a module called I to your distribution containing: package CHI::Driver::MyDriver::t::CHIDriverTests; use strict; use warnings; use CHI::Test; use base qw(CHI::t::Driver); sub testing_driver_class { 'CHI::Driver::MyDriver' } sub new_cache_options { my $self = shift; return ( $self->SUPER::new_cache_options(), # Any necessary CHI->new parameters for your test driver ); } 1; =item * Add a test script called I to your distribution containing: #!perl -w use strict; use warnings; use CHI::Driver::MyDriver::t::CHIDriverTests; CHI::Driver::MyDriver::t::CHIDriverTests->runtests; =item * You may need to override other methods in I, e.g. to skip tests that do not apply to your driver. See CHI::t::Driver::Memory and CHI::t::Driver::File in this distribution for examples. =back =head2 Test cleanup You are responsible for cleaning up your datastore after tests are done. The easiest way to do this is to place your datastore wholly inside a temporary directory, or use a L to remove it at process end. For example, the L, L, and L tests place all data inside a tempdir that is automatically cleaned up at process end. =head1 SEE ALSO L =head1 AUTHOR Jonathan Swartz =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2012 by Jonathan Swartz. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut CHI-0.60/lib/CHI/Driver/FastMmap.pm0000644€ˆž«€q{Ì0000000747212535132431016215 0ustar jonswartpackage CHI::Driver::FastMmap; $CHI::Driver::FastMmap::VERSION = '0.60'; use Carp; use Cache::FastMmap; use CHI::Util qw(read_dir); use File::Path qw(mkpath); use File::Spec::Functions qw(catdir catfile splitdir tmpdir); use Moo; use MooX::Types::MooseLike::Base qw(:all); use strict; use warnings; extends 'CHI::Driver::Base::CacheContainer'; has 'dir_create_mode' => ( is => 'ro', isa => Int, default => sub { oct(775) } ); has 'root_dir' => ( is => 'ro', isa => Str, default => sub { catdir( tmpdir(), "chi-driver-fastmmap" ) } ); sub BUILD { my ( $self, $params ) = @_; mkpath( $self->root_dir, 0, $self->dir_create_mode ) if !-d $self->root_dir; $self->{fm_params} = { raw_values => 1, unlink_on_exit => 0, share_file => catfile( $self->root_dir, $self->escape_for_filename( $self->namespace ) . ".dat" ), %{ $self->non_common_constructor_params($params) }, }; $self->{_contained_cache} = $self->_build_contained_cache; } sub _build_contained_cache { my ($self) = @_; return Cache::FastMmap->new( %{ $self->{fm_params} } ); } sub fm_cache { my $self = shift; return $self->_contained_cache(@_); } sub get_keys { my ($self) = @_; my @keys = $self->_contained_cache->get_keys(0); return @keys; } sub get_namespaces { my ($self) = @_; my $root_dir = $self->root_dir; my @contents = read_dir($root_dir); my @namespaces = map { $self->unescape_for_filename( substr( $_, 0, -4 ) ) } grep { /\.dat$/ } @contents; return @namespaces; } # Capture set failures sub store { my $self = shift; my $result = $self->_contained_cache->set(@_); if ( !$result ) { my ( $key, $value ) = @_; croak( sprintf( "fastmmap set failed - value too large? (%d bytes)", length($value) ) ); } } 1; __END__ =pod =head1 NAME CHI::Driver::FastMmap - Persistent interprocess cache via mmap'ed files =head1 VERSION version 0.60 =head1 SYNOPSIS use CHI; my $cache = CHI->new( driver => 'FastMmap', root_dir => '/path/to/cache/root', cache_size => '1m' ); =head1 DESCRIPTION This cache driver uses Cache::FastMmap to store data in an mmap'ed file. It is very fast, and can be used to share data between processes on a single host, though not between hosts. To support namespaces, this driver takes a directory parameter rather than a file, and creates one Cache::FastMMap file for each namespace. Because CHI handles serialization automatically, we pass the C flag as 1; and to conform to the CHI API, we pass C as 0, so that all cache files are permanent. =head1 REQUIREMENTS You will need to install L from CPAN to use this driver. =head1 CONSTRUCTOR OPTIONS =over =item root_dir Path to the directory that will contain the share files, one per namespace. Defaults to a directory called 'chi-driver-fastmmap' under the OS default temp directory (e.g. '/tmp' on UNIX). =item dir_create_mode Permissions mode to use when creating directories. Defaults to 0775. =back Any other constructor options L are passed along to Lnew>. =head1 METHODS =over =item fm_cache Returns a handle to the underlying Cache::FastMmap object. You can use this to call FastMmap-specific methods that are not supported by the general API, e.g. $self->fm_cache->get_and_set("key", sub { ... }); =back =head1 SEE ALSO L =head1 AUTHOR Jonathan Swartz =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2012 by Jonathan Swartz. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut CHI-0.60/lib/CHI/Driver/File.pm0000644€ˆž«€q{Ì0000002371212535132431015357 0ustar jonswartpackage CHI::Driver::File; $CHI::Driver::File::VERSION = '0.60'; use Carp; use Cwd qw(realpath cwd); use CHI::Util qw(fast_catdir fast_catfile unique_id read_dir read_file write_file); use Digest::JHash qw(jhash); use File::Basename qw(basename dirname); use File::Find qw(find); use File::Path qw(mkpath rmtree); use File::Spec::Functions qw(catdir catfile splitdir tmpdir); use Log::Any qw($log); use Moo; use MooX::Types::MooseLike::Base qw(:all); use strict; use warnings; extends 'CHI::Driver'; has '+max_key_length' => ( default => sub { 248 } ); has 'depth' => ( is => 'ro', isa => Int, default => sub { 2 } ); has 'dir_create_mode' => ( is => 'ro', isa => Int, default => sub { oct(775) } ); has 'file_create_mode' => ( is => 'ro', isa => Int, default => sub { oct(666) } ); has 'file_extension' => ( is => 'ro', isa => Str, default => sub { '.dat' } ); has 'path_to_namespace' => ( is => 'lazy' ); has 'root_dir' => ( is => 'ro', isa => Str, default => sub { catdir( tmpdir(), 'chi-driver-file' ) } ); sub BUILDARGS { my ( $class, %params ) = @_; # Backward compat # if ( defined( $params{key_digest} ) ) { $params{key_digester} = $params{key_digest}; $params{max_key_length} = 0; } return \%params; } sub _build_path_to_namespace { my $self = shift; my $namespace = $self->escape_for_filename( $self->namespace ); $namespace = $self->digest_key($namespace) if length($namespace) > $self->max_key_length; return catdir( $self->root_dir, $namespace ); } # Escape key to make safe for filesystem; if it then grows larger than # max_key_length, digest it. # sub escape_key { my ( $self, $key ) = @_; my $new_key = $self->escape_for_filename($key); if ( length($new_key) > length($key) && length($new_key) > $self->max_key_length() ) { $new_key = $self->digest_key($new_key); } return $new_key; } sub unescape_key { my ( $self, $key ) = @_; return $self->unescape_for_filename($key); } sub fetch { my ( $self, $key ) = @_; my $file = $self->path_to_key($key); if ( defined $file && -f $file ) { return read_file($file); } else { return undef; } } sub store { my ( $self, $key, $data ) = @_; my $dir; my $file = $self->path_to_key( $key, \$dir ) or return undef; mkpath( $dir, 0, $self->{dir_create_mode} ) if !-d $dir; # Possibly generate a temporary file - if generate_temporary_filename returns undef, # store to the destination file directly # my $temp_file = $self->generate_temporary_filename( $dir, $file ); my $store_file = defined($temp_file) ? $temp_file : $file; write_file( $store_file, $data, $self->{file_create_mode} ); if ( defined($temp_file) ) { # Rename can fail in rare race conditions...try multiple times # for ( my $try = 0 ; $try < 3 ; $try++ ) { last if ( rename( $temp_file, $file ) ); } if ( -f $temp_file ) { my $error = $!; unlink($temp_file); die "could not rename '$temp_file' to '$file': $error"; } } } sub remove { my ( $self, $key ) = @_; my $file = $self->path_to_key($key) or return undef; unlink($file); } sub clear { my ($self) = @_; my $namespace_dir = $self->path_to_namespace; return if !-d $namespace_dir; my $renamed_dir = join( ".", $namespace_dir, unique_id() ); rename( $namespace_dir, $renamed_dir ); rmtree($renamed_dir); die "could not remove '$renamed_dir'" if -d $renamed_dir; } sub get_keys { my ($self) = @_; my @filepaths; my $re = quotemeta( $self->file_extension ); my $wanted = sub { push( @filepaths, $_ ) if -f && /${re}$/ }; my @keys = $self->_collect_keys_via_file_find( \@filepaths, $wanted ); return @keys; } sub _collect_keys_via_file_find { my ( $self, $filepaths, $wanted ) = @_; my $namespace_dir = $self->path_to_namespace; return () if !-d $namespace_dir; find( { wanted => $wanted, no_chdir => 1 }, $namespace_dir ); my @keys; my $key_start = length($namespace_dir) + 1 + $self->depth * 2; my $subtract = -1 * length( $self->file_extension ); foreach my $filepath (@$filepaths) { my $key = substr( $filepath, $key_start, $subtract ); $key = $self->unescape_key( join( "", splitdir($key) ) ); push( @keys, $key ); } return @keys; } sub generate_temporary_filename { my ( $self, $dir, $file ) = @_; # Generate a temporary filename using unique_id - faster than tempfile, as long as # we don't need automatic removal. # Note: $file not used here, but might be used in an override. # return fast_catfile( $dir, unique_id() ); } sub get_namespaces { my ($self) = @_; my $root_dir = $self->root_dir(); return () if !-d $root_dir; my @contents = read_dir($root_dir); my @namespaces = map { $self->unescape_for_filename($_) } grep { $self->is_escaped_for_filename($_) } grep { -d fast_catdir( $root_dir, $_ ) } @contents; return @namespaces; } my %hex_strings = map { ( $_, sprintf( "%x", $_ ) ) } ( 0x0 .. 0xf ); sub path_to_key { my ( $self, $key, $dir_ref ) = @_; return undef if !defined($key); my @paths = ( $self->path_to_namespace ); my $orig_key = $key; $key = $self->escape_key($key); # Hack: If key is exactly 32 hex chars, assume it's an md5 digest and # take a prefix of it for bucket. Digesting will usually happen in # transform_key and there's no good way for us to know it occurred. # if ( $key =~ /^[0-9a-f]{32}$/ ) { push( @paths, map { substr( $key, $_, 1 ) } ( 0 .. $self->{depth} - 1 ) ); } else { # Hash key to a 32-bit integer (using non-escaped key for back compat) # my $bucket = jhash($orig_key); # Create $self->{depth} subdirectories, containing a maximum of 64 # subdirectories each, by successively shifting 4 bits off the # bucket and converting to hex. # for ( my $d = $self->{depth} ; $d > 0 ; $d-- ) { push( @paths, $hex_strings{ $bucket & 0xf } ); $bucket >>= 4; } } # Join paths together, computing dir separately if $dir_ref was passed. # my $filename = $key . $self->file_extension; my $filepath; if ( defined $dir_ref && ref($dir_ref) ) { my $dir = fast_catdir(@paths); $filepath = fast_catfile( $dir, $filename ); $$dir_ref = $dir; } else { $filepath = fast_catfile( @paths, $filename ); } return $filepath; } 1; __END__ =pod =head1 NAME CHI::Driver::File - File-based cache using one file per entry in a multi-level directory structure =head1 VERSION version 0.60 =head1 SYNOPSIS use CHI; my $cache = CHI->new( driver => 'File', root_dir => '/path/to/cache/root', depth => 3, max_key_length => 64 ); =head1 DESCRIPTION This cache driver stores data on the filesystem, so that it can be shared between processes on a single machine, or even on multiple machines if using NFS. Each item is stored in its own file. By default, during a set, a temporary file is created and then atomically renamed to the proper file. While not the most efficient, it eliminates the need for locking (with multiple overlapping sets, the last one "wins") and makes this cache usable in environments like NFS where locking might normally be undesirable. By default, the base filename is the key itself, with unsafe characters escaped similar to URL escaping. If the escaped key is larger than L (default 248 characters), it will be L. You may want to lower L if you are storing a lot of items as long filenames can be more expensive to work with. The files are evenly distributed within a multi-level directory structure with a customizable L, to minimize the time needed to search for a given entry. =head1 CONSTRUCTOR OPTIONS When using this driver, the following options can be passed to CHI->new() in addition to the L. =over =item root_dir The location in the filesystem that will hold the root of the cache. Defaults to a directory called 'chi-driver-file' under the OS default temp directory (e.g. '/tmp' on UNIX). This directory will be created as needed on the first cache set. =item depth The number of subdirectories deep to place cache files. Defaults to 2. This should be large enough that no leaf directory has more than a few hundred files. Each non-leaf directory contains up to 16 subdirectories (0-9, A-F). =item dir_create_mode Permissions mode to use when creating directories. Defaults to 0775. =item file_create_mode Permissions mode to use when creating files, modified by the current umask. Defaults to 0666. =item file_extension Extension to append to filename. Default is C<.dat>. =back =head1 METHODS =over =item path_to_key ( $key ) Returns the full path to the cache file representing $key, whether or not that entry exists. Returns the empty list if a valid path cannot be computed, for example if the key is too long. =item path_to_namespace Returns the full path to the directory representing this cache's namespace, whether or not it has any entries. =back =head1 TEMPORARY FILE RENAME By default, during a set, a temporary file is created and then atomically renamed to the proper file. This eliminates the need for locking. You can subclass and override method I to either change the path of the temporary filename, or skip the temporary file and rename altogether by having it return undef. =head1 SEE ALSO L =head1 AUTHOR Jonathan Swartz =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2012 by Jonathan Swartz. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut CHI-0.60/lib/CHI/Driver/Memory.pm0000644€ˆž«€q{Ì0000001107312535132431015745 0ustar jonswartpackage CHI::Driver::Memory; $CHI::Driver::Memory::VERSION = '0.60'; use Carp qw(cluck croak); use CHI::Constants qw(CHI_Meta_Namespace); use Moo; use MooX::Types::MooseLike::Base qw(:all); use strict; use warnings; extends 'CHI::Driver'; our %Global_Datastore = (); ## no critic (ProhibitPackageVars) has 'datastore' => ( is => 'ro', isa => HashRef ); has 'global' => ( is => 'ro', isa => Bool ); sub default_discard_policy { 'lru' } # We see a lot of repeated '$self->{datastore}->{$self->{namespace}}' # expressions below. The reason this cannot be easily memoized in the object # is that we want the cache to be cleared across multiple existing CHI # objects when the datastore itself is emptied - e.g. %datastore = () # sub BUILD { my ( $self, $params ) = @_; if ( defined $self->{global} ) { croak "cannot specify both 'datastore' and 'global'" if ( defined( $self->{datastore} ) ); $self->{datastore} = $self->{global} ? \%Global_Datastore : {}; } if ( !defined( $self->{datastore} ) ) { cluck "must specify either 'datastore' hashref or 'global' flag"; $self->{datastore} = \%Global_Datastore; } } sub fetch { my ( $self, $key ) = @_; if ( $self->{is_size_aware} ) { $self->{datastore}->{ CHI_Meta_Namespace() }->{last_used_time}->{$key} = time; } return $self->{datastore}->{ $self->{namespace} }->{$key}; } sub store { my ( $self, $key, $data ) = @_; $self->{datastore}->{ $self->{namespace} }->{$key} = $data; } sub remove { my ( $self, $key ) = @_; delete $self->{datastore}->{ $self->{namespace} }->{$key}; delete $self->{datastore}->{ CHI_Meta_Namespace() }->{last_used_time} ->{$key}; } sub clear { my ($self) = @_; $self->{datastore}->{ $self->{namespace} } = {}; } sub get_keys { my ($self) = @_; return keys( %{ $self->{datastore}->{ $self->{namespace} } } ); } sub get_namespaces { my ($self) = @_; return keys( %{ $self->{datastore} } ); } sub discard_policy_lru { my ($self) = @_; my $last_used_time = $self->{datastore}->{ CHI_Meta_Namespace() }->{last_used_time}; my @keys_in_lru_order = sort { $last_used_time->{$a} <=> $last_used_time->{$b} } $self->get_keys; return sub { shift(@keys_in_lru_order); }; } 1; __END__ =pod =head1 NAME CHI::Driver::Memory - In-process memory based cache =head1 VERSION version 0.60 =head1 SYNOPSIS use CHI; my $hash = {}; my $cache = CHI->new( driver => 'Memory', datastore => $hash ); my $cache = CHI->new( driver => 'Memory', global => 1 ); my $cache = CHI->new( driver => 'Memory', global => 0 ); =head1 DESCRIPTION This cache driver stores data on a per-process basis. This is the fastest of the cache implementations, but data can not be shared between processes. Data will remain in the cache until cleared, expired, or the process dies. To maintain the same semantics as other caches, references to data structures are deep-copied on set and get. Thus, modifications to the original data structure will not affect the data structure stored in the cache, and vice versa. See L for a faster memory cache that sacrifices this behavior. =head1 CONSTRUCTOR OPTIONS When using this driver, the following options can be passed to CHI->new() in addition to the L. One of I or I must be specified, or else a warning (possibly an error eventually) will be thrown. =over =item datastore [HASHREF] A reference to a hash to be used for storage. Within the hash, each namespace is used as a key to a second-level hash. This hash may be passed to multiple CHI::Driver::Memory constructors. =item global [BOOL] Use a standard global datastore. Multiple caches created with this set to true will see the same data. Before 0.21, this was the default behavior; now it must be specified explicitly (to avoid accidentally sharing the same datastore in unrelated code). If this is set to false then datastore will be set to a new reference to a hash. =back =head1 DISCARD POLICY For L caches, this driver implements an 'LRU' policy, which discards the least recently used items first. This is the default policy. =head1 SEE ALSO L, L =head1 AUTHOR Jonathan Swartz =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2012 by Jonathan Swartz. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut CHI-0.60/lib/CHI/Driver/Metacache.pm0000644€ˆž«€q{Ì0000000356312535132431016354 0ustar jonswartpackage CHI::Driver::Metacache; $CHI::Driver::Metacache::VERSION = '0.60'; use CHI::Constants qw(CHI_Meta_Namespace); use Moo; use strict; use warnings; has 'meta_cache' => ( is => 'lazy', clearer => 'clear_meta_cache', predicate => 'has_meta_cache' ); has 'owner_cache' => ( is => 'ro', weak_ref => 1 ); has 'owner_namespace' => ( is => 'lazy', clearer => 'clear_owner_namespace', predicate => 'has_owner_namespace' ); sub _build_meta_cache { my ($self) = @_; my $owner_cache = $self->owner_cache; my %params = %{ $owner_cache->constructor_params }; delete( @params{qw(l1_cache mirror_cache parent_cache chi_root_class)} ); $params{label} = $owner_cache->label . " (meta)"; $params{namespace} = CHI_Meta_Namespace; return $owner_cache->chi_root_class->new(%params); } sub _build_owner_namespace { my ($self) = @_; return $self->owner_cache->namespace; } sub get { my ( $self, $key ) = @_; return $self->meta_cache->fetch( $self->_prefixed_key($key) ); } sub set { my ( $self, $key, $value ) = @_; return $self->meta_cache->store( $self->_prefixed_key($key), $value ); } sub remove { my ( $self, $key, $value ) = @_; return $self->meta_cache->remove( $self->_prefixed_key($key) ); } sub _prefixed_key { my ( $self, $key ) = @_; return $self->owner_namespace . ":" . $key; } 1; __END__ =pod =head1 NAME CHI::Driver::Metacache - Metacache for internal CHI use =head1 VERSION version 0.60 =head1 SYNOPSIS $cache->metacache->get($meta_key); $cache->metacache->set($meta_key => $value); =head1 SEE ALSO L =head1 AUTHOR Jonathan Swartz =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2012 by Jonathan Swartz. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut CHI-0.60/lib/CHI/Driver/Null.pm0000644€ˆž«€q{Ì0000000202512535132431015404 0ustar jonswartpackage CHI::Driver::Null; $CHI::Driver::Null::VERSION = '0.60'; use Moo; use strict; use warnings; extends 'CHI::Driver'; sub fetch { undef } sub store { undef } sub remove { undef } sub clear { undef } sub get_keys { return () } sub get_namespaces { return () } 1; __END__ =pod =head1 NAME CHI::Driver::Null - Nothing is cached =head1 VERSION version 0.60 =head1 SYNOPSIS use CHI; my $cache = CHI->new(driver => 'Null'); $cache->set('key', 5); my $value = $cache->get('key'); # returns undef =head1 DESCRIPTION This cache driver implements the full CHI interface without ever actually storing items. Useful for disabling caching in an application, for example. =head1 SEE ALSO L =head1 AUTHOR Jonathan Swartz =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2012 by Jonathan Swartz. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut CHI-0.60/lib/CHI/Driver/RawMemory.pm0000644€ˆž«€q{Ì0000000464412535132431016425 0ustar jonswartpackage CHI::Driver::RawMemory; $CHI::Driver::RawMemory::VERSION = '0.60'; use Moo; use strict; use warnings; extends 'CHI::Driver::Memory'; has 'serializer' => ( is => 'ro', init_arg => undef ); sub append { my ( $self, $key, $new ) = @_; return "append not yet supported in this driver"; } 1; __END__ =pod =head1 NAME CHI::Driver::RawMemory - In-process memory cache that stores direct references =head1 VERSION version 0.60 =head1 SYNOPSIS use CHI; my $hash = {}; my $cache = CHI->new( driver => 'RawMemory', datastore => $hash ); my $cache = CHI->new( driver => 'RawMemory', global => 1 ); my $cache = CHI->new( driver => 'RawMemory', global => 0 ); =head1 DESCRIPTION This is a subclass of L that stores references to data structures directly instead of serializing / deserializing. This makes the cache faster at getting and setting complex data structures, but unlike most drivers, modifications to the original data structure I affect the data structure stored in the cache, and vice versa. e.g. my $cache = CHI->new( driver => 'Memory', global => 1 ); my $lst = ['foo']; $cache->set('key' => $lst); # serializes $lst before storing $cache->get('key'); # returns ['foo'] $lst->[0] = 'bar'; $cache->get('key'); # returns ['foo'] my $cache = CHI->new( driver => 'RawMemory', global => 1 ); my $lst = ['foo']; $cache->set('key' => $lst); # stores $lst directly $cache->get('key'); # returns ['foo'] $lst->[0] = 'bar'; $cache->get('key'); # returns ['bar']! =head1 CONSTRUCTOR OPTIONS Same as L. =head1 SIZE AWARENESS For the purpose of L, all items count as size 1 for this driver. (Because data structures are not serialized, there's no good way to determine their size.) # Keep a maximum of 10 items in cache # my $cache = CHI->new( driver => 'RawMemory', datastore => {}, max_size => 10 ); =head1 ACKNOWLEDGMENTS Thanks to Yuval Kogman whose L inspired me to do this. =head1 SEE ALSO L, L =head1 AUTHOR Jonathan Swartz =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2012 by Jonathan Swartz. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut CHI-0.60/lib/CHI/Driver/Role/0000775€ˆž«€q{Ì0000000000012535132431015040 5ustar jonswartCHI-0.60/lib/CHI/Driver/Role/HasSubcaches.pm0000644€ˆž«€q{Ì0000001037512535132431017736 0ustar jonswartpackage CHI::Driver::Role::HasSubcaches; $CHI::Driver::Role::HasSubcaches::VERSION = '0.60'; use Moo::Role; use CHI::Types qw(:all); use MooX::Types::MooseLike::Base qw(:all); use Hash::MoreUtils qw(slice_exists); use Log::Any qw($log); use Scalar::Util qw(weaken); use strict; use warnings; my @subcache_nonoverride_params = qw(expires_at expires_in expires_variance serializer); sub _non_overridable { my $params = shift; if ( is_HashRef($params) ) { if ( my @nonoverride = grep { exists $params->{$_} } @subcache_nonoverride_params ) { warn sprintf( "cannot override these keys in a subcache: %s", join( ", ", @nonoverride ) ); delete( @$params{@nonoverride} ); } } return $params; } my @subcache_inherited_params = ( qw(expires_at expires_in expires_variance namespace on_get_error on_set_error serializer) ); for my $type (qw(l1_cache mirror_cache)) { my $config_acc = "_${type}_config"; has $config_acc => ( is => 'ro', init_arg => $type, isa => HashRef, coerce => \&_non_overridable, ); my $default = sub { my $self = shift; my $config = $self->$config_acc or return undef; my %inherit = map { ( defined $self->$_ ) ? ( $_ => $self->$_ ) : () } @subcache_inherited_params; my $build_config = { %inherit, label => $self->label . ":$type", %$config, is_subcache => 1, parent_cache => $self, subcache_type => $type, }; return $self->chi_root_class->new(%$build_config); }; has $type => ( is => 'ro', lazy => 1, init_arg => undef, default => $default, isa => Maybe [ InstanceOf ['CHI::Driver'] ], ); } has subcaches => ( is => 'lazy', init_arg => undef, ); sub _build_subcaches { [ grep { defined $_ } $_[0]->l1_cache, $_[0]->mirror_cache ]; } sub _build_has_subcaches { 1 } # Call these methods first on the main cache, then on any subcaches. # foreach my $method (qw(clear expire purge remove set)) { after $method => sub { my $self = shift; my $subcaches = $self->subcaches; foreach my $subcache (@$subcaches) { $subcache->$method(@_); } }; } around 'get' => sub { my $orig = shift; my $self = shift; my ( $key, %params ) = @_; my $l1_cache = $self->l1_cache; if ( !defined($l1_cache) || $params{obj} ) { return $self->$orig(@_); } else { # Consult l1 cache first # if ( defined( my $value = $l1_cache->get(@_) ) ) { return $value; } else { my ( $key, %params ) = @_; $params{obj_ref} ||= \my $obj_store; my $value = $self->$orig( $key, %params ); if ( defined($value) ) { # If found in primary cache, write back to l1 cache. # my $obj = ${ $params{obj_ref} }; $l1_cache->set( $key, $obj->value, { expires_at => $obj->expires_at, early_expires_at => $obj->early_expires_at } ); } return $value; } } }; around 'get_multi_arrayref' => sub { my $orig = shift; my $self = shift; my ($keys) = @_; my $l1_cache = $self->l1_cache; if ( !defined($l1_cache) ) { return $self->$orig(@_); } else { # Consult l1 cache first, then call on primary cache with remainder of keys, # and combine the arrays. # my $l1_values = $l1_cache->get_multi_arrayref($keys); my @indices = ( 0 .. scalar(@$keys) - 1 ); my @primary_keys = map { $keys->[$_] } grep { !defined( $l1_values->[$_] ) } @indices; my $primary_values = $self->$orig( \@primary_keys ); my $values = [ map { defined( $l1_values->[$_] ) ? $l1_values->[$_] : shift(@$primary_values) } @indices ]; return $values; } }; 1; CHI-0.60/lib/CHI/Driver/Role/IsSizeAware.pm0000644€ˆž«€q{Ì0000001026412535132431017565 0ustar jonswartpackage CHI::Driver::Role::IsSizeAware; $CHI::Driver::Role::IsSizeAware::VERSION = '0.60'; use Carp::Assert; use Moo::Role; use MooX::Types::MooseLike::Base qw(:all); use CHI::Types qw(:all); use strict; use warnings; has 'discard_policy' => ( is => 'lazy', isa => Maybe[DiscardPolicy] ); has 'discard_timeout' => ( is => 'rw', isa => Num, default => sub { 10 } ); has 'max_size' => ( is => 'rw', isa => MemorySize, coerce => \&to_MemorySize ); has 'max_size_reduction_factor' => ( is => 'rw', isa => Num, default => sub { 0.8 } ); use constant Size_Key => 'CHI_IsSizeAware_size'; sub _build_discard_policy { my $self = shift; return $self->can('default_discard_policy') ? $self->default_discard_policy : 'arbitrary'; } after 'BUILD_roles' => sub { my ( $self, $params ) = @_; $self->{is_size_aware} = 1; }; after 'clear' => sub { my $self = shift; $self->_set_size(0); }; around 'remove' => sub { my $orig = shift; my $self = shift; my ($key) = @_; my ( $size_delta, $obj ); if ( !$self->{_no_set_size_on_remove} && ( $obj = $self->get_object($key) ) ) { $size_delta = -1 * $obj->size; } $self->$orig(@_); if ($size_delta) { $self->_add_to_size($size_delta); } }; around 'set_object' => sub { my ( $orig, $self, $key, $obj ) = @_; # If item exists, record its size so we can subtract it below # my $size_delta = 0; if ( my $obj = $self->get_object($key) ) { $size_delta = -1 * $obj->size; } my $result = $self->$orig( $key, $obj ); # Add to size and reduce size if over the maximum # $size_delta += $obj->size; my $namespace_size = $self->_add_to_size($size_delta); if ( defined( $self->max_size ) && $namespace_size > $self->max_size ) { $self->discard_to_size( $self->max_size * $self->max_size_reduction_factor ); } return $result; }; sub get_size { my ($self) = @_; my $size = $self->metacache->get(Size_Key) || 0; return $size; } sub _set_size { my ( $self, $new_size ) = @_; $self->metacache->set( Size_Key, $new_size ); } sub _add_to_size { my ( $self, $incr ) = @_; # Non-atomic, so may be inaccurate over time my $new_size = ( $self->get_size || 0 ) + $incr; $self->_set_size($new_size); return $new_size; } sub discard_to_size { my ( $self, $ceiling ) = @_; # Get an iterator that produces keys in the order they should be removed # my $discard_iterator = $self->_get_iterator_for_discard_policy( $self->discard_policy ); # Remove keys until we are under $ceiling. Temporarily turn off size # setting on remove because we will set size once at end. Check if # we exceed discard timeout. # my $end_time = time + $self->discard_timeout; local $self->{_no_set_size_on_remove} = 1; my $size = $self->get_size(); eval { while ( $size > $ceiling ) { if ( defined( my $key = $discard_iterator->() ) ) { if ( my $obj = $self->get_object($key) ) { $self->remove($key); $size -= $obj->size; } } else { affirm { $self->is_empty } "iterator returned undef, cache should be empty"; last; } if ( time > $end_time ) { die sprintf( "discard timeout (%s sec) reached", $self->discard_timeout ); } } }; $self->_set_size($size); die $@ if $@; } sub _get_iterator_for_discard_policy { my ( $self, $discard_policy ) = @_; if ( ref($discard_policy) eq 'CODE' ) { return $discard_policy->($self); } else { my $discard_policy_sub = "discard_policy_" . $discard_policy; if ( $self->can($discard_policy_sub) ) { return $self->$discard_policy_sub(); } else { die sprintf( "cannot get iterator for discard policy '%s' ('%s')", $discard_policy, $discard_policy_sub ); } } } sub discard_policy_arbitrary { my ($self) = @_; return $self->get_keys_iterator(); } 1; CHI-0.60/lib/CHI/Driver/Role/IsSubcache.pm0000644€ˆž«€q{Ì0000000034412535132431017406 0ustar jonswartpackage CHI::Driver::Role::IsSubcache; $CHI::Driver::Role::IsSubcache::VERSION = '0.60'; use Moo::Role; use strict; use warnings; has 'parent_cache' => ( is => 'ro', weak_ref => 1 ); has 'subcache_type' => ( is => 'ro' ); 1; CHI-0.60/lib/CHI/Driver/Role/Universal.pm0000644€ˆž«€q{Ì0000000120112535132431017336 0ustar jonswartpackage CHI::Driver::Role::Universal; $CHI::Driver::Role::Universal::VERSION = '0.60'; use CHI::Constants qw(CHI_Meta_Namespace); use Moo::Role; use strict; use warnings; around 'get_namespaces' => sub { my $orig = shift; my $self = shift; # Call driver get_namespaces, then filter out meta-namespace return grep { $_ ne CHI_Meta_Namespace } $self->$orig(@_); }; foreach my $method (qw(remove append)) { around $method => sub { my ( $orig, $self, $key, @rest ) = @_; # Call transform_key before passing to method return $self->$orig( $self->transform_key($key), @rest ); }; } 1; __END__ CHI-0.60/lib/CHI/Driver.pm0000644€ˆž«€q{Ì0000005401712535132431014502 0ustar jonswartpackage CHI::Driver; $CHI::Driver::VERSION = '0.60'; use Carp; use CHI::CacheObject; use CHI::Constants qw(CHI_Max_Time); use CHI::Driver::Metacache; use CHI::Driver::Role::HasSubcaches; use CHI::Driver::Role::IsSizeAware; use CHI::Driver::Role::IsSubcache; use CHI::Driver::Role::Universal; use CHI::Serializer::Storable; use CHI::Serializer::JSON; use CHI::Util qw(parse_duration); use CHI::Types qw(:all); use Digest::MD5; use Encode; use Hash::MoreUtils qw(slice_grep); use Log::Any qw($log); use Moo; use MooX::Types::MooseLike::Base qw(:all); use Scalar::Util qw(blessed); use Time::Duration; use Time::HiRes qw(gettimeofday); use strict; use warnings; my $default_serializer = CHI::Serializer::Storable->new(); my $default_key_serializer = CHI::Serializer::JSON->new(); my $default_key_digester = Digest::MD5->new(); my @common_params; { my %attr = ( chi_root_class => { is => 'ro', }, compress_threshold => { is => 'ro', isa => Int, }, constructor_params => { is => 'ro', init_arg => undef, }, driver_class => { is => 'ro', }, expires_at => { is => 'rw', default => sub { CHI_Max_Time }, }, expires_in => { is => 'rw', isa => Duration, coerce => \&to_Duration, }, expires_on_backend => { is => 'ro', isa => Num, default => sub { 0 }, }, expires_variance => { is => 'rw', isa => Num, default => sub { 0 }, }, has_subcaches => { is => 'lazy', isa => Bool, init_arg => undef, }, is_size_aware => { is => 'ro', isa => Bool, }, is_subcache => { is => 'ro', isa => Bool, }, key_digester => { is => 'ro', isa => Digester, coerce => \&to_Digester, default => sub { $default_key_digester }, }, key_serializer => { is => 'ro', isa => Serializer, coerce => \&to_Serializer, default => sub { $default_key_serializer }, }, label => { is => 'rw', lazy => 1, builder => 1, clearer => 1, predicate => 1, }, max_build_depth => { is => 'ro', default => sub { 8 }, }, max_key_length => { is => 'ro', isa => Int, default => sub { 1 << 31 }, }, metacache => { is => 'lazy', clearer => 1, predicate => 1, }, namespace => { is => 'ro', isa => Str, default => sub { 'Default' }, }, on_get_error => { is => 'rw', isa => OnError, default => sub { 'log' }, }, on_set_error => { is => 'rw', isa => OnError, default => sub { 'log' }, }, serializer => { is => 'ro', isa => Serializer, coerce => \&to_Serializer, default => sub { $default_serializer }, }, short_driver_name => { is => 'lazy', clearer => 1, predicate => 1, }, storage => { is => 'ro', }, ); push @common_params, keys %attr; for my $attr ( keys %attr ) { has $attr => %{ $attr{$attr} }; } } sub _build_has_subcaches { undef } # These methods must be implemented by subclass foreach my $method (qw(fetch store remove get_keys get_namespaces)) { no strict 'refs'; *{$method} = sub { die "method '$method' must be implemented by subclass" }; } # Given a hash of params, return the subset that are not in CHI's common parameters. # push @common_params, qw( discard_policy discard_timeout l1_cache max_size max_size_reduction_factor mirror_cache parent_cache subcache_type subcaches ); my %common_params = map { ( $_, 1 ) } @common_params; sub non_common_constructor_params { my ( $class, $params ) = @_; return { map { ( $_, $params->{$_} ) } grep { !$common_params{$_} } keys(%$params) }; } sub declare_unsupported_methods { my ( $class, @methods ) = @_; foreach my $method (@methods) { no strict 'refs'; *{"$class\::$method"} = sub { croak "method '$method' not supported by '$class'" }; } } sub cache_object_class { 'CHI::CacheObject' } # To override time() for testing - must be writable in a dynamically scoped way from tests our $Test_Time; ## no critic (ProhibitPackageVars) our $Build_Depth = 0; ## no critic (ProhibitPackageVars) sub valid_get_options { qw(expire_if busy_lock) } sub valid_set_options { qw(expires_at expires_in expires_variance) } sub BUILD { my ( $self, $params ) = @_; # Ward off infinite build recursion, e.g. from circular subcache configuration. # local $Build_Depth = $Build_Depth + 1; die "$Build_Depth levels of CHI cache creation; infinite recursion?" if ( $Build_Depth > $self->max_build_depth ); # Save off constructor params. Used to create metacache, for # example. Hopefully this will not cause circular references... # $self->{constructor_params} = {%$params}; foreach my $param (qw(l1_cache mirror_cache parent_cache)) { delete( $self->{constructor_params}->{$param} ); } # If stats enabled, add ns_stats slot for keeping track of stats # my $stats = $self->chi_root_class->stats; if ( $stats->enabled ) { $self->{ns_stats} = $stats->stats_for_driver($self); } # Call BUILD_roles on any of the roles that need initialization. # $self->BUILD_roles($params); } sub BUILD_roles { # Will be modified by roles that need it } sub _build_short_driver_name { my ($self) = @_; ( my $name = $self->driver_class ) =~ s/^CHI::Driver:://; return $name; } sub _build_label { my ($self) = @_; return $self->short_driver_name; } sub _build_metacache { my $self = shift; return CHI::Driver::Metacache->new( owner_cache => $self ); } sub get { my ( $self, $key, %params ) = @_; croak "must specify key" unless defined($key); my $ns_stats = $self->{ns_stats}; my $log_is_debug = $log->is_debug; my $measure_time = defined($ns_stats) || $log_is_debug; my ( $start_time, $elapsed_time ); # Fetch cache object # $start_time = gettimeofday() if $measure_time; my $obj = eval { $params{obj} || $self->get_object($key) }; $elapsed_time = ( gettimeofday() - $start_time ) * 1000 if $measure_time; if ( my $error = $@ ) { $ns_stats->{'get_errors'}++ if defined($ns_stats); $self->_handle_get_error( $error, $key ); return undef; } if ( !defined $obj ) { $self->_record_get_stats( 'absent_misses', $elapsed_time ) if defined($ns_stats); $self->_log_get_result( $log, "MISS (not in cache)", $key, $elapsed_time ) if $log_is_debug; return undef; } if ( defined( my $obj_ref = $params{obj_ref} ) ) { $$obj_ref = $obj; } # Check if expired # my $is_expired = $obj->is_expired() || ( defined( $params{expire_if} ) && $params{expire_if}->( $obj, $self ) ); if ($is_expired) { $self->_record_get_stats( 'expired_misses', $elapsed_time ) if defined($ns_stats); $self->_log_get_result( $log, "MISS (expired)", $key, $elapsed_time ) if $log_is_debug; # If busy_lock value provided, set a new "temporary" expiration time that many # seconds forward before returning undef # if ( defined( my $busy_lock = $params{busy_lock} ) ) { my $time = $Test_Time || time(); my $busy_lock_time = $time + parse_duration($busy_lock); $obj->set_early_expires_at($busy_lock_time); $obj->set_expires_at($busy_lock_time); $self->set_object( $key, $obj ); } return undef; } $self->_record_get_stats( 'hits', $elapsed_time ) if defined($ns_stats); $self->_log_get_result( $log, "HIT", $key, $elapsed_time ) if $log_is_debug; return $obj->value; } sub _record_get_stats { my ( $self, $stat, $elapsed_time ) = @_; $self->{ns_stats}->{$stat}++; $self->{ns_stats}->{'get_time_ms'} += $elapsed_time; } sub unpack_from_data { my ( $self, $key, $data ) = @_; return $self->cache_object_class->unpack_from_data( $key, $data, $self->serializer ); } sub get_object { my ( $self, $key ) = @_; croak "must specify key" unless defined($key); $key = $self->transform_key($key); my $data = $self->fetch($key) or return undef; my $obj = $self->unpack_from_data( $key, $data ); return $obj; } sub get_expires_at { my ( $self, $key ) = @_; croak "must specify key" unless defined($key); if ( my $obj = $self->get_object($key) ) { return $obj->expires_at; } else { return; } } sub exists_and_is_expired { my ( $self, $key ) = @_; croak "must specify key" unless defined($key); if ( my $obj = $self->get_object($key) ) { return $obj->is_expired; } else { return; } } sub is_valid { my ( $self, $key ) = @_; croak "must specify key" unless defined($key); if ( my $obj = $self->get_object($key) ) { return !$obj->is_expired; } else { return; } } sub _default_set_options { my $self = shift; return { map { $_ => $self->$_() } qw( expires_at expires_in expires_variance ) }; } sub set { my $self = shift; my ( $key, $value, $options ) = @_; croak "must specify key" unless defined($key); $key = $self->transform_key($key); return unless defined($value); # Fill in $options if not passed, copy if passed, and apply defaults. # if ( !defined($options) ) { $options = $self->_default_set_options; } else { if ( !ref($options) ) { if ( $options eq 'never' ) { $options = { expires_at => CHI_Max_Time }; } elsif ( $options eq 'now' ) { $options = { expires_in => 0 }; } else { $options = { expires_in => $options }; } } # Disregard default expires_at and expires_in if either are provided # if ( exists( $options->{expires_at} ) || exists( $options->{expires_in} ) ) { $options = { expires_variance => $self->expires_variance, %$options }; } else { $options = { %{ $self->_default_set_options }, %$options }; } } $self->set_with_options( $key, $value, $options ); } sub set_with_options { my ( $self, $key, $value, $options ) = @_; my $ns_stats = $self->{ns_stats}; my $log_is_debug = $log->is_debug; my $measure_time = defined($ns_stats) || $log_is_debug; my ( $start_time, $elapsed_time ); # Determine early and final expiration times # my $time = $Test_Time || time(); my $created_at = $time; my $expires_at = ( defined( $options->{expires_in} ) ) ? $time + parse_duration( $options->{expires_in} ) : $options->{expires_at}; my $early_expires_at = defined( $options->{early_expires_at} ) ? $options->{early_expires_at} : ( $expires_at == CHI_Max_Time ) ? CHI_Max_Time : $expires_at - ( ( $expires_at - $time ) * $options->{expires_variance} ); # Pack into data, and store # my $obj = $self->cache_object_class->new( $key, $value, $created_at, $early_expires_at, $expires_at, $self->serializer, $self->compress_threshold ); if ( defined( my $obj_ref = $options->{obj_ref} ) ) { $$obj_ref = $obj; } $start_time = gettimeofday() if $measure_time; if ( $self->set_object( $key, $obj ) ) { $elapsed_time = ( gettimeofday() - $start_time ) * 1000 if $measure_time; # Log the set # if ( defined($ns_stats) ) { $ns_stats->{'sets'}++; $ns_stats->{'set_key_size'} += length( $obj->key ); $ns_stats->{'set_value_size'} += $obj->size; $ns_stats->{'set_time_ms'} += $elapsed_time; } if ($log_is_debug) { $self->_log_set_result( $log, $obj, $elapsed_time ); } } return $value; } sub set_object { my ( $self, $key, $obj ) = @_; my $data = $obj->pack_to_data(); my $expires_on_backend = $self->expires_on_backend; my @expires_in = ( $expires_on_backend && $obj->expires_at < CHI_Max_Time ? ( ( $obj->expires_at - time ) * $expires_on_backend ) : () ); eval { $self->store( $key, $data, @expires_in ) }; if ( my $error = $@ ) { $self->{ns_stats}->{'set_errors'}++ if defined( $self->{ns_stats} ); $self->_handle_set_error( $error, $obj ); return 0; } return 1; } sub get_keys_iterator { my ($self) = @_; my @keys = $self->get_keys(); return sub { shift(@keys) }; } sub clear { my $self = shift; die "clear takes no arguments" if @_; $self->remove_multi( [ $self->get_keys() ] ); } sub expire { my ( $self, $key ) = @_; croak "must specify key" unless defined($key); my $time = $Test_Time || time(); if ( defined( my $obj = $self->get_object($key) ) ) { my $expires_at = $time - 1; $obj->set_early_expires_at($expires_at); $obj->set_expires_at($expires_at); $self->set_object( $key, $obj ); } } sub compute { my $self = shift; my $key = shift; my $wantarray = wantarray(); # Allow these in either order for backward compatibility my ( $code, $options ) = ( ref( $_[0] ) eq 'CODE' ) ? ( $_[0], $_[1] ) : ( $_[1], $_[0] ); croak "must specify key and code" unless defined($key) && defined($code); my %get_options = ( ref($options) eq 'HASH' ) ? slice_grep { /(?:expire_if|busy_lock)/ } $options : (); my $set_options = ( ref($options) eq 'HASH' ) ? { slice_grep { !/(?:expire_if|busy_lock)/ } $options } : $options; my $value = $self->get( $key, %get_options ); if ( !defined $value ) { my ( $start_time, $elapsed_time ); my $ns_stats = $self->{ns_stats}; $start_time = gettimeofday if defined($ns_stats); $value = $wantarray ? [ $code->() ] : $code->(); $elapsed_time = ( gettimeofday() - $start_time ) * 1000 if defined($ns_stats); $self->set( $key, $value, $set_options ); if ( defined($ns_stats) ) { $ns_stats->{'computes'}++; $ns_stats->{'compute_time_ms'} += $elapsed_time; } } return $wantarray ? @$value : $value; } sub purge { my ($self) = @_; foreach my $key ( $self->get_keys() ) { if ( my $obj = $self->get_object($key) ) { if ( $obj->is_expired() ) { $self->remove($key); } } } } sub dump_as_hash { my ($self) = @_; my %hash; foreach my $key ( $self->get_keys() ) { if ( defined( my $value = $self->get($key) ) ) { $hash{$key} = $value; } } return \%hash; } sub is_empty { my ($self) = @_; return !$self->get_keys(); } # # (SEMI-) ATOMIC OPERATIONS # sub add { my $self = shift; my $key = shift; if ( !$self->is_valid($key) ) { $self->set( $key, @_ ); } } sub append { my ( $self, $key, $new ) = @_; my $current = $self->fetch($key) or return undef; $self->store( $key, $current . $new ); return 1; } sub replace { my $self = shift; my $key = shift; if ( $self->is_valid($key) ) { $self->set( $key, @_ ); } } # # MULTI KEY OPERATIONS # sub fetch_multi_hashref { my ( $self, $keys ) = @_; return { map { ( $_, $self->fetch($_) ) } @$keys }; } sub get_multi_hashref_objects { my ( $self, $keys ) = @_; my $key_data = $self->fetch_multi_hashref($keys); return { map { my $data = $key_data->{$_}; defined($data) ? ( $_, $self->unpack_from_data( $_, $data ) ) : ( $_, undef ) } keys(%$key_data) }; } sub get_multi_arrayref { my ( $self, $keys ) = @_; croak "must specify keys" unless defined($keys); my $transformed_keys = [ map { $self->transform_key($_) } @$keys ]; my $key_count = scalar(@$keys); my $keyobjs = $self->get_multi_hashref_objects($transformed_keys); return [ map { my $key = $transformed_keys->[$_]; my $obj = $keyobjs->{$key}; $obj ? $self->get( $key, obj => $obj ) : undef } ( 0 .. $key_count - 1 ) ]; } sub get_multi_hashref { my ( $self, $keys ) = @_; croak "must specify keys" unless defined($keys); my $key_count = scalar(@$keys); my $values = $self->get_multi_arrayref($keys); return { map { ( $keys->[$_], $values->[$_] ) } ( 0 .. $key_count - 1 ) }; } sub set_multi { my $self = shift; $self->store_multi(@_); } sub store_multi { my ( $self, $key_values, $set_options ) = @_; croak "must specify key_values" unless defined($key_values); while ( my ( $key, $value ) = each(%$key_values) ) { $self->set( $key, $value, $set_options ); } } sub remove_multi { my ( $self, $keys ) = @_; croak "must specify keys" unless defined($keys); foreach my $key (@$keys) { $self->remove($key); } } # # KEY TRANSFORMATION # my %escapes; for ( 0 .. 255 ) { $escapes{ chr($_) } = sprintf( "+%02x", $_ ); } my $_fail_hi = sub { croak( sprintf "Can't escape multibyte character \\x{%04X}", ord( $_[0] ) ); }; sub transform_key { my ( $self, $key ) = @_; if ( ref($key) ) { $key = $self->key_serializer->serialize($key); } elsif ( Encode::is_utf8($key) && $key =~ /[^\x00-\xFF]/ ) { $key = $self->encode_key($key); } if ( length($key) > $self->max_key_length ) { $key = $self->digest_key($key); } return $key; } sub digest_key { my ( $self, $key ) = @_; return $self->key_digester->add($key)->hexdigest; } sub encode_key { my ( $self, $key ) = @_; return Encode::encode( utf8 => $key ); } # These will be called by drivers if necessary, and in testing. By default # no escaping/unescaping is necessary. # sub escape_key { $_[1] } sub unescape_key { $_[1] } # May be used by drivers to implement escape_key/unescape_key. # sub escape_for_filename { my ( $self, $key ) = @_; $key =~ s/([^A-Za-z0-9_\=\-\~])/$escapes{$1} || $_fail_hi->($1)/ge; return $key; } sub unescape_for_filename { my ( $self, $key ) = @_; $key =~ s/\+([0-9A-Fa-f]{2})/chr(hex($1))/eg if defined $key; return $key; } sub is_escaped_for_filename { my ( $self, $key ) = @_; return $self->escape_for_filename( $self->unescape_for_filename($key) ) eq $key; } # # LOGGING AND ERROR HANDLING # sub _log_get_result { my $self = shift; my $log = shift; my $msg = shift; $log->debug( sprintf( "%s: %s", $self->_describe_cache_get(@_), $msg ) ); } sub _log_set_result { my $self = shift; my $log = shift; $log->debug( $self->_describe_cache_set(@_) ); } sub _handle_get_error { my $self = shift; my $error = shift; my $key = $_[0]; my $msg = sprintf( "error during %s: %s", $self->_describe_cache_get(@_), $error ); $self->_dispatch_error_msg( $msg, $error, $self->on_get_error(), $key ); } sub _handle_set_error { my ( $self, $error, $obj ) = @_; my $msg = sprintf( "error during %s: %s", $self->_describe_cache_set($obj), $error ); $self->_dispatch_error_msg( $msg, $error, $self->on_set_error(), $obj->key ); } sub _dispatch_error_msg { my ( $self, $msg, $error, $on_error, $key ) = @_; for ($on_error) { ( ref($_) eq 'CODE' ) && do { $_->( $msg, $key, $error ) }; /^log$/ && do { $log->error($msg) }; /^ignore$/ && do { }; /^warn$/ && do { carp $msg }; /^die$/ && do { croak $msg }; } } sub _describe_cache_get { my ( $self, $key, $elapsed_time ) = @_; return sprintf( "cache get for namespace='%s', key='%s', cache='%s'" . ( defined($elapsed_time) ? ", time='%dms'" : "" ), $self->namespace, $key, $self->label, defined($elapsed_time) ? int($elapsed_time) : () ); } sub _describe_cache_set { my ( $self, $obj, $elapsed_time ) = @_; my $expires_str = ( ( $obj->expires_at == CHI_Max_Time ) ? 'never' : Time::Duration::concise( Time::Duration::duration_exact( $obj->expires_at - $obj->created_at ) ) ); return sprintf( "cache set for namespace='%s', key='%s', size=%d, expires='%s', cache='%s'" . ( defined($elapsed_time) ? ", time='%dms'" : "" ), $self->namespace, $obj->key, $obj->size, $expires_str, $self->label, defined($elapsed_time) ? int($elapsed_time) : () ); } 1; __END__ =pod =head1 NAME CHI::Driver - Base class for all CHI drivers =head1 VERSION version 0.60 =head1 DESCRIPTION This is the base class that all CHI drivers inherit from. It provides the methods that one calls on $cache handles, such as get() and set(). See L for documentation on $cache methods, and L for documentation on creating new subclasses of CHI::Driver. =head1 SEE ALSO L =head1 AUTHOR Jonathan Swartz =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2012 by Jonathan Swartz. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut CHI-0.60/lib/CHI/Serializer/0000775€ˆž«€q{Ì0000000000012535132431015015 5ustar jonswartCHI-0.60/lib/CHI/Serializer/JSON.pm0000644€ˆž«€q{Ì0000000066312535132431016127 0ustar jonswart# Default key serializer class, so that we don't have to depend on Data::Serializer. # Recommend Data::Serializer for other serializers, rather than reinventing the wheel. # package CHI::Serializer::JSON; $CHI::Serializer::JSON::VERSION = '0.60'; use CHI::Util qw(json_encode json_decode); use Moo; use strict; use warnings; sub serialize { return json_encode( $_[1] ); } sub deserialize { return json_decode( $_[1] ); } 1; CHI-0.60/lib/CHI/Serializer/Storable.pm0000644€ˆž«€q{Ì0000000071612535132431017130 0ustar jonswart# Default serializer class, so that we don't have to depend on Data::Serializer. # Recommend Data::Serializer for other serializers, rather than reinventing the wheel. # package CHI::Serializer::Storable; $CHI::Serializer::Storable::VERSION = '0.60'; use Moo; use Storable; use strict; use warnings; sub serialize { return Storable::nfreeze( $_[1] ); } sub deserialize { return Storable::thaw( $_[1] ); } sub serializer { return 'Storable'; } 1; CHI-0.60/lib/CHI/Stats.pm0000644€ˆž«€q{Ì0000002300612535132431014337 0ustar jonswartpackage CHI::Stats; $CHI::Stats::VERSION = '0.60'; use CHI::Util qw(json_encode json_decode); use List::Util qw(sum); use Log::Any qw($log); use Moo; use strict; use warnings; has 'chi_root_class' => ( is => 'ro' ); has 'data' => ( is => 'ro', default => sub { {} } ); has 'enabled' => ( is => 'rwp', default => sub { 0 } ); has 'start_time' => ( is => 'ro', default => sub { time } ); sub enable { $_[0]->_set_enabled(1) } sub disable { $_[0]->_set_enabled(0) } sub flush { my ($self) = @_; my $data = $self->data; foreach my $label ( sort keys %$data ) { my $label_stats = $data->{$label}; foreach my $namespace ( sort keys(%$label_stats) ) { my $namespace_stats = $label_stats->{$namespace}; if (%$namespace_stats) { $self->log_namespace_stats( $label, $namespace, $namespace_stats ); } } } $self->clear(); } sub log_namespace_stats { my ( $self, $label, $namespace, $namespace_stats ) = @_; my %data = ( label => $label, end_time => time(), namespace => $namespace, root_class => $self->chi_root_class, %$namespace_stats ); %data = map { /_ms$/ ? ( $_, int( $data{$_} ) ) : ( $_, $data{$_} ) } keys(%data); $log->infof( 'CHI stats: %s', json_encode( \%data ) ); } sub format_time { my ($time) = @_; my ( $sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst ) = localtime($time); return sprintf( "%04d%02d%02d:%02d:%02d:%02d", $year + 1900, $mon + 1, $mday, $hour, $min, $sec ); } sub stats_for_driver { my ( $self, $cache ) = @_; my $stats = ( $self->data->{ $cache->label }->{ $cache->namespace } ||= {} ); $stats->{start_time} ||= time; return $stats; } sub parse_stats_logs { my $self = shift; my ( %results_hash, @results, %numeric_fields_seen ); foreach my $log_file (@_) { my $logfh; if ( ref($log_file) ) { $logfh = $log_file; } else { open( $logfh, '<', $log_file ) or die "cannot open $log_file: $!"; $log->infof( "processing '%s'", $log_file ); } while ( my $line = <$logfh> ) { chomp($line); if ( my ($json) = ( $line =~ /CHI stats: (\{.*\})$/ ) ) { my %hash = %{ json_decode($json) }; my $root_class = delete( $hash{root_class} ); my $namespace = delete( $hash{namespace} ); my $label = delete( $hash{label} ); my $results_set = ( $results_hash{$root_class}->{$label}->{$namespace} ||= {} ); if ( !%$results_set ) { $results_set->{root_class} = $root_class; $results_set->{namespace} = $namespace; $results_set->{label} = $label; push( @results, $results_set ); } while ( my ( $key, $value ) = each(%hash) ) { next if $key =~ /_time$/; $results_set->{$key} += $value; $numeric_fields_seen{$key}++; } } } } my @numeric_fields = sort( keys(%numeric_fields_seen) ); my $sum = sub { my ( $rs, $name, @fields ) = @_; if ( grep { $rs->{$_} } @fields ) { $rs->{$name} = sum( map { $rs->{$_} || 0 } @fields ); } }; foreach my $rs (@results) { $sum->( $rs, 'misses', 'absent_misses', 'expired_misses' ); $sum->( $rs, 'gets', 'hits', 'misses' ); } my %totals = map { ( $_, 'TOTALS' ) } qw(root_class namespace label); foreach my $field (@numeric_fields) { $totals{$field} = sum( map { $_->{$field} || 0 } @results ); } push( @results, \%totals ); my $divide = sub { my ( $rs, $name, $top, $bottom ) = @_; if ( $rs->{$top} && $rs->{$bottom} ) { $rs->{$name} = ( $rs->{$top} / $rs->{$bottom} ); } }; foreach my $rs (@results) { $divide->( $rs, 'avg_compute_time_ms', 'compute_time_ms', 'computes' ); $divide->( $rs, 'avg_get_time_ms', 'get_time_ms', 'gets' ); $divide->( $rs, 'avg_set_time_ms', 'set_time_ms', 'sets' ); $divide->( $rs, 'avg_set_key_size', 'set_key_size', 'sets' ); $divide->( $rs, 'avg_set_value_size', 'set_value_size', 'sets' ); $divide->( $rs, 'hit_rate', 'hits', 'gets' ); } return \@results; } sub clear { my ($self) = @_; my $data = $self->data; foreach my $key ( keys %{$data} ) { %{ $data->{$key} } = (); } $self->{start_time} = time; } 1; __END__ =pod =head1 NAME CHI::Stats - Record and report per-namespace cache statistics =head1 VERSION version 0.60 =head1 SYNOPSIS # Turn on statistics collection CHI->stats->enable(); # Perform cache operations # Flush statistics to logs CHI->stats->flush(); ... # Parse logged statistics my $results = CHI->stats->parse_stats_logs($file1, ...); =head1 DESCRIPTION CHI can record statistics, such as number of hits, misses and sets, on a per-namespace basis and log the results to your L logger. You can then parse the logs to get a combined summary. A single CHI::Stats object is maintained for each CHI root class, and tallies statistics over any number of CHI::Driver objects. Statistics are reported when you call the L method. You can choose to do this once at process end, or on a periodic basis. =head1 METHODS =over =item enable, disable, enabled Enable, disable, and query the current enabled status. When stats are enabled, each new cache object will collect statistics. Enabling and disabling does not affect existing cache objects. e.g. my $cache1 = CHI->new(...); CHI->stats->enable(); # $cache1 will not collect statistics my $cache2 = CHI->new(...); CHI->stats->disable(); # $cache2 will continue to collect statistics =item flush Log all statistics to L (at Info level in the CHI::Stats category), then clear statistics from memory. There is one log message for each distinct triplet of L, L, and L. Each log message contains the string "CHI stats:" followed by a JSON encoded hash of statistics. e.g. CHI stats: {"absent_misses":1,"label":"File","end_time":1338410398, "get_time_ms":5,"namespace":"Foo","root_class":"CHI", "set_key_size":6,"set_time_ms":23,"set_value_size":20,"sets":1, "start_time":1338409391} =item parse_stats_logs Accepts one or more stats log files as parameters. Parses the logs and returns a listref of stats hashes by root class, cache label, and namespace. e.g. [ { root_class => 'CHI', label => 'File', namespace => 'Foo', absent_misses => 100, avg_compute_time_ms => 23, ... }, { root_class => 'CHI', label => 'File', namespace => 'Bar', ... }, ] Lines with the same root class, cache label, and namespace are summed together. Non-stats lines are ignored. The parser will ignore anything on the line before the "CHI stats:" string, e.g. a timestamp. Each parameter to this method may be a filename or a reference to an open filehandle. =back =head1 STATISTICS The following statistics are tracked in the logs: =over =item * C - Number of gets that failed due to item not being in the cache =item * C - Total time spent computing missed results in L, in ms (divide by number of computes to get average). i.e. the amount of time spent in the code reference passed as the third argument to compute(). =item * C - Number of L calls =item * C - Number of gets that failed due to item expiring =item * C - Number of caught runtime errors during gets =item * C - Total time spent in get operation, in ms (divide by number of gets to get average) =item * C - Number of gets that succeeded =item * C - Number of bytes in set keys (divide by number of sets to get average) =item * C - Number of bytes in set values (divide by number of sets to get average) =item * C - Total time spent in set operation, in ms (divide by number of sets to get average) =item * C - Number of sets =item * C - Number of caught runtime errors during sets =back The following additional derived/aggregate statistics are computed by L: =over =item * C - C + C =item * C - C + C =item * C - C / C =item * C - C / C =item * C - C / C =item * C - C / C =item * C - C / C =item * C - C / C =back =head1 SEE ALSO L =head1 AUTHOR Jonathan Swartz =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2012 by Jonathan Swartz. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut CHI-0.60/lib/CHI/t/0000775€ˆž«€q{Ì0000000000012535132431013147 5ustar jonswartCHI-0.60/lib/CHI/t/Bugs.pm0000644€ˆž«€q{Ì0000000102512535132431014401 0ustar jonswartpackage CHI::t::Bugs; $CHI::t::Bugs::VERSION = '0.60'; use strict; use warnings; use CHI::Test; use File::Temp qw(tempdir); use base qw(CHI::Test::Class); # A place for testing obscure bug fixes. When possible, test will be named for RT ticket. sub test_48998 : Tests { my $cache = CHI->new( driver => 'Memory', global => 1 ); $cache->set( 'a', 5 ); $cache->set( 'b', 6 ); eval { die "bleah" }; $DB::single = 1; cmp_deeply( $cache->get_multi_arrayref( [ 'a', 'b' ] ), [ 5, 6 ], "get_multi" ); } 1; CHI-0.60/lib/CHI/t/Config.pm0000644€ˆž«€q{Ì0000000717512535132431014722 0ustar jonswartpackage CHI::t::Config; $CHI::t::Config::VERSION = '0.60'; use CHI::Util qw(dump_one_line); use CHI::Test; use File::Temp qw(tempdir); use strict; use warnings; use base qw(CHI::Test::Class); my $root_dir = tempdir( 'CHI-t-Config-XXXX', TMPDIR => 1, CLEANUP => 1 ); my %config = ( storage => { memory => { driver => 'Memory', global => 1 }, file => { driver => 'File', root_dir => $root_dir }, }, namespace => { 'Foo' => { storage => 'file' }, 'Bar' => { storage => 'file', depth => 3 }, }, defaults => { storage => 'memory' }, ); { package My::CHI; $My::CHI::VERSION = '0.60'; use base qw(CHI); My::CHI->config( {%config} ); } { package My::CHI::Subclass; $My::CHI::Subclass::VERSION = '0.60'; use base qw(My::CHI); } { package My::CHI::Memo; $My::CHI::Memo::VERSION = '0.60'; use base qw(CHI); My::CHI::Memo->config( { %config, memoize_cache_objects => 1 } ); } sub _create { my ( $params, $checks ) = @_; my $desc = dump_one_line($params); foreach my $class (qw(My::CHI My::CHI::Subclass)) { my $cache = $class->new(%$params); while ( my ( $key, $value ) = each(%$checks) ) { is( $cache->$key, $value, "$key == $value ($desc)" ); } } } sub test_config : Tests { my $self = shift; _create( { namespace => 'Foo' }, { namespace => 'Foo', storage => 'file', short_driver_name => 'File', root_dir => $root_dir, depth => 2 }, ); _create( { namespace => 'Bar' }, { namespace => 'Bar', storage => 'file', short_driver_name => 'File', root_dir => $root_dir, depth => 3 } ); _create( { namespace => 'Foo', depth => 4 }, { namespace => 'Foo', storage => 'file', short_driver_name => 'File', root_dir => $root_dir, depth => 4 } ); _create( { namespace => 'Bar', depth => 4 }, { namespace => 'Bar', storage => 'file', short_driver_name => 'File', root_dir => $root_dir, depth => 4 } ); my %new_config = %config; $new_config{namespace}->{'Bar'}->{depth} = 5; My::CHI->config( {%new_config} ); _create( { namespace => 'Bar' }, { namespace => 'Bar', storage => 'file', short_driver_name => 'File', root_dir => $root_dir, depth => 5 } ); } sub test_memoize : Tests { my $cache1 = My::CHI::Memo->new( namespace => 'Foo' ); my $cache2 = My::CHI::Memo->new( namespace => 'Foo' ); is( $cache1, $cache2, "same - namespace Foo" ); my $cache3 = My::CHI::Memo->new( namespace => 'Bar', depth => 4 ); my $cache4 = My::CHI::Memo->new( namespace => 'Bar', depth => 4 ); isnt( $cache3, $cache4, "different - namespace Bar" ); My::CHI::Memo->clear_memoized_cache_objects(); my $cache5 = My::CHI::Memo->new( namespace => 'Foo' ); my $cache6 = My::CHI::Memo->new( namespace => 'Foo' ); is( $cache5, $cache6, "same - namespace Foo" ); isnt( $cache1, $cache3, "different - post-clear" ); my $cache7 = My::CHI->new( namespace => 'Foo' ); my $cache8 = My::CHI->new( namespace => 'Foo' ); isnt( $cache7, $cache8, "different - namespace Foo - no memoization" ); } 1; CHI-0.60/lib/CHI/t/Constants.pm0000644€ˆž«€q{Ì0000000113012535132431015452 0ustar jonswartpackage CHI::t::Constants; $CHI::t::Constants::VERSION = '0.60'; use strict; use warnings; use CHI::Test; use base qw(CHI::Test::Class); sub test_import : Tests { { package Foo; $Foo::VERSION = '0.60'; use CHI::Constants qw(CHI_Meta_Namespace); } { package Bar; $Bar::VERSION = '0.60'; use CHI::Constants qw(:all); } { package Baz; $Baz::VERSION = '0.60'; } is( Foo::CHI_Meta_Namespace, '_CHI_METACACHE' ); is( Bar::CHI_Meta_Namespace, '_CHI_METACACHE' ); ok( Bar->can('CHI_Meta_Namespace') ); ok( !Baz->can('CHI_Meta_Namespace') ); } 1; CHI-0.60/lib/CHI/t/Driver/0000775€ˆž«€q{Ì0000000000012535132431014402 5ustar jonswartCHI-0.60/lib/CHI/t/Driver/CacheCache.pm0000644€ˆž«€q{Ì0000000176512535132431016676 0ustar jonswartpackage CHI::t::Driver::CacheCache; $CHI::t::Driver::CacheCache::VERSION = '0.60'; use strict; use warnings; use CHI::Test; use File::Temp qw(tempdir); use base qw(CHI::t::Driver); my $root_dir; sub supports_expires_on_backend { 1 } sub required_modules { return { 'Cache::Cache' => undef, 'Cache::FileCache' => undef }; } sub new_cache_options { my $self = shift; $root_dir ||= tempdir( "chi-driver-cachecache-XXXX", TMPDIR => 1, CLEANUP => 1 ); return ( $self->SUPER::new_cache_options(), cc_class => 'Cache::FileCache', cc_options => { cache_root => $root_dir } ); } sub set_standard_keys_and_values { my ($self) = @_; my ( $keys, $values ) = $self->SUPER::set_standard_keys_and_values(); # Cache::FileCache apparently cannot handle key = 0 $keys->{'zero'} = 'zero'; return ( $keys, $values ); } # Skip multiple process test - Cache::FileCache will hit occasional rename failures under this test sub test_multiple_procs { } 1; CHI-0.60/lib/CHI/t/Driver/FastMmap.pm0000644€ˆž«€q{Ì0000000413712535132431016453 0ustar jonswartpackage CHI::t::Driver::FastMmap; $CHI::t::Driver::FastMmap::VERSION = '0.60'; use strict; use warnings; use CHI::Test; use Encode; use File::Temp qw(tempdir); use base qw(CHI::t::Driver); my $root_dir; sub required_modules { return { 'Cache::FastMmap' => undef }; } sub new_cache_options { my $self = shift; $root_dir ||= tempdir( "chi-driver-fastmmap-XXXX", TMPDIR => 1, CLEANUP => 1 ); return ( $self->SUPER::new_cache_options(), root_dir => $root_dir ); } sub test_fm_cache : Tests { my ($self) = @_; # Create brand new cache and check defaults my $cache = $self->new_cache( root_dir => tempdir( "chi-driver-fastmmap-XXXX", TMPDIR => 1, CLEANUP => 1 ) ); my $fm_cache = $cache->fm_cache(); isa_ok( $fm_cache, 'Cache::FastMmap' ); my %defaults = ( unlink_on_exit => 0, empty_on_exit => 0, raw_values => 1, ); while ( my ( $key, $value ) = each(%defaults) ) { is( $fm_cache->{$key} || 0, $value, "$key = $value by default" ); } } sub test_parameter_passthrough : Tests { my ($self) = @_; my $cache = $self->new_cache( cache_size => '500k' ); # The number gets munged by FastMmap so it's not equal to 500 * 1024 is( $cache->fm_cache()->{cache_size}, 589824, 'cache_size parameter is passed to Cache::FastMmap constructor' ); $cache = $self->new_cache( page_size => 5000, num_pages => 11 ); # Same here, it won't be equal to 5000 * 11 is( $cache->fm_cache()->{cache_size}, 45056, 'page_size and num_pages parameters are passed to Cache::FastMmap constructor' ); } sub test_value_too_large : Tests { my ($self) = @_; my $cache = $self->new_cache( page_size => '4k', num_pages => 11, on_set_error => 'die' ); my %values; $values{small} = 'x' x 3 x 1024; $values{large} = 'x' x 10 x 1024; $cache->set( 'small', $values{small} ); is( $cache->get('small'), $values{small}, "got small" ); throws_ok { $cache->set( 'large', $values{large} ) } qr/error during cache set.*fastmmap set failed/; } 1; CHI-0.60/lib/CHI/t/Driver/File/0000775€ˆž«€q{Ì0000000000012535132431015261 5ustar jonswartCHI-0.60/lib/CHI/t/Driver/File/DepthZero.pm0000644€ˆž«€q{Ì0000000125212535132431017521 0ustar jonswartpackage CHI::t::Driver::File::DepthZero; $CHI::t::Driver::File::DepthZero::VERSION = '0.60'; use strict; use warnings; use CHI::Test; use File::Temp qw(tempdir); use File::Basename qw(dirname); use base qw(CHI::t::Driver::File); # Test file driver with zero depth sub testing_driver_class { 'CHI::Driver::File' } sub new_cache_options { my $self = shift; return ( $self->SUPER::new_cache_options(), depth => 0 ); } sub test_default_depth : Tests { my $self = shift; my $cache = $self->new_cache(); is( $cache->depth, 0 ); is( dirname( $cache->path_to_key('foo') ), $cache->path_to_namespace, "data files are one level below namespace" ); } 1; CHI-0.60/lib/CHI/t/Driver/File.pm0000644€ˆž«€q{Ì0000000713612535132431015624 0ustar jonswartpackage CHI::t::Driver::File; $CHI::t::Driver::File::VERSION = '0.60'; use strict; use warnings; use CHI::Test; use CHI::Test::Util qw(random_string); use CHI::Util qw(fast_catdir unique_id); use File::Basename; use File::Path; use File::Temp qw(tempdir); use base qw(CHI::t::Driver); my $root_dir; sub new_cache_options { my $self = shift; $root_dir ||= tempdir( "chi-driver-file-XXXX", TMPDIR => 1, CLEANUP => 1 ); return ( $self->SUPER::new_cache_options(), root_dir => $root_dir ); } { package CHI::t::Driver::File::NoTempDriver; $CHI::t::Driver::File::NoTempDriver::VERSION = '0.60'; use Moo; extends 'CHI::Driver::File'; sub generate_temporary_filename { my ( $self, $dir, $file ) = @_; return undef; } } { package CHI::t::Driver::File::BadTempDriver; $CHI::t::Driver::File::BadTempDriver::VERSION = '0.60'; use Moo; extends 'CHI::Driver::File'; sub generate_temporary_filename { my ( $self, $dir, $file ) = @_; return "/dir/does/not/exist/$file"; } } # Test that we can override how temporary files are generated # sub test_generate_temporary_filename : Tests { my $self = shift; $self->{cache} = $self->new_cache( driver => '+CHI::t::Driver::File::NoTempDriver' ); $self->test_simple(); $self->{cache} = $self->new_cache( driver => '+CHI::t::Driver::File::BadTempDriver' ); throws_ok { $self->test_simple() } qr/error during cache set/; } sub test_default_depth : Tests { my $self = shift; my $cache = $self->new_cache(); is( $cache->depth, 2 ); } sub test_creation_and_deletion : Tests { my $self = shift; my $cache = $self->new_cache(); my ( $key, $value ) = $self->kvpair(); my $cache_file = $cache->path_to_key($key); my $namespace_dir = $cache->path_to_namespace(); ok( !-f $cache_file, "cache file '$cache_file' does not exist before set" ); $cache->set( $key, $value, 0 ); ok( !defined $cache->get($key) ); ok( -f $cache_file, "cache file '$cache_file' exists after set" ); ok( -d $namespace_dir, "namespace dir '$namespace_dir' exists after set" ); $cache->remove($key); ok( !-f $cache_file, "cache file '$cache_file' does not exist after remove" ); ok( -d $namespace_dir, "namespace dir '$namespace_dir' exists after remove" ); $cache->clear(); ok( !-d $namespace_dir, "namespace dir '$namespace_dir' does not exist after clear" ); } sub test_root_dir_does_not_exist : Tests { my $self = shift; my $parent_dir = tempdir( "chi-driver-file-XXXX", TMPDIR => 1, CLEANUP => 1 ); my $non_existent_root = fast_catdir( $parent_dir, unique_id() ); ok( !-d $non_existent_root, "$non_existent_root does not exist" ); my $cache = $self->new_cache( root_dir => $non_existent_root ); ok( !defined( $cache->get('foo') ), 'miss' ); $cache->set( 'foo', 5 ); is( $cache->get('foo'), 5, 'hit' ); ok( -d $non_existent_root, "$non_existent_root exists after set" ); } sub test_ignore_bad_namespaces : Tests { my $self = shift; my $cache = $self->new_cleared_cache( root_dir => tempdir( "chi-driver-file-XXXX", TMPDIR => 1, CLEANUP => 1 ) ); foreach my $dir ( ".etc", "+2eetd", 'a@b', 'a+40c', "plain" ) { mkpath( join( "/", $cache->root_dir, $dir ) ); } cmp_set( [ $cache->get_namespaces ], [ '.etd', 'a@c', 'plain' ], 'only valid dirs shown as namespaces' ); } sub test_default_discard : Tests { my $self = shift; my $cache = $self->new_cleared_cache( is_size_aware => 1 ); is( $cache->discard_policy, 'arbitrary' ); } 1; CHI-0.60/lib/CHI/t/Driver/Memory.pm0000644€ˆž«€q{Ì0000000633312535132431016213 0ustar jonswartpackage CHI::t::Driver::Memory; $CHI::t::Driver::Memory::VERSION = '0.60'; use strict; use warnings; use CHI::Test; use CHI::Test::Driver::Role::CheckKeyValidity; use Test::Warn; use base qw(CHI::t::Driver); # Skip multiple process test sub test_multiple_processes { } sub new_cache_options { my $self = shift; return ( $self->SUPER::new_cache_options(), global => 1 ); } sub new_cache { my $self = shift; my %params = ( $self->new_cache_options(), @_ ); # If new_cache called with datastore, ignore global flag (otherwise would be an error) # if ( $params{datastore} ) { delete $params{global}; } # Check test key validity on every get and set - only necessary to do for one driver # $params{roles} = ['+CHI::Test::Driver::Role::CheckKeyValidity']; $params{test_object} = $self; my $cache = CHI->new(%params); return $cache; } sub test_short_driver_name : Tests { my ($self) = @_; my $cache = $self->{cache}; is( $cache->short_driver_name, 'Memory' ); } # Warn if global or datastore not passed, but still use global datastore by default # sub test_global_or_datastore_required : Tests { my ( $cache, $cache2 ); warning_like( sub { $cache = CHI->new( driver => 'Memory' ) }, qr/must specify either/ ); warning_like( sub { $cache2 = CHI->new( driver => 'Memory' ) }, qr/must specify either/ ); $cache->set( 'foo', 5 ); is( $cache2->get('foo'), 5, "defaulted to global datastore" ); } # Make sure two caches don't share datastore # sub test_different_datastores : Tests { my $self = shift; my $cache1 = CHI->new( driver => 'Memory', datastore => {} ); my $cache2 = CHI->new( driver => 'Memory', datastore => {} ); $self->set_some_keys($cache1); ok( !$cache2->get_keys() ); } # Make sure two global=0 caches don't share datastore # sub test_different_global_0 : Tests { my $self = shift; my $cache1 = CHI->new( driver => 'Memory', global => 0 ); my $cache2 = CHI->new( driver => 'Memory', global => 0 ); $self->set_some_keys($cache1); ok( !$cache2->get_keys() ); } # Make sure cache is cleared when datastore itself is cleared # sub test_clear_datastore : Tests { my $self = shift; $self->num_tests( $self->{key_count} * 3 + 6 ); my (@caches); my %datastore; $caches[0] = $self->new_cache( namespace => 'name', datastore => \%datastore ); $caches[1] = $self->new_cache( namespace => 'other', datastore => \%datastore ); $caches[2] = $self->new_cache( namespace => 'name', datastore => \%datastore ); $self->set_some_keys( $caches[0] ); $self->set_some_keys( $caches[1] ); %datastore = (); foreach my $i ( 0 .. 2 ) { $self->_verify_cache_is_cleared( $caches[$i], "cache $i after out of scope" ); } } sub test_lru_discard : Tests { my $self = shift; return 'author testing only' unless ( $ENV{AUTHOR_TESTING} ); my $cache = $self->new_cleared_cache( max_size => 41 ); is( $cache->discard_policy, 'lru' ); my $value_20 = 'x' x 6; foreach my $key ( map { "key$_" } (qw(1 2 3 4 5 6 5 6 5 3 2)) ) { $cache->set( $key, $value_20 ); } cmp_set( [ $cache->get_keys ], [ "key2", "key3" ] ); } 1; CHI-0.60/lib/CHI/t/Driver/NonMoose.pm0000644€ˆž«€q{Ì0000000037612535132431016501 0ustar jonswartpackage CHI::t::Driver::NonMoose; $CHI::t::Driver::NonMoose::VERSION = '0.60'; use strict; use warnings; use CHI::Test; use base qw(CHI::t::Driver::Memory); sub testing_driver_class { 'CHI::Test::Driver::NonMoose' } sub test_short_driver_name { } 1; CHI-0.60/lib/CHI/t/Driver/RawMemory.pm0000644€ˆž«€q{Ì0000000754012535132431016666 0ustar jonswartpackage CHI::t::Driver::RawMemory; $CHI::t::Driver::RawMemory::VERSION = '0.60'; use strict; use warnings; use CHI::Test; use CHI::Test::Util qw(is_between); use base qw(CHI::t::Driver::Memory); sub new_cache { my $self = shift; my %params = ( $self->new_cache_options(), @_, ); # If new_cache called with datastore, ignore global flag (otherwise would be an error) # if ( $params{datastore} ) { delete $params{global}; } my $cache = CHI->new(%params); return $cache; } # Not applicable to raw memory # sub test_deep_copy { } sub test_scalar_return_values { } sub test_serialize { } sub test_serializers { } # Would need tweaking to pass # sub test_append { } sub test_compress_threshold { } sub test_custom_discard_policy { } sub test_lru_discard { } sub test_size_awareness_with_subcaches { } sub test_stats { } sub test_subcache_overridable_params { } # Size of all items = 1 in this driver # sub test_size_awareness : Tests { my $self = shift; my ( $key, $value ) = $self->kvpair(); ok( !$self->new_cleared_cache()->is_size_aware(), "not size aware by default" ); ok( $self->new_cleared_cache( is_size_aware => 1 )->is_size_aware(), "is_size_aware turns on size awareness" ); ok( $self->new_cleared_cache( max_size => 10 )->is_size_aware(), "max_size turns on size awareness" ); my $cache = $self->new_cleared_cache( is_size_aware => 1 ); is( $cache->get_size(), 0, "size is 0 for empty" ); $cache->set( $key, $value ); is( $cache->get_size, 1, "size is 1 with one value" ); $cache->set( $key, scalar( $value x 5 ) ); is( $cache->get_size, 1, "size is still 1 after override" ); $cache->set( $key, scalar( $value x 5 ) ); is( $cache->get_size, 1, "size is still 1 after same overwrite" ); $cache->set( $key, scalar( $value x 2 ) ); is( $cache->get_size, 1, "size is 1 after overwrite" ); $cache->set( $key . "2", $value ); is( $cache->get_size, 2, "size is 2 after second key" ); $cache->remove($key); is( $cache->get_size, 1, "size is 1 again after removing key" ); $cache->remove( $key . "2" ); is( $cache->get_size, 0, "size is 0 again after removing keys" ); $cache->set( $key, $value ); is( $cache->get_size, 1, "size is 1 with one value" ); $cache->clear(); is( $cache->get_size, 0, "size is 0 again after clear" ); my $time = time() + 10; $cache->set( $key, $value, { expires_at => $time } ); is( $cache->get_expires_at($key), $time, "set options respected by size aware cache" ); } sub test_max_size : Tests { my $self = shift; my $cache = $self->new_cleared_cache( max_size => 5 ); ok( $cache->is_size_aware, "is size aware when max_size specified" ); my $value = 'x'; for ( my $i = 0 ; $i < 5 ; $i++ ) { $cache->set( "key$i", $value ); } for ( my $i = 0 ; $i < 10 ; $i++ ) { $cache->set( "key" . int( rand(10) ), $value ); is_between( $cache->get_size, 3, 5, "after iteration $i, size = " . $cache->get_size ); is_between( scalar( $cache->get_keys ), 3, 5, "after iteration $i, keys = " . scalar( $cache->get_keys ) ); } } # Test that we're caching a reference, not a deep copy # sub test_cache_ref : Tests { my $self = shift; my $cache = $self->{cache}; my $lst = ['foo']; $cache->set( 'key1' => $lst ); $cache->set( 'key2' => $lst ); is( $cache->get('key1'), $lst, "got same reference" ); is( $cache->get('key2'), $lst, "got same reference" ); $lst->[0] = 'bar'; is( $cache->get('key1')->[0], 'bar', "changed value in cache" ); } sub test_short_driver_name : Tests { my ($self) = @_; my $cache = $self->{cache}; is( $cache->short_driver_name, 'RawMemory' ); } 1; CHI-0.60/lib/CHI/t/Driver/Subcache/0000775€ˆž«€q{Ì0000000000012535132431016117 5ustar jonswartCHI-0.60/lib/CHI/t/Driver/Subcache/l1_cache.pm0000644€ˆž«€q{Ì0000000320112535132431020106 0ustar jonswartpackage CHI::t::Driver::Subcache::l1_cache; $CHI::t::Driver::Subcache::l1_cache::VERSION = '0.60'; use strict; use warnings; use CHI::Test; use CHI::Test::Util qw(activate_test_logger); use File::Temp qw(tempdir); use base qw(CHI::t::Driver::Subcache); my $root_dir; sub testing_driver_class { return 'CHI::Driver::File'; } sub new_cache_options { my $self = shift; $root_dir ||= tempdir( "chi-driver-subcache-l1-XXXX", TMPDIR => 1, CLEANUP => 1 ); return ( $self->SUPER::new_cache_options(), root_dir => $root_dir, l1_cache => { driver => 'Memory', global => 1 }, ); } sub test_stats : Tests { my $self = shift; my $stats = $self->testing_chi_root_class->stats; $stats->enable(); my ( $key, $value ) = $self->kvpair(); my $start_time = time(); my $cache; $cache = $self->new_cache( namespace => 'Foo' ); $cache->get($key); $cache->set( $key, $value, 80 ); $cache->get($key); my $log = activate_test_logger(); $log->empty_ok(); $stats->flush(); $log->contains_ok( qr/CHI stats: {"absent_misses":1,"end_time":\d+,"get_time_ms":\d+,"label":"File","namespace":"Foo","root_class":"CHI","set_key_size":6,"set_time_ms":\d+,"set_value_size":20,"sets":1,"start_time":\d+}/ ); $log->contains_ok( qr/CHI stats: {"absent_misses":1,"end_time":\d+,"get_time_ms":\d+,"hits":1,"label":"File:l1_cache","namespace":"Foo","root_class":"CHI","set_key_size":6,"set_time_ms":\d+,"set_value_size":20,"sets":1,"start_time":\d+}/ ); } # not working yet sub test_append { } # won't work in presence of l1 cache sub test_max_key_length { } 1; CHI-0.60/lib/CHI/t/Driver/Subcache/mirror_cache.pm0000644€ˆž«€q{Ì0000000130412535132431021106 0ustar jonswartpackage CHI::t::Driver::Subcache::mirror_cache; $CHI::t::Driver::Subcache::mirror_cache::VERSION = '0.60'; use strict; use warnings; use CHI::Test; use File::Temp qw(tempdir); use base qw(CHI::t::Driver::Subcache); my $root_dir; sub testing_driver_class { return 'CHI::Driver::File'; } sub new_cache_options { my $self = shift; $root_dir ||= tempdir( "chi-driver-subcache-mirror-XXXX", TMPDIR => 1, CLEANUP => 1 ); return ( $self->SUPER::new_cache_options(), depth => 2, root_dir => $root_dir, mirror_to_cache => { driver => 'File', depth => 3 }, ); } # This tries to create its own mirror cache sub test_max_key_length { } 1; CHI-0.60/lib/CHI/t/Driver/Subcache.pm0000644€ˆž«€q{Ì0000000127612535132431016461 0ustar jonswartpackage CHI::t::Driver::Subcache; $CHI::t::Driver::Subcache::VERSION = '0.60'; use strict; use warnings; use CHI::Test; use base qw(CHI::t::Driver); sub set_standard_keys_and_values { my ($self) = @_; my ( $keys, $values ) = $self->SUPER::set_standard_keys_and_values(); # keys for file driver have max length of 255 or so # but on windows xp, the full pathname is limited to 255 chars as well $keys->{'large'} = scalar( 'ab' x ( $^O eq 'MSWin32' ? 64 : 120 ) ); return ( $keys, $values ); } # Skip these tests - the logging will be wrong # sub test_l1_cache : Tests { ok(1); } sub test_mirror_cache : Tests { ok(1); } sub test_logging : Tests { ok(1); } 1; CHI-0.60/lib/CHI/t/Driver.pm0000644€ˆž«€q{Ì0000020275312535132431014747 0ustar jonswartpackage CHI::t::Driver; $CHI::t::Driver::VERSION = '0.60'; use strict; use warnings; use CHI::Test; use CHI::Test::Util qw(activate_test_logger cmp_bool is_between random_string skip_until); use CHI::Util qw(can_load dump_one_line write_file); use Encode; use File::Spec::Functions qw(tmpdir); use File::Temp qw(tempdir); use List::Util qw(shuffle); use Scalar::Util qw(weaken); use Storable qw(dclone); use Test::Warn; use Time::HiRes qw(usleep); use base qw(CHI::Test::Class); # Flags indicating what each test driver supports sub supports_clear { 1 } sub supports_expires_on_backend { 0 } sub supports_get_namespaces { 1 } sub standard_keys_and_values : Test(startup) { my ($self) = @_; my ( $keys_ref, $values_ref ) = $self->set_standard_keys_and_values(); $self->{keys} = $keys_ref; $self->{values} = $values_ref; $self->{keynames} = [ keys( %{$keys_ref} ) ]; $self->{key_count} = scalar( @{ $self->{keynames} } ); $self->{all_test_keys} = [ values(%$keys_ref), $self->extra_test_keys() ]; my $cache = $self->new_cache(); push( @{ $self->{all_test_keys} }, $self->process_keys( $cache, @{ $self->{all_test_keys} } ) ); $self->{all_test_keys_hash} = { map { ( $_, 1 ) } @{ $self->{all_test_keys} } }; } sub kvpair { my $self = shift; my $count = shift || 1; return map { ( $self->{keys}->{medium} . ( $_ == 1 ? '' : $_ ), $self->{values}->{medium} . ( $_ == 1 ? '' : $_ ) ) } ( 1 .. $count ); } sub setup : Test(setup) { my $self = shift; $self->{cache} = $self->new_cache(); $self->{cache}->clear() if $self->supports_clear(); } sub testing_driver_class { my $self = shift; my $class = ref($self); # By default, take the last part of the classname and use it as driver my $driver_class = 'CHI::Driver::' . ( split( '::', $class ) )[-1]; return $driver_class; } sub testing_chi_root_class { return 'CHI'; } sub new_cache { my $self = shift; return $self->testing_chi_root_class->new( $self->new_cache_options(), @_ ); } sub new_cleared_cache { my $self = shift; my $cache = $self->new_cache(@_); $cache->clear(); return $cache; } sub new_cache_options { my $self = shift; return ( driver => '+' . $self->testing_driver_class(), on_get_error => 'die', on_set_error => 'die' ); } sub set_standard_keys_and_values { my $self = shift; my ( %keys, %values ); my @mixed_chars = ( 32 .. 48, 57 .. 65, 90 .. 97, 122 .. 126, 240 ); %keys = ( 'space' => ' ', 'newline' => "\n", 'char' => 'a', 'zero' => 0, 'one' => 1, 'medium' => 'medium', 'mixed' => join( "", map { chr($_) } @mixed_chars ), 'binary' => join( "", map { chr($_) } ( 129 .. 255 ) ), 'large' => scalar( 'ab' x 256 ), 'empty' => 'empty', 'arrayref' => [ 1, 2 ], 'hashref' => { foo => [ 'bar', 'baz' ] }, 'utf8' => "Have \x{263a} a nice day", ); %values = map { ( $_, ref( $keys{$_} ) ? $keys{$_} : scalar( reverse( $keys{$_} ) ) ) } keys(%keys); $values{empty} = ''; return ( \%keys, \%values ); } # Extra keys (beyond the standard keys above) that we may use in these # tests. We need to adhere to this for the benefit of drivers that don't # support get_keys (like memcached) - they simulate get_keys(), clear(), # etc. by using this fixed list of keys. # sub extra_test_keys { my ($class) = @_; return ( '', '2', 'medium2', 'foo', 'hashref', 'test_namespace_types', "utf8", "encoded", "binary", ( map { "done$_" } ( 0 .. 2 ) ), ( map { "key$_" } ( 0 .. 20 ) ) ); } sub set_some_keys { my ( $self, $c ) = @_; foreach my $keyname ( @{ $self->{keynames} } ) { $c->set( $self->{keys}->{$keyname}, $self->{values}->{$keyname} ); } } sub test_encode : Tests { my $self = shift; my $cache = $self->new_cleared_cache(); my $utf8 = $self->{keys}->{utf8}; my $encoded = encode( utf8 => $utf8 ); my $binary_off = $self->{keys}->{binary}; my $binary_on = substr( $binary_off . $utf8, 0, length($binary_off) ); ok( $binary_off eq $binary_on, "binary_off eq binary_on" ); ok( !Encode::is_utf8($binary_off), "!is_utf8(binary_off)" ); ok( Encode::is_utf8($binary_on), "is_utf8(binary_on)" ); # Key maps to same thing whether encoded or non-encoded # my $value = time; $cache->set( $utf8, $value ); is( $cache->get($utf8), $value, "get" ); is( $cache->get($encoded), $value, "encoded and non-encoded map to same value" ); # Key maps to same thing whether utf8 flag is off or on # # Commenting out for now - this is broken on FastMmap and # DBI drivers (at least), and not entirely sure whether or # with what priority we should demand this behavior. # if (0) { $cache->set( $binary_off, $value ); is( $cache->get($binary_off), $value, "get binary_off" ); is( $cache->get($binary_on), $value, "binary_off and binary_on map to same value" ); $cache->clear($binary_on); ok( !$cache->get($binary_off), "cleared binary_off" ); # } # Value is maintained as a utf8 or binary string, in scalar or in arrayref $cache->set( "utf8", $utf8 ); is( $cache->get("utf8"), $utf8, "utf8 in scalar" ); $cache->set( "utf8", [$utf8] ); is( $cache->get("utf8")->[0], $utf8, "utf8 in arrayref" ); $cache->set( "encoded", $encoded ); is( $cache->get("encoded"), $encoded, "encoded in scalar" ); $cache->set( "encoded", [$encoded] ); is( $cache->get("encoded")->[0], $encoded, "encoded in arrayref" ); # Value retrieves as same thing whether stored with utf8 flag off or on # $cache->set( "binary", $binary_off ); is( $cache->get("binary"), $binary_on, "stored binary_off = binary_on" ); $cache->set( "binary", $binary_on ); is( $cache->get("binary"), $binary_off, "stored binary_on = binary_off" ); } sub test_simple : Tests { my $self = shift; my $cache = shift || $self->{cache}; ok( $cache->set( $self->{keys}->{medium}, $self->{values}->{medium} ) ); is( $cache->get( $self->{keys}->{medium} ), $self->{values}->{medium} ); } sub test_driver_class : Tests { my $self = shift; my $cache = $self->{cache}; isa_ok( $cache, 'CHI::Driver' ); isa_ok( $cache, $cache->driver_class ); can_ok( $cache, 'get', 'set', 'remove', 'clear', 'expire' ); } sub test_key_types : Tests { my $self = shift; my $cache = $self->{cache}; $self->num_tests( $self->{key_count} * 9 + 1 ); my @keys_set; my $check_keys_set = sub { my $desc = shift; cmp_set( [ $cache->get_keys ], \@keys_set, "checking keys $desc" ); }; $check_keys_set->("before sets"); foreach my $keyname ( @{ $self->{keynames} } ) { my $key = $self->{keys}->{$keyname}; my $value = $self->{values}->{$keyname}; ok( !defined $cache->get($key), "miss for key '$keyname'" ); is( $cache->set( $key, $value ), $value, "set for key '$keyname'" ); push( @keys_set, $self->process_keys( $cache, $key ) ); $check_keys_set->("after set of key '$keyname'"); cmp_deeply( $cache->get($key), $value, "hit for key '$keyname'" ); } foreach my $keyname ( reverse @{ $self->{keynames} } ) { my $key = $self->{keys}->{$keyname}; $cache->remove($key); ok( !defined $cache->get($key), "miss after remove for key '$keyname'" ); pop(@keys_set); $check_keys_set->("after removal of key '$keyname'"); } # Confirm that transform_key is idempotent # foreach my $keyname ( @{ $self->{keynames} } ) { my $key = $self->{keys}->{$keyname}; my $value = $self->{values}->{$keyname}; is( $cache->transform_key( $cache->transform_key($key) ), $cache->transform_key($key), "transform_key is idempotent for '$keyname'" ); $cache->clear(); $cache->set( $key, $value ); is( scalar( $cache->get_keys() ), 1, "exactly one key" ); cmp_deeply( $cache->get( ( $cache->get_keys )[0] ), $value, "get with get_keys[0] got same value" ); } } sub test_deep_copy : Tests { my $self = shift; my $cache = $self->{cache}; $self->set_some_keys($cache); foreach my $keyname (qw(arrayref hashref)) { my $key = $self->{keys}->{$keyname}; my $value = $self->{values}->{$keyname}; cmp_deeply( $cache->get($key), $value, "get($key) returns original data structure" ); cmp_deeply( $cache->get($key), $cache->get($key), "multiple get($key) return same data structure" ); isnt( $cache->get($key), $value, "get($key) does not return original reference" ); isnt( $cache->get($key), $cache->get($key), "multiple get($key) do not return same reference" ); } my $struct = { a => [ 1, 2 ], b => [ 4, 5 ] }; my $struct2 = dclone($struct); $cache->set( 'hashref', $struct ); push( @{ $struct->{a} }, 3 ); delete( $struct->{b} ); cmp_deeply( $cache->get('hashref'), $struct2, "altering original set structure does not affect cached copy" ); } sub test_expires_immediately : Tests { my $self = shift; return 'author testing only - timing is unreliable' unless ( $ENV{AUTHOR_TESTING} ); # expires_in default should be ignored my $cache = $self->new_cache( expires_in => '1 hour' ); # Expires immediately my $test_expires_immediately = sub { my ($set_option) = @_; my ( $key, $value ) = $self->kvpair(); my $desc = dump_one_line($set_option); is( $cache->set( $key, $value, $set_option ), $value, "set ($desc)" ); is_between( $cache->get_expires_at($key), time() - 4, time(), "expires_at ($desc)" ); ok( $cache->exists_and_is_expired($key), "is_expired ($desc)" ); ok( !defined $cache->get($key), "immediate miss ($desc)" ); }; $test_expires_immediately->(0); $test_expires_immediately->(-1); $test_expires_immediately->("0 seconds"); $test_expires_immediately->("0 hours"); $test_expires_immediately->("-1 seconds"); $test_expires_immediately->( { expires_in => "0 seconds" } ); $test_expires_immediately->( { expires_at => time - 1 } ); $test_expires_immediately->("now"); } sub test_expires_shortly : Tests { my $self = shift; return 'author testing only - timing is unreliable' unless ( $ENV{AUTHOR_TESTING} ); # expires_in default should be ignored my $cache = $self->new_cache( expires_in => '1 hour' ); # Expires shortly (real time) my $test_expires_shortly = sub { my ($set_option) = @_; my ( $key, $value ) = $self->kvpair(); my $desc = "set_option = " . dump_one_line($set_option); my $start_time = time(); is( $cache->set( $key, $value, $set_option ), $value, "set ($desc)" ); is( $cache->get($key), $value, "hit ($desc)" ); is_between( $cache->get_expires_at($key), $start_time + 1, $start_time + 8, "expires_at ($desc)" ); ok( !$cache->exists_and_is_expired($key), "not expired ($desc)" ); ok( $cache->is_valid($key), "valid ($desc)" ); # Only bother sleeping and expiring for one of the variants if ( $set_option eq "3 seconds" ) { sleep(3); ok( !defined $cache->get($key), "miss after 2 seconds ($desc)" ); ok( $cache->exists_and_is_expired($key), "is_expired ($desc)" ); ok( !$cache->is_valid($key), "invalid ($desc)" ); } }; $test_expires_shortly->(3); $test_expires_shortly->("3 seconds"); $test_expires_shortly->( { expires_at => time + 3 } ); } sub test_expires_later : Tests { my $self = shift; return 'author testing only - timing is unreliable' unless ( $ENV{AUTHOR_TESTING} ); # expires_in default should be ignored my $cache = $self->new_cache( expires_in => '1s' ); # Expires later (test time) my $test_expires_later = sub { my ($set_option) = @_; my ( $key, $value ) = $self->kvpair(); my $desc = "set_option = " . dump_one_line($set_option); is( $cache->set( $key, $value, $set_option ), $value, "set ($desc)" ); is( $cache->get($key), $value, "hit ($desc)" ); my $start_time = time(); is_between( $cache->get_expires_at($key), $start_time + 3580, $start_time + 3620, "expires_at ($desc)" ); ok( !$cache->exists_and_is_expired($key), "not expired ($desc)" ); ok( $cache->is_valid($key), "valid ($desc)" ); local $CHI::Driver::Test_Time = $start_time + 3590; ok( !$cache->exists_and_is_expired($key), "not expired ($desc)" ); ok( $cache->is_valid($key), "valid ($desc)" ); local $CHI::Driver::Test_Time = $start_time + 3610; ok( !defined $cache->get($key), "miss after 1 hour ($desc)" ); ok( $cache->exists_and_is_expired($key), "is_expired ($desc)" ); ok( !$cache->is_valid($key), "invalid ($desc)" ); }; $test_expires_later->(3600); $test_expires_later->("1 hour"); $test_expires_later->( { expires_at => time + 3600 } ); } sub test_expires_never : Tests { my $self = shift; my $cache; # Expires never (will fail in 2037) my ( $key, $value ) = $self->kvpair(); my $test_expires_never = sub { my (@set_options) = @_; $cache->set( $key, $value, @set_options ); ok( $cache->get_expires_at($key) > time + Time::Duration::Parse::parse_duration('1 year'), "expires never" ); ok( !$cache->exists_and_is_expired($key), "not expired" ); ok( $cache->is_valid($key), "valid" ); }; # never is default $cache = $self->new_cache(); $test_expires_never->(); # expires_in default should be ignored when never passed to set (RT #67970) $cache = $self->new_cache( expires_in => '1s' ); $test_expires_never->('never'); } sub test_expires_defaults : Tests { my $self = shift; my $start_time = time(); local $CHI::Driver::Test_Time = $start_time; my $cache; my $set_and_confirm_expires_at = sub { my ( $expected_expires_at, $desc ) = @_; my ( $key, $value ) = $self->kvpair(); $cache->set( $key, $value ); is( $cache->get_expires_at($key), $expected_expires_at, $desc ); $cache->clear(); }; $cache = $self->new_cache( expires_in => 10 ); $set_and_confirm_expires_at->( $start_time + 10, "after expires_in constructor option" ); $cache->expires_in(20); $set_and_confirm_expires_at->( $start_time + 20, "after expires_in method" ); $cache = $self->new_cache( expires_at => $start_time + 30 ); $set_and_confirm_expires_at->( $start_time + 30, "after expires_at constructor option" ); $cache->expires_at( $start_time + 40 ); $set_and_confirm_expires_at->( $start_time + 40, "after expires_at method" ); } sub test_expires_manually : Tests { my $self = shift; my $cache = $self->{cache}; my ( $key, $value ) = $self->kvpair(); my $desc = "expires manually"; $cache->set( $key, $value ); is( $cache->get($key), $value, "hit ($desc)" ); $cache->expire($key); ok( !defined $cache->get($key), "miss after expire ($desc)" ); ok( !$cache->is_valid($key), "invalid after expire ($desc)" ); } sub test_expires_conditionally : Tests { my $self = shift; my $cache = $self->{cache}; # Expires conditionally my $test_expires_conditionally = sub { my ( $code, $cond_desc, $expect_expire ) = @_; my ( $key, $value ) = $self->kvpair(); my $desc = "expires conditionally ($cond_desc)"; $cache->set( $key, $value ); is( $cache->get( $key, expire_if => $code ), $expect_expire ? undef : $value, "get result ($desc)" ); is( $cache->get($key), $value, "hit after expire_if ($desc)" ); }; my $time = time(); $test_expires_conditionally->( sub { 1 }, 'true', 1 ); $test_expires_conditionally->( sub { 0 }, 'false', 0 ); $test_expires_conditionally->( sub { $_[0]->created_at >= $time }, 'created_at >= now', 1 ); $test_expires_conditionally->( sub { $_[0]->created_at < $time }, 'created_at < now', 0 ); } sub test_expires_variance : Tests { my $self = shift; my $cache = $self->{cache}; my $start_time = time(); my $expires_at = $start_time + 10; my ( $key, $value ) = $self->kvpair(); $cache->set( $key, $value, { expires_at => $expires_at, expires_variance => 0.5 } ); is( $cache->get_object($key)->expires_at(), $expires_at, "expires_at = $start_time" ); is( $cache->get_object($key)->early_expires_at(), $start_time + 5, "early_expires_at = $start_time + 5" ); my %expire_count; for ( my $time = $start_time + 3 ; $time <= $expires_at + 1 ; $time++ ) { local $CHI::Driver::Test_Time = $time; for ( my $i = 0 ; $i < 100 ; $i++ ) { if ( !defined $cache->get($key) ) { $expire_count{$time}++; } } } for ( my $time = $start_time + 3 ; $time <= $start_time + 5 ; $time++ ) { ok( !$expire_count{$time}, "got no expires at $time" ); } for ( my $time = $start_time + 7 ; $time <= $start_time + 8 ; $time++ ) { ok( $expire_count{$time} > 0 && $expire_count{$time} < 100, "got some expires at $time" ); } for ( my $time = $expires_at ; $time <= $expires_at + 1 ; $time++ ) { ok( $expire_count{$time} == 100, "got all expires at $time" ); } } sub test_not_in_cache : Tests { my $self = shift; my $cache = $self->{cache}; ok( !defined $cache->get_object('not in cache') ); ok( !defined $cache->get_expires_at('not in cache') ); ok( !$cache->is_valid('not in cache') ); } sub test_serialize : Tests { my $self = shift; my $cache = $self->{cache}; $self->num_tests( $self->{key_count} ); $self->set_some_keys($cache); foreach my $keyname ( @{ $self->{keynames} } ) { my $expect_transformed = ( $keyname eq 'arrayref' || $keyname eq 'hashref' ) ? 1 : ( $keyname eq 'utf8' ) ? 2 : 0; is( $cache->get_object( $self->{keys}->{$keyname} )->_is_transformed(), $expect_transformed, "is_transformed = $expect_transformed ($keyname)" ); } } { package DummySerializer; $DummySerializer::VERSION = '0.60'; sub serialize { } sub deserialize { } } sub test_serializers : Tests { my ($self) = @_; unless ( can_load('Data::Serializer') ) { $self->num_tests(1); return 'Data::Serializer not installed'; } my @modes = (qw(string hash object)); my @variants = (qw(Storable Data::Dumper YAML)); @variants = grep { can_load($_) } @variants; ok( scalar(@variants), "some variants ok" ); my $initial_count = 5; my $test_key_types_count = $self->{key_count}; my $test_count = $initial_count + scalar(@variants) * scalar(@modes) * ( 1 + $test_key_types_count ); my $cache1 = $self->new_cache(); isa_ok( $cache1->serializer, 'CHI::Serializer::Storable' ); my $cache2 = $self->new_cache(); is( $cache1->serializer, $cache2->serializer, 'same serializer returned from two objects' ); throws_ok( sub { $self->new_cache( serializer => [1] ); }, qr/Validation failed for|isa check for ".*?" failed/, "invalid serializer" ); lives_ok( sub { $self->new_cache( serializer => bless( {}, 'DummySerializer' ) ) } , "valid dummy serializer" ); foreach my $mode (@modes) { foreach my $variant (@variants) { my $serializer_param = ( $mode eq 'string' ? $variant : $mode eq 'hash' ? { serializer => $variant } : Data::Serializer->new( serializer => $variant ) ); my $cache = $self->new_cache( serializer => $serializer_param ); is( $cache->serializer->serializer, $variant, "serializer = $variant, mode = $mode" ); $self->{cache} = $cache; foreach my $keyname ( @{ $self->{keynames} } ) { my $key = $self->{keys}->{$keyname}; my $value = $self->{values}->{$keyname}; $cache->set( $key, $value ); cmp_deeply( $cache->get($key), $value, "hit for key '$keyname'" ); } $self->num_tests($test_count); } } } sub test_namespaces : Tests { my $self = shift; my $cache = $self->{cache}; my $cache0 = $self->new_cache(); is( $cache0->namespace, 'Default', 'namespace defaults to "Default"' ); my ( $ns1, $ns2, $ns3 ) = ( 'ns1', 'ns2', 'ns3' ); my ( $cache1, $cache1a, $cache2, $cache3 ) = map { $self->new_cache( namespace => $_ ) } ( $ns1, $ns1, $ns2, $ns3 ); cmp_deeply( [ map { $_->namespace } ( $cache1, $cache1a, $cache2, $cache3 ) ], [ $ns1, $ns1, $ns2, $ns3 ], 'cache->namespace()' ); $self->set_some_keys($cache1); cmp_deeply( $cache1->dump_as_hash(), $cache1a->dump_as_hash(), 'cache1 and cache1a are same cache' ); cmp_deeply( [ $cache2->get_keys() ], [], 'cache2 empty after setting keys in cache1' ); $cache3->set( $self->{keys}->{medium}, 'different' ); is( $cache1->get('medium'), $self->{values}->{medium}, 'cache1{medium} = medium' ); is( $cache3->get('medium'), 'different', 'cache1{medium} = different' ); if ( $self->supports_get_namespaces() ) { # get_namespaces may or may not automatically include empty namespaces cmp_deeply( [ $cache1->get_namespaces() ], supersetof( $ns1, $ns3 ), "get_namespaces contains $ns1 and $ns3" ); foreach my $c ( $cache0, $cache1, $cache1a, $cache2, $cache3 ) { cmp_set( [ $cache->get_namespaces() ], [ $c->get_namespaces() ], 'get_namespaces the same regardless of which cache asks' ); } } else { throws_ok( sub { $cache1->get_namespaces() }, qr/not supported/, "get_namespaces not supported" ); SKIP: { skip "get_namespaces not supported", 5 } } } sub test_persist : Tests { my $self = shift; my $cache = $self->{cache}; my $hash; { my $cache1 = $self->new_cache(); $self->set_some_keys($cache1); $hash = $cache1->dump_as_hash(); } my $cache2 = $self->new_cache(); cmp_deeply( $hash, $cache2->dump_as_hash(), 'cache persisted between cache object creations' ); } sub test_multi : Tests { my $self = shift; my $cache = $self->{cache}; my ( $keys, $values, $keynames ) = ( $self->{keys}, $self->{values}, $self->{keynames} ); my @ordered_keys = map { $keys->{$_} } @{$keynames}; my @ordered_values = map { $values->{$_} } @{$keynames}; my %ordered_scalar_key_values = map { ( $keys->{$_}, $values->{$_} ) } grep { !ref( $keys->{$_} ) } @{$keynames}; cmp_deeply( $cache->get_multi_arrayref( ['foo'] ), [undef], "get_multi_arrayref before set" ); $cache->set_multi( \%ordered_scalar_key_values ); $cache->set( $keys->{arrayref}, $values->{arrayref} ); $cache->set( $keys->{hashref}, $values->{hashref} ); cmp_deeply( $cache->get_multi_arrayref( \@ordered_keys ), \@ordered_values, "get_multi_arrayref" ); cmp_deeply( $cache->get( $ordered_keys[0] ), $ordered_values[0], "get one after set_multi" ); cmp_deeply( $cache->get_multi_arrayref( [ reverse @ordered_keys ] ), [ reverse @ordered_values ], "get_multi_arrayref" ); cmp_deeply( $cache->get_multi_hashref( [ grep { !ref($_) } @ordered_keys ] ), \%ordered_scalar_key_values, "get_multi_hashref" ); cmp_set( [ $cache->get_keys ], [ $self->process_keys( $cache, @ordered_keys ) ], "get_keys after set_multi" ); $cache->remove_multi( \@ordered_keys ); cmp_deeply( $cache->get_multi_arrayref( \@ordered_keys ), [ (undef) x scalar(@ordered_values) ], "get_multi_arrayref after remove_multi" ); cmp_set( [ $cache->get_keys ], [], "get_keys after remove_multi" ); } sub test_multi_no_keys : Tests { my $self = shift; my $cache = $self->{cache}; cmp_deeply( $cache->get_multi_arrayref( [] ), [], "get_multi_arrayref (no args)" ); cmp_deeply( $cache->get_multi_hashref( [] ), {}, "get_multi_hashref (no args)" ); lives_ok { $cache->set_multi( {} ) } "set_multi (no args)"; lives_ok { $cache->remove_multi( [] ) } "remove_multi (no args)"; } sub test_l1_cache : Tests { my $self = shift; my @keys = map { "key$_" } ( 0 .. 2 ); my @values = map { "value$_" } ( 0 .. 2 ); my ( $cache, $l1_cache ); return "skipping - no support for clear" unless $self->supports_clear(); my $test_l1_cache = sub { is( $l1_cache->subcache_type, "l1_cache", "subcache_type = l1_cache" ); # Get on cache should populate l1 cache # $cache->set( $keys[0], $values[0] ); $l1_cache->clear(); ok( !$l1_cache->get( $keys[0] ), "l1 miss after clear" ); is( $cache->get( $keys[0] ), $values[0], "primary hit after primary set" ); is( $l1_cache->get( $keys[0] ), $values[0], "l1 hit after primary get" ); # Primary cache should be reading l1 cache first # $l1_cache->set( $keys[0], $values[1] ); is( $cache->get( $keys[0] ), $values[1], "got new value set explicitly in l1 cache" ); $l1_cache->remove( $keys[0] ); is( $cache->get( $keys[0] ), $values[0], "got old value again" ); $cache->clear(); ok( !$cache->get( $keys[0] ), "miss after clear" ); ok( !$l1_cache->get( $keys[0] ), "miss after clear" ); # get_multi_* - one from l1 cache, one from primary cache, one miss # $cache->set( $keys[0], $values[0] ); $cache->set( $keys[1], $values[1] ); $l1_cache->remove( $keys[0] ); $l1_cache->set( $keys[1], $values[2] ); cmp_deeply( $cache->get_multi_arrayref( [ $keys[0], $keys[1], $keys[2] ] ), [ $values[0], $values[2], undef ], "get_multi_arrayref" ); cmp_deeply( $cache->get_multi_hashref( [ $keys[0], $keys[1], $keys[2] ] ), { $keys[0] => $values[0], $keys[1] => $values[2], $keys[2] => undef }, "get_multi_hashref" ); $self->_test_logging_with_l1_cache( $cache, $l1_cache ); $self->_test_common_subcache_features( $cache, $l1_cache, 'l1_cache' ); }; # Test with current cache in primary position... # $cache = $self->new_cache( l1_cache => { driver => 'Memory', datastore => {} } ); $l1_cache = $cache->l1_cache; isa_ok( $cache, $self->testing_driver_class, 'cache' ); isa_ok( $l1_cache, 'CHI::Driver::Memory', 'l1_cache' ); $test_l1_cache->(); # and in l1 position # $cache = $self->testing_chi_root_class->new( driver => 'Memory', datastore => {}, l1_cache => { $self->new_cache_options() } ); $l1_cache = $cache->l1_cache; isa_ok( $cache, 'CHI::Driver::Memory', 'cache' ); isa_ok( $l1_cache, $self->testing_driver_class, 'l1_cache' ); $test_l1_cache->(); } sub test_mirror_cache : Tests { my $self = shift; my ( $cache, $mirror_cache ); my ( $key, $value, $key2, $value2 ) = $self->kvpair(2); return "skipping - no support for clear" unless $self->supports_clear(); my $test_mirror_cache = sub { is( $mirror_cache->subcache_type, "mirror_cache" ); # Get on either cache should not populate the other, and should not be able to see # mirror keys from regular cache # $cache->set( $key, $value ); $mirror_cache->remove($key); $cache->get($key); ok( !$mirror_cache->get($key), "key not in mirror_cache" ); $mirror_cache->set( $key2, $value2 ); ok( !$cache->get($key2), "key2 not in cache" ); $self->_test_logging_with_mirror_cache( $cache, $mirror_cache ); $self->_test_common_subcache_features( $cache, $mirror_cache, 'mirror_cache' ); }; my $file_cache_options = sub { my $root_dir = tempdir( "chi-test-mirror-cache-XXXX", TMPDIR => 1, CLEANUP => 1 ); return ( driver => 'File', root_dir => $root_dir, depth => 3 ); }; # Test with current cache in primary position... # $cache = $self->new_cache( mirror_cache => { $file_cache_options->() } ); $mirror_cache = $cache->mirror_cache; isa_ok( $cache, $self->testing_driver_class ); isa_ok( $mirror_cache, 'CHI::Driver::File' ); $test_mirror_cache->(); # and in mirror position # $cache = $self->testing_chi_root_class->new( $file_cache_options->(), mirror_cache => { $self->new_cache_options() } ); $mirror_cache = $cache->mirror_cache; isa_ok( $cache, 'CHI::Driver::File' ); isa_ok( $mirror_cache, $self->testing_driver_class ); $test_mirror_cache->(); } sub test_subcache_overridable_params : Tests { my ($self) = @_; my $cache; warning_like { $cache = $self->new_cache( l1_cache => { driver => 'Memory', on_get_error => 'log', datastore => {}, expires_variance => 0.5, serializer => 'Foo' } ); } qr/cannot override these keys/, "non-overridable subcache keys"; is( $cache->l1_cache->expires_variance, $cache->expires_variance ); is( $cache->l1_cache->serializer, $cache->serializer ); is( $cache->l1_cache->on_set_error, $cache->on_set_error ); is( $cache->l1_cache->on_get_error, 'log' ); } # Run logging tests for a cache with an l1_cache # sub _test_logging_with_l1_cache { my ( $self, $cache ) = @_; $cache->clear(); my $log = activate_test_logger(); my ( $key, $value ) = $self->kvpair(); my $driver = $cache->label; my $miss_not_in_cache = 'MISS \(not in cache\)'; my $miss_expired = 'MISS \(expired\)'; my $start_time = time(); $cache->get($key); $log->contains_ok( qr/cache get for .* key='$key', cache='$driver', time='[-\d]+ms': $miss_not_in_cache/ ); $log->contains_ok( qr/cache get for .* key='$key', cache='.*l1.*', time='[-\d]+ms': $miss_not_in_cache/ ); $log->empty_ok(); $cache->set( $key, $value, 81 ); $log->contains_ok( qr/cache set for .* key='$key', size=\d+, expires='1m2[012]s', cache='$driver', time='[-\d]+ms'/ ); $log->contains_ok( qr/cache set for .* key='$key', size=\d+, expires='1m2[012]s', cache='.*l1.*', time='[-\d]+ms'/ ); $log->empty_ok(); $cache->get($key); $log->contains_ok( qr/cache get for .* key='$key', cache='.*l1.*', time='[-\d]+ms': HIT/); $log->empty_ok(); local $CHI::Driver::Test_Time = $start_time + 120; $cache->get($key); $log->contains_ok( qr/cache get for .* key='$key', cache='$driver', time='[-\d]+ms': $miss_expired/ ); $log->contains_ok( qr/cache get for .* key='$key', cache='.*l1.*', time='[-\d]+ms': $miss_expired/ ); $log->empty_ok(); $cache->remove($key); $cache->get($key); $log->contains_ok( qr/cache get for .* key='$key', cache='$driver', time='[-\d]+ms': $miss_not_in_cache/ ); $log->contains_ok( qr/cache get for .* key='$key', cache='.*l1.*', time='[-\d]+ms': $miss_not_in_cache/ ); $log->empty_ok(); } sub _test_logging_with_mirror_cache { my ( $self, $cache ) = @_; $cache->clear(); my $log = activate_test_logger(); my ( $key, $value ) = $self->kvpair(); my $driver = $cache->label; my $miss_not_in_cache = 'MISS \(not in cache\)'; my $miss_expired = 'MISS \(expired\)'; my $start_time = time(); $cache->get($key); $log->contains_ok( qr/cache get for .* key='$key', cache='$driver', time='[-\d]+ms': $miss_not_in_cache/ ); $log->empty_ok(); $cache->set( $key, $value, 81 ); $log->contains_ok( qr/cache set for .* key='$key', size=\d+, expires='1m2[012]s', cache='$driver', time='[-\d]+ms'/ ); $log->contains_ok( qr/cache set for .* key='$key', size=\d+, expires='1m2[012]s', cache='.*mirror.*', time='[-\d]+ms'/ ); $log->empty_ok(); $cache->get($key); $log->contains_ok( qr/cache get for .* key='$key', cache='$driver', time='[-\d]+ms': HIT/); $log->empty_ok(); local $CHI::Driver::Test_Time = $start_time + 120; $cache->get($key); $log->contains_ok( qr/cache get for .* key='$key', cache='$driver', time='[-\d]+ms': $miss_expired/ ); $log->empty_ok(); $cache->remove($key); $cache->get($key); $log->contains_ok( qr/cache get for .* key='$key', cache='$driver', time='[-\d]+ms': $miss_not_in_cache/ ); $log->empty_ok(); } # Run tests common to l1_cache and mirror_cache # sub _test_common_subcache_features { my ( $self, $cache, $subcache, $subcache_type ) = @_; my ( $key, $value, $key2, $value2 ) = $self->kvpair(2); for ( $cache, $subcache ) { $_->clear() } # Test informational methods # ok( !$cache->is_subcache, "is_subcache - false" ); ok( $subcache->is_subcache, "is_subcache - true" ); ok( $cache->has_subcaches, "has_subcaches - true" ); ok( !$subcache->has_subcaches, "has_subcaches - false" ); ok( !$cache->can('parent_cache'), "parent_cache - cannot" ); is( $subcache->parent_cache, $cache, "parent_cache - defined" ); ok( !$cache->can('subcache_type'), "subcache_type - cannot" ); is( $subcache->subcache_type, $subcache_type, "subcache_type - defined" ); cmp_deeply( $cache->subcaches, [$subcache], "subcaches - defined" ); ok( !$subcache->can('subcaches'), "subcaches - cannot" ); is( $cache->$subcache_type, $subcache, "$subcache_type - defined" ); ok( !$subcache->can($subcache_type), "$subcache_type - cannot" ); # Test that sets and various kinds of removals and expirations are distributed to both # the primary cache and the subcache # my ( $test_remove_method, $confirm_caches_empty, $confirm_caches_populated ); $test_remove_method = sub { my ( $desc, $remove_code ) = @_; $desc = "testing $desc"; $confirm_caches_empty->("$desc: before set"); $cache->set( $key, $value ); $cache->set( $key2, $value2 ); $confirm_caches_populated->("$desc: after set"); $remove_code->(); $confirm_caches_empty->("$desc: before set_multi"); $cache->set_multi( { $key => $value, $key2 => $value2 } ); $confirm_caches_populated->("$desc: after set_multi"); $remove_code->(); $confirm_caches_empty->("$desc: before return"); }; $confirm_caches_empty = sub { my ($desc) = @_; ok( !defined( $cache->get($key) ), "primary cache is not populated with '$key' - $desc" ); ok( !defined( $subcache->get($key) ), "subcache is not populated with '$key' - $desc" ); ok( !defined( $cache->get($key2) ), "primary cache is not populated #2 with '$key2' - $desc" ); ok( !defined( $subcache->get($key2) ), "subcache is not populated #2 with '$key2' - $desc" ); }; $confirm_caches_populated = sub { my ($desc) = @_; is( $cache->get($key), $value, "primary cache is populated with '$key' - $desc" ); is( $subcache->get($key), $value, "subcache is populated with '$key' - $desc" ); is( $cache->get($key2), $value2, "primary cache is populated with '$key2' - $desc" ); is( $subcache->get($key2), $value2, "subcache is populated with '$key2' - $desc" ); }; $test_remove_method->( 'remove', sub { $cache->remove($key); $cache->remove($key2) } ); $test_remove_method->( 'expire', sub { $cache->expire($key); $cache->expire($key2) } ); $test_remove_method->( 'clear', sub { $cache->clear() } ); } sub _verify_cache_is_cleared { my ( $self, $cache, $desc ) = @_; cmp_deeply( [ $cache->get_keys ], [], "get_keys ($desc)" ); is( scalar( $cache->get_keys ), 0, "scalar(get_keys) = 0 ($desc)" ); while ( my ( $keyname, $key ) = each( %{ $self->{keys} } ) ) { ok( !defined $cache->get($key), "key '$keyname' no longer defined ($desc)" ); } } sub process_keys { my ( $self, $cache, @keys ) = @_; $self->process_key( $cache, 'foo' ); return map { $self->process_key( $cache, $_ ) } @keys; } sub process_key { my ( $self, $cache, $key ) = @_; return $cache->unescape_key( $cache->escape_key( $cache->transform_key($key) ) ); } sub test_clear : Tests { my $self = shift; my $cache = $self->new_cache( namespace => 'name' ); my $cache2 = $self->new_cache( namespace => 'other' ); my $cache3 = $self->new_cache( namespace => 'name' ); $self->num_tests( $self->{key_count} * 2 + 5 ); if ( $self->supports_clear() ) { $self->set_some_keys($cache); $self->set_some_keys($cache2); $cache->clear(); $self->_verify_cache_is_cleared( $cache, 'cache after clear' ); $self->_verify_cache_is_cleared( $cache3, 'cache3 after clear' ); cmp_set( [ $cache2->get_keys ], [ $self->process_keys( $cache2, values( %{ $self->{keys} } ) ) ], 'cache2 untouched by clear' ); } else { throws_ok( sub { $cache->clear() }, qr/not supported/, "clear not supported" ); SKIP: { skip "clear not supported", 9 } } } sub test_logging : Tests { my $self = shift; my $cache = $self->{cache}; my $log = activate_test_logger(); my ( $key, $value ) = $self->kvpair(); my $driver = $cache->label; my $miss_not_in_cache = 'MISS \(not in cache\)'; my $miss_expired = 'MISS \(expired\)'; my $start_time = time(); $cache->get($key); $log->contains_ok( qr/cache get for .* key='$key', cache='$driver', time='[-\d]+ms': $miss_not_in_cache/ ); $log->empty_ok(); $cache->set( $key, $value ); $log->contains_ok( qr/cache set for .* key='$key', size=\d+, expires='never', cache='$driver', time='[-\d]+ms'/ ); $log->empty_ok(); $cache->set( $key, $value, 81 ); $log->contains_ok( qr/cache set for .* key='$key', size=\d+, expires='1m2[012]s', cache='$driver', time='[-\d]+ms'/ ); $log->empty_ok(); $cache->get($key); $log->contains_ok( qr/cache get for .* key='$key', cache='$driver', time='[-\d]+ms': HIT/); $log->empty_ok(); local $CHI::Driver::Test_Time = $start_time + 120; $cache->get($key); $log->contains_ok( qr/cache get for .* key='$key', cache='$driver', time='[-\d]+ms': $miss_expired/ ); $log->empty_ok(); $cache->remove($key); $cache->get($key); $log->contains_ok( qr/cache get for .* key='$key', cache='$driver', time='[-\d]+ms': $miss_not_in_cache/ ); $log->empty_ok(); } sub test_stats : Tests { my $self = shift; return 'author testing only - possible differences between JSON versions' unless ( $ENV{AUTHOR_TESTING} ); my $stats = $self->testing_chi_root_class->stats; $stats->enable(); my ( $key, $value ) = $self->kvpair(); my $start_time = time(); my $cache; $cache = $self->new_cache( namespace => 'Foo' ); $cache->get($key); $cache->set( $key, $value, 80 ); $cache->get($key); local $CHI::Driver::Test_Time = $start_time + 120; $cache->get($key); $cache->remove($key); $cache->get($key); $cache = $self->new_cache( namespace => 'Bar' ); $cache->set( $key, scalar( $value x 3 ) ); $cache->set( $key, $value ); $cache = $self->new_cache( namespace => 'Baz' ); my $code = sub { usleep(100000); scalar( $value x 5 ) }; $cache->compute( $key, undef, $code ); $cache->compute( $key, undef, $code ); $cache->compute( $key, undef, $code ); my $log = activate_test_logger(); my $label = $cache->label; $log->empty_ok(); $stats->flush(); $log->contains_ok( qr/CHI stats: {"absent_misses":2,"end_time":\d+,"expired_misses":1,"get_time_ms":\d+,"hits":1,"label":"$label","namespace":"Foo","root_class":"CHI","set_key_size":6,"set_time_ms":\d+,"set_value_size":20,"sets":1,"start_time":\d+}/ ); $log->contains_ok( qr/CHI stats: {"end_time":\d+,"label":"$label","namespace":"Bar","root_class":"CHI","set_key_size":12,"set_time_ms":\d+,"set_value_size":52,"sets":2,"start_time":\d+}/ ); $log->contains_ok( qr/CHI stats: {"absent_misses":1,"compute_time_ms":\d+,"computes":1,"end_time":\d+,"get_time_ms":\d+,"hits":2,"label":"$label","namespace":"Baz","root_class":"CHI","set_key_size":6,"set_time_ms":\d+,"set_value_size":44,"sets":1,"start_time":\d+}/ ); $log->empty_ok(); my @logs = ( 'CHI stats: {"root_class":"CHI","namespace":"Foo","label":"File","start_time":1338404896,"end_time":1338404899,"hits":3,"sets":5,"set_time_ms":10}', 'CHI stats: {"root_class":"CHI","namespace":"Foo","label":"File","start_time":1338404896,"end_time":1338404899,"hits":1,"sets":7,"set_time_ms":14}', 'CHI stats: {"root_class":"CHI","namespace":"Bar","label":"File","start_time":1338404896,"end_time":1338404899,"hits":4,"sets":9,"set_time_ms":18}', 'CHI stats: {"root_class":"CHI","namespace":"Foo","label":"File","start_time":1338404896,"end_time":1338404899,"sets":3,"set_time_ms":6}', 'CHI stats: {"root_class":"CHI","namespace":"Foo","label":"File","start_time":1338404896,"end_time":1338404899,"hits":8}', 'CHI stats: {"root_class":"CHI","namespace":"Foo","label":"Memory","start_time":1338404896,"end_time":1338404899,"sets":2,"set_time_ms":4}', 'CHI stats: {"root_class":"CHI","namespace":"Bar","label":"File","start_time":1338404896,"end_time":1338404899,"hits":10,"sets":1,"set_time_ms":2}', 'CHI stats: {"root_class":"CHI","namespace":"Bar","label":"File","start_time":1338404896,"end_time":1338404899,"hits":3,"set_errors":2}', ); my $log_dir = tempdir( "chi-test-stats-XXXX", TMPDIR => 1, CLEANUP => 1 ); write_file( "$log_dir/log1", join( "\n", splice( @logs, 0, 4 ) ) . "\n" ); write_file( "$log_dir/log2", join( "\n", @logs ) ); open( my $fh2, "<", "$log_dir/log2" ) or die "cannot open $log_dir/log2"; my $results = $stats->parse_stats_logs( "$log_dir/log1", $fh2 ); close($fh2); cmp_deeply( $results, Test::Deep::bag( { avg_set_time_ms => '2', gets => 12, hit_rate => '1', hits => 12, label => 'File', namespace => 'Foo', root_class => 'CHI', set_time_ms => 30, sets => 15 }, { avg_set_time_ms => '2', gets => 17, hit_rate => '1', hits => 17, label => 'File', namespace => 'Bar', root_class => 'CHI', set_errors => 2, set_time_ms => 20, sets => 10 }, { avg_set_time_ms => '2', label => 'Memory', namespace => 'Foo', root_class => 'CHI', set_time_ms => 4, sets => 2 }, { avg_set_time_ms => '2', hits => '29', label => 'TOTALS', namespace => 'TOTALS', root_class => 'TOTALS', set_errors => '2', set_time_ms => 54, sets => 27 } ), 'parse_stats_logs' ); } sub test_cache_object : Tests { my $self = shift; my $cache = $self->{cache}; my ( $key, $value ) = $self->kvpair(); my $start_time = time(); $cache->set( $key, $value, { expires_at => $start_time + 10 } ); is_between( $cache->get_object($key)->created_at, $start_time, $start_time + 2 ); is_between( $cache->get_object($key)->get_created_at, $start_time, $start_time + 2 ); is( $cache->get_object($key)->expires_at, $start_time + 10 ); is( $cache->get_object($key)->get_expires_at, $start_time + 10 ); local $CHI::Driver::Test_Time = $start_time + 50; $cache->set( $key, $value ); is_between( $cache->get_object($key)->created_at, $start_time + 50, $start_time + 52 ); is_between( $cache->get_object($key)->get_created_at, $start_time + 50, $start_time + 52 ); } sub test_size_awareness : Tests { my $self = shift; my ( $key, $value ) = $self->kvpair(); ok( !$self->new_cleared_cache()->is_size_aware(), "not size aware by default" ); ok( $self->new_cleared_cache( is_size_aware => 1 )->is_size_aware(), "is_size_aware turns on size awareness" ); ok( $self->new_cleared_cache( max_size => 10 )->is_size_aware(), "max_size turns on size awareness" ); my $cache = $self->new_cleared_cache( is_size_aware => 1 ); is( $cache->get_size(), 0, "size is 0 for empty" ); $cache->set( $key, $value ); is_about( $cache->get_size, 20, "size is about 20 with one value" ); $cache->set( $key, scalar( $value x 5 ) ); is_about( $cache->get_size, 45, "size is 45 after overwrite" ); $cache->set( $key, scalar( $value x 5 ) ); is_about( $cache->get_size, 45, "size is still 45 after same overwrite" ); $cache->set( $key, scalar( $value x 2 ) ); is_about( $cache->get_size, 26, "size is 26 after overwrite" ); $cache->remove($key); is( $cache->get_size, 0, "size is 0 again after removing key" ); $cache->set( $key, $value ); is_about( $cache->get_size, 20, "size is about 20 with one value" ); $cache->clear(); is( $cache->get_size, 0, "size is 0 again after clear" ); my $time = time() + 10; $cache->set( $key, $value, { expires_at => $time } ); is( $cache->get_expires_at($key), $time, "set options respected by size aware cache" ); } sub test_max_size : Tests { my $self = shift; is( $self->new_cache( max_size => '30k' )->max_size, 30 * 1024, 'max_size parsing' ); my $cache = $self->new_cleared_cache( max_size => 99 ); ok( $cache->is_size_aware, "is size aware when max_size specified" ); my $value_20 = 'x' x 6; for ( my $i = 0 ; $i < 5 ; $i++ ) { $cache->set( "key$i", $value_20 ); } for ( my $i = 0 ; $i < 10 ; $i++ ) { $cache->set( "key" . int( rand(10) ), $value_20 ); is_between( $cache->get_size, 60, 99, "after iteration $i, size = " . $cache->get_size ); is_between( scalar( $cache->get_keys ), 3, 5, "after iteration $i, keys = " . scalar( $cache->get_keys ) ); } } sub test_max_size_with_l1_cache : Tests { my $self = shift; my $cache = $self->new_cleared_cache( l1_cache => { driver => 'Memory', datastore => {}, max_size => 99 } ); my $l1_cache = $cache->l1_cache; ok( $l1_cache->is_size_aware, "is size aware when max_size specified" ); my $value_20 = 'x' x 6; my @keys = map { "key$_" } ( 0 .. 9 ); my @shuffle_keys = shuffle(@keys); for ( my $i = 0 ; $i < 5 ; $i++ ) { $cache->set( "key$i", $value_20 ); } for ( my $i = 0 ; $i < 10 ; $i++ ) { my $key = $shuffle_keys[$i]; $cache->set( $key, $value_20 ); is_between( $l1_cache->get_size, 60, 99, "after iteration $i, size = " . $l1_cache->get_size ); is_between( scalar( $l1_cache->get_keys ), 3, 5, "after iteration $i, keys = " . scalar( $l1_cache->get_keys ) ); } cmp_deeply( [ sort $cache->get_keys ], \@keys, "primary cache still has all keys" ); # Now test population by writeback $l1_cache->clear(); is( $l1_cache->get_size, 0, "l1 size is 0 after clear" ); for ( my $i = 0 ; $i < 5 ; $i++ ) { $cache->get("key$i"); } for ( my $i = 0 ; $i < 10 ; $i++ ) { my $key = $shuffle_keys[$i]; $cache->get($key); is_between( $l1_cache->get_size, 60, 99, "after iteration $i, size = " . $l1_cache->get_size ); is_between( scalar( $l1_cache->get_keys ), 3, 5, "after iteration $i, keys = " . scalar( $l1_cache->get_keys ) ); } } sub test_custom_discard_policy : Tests { my $self = shift; my $value_20 = 'x' x 6; my $highest_first = sub { my $c = shift; my @sorted_keys = sort( $c->get_keys ); return sub { pop(@sorted_keys) }; }; my $cache = $self->new_cleared_cache( is_size_aware => 1, discard_policy => $highest_first ); for ( my $j = 0 ; $j < 10 ; $j += 2 ) { $cache->clear(); for ( my $i = 0 ; $i < 10 ; $i++ ) { my $k = ( $i + $j ) % 10; $cache->set( "key$k", $value_20 ); } $cache->discard_to_size(100); cmp_set( [ $cache->get_keys ], [ map { "key$_" } ( 0 .. 4 ) ], "5 lowest" ); $cache->discard_to_size(20); cmp_set( [ $cache->get_keys ], ["key0"], "1 lowest" ); } } sub test_discard_timeout : Tests { my $self = shift; return 'author testing only' unless ( $ENV{AUTHOR_TESTING} ); my $bad_policy = sub { return sub { '1' }; }; my $cache = $self->new_cleared_cache( is_size_aware => 1, discard_policy => $bad_policy ); ok( defined( $cache->discard_timeout ) && $cache->discard_timeout > 1, "positive discard timeout" ); $cache->discard_timeout(1); is( $cache->discard_timeout, 1, "can set timeout" ); my $start_time = time; $cache->set( 2, 2 ); throws_ok { $cache->discard_to_size(0) } qr/discard timeout .* reached/; ok( time >= $start_time && time <= $start_time + 4, sprintf( "time (%d) is between %d and %d", time, $start_time, $start_time + 4 ) ); } sub test_size_awareness_with_subcaches : Tests { my $self = shift; my ( $cache, $l1_cache ); my $set_values = sub { my $value_20 = 'x' x 6; for ( my $i = 0 ; $i < 20 ; $i++ ) { $cache->set( "key$i", $value_20 ); } $l1_cache = $cache->l1_cache; }; my $is_size_aware = sub { my $c = shift; my $label = $c->label; ok( $c->is_size_aware, "$label is size aware" ); my $max_size = $c->max_size; ok( $max_size > 0, "$label has max size" ); is_between( $c->get_size, $max_size - 40, $max_size, "$label size = " . $c->get_size ); is_between( scalar( $c->get_keys ), ( $max_size + 1 ) / 20 - 2, ( $max_size + 1 ) / 20, "$label keys = " . scalar( $c->get_keys ) ); }; my $is_not_size_aware = sub { my $c = shift; my $label = $c->label; ok( !$c->is_size_aware, "$label is not size aware" ); is( $c->get_keys, 20, "$label keys = 20" ); }; $cache = $self->new_cleared_cache( l1_cache => { driver => 'Memory', datastore => {}, max_size => 99 } ); $set_values->(); $is_not_size_aware->($cache); $is_size_aware->($l1_cache); $cache = $self->new_cleared_cache( l1_cache => { driver => 'Memory', datastore => {}, max_size => 99 }, max_size => 199 ); $set_values->(); $is_size_aware->($cache); $is_size_aware->($l1_cache); $cache = $self->new_cleared_cache( l1_cache => { driver => 'Memory', datastore => {} }, max_size => 199 ); $set_values->(); $is_size_aware->($cache); # Cannot call is_not_size_aware because the get_keys check will # fail. Keys will be removed from the l1_cache when they are removed # from the main cache, even though l1_cache does not have a max # size. Not sure if this is the correct behavior, but for now, we're not # going to test it. Normally, l1 caches will be more size limited than # their parent caches. # ok( !$l1_cache->is_size_aware, $l1_cache->label . " is not size aware" ); } sub is_about { my ( $value, $expected, $msg ) = @_; my $margin = int( $expected * 0.1 ); if ( abs( $value - $expected ) <= $margin ) { pass($msg); } else { fail("$msg - got $value, expected $expected"); } } sub test_busy_lock : Tests { my $self = shift; my $cache = $self->{cache}; my ( $key, $value ) = $self->kvpair(); my @bl = ( busy_lock => '30 sec' ); my $start_time = time(); local $CHI::Driver::Test_Time = $start_time; $cache->set( $key, $value, 100 ); local $CHI::Driver::Test_Time = $start_time + 90; is( $cache->get( $key, @bl ), $value, "hit before expiration" ); is( $cache->get_expires_at($key), $start_time + 100, "expires_at before expiration" ); local $CHI::Driver::Test_Time = $start_time + 110; ok( !defined( $cache->get( $key, @bl ) ), "miss after expiration" ); is( $cache->get_expires_at($key), $start_time + 140, "expires_at after busy lock" ); is( $cache->get( $key, @bl ), $value, "hit after busy lock" ); } sub test_obj_ref : Tests { my $self = shift; # Make sure obj_ref works in conjunction with subcaches too my $cache = $self->new_cache( l1_cache => { driver => 'Memory', datastore => {} } ); my $obj; my ( $key, $value ) = ( 'medium', [ a => 5, b => 6 ] ); my $validate_obj = sub { isa_ok( $obj, 'CHI::CacheObject' ); is( $obj->key, $key, "keys match" ); cmp_deeply( $obj->value, $value, "values match" ); }; $cache->get( $key, obj_ref => \$obj ); ok( !defined($obj), "obj not defined on miss" ); $cache->set( $key, $value, { obj_ref => \$obj } ); $validate_obj->(); undef $obj; ok( !defined($obj), "obj not defined before get" ); $cache->get( $key, obj_ref => \$obj ); $validate_obj->(); } sub test_metacache : Tests { my $self = shift; my $cache = $self->{cache}; ok( !defined( $cache->{metacache} ), "metacache is lazy" ); $cache->metacache->set( 'foo', 5 ); ok( defined( $cache->{metacache} ), "metacache autovivified" ); is( $cache->metacache->get('foo'), 5 ); } sub test_scalar_return_values : Tests { my $self = shift; my $cache = $self->{cache}; my $check = sub { my ($code) = @_; my $scalar_result = $code->(); my @list = $code->(); cmp_deeply( \@list, [$scalar_result] ); }; $check->( sub { $cache->fetch('a') } ); $check->( sub { $cache->get('a') } ); $check->( sub { $cache->set( 'a', 5 ) } ); $check->( sub { $cache->fetch('a') } ); $check->( sub { $cache->get('a') } ); } sub test_no_leak : Tests { my ($self) = @_; my $weakref; { my $cache = $self->new_cache(); $weakref = $cache; weaken($weakref); ok( defined($weakref) && $weakref->isa('CHI::Driver'), "weakref is defined" ); } ok( !defined($weakref), "weakref is no longer defined - cache was freed" ); } { package My::CHI; $My::CHI::VERSION = '0.60'; our @ISA = qw(CHI); } sub test_driver_properties : Tests { my $self = shift; my $cache = $self->{cache}; is( $cache->chi_root_class, 'CHI', 'chi_root_class=CHI' ); my $cache2 = My::CHI->new( $self->new_cache_options() ); is( $cache2->chi_root_class, 'My::CHI', 'chi_root_class=My::CHI' ); } sub test_missing_params : Tests { my $self = shift; my $cache = $self->{cache}; # These methods require a key foreach my $method ( qw(get get_object get_expires_at exists_and_is_expired is_valid set expire compute get_multi_arrayref get_multi_hashref set_multi remove_multi) ) { throws_ok( sub { $cache->$method() }, qr/must specify key/, "$method throws error when no key passed" ); } } sub test_compute : Tests { my $self = shift; my $cache = $self->{cache}; # Test current arg order and pre-0.40 arg order foreach my $iter ( 0 .. 1 ) { my $count = 5; my $expire_time = time + 10; my @args1 = ( { expires_at => $expire_time }, sub { $count++ } ); my @args2 = ( { expire_if => sub { 1 } }, sub { $count++ } ); if ($iter) { @args1 = reverse(@args1); @args2 = reverse(@args2); } $cache->clear; is( $cache->get('foo'), undef, "miss" ); is( $cache->compute( 'foo', @args1 ), 5, "compute - 5" ); is( $cache->get('foo'), 5, "hit - 5" ); is( $cache->get_object('foo')->expires_at, $expire_time, "expire time" ); is( $cache->compute( 'foo', @args2 ), 6, "compute - 6" ); is( $cache->get('foo'), 6, "hit - 6" ); } # Test wantarray $cache->clear(); my $compute_list = sub { $cache->compute( 'foo', {}, sub { ( int( rand(10000) ) ) x 5 } ); }; my @list1 = $compute_list->(); my @list2 = $compute_list->(); is( scalar(@list1), 5, "list has 5 items" ); cmp_deeply( \@list1, \@list2, "lists are the same" ); } sub test_compress_threshold : Tests { my $self = shift; my $cache = $self->{cache}; my $s0 = 'x' x 180; my $s1 = 'x' x 200; $cache->set( 'key0', $s0 ); $cache->set( 'key1', $s1 ); is_between( $cache->get_object('key0')->size, 180, 220 ); is_between( $cache->get_object('key1')->size, 200, 240 ); my $cache2 = $self->new_cache( compress_threshold => 190 ); $cache2->set( 'key0', $s0 ); $cache2->set( 'key1', $s1 ); is_between( $cache2->get_object('key0')->size, 180, 220 ); ok( $cache2->get_object('key1')->size < 100 ); is( $cache2->get('key0'), $s0 ); is( $cache2->get('key1'), $s1 ); } sub test_expires_on_backend : Tests { my $self = shift; return "skipping - no support for expires_on_backend" unless $self->supports_expires_on_backend(); foreach my $expires_on_backend ( 0, 1 ) { my $cache = $self->new_cache( expires_on_backend => $expires_on_backend ); $cache->set( 'key0', 5, '2s' ); $cache->set( 'key1', 6, { expires_at => time + 2 } ); is( $cache->get('key0'), 5, 'hit key0 before expire' ); is( $cache->get('key1'), 6, 'hit key1 before expire' ); sleep(3); ok( !defined( $cache->get('key0') ), 'miss key0 after expire' ); ok( !defined( $cache->get('key1') ), 'miss key1 after expire' ); if ($expires_on_backend) { ok( !defined( $cache->get_object('key0') ), 'cannot get_object(key0) after expire' ); ok( !defined( $cache->get_object('key1') ), 'cannot get_object(key1) after expire' ); } else { ok( $cache->get_object('key0')->is_expired(), 'can get_object(key0) after expire' ); ok( $cache->get_object('key1')->is_expired(), 'can get_object(key1) after expire' ); } } } sub test_append : Tests { my $self = shift; my $cache = $self->{cache}; my ( $key, $value ) = ( $self->{keys}->{arrayref}, $self->{values}->{medium} ); # Appending to non-existent key has no effect # $cache->append( $key, $value ); ok( !$cache->get($key) ); ok( $cache->set( $key, $value ) ); $cache->append( $key, $value ); is( $cache->get($key), $value . $value ); $cache->append( $key, $value ); is( $cache->get($key), $value . $value . $value ); } sub test_add : Tests { my $self = shift; my $cache = $self->{cache}; my ( $key, $value ) = ( $self->{keys}->{arrayref}, $self->{values}->{medium} ); my $t = time(); $cache->add( $key, $value, { expires_at => $t + 100 } ); is( $cache->get($key), $value, "get" ); is( $cache->get_object($key)->expires_at, $t + 100, "expires_at" ); $cache->add( $key, $value . $value, { expires_at => $t + 200 } ); is( $cache->get($key), $value, "get (after add)" ); is( $cache->get_object($key)->expires_at, $t + 100, "expires_at (after add)" ); $cache->remove($key); $cache->add( $key, $value . $value, { expires_at => $t + 200 } ); is( $cache->get($key), $value . $value, "get (after expire and add)" ); is( $cache->get_object($key)->expires_at, $t + 200, "expires_at (after expire and add)" ); } sub test_replace : Tests { my $self = shift; my $cache = $self->{cache}; my ( $key, $value ) = ( $self->{keys}->{arrayref}, $self->{values}->{medium} ); my $t = time(); $cache->replace( $key, $value, { expires_at => $t + 100 } ); ok( !$cache->get_object($key), "get" ); $cache->set( $key, $value . $value, { expires_at => $t + 200 } ); $cache->replace( $key, $value, { expires_at => $t + 100 } ); is( $cache->get($key), $value, "get (after replace)" ); is( $cache->get_object($key)->expires_at, $t + 100, "expires_at (after replace)" ); } sub test_max_key_length : Tests { my $self = shift; # Test max_key_length and also that key does not get transformed twice in mirror_cache # my $mirror_store = {}; my $cache = $self->new_cleared_cache( max_key_length => 10, mirror_cache => { driver => 'Memory', datastore => $mirror_store } ); foreach my $keyname ( 'medium', 'large' ) { my ( $key, $value ) = ( $self->{keys}->{$keyname}, $self->{values}->{$keyname} ); $cache->set( $key, $value ); is( $cache->get($key), $value, $keyname ); is( $cache->mirror_cache->get($key), $value, $keyname ); if ( $keyname eq 'medium' ) { is( $cache->get_object($key)->key(), $key, "medium key stored" ); } else { isnt( $cache->get_object($key)->key(), $key, "md5 key stored" ); is( length( $cache->get_object($key)->key() ), 32, "md5 key stored" ); } } } # Test that cache does not get corrupted with multiple concurrent processes writing # sub test_multiple_processes : Tests { my $self = shift; return "author test only" unless $ENV{AUTHOR_TESTING}; return "does not pass on file driver" if $self->new_cache->short_driver_name eq 'File'; my ( @values, @pids, %valid_values ); my $shared_key = $self->{keys}->{medium}; my $num_procs = 4; local $SIG{CHLD} = 'IGNORE'; # Each child continuously writes a unique 10000 byte string to a single shared key # my $child_action = sub { my $p = shift; my $value = $values[$p]; my $child_cache = $self->new_cache(); sleep(1); # Wait for parent to be ready my $child_end_time = time() + 5; while ( time < $child_end_time ) { $child_cache->set( $shared_key, $value ); } $child_cache->set( "done$p", 1 ); }; foreach my $p ( 0 .. $num_procs ) { $values[$p] = random_string(10000); $valid_values{ $values[$p] } = $p; if ( my $pid = fork() ) { $pids[$p] = $pid; } else { $child_action->($p); exit; } } # Parent continuously gets shared key, makes sure it is one of the valid values. # Loop until we see done flag for each child process, or until 10 secs pass. # At end make sure we saw each process's value once. # my ( %seen, $error ); my $parent_end_time = time() + 10; my $parent_cache = $self->new_cache(); while ( !$error ) { for ( my $i = 0 ; $i < 100 ; $i++ ) { my $value = $parent_cache->get($shared_key); if ( defined($value) ) { if ( defined( my $p = $valid_values{$value} ) ) { $seen{$p} = 1; } else { $error = "got invalid value '$value' from shared key"; last; } } } if ( !grep { !$parent_cache->get("done$_") } ( 0 .. $num_procs ) ) { last; } if ( time() >= $parent_end_time ) { $error = "did not see all done flags after 10 secs"; } } if ( !$error ) { if ( my ($p) = grep { !$seen{$_} } ( 0 .. $num_procs ) ) { $error = "never saw value from process $p"; } } if ($error) { ok( 0, $error ); } else { ok( 1, "passed" ); } } 1; CHI-0.60/lib/CHI/t/GetError.pm0000644€ˆž«€q{Ì0000000327412535132431015242 0ustar jonswartpackage CHI::t::GetError; $CHI::t::GetError::VERSION = '0.60'; use strict; use warnings; use CHI::Test; use CHI::Test::Util qw(activate_test_logger); use base qw(CHI::Test::Class); sub writeonly_cache { my ($on_get_error) = @_; return CHI->new( # leave as driver_class rather than driver to test back compat driver_class => 'CHI::Test::Driver::Writeonly', on_get_error => $on_get_error, global => 1, ); } sub test_get_errors : Tests { my ( $key, $value ) = ( 'medium', 'medium' ); my $error_pattern = qr/error during cache get for namespace='.*', key='medium'.*: write-only cache/; my $log = activate_test_logger(); my $cache; $cache = writeonly_cache('ignore'); $cache->set( $key, $value ); ok( !defined( $cache->get($key) ), "ignore - miss" ); $cache = writeonly_cache('die'); $cache->set( $key, $value ); throws_ok( sub { $cache->get($key) }, $error_pattern, "die - dies" ); $log->clear(); $cache = writeonly_cache('log'); $cache->set( $key, $value ); ok( !defined( $cache->get($key) ), "log - miss" ); $log->contains_ok(qr/cache set for .* key='medium'/); $log->contains_ok($error_pattern); $log->empty_ok(); my ( $err_msg, $err_key ); $cache = writeonly_cache( sub { ( $err_msg, $err_key ) = @_; } ); $cache->set( $key, $value ); ok( !defined( $cache->get($key) ), "custom - miss" ); like( $err_msg, $error_pattern, "custom - got msg" ); is( $err_key, $key, "custom - got key" ); throws_ok( sub { writeonly_cache('bad') }, qr/Validation failed for|isa check for .* failed/, "bad - dies" ); } 1; CHI-0.60/lib/CHI/t/Initialize.pm0000644€ˆž«€q{Ì0000000172712535132431015613 0ustar jonswartpackage CHI::t::Initialize; $CHI::t::Initialize::VERSION = '0.60'; use strict; use warnings; use CHI::Test; use CHI::Util qw(dump_one_line); use base qw(CHI::Test::Class); sub is_good { my (@params) = @_; my $cache = CHI->new(@params); isa_ok( $cache, 'CHI::Driver', sprintf( "got a good cache with params '%s'", dump_one_line( \@params ) ) ); } sub is_bad { my (@params) = @_; dies_ok( sub { my $cache = CHI->new(@params) }, sprintf( "died with params '%s'", dump_one_line( \@params ) ) ); } sub test_driver_options : Tests { my $cache; is_good( driver => 'Memory', global => 1 ); is_good( driver => 'File' ); is_good( driver_class => 'CHI::Driver::Memory', global => 1 ); is_good( driver_class => 'CHI::Driver::File' ); is_bad( driver_class => 'Memory' ); is_bad( driver => 'CHI::Driver::File' ); is_bad( driver => 'DoesNotExist' ); } 1; CHI-0.60/lib/CHI/t/Null.pm0000644€ˆž«€q{Ì0000000075712535132431014426 0ustar jonswartpackage CHI::t::Null; $CHI::t::Null::VERSION = '0.60'; use strict; use warnings; use CHI::Test; use base qw(CHI::Test::Class); sub test_basic : Tests { my ( $key, $value ) = ( 'medium', 'medium' ); my $cache = CHI->new( driver => 'Null' ); $cache->set( $key, $value ); ok( !defined( $cache->get($key) ), "miss after set" ); cmp_deeply( [ $cache->get_keys ], [], "no keys after set" ); cmp_deeply( [ $cache->get_namespaces ], [], "no namespaces after set" ); } 1; CHI-0.60/lib/CHI/t/RequiredModules.pm0000644€ˆž«€q{Ì0000000045312535132431016616 0ustar jonswartpackage CHI::t::RequiredModules; $CHI::t::RequiredModules::VERSION = '0.60'; use strict; use warnings; use CHI::Test; use base qw(CHI::Test::Class); sub required_modules { return { 'Data::Dumper' => undef, 'blarg' => undef } } sub test_blarg : Tests { require Blarg; Blarg->funny(); } 1; CHI-0.60/lib/CHI/t/Sanity.pm0000644€ˆž«€q{Ì0000000027012535132431014751 0ustar jonswartpackage CHI::t::Sanity; $CHI::t::Sanity::VERSION = '0.60'; use strict; use warnings; use CHI::Test; use base qw(CHI::Test::Class); sub test_ok : Tests { ok( 1, '1 is ok' ); } 1; CHI-0.60/lib/CHI/t/SetError.pm0000644€ˆž«€q{Ì0000000343112535132431015251 0ustar jonswartpackage CHI::t::SetError; $CHI::t::SetError::VERSION = '0.60'; use strict; use warnings; use CHI::Test; use CHI::Test::Util qw(activate_test_logger); use base qw(CHI::Test::Class); sub readonly_cache { my ($on_set_error) = @_; return CHI->new( driver => '+CHI::Test::Driver::Readonly', on_set_error => $on_set_error, global => 1 ); } sub test_set_errors : Tests { my ( $key, $value ) = ( 'medium', 'medium' ); my $error_pattern = qr/error during cache set for namespace='.*', key='medium', size=\d+.*: read-only cache/; my $log = activate_test_logger(); my $cache; $cache = readonly_cache('ignore'); lives_ok( sub { $cache->set( $key, $value ) }, "ignore - lives" ); ok( !defined( $cache->get($key) ), "ignore - miss" ); $cache = readonly_cache('die'); throws_ok( sub { $cache->set( $key, $value ) }, $error_pattern, "die - dies" ); ok( !defined( $cache->get($key) ), "die - miss" ); $log->clear(); $cache = readonly_cache('log'); lives_ok( sub { $cache->set( $key, $value ) }, "log - lives" ); ok( !defined( $cache->get($key) ), "log - miss" ); $log->contains_ok(qr/cache get for .* key='medium', .*: MISS/); $log->contains_ok($error_pattern); $log->empty_ok(); my ( $err_msg, $err_key ); $cache = readonly_cache( sub { ( $err_msg, $err_key ) = @_; } ); lives_ok( sub { $cache->set( $key, $value ) }, "custom - lives" ); ok( !defined( $cache->get($key) ), "custom - miss" ); like( $err_msg, $error_pattern, "custom - got msg" ); is( $err_key, $key, "custom - got key" ); throws_ok( sub { readonly_cache('bad') }, qr/Validation failed for|isa check for ".*" failed/, "bad - dies" ); } 1; CHI-0.60/lib/CHI/t/Subcache.pm0000644€ˆž«€q{Ì0000000262412535132431015224 0ustar jonswartpackage CHI::t::Subcache; $CHI::t::Subcache::VERSION = '0.60'; use CHI::Test; use CHI::Util qw(can_load); use base qw(CHI::Test::Class); use strict; use warnings; sub test_option_inheritance : Tests { my $self = shift; return 'Data::Serializer not installed' unless can_load('Data::Serializer'); my %params = ( expires_variance => 0.2, namespace => 'Blurg', on_get_error => 'warn', on_set_error => 'warn', serializer => 'Data::Dumper', depth => 4, ); my $cache = CHI->new( driver => 'File', %params, l1_cache => { driver => 'File' } ); foreach my $field (qw(expires_variance namespace on_get_error on_set_error)) { is( $cache->$field, $cache->l1_cache->$field, "$field matches" ); } is( $cache->l1_cache->serializer->serializer, 'Data::Dumper', 'l1 cache serializer' ); is( $cache->depth, 4, 'cache depth' ); is( $cache->l1_cache->depth, 2, 'l1 cache depth' ); } sub test_bad_subcache_option : Tests { my $self = shift; throws_ok( sub { CHI->new( driver => 'Memory', global => 1, l1_cache => CHI->new( driver => 'Memory', global => 1 ) ); }, qr/Validation failed for|isa check for .*? failed/, 'cannot pass cache object as subcache' ); } 1; CHI-0.60/lib/CHI/t/Subclass.pm0000644€ˆž«€q{Ì0000000146012535132431015263 0ustar jonswartpackage CHI::t::Subclass; $CHI::t::Subclass::VERSION = '0.60'; use strict; use warnings; use CHI::Test; use base qw(CHI::Test::Class); # Test declare_unsupported_methods # { package CHI::t::Subclass::Driver::HasUnsupported; $CHI::t::Subclass::Driver::HasUnsupported::VERSION = '0.60'; use Moo; extends 'CHI::Driver::Memory'; __PACKAGE__->declare_unsupported_methods(qw(get_namespaces)); } sub test_unsupported : Tests { my $cache = CHI->new( driver_class => 'CHI::t::Subclass::Driver::HasUnsupported', global => 1 ); lives_ok( sub { $cache->get_keys }, 'get_keys lives' ); throws_ok( sub { $cache->get_namespaces }, qr/method 'get_namespaces' not supported by 'CHI::t::Subclass::Driver::HasUnsupported'/, 'get_namespaces dies' ); } 1; CHI-0.60/lib/CHI/t/Util.pm0000644€ˆž«€q{Ì0000000261112535132431014420 0ustar jonswartpackage CHI::t::Util; $CHI::t::Util::VERSION = '0.60'; use strict; use warnings; use CHI::Test; use CHI::Util qw(unique_id parse_memory_size); use CHI::Test::Util qw(random_string); use List::MoreUtils qw(uniq); use base qw(CHI::Test::Class); # The inevitably lame unique_id test sub test_unique_id : Tests { my @ids = map { unique_id } ( 0 .. 9 ); cmp_deeply( \@ids, [ uniq(@ids) ], 'generated ten unique ids' ); } sub test_random_string : Tests { my @strings = map { random_string(100) } ( 0 .. 2 ); cmp_deeply( \@strings, [ uniq(@strings) ], 'generated three unique strings' ); cmp_deeply( [ map { length($_) } @strings ], [ 100, 100, 100 ], 'lengths are 100' ); } sub test_non_common_constructor_params : Tests { my $params = { map { ( $_, 1 ) } qw( foo expires_in bar baz on_get_error ) }; my $non_common_params = CHI::Driver->non_common_constructor_params($params); cmp_deeply( $non_common_params, { map { ( $_, 1 ) } qw(foo bar baz) } ); } sub test_parse_memory_size : Tests { my %results = ( '12345' => '12345', '50K' => 50 * 1024, '8Mb' => 8 * 1024 * 1024, '301k' => 301 * 1024, ); while ( my ( $input, $expected ) = each(%results) ) { is( parse_memory_size($input), $expected ); } throws_ok { parse_memory_size('8kk') } qr/cannot parse/; } 1; CHI-0.60/lib/CHI/Test/0000775€ˆž«€q{Ì0000000000012535132431013623 5ustar jonswartCHI-0.60/lib/CHI/Test/Class.pm0000644€ˆž«€q{Ì0000000125512535132431015227 0ustar jonswartpackage CHI::Test::Class; $CHI::Test::Class::VERSION = '0.60'; use Getopt::Long; use CHI::Util qw(can_load); use strict; use warnings; use base qw(Test::Class); sub runtests { my ($class) = @_; # Check for required modules # if ( my $required_modules = $class->required_modules ) { while ( my ( $key, $value ) = each(%$required_modules) ) { unless ( can_load($key) ) { $class->SKIP_ALL("one of required modules not installed: $key"); } } } # Only run tests directly in $class. # my $test_obj = $class->new(); Test::Class::runtests($test_obj); } sub required_modules { return {}; } 1; CHI-0.60/lib/CHI/Test/Driver/0000775€ˆž«€q{Ì0000000000012535132431015056 5ustar jonswartCHI-0.60/lib/CHI/Test/Driver/NonMoose.pm0000644€ˆž«€q{Ì0000000023712535132431017151 0ustar jonswartpackage CHI::Test::Driver::NonMoose; $CHI::Test::Driver::NonMoose::VERSION = '0.60'; use Carp; use strict; use warnings; use base qw(CHI::Driver::Memory); 1; CHI-0.60/lib/CHI/Test/Driver/Readonly.pm0000644€ˆž«€q{Ì0000000036612535132431017174 0ustar jonswartpackage CHI::Test::Driver::Readonly; $CHI::Test::Driver::Readonly::VERSION = '0.60'; use Carp; use Moo; use strict; use warnings; extends 'CHI::Driver::Memory'; sub store { my ( $self, $key, $data ) = @_; croak "read-only cache"; } 1; CHI-0.60/lib/CHI/Test/Driver/Role/0000775€ˆž«€q{Ì0000000000012535132431015757 5ustar jonswartCHI-0.60/lib/CHI/Test/Driver/Role/CheckKeyValidity.pm0000644€ˆž«€q{Ì0000000111712535132431021507 0ustar jonswartpackage CHI::Test::Driver::Role::CheckKeyValidity; $CHI::Test::Driver::Role::CheckKeyValidity::VERSION = '0.60'; use Carp; use Moo::Role; use strict; use warnings; has 'test_object' => ( is => 'rw' ); before 'get' => sub { my ( $self, $key ) = @_; $self->verify_valid_test_key($key); }; before 'set' => sub { my ( $self, $key ) = @_; $self->verify_valid_test_key($key); }; sub verify_valid_test_key { my ( $self, $key ) = @_; croak "invalid test key '$key'" if ( defined($key) && !exists( $self->test_object->{all_test_keys_hash}->{$key} ) ); } 1; CHI-0.60/lib/CHI/Test/Driver/Writeonly.pm0000644€ˆž«€q{Ì0000000036212535132431017407 0ustar jonswartpackage CHI::Test::Driver::Writeonly; $CHI::Test::Driver::Writeonly::VERSION = '0.60'; use Carp; use strict; use warnings; use Moo; extends 'CHI::Driver::Memory'; sub fetch { my ( $self, $key ) = @_; croak "write-only cache"; } 1; CHI-0.60/lib/CHI/Test/Util.pm0000644€ˆž«€q{Ì0000000256512535132431015104 0ustar jonswartpackage CHI::Test::Util; $CHI::Test::Util::VERSION = '0.60'; use Date::Parse; use Test::Builder; use Test::More; use strict; use warnings; use base qw(Exporter); our @EXPORT_OK = qw(activate_test_logger is_between cmp_bool random_string skip_until); sub activate_test_logger { my $log = Log::Any->get_logger( category => 'CHI' ); $log->clear(); return $log; } sub is_between { my ( $value, $min, $max, $desc ) = @_; my $tb = Test::Builder->new(); if ( $value >= $min && $value <= $max ) { $tb->ok( 1, $desc ); } else { $tb->diag("$value is not between $min and $max"); $tb->ok( undef, $desc ); } } sub cmp_bool { my ( $bool1, $bool2, $desc ) = @_; my $tb = Test::Builder->new(); if ( $bool1 && !$bool2 ) { $tb->ok( 0, "$desc - bool1 is true, bool2 is false" ); } elsif ( !$bool1 && $bool2 ) { $tb->ok( 0, "$desc - bool1 is false, bool2 is true" ); } else { $tb->ok( 1, $desc ); } } sub skip_until { my ( $until_str, $how_many, $code ) = @_; my $until = str2time($until_str); SKIP: { skip "until $until_str", $how_many if ( time < $until ); $code->(); } } # Generate random string of printable ASCII characters. # sub random_string { my ($length) = @_; return join( '', map { chr( int( rand(95) + 33 ) ) } ( 1 .. $length ) ); } 1; CHI-0.60/lib/CHI/Test.pm0000644€ˆž«€q{Ì0000000220712535132431014160 0ustar jonswart# $Id: $ # package CHI::Test; $CHI::Test::VERSION = '0.60'; use Log::Any::Test; # as early as possible use List::MoreUtils qw(uniq); use Module::Runtime qw(require_module); use CHI; use CHI::Driver::Memory; use strict; use warnings; sub import { my $class = shift; $class->export_to_level( 1, undef, @_ ); } sub packages_to_import { return ( qw( Test::Deep Test::More Test::Exception CHI::Test::Util ) ); } sub export_to_level { my ( $class, $level, $ignore ) = @_; foreach my $package ( $class->packages_to_import() ) { require_module($package); my @export; if ( $package eq 'Test::Deep' ) { # Test::Deep exports way too much by default @export = qw(eq_deeply cmp_deeply cmp_set cmp_bag cmp_methods subbagof superbagof subsetof supersetof superhashof subhashof); } else { # Otherwise, grab everything from @EXPORT no strict 'refs'; @export = @{"$package\::EXPORT"}; } $package->export_to_level( $level + 1, undef, @export ); } } 1; CHI-0.60/lib/CHI/Types.pm0000644€ˆž«€q{Ì0000000720312535132431014346 0ustar jonswartpackage CHI::Types; $CHI::Types::VERSION = '0.60'; use Carp; use CHI::Util qw(can_load parse_duration parse_memory_size); use MooX::Types::MooseLike qw(exception_message); use MooX::Types::MooseLike::Base qw(:all); use MooX::Types::MooseLike::Numeric qw(:all); use base qw(Exporter); use strict; use warnings; our @EXPORT_OK = (); our %EXPORT_TAGS = ( 'all' => \@EXPORT_OK ); MooX::Types::MooseLike::register_types( [ { name => 'OnError', test => sub { ref( $_[0] ) eq 'CODE' || $_[0] =~ /^(?:ignore|warn|die|log)$/; }, message => sub { return exception_message( $_[0], 'a coderef or error level' ); }, inflate => 0, }, { name => 'Duration', subtype_of => PositiveInt, test => sub { 1 }, message => sub { return exception_message( $_[0], 'a positive integer' ) }, inflate => 0, }, { name => 'MemorySize', subtype_of => PositiveInt, test => sub { 1 }, message => sub { return exception_message( $_[0], 'a positive integer' ) }, inflate => 0, }, { name => 'DiscardPolicy', test => sub { !ref( $_[0] ) || ref( $_[0] ) eq 'CODE' }, message => sub { return exception_message( $_[0], 'a coderef or policy name' ); }, inflate => 0, }, { name => 'Serializer', subtype_of => Object, test => sub { 1 }, message => sub { return exception_message( $_[0], 'a serializer, hashref, or string' ); }, inflate => 0, }, { name => 'Digester', subtype_of => Object, test => sub { 1 }, message => sub { return exception_message( $_[0], 'a digester, hashref, or string' ); }, inflate => 0, } ], __PACKAGE__ ); sub to_MemorySize { my $from = shift; if ( is_Num($from) ) { $from; } elsif ( is_Str($from) ) { parse_memory_size($from); } else { $from; } } push @EXPORT_OK, 'to_MemorySize'; sub to_Duration { my $from = shift; if ( is_Str($from) ) { parse_duration($from); } else { $from; } } push @EXPORT_OK, 'to_Duration'; sub to_Serializer { my $from = shift; if ( is_HashRef($from) ) { _build_data_serializer($from); } elsif ( is_Str($from) ) { _build_data_serializer( { serializer => $from, raw => 1 } ); } else { $from; } } push @EXPORT_OK, 'to_Serializer'; sub to_Digester { my $from = shift; if ( is_HashRef($from) ) { _build_digester(%$from); } elsif ( is_Str($from) ) { _build_digester($from); } else { $from; } } push @EXPORT_OK, 'to_Digester'; my $data_serializer_loaded = can_load('Data::Serializer'); sub _build_data_serializer { my ($params) = @_; if ($data_serializer_loaded) { return Data::Serializer->new(%$params); } else { croak "Could not load Data::Serializer - install Data::Serializer from CPAN to support serializer argument"; } } my $digest_loaded = can_load('Digest'); sub _build_digester { if ($digest_loaded) { return Digest->new(@_); } else { croak "Digest could not be loaded, cannot handle digester argument"; } } 1; CHI-0.60/lib/CHI/Util.pm0000644€ˆž«€q{Ì0000001046712535132431014165 0ustar jonswartpackage CHI::Util; $CHI::Util::VERSION = '0.60'; use Carp qw( croak longmess ); use Module::Runtime qw(require_module); use Data::Dumper; use Data::UUID; use Fcntl qw( :DEFAULT ); use File::Spec::Functions qw(catdir catfile); use JSON::MaybeXS; use Time::Duration::Parse; use Try::Tiny; use strict; use warnings; use base qw(Exporter); our @EXPORT_OK = qw( can_load dump_one_line fast_catdir fast_catfile has_moose_class json_decode json_encode parse_duration parse_memory_size read_file read_dir unique_id write_file ); my $Fetch_Flags = O_RDONLY | O_BINARY; my $Store_Flags = O_WRONLY | O_CREAT | O_BINARY; sub can_load { # Load $class_name if possible. Return 1 if successful, 0 if it could not be # found, and rethrow load error (other than not found). # my ($class_name) = @_; my $result; try { require_module($class_name); $result = 1; } catch { if ( /Can\'t locate .* in \@INC/ && !/Compilation failed/ ) { $result = 0; } else { die $_; } }; return $result; } sub dump_one_line { my ($value) = @_; return Data::Dumper->new( [$value] )->Indent(0)->Sortkeys(1)->Quotekeys(0) ->Terse(1)->Dump(); } # Simplified read_dir cribbed from File::Slurp sub read_dir { my ($dir) = @_; ## no critic (RequireInitializationForLocalVars) local *DIRH; opendir( DIRH, $dir ) or croak "cannot open '$dir': $!"; return grep { $_ ne "." && $_ ne ".." } readdir(DIRH); } sub read_file { my ($file) = @_; # Fast slurp, adapted from File::Slurp::read, with unnecessary options removed # my $buf = ""; my $read_fh; unless ( sysopen( $read_fh, $file, $Fetch_Flags ) ) { croak "read_file '$file' - sysopen: $!"; } my $size_left = -s $read_fh; while (1) { my $read_cnt = sysread( $read_fh, $buf, $size_left, length $buf ); if ( defined $read_cnt ) { last if $read_cnt == 0; $size_left -= $read_cnt; last if $size_left <= 0; } else { croak "read_file '$file' - sysread: $!"; } } return $buf; } sub write_file { my ( $file, $data, $file_create_mode ) = @_; $file_create_mode = oct(666) if !defined($file_create_mode); # Fast spew, adapted from File::Slurp::write, with unnecessary options removed # { my $write_fh; unless ( sysopen( $write_fh, $file, $Store_Flags, $file_create_mode ) ) { croak "write_file '$file' - sysopen: $!"; } my $size_left = length($data); my $offset = 0; do { my $write_cnt = syswrite( $write_fh, $data, $size_left, $offset ); unless ( defined $write_cnt ) { croak "write_file '$file' - syswrite: $!"; } $size_left -= $write_cnt; $offset += $write_cnt; } while ( $size_left > 0 ); } } { # For efficiency, use Data::UUID to generate an initial unique id, then suffix it to # generate a series of 0x10000 unique ids. Not to be used for hard-to-guess ids, obviously. my $uuid; my $suffix = 0; sub unique_id { if ( !$suffix || !defined($uuid) ) { my $ug = Data::UUID->new(); $uuid = $ug->create_hex(); } my $hex = sprintf( '%s%04x', $uuid, $suffix ); $suffix = ( $suffix + 1 ) & 0xffff; return $hex; } } use constant _FILE_SPEC_USING_UNIX => ( $File::Spec::ISA[0] eq 'File::Spec::Unix' ); sub fast_catdir { if (_FILE_SPEC_USING_UNIX) { return join '/', @_; } else { return catdir(@_); } } sub fast_catfile { if (_FILE_SPEC_USING_UNIX) { return join '/', @_; } else { return catfile(@_); } } my %memory_size_units = ( 'k' => 1024, 'm' => 1024 * 1024 ); sub parse_memory_size { my $size = shift; if ( $size =~ /^\d+b?$/ ) { return $size; } elsif ( my ( $quantity, $unit ) = ( $size =~ /^(\d+)\s*([km])b?$/i ) ) { return $quantity * $memory_size_units{ lc($unit) }; } else { croak "cannot parse memory size '$size'"; } } my $json = JSON::MaybeXS->new( utf8 => 1, canonical => 1 ); sub json_decode { $json->decode( $_[0] ); } sub json_encode { $json->encode( $_[0] ); } 1; __END__ CHI-0.60/lib/CHI.pm0000644€ˆž«€q{Ì0000013375512535132431013256 0ustar jonswartpackage CHI; $CHI::VERSION = '0.60'; use 5.006; use Carp; use CHI::Stats; use String::RewritePrefix; use Module::Runtime qw(require_module); use Moo::Role (); use strict; use warnings; my ( %final_class_seen, %memoized_cache_objects, %stats ); my %valid_config_keys = map { ( $_, 1 ) } qw(defaults memoize_cache_objects namespace storage); sub logger { warn "CHI now uses Log::Any for logging - see Log::Any documentation for details"; } sub config { my $class = shift; $class->_set_config(@_) if @_; return $class->_get_config(); } sub _set_config { my ( $class, $config ) = @_; if ( my @bad_keys = grep { !$valid_config_keys{$_} } keys(%$config) ) { croak "unknown keys in config hash: " . join( ", ", @bad_keys ); } # set class specific configuration no strict 'refs'; no warnings 'redefine'; *{"$class\::_get_config"} = sub { $config }; } BEGIN { __PACKAGE__->config( {} ) } sub memoized_cache_objects { my ($class) = @_; # Each CHI root class gets its hash of memoized objects # $memoized_cache_objects{$class} ||= {}; return $memoized_cache_objects{$class}; } sub clear_memoized_cache_objects { my ($class) = @_; $memoized_cache_objects{$class} = {}; } sub stats { my ($class) = @_; # Each CHI root class gets its own stats object # $stats{$class} ||= CHI::Stats->new( chi_root_class => $class ); return $stats{$class}; } sub new { my ( $chi_root_class, %params ) = @_; my $config = $chi_root_class->config; # Cache object memoization: See if cache object with these parameters # has already been created, and return it if so. Only for parameters # with 0 or 1 keys. # my ( $cache_object_key, $cache_objects ); if ( $config->{memoize_cache_objects} && keys(%params) <= 1 ) { $cache_object_key = join chr(28), %params; $cache_objects = $chi_root_class->memoized_cache_objects; if ( my $cache_object = $cache_objects->{$cache_object_key} ) { return $cache_object; } } # Gather defaults # my $core_defaults = $config->{defaults} || {}; my $namespace_defaults = $config->{namespace}->{ $params{namespace} || 'Default' } || {}; my $storage = $params{storage} || $namespace_defaults->{storage} || $core_defaults->{storage}; my $storage_defaults = {}; if ( defined($storage) ) { $storage_defaults = $config->{storage}->{$storage} or croak "no config for storage type '$storage'"; } # Combine passed params with defaults # %params = ( %$core_defaults, %$storage_defaults, %$namespace_defaults, %params ); # Get driver class from driver or driver_class parameters # my $driver_class; if ( my $driver = delete( $params{driver} ) ) { ($driver_class) = String::RewritePrefix->rewrite( { '' => 'CHI::Driver::', '+' => '' }, $driver ); } else { $driver_class = delete( $params{driver_class} ); } croak "missing required param 'driver' or 'driver_class'" unless defined $driver_class; # Load driver class if it hasn't been loaded or defined in-line already # unless ( $driver_class->can('fetch') ) { require_module($driver_class); } # Select roles depending on presence of certain arguments. Everyone gets # the Universal role. Accept both 'roles' and 'traits' for backwards # compatibility. Add CHI::Driver::Role:: unless prefixed with '+'. # my @roles = ('Universal'); foreach my $param_name (qw(roles traits)) { if ( exists( $params{$param_name} ) ) { push( @roles, @{ delete( $params{$param_name} ) } ); } } if ( exists( $params{max_size} ) || exists( $params{is_size_aware} ) ) { push( @roles, 'IsSizeAware' ); } if ( exists( $params{l1_cache} ) || exists( $params{mirror_cache} ) ) { push( @roles, 'HasSubcaches' ); } if ( $params{is_subcache} ) { push( @roles, 'IsSubcache' ); } @roles = String::RewritePrefix->rewrite( { '' => 'CHI::Driver::Role::', '+' => '' }, @roles ); # Select a final class based on the driver class and roles, creating it # if necessary - adapted from MooseX::Traits # my $final_class = Moo::Role->create_class_with_roles( $driver_class, @roles ); my $cache_object = $final_class->new( chi_root_class => $chi_root_class, driver_class => $driver_class, %params ); # Memoize if appropriate # if ($cache_object_key) { $cache_objects->{$cache_object_key} = $cache_object; } return $cache_object; } 1; __END__ =pod =head1 NAME CHI - Unified cache handling interface =head1 VERSION version 0.60 =head1 SYNOPSIS use CHI; # Choose a standard driver # my $cache = CHI->new( driver => 'Memory', global => 1 ); my $cache = CHI->new( driver => 'RawMemory', global => 1 ); my $cache = CHI->new( driver => 'File', root_dir => '/path/to/root' ); my $cache = CHI->new( driver => 'FastMmap', root_dir => '/path/to/root', cache_size => '1k' ); my $cache = CHI->new( driver => 'Memcached::libmemcached', servers => [ "10.0.0.15:11211", "10.0.0.15:11212" ], l1_cache => { driver => 'FastMmap', root_dir => '/path/to/root' } ); my $cache = CHI->new( driver => 'DBI', dbh => $dbh ); my $cache = CHI->new( driver => 'BerkeleyDB', root_dir => '/path/to/root' ); # Create your own driver # my $cache = CHI->new( driver => '+My::Special::Driver', ... ); # Cache operations # my $customer = $cache->get($name); if ( !defined $customer ) { $customer = get_customer_from_db($name); $cache->set( $name, $customer, "10 minutes" ); } my $customer2 = $cache->compute($name2, "10 minutes", sub { get_customer_from_db($name2) }); $cache->remove($name); =head1 DESCRIPTION CHI provides a unified caching API, designed to assist a developer in persisting data for a specified period of time. The CHI interface is implemented by driver classes that support fetching, storing and clearing of data. Driver classes exist or will exist for the gamut of storage backends available to Perl, such as memory, plain files, memory mapped files, memcached, and DBI. CHI is intended as an evolution of DeWitt Clinton's L package, adhering to the basic Cache API but adding new features and addressing limitations in the Cache::Cache implementation. =head1 FEATURES =over =item * Easy to create new drivers =item * Uniform support for namespaces =item * Automatic serialization of keys and values =item * Multilevel caches =item * Probabilistic expiration and busy locks, to reduce cache miss stampedes =item * Optional logging and statistics collection of cache activity =back =for readme stop =head1 CONSTRUCTOR To create a new cache object, call C<new>. It takes the common options listed below. I is required; all others are optional. Some drivers will take additional constructor options. For example, the File driver takes C and C options. You can configure default options for each new cache object created - see L. Note that Cnew> returns an instance of a subclass of L, not C. =over =item compress_threshold [INT] A value in bytes. Automatically compress values larger than this before storing. Requires L to be installed. Defaults to undef, meaning no automatic compression. Inspired by the parameter of the same name in L. # Compress values larger than 1MB compress_threshold => 1024*1024 =item driver [STRING] Required. The name of a cache driver, for example "Memory" or "File". CHI will prefix the string with "CHI::Driver::", unless it begins with '+'. e.g. driver => 'File'; # uses CHI::Driver::File driver => '+My::CHI::Driver::File' # uses My::CHI::Driver::File =item expires_in [DURATION], expires_at [INT], expires_variance [FLOAT] Provide default values for the corresponding L options. =item expires_on_backend [NUM] If set to 0 (the default), CHI alone is aware of the expiration time and does not pass it along to the backend driver. This allows you to use L to retrieve expired items. If set to 1, pass expiration times to backend driver if the driver supports it -- for example, L and L. This may allow the driver to better manage its space and evict items. Note that only simple expiration time will be passed along, e.g. not L. If set to a number greater than 1 (e.g. 1.25), the time until expiration will be multiplied by that number before being passed to the backend driver. This gives you a customizable window of opportunity to retrieve expired items. =item key_digester [STRING|HASHREF|OBJECT] Digest algorithm to use on keys longer than L - e.g. "MD5", "SHA-1", or "SHA-256". Can be a L object, or a string or hashref which will passed to Digest->new(). You will need to ensure Digest is installed to use these options. Default is "MD5". =item key_serializer [STRING|HASHREF|OBJECT] An object to use for serializing keys that are references. See L above for the different ways this can be passed in. The default is to use the JSON backend in canonical mode (sorted hash keys). =item label [STRING] A label for the cache as a whole, independent of namespace - e.g. "web-file-cache". Used when referring to the cache in logs, L, and error messages. By default, set to L. =item l1_cache [HASHREF] Add an L1 cache as a subcache. See L. =item max_key_length [INT] Keys over this size will be L. The default is driver-specific; L, for example, defaults this to 240 due to file system limits. For most drivers there is no maximum. =item mirror_cache [HASHREF] Add an mirror cache as a subcache. See L. =item namespace [STRING] Identifies a namespace that all cache entries for this object will be in. This allows easy separation of multiple, distinct caches without worrying about key collision. Suggestions for easy namespace selection: =over =item * In a class, use the class name: my $cache = CHI->new(namespace => __PACKAGE__, ...); =item * In a script, use the script's absolute path name: use Cwd qw(realpath); my $cache = CHI->new(namespace => realpath($0), ...); =item * In a web template, use the template name. For example, in Mason, $m-Ecache will set the namespace to the current component path. =back Defaults to 'Default' if not specified. =item on_get_error [STRING|CODEREF] =item on_set_error [STRING|CODEREF] How to handle runtime errors occurring during cache gets and cache sets, which may or may not be considered fatal in your application. Options are: =over =item * log (the default) - log an error, or ignore if no logger is set - see L =item * ignore - do nothing =item * warn - call warn() with an appropriate message =item * die - call die() with an appropriate message =item * I - call this code reference with three arguments: an appropriate message, the key, and the original raw error message =back =item serializer [STRING|HASHREF|OBJECT] An object to use for serializing data before storing it in the cache, and deserializing data after retrieving it from the cache. Only references will be serialized; plain scalars will be placed in the cache as-is. If this is a string, a L object will be created, with the string passed as the 'serializer' option and raw=1. Common options include 'Storable', 'Data::Dumper', and 'YAML'. If this is a hashref, Lnew> will be called with the hash. You will need to ensure Data::Serializer is installed to use these options. Otherwise, this must be a L object or another object that implements I and I. e.g. # Serialize using raw Data::Dumper my $cache = CHI->new(serializer => 'Data::Dumper'); # Serialize using Data::Dumper, compressed and (per Data::Serializer defaults) hex-encoded my $cache = CHI->new(serializer => { serializer => 'Data::Dumper', compress => 1 }); # Serialize using custom object my $cache = CHI->new(serializer => My::Custom::Serializer->new()) The default is to use raw Storable. =item traits [LISTREF] List of one or more roles to apply to the C class that is constructed. The roles will automatically be prefixed with C unless preceded with a '+'. e.g. traits => ['StoresAccessedAt', '+My::CHI::Driver::Role'] =back =head1 INSTANCE METHODS The following methods can be called on any cache handle returned from CHI-Enew(). They are implemented in the L package. =head2 Getting and setting =over =item get( $key, [option =E value, ...] ) Returns the data associated with I<$key>. If I<$key> does not exist or has expired, returns undef. Expired items are not automatically removed and may be examined with L or L. I<$key> may be followed by one or more name/value parameters: =over =item expire_if [CODEREF] If I<$key> exists and has not expired, call code reference with the L and L as the parameters. If code returns a true value, C returns undef as if the item were expired. For example, to treat the cache as expired if I<$file> has changed since the value was computed: $cache->get('foo', expire_if => sub { $_[0]->created_at < (stat($file))[9] }); =item busy_lock [DURATION] If the value has expired, the get will still return undef, but the expiration time of the cache entry will be set to the current time plus the specified L. This is used to prevent multiple processes from recomputing the same expensive value simultaneously. The problem with this technique is that it doubles the number of writes performed - see L for another technique. =item obj_ref [SCALARREF] If the item exists in cache (even if expired), place the L object in the provided SCALARREF. =back =item set( $key, $data, [$expires_in | "now" | "never" | options] ) Associates I<$data> with I<$key> in the cache, overwriting any existing entry. Returns I<$data>. The third argument to C is optional, and may be either a scalar or a hash reference. If it is a scalar, it may be the string "now", the string "never", or else a duration treated as an I value described below. If it is a hash reference, it may contain one or more of the following options. Most of these options can be provided with defaults in the cache constructor. =over =item expires_in [DURATION] Amount of time from now until this data expires. I may be an integer number of seconds or a L. =item expires_at [INT] The epoch time at which the data expires. =item expires_variance [FLOAT] Controls the variable expiration feature, which allows items to expire a little earlier than the stated expiration time to help prevent cache miss stampedes. Value is between 0.0 and 1.0, with 0.0 meaning that items expire exactly when specified (feature is disabled), and 1.0 meaning that items might expire anytime from now until the stated expiration time. The default is 0.0. A setting of 0.10 to 0.25 would introduce a small amount of variation without interfering too much with intended expiration times. The probability of expiration increases as a function of how far along we are in the potential expiration window, with the probability being near 0 at the beginning of the window and approaching 1 at the end. For example, in all of the following cases, an item might be considered expired any time between 15 and 20 minutes, with about a 20% chance at 16 minutes, a 40% chance at 17 minutes, and a 100% chance at 20 minutes. my $cache = CHI->new ( ..., expires_variance => 0.25, ... ); $cache->set($key, $value, '20 min'); $cache->set($key, $value, { expires_at => time() + 20*60 }); my $cache = CHI->new ( ... ); $cache->set($key, $value, { expires_in => '20 min', expires_variance => 0.25 }); CHI will make a new probabilistic choice every time it needs to know whether an item has expired (i.e. it does not save the results of its determination), so you can get situations like this: my $value = $cache->get($key); # returns undef (indicating expired) my $value = $cache->get($key); # returns valid value this time! if ($cache->is_valid($key)) # returns undef (indicating expired) if ($cache->is_valid($key)) # returns true this time! Typical applications won't be affected by this, since the object is recomputed as soon as it is determined to be expired. But it's something to be aware of. =back =item compute( $key, $options, $code ) Combines the C and C operations in a single call. Attempts to get I<$key>; if successful, returns the value. Otherwise, calls I<$code> and uses the return value as the new value for I<$key>, which is then returned. Caller context (scalar or list) is respected. I<$options> can be undef, a scalar, or a hash reference. If it is undef, it has no effect. If it is a scalar, it is treated as the C duration and passed as the third argument to C. If it is a hash reference, it may contain name/value pairs for both C and C. e.g. # No expiration my $value = $cache->compute($key, undef, sub { # compute and return value for $key here }); # Expire in 5 minutes my $value = $cache->compute($key, '5min', sub { # compute and return value for $key here }); # Expire in 5 minutes or when a particular condition occurs my $value = $cache->compute($key, { expires_in => '5min', expire_if => sub { ... } }, sub { # compute and return value for $key here }); # List context my @value = $cache->compute($key, '5min', sub { ... return @some_list; }); This method will eventually support the ability to recompute a value in the background just before it actually expires, so that users are not impacted by recompute time. Note: Prior to version 0.40, the last two arguments were in reverse order; both will be accepted for backward compatibility. We think the coderef looks better at the end. =back =head2 Removing and expiring =over =item remove( $key ) Remove the data associated with the I<$key> from the cache. =item expire( $key ) If I<$key> exists, expire it by setting its expiration time into the past. Does not necessarily remove the data. Since this involves essentially setting the value again, C may be more efficient for some drivers. =back =head2 Inspecting keys =over =item is_valid( $key ) Returns a boolean indicating whether I<$key> exists in the cache and has not expired. Note: Expiration may be determined probabilistically if L was used. =item exists_and_is_expired( $key ) Returns a boolean indicating whether I<$key> exists in the cache and has expired. Note: Expiration may be determined probabilistically if L was used. =item get_expires_at( $key ) Returns the epoch time at which I<$key> definitively expires. Returns undef if the key does not exist or it has no expiration time. =item get_object( $key ) Returns a L object containing data about the entry associated with I<$key>, or undef if no such key exists. The object will be returned even if the entry has expired, as long as it has not been removed. =back =head2 Atomic operations (ALPHA) These methods combine both reading and writing of a cache entry in a single operation. The names and behaviors were adapted from L. Some drivers (e.g. L, L) may implement these as truly atomic operations, and will be documented thusly. The default implementations are not atomic: the get and set occur discretely and another process could potentially modify the cache in between them. These operations are labeled ALPHA because we haven't yet figured out how they integrate with other CHI features, in particular L. APIs and behavior may change. =over =item add( $key, $data, [$expires_in | "now" | "never" | options] ) Do a L, but only if I<$key> is not L in the cache. =item replace( $key, $data, [$expires_in | "now" | "never" | options] ) Do a L, but only if I<$key> is L in the cache. =item append( $key, $new_data) Append I<$new_data> to whatever value is currently associated with I<$key>. Has no effect if I<$key> does not exist in the cache. Returns true if I<$key> was in the cache, false otherwise. This is intended for simple string values only. For efficiency's sake, CHI won't attempt to check for, or handle, the case where data is L or L; the new data will simply be appended, and an error will most probably occur when you try to retrieve the value. Does not modify expiration or other metadata. If I<$key> exists but is expired, it will remain expired. If you use a driver with the non-atomic (default) implementation, some appends may be lost due to race conditions. =back =head2 Namespace operations =over =item clear( ) Remove all entries from the namespace. =item get_keys( ) Returns a list of keys in the namespace. This may or may not include expired keys, depending on the driver. The keys may not look the same as they did when passed into L; they may have been serialized, utf8 encoded, and/or digested (see L). However, they may still be passed back into L, L, etc. to access the same underlying objects. i.e. the following code is guaranteed to produce all key/value pairs from the cache: map { ($_, $c->get($_)) } $c->get_keys() =item purge( ) Remove all entries that have expired from the namespace associated with this cache instance. Warning: May be very inefficient, depending on the number of keys and the driver. =item get_namespaces( ) Returns a list of namespaces associated with the cache. This may or may not include empty namespaces, depending on the driver. =back =head2 Multiple key/value operations The methods in this section process multiple keys and/or values at once. By default these are implemented with the obvious map operations, but some cache drivers (e.g. L) can override them with more efficient implementations. =over =item get_multi_arrayref( $keys ) Get the keys in list reference I<$keys>, and return a list reference of the same length with corresponding values or undefs. =item get_multi_hashref( $keys ) Like L, but returns a hash reference with each key in I<$keys> mapping to its corresponding value or undef. Will only work with scalar keys. =item set_multi( $key_values, $set_options ) Set the multiple keys and values provided in hash reference I<$key_values>. I<$set_options> is a scalar or hash reference, used as the third argument to set. Will only work with scalar keys. =item remove_multi( $keys ) Removes the keys in list reference I<$keys>. =item dump_as_hash( ) Returns a hash reference containing all the non-expired keys and values in the cache. =back =head2 Property accessors =over =item chi_root_class( ) Returns the name of the root class under which this object was created, e.g. C or C. See L. =item driver_class( ) Returns the full name of the driver class. e.g. CHI->new(driver=>'File')->driver_class => CHI::Driver::File CHI->new(driver=>'+CHI::Driver::File')->driver_class => CHI::Driver::File CHI->new(driver=>'+My::Driver::File')->driver_class => My::Driver::File You should use this rather than C. Due to some subclassing tricks CHI employs, the actual class of the object is neither guaranteed nor likely to be the driver class. =item short_driver_name( ) Returns the name of the driver class, minus the CHI::Driver:: prefix, if any. e.g. CHI->new(driver=>'File')->short_driver_name => File CHI->new(driver_class=>'CHI::Driver::File')->short_driver_name => File CHI->new(driver_class=>'My::Driver::File')->short_driver_name => My::Driver::File =item Standard read-write accessors expires_in expires_at expires_variance label on_get_error on_set_error =item Standard read-only accessors namespace serializer =back =head2 Deprecated methods The following methods are deprecated and will be removed in a later version: is_empty =head1 DURATION EXPRESSIONS Duration expressions, which appear in the L command and various other parts of the API, are parsed by L. A duration is either a plain number, which is treated like a number of seconds, or a number and a string representing time units where the string is one of: s second seconds sec secs m minute minutes min mins h hr hour hours d day days w week weeks M month months y year years e.g. the following are all valid duration expressions: 25 3s 5 seconds 1 minute and ten seconds 1 hour =head1 KEY AND VALUE TRANSFORMATIONS CHI strives to accept arbitrary keys and values for caching regardless of the limitations of the underlying driver. =head2 Key transformations =over =item * Keys that are references are serialized - see L. =item * Keys with wide (>255) characters are utf8 encoded. =item * Keys exceeding the maximum length for the underlying driver are digested - see L and L. =item * For some drivers (e.g. L), keys containing special characters or whitespace are escaped with URL-like escaping. =back Note: All transformations above with the exception of escaping are I, meaning that CHI does not attempt to undo them when returned from L; and I, meaning that applying them a second time has no effect. So when you call L, the key you get may not be exactly what you passed in, but you'll be able to pass that key in to get the corresponding object. =head2 Value transformations =over =item * Values which are references are automatically serialized before storing, and deserialized after retrieving - see L. =item * Values with their utf8 flag on are utf8 encoded before storing, and utf8 decoded after retrieving. =back =head1 SUBCACHES It is possible to a cache to have one or more I. There are currently two types of subcaches: I and I. =head2 L1 cache An L1 (or "level one") cache sits in front of the primary cache, usually to provide faster access for commonly accessed cache entries. For example, this places an in-process Memory cache in front of a Memcached cache: my $cache = CHI->new( driver => 'Memcached', servers => [ "10.0.0.15:11211", "10.0.0.15:11212" ], l1_cache => { driver => 'Memory', global => 1, max_size => 1024*1024 } ); On a C, the L1 cache is checked first - if a valid value exists, it is returned. Otherwise, the primary cache is checked - if a valid value exists, it is returned, and the value is placed in the L1 cache with the same expiration time. In this way, items fetched most frequently from the primary cache will tend to be in the L1 cache. C operations are distributed to both the primary and L1 cache. You can access the L1 cache with the C method. For example, this clears the L1 cache but leaves the primary cache intact: $cache->l1_cache->clear(); =head2 Mirror cache A mirror cache is a write-only cache that, over time, mirrors the content of the primary cache. C operations are distributed to both the primary and mirror cache, but C operations go only to the primary cache. Mirror caches are useful when you want to migrate from one cache to another. You can populate a mirror cache and switch over to it once it is sufficiently populated. For example, here we migrate from an old to a new cache directory: my $cache = CHI->new( driver => 'File', root_dir => '/old/cache/root', mirror_cache => { driver => 'File', root_dir => '/new/cache/root' }, ); We leave this running for a few hours (or as needed), then replace it with my $cache = CHI->new( driver => 'File', root_dir => '/new/cache/root' ); You can access the mirror cache with the C method. For example, to see how many keys have made it over to the mirror cache: my @keys = $cache->mirror_cache->get_keys(); =head2 Creating subcaches As illustrated above, you create subcaches by passing the C and/or C option to the CHI constructor. These options, in turn, should contain a hash of options to create the subcache with. The cache containing the subcache is called the I. The following options are automatically inherited by the subcache from the parent cache, and may not be overridden: expires_at expires_in expires_variance serializer (Reason: for efficiency, we want to create a single L and store it in both caches. The cache object contains expiration information and is dependent on the serializer. At some point we could conceivably add code that will use a single object or separate objects as necessary, and thus allow the above to be overridden.) The following options are automatically inherited by the subcache from the parent cache, but may be overridden: namespace on_get_error on_set_error All other options are initialized in the subcache as normal, irrespective of their values in the parent. It is not currently possible to pass an existing cache in as a subcache. =head2 Common subcache behaviors These behaviors hold regardless of the type of subcache. The following methods are distributed to both the primary cache and subcache: clear expire purge remove The following methods return information solely from the primary cache. However, you are free to call them explicitly on the subcache. (Trying to merge in subcache information automatically would require too much guessing about the caller's intent.) get_keys get_namespaces get_object get_expires_at exists_and_is_expired is_valid dump_as_hash =head2 Multiple subcaches It is valid for a cache to have one of each kind of subcache, e.g. an L1 cache and a mirror cache. A cache cannot have more than one of each kind of subcache, but a subcache can have its own subcaches, and so on. e.g. my $cache = CHI->new( driver => 'Memcached', servers => [ "10.0.0.15:11211", "10.0.0.15:11212" ], l1_cache => { driver => 'File', root_dir => '/path/to/root', l1_cache => { driver => 'RawMemory', global => 1 } } ); =head2 Methods for parent caches =over =item has_subcaches( ) Returns a boolean indicating whether this cache has subcaches. =item l1_cache( ) Returns the L1 cache for this cache, if any. Can only be called if I is true. =item mirror_cache( ) Returns the mirror cache for this cache, if any. Can only be called if I is true. =item subcaches( ) Returns the subcaches for this cache, in arbitrary order. Can only be called if I is true. =back =head2 Methods for subcaches =over =item is_subcache( ) Returns a boolean indicating whether this is a subcache. =item subcache_type( ) Returns the type of subcache as a string, e.g. 'l1_cache' or 'mirror_cache'. Can only be called if I is true. =item parent_cache( ) Returns the parent cache (weakened to prevent circular reference). Can only be called if I is true. =back =head2 Developing new kinds of subcaches At this time, subcache behavior is hardcoded into CHI::Driver, so there is no easy way to modify the behavior of existing subcache types or create new ones. We'd like to make this more flexible eventually. =head1 SIZE AWARENESS If L or L are passed to the constructor, the cache will be I - that is, it will keep track of its own size (in bytes) as items are added and removed. You can get a cache's size with L. Size aware caches generally keep track of their size in a separate meta-key, and have to do an extra store whenever the size changes (e.g. on each set and remove). =head2 Maximum size and discard policies If a cache's size rises above its L, items are discarded until the cache size is sufficiently below the max size. (See L for how to fine-tune this.) The order in which items are discarded is controlled with L. The default discard policy is 'arbitrary', which discards items in an arbitrary order. The available policies and default policy can differ with each driver, e.g. the L driver provides and defaults to an 'LRU' policy. =head2 Appropriate drivers Size awareness was chiefly designed for, and works well with, the L driver: one often needs to enforce a maximum size on a memory cache, and the overhead of tracking size in memory is negligible. However, the capability may be useful with other drivers. Some drivers - for example, L and L - inherently keep track of their size and enforce a maximum size, and it makes no sense to turn on CHI's size awareness for these. Also, for drivers that cannot atomically read and update a value - for example, L - there is a race condition in the updating of size that can cause the size to grow inaccurate over time. =head1 SUBCLASSING AND CONFIGURING CHI You can subclass CHI for your own application and configure it in a variety of ways, e.g. predefining storage types and defaults for new cache objects. Your configuration will be independent of the main CHI class and other CHI subclasses. Start with a trivial subclass: package My::CHI; use base qw(CHI); 1; Then, just use your subclass in place of CHI: my $cache = My::CHI->new( ... ); print $cache->chi_root_class; ==> 'My::CHI' This obviously doesn't change any behavior by itself. Here's an example with actual config: package My::CHI; use base qw(CHI); __PACKAGE__->config({ storage => { local_file => { driver => 'File', root_dir => '/my/root' }, memcached => { driver => 'Memcached::libmemcached', servers => [ '10.0.0.15:11211', '10.0.0.15:11212' ] }, }, namespace => { 'Foo' => { storage => 'local_file' }, 'Bar' => { storage => 'local_file', depth => 3 }, 'Baz' => { storage => 'memcached' }, } defaults => { storage => 'local_file' }, memoize_cache_objects => 1, }); 1; Each of these config keys is explained in the next section. =head2 Configuration keys =over =item storage A map of names to parameter hashrefs. This provides a way to encapsulate common sets of parameters that might be used in many caches. e.g. if you define storage => { local_file => { driver => 'File', root_dir => '/my/root' }, ... } then my $cache = My::CHI->new (namespace => 'Foo', storage => 'local_file'); is equivalent to my $cache = My::CHI->new (namespace => 'Foo', driver => 'File', root_dir => '/my/root'); =item namespace A map of namespace names to parameter hashrefs. When you create a cache object with the specified namespace, the hashref of parameters will be applied as defaults. e.g. if you define namespace => { 'Foo' => { driver => 'File', root_dir => '/my/root' }, 'Bar' => { storage => 'database' }, ... } then my $cache1 = My::CHI->new (namespace => 'Foo'); my $cache2 = My::CHI->new (namespace => 'Bar'); is equivalent to my $cache1 = My::CHI->new (namespace => 'Foo', driver => 'File', root_dir => '/my/root'); my $cache2 = My::CHI->new (namespace => 'Bar', storage => 'database'); =item defaults A hash of parameters that will be used as core defaults for all cache objects created under this root class. e.g. defaults => { on_get_error => 'die', expires_variance => 0.2, } These can be overridden by namespace defaults, storage settings, or C parameters. =item memoize_cache_objects True or false, indicates whether Cnew> should memoize and return the same cache object if given the same parameters. This can speed things up if you create cache objects frequently. Will currently only work for 0- or 1- key parameter hashes. e.g. My::CHI->config({ memoize_cache_objects => 1, }); then # $cache1 and $cache2 will be the same object, regardless of what # namespace and storage defaults are associated with 'Foo' # my $cache1 = My::CHI->new(namespace => 'Foo'); my $cache2 = My::CHI->new(namespace => 'Foo'); # $cache3 and $cache4 will be different objects # my $cache3 = My::CHI->new (namespace => 'Bar', driver => 'File', root_dir => '/my/root'); my $cache4 = My::CHI->new (namespace => 'Bar', driver => 'File', root_dir => '/my/root'); To clear the memoized cache objects, call My::CHI->clear_memoized_cache_objects; =back =head2 How defaults are combined Defaults are applied in the following order, from highest to lowest precedence: =over =item * Parameters passed in C =item * Namespace defaults, if any =item * Storage settings, if any =item * Core defaults defined under 'defaults' =back =head2 Inheritance of config A subclass will automatically inherit the configuration of its parent if it does not call C itself (ala L). =head2 Reading config from a file use YAML::XS qw(LoadFile); __PACKAGE__->config(LoadFile("/path/to/cache.yml")); =for readme continue =head1 AVAILABILITY OF DRIVERS The following drivers are currently available as part of this distribution: =over =item * L - In-process memory based cache =item * L - In-process memory based cache that stores references directly instead of serializing/deep-copying =item * L - File-based cache using one file per entry in a multi-level directory structure =item * L - Shared memory interprocess cache via mmap'ed files =item * L - Dummy cache in which nothing is stored =item * L - CHI wrapper for Cache::Cache =back The following drivers are currently available as separate CPAN distributions: =over =item * L - Distributed memory-based cache (works with L, L, and L) =item * L - Cache in any DBI-supported database =item * L - Cache in BerkeleyDB files =item * L - Cache in L =item * L - Cache in shared memory =back This list is likely incomplete. A complete set of drivers can be found on CPAN by searching for "CHI::Driver". =for readme stop =head1 PERFORMANCE COMPARISON OF DRIVERS See L for a comparison of read/write times of both CHI and non-CHI cache implementations. C in the C distribution contains a script to run these types of benchmarks on your own system. =head1 DEVELOPING NEW DRIVERS See L for information on developing new drivers. =head1 LOGGING C uses L for logging events. For example, a debug log message is sent with category C for every cache get and set. See L documentation for how to control where logs get sent, if anywhere. =head1 STATS CHI can record statistics, such as number of hits, misses and sets, on a per-namespace basis and log the results to your L logger. You can then use utilities included with this distribution to read stats back from the logs and report a summary. See L for details. =for readme continue =head1 RELATION TO OTHER MODULES =head2 Cache::Cache CHI is intended as an evolution of DeWitt Clinton's L package. It starts with the same basic API (which has proven durable over time) but addresses some implementation shortcomings that cannot be fixed in Cache::Cache due to backward compatibility concerns. In particular: =over =item Performance Some of Cache::Cache's subclasses (e.g. L) have been justifiably criticized as inefficient. CHI has been designed from the ground up with performance in mind, both in terms of general overhead and in the built-in driver classes. Method calls are kept to a minimum, data is only serialized when necessary, and metadata such as expiration time is stored in packed binary format alongside the data. =item Ease of subclassing New Cache::Cache subclasses can be tedious to create, due to a lack of code refactoring, the use of non-OO package subroutines, and the separation of "cache" and "backend" classes. With CHI, the goal is to make the creation of new drivers as easy as possible, roughly the same as writing a TIE interface to your data store. Concerns like serialization and expiration options are handled by the driver base class so that individual drivers don't have to worry about them. =item Increased compatibility with cache implementations Probably because of the reasons above, Cache::Cache subclasses were never created for some of the most popular caches available on CPAN, e.g. L and L. CHI's goal is to be able to support these and other caches with a minimum performance overhead and minimum of glue code required. =back =head2 Cache The L distribution is another redesign and implementation of Cache, created by Chris Leishman in 2003. Like CHI, it improves performance and reduces the barrier to implementing new cache drivers. It breaks with the Cache::Cache interface in a few ways that I considered non-negotiable - for example, get/set do not serialize data, and namespaces are an optional feature that drivers may decide not to implement. =head2 Cache::Memcached, Cache::FastMmap, etc. CPAN sports a variety of full-featured standalone cache modules representing particular backends. CHI does not reinvent these but simply wraps them with an appropriate driver. For example, CHI::Driver::Memcached and CHI::Driver::FastMmap are thin layers around Cache::Memcached and Cache::FastMmap. Of course, because these modules already work on their own, there will be some overlap. Cache::FastMmap, for example, already has code to serialize data and handle expiration times. Here's how CHI resolves these overlaps. =over =item Serialization CHI handles its own serialization, passing a flat binary string to the underlying cache backend. The notable exception is L which does no serialization. =item Expiration CHI packs expiration times (as well as other metadata) inside the binary string passed to the underlying cache backend. The backend is unaware of these values; from its point of view the item has no expiration time. Among other things, this means that you can use CHI to examine expired items (e.g. with $cache-Eget_object) even if this is not supported natively by the backend. At some point CHI will provide the option of explicitly notifying the backend of the expiration time as well. This might allow the backend to do better storage management, etc., but would prevent CHI from examining expired items. =back Naturally, using CHI's FastMmap or Memcached driver will never be as time or storage efficient as simply using Cache::FastMmap or Cache::Memcached. In terms of performance, we've attempted to make the overhead as small as possible, on the order of 5% per get or set (benchmarks coming soon). In terms of storage size, CHI adds about 16 bytes of metadata overhead to each item. How much this matters obviously depends on the typical size of items in your cache. =head1 SUPPORT AND DOCUMENTATION Questions and feedback are welcome, and should be directed to the perl-cache mailing list: http://groups.google.com/group/perl-cache-discuss Bugs and feature requests will be tracked at RT: http://rt.cpan.org/NoAuth/Bugs.html?Dist=CHI bug-chi@rt.cpan.org The latest source code can be browsed and fetched at: http://github.com/jonswar/perl-chi/tree/master git clone git://github.com/jonswar/perl-chi.git =head1 ACKNOWLEDGMENTS Thanks to Dewitt Clinton for the original Cache::Cache, to Rob Mueller for the Perl cache benchmarks, and to Perrin Harkins for the discussions that got this going. CHI was originally designed and developed for the Digital Media group of the Hearst Corporation, a diversified media company based in New York City. Many thanks to Hearst management for agreeing to this open source release. =head1 SEE ALSO L =head1 AUTHOR Jonathan Swartz =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2012 by Jonathan Swartz. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut CHI-0.60/LICENSE0000644€ˆž«€q{Ì0000004366612535132431012555 0ustar jonswartThis software is copyright (c) 2012 by Jonathan Swartz. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. Terms of the Perl programming language system itself a) the GNU General Public License as published by the Free Software Foundation; either version 1, or (at your option) any later version, or b) the "Artistic License" --- The GNU General Public License, Version 1, February 1989 --- This software is Copyright (c) 2012 by Jonathan Swartz. This is free software, licensed under: The GNU General Public License, Version 1, February 1989 GNU GENERAL PUBLIC LICENSE Version 1, February 1989 Copyright (C) 1989 Free Software Foundation, Inc. 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 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., 51 Franklin Street, Fifth Floor, Boston MA 02110-1301 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! --- The Artistic License 1.0 --- This software is Copyright (c) 2012 by Jonathan Swartz. This is free software, licensed under: The Artistic License 1.0 The Artistic License Preamble The intent of this document is to state the conditions under which a Package may be copied, such that the Copyright Holder maintains some semblance of artistic control over the development of the package, while giving the users of the package the right to use and distribute the Package in a more-or-less customary fashion, plus the right to make reasonable modifications. Definitions: - "Package" refers to the collection of files distributed by the Copyright Holder, and derivatives of that collection of files created through textual modification. - "Standard Version" refers to such a Package if it has not been modified, or has been modified in accordance with the wishes of the Copyright Holder. - "Copyright Holder" is whoever is named in the copyright or copyrights for the package. - "You" is you, if you're thinking about copying or distributing this Package. - "Reasonable copying fee" is whatever you can justify on the basis of media cost, duplication charges, time of people involved, and so on. (You will not be required to justify it to the Copyright Holder, but only to the computing community at large as a market that must bear the fee.) - "Freely Available" means that no fee is charged for the item itself, though there may be fees involved in handling the item. It also means that recipients of the item may redistribute it under the same conditions they received it. 1. You may make and give away verbatim copies of the source form of the Standard Version of this Package without restriction, provided that you duplicate all of the original copyright notices and associated disclaimers. 2. You may apply bug fixes, portability fixes and other modifications derived from the Public Domain or from the Copyright Holder. A Package modified in such a way shall still be considered the Standard Version. 3. You may otherwise modify your copy of this Package in any way, provided that you insert a prominent notice in each changed file stating how and when you changed that file, and provided that you do at least ONE of the following: a) place your modifications in the Public Domain or otherwise make them Freely Available, such as by posting said modifications to Usenet or an equivalent medium, or placing the modifications on a major archive site such as ftp.uu.net, or by allowing the Copyright Holder to include your modifications in the Standard Version of the Package. b) use the modified Package only within your corporation or organization. c) rename any non-standard executables so the names do not conflict with standard executables, which must also be provided, and provide a separate manual page for each non-standard executable that clearly documents how it differs from the Standard Version. d) make other distribution arrangements with the Copyright Holder. 4. You may distribute the programs of this Package in object code or executable form, provided that you do at least ONE of the following: a) distribute a Standard Version of the executables and library files, together with instructions (in the manual page or equivalent) on where to get the Standard Version. b) accompany the distribution with the machine-readable source of the Package with your modifications. c) accompany any non-standard executables with their corresponding Standard Version executables, giving the non-standard executables non-standard names, and clearly documenting the differences in manual pages (or equivalent), together with instructions on where to get the Standard Version. d) make other distribution arrangements with the Copyright Holder. 5. You may charge a reasonable copying fee for any distribution of this Package. You may charge any fee you choose for support of this Package. You may not charge a fee for this Package itself. However, you may distribute this Package in aggregate with other (possibly commercial) programs as part of a larger (possibly commercial) software distribution provided that you do not advertise this Package as a product of your own. 6. The scripts and library files supplied as input to or produced as output from the programs of this Package do not automatically fall under the copyright of this Package, but belong to whomever generated them, and may be sold commercially, and may be aggregated with this Package. 7. C or perl subroutines supplied by you and linked into this Package shall not be considered part of this Package. 8. The name of the Copyright Holder may not be used to endorse or promote products derived from this software without specific prior written permission. 9. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. The End CHI-0.60/Makefile.PL0000644€ˆž«€q{Ì0000000463512535132431013513 0ustar jonswart # This file was automatically generated by Dist::Zilla::Plugin::MakeMaker v5.020. use strict; use warnings; use ExtUtils::MakeMaker ; my %WriteMakefileArgs = ( "ABSTRACT" => "Unified cache handling interface", "AUTHOR" => "Jonathan Swartz ", "CONFIGURE_REQUIRES" => { "ExtUtils::MakeMaker" => 0 }, "DISTNAME" => "CHI", "EXE_FILES" => [], "LICENSE" => "perl", "NAME" => "CHI", "PREREQ_PM" => { "Carp::Assert" => "0.20", "Class::Load" => 0, "Data::UUID" => 0, "Digest::JHash" => 0, "Digest::MD5" => 0, "File::Spec" => "0.80", "Hash::MoreUtils" => 0, "JSON::MaybeXS" => "1.003003", "List::MoreUtils" => "0.13", "Log::Any" => "0.08", "Moo" => "1.003", "MooX::Types::MooseLike" => "0.23", "MooX::Types::MooseLike::Base" => 0, "MooX::Types::MooseLike::Numeric" => 0, "Storable" => 0, "String::RewritePrefix" => 0, "Task::Weaken" => 0, "Time::Duration" => "1.06", "Time::Duration::Parse" => "0.03", "Time::HiRes" => "1.30", "Try::Tiny" => "0.05" }, "TEST_REQUIRES" => { "Date::Parse" => 0, "Test::Builder" => 0, "Test::Class" => 0, "Test::Deep" => 0, "Test::Exception" => 0, "Test::More" => 0, "Test::Warn" => 0 }, "VERSION" => "0.60", "test" => { "TESTS" => "t/*.t" } ); my %FallbackPrereqs = ( "Carp::Assert" => "0.20", "Class::Load" => 0, "Data::UUID" => 0, "Date::Parse" => 0, "Digest::JHash" => 0, "Digest::MD5" => 0, "File::Spec" => "0.80", "Hash::MoreUtils" => 0, "JSON::MaybeXS" => "1.003003", "List::MoreUtils" => "0.13", "Log::Any" => "0.08", "Moo" => "1.003", "MooX::Types::MooseLike" => "0.23", "MooX::Types::MooseLike::Base" => 0, "MooX::Types::MooseLike::Numeric" => 0, "Storable" => 0, "String::RewritePrefix" => 0, "Task::Weaken" => 0, "Test::Builder" => 0, "Test::Class" => 0, "Test::Deep" => 0, "Test::Exception" => 0, "Test::More" => 0, "Test::Warn" => 0, "Time::Duration" => "1.06", "Time::Duration::Parse" => "0.03", "Time::HiRes" => "1.30", "Try::Tiny" => "0.05" ); unless ( eval { ExtUtils::MakeMaker->VERSION(6.63_03) } ) { delete $WriteMakefileArgs{TEST_REQUIRES}; delete $WriteMakefileArgs{BUILD_REQUIRES}; $WriteMakefileArgs{PREREQ_PM} = \%FallbackPrereqs; } delete $WriteMakefileArgs{CONFIGURE_REQUIRES} unless eval { ExtUtils::MakeMaker->VERSION(6.52) }; WriteMakefile(%WriteMakefileArgs); CHI-0.60/MANIFEST0000644€ˆž«€q{Ì0000000462312535132431012667 0ustar jonswart# This file was automatically generated by Dist::Zilla::Plugin::Manifest v5.020. Changes INSTALL LICENSE MANIFEST META.json META.yml Makefile.PL etc/bench/bench.pl lib/CHI.pm lib/CHI/Benchmarks.pod lib/CHI/CacheObject.pm lib/CHI/Constants.pm lib/CHI/Driver.pm lib/CHI/Driver/Base/CacheContainer.pm lib/CHI/Driver/CacheCache.pm lib/CHI/Driver/Development.pod lib/CHI/Driver/FastMmap.pm lib/CHI/Driver/File.pm lib/CHI/Driver/Memory.pm lib/CHI/Driver/Metacache.pm lib/CHI/Driver/Null.pm lib/CHI/Driver/RawMemory.pm lib/CHI/Driver/Role/HasSubcaches.pm lib/CHI/Driver/Role/IsSizeAware.pm lib/CHI/Driver/Role/IsSubcache.pm lib/CHI/Driver/Role/Universal.pm lib/CHI/Serializer/JSON.pm lib/CHI/Serializer/Storable.pm lib/CHI/Stats.pm lib/CHI/Test.pm lib/CHI/Test/Class.pm lib/CHI/Test/Driver/NonMoose.pm lib/CHI/Test/Driver/Readonly.pm lib/CHI/Test/Driver/Role/CheckKeyValidity.pm lib/CHI/Test/Driver/Writeonly.pm lib/CHI/Test/Util.pm lib/CHI/Types.pm lib/CHI/Util.pm lib/CHI/t/Bugs.pm lib/CHI/t/Config.pm lib/CHI/t/Constants.pm lib/CHI/t/Driver.pm lib/CHI/t/Driver/CacheCache.pm lib/CHI/t/Driver/FastMmap.pm lib/CHI/t/Driver/File.pm lib/CHI/t/Driver/File/DepthZero.pm lib/CHI/t/Driver/Memory.pm lib/CHI/t/Driver/NonMoose.pm lib/CHI/t/Driver/RawMemory.pm lib/CHI/t/Driver/Subcache.pm lib/CHI/t/Driver/Subcache/l1_cache.pm lib/CHI/t/Driver/Subcache/mirror_cache.pm lib/CHI/t/GetError.pm lib/CHI/t/Initialize.pm lib/CHI/t/Null.pm lib/CHI/t/RequiredModules.pm lib/CHI/t/Sanity.pm lib/CHI/t/SetError.pm lib/CHI/t/Subcache.pm lib/CHI/t/Subclass.pm lib/CHI/t/Util.pm perltidy.LOG t/00-load.t t/Bugs.t t/Config.t t/Constants.t t/Driver-Memory.t t/Driver-RawMemory.t t/GetError.t t/Initialize.t t/Sanity.t t/SetError.t t/Subcache.t t/Subclass.t t/Util.t t/author-03-pod.t t/author-RequiredModules.t t/author-file-driver.t t/author-no-data-serializer.t t/permcache/Default/0/4/1.dat t/permcache/Default/0/4/empty.dat t/permcache/Default/1/a/+20+21+22+23+24+25+26+27+28+29+2a+2b+2c-+2e+2f09+3a+3b+3c=+3e+3f+40AZ+5b+5c+5d+5e_+60az+7b+7c+7d~+f0.dat t/permcache/Default/2/3/+0a.dat t/permcache/Default/6/3/0.dat t/permcache/Default/7/7/+20.dat t/permcache/Default/8/1/a.dat t/permcache/Default/b/6/medium.dat t/release-dependent.t t/set_permcache.pl t/smoke-Driver-CacheCache.t t/smoke-Driver-FastMmap.t t/smoke-Driver-File-DepthZero.t t/smoke-Driver-File.t t/smoke-Driver-NonMoose.t t/smoke-Driver-Subcache-l1_cache.t t/smoke-Driver-Subcache-mirror_cache.t t/smoke-Null.t CHI-0.60/META.json0000644€ˆž«€q{Ì0000000453212535132431013156 0ustar jonswart{ "abstract" : "Unified cache handling interface", "author" : [ "Jonathan Swartz " ], "dynamic_config" : 0, "generated_by" : "Dist::Zilla version 5.020, CPAN::Meta::Converter version 2.120921", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "CHI", "no_index" : { "directory" : [ "lib/CHI/Serializer", "lib/CHI/Test", "lib/CHI/t" ], "file" : [ "lib/CHI/Constants.pm", "lib/CHI/Driver/Role/Universal.pm", "lib/CHI/Test.pm", "lib/CHI/Types.pm", "lib/CHI/Util.pm" ] }, "prereqs" : { "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "runtime" : { "requires" : { "Carp::Assert" : "0.20", "Class::Load" : "0", "Data::UUID" : "0", "Digest::JHash" : "0", "Digest::MD5" : "0", "File::Spec" : "0.80", "Hash::MoreUtils" : "0", "JSON::MaybeXS" : "1.003003", "List::MoreUtils" : "0.13", "Log::Any" : "0.08", "Moo" : "1.003", "MooX::Types::MooseLike" : "0.23", "MooX::Types::MooseLike::Base" : "0", "MooX::Types::MooseLike::Numeric" : "0", "Storable" : "0", "String::RewritePrefix" : "0", "Task::Weaken" : "0", "Time::Duration" : "1.06", "Time::Duration::Parse" : "0.03", "Time::HiRes" : "1.30", "Try::Tiny" : "0.05" } }, "test" : { "requires" : { "Date::Parse" : "0", "Test::Builder" : "0", "Test::Class" : "0", "Test::Deep" : "0", "Test::Exception" : "0", "Test::More" : "0", "Test::Warn" : "0" } } }, "release_status" : "stable", "resources" : { "bugtracker" : { "mailto" : "bug-chi@rt.cpan.org", "web" : "http://rt.cpan.org/NoAuth/Bugs.html?Dist=CHI" }, "repository" : { "type" : "git", "url" : "git://github.com/jonswar/perl-chi.git", "web" : "https://github.com/jonswar/perl-chi" } }, "version" : "0.60" } CHI-0.60/META.yml0000644€ˆž«€q{Ì0000000255412535132431013010 0ustar jonswart--- abstract: 'Unified cache handling interface' author: - 'Jonathan Swartz ' build_requires: Date::Parse: '0' Test::Builder: '0' Test::Class: '0' Test::Deep: '0' Test::Exception: '0' Test::More: '0' Test::Warn: '0' configure_requires: ExtUtils::MakeMaker: '0' dynamic_config: 0 generated_by: 'Dist::Zilla version 5.020, CPAN::Meta::Converter version 2.120921' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: CHI no_index: directory: - lib/CHI/Serializer - lib/CHI/Test - lib/CHI/t file: - lib/CHI/Constants.pm - lib/CHI/Driver/Role/Universal.pm - lib/CHI/Test.pm - lib/CHI/Types.pm - lib/CHI/Util.pm requires: Carp::Assert: '0.20' Class::Load: '0' Data::UUID: '0' Digest::JHash: '0' Digest::MD5: '0' File::Spec: '0.80' Hash::MoreUtils: '0' JSON::MaybeXS: '1.003003' List::MoreUtils: '0.13' Log::Any: '0.08' Moo: '1.003' MooX::Types::MooseLike: '0.23' MooX::Types::MooseLike::Base: '0' MooX::Types::MooseLike::Numeric: '0' Storable: '0' String::RewritePrefix: '0' Task::Weaken: '0' Time::Duration: '1.06' Time::Duration::Parse: '0.03' Time::HiRes: '1.30' Try::Tiny: '0.05' resources: bugtracker: http://rt.cpan.org/NoAuth/Bugs.html?Dist=CHI repository: git://github.com/jonswar/perl-chi.git version: '0.60' CHI-0.60/perltidy.LOG0000644€ˆž«€q{Ì0000000222612535132431013732 0ustar jonswartperltidy version 20121207 log file on a darwin system, OLD_PERL_VERSION=5.012004 Configuration and command line parameters for this run: -noll -blbp=0 To find error messages search for 'WARNING' with your editor Indentation will be with 4 spaces Line 1 implies starting-indentation-level = 0 The nesting depths in the table below are at the start of the lines. The indicated output line numbers are not always exact. ci = levels of continuation indentation; bk = 1 if in BLOCK, 0 if not. in:out indent c b nesting code + messages; (messages begin with >>>) lines levels i k (code begins with one '.' per indent level) ------ ----- - - -------- ------------------------------------------- L1:1 i0:0 0 1 package CHI::t::Util; L12:12 i0:0 0 1 sub test_unique_id : Tests { L17:17 i0:0 0 1 sub test_random_string : Tests { L31:31 i0:0 0 1 sub test_non_common_constructor_par .... L38:38 i0:0 0 1 sub test_parse_memory_size : Tests .... L51:51 i0:0 0 1 >>>Last line No indentation disagreement seen No lines exceeded 80 characters Maximum output line length was 80 at line 34 CHI-0.60/README0000664€ˆž«€q{Ì0000002163612535132431012423 0ustar jonswartNAME CHI - Unified cache handling interface VERSION version 0.60 SYNOPSIS use CHI; # Choose a standard driver # my $cache = CHI->new( driver => 'Memory', global => 1 ); my $cache = CHI->new( driver => 'RawMemory', global => 1 ); my $cache = CHI->new( driver => 'File', root_dir => '/path/to/root' ); my $cache = CHI->new( driver => 'FastMmap', root_dir => '/path/to/root', cache_size => '1k' ); my $cache = CHI->new( driver => 'Memcached::libmemcached', servers => [ "10.0.0.15:11211", "10.0.0.15:11212" ], l1_cache => { driver => 'FastMmap', root_dir => '/path/to/root' } ); my $cache = CHI->new( driver => 'DBI', dbh => $dbh ); my $cache = CHI->new( driver => 'BerkeleyDB', root_dir => '/path/to/root' ); # Create your own driver # my $cache = CHI->new( driver => '+My::Special::Driver', ... ); # Cache operations # my $customer = $cache->get($name); if ( !defined $customer ) { $customer = get_customer_from_db($name); $cache->set( $name, $customer, "10 minutes" ); } my $customer2 = $cache->compute($name2, "10 minutes", sub { get_customer_from_db($name2) }); $cache->remove($name); DESCRIPTION CHI provides a unified caching API, designed to assist a developer in persisting data for a specified period of time. The CHI interface is implemented by driver classes that support fetching, storing and clearing of data. Driver classes exist or will exist for the gamut of storage backends available to Perl, such as memory, plain files, memory mapped files, memcached, and DBI. CHI is intended as an evolution of DeWitt Clinton's Cache::Cache package, adhering to the basic Cache API but adding new features and addressing limitations in the Cache::Cache implementation. FEATURES * Easy to create new drivers * Uniform support for namespaces * Automatic serialization of keys and values * Multilevel caches * Probabilistic expiration and busy locks, to reduce cache miss stampedes * Optional logging and statistics collection of cache activity AVAILABILITY OF DRIVERS The following drivers are currently available as part of this distribution: * CHI::Driver::Memory - In-process memory based cache * CHI::Driver::RawMemory - In-process memory based cache that stores references directly instead of serializing/deep-copying * CHI::Driver::File - File-based cache using one file per entry in a multi-level directory structure * CHI::Driver::FastMmap - Shared memory interprocess cache via mmap'ed files * CHI::Driver::Null - Dummy cache in which nothing is stored * CHI::Driver::CacheCache - CHI wrapper for Cache::Cache The following drivers are currently available as separate CPAN distributions: * CHI::Driver::Memcached - Distributed memory-based cache (works with Cache::Memcached, Cache::Memcached::Fast, and Cache::Memcached::libmemcached) * CHI::Driver::DBI - Cache in any DBI-supported database * CHI::Driver::BerkeleyDB - Cache in BerkeleyDB files * CHI::Driver::Redis - Cache in Redis * CHI::Driver::SharedMem - Cache in shared memory This list is likely incomplete. A complete set of drivers can be found on CPAN by searching for "CHI::Driver". RELATION TO OTHER MODULES Cache::Cache CHI is intended as an evolution of DeWitt Clinton's Cache::Cache package. It starts with the same basic API (which has proven durable over time) but addresses some implementation shortcomings that cannot be fixed in Cache::Cache due to backward compatibility concerns. In particular: Performance Some of Cache::Cache's subclasses (e.g. Cache::FileCache) have been justifiably criticized as inefficient. CHI has been designed from the ground up with performance in mind, both in terms of general overhead and in the built-in driver classes. Method calls are kept to a minimum, data is only serialized when necessary, and metadata such as expiration time is stored in packed binary format alongside the data. Ease of subclassing New Cache::Cache subclasses can be tedious to create, due to a lack of code refactoring, the use of non-OO package subroutines, and the separation of "cache" and "backend" classes. With CHI, the goal is to make the creation of new drivers as easy as possible, roughly the same as writing a TIE interface to your data store. Concerns like serialization and expiration options are handled by the driver base class so that individual drivers don't have to worry about them. Increased compatibility with cache implementations Probably because of the reasons above, Cache::Cache subclasses were never created for some of the most popular caches available on CPAN, e.g. Cache::FastMmap and Cache::Memcached. CHI's goal is to be able to support these and other caches with a minimum performance overhead and minimum of glue code required. Cache The Cache distribution is another redesign and implementation of Cache, created by Chris Leishman in 2003. Like CHI, it improves performance and reduces the barrier to implementing new cache drivers. It breaks with the Cache::Cache interface in a few ways that I considered non-negotiable - for example, get/set do not serialize data, and namespaces are an optional feature that drivers may decide not to implement. Cache::Memcached, Cache::FastMmap, etc. CPAN sports a variety of full-featured standalone cache modules representing particular backends. CHI does not reinvent these but simply wraps them with an appropriate driver. For example, CHI::Driver::Memcached and CHI::Driver::FastMmap are thin layers around Cache::Memcached and Cache::FastMmap. Of course, because these modules already work on their own, there will be some overlap. Cache::FastMmap, for example, already has code to serialize data and handle expiration times. Here's how CHI resolves these overlaps. Serialization CHI handles its own serialization, passing a flat binary string to the underlying cache backend. The notable exception is CHI::Driver::RawMemory which does no serialization. Expiration CHI packs expiration times (as well as other metadata) inside the binary string passed to the underlying cache backend. The backend is unaware of these values; from its point of view the item has no expiration time. Among other things, this means that you can use CHI to examine expired items (e.g. with $cache->get_object) even if this is not supported natively by the backend. At some point CHI will provide the option of explicitly notifying the backend of the expiration time as well. This might allow the backend to do better storage management, etc., but would prevent CHI from examining expired items. Naturally, using CHI's FastMmap or Memcached driver will never be as time or storage efficient as simply using Cache::FastMmap or Cache::Memcached. In terms of performance, we've attempted to make the overhead as small as possible, on the order of 5% per get or set (benchmarks coming soon). In terms of storage size, CHI adds about 16 bytes of metadata overhead to each item. How much this matters obviously depends on the typical size of items in your cache. SUPPORT AND DOCUMENTATION Questions and feedback are welcome, and should be directed to the perl-cache mailing list: http://groups.google.com/group/perl-cache-discuss Bugs and feature requests will be tracked at RT: http://rt.cpan.org/NoAuth/Bugs.html?Dist=CHI bug-chi@rt.cpan.org The latest source code can be browsed and fetched at: http://github.com/jonswar/perl-chi/tree/master git clone git://github.com/jonswar/perl-chi.git ACKNOWLEDGMENTS Thanks to Dewitt Clinton for the original Cache::Cache, to Rob Mueller for the Perl cache benchmarks, and to Perrin Harkins for the discussions that got this going. CHI was originally designed and developed for the Digital Media group of the Hearst Corporation, a diversified media company based in New York City. Many thanks to Hearst management for agreeing to this open source release. SEE ALSO Cache::Cache AUTHOR Jonathan Swartz COPYRIGHT AND LICENSE This software is copyright (c) 2012 by Jonathan Swartz. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. CHI-0.60/t/0000775€ˆž«€q{Ì0000000000012535132431011776 5ustar jonswartCHI-0.60/t/00-load.t0000644€ˆž«€q{Ì0000000017412535132431013317 0ustar jonswart#!/usr/bin/perl use Test::More tests => 1; BEGIN { use_ok('CHI'); } diag("Testing CHI $CHI::VERSION, Perl $], $^X"); CHI-0.60/t/author-03-pod.t0000644€ˆž«€q{Ì0000000036712535132431014471 0ustar jonswart#!/usr/bin/perl BEGIN { unless ($ENV{AUTHOR_TESTING}) { require Test::More; Test::More::plan(skip_all => 'these tests are for testing by the author'); } } use strict; use warnings; use Test::More; use Test::Pod; all_pod_files_ok(); CHI-0.60/t/author-file-driver.t0000644€ˆž«€q{Ì0000000400412535132431015667 0ustar jonswart#!/usr/bin/perl BEGIN { unless ($ENV{AUTHOR_TESTING}) { require Test::More; Test::More::plan(skip_all => 'these tests are for testing by the author'); } } # use strict; use warnings; use File::Basename; use File::Temp qw(tempdir); use Test::More; use Test::Exception; use CHI; my $root_dir = tempdir( "file-digest-XXXX", TMPDIR => 1, CLEANUP => 1 ); my $cache; my ( $keys, $values ) = set_standard_keys_and_values(); my @keynames = sort keys(%$keys); plan tests => ( scalar(@keynames) * 2 + 1 ); # Test key_digest (old name for key_digester) and file_extension # $cache = CHI->new( driver => 'File', root_dir => $root_dir, key_digest => 'SHA-1', file_extension => '.sha' ); my $key = scalar( 'ab' x 256 ); my $file = basename( $cache->path_to_key( $cache->transform_key($key) ) ); is( $file, 'db62ffe116024a7a4e1bd949c0e30dbae9b5db77.sha', 'SHA-1 digest' ); # Test that we can retrieve from a permanent cache in this directory. If # key escaping or metadata format changes between versions, this will break # - we at least want to know about it to warn users. # my $perm_cache = CHI->new( driver => 'File', root_dir => "t/permcache" ); foreach my $keyname (@keynames) { is( $perm_cache->get( $keys->{$keyname} ), $values->{$keyname}, "get $keyname from perm test cache" ); my $obj = $perm_cache->get_object( $keys->{$keyname} ); is( $obj->created_at, 1275657865 ); } sub set_standard_keys_and_values { my $self = shift; my ( %keys, %values ); my @mixed_chars = ( 32 .. 48, 57 .. 65, 90 .. 97, 122 .. 126, 240 ); %keys = ( 'space' => ' ', 'newline' => "\n", 'char' => 'a', 'zero' => 0, 'one' => 1, 'medium' => 'medium', 'mixed' => join( "", map { chr($_) } @mixed_chars ), 'empty' => 'empty', ); %values = map { ( $_, ref( $keys{$_} ) ? $keys{$_} : scalar( reverse( $keys{$_} ) ) ) } keys(%keys); $values{empty} = ''; return ( \%keys, \%values ); } CHI-0.60/t/author-no-data-serializer.t0000755€ˆž«€q{Ì0000000220012535132431017150 0ustar jonswart#!/usr/bin/perl BEGIN { unless ($ENV{AUTHOR_TESTING}) { require Test::More; Test::More::plan(skip_all => 'these tests are for testing by the author'); } } # # Tests that things work ok (with warning) without Data::Serializer installed # use strict; use warnings; use Test::More tests => 3; use Test::Exception; use Module::Load::Conditional qw(can_load); BEGIN { package MaskNativeMessage; use base qw(Module::Mask); my $test_module = "NonExistantModule" . time; my $native_message = do { eval "require $test_module"; $@ }; sub message { my ($class, $filename) = @_; (my $message = $native_message) =~ s/\Q$test_module.pm/$filename/; return $message; } $::mask = $::mask = MaskNativeMessage->new('Data::Serializer'); } use CHI; require CHI::Driver; my $cache; throws_ok { $cache = CHI->new( driver => 'Memory', serializer => 'Data::Dumper', global => 1 ); } qr/Could not load/, "dies with serializer"; lives_ok { $cache = CHI->new( driver => 'Memory', global => 1 ) } "lives with no serializer"; $cache->set( 'foo', 5 ); is( $cache->get('foo'), 5, 'cache get ok' ); CHI-0.60/t/author-RequiredModules.t0000644€ˆž«€q{Ì0000000035112535132431016571 0ustar jonswart#!/usr/bin/perl BEGIN { unless ($ENV{AUTHOR_TESTING}) { require Test::More; Test::More::plan(skip_all => 'these tests are for testing by the author'); } } use CHI::t::RequiredModules; CHI::t::RequiredModules->runtests; CHI-0.60/t/Bugs.t0000644€ˆž«€q{Ì0000000007212535132431013060 0ustar jonswart#!/usr/bin/perl use CHI::t::Bugs; CHI::t::Bugs->runtests; CHI-0.60/t/Config.t0000644€ˆž«€q{Ì0000000007612535132431013371 0ustar jonswart#!/usr/bin/perl use CHI::t::Config; CHI::t::Config->runtests; CHI-0.60/t/Constants.t0000644€ˆž«€q{Ì0000000010412535132431014130 0ustar jonswart#!/usr/bin/perl use CHI::t::Constants; CHI::t::Constants->runtests; CHI-0.60/t/Driver-Memory.t0000644€ˆž«€q{Ì0000000011612535132431014660 0ustar jonswart#!/usr/bin/perl use CHI::t::Driver::Memory; CHI::t::Driver::Memory->runtests; CHI-0.60/t/Driver-RawMemory.t0000644€ˆž«€q{Ì0000000012412535132431015331 0ustar jonswart#!/usr/bin/perl use CHI::t::Driver::RawMemory; CHI::t::Driver::RawMemory->runtests; CHI-0.60/t/GetError.t0000644€ˆž«€q{Ì0000000010212535132431013703 0ustar jonswart#!/usr/bin/perl use CHI::t::GetError; CHI::t::GetError->runtests; CHI-0.60/t/Initialize.t0000644€ˆž«€q{Ì0000000010612535132431014257 0ustar jonswart#!/usr/bin/perl use CHI::t::Initialize; CHI::t::Initialize->runtests; CHI-0.60/t/permcache/0000775€ˆž«€q{Ì0000000000012535132431013725 5ustar jonswartCHI-0.60/t/permcache/Default/0000775€ˆž«€q{Ì0000000000012535132431015311 5ustar jonswartCHI-0.60/t/permcache/Default/0/0000775€ˆž«€q{Ì0000000000012535132431015450 5ustar jonswartCHI-0.60/t/permcache/Default/0/4/0000775€ˆž«€q{Ì0000000000012535132431015613 5ustar jonswartCHI-0.60/t/permcache/Default/0/4/1.dat0000644€ˆž«€q{Ì0000000001712535132431016441 0ustar jonswart‰þLÿÿÿÿÿÿÿÿ1CHI-0.60/t/permcache/Default/0/4/empty.dat0000644€ˆž«€q{Ì0000000001612535132431017436 0ustar jonswart‰þLÿÿÿÿÿÿÿÿCHI-0.60/t/permcache/Default/1/0000775€ˆž«€q{Ì0000000000012535132431015451 5ustar jonswartCHI-0.60/t/permcache/Default/1/a/0000775€ˆž«€q{Ì0000000000012535132431015671 5ustar jonswart././@LongLink0000644000000000000000000000021212535132431011755 Lustar rootwheelCHI-0.60/t/permcache/Default/1/a/+20+21+22+23+24+25+26+27+28+29+2a+2b+2c-+2e+2f09+3a+3b+3c=+3e+3f+40AZ+5b+5c+5d+5e_+60az+7b+7c+7d~+f0.datCHI-0.60/t/permcache/Default/1/a/+20+21+22+23+24+25+26+27+28+29+2a+2b+2c-+2e+2f09+3a+3b+3c=+3e+3f+400000644€ˆž«€q{Ì0000000006612535132431025125 0ustar jonswart‰þLÿÿÿÿÿÿÿÿð~}|{za`_^]\[ZA@?>=<;:90/.-,+*)('&%$#"! CHI-0.60/t/permcache/Default/2/0000775€ˆž«€q{Ì0000000000012535132431015452 5ustar jonswartCHI-0.60/t/permcache/Default/2/3/0000775€ˆž«€q{Ì0000000000012535132431015614 5ustar jonswartCHI-0.60/t/permcache/Default/2/3/+0a.dat0000644€ˆž«€q{Ì0000000001712535132431016655 0ustar jonswart‰þLÿÿÿÿÿÿÿÿ CHI-0.60/t/permcache/Default/6/0000775€ˆž«€q{Ì0000000000012535132431015456 5ustar jonswartCHI-0.60/t/permcache/Default/6/3/0000775€ˆž«€q{Ì0000000000012535132431015620 5ustar jonswartCHI-0.60/t/permcache/Default/6/3/0.dat0000644€ˆž«€q{Ì0000000001712535132431016445 0ustar jonswart‰þLÿÿÿÿÿÿÿÿ0CHI-0.60/t/permcache/Default/7/0000775€ˆž«€q{Ì0000000000012535132431015457 5ustar jonswartCHI-0.60/t/permcache/Default/7/7/0000775€ˆž«€q{Ì0000000000012535132431015625 5ustar jonswartCHI-0.60/t/permcache/Default/7/7/+20.dat0000644€ˆž«€q{Ì0000000001712535132431016607 0ustar jonswart‰þLÿÿÿÿÿÿÿÿ CHI-0.60/t/permcache/Default/8/0000775€ˆž«€q{Ì0000000000012535132431015460 5ustar jonswartCHI-0.60/t/permcache/Default/8/1/0000775€ˆž«€q{Ì0000000000012535132431015620 5ustar jonswartCHI-0.60/t/permcache/Default/8/1/a.dat0000644€ˆž«€q{Ì0000000001712535132431016526 0ustar jonswart‰þLÿÿÿÿÿÿÿÿaCHI-0.60/t/permcache/Default/b/0000775€ˆž«€q{Ì0000000000012535132431015532 5ustar jonswartCHI-0.60/t/permcache/Default/b/6/0000775€ˆž«€q{Ì0000000000012535132431015677 5ustar jonswartCHI-0.60/t/permcache/Default/b/6/medium.dat0000644€ˆž«€q{Ì0000000002412535132431017643 0ustar jonswart‰þLÿÿÿÿÿÿÿÿmuidemCHI-0.60/t/release-dependent.t0000644€ˆž«€q{Ì0000000324512535132431015551 0ustar jonswart BEGIN { unless ($ENV{RELEASE_TESTING}) { require Test::More; Test::More::plan(skip_all => 'these tests are for release candidate testing'); } } use strict; use warnings; use Test::More; BEGIN { plan skip_all => <<'END_HELP' unless $ENV{CHI_TEST_MD}; This test will not run unless you set CHI_TEST_MD to a true value. END_HELP } use Test::DependentModules qw(test_modules); #$ENV{CHI_REDIS_SERVER} = 1; # CHI::Driver::Redis #$ENV{FORCE_MEMCACHED_TESTS} = 1; # CHI::Cascade # extra dep: Cache::Memcached::libmemcached test_modules(qw( CGI::Application::Plugin::CHI CHI::Cascade CHI::Driver::BerkeleyDB CHI::Driver::DBI CHI::Driver::Memcached CHI::Driver::Redis CHI::Driver::SharedMem CHI::Memoize Cache::Profile Dancer::Plugin::Cache::CHI Dancer::Session::CHI Dezi::Bot Dist::Zilla::Role::MetaCPANInterfacer Elastic::Model File::DataClass Mason::Plugin::Cache Metabase Mojito Mojolicious::Plugin::CHI Parallel::ForkControl Perlanet RDF::Helper::Properties Rose::DBx::Object::Cached::CHI Search::OpenSearch Tapper::Reports::DPath Tie::CHI Yukki )); #Mojolicious::Plugin::Cache # broken #Text::Corpus::CNN # broken #Text::Corpus::VoiceOfAmerica # broken #Geo::Heatmap # Image::Magick #CHI::Driver::Ping # no useful tests, also insane #CHI::Driver::MemcachedFast # tests broken #CHI::Driver::HandlerSocket # missing dep Net::HandlerSocket #App::ListPrereqs # no useful tests #Poet # broken dep #Plack::Middleware::ActiveMirror # no tests #Apache2::AutoTicketLDAP # apache #Net::FullAuto # wtf #CHI::Driver::TokyoTyrant # darkpan #Tapper::Testplan # tests broken #Template::Provider::Amazon::S3 # no useful tests done_testing; CHI-0.60/t/Sanity.t0000644€ˆž«€q{Ì0000000007612535132431013433 0ustar jonswart#!/usr/bin/perl use CHI::t::Sanity; CHI::t::Sanity->runtests; CHI-0.60/t/set_permcache.pl0000755€ˆž«€q{Ì0000000220612535132431015136 0ustar jonswart#!/usr/bin/perl # # Write permcache - for xt/author/file-driver.t and possibly other tests. # use CHI; use warnings; use strict; sub set_standard_keys_and_values { my $self = shift; my ( %keys, %values ); my @mixed_chars = ( 32 .. 48, 57 .. 65, 90 .. 97, 122 .. 126, 240 ); %keys = ( 'space' => ' ', 'newline' => "\n", 'char' => 'a', 'zero' => 0, 'one' => 1, 'medium' => 'medium', 'mixed' => join( "", map { chr($_) } @mixed_chars ), 'large' => scalar( 'ab' x 256 ), 'empty' => 'empty', ); %values = map { ( $_, ref( $keys{$_} ) ? $keys{$_} : scalar( reverse( $keys{$_} ) ) ) } keys(%keys); $values{empty} = ''; return ( \%keys, \%values ); } my ( $keys, $values ) = set_standard_keys_and_values(); my $perm_cache = CHI->new( driver => 'File', root_dir => "permcache", on_set_error => 'die' ); $perm_cache->clear(); foreach my $keyname ( sort keys(%$keys) ) { $perm_cache->set( $keys->{$keyname}, $values->{$keyname} ); use d; dp [ $keys->{$keyname}, $perm_cache->path_to_key( $keys->{$keyname} ) ]; } CHI-0.60/t/SetError.t0000644€ˆž«€q{Ì0000000010212535132431013717 0ustar jonswart#!/usr/bin/perl use CHI::t::SetError; CHI::t::SetError->runtests; CHI-0.60/t/smoke-Driver-CacheCache.t0000644€ˆž«€q{Ì0000000035212535132431016455 0ustar jonswart#!perl -w BEGIN { unless ($ENV{AUTOMATED_TESTING}) { require Test::More; Test::More::plan(skip_all => 'these tests are for "smoke bot" testing'); } } use CHI::t::Driver::CacheCache; CHI::t::Driver::CacheCache->runtests; CHI-0.60/t/smoke-Driver-FastMmap.t0000644€ˆž«€q{Ì0000000034612535132431016241 0ustar jonswart#!perl -w BEGIN { unless ($ENV{AUTOMATED_TESTING}) { require Test::More; Test::More::plan(skip_all => 'these tests are for "smoke bot" testing'); } } use CHI::t::Driver::FastMmap; CHI::t::Driver::FastMmap->runtests; CHI-0.60/t/smoke-Driver-File-DepthZero.t0000644€ˆž«€q{Ì0000000036412535132431017312 0ustar jonswart#!perl -w BEGIN { unless ($ENV{AUTOMATED_TESTING}) { require Test::More; Test::More::plan(skip_all => 'these tests are for "smoke bot" testing'); } } use CHI::t::Driver::File::DepthZero; CHI::t::Driver::File::DepthZero->runtests; CHI-0.60/t/smoke-Driver-File.t0000644€ˆž«€q{Ì0000000033612535132431015407 0ustar jonswart#!perl -w BEGIN { unless ($ENV{AUTOMATED_TESTING}) { require Test::More; Test::More::plan(skip_all => 'these tests are for "smoke bot" testing'); } } use CHI::t::Driver::File; CHI::t::Driver::File->runtests; CHI-0.60/t/smoke-Driver-NonMoose.t0000644€ˆž«€q{Ì0000000034612535132431016266 0ustar jonswart#!perl -w BEGIN { unless ($ENV{AUTOMATED_TESTING}) { require Test::More; Test::More::plan(skip_all => 'these tests are for "smoke bot" testing'); } } use CHI::t::Driver::NonMoose; CHI::t::Driver::NonMoose->runtests; CHI-0.60/t/smoke-Driver-Subcache-l1_cache.t0000644€ˆž«€q{Ì0000000037212535132431017702 0ustar jonswart#!perl -w BEGIN { unless ($ENV{AUTOMATED_TESTING}) { require Test::More; Test::More::plan(skip_all => 'these tests are for "smoke bot" testing'); } } use CHI::t::Driver::Subcache::l1_cache; CHI::t::Driver::Subcache::l1_cache->runtests; CHI-0.60/t/smoke-Driver-Subcache-mirror_cache.t0000644€ˆž«€q{Ì0000000040212535132431020672 0ustar jonswart#!perl -w BEGIN { unless ($ENV{AUTOMATED_TESTING}) { require Test::More; Test::More::plan(skip_all => 'these tests are for "smoke bot" testing'); } } use CHI::t::Driver::Subcache::mirror_cache; CHI::t::Driver::Subcache::mirror_cache->runtests; CHI-0.60/t/smoke-Null.t0000644€ˆž«€q{Ì0000000031612535132431014207 0ustar jonswart#!perl -w BEGIN { unless ($ENV{AUTOMATED_TESTING}) { require Test::More; Test::More::plan(skip_all => 'these tests are for "smoke bot" testing'); } } use CHI::t::Null; CHI::t::Null->runtests; CHI-0.60/t/Subcache.t0000644€ˆž«€q{Ì0000000010212535132431013667 0ustar jonswart#!/usr/bin/perl use CHI::t::Subcache; CHI::t::Subcache->runtests; CHI-0.60/t/Subclass.t0000644€ˆž«€q{Ì0000000010212535132431013731 0ustar jonswart#!/usr/bin/perl use CHI::t::Subclass; CHI::t::Subclass->runtests; CHI-0.60/t/Util.t0000644€ˆž«€q{Ì0000000007212535132431013075 0ustar jonswart#!/usr/bin/perl use CHI::t::Util; CHI::t::Util->runtests;