Cache-Mmap-0.11/0000755001163000001440000000000011001075015012015 5ustar pmhusersCache-Mmap-0.11/cmmtest0000755001163000001440000000373007772025427013450 0ustar pmhusers#!/usr/local/bin/perl-journals # cmmtest: test of mmapped cache # $Id: cmmtest,v 1.5 2003/12/23 11:46:31 pmh Exp $ use Cache::Mmap; use Data::Dumper; use strict; # These will be read from the file if it already exists my %options=( buckets => 11, bucketsize => 200, strings => 1, ); my %escape=( "\n" => '\n', "\r" => '\r', "\t" => '\t', "\\" => '\\\\', ); my $filename='.cache'; $filename=shift if @ARGV; my $cache=Cache::Mmap->new($filename,\%options) or die; print "Strings: ",$cache->strings,"\n"; # Read user commands from STDIN $|=1; print "cmmtest: "; while(<>){ my($cmd,$key,$value)=/^([<>0?\-k])(?:\s+(\S+)(?:\s+(.*))?)?\s+$/ or do{ warn "Invalid command\n"; next; }; if($cmd eq '<'){ # Read if($value ne ''){ warn "Unexpected stuff after key\n"; next; } my($found,$val)=$cache->read($key); if(!$found){ print "No such value\n"; }elsif(defined $val){ if($cache->{strings}){ $val=~s/([^\40-\176\\])/$escape{$1} || sprintf '\\x{%02x}',ord $1/ge; }else{ $val=Dumper($val); } print "=> $val\n"; }else{ print "Undefined value\n"; } }elsif($cmd eq '>'){ # Write if($cache->write($key,$cache->strings ? $value : \$value)){ print "OK\n"; }else{ warn "Can't write value\n"; } }elsif($cmd eq '-'){ # delete my($found,$val)=$cache->delete($key); if(!$found){ print "No such value\n"; }elsif(defined $val){ $val=Dumper($val) unless $cache->strings; print "= ok[$val]\n"; }else{ warn "Undefined value\n"; } }elsif($cmd eq '0'){ # clear $cache->quick_clear(); print "OK\n"; }elsif($cmd eq 'k'){ print map " $_\n",$cache->entries; print "OK\n"; }elsif($cmd eq '?'){ # exists my($found,$val)=$cache->read($key); if($found){ print "= yes\n"; }else{ print "= no\n"; } }else{ warn "Unknown command: $cmd\n"; } }continue{ print "cmmtest: "; } Cache-Mmap-0.11/ppport.h0000644001163000001440000003470511001061370013522 0ustar pmhusers /* ppport.h -- Perl/Pollution/Portability Version 2.0002 * * Automatically Created by Devel::PPPort on Wed Apr 9 17:29:22 2003 * * Do NOT edit this file directly! -- Edit PPPort.pm instead. * * Version 2.x, Copyright (C) 2001, Paul Marquess. * Version 1.x, Copyright (C) 1999, Kenneth Albanowski. * This code may be used and distributed under the same license as any * version of Perl. * * This version of ppport.h is designed to support operation with Perl * installations back to 5.004, and has been tested up to 5.8.0. * * If this version of ppport.h is failing during the compilation of this * module, please check if a newer version of Devel::PPPort is available * on CPAN before sending a bug report. * * If you are using the latest version of Devel::PPPort and it is failing * during compilation of this module, please send a report to perlbug@perl.com * * Include all following information: * * 1. The complete output from running "perl -V" * * 2. This file. * * 3. The name & version of the module you were trying to build. * * 4. A full log of the build that failed. * * 5. Any other information that you think could be relevant. * * * For the latest version of this code, please retreive the Devel::PPPort * module from CPAN. * */ /* * In order for a Perl extension module to be as portable as possible * across differing versions of Perl itself, certain steps need to be taken. * Including this header is the first major one, then using dTHR is all the * appropriate places and using a PL_ prefix to refer to global Perl * variables is the second. * */ /* If you use one of a few functions that were not present in earlier * versions of Perl, please add a define before the inclusion of ppport.h * for a static include, or use the GLOBAL request in a single module to * produce a global definition that can be referenced from the other * modules. * * Function: Static define: Extern define: * newCONSTSUB() NEED_newCONSTSUB NEED_newCONSTSUB_GLOBAL * */ /* To verify whether ppport.h is needed for your module, and whether any * special defines should be used, ppport.h can be run through Perl to check * your source code. Simply say: * * perl -x ppport.h *.c *.h *.xs foo/bar*.c [etc] * * The result will be a list of patches suggesting changes that should at * least be acceptable, if not necessarily the most efficient solution, or a * fix for all possible problems. It won't catch where dTHR is needed, and * doesn't attempt to account for global macro or function definitions, * nested includes, typemaps, etc. * * In order to test for the need of dTHR, please try your module under a * recent version of Perl that has threading compiled-in. * */ /* #!/usr/bin/perl @ARGV = ("*.xs") if !@ARGV; %badmacros = %funcs = %macros = (); $replace = 0; foreach () { $funcs{$1} = 1 if /Provide:\s+(\S+)/; $macros{$1} = 1 if /^#\s*define\s+([a-zA-Z0-9_]+)/; $replace = $1 if /Replace:\s+(\d+)/; $badmacros{$2}=$1 if $replace and /^#\s*define\s+([a-zA-Z0-9_]+).*?\s+([a-zA-Z0-9_]+)/; $badmacros{$1}=$2 if /Replace (\S+) with (\S+)/; } foreach $filename (map(glob($_),@ARGV)) { unless (open(IN, "<$filename")) { warn "Unable to read from $file: $!\n"; next; } print "Scanning $filename...\n"; $c = ""; while () { $c .= $_; } close(IN); $need_include = 0; %add_func = (); $changes = 0; $has_include = ($c =~ /#.*include.*ppport/m); foreach $func (keys %funcs) { if ($c =~ /#.*define.*\bNEED_$func(_GLOBAL)?\b/m) { if ($c !~ /\b$func\b/m) { print "If $func isn't needed, you don't need to request it.\n" if $changes += ($c =~ s/^.*#.*define.*\bNEED_$func\b.*\n//m); } else { print "Uses $func\n"; $need_include = 1; } } else { if ($c =~ /\b$func\b/m) { $add_func{$func} =1 ; print "Uses $func\n"; $need_include = 1; } } } if (not $need_include) { foreach $macro (keys %macros) { if ($c =~ /\b$macro\b/m) { print "Uses $macro\n"; $need_include = 1; } } } foreach $badmacro (keys %badmacros) { if ($c =~ /\b$badmacro\b/m) { $changes += ($c =~ s/\b$badmacro\b/$badmacros{$badmacro}/gm); print "Uses $badmacros{$badmacro} (instead of $badmacro)\n"; $need_include = 1; } } if (scalar(keys %add_func) or $need_include != $has_include) { if (!$has_include) { $inc = join('',map("#define NEED_$_\n", sort keys %add_func)). "#include \"ppport.h\"\n"; $c = "$inc$c" unless $c =~ s/#.*include.*XSUB.*\n/$&$inc/m; } elsif (keys %add_func) { $inc = join('',map("#define NEED_$_\n", sort keys %add_func)); $c = "$inc$c" unless $c =~ s/^.*#.*include.*ppport.*$/$inc$&/m; } if (!$need_include) { print "Doesn't seem to need ppport.h.\n"; $c =~ s/^.*#.*include.*ppport.*\n//m; } $changes++; } if ($changes) { open(OUT,">/tmp/ppport.h.$$"); print OUT $c; close(OUT); open(DIFF, "diff -u $filename /tmp/ppport.h.$$|"); while () { s!/tmp/ppport\.h\.$$!$filename.patched!; print STDOUT; } close(DIFF); unlink("/tmp/ppport.h.$$"); } else { print "Looks OK\n"; } } __DATA__ */ #ifndef _P_P_PORTABILITY_H_ #define _P_P_PORTABILITY_H_ #ifndef PERL_REVISION # ifndef __PATCHLEVEL_H_INCLUDED__ # include "patchlevel.h" # endif # ifndef PERL_REVISION # define PERL_REVISION (5) /* Replace: 1 */ # define PERL_VERSION PATCHLEVEL # define PERL_SUBVERSION SUBVERSION /* Replace PERL_PATCHLEVEL with PERL_VERSION */ /* Replace: 0 */ # endif #endif #define PERL_BCDVERSION ((PERL_REVISION * 0x1000000L) + (PERL_VERSION * 0x1000L) + PERL_SUBVERSION) /* It is very unlikely that anyone will try to use this with Perl 6 (or greater), but who knows. */ #if PERL_REVISION != 5 # error ppport.h only works with Perl version 5 #endif /* PERL_REVISION != 5 */ #ifndef ERRSV # define ERRSV perl_get_sv("@",FALSE) #endif #if (PERL_VERSION < 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION <= 5)) /* Replace: 1 */ # define PL_Sv Sv # define PL_compiling compiling # define PL_copline copline # define PL_curcop curcop # define PL_curstash curstash # define PL_defgv defgv # define PL_dirty dirty # define PL_dowarn dowarn # define PL_hints hints # define PL_na na # define PL_perldb perldb # define PL_rsfp_filters rsfp_filters # define PL_rsfpv rsfp # define PL_stdingv stdingv # define PL_sv_no sv_no # define PL_sv_undef sv_undef # define PL_sv_yes sv_yes /* Replace: 0 */ #endif #ifdef HASATTRIBUTE # if defined(__GNUC__) && defined(__cplusplus) # define PERL_UNUSED_DECL # else # define PERL_UNUSED_DECL __attribute__((unused)) # endif #else # define PERL_UNUSED_DECL #endif #ifndef dNOOP # define NOOP (void)0 # define dNOOP extern int Perl___notused PERL_UNUSED_DECL #endif #ifndef dTHR # define dTHR dNOOP #endif #ifndef dTHX # define dTHX dNOOP # define dTHXa(x) dNOOP # define dTHXoa(x) dNOOP #endif #ifndef pTHX # define pTHX void # define pTHX_ # define aTHX # define aTHX_ #endif #ifndef UVSIZE # define UVSIZE IVSIZE #endif #ifndef NVTYPE # if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE) # define NVTYPE long double # else # define NVTYPE double # endif typedef NVTYPE NV; #endif #ifndef INT2PTR #if (IVSIZE == PTRSIZE) && (UVSIZE == PTRSIZE) # define PTRV UV # define INT2PTR(any,d) (any)(d) #else # if PTRSIZE == LONGSIZE # define PTRV unsigned long # else # define PTRV unsigned # endif # define INT2PTR(any,d) (any)(PTRV)(d) #endif #define NUM2PTR(any,d) (any)(PTRV)(d) #define PTR2IV(p) INT2PTR(IV,p) #define PTR2UV(p) INT2PTR(UV,p) #define PTR2NV(p) NUM2PTR(NV,p) #if PTRSIZE == LONGSIZE # define PTR2ul(p) (unsigned long)(p) #else # define PTR2ul(p) INT2PTR(unsigned long,p) #endif #endif /* !INT2PTR */ #ifndef boolSV # define boolSV(b) ((b) ? &PL_sv_yes : &PL_sv_no) #endif #ifndef gv_stashpvn # define gv_stashpvn(str,len,flags) gv_stashpv(str,flags) #endif #ifndef newSVpvn # define newSVpvn(data,len) ((len) ? newSVpv ((data), (len)) : newSVpv ("", 0)) #endif #ifndef newRV_inc /* Replace: 1 */ # define newRV_inc(sv) newRV(sv) /* Replace: 0 */ #endif /* DEFSV appears first in 5.004_56 */ #ifndef DEFSV # define DEFSV GvSV(PL_defgv) #endif #ifndef SAVE_DEFSV # define SAVE_DEFSV SAVESPTR(GvSV(PL_defgv)) #endif #ifndef newRV_noinc # ifdef __GNUC__ # define newRV_noinc(sv) \ ({ \ SV *nsv = (SV*)newRV(sv); \ SvREFCNT_dec(sv); \ nsv; \ }) # else # if defined(USE_THREADS) static SV * newRV_noinc (SV * sv) { SV *nsv = (SV*)newRV(sv); SvREFCNT_dec(sv); return nsv; } # else # define newRV_noinc(sv) \ (PL_Sv=(SV*)newRV(sv), SvREFCNT_dec(sv), (SV*)PL_Sv) # endif # endif #endif /* Provide: newCONSTSUB */ /* newCONSTSUB from IO.xs is in the core starting with 5.004_63 */ #if (PERL_VERSION < 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION < 63)) #if defined(NEED_newCONSTSUB) static #else extern void newCONSTSUB(HV * stash, char * name, SV *sv); #endif #if defined(NEED_newCONSTSUB) || defined(NEED_newCONSTSUB_GLOBAL) void newCONSTSUB(stash,name,sv) HV *stash; char *name; SV *sv; { U32 oldhints = PL_hints; HV *old_cop_stash = PL_curcop->cop_stash; HV *old_curstash = PL_curstash; line_t oldline = PL_curcop->cop_line; PL_curcop->cop_line = PL_copline; PL_hints &= ~HINT_BLOCK_SCOPE; if (stash) PL_curstash = PL_curcop->cop_stash = stash; newSUB( #if (PERL_VERSION < 3) || ((PERL_VERSION == 3) && (PERL_SUBVERSION < 22)) /* before 5.003_22 */ start_subparse(), #else # if (PERL_VERSION == 3) && (PERL_SUBVERSION == 22) /* 5.003_22 */ start_subparse(0), # else /* 5.003_23 onwards */ start_subparse(FALSE, 0), # endif #endif newSVOP(OP_CONST, 0, newSVpv(name,0)), newSVOP(OP_CONST, 0, &PL_sv_no), /* SvPV(&PL_sv_no) == "" -- GMB */ newSTATEOP(0, Nullch, newSVOP(OP_CONST, 0, sv)) ); PL_hints = oldhints; PL_curcop->cop_stash = old_cop_stash; PL_curstash = old_curstash; PL_curcop->cop_line = oldline; } #endif #endif /* newCONSTSUB */ #ifndef START_MY_CXT /* * Boilerplate macros for initializing and accessing interpreter-local * data from C. All statics in extensions should be reworked to use * this, if you want to make the extension thread-safe. See ext/re/re.xs * for an example of the use of these macros. * * Code that uses these macros is responsible for the following: * 1. #define MY_CXT_KEY to a unique string, e.g. "DynaLoader_guts" * 2. Declare a typedef named my_cxt_t that is a structure that contains * all the data that needs to be interpreter-local. * 3. Use the START_MY_CXT macro after the declaration of my_cxt_t. * 4. Use the MY_CXT_INIT macro such that it is called exactly once * (typically put in the BOOT: section). * 5. Use the members of the my_cxt_t structure everywhere as * MY_CXT.member. * 6. Use the dMY_CXT macro (a declaration) in all the functions that * access MY_CXT. */ #if defined(MULTIPLICITY) || defined(PERL_OBJECT) || \ defined(PERL_CAPI) || defined(PERL_IMPLICIT_CONTEXT) /* This must appear in all extensions that define a my_cxt_t structure, * right after the definition (i.e. at file scope). The non-threads * case below uses it to declare the data as static. */ #define START_MY_CXT #if (PERL_VERSION < 4 || (PERL_VERSION == 4 && PERL_SUBVERSION < 68 )) /* Fetches the SV that keeps the per-interpreter data. */ #define dMY_CXT_SV \ SV *my_cxt_sv = perl_get_sv(MY_CXT_KEY, FALSE) #else /* >= perl5.004_68 */ #define dMY_CXT_SV \ SV *my_cxt_sv = *hv_fetch(PL_modglobal, MY_CXT_KEY, \ sizeof(MY_CXT_KEY)-1, TRUE) #endif /* < perl5.004_68 */ /* This declaration should be used within all functions that use the * interpreter-local data. */ #define dMY_CXT \ dMY_CXT_SV; \ my_cxt_t *my_cxtp = INT2PTR(my_cxt_t*,SvUV(my_cxt_sv)) /* Creates and zeroes the per-interpreter data. * (We allocate my_cxtp in a Perl SV so that it will be released when * the interpreter goes away.) */ #define MY_CXT_INIT \ dMY_CXT_SV; \ /* newSV() allocates one more than needed */ \ my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1));\ Zero(my_cxtp, 1, my_cxt_t); \ sv_setuv(my_cxt_sv, PTR2UV(my_cxtp)) /* This macro must be used to access members of the my_cxt_t structure. * e.g. MYCXT.some_data */ #define MY_CXT (*my_cxtp) /* Judicious use of these macros can reduce the number of times dMY_CXT * is used. Use is similar to pTHX, aTHX etc. */ #define pMY_CXT my_cxt_t *my_cxtp #define pMY_CXT_ pMY_CXT, #define _pMY_CXT ,pMY_CXT #define aMY_CXT my_cxtp #define aMY_CXT_ aMY_CXT, #define _aMY_CXT ,aMY_CXT #else /* single interpreter */ #define START_MY_CXT static my_cxt_t my_cxt; #define dMY_CXT_SV dNOOP #define dMY_CXT dNOOP #define MY_CXT_INIT NOOP #define MY_CXT my_cxt #define pMY_CXT void #define pMY_CXT_ #define _pMY_CXT #define aMY_CXT #define aMY_CXT_ #define _aMY_CXT #endif #endif /* START_MY_CXT */ #ifndef IVdf # if IVSIZE == LONGSIZE # define IVdf "ld" # define UVuf "lu" # define UVof "lo" # define UVxf "lx" # define UVXf "lX" # else # if IVSIZE == INTSIZE # define IVdf "d" # define UVuf "u" # define UVof "o" # define UVxf "x" # define UVXf "X" # endif # endif #endif #ifndef NVef # if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE) && \ defined(PERL_PRIfldbl) /* Not very likely, but let's try anyway. */ # define NVef PERL_PRIeldbl # define NVff PERL_PRIfldbl # define NVgf PERL_PRIgldbl # else # define NVef "e" # define NVff "f" # define NVgf "g" # endif #endif #ifndef AvFILLp /* Older perls (<=5.003) lack AvFILLp */ # define AvFILLp AvFILL #endif #ifdef SvPVbyte # if PERL_REVISION == 5 && PERL_VERSION < 7 /* SvPVbyte does not work in perl-5.6.1, borrowed version for 5.7.3 */ # undef SvPVbyte # define SvPVbyte(sv, lp) \ ((SvFLAGS(sv) & (SVf_POK|SVf_UTF8)) == (SVf_POK) \ ? ((lp = SvCUR(sv)), SvPVX(sv)) : my_sv_2pvbyte(aTHX_ sv, &lp)) static char * my_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp) { sv_utf8_downgrade(sv,0); return SvPV(sv,*lp); } # endif #else # define SvPVbyte SvPV #endif #endif /* _P_P_PORTABILITY_H_ */ /* End of File ppport.h */ Cache-Mmap-0.11/META.yml0000644001163000001440000000067211001075015013273 0ustar pmhusers# http://module-build.sourceforge.net/META-spec.html #XXXXXXX This is a prototype!!! It will change in the future!!! XXXXX# name: Cache-Mmap version: 0.11 version_from: Mmap.pm installdirs: site requires: Carp: 0 Fcntl: 0 Storable: 0 Test::More: 0 distribution_type: module generated_by: ExtUtils::MakeMaker version 6.30 Cache-Mmap-0.11/t/0000755001163000001440000000000011001075015012260 5ustar pmhusersCache-Mmap-0.11/t/01simple.t0000644001163000001440000000334111001061370014077 0ustar pmhusers# Simple test of cache with default parameters # $Id: 01simple.t,v 1.2 2003/06/13 16:22:22 pmh Exp $ use Test::More tests => 46; BEGIN{ use_ok('Cache::Mmap'); } use strict; # Prepare the ground chdir 't' if -d 't'; my $fname='test.cmm'; unlink $fname; # Check defaults are OK ok(my $cache=Cache::Mmap->new($fname,{}),'creating cache file'); foreach( [buckets => 13], [bucketsize => 1024], [pagesize => 1024], [strings => 0], [expiry => 0], [cachenegative => 0], [writethrough => 1], ){ my($key,$val)=@$_; is($cache->$key(),$val,"default $key"); } # There shouldn't be anything in the file is($cache->read('some random key'),undef,'cache is empty'); # Store some stuff in the file my %data; for(1..10){ my $datum=[map chr(65+$_) x $_,0..$_]; $data{$_}=$datum; $cache->write($_,$datum); } for(1..10){ ok(eq_array(scalar $cache->read($_),$data{$_}),"read $_: @{$data{$_}}"); } # Overwite some entries for(3,5,7){ my $datum={map +($_ => 'z' x $_),1..$_}; $data{$_}=$datum; $cache->write($_,$datum); } for(1,2,4,6,8,9,10){ ok(eq_array(scalar $cache->read($_),$data{$_}),"overwrite $_: @{$data{$_}}"); } for(3,5,7){ ok(eq_hash(scalar $cache->read($_),$data{$_}),"overwrite $_: @{[%{$data{$_}}]}"); } # Delete some entries for(3,6,9){ my($found,$datum)=$cache->delete($_); ok($found,"delete $_"); ok($_==3 ? eq_hash($datum,$data{$_}) : eq_array($datum,$data{$_}),"delete data $_"); } # Check that everything else is still OK for(1..10){ my($found,$datum)=$cache->read($_); if(not $_%3){ ok(!$found,"deleted $_"); }elsif(!$found){ fail("deleted $_"); }elsif($_==5 || $_==7){ ok(eq_hash($datum,$data{$_}),"deleted $_"); }else{ ok(eq_array($datum,$data{$_}),"deleted $_"); } } unlink $fname; Cache-Mmap-0.11/t/03corrupt.t0000644001163000001440000000610510025355531014321 0ustar pmhusers# Test of behaviour wrt corrupt cache files # $Id: 03corrupt.t,v 1.7 2004/03/15 16:35:37 pmh Exp $ # This test is aware of some of the structure of the cache files # Be careful when changing things use IO::File; use Test::More tests => 26; use strict; BEGIN{ use_ok('Cache::Mmap'); } BEGIN{ if($]>=5.008){ require 'open.pm'; open::import(open => OUT => ':raw'); } } chdir 't' if -d 't'; my $fname='corrupt.cmm'; # Create a new cache file ok(my $cache=newcache(),'creating cache file 1'); my $pagesize=$cache->pagesize; my $bucketsize=$cache->bucketsize; my $headsize=40; my $bheadsize=40; my $eheadsize=40; is($cache->buckets,1,'only one bucket'); # Make it seem very full substr($cache->{_mmap},$pagesize,4)='huge'; # Attempt to read something eval{ $cache->read('abc'); }; ok($@=~/Zero-sized/,'zero-sized error'); # Start again ok($cache=newcache(),'creating cache file 2'); # Add a normal entry ok($cache->write('abc','def'),'adding entry'); # Check it's OK is($cache->read('abc'),'def','checking entry'); # Make it seem very long substr($cache->{_mmap},$pagesize,4)=pack 'l',1000; substr($cache->{_mmap},$pagesize+$bheadsize,4)=pack 'l',100; # Attempt to read something eval{ $cache->read('abs'); }; ok($@=~/Super-sized/,'super-sized error'); # Start a new cache, with a low expiry date ok($cache=newcache(expiry => 5),'creating cache file 3'); # Add an entry which will expire ok($cache->write('old','dlo'),'adding old entry'); sleep 6; # Add an entry which will replace the first entry ok($cache->write('new','wen'),'adding new entry'); # Check we've got what we expect is($cache->read('new'),'wen','new entry still present'); is($cache->read('old'),undef,'old entry expired'); # Start a new cache file ok($cache=newcache(),'creating cache file 4'); undef $cache; # Make sure it's OK when we open it again ok($cache=eval{ Cache::Mmap->new($fname); },'reopened cache file 4'); # Try accessing a file with the wrong magic number ok(unlink($fname),'delete old file'); undef $cache; sleep 2; ok(my $fh=IO::File->new($fname,'>'),'creating broken file 1') or print "# Can't open $fname: $!\n"; my $head=pack "l$headsize",12345; ok(syswrite($fh,$head,length $head),'writing broken header'); ok(close $fh,'closing broken file'); if(my $cache=eval{ Cache::Mmap->new($fname); }){ print "# $cache\n"; }else{ print "# $@"; } ok($@=~/not a Cache::Mmap file/,"magic number check"); # Try accessing a file with a different file format ok(unlink($fname),'delete old file'); undef $cache; sleep 2; ok($fh=IO::File->new($fname,'>'),'creating broken file 2') or print "# Can't open $fname: $!\n"; $head=pack "l$headsize",0x15ACACE,1,2,3,4,5,6,7,8,9; ok(syswrite($fh,$head,length $head),'writing broken header'); ok(close $fh,'closing broken file'); if(my $cache=eval{ Cache::Mmap->new($fname); }){ print "# $cache\n"; }else{ print "# $@"; } ok($@=~/only supports v/,"file format version check"); unlink $fname; ok(1,'final test'); sub newcache{ unlink $fname; my $cache=Cache::Mmap->new($fname,{ strings => 1, pagesize => 100, bucketsize => 100, buckets => 1, @_, }); } Cache-Mmap-0.11/t/02entries.t0000644001163000001440000000205007750256147014304 0ustar pmhusers# Test of entries() method # $Id: 02entries.t,v 1.3 2003/10/30 18:45:59 pmh Exp $ use Test::More tests => 6; use strict; BEGIN{ use_ok('Cache::Mmap'); } # Prepare the ground chdir 't' if -d 't'; my $fname='entries.cmm'; unlink $fname; ok(my $cache=Cache::Mmap->new($fname,{strings => 1}),'creating cache file'); ok(eq_array([$cache->entries],[]),'cache should be empty'); for(1..5){ $cache->write($_,$_*$_); } ok(eq_set([$cache->entries],[1..5]),'simple entries(): '.join ' ',$cache->entries); my @entries=sort { $a->{key} cmp $b->{key} } $cache->entries(1); foreach(@entries){ delete $_->{'time'}; # We can't guarantee the time we think it went in } my @expect=map +{ key => $_, dirty => 0, },1..5; ok(eq_array(\@entries,\@expect),'complex entries()'); @entries=sort { $a->{key} cmp $b->{key} } $cache->entries(2); foreach(@entries){ delete $_->{'time'}; # We can't guarantee the time we think it went in } foreach(@expect){ $_->{value}=$_->{key} * $_->{key}; } ok(eq_array(\@entries,\@expect), 'complex entries() with values'); unlink $fname; Cache-Mmap-0.11/t/05keep.t0000644001163000001440000000212207750256225013557 0ustar pmhusers# Test of CMM_keep_expired special values # $Id: 05keep.t,v 1.1 2003/10/30 18:46:45 pmh Exp $ use Test::More tests => 9; use strict; BEGIN{ use_ok('Cache::Mmap',qw(CMM_keep_expired CMM_keep_expired_refresh)); } # Prepare the ground chdir 't' if -d 't'; my $fname='keep.cmm'; unlink $fname; my($found,$val); ok(my $cache=Cache::Mmap->new($fname,{ strings => 1, expiry => 5, # Needs to be long enough to keep slow machines happy read => sub{ return ($found,$val); }, }),'creating cache file'); $cache->write(keep => 'peek'); $cache->write(lose => 'sole'); is($cache->read('keep'),'peek','keep => peek'); is($cache->read('lose'),'sole','lose => sole'); print "# sleep 6\n"; sleep 6; # Let things expire is($cache->read('lose'),undef,'lost lose'); ($found,$val)=(CMM_keep_expired_refresh,'banana'); is($cache->read('keep'),'peek','refresh'); is($cache->read('keep'),'peek','stays refreshed'); print "# sleep 6\n"; sleep 6; # Expire again $found=CMM_keep_expired; is($cache->read('keep'),'peek','still here'); undef $found; is($cache->read('keep'),undef,'really expired'); unlink $fname; Cache-Mmap-0.11/t/04utf8.t0000644001163000001440000000241011001061370013473 0ustar pmhusers# Test that UTF8 values are read/written correctly # $Id: 04utf8.t,v 1.3 2003/06/17 18:10:55 pmh Exp $ use Test::More; BEGIN{ # Should use C here, but ancient Test::More doesn't like it if($^V){ Test::More->import(tests => 13); }else{ Test::More->import(skip_all => 'Test irrelevant without utf8 support'); } use_ok('Cache::Mmap'); } use strict; chdir 't' if -d 't'; my $fname='utf8.cmm'; unlink $fname; ok(my $cache=Cache::Mmap->new($fname,{buckets => 1, strings => 1}), 'creating cache file'); ok($cache->write('abc','\x{1234}\x{4321}'), 'writing plain value'); is($cache->read('abc'),'\x{1234}\x{4321}', 'reading plain value'); ok($cache->write('def',"\x{5678}\x{8765}"), 'writing utf8 value'); ok(scalar $cache->read('def') eq "\x{5678}\x{8765}", 'reading utf8 value'); ok($cache->write('ghi','\x{9abc}\x{cba9}'), 'writing post-utf8 plain value'); is($cache->read('ghi'),'\x{9abc}\x{cba9}', 'reading post-utf8 plain value'); is($cache->read('abc'),'\x{1234}\x{4321}', 'reading pre-utf8 plain value'); ok($cache->write("\x{1234}",'1234'), 'writing utf8 key'); is($cache->read("\x{1234}"),'1234', 'reading utf8 key'); ok($cache->write("\xff",'ffff'), 'writing 8 bit key'); is($cache->read("\xff"),'ffff', 'reading 8 bit key'); unlink $fname; Cache-Mmap-0.11/Todo0000644001163000001440000000160607751426454012700 0ustar pmhusers$Id: Todo,v 1.6 2003/11/03 10:25:48 pmh Exp $ clear(), like quick_clear(), but flushing dirty entries entry-specific expiry times (see differential-expiry) Untaint values read from file in _set_options() (see taint) Actually, only the header values should be untainted Cache entries should be tainted Make thread-safe Factor common code out of read() and write() Improve test suite Another good idea from Rob Mueller: > One thing I was wondering about your cache, whenever you access something, > it seems to move it to the front of the bucket. That's neat from a LRU > perspective, but couldn't you just use pointers or offsets or something > instead of having to move the whole data around each time you access it? Store pointer table at beginning of bucket, and just swap pointers Only move entries when deleting entries What about backwards compatibility? Will it need defragging? Cache-Mmap-0.11/Changes0000644001163000001440000000661011001074557013325 0ustar pmhusers$Id: Changes,v 1.10 2008/04/15 09:46:23 pmh Exp $ 2008-04-15 0.11 Doc fix: Add 0.10's changes to this list :-) 2008-04-15 0.11 Bug fix: Fix the perl version check to something which doesn't complain with 5.10 2005-11-15 0.09 Bug fix: Unlock the file before mmap(), as mandated by the spec Return useful values from XS Thanks to Janardhan Molumuri for being bitten by this, and for assistance in fixing it Minor documentation improvements 2004-03-15 0.081 Fix bug in t/03corrupt.t in the face of UTF8 locales Escape non-printable characters in cmmtest 2003-10-30 0.08 Add CMM_keep_expired and CMM_keep_expired_refresh flags to enable temporary underlying data availability problems to be dealt with nicely Thanks to Jeffrey Friedl for the idea and initial implementation Document quick_clear() Commit all of the 0.07 changes to CVS (whoops, nearly lost them!) 2003-06-17 0.07 Fix test which got broken at the last minute before 0.06's release 2003-06-17 0.06 Deal with utf8 properly (and add t/04utf8.t) This changes the file format, so added format version number to file header Existing files which aren't cache files are not overwritten 2003-06-13 0.05_1 Add a check for super-sized entries (those which extend past the bucket end) Make zero-sized check message include cache filename and key Add t/03corrupt.t to check that the corruption checks are working 2002-08-28 0.05 Add the entries() method, suggested by Marc Kelly Actually, he wanted get_keys(), but this does more than that Remove the CDROM exception in the license The module is now completely Free, as in speech Remove a warning from the compilation stage Remove a potential warning in new() 2001-12-31 0.04 Fixed another serious bug in write(), which was introduced in the previous fix Move file locking into XS, so we don't need to know struct flock's layout Remove dependency on Mmap.pm by doing that in XS, too This means that it will compile on 5.6.0 without too many hassles Added a test suite (well, one file so far) This is how the new write() bug was caught. Yay, tests! 2001-12-28 0.03 Fixed serious bug in write(), which corrupted the cache file when replacing an already existing entry Thanks to Rob Mueller for the test case 2001-06-07 0.02 Fixed serious bug in read(), which didn't update the current bucket content size when expiring entries. This caused infinite loops in _find() and _insert(), which have also been fixed, should anything else ever go wrong in a similar way 2000-09-18 0.01, First release Only lock file header in _lock(0), rather than whole file Factor out code from read() and write() into _insert() Only delete clean items from underlying data in delete() Add documentation, including README 2000-08-25 0.00_05 Mostly finish write() Fix bug where 'use integer' interfered with safe bucketsize calculation 2000-07-13 0.00_04 Write pushed out items to underlying data when new items read in This caused the file format to change Add delete() Start work on write() 2000-07-13 0.00_03 Actually mmap the cache file! Attempt to write newly cached items (causing hangups) 2000-07-12 0.00_02 Start work on read() Add accessor methods for config options 2000-07-12 0.00_01 Actually add some code (new, _set_options, _lock, _unlock) Cache-Mmap-0.11/MANIFEST0000644001163000001440000000034007750256110013160 0ustar pmhusersChanges MANIFEST Makefile.PL Mmap.pm Mmap.xs README Todo cmmtest ppport.h t/01simple.t t/02entries.t t/03corrupt.t t/04utf8.t t/05keep.t typemap META.yml Module meta-data (added by MakeMaker) Cache-Mmap-0.11/Mmap.pm0000644001163000001440000006740111001074106013255 0ustar pmhusers# $Id: Mmap.pm,v 1.15 2008/04/15 09:41:26 pmh Exp $ =head1 NAME Cache::Mmap - Shared data cache using memory mapped files =head1 SYNOPSIS use Cache::Mmap; $cache=Cache::Mmap->new($filename,\%options); $val1=$cache->read($key1); $cache->write($key2,$val2); $cache->delete($key3); =head1 DESCRIPTION This module implements a shared data cache, using memory mapped files. If routines are provided which interact with the underlying data, access to the cache is completely transparent, and the module handles all the details of refreshing cache contents, and updating underlying data, if necessary. Cache entries are assigned to "buckets" within the cache file, depending on the key. Within each bucket, entries are stored approximately in order of last access, so that frequently accessed entries will move to the head of the bucket, thus decreasing access time. Concurrent accesses to the same bucket are prevented by file locking of the relevant section of the cache file. =cut package Cache::Mmap; # Do we need to worry about UTF-8? use constant has_utf8 => has_utf8 => $] >= 5.006_000; use Carp qw(croak); use DynaLoader(); use Exporter; use Fcntl; use IO::Seekable qw(SEEK_SET SEEK_END); use Storable qw(freeze thaw); use Symbol(); use integer; use strict; use vars qw( $VERSION @ISA @EXPORT_OK ); $VERSION='0.11'; @ISA=qw(DynaLoader Exporter); @EXPORT_OK=qw(CMM_keep_expired CMM_keep_expired_refresh); __PACKAGE__->bootstrap($VERSION); # Default cache options my %def_options=( buckets => 13, # Number of buckets bucketsize => 1024, # Size of each bucket pagesize => 1024, # Bucket alignment strings => 0, # Store strings, rather than refs expiry => 0, # Number of seconds to hold values, 0==forever context => undef, # Context to pass to read and write subs permissions => 0600, # Permissions for new file creation # read => sub called as ($found,$val)/$val=$read->($key,$context) cachenegative => 0, # true: Cache not-found values # false: Don't cache not-found values # write => sub called as $write->($key,$oval,$context) # Leave out for no writing to underlying data writethrough => 1, # true: Write when value is added to cache # false: Write when value expires or is pushed out # delete => sub called as $delete->($key,$oval,$context) # Leave out for no deleting of underlying data ); # Bit positions for cache-level flags use constant flag_strings => 0x0001; # Names for cache-level flags my %bool_opts=( strings => flag_strings, ); # Bit positions for element flags use constant elem_dirty => 0x0001; use constant magic => 0x15ACACE;# Cache file magic number use constant filevers => 1; # File format version number supported my $headsize=4*10; # File: magic, buckets, bucketsize, pagesize, flags, # file format version my $bheadsize=4*10; # Bucket: filled my $eheadsize=4*10; # Element: size, time, klen, vlen, flags my $maxheadsize=$headsize > $bheadsize ? $headsize : $bheadsize; $maxheadsize=$eheadsize if $eheadsize > $maxheadsize; # While these look random, the low word could be a bitmask use constant CMM_keep_expired => 0xCACE0001; # Keep the expired value use constant CMM_keep_expired_refresh => 0xCACE0003; # Keep the expired value, and unexpire it =head1 CLASS METHODS =over =item new($filename,\%options) Creates a new cache object. If the file named by C<$filename> does not already exist, it will be created. If the cache object cannot be created for any reason, an exception will be thrown. Various options may be set in C<%options>, which affect the behaviour of the cache (defaults in parentheses): =over 4 =item permissions (0600) Sets the file permissions for the cache file if it doesn't already exist. =item buckets (13) Sets the number of buckets inside the cache file. A larger number of buckets will give better performance for a cache with many accesses, as there will be less chance of concurrent access to the same bucket. =item bucketsize (1024) Sets the size of each bucket, in bytes. A larger bucket size will be needed to store large cache entries. If the bucketsize is not large enough to hold a particular entry, it will still be passed between the underlying data and the application in its entirety, but will not be stored in the cache. =item pagesize (1024) Sets the alignment of buckets within the file. The file header will be extended to this size, and bucket sizes will be rounded up to the nearest multiple. Choosing a pagesize equal to the virtual memory page size of the host system should improve performance. =item strings (0) If true, cache entries are treated as strings, rather than references. This will help performance for string-only caches, as no time will be taken to serialize cache entries. =item expiry (0) If non-zero, sets the length of time, in seconds, which cache entries are considered valid. A new entry will be fetched from the underlying data if an expired cache entry would otherwise have been returned. =item context (undef) This value is passed to the read/write/delete routines below, to provide context. This will typically be a database handle, used to fetch data from. =item read (undef) Provides a code reference to a routine which will fetch entries from the underlying data. Called as C<$read-E($key,$context)>, this routine should return a list C<($found,$value)>, where C<$found> is true if the entry could be found in the underlying data, and C<$value> is the value to cache. If the routine only returns a single scalar, that will be taken as the value, and C<$found> will be set to true if the value is defined. If this routine is not provided, only values already in the cache will ever be returned. There are currently two special values of C<$found> which cause slightly different behaviour. These are constants which may be imported in the C statement. =over 4 =item C Use the previously cached value, even if it has expired. This is useful if the underlying data source has become unavailable for some reason. Note that even though the value returned will be ignored in this case, it must be returned to avoid C<$found> being interpreted as a single scalar: return (Cache::Mmap::CMM_keep_expired, undef); =item C This causes the same behaviour as C, but the cache entry's expiry time will be reset as if a value had been successfully read from the underlying data. =back =item cachenegative (0) If true, even unsuccessful fetches from the underlying data are cached. This can be useful to only search the underlying data once for each required key. =item write (undef) Provides a code reference to a routine which will write cache entries into the underlying data. This routine will be called by write(), to synchronise the underlying data with the cache. Called as C<$write-E($key,$val,$context)>. If the routine is not provided, the underlying data will not be synchronised after cache writes. =item writethrough (1) If true, the C routine above will be called as soon as write() is called. This provides immediate synchronisation of underlying data and cache contents. If false, the C routine will be called for each cache entry which no longer fits in its bucket after a cache read or write. This provides a write-as-necessary behaviour, which may be more efficient than the writethrough behaviour. However, only data fetched through the cache will reflect these changes. =item delete (undef) Provides a code reference to a routine which will delete items from the underlying data. This routine will be called by delete(), to synchronise the underlying data with the cache. Called as C<$delete-E($key,$cval,$context)>, where C<$cval> is the value currently stored in the cache. If this routine is not provided, entries deleted from the cache have no effect on the underlying data. =back An alternative to supplying a C routine, is to call delete() after updating the underlying data. Note however, that in the case of databases, this should be done after committing the update, so that a concurrent process doesn't reload the cache between being the entry being deleted, and the database updates being committed. =cut sub new{ my($class,$filename,$options)=@_; my $self={ %def_options, %{$options || {}}, }; # Check options for sensible values foreach(qw(buckets bucketsize pagesize permissions)){ defined($self->{$_}) && $self->{$_}=~/^[1-9]\d*$/s or croak "'$_' option for $class must be a positive integer"; } $self->{pagesize}>=$maxheadsize or croak "'pagesize' option for $class must be at least $maxheadsize"; foreach(qw(read write delete)){ !$self->{$_} || ref $self->{$_} eq 'CODE' or croak "'$_' option for $class must be a CODE ref or empty"; } # Align bucketsize { no integer; my $n_pages=$self->{bucketsize}/$self->{pagesize}; if((my $i_pages=int $n_pages)!=$n_pages){ $self->{bucketsize}=($i_pages+1)*$self->{pagesize}; } } # Try to open a file my $fh=Symbol::gensym; sysopen($fh,$filename,O_RDWR|O_CREAT,$self->{permissions}) or croak "Can't open cache file $filename: $!"; # Create cache object bless $self,$class; $self->{_filename}=$filename; $self->{_fh}=$fh; # Set options $self->_set_options; $self; } =back =head1 METHODS =head2 CACHE DATA METHODS These are the everyday methods used to access the data stored by the cache. =over 4 =item read($key) Reads an entry from the cache, or from the underlying data if not cached. Returns the value in scalar context, and C<($found,$value)> in list context, where C<$found> is true if the item was found in either the cache or the underlying data. =cut sub read{ my($self,$key)=@_; my $bucket=$self->_bucket($key); my $ekey=$self->_encode($key,1); # Lock the bucket. This is a write lock, even for reading, since we may # move items within the bucket $self->_lock($bucket); my($found,$val,$err); eval{ local $SIG{__DIE__}; ($found,my($expired,$poff,$off,$size,$klen,$vlen,$flags)) =$self->_find($bucket,$key); # We need to read a new value if we don't have a value, # or if that value is expired. my ($new_found, $new_val); if (!$found or $expired) { my @_read=$self->{read} ? $self->{read}->($key,$self->{context}) : (); ($new_found,$new_val)=@_read==1 ? (defined($_read[0]),$_read[0]) : @_read; $new_found=0 if !defined $new_found; undef $new_val unless $new_found; if($new_found==CMM_keep_expired){ # Use the old value, even though it's expired $found=$expired; $expired=0; $new_found=0; }elsif($new_found==CMM_keep_expired_refresh){ # Use the old value, and update its time so it's not expired anymore $found=$expired; $expired=0; $new_found=0; # Modify the time field in a hideously unmaintainable way substr($self->{_mmap},$off+4,4)=pack 'l',time if $found; } } if($found){{ # Remove expired item, and pretend we didn't find it # XXX What about dirty expired items??? if($expired && !($flags & elem_dirty)){ # No need to write underlying data, because it's not dirty my $b_end=$bucket+$self->{bucketsize}; substr($self->{_mmap},$off,$b_end-$off) =substr($self->{_mmap},$off+$size,$b_end-$off-$size).("\0" x $size); my($filled)=unpack 'l',substr($self->{_mmap},$bucket,$bheadsize); $filled-=$size; substr($self->{_mmap},$bucket,$bheadsize) =substr(pack("lx$bheadsize",$filled),0,$bheadsize); $found=0; # it's expired, so pretend we didn't find anything last; } # Swap with previous item unless at head of bucket if($poff){ my $psize=$off-$poff; substr($self->{_mmap},$poff,$psize+$size) =substr($self->{_mmap},$off,$size) .substr($self->{_mmap},$poff,$psize); $off=$poff; } $val=$self->_decode(substr($self->{_mmap},$off+$eheadsize+$klen,$vlen),0); }} if(!$found){ # go ahead and use the new data, read above ($found,$val)=($new_found,$new_val); # Store value in cache if($found || $self->{cachenegative}){ my $eval=$self->_encode($val,0); $self->_insert($bucket,$ekey,$eval,0); } } 1; } or $err=1; $self->_unlock; # Propagate errors die $@ if $err; return ($found,$val); } =item write($key,$val) Writes an entry into the cache, and depending on the configuration, into the underlying data. =cut sub write{ my($self,$key,$val)=@_; my $ekey=$self->_encode($key,1); my $klen=length $ekey; my $eval=$self->_encode($val,0); my $vlen=length $eval; my $size=$eheadsize+$klen+$vlen; my $bsize=$self->{bucketsize}-$bheadsize; if($size<=$bsize){ # The item will fit in a cache bucket, so store it my $bucket=$self->_bucket($key); $self->_lock($bucket); my $err; eval{ local $SIG{__DIE__}; my($found,$expired,$poff,$off,$_size,$_klen,$_vlen,$flags) =$self->_find($bucket,$key); # Remove the old version if($found){ my($filled)=unpack 'l',substr($self->{_mmap},$bucket,$bheadsize); my $pre=substr $self->{_mmap}, $bucket+$bheadsize,$off-($bucket+$bheadsize); my $post=substr $self->{_mmap}, $off+$_size,$bucket+$bheadsize+$filled-$off-$_size; my $new_filled=length($pre.$post); my $bhead=substr(pack("lx$bheadsize",$new_filled),0,$bheadsize); substr($self->{_mmap},$bucket,$bheadsize+$new_filled) =$bhead.$pre.$post; } # Generate new bucket contents $self->_insert($bucket,$ekey,$eval,1); # Write to underlying data if($self->{writethrough} and my $write=$self->{write}){ $write->($key,$val,$self->{context}); } 1; } or $err=1; $self->_unlock; die $@ if $err; }elsif(my $wsub=$self->{write}){ # It won't fit in a cache bucket, but we can update the underlying data $self->delete($key); $wsub->($key,$val,$self->{context}); }else{ # It won't fit, and we can't update the data # XXX Should we blow up here? # Probably not, since an item may be removed from the cache at any time } 1; } =item delete($key) Deletes an entry from the cache, and depending on C options, from the underlying data. Returns the value in scalar context, and C<($found,$value)> in list context, where C<$found> is true if the item was found in the cache. =cut sub delete{ my($self,$key)=@_; my $bucket=$self->_bucket($key); # Lock the bucket $self->_lock($bucket); my($found,$val,$err); eval{ local $SIG{__DIE__}; ($found,my($expired,$poff,$off,$size,$klen,$vlen,$flags)) =$self->_find($bucket,$key); if($found){ $val=$self->_decode(substr($self->{_mmap},$off+$eheadsize+$klen,$vlen),0); if(my $dsub=$self->{delete} and !($flags & elem_dirty)){ $dsub->($key,$val,$self->{context}); } my($filled)=unpack 'l',substr($self->{_mmap},$bucket,$bheadsize); my $new_filled=$filled-$size; substr($self->{_mmap},$bucket,$bheadsize) =substr(pack("lx$bheadsize",$new_filled),0,$bheadsize); my $fill_end=$bucket+$bheadsize+$filled; my $elem_end=$off+$size; substr($self->{_mmap},$off,$fill_end-$elem_end) =substr($self->{_mmap},$elem_end,$fill_end-$elem_end); } 1; } or $err=1; $self->_unlock; # Propagate errors die $@ if $err; return ($found,$val); } =item entries() =item entries(0) Returns a list of the keys of entries held in the cache. Note that this list may be immediately out of date, due to the shared nature of the cache. Entries may be added or removed by other processes between this list being generated and when it is used. =item entries(1) Returns a list of hashrefs representing entries held in the cache. The following keys are present in each hashref: key The key used to identify the entry time The time the entry was stored (seconds since the epoch) dirty Whether the entry needs writing to the underlying data The same caveat applies to the currency of this information as above. =item entries(2) As C, with the addition of a C element in each hashref, holding the value stored in the cache entry. =cut sub entries{ my($self,$details)=@_; $details=defined($details) && $details+0; my $buckets=$self->buckets; my $bucketsize=$self->bucketsize; my $pagesize=$self->pagesize; my $expiry=$self->expiry; my @entries; for(0..$buckets-1){ my $bucket=$pagesize+$bucketsize*$_; $self->_lock($bucket); my $err; eval{ local $SIG{__DIE__}; my($filled)=unpack 'l',substr($self->{_mmap},$bucket,$bheadsize); my $off=$bucket+$bheadsize; my $end=$off+$filled; my $size; while($off<$end){ ($size,my($time,$klen,$vlen,$flags)) =unpack 'l5',substr $self->{_mmap},$off,$eheadsize; if(!$size){ my $part=substr($self->{_mmap},$off,$end-$off); $part=~s/\\/\\\\/g; $part=~s/([^\040-\176])/sprintf '\\%02x',ord $1/ge; die "Zero-sized entry in $self->{_filename}, offset $off! Remaining bucket contents: $part"; } next if $expiry && time()-$time > $expiry; my $key=$self->_decode(substr($self->{_mmap},$off+$eheadsize,$klen),1); if($details){ push @entries,{ key => $key, 'time' => $time, dirty => $flags & elem_dirty, $details>1 ? ( value => $self->_decode( substr($self->{_mmap},$off+$eheadsize+$klen,$vlen),0 ), ) : (), }; }else{ push @entries,$key; } }continue{ $off+=$size; } 1; } or $err=1; $self->_unlock; die $@ if $err; } @entries; } =item quick_clear() Forcefully delete the cache, with prejudice. Unwritten dirty elements are B written back to the underlying data source; they are simply thrown away. =cut sub quick_clear{ my($self)=@_; $self->_lock(0) or croak "Can't lock cache file: $!"; my $err; eval{ local $SIG{__DIE__}; my $buckets=$self->buckets; my $bucketsize=$self->bucketsize; my $pagesize=$self->pagesize; my $empty="\0" x $bucketsize; for(0..$buckets-1){ substr($self->{_mmap},$pagesize+$bucketsize*$_,$bucketsize)=$empty; } 1; } or $err=1; $self->_unlock; die $@ if $err; } =back =head2 CONFIGURATION METHODS These methods are used to examine/update the configuration of a cache. Most of these methods are read-only, and the value returned may be different to that passed to the constructor, since the cache may have been created by an earlier process which specified different parameters. =over =item buckets() Returns the number of buckets in the cache file. =cut sub buckets{ my($self)=@_; $self->{buckets}; } =item bucketsize() Returns the size of buckets (in bytes) in the cache file. =cut sub bucketsize{ my($self)=@_; $self->{bucketsize}; } =item cachenegative() Returns true if items not found in the underlying data are cached anyway. =cut sub cachenegative{ my($self)=@_; $self->{cachenegative}; } =item context() Returns the context data for reads and writes to the underlying data. =item context($context) Provides new context data for reads and writes to the underlying data. =cut sub context{ my $self=shift; @_ ? ($self->{context}=$_[0]) : $self->{context}; } =item expiry() Returns the time in seconds cache entries are considered valid for, or zero for indefinite validity. =cut sub expiry{ my($self)=@_; $self->{expiry}; } =item pagesize() Returns the page size (in bytes) of the cache file. =cut sub pagesize{ my($self)=@_; $self->{pagesize}; } =item strings() Returns true if the cache stores strings rather than references. =cut sub strings{ my($self)=@_; $self->{strings}; } =item writethrough() Returns true if items written to the cache are immediately written to the underlying data. =cut sub writethrough{ my($self)=@_; $self->{writethrough}; } =back =begin private =head1 PRIVATE METHODS These methods are for internal use only, and are not for general consumption. =over =item _set_options() If the cache already exists, read its options. Otherwise, set them according to the values passed to the constructor. This method should only be called by the constructor. =cut sub _set_options{ my($self)=@_; # Lock file, so only one process sets the size $self->_lock(0) or croak "Can't lock cache file: $!"; my $err; eval{ local $SIG{__DIE__}; # If the file is big enough to contain a header, attempt to read one my $size_cur= -s $self->{_fh}; my $magic_ok; if($size_cur>=$headsize){ my $head; if((my $bytes=sysread($self->{_fh},$head,$headsize))!=$headsize){ croak "Expecting $headsize bytes, read $bytes from cache header\n"; } my($mg,$buckets,$bucketsize,$pagesize,$flags,$format)=unpack('l6',$head); $mg==magic or croak "$self->{_filename} is not a Cache::Mmap file"; ($format+=0)==filevers or croak "$self->{_filename} uses v$format data structures. Cache::Mmap $VERSION only supports v".filevers." data structures"; $self->{buckets}=$buckets; $self->{bucketsize}=$bucketsize; $self->{pagesize}=$pagesize; while(my($opt,$bit)=each %bool_opts){ $self->{$opt}=!!($flags&$bit); } $magic_ok=1; } # Make sure the file is big enough for the whole cache my $size=$self->{pagesize}+$self->{buckets}*$self->{bucketsize}; if($size_cur < $size){ my $pad="\0" x 1024; sysseek $self->{_fh},SEEK_END,0 or croak "Can't seek to end of file: $!\n"; while($size_cur < $size){ my $len=syswrite($self->{_fh},$pad,1024) or croak "Can't pad file: $!"; $size_cur+=$len; } -s $self->{_fh} >= $size or croak "Failed to set correct file size\n"; } # Write file header if it's not already done if(!$magic_ok){ my $flags=0; while(my($opt,$bit)=each %bool_opts){ $flags|=$bit if $self->{$opt}; } my $head=pack("l6x$headsize", magic,@$self{'buckets','bucketsize','pagesize'},$flags,filevers ); sysseek $self->{_fh},SEEK_SET,0 or croak "Can't seek to beginning: $!"; syswrite($self->{_fh},$head,$headsize)==$headsize or croak "Can't write file header: $!"; } # mmap() isn't supposed to work on locked files, so unlock $self->_unlock; mmap($self->{_mmap}='',$size,$self->{_fh}) or do{ delete $self->{_mmap}; croak "Can't mmap $self->{_filename}: $!"; }; length($self->{_mmap}) eq $size or do{ delete $self->{_mmap}; croak "mmap() failed silently: $!"; }; 1; } or $err=1; # Unlock file before returning $self->_unlock; # Propagate caught error if there was one die $@ if $err; } =item DESTROY() Unmap and close the file. =cut sub DESTROY{ my($self)=@_; munmap($self->{_mmap}) if exists $self->{_mmap}; close $self->{_fh}; } =item _lock($offset) Lock the cache file. If $offset is zero, the file header is locked. Otherwise, the bucket starting at $offset is locked. XXX This also needs to create an internal lock if threading is enabled. =cut sub _lock{ my($self,$offset)=@_; my $length=$offset ? $self->{bucketsize} : $headsize; _lock_xs($self->{_fh},$offset,$length,1); } =item _unlock() Unlocks the entire cache file. XXX This needs to unlock internal lock and take an offset arg if threading =cut sub _unlock{ my($self)=@_; _lock_xs($self->{_fh},0,0,0); } =item _insert($bucket,$ekey,$eval,$write) Inserts the key/value pair into the bucket. The item will be marked as dirty if $write is true, and writethrough() is false. =cut sub _insert{ my($self,$bucket,$ekey,$eval,$write)=@_; my $klen=length $ekey; my $vlen=length $eval; my $size=$eheadsize+$klen+$vlen; my $bsize=$self->{bucketsize}-$bheadsize; return if $size>$bsize; my $ehead=substr(pack("l5x$eheadsize", $size,time(),$klen,$vlen,($write && !$self->{writethrough} && elem_dirty), ),0,$eheadsize); my($filled)=unpack 'l',substr($self->{_mmap},$bucket,4); my $content=$ehead.$ekey.$eval .substr($self->{_mmap},$bucket+$bheadsize,$filled); $filled=length $content; # Trim down to fit into bucket if($filled > $bsize){ # Find all items which fit in the bucket my $poff=my $off=$size; while($off<=$bsize){ $poff=$off; last if $poff>=$filled; my($size)=unpack 'l',substr($content,$off,4); $off+=$size; } # Write remaining items back to underlying data if dirty if(my $wsub=$self->{write} && !$self->{writethrough}){ for($off=$poff;$off<$filled;){ my($size,$time,$vlen,$klen,$flags) =unpack 'l5',substr($content,$off,$eheadsize); if(!$size){ my $part=substr($content,$off,length($content)-$off); my $off=$bucket+$off; $part=~s/\\/\\\\/g; $part=~s/([^\040-\176])/sprintf '\\%02x',ord $1/ge; die "Zero-size entry in $self->{_filename}, offset $off! [ekey=$ekey] Remaining bucket contents: $part"; return; } if($flags & elem_dirty){ my $key=$self->_decode(substr($content,$off+$eheadsize,$klen),1); my $val=$self->_decode( substr($content,$off+$eheadsize+$klen,$vlen),0); $wsub->($key,$val,$self->{content}); } $off+=$size; } } # Remove dead items $filled=$poff; substr($content,$filled)=''; # Chop off the end of the string } # Write the bucket my $bhead=substr(pack("lx$bheadsize",$filled),0,$bheadsize); substr($self->{_mmap},$bucket,$bheadsize+$filled)=$bhead.$content; } =item _bucket($key) Returns the offset of the bucket which would hold $key. =cut sub _bucket{ my($self,$key)=@_; my $hash=0; while($key=~/(.)/gs){ $hash*=33; $hash+=ord $1; } my $bucket=do{ no integer; $hash % $self->{buckets}; }; return $self->{pagesize}+$bucket*$self->{bucketsize}; } =item _find($bucket,$key) Locate the item keyed by $key in the bucket starting at $bucket. Returns: ($found,$expired,$poff,$off,$size,$klen,$vlen,$flags) =cut sub _find{ my($self,$bucket,$key)=@_; my($filled)=unpack 'l',substr($self->{_mmap},$bucket,$bheadsize); my $off=$bucket+$bheadsize; my $end=$off+$filled; my $b_end=$bucket+$self->bucketsize; my($found,$size,$time,$klen,$vlen,$flags,$poff); while($off<$end){ if($off>=$b_end){ die "Super-sized entry in $self->{_filename}, offset $poff! [size=$size, finding key=$key]"; } ($size,$time,$klen,$vlen,$flags) =unpack 'l5',substr $self->{_mmap},$off,$eheadsize; if(!$size){ my $part=substr($self->{_mmap},$off,$end-$off); $part=~s/\\/\\\\/g; $part=~s/([^\040-\176])/sprintf '\\%02x',ord $1/ge; my $prev; if($poff){ $prev=" [poff=$poff]"; } local $^W; die "Zero-sized entry in $self->{_filename}, offset $off! [bucket=$bucket][key=$key]$prev Remaining bucket contents: $part"; } if($self->_decode(substr($self->{_mmap},$off+$eheadsize,$klen),1) eq $key){ $found=1; last; } $poff=$off; $off+=$size; } return unless $found; my $expired; if($found and my $exp=$self->expiry){ $expired=time-$time>$exp; } return ($found,$expired,$poff,$off,$size,$klen,$vlen,$flags); } =item _encode($value,$is_key) Encodes the given value into a string =cut sub _encode{ my($self,$value,$is_key)=@_; if(!defined $value){ return ''; }elsif($self->{strings} || $is_key){ if(has_utf8){ my $eval=pack 'a*',$value; if($eval eq $value){ return " $eval"; }else{ return "U$eval"; } }else{ return " $value"; } }else{ return ' '.freeze($value); } } =item _decode($value,$is_key) Decodes the given string value =cut sub _decode{ my($self,$value,$is_key)=@_; if($value eq ''){ return undef; }else{ $value=~s/^(.)//s; my $code=$1; if($code eq 'U'){ if(has_utf8){ utf8::decode($value); return $value; }else{ croak "UTF8 encoded value in $self->{_filename} detected\n"; } }elsif($self->{strings} || $is_key){ return $value; }else{ return thaw($value); } } } # Return true to require 1; =back =end private =head1 AUTHOR Copyright (C) Institute of Physics Publishing 2002-2008 Peter Haworth You may distribute under the terms of the GPL or the Artistic License, as distributed with Perl. Cache-Mmap-0.11/typemap0000644001163000001440000000001307414142116013423 0ustar pmhusersoff_t T_IV Cache-Mmap-0.11/Mmap.xs0000644001163000001440000000400110336424743013276 0ustar pmhusers/* All the mmap() stuff is copied from Malcolm Beattie's Mmap.pm */ #ifdef __cplusplus extern "C" { #endif #include "EXTERN.h" #include "perl.h" #include "XSUB.h" #ifdef __cplusplus } #endif #include #ifndef MMAP_RETTYPE # ifndef _POSIX_C_SOURCE # define _POSIX_C_SOURCE 199309 # endif # ifdef _POSIX_VERSION # if _POSIX_VERSION >= 199309 # define MMAP_RETTYPE void * # endif # endif #endif #ifndef MMAP_RETTYPE # define MMAP_RETTYPE caddr_t #endif #ifndef MAP_FAILED # define MAP_FAILED ((caddr_t)-1) #endif /* Required stuff for fcntl locking */ #include /* Stay backwards compatible */ #include "ppport.h" MODULE = Cache::Mmap PACKAGE = Cache::Mmap int mmap(var,len,fh) SV *var size_t len FILE *fh int fd = NO_INIT MMAP_RETTYPE addr = NO_INIT PROTOTYPE: $$$ CODE: /* XXX Use new perlio stuff to get fd */ fd=fileno(fh); addr=mmap(0,len,PROT_READ|PROT_WRITE,MAP_SHARED,fd,0); if(addr==MAP_FAILED){ RETVAL=0; }else{ SvUPGRADE(var,SVt_PV); SvPVX(var)=(char*)addr; SvCUR_set(var,len); SvLEN_set(var,0); SvPOK_only(var); RETVAL=1; } OUTPUT: RETVAL int munmap(var) SV *var PROTOTYPE: $ CODE: if(munmap((MMAP_RETTYPE)SvPVX(var),SvCUR(var))<0){ RETVAL=0; }else{ SvREADONLY_off(var); SvPVX(var)=0; SvCUR_set(var,0); SvLEN_set(var,0); SvOK_off(var); RETVAL=1; } OUTPUT: RETVAL int _lock_xs(fh,off,len,mode) FILE *fh off_t off size_t len int mode int fd = NO_INIT struct flock fl = NO_INIT PROTOTYPE: $$$$ CODE: /* XXX Use new perlio stuff to get fd */ fd=fileno(fh); fl.l_whence=SEEK_SET; fl.l_start=off; fl.l_len=len; fl.l_type=mode ? F_WRLCK : F_UNLCK; RETVAL=fcntl(fd,F_SETLKW,&fl)>=0; /* Define our own utf8::decode(), if we're on perl 5.6 */ MODULE = Cache::Mmap PACKAGE = utf8 #if (PERL_VERSION == 6) void decode(SV *str) PROTOTYPE: $ PPCODE: SV *sv=ST(0); int RETVAL; RETVAL=sv_utf8_decode(sv); ST(0)=boolSV(RETVAL); sv_2mortal(ST(0)); XSRETURN(1); #endif Cache-Mmap-0.11/Makefile.PL0000644001163000001440000000305111001061370013765 0ustar pmhusers################################################################################ # # File name: Makefile.PL # Project: Cache::Mmap # Description: Makefile creator # # Author: Peter Haworth # Date created: 28/06/2000 # # $Id: Makefile.PL,v 1.4 2003/06/13 16:21:49 pmh Exp $ # # Copyright Institute of Physics Publishing 2002 # You may distribute under the terms of the GPL or the Artistic License, # as distributed with Perl # ################################################################################ use ExtUtils::MakeMaker; use Config; use strict; warn "WARNING! I can't test for the existence of mmap() yet.\n"; warn " If your system does not provide mmap(), you will be unable\n"; warn " to compile this module.\n"; if($Config{d_fcntl} eq 'define'){ if($Config{d_fcntl_can_lock} eq 'define'){ # OK }else{ warn "WARNING! fcntl() on this system may be unable to lock files.\n"; warn " If so, you will be unable to compile this module.\n"; } }else{ warn "FATAL! This system does not provide fcntl().\n"; die " You will be unable to compile this module.\n"; } WriteMakefile( NAME => 'Cache::Mmap', VERSION_FROM => 'Mmap.pm', PREREQ_PM => { Fcntl => 0, Carp => 0, Storable => 0, 'Test::More' => 0, }, dist => { COMPRESS => 'gzip -9f', SUFFIX => 'gz', DIST_DEFAULT => 'all tardist', }, $ExtUtils::MakeMaker::VERSION >= 5.4301 ? ( ABSTRACT => "Shared cache using mmap'd file", AUTHOR => 'Peter Haworth (pmh@edison.ioppublishing.com)', ) : (), ); Cache-Mmap-0.11/README0000644001163000001440000000200511001074702012674 0ustar pmhusersThis module provides a shared cache, using a memory mapped file. Very useful for mod_perl applications. If routines are provided which interact with the underlying data, access to the cache is completely transparent, and the module handles all the details of refreshing cache contents, and updating underlying data, if necessary. Changes between versions 0.10 and 0.11 Add 0.10's changes to this list Changes between versions 0.09 and 0.10 Check perl's version number in a way that works on perl 5.10 Changes between versions 0.081 and 0.09 Behave correctly on systems which don't allow mmap()ing of locked files Minor documentation improvements INSTALLING What you need to install this module: Storable module Test::More module (only used during testing) How to install perl Makefile.PL make make install $Id: README,v 1.10 2008/04/15 09:47:46 pmh Exp $ Copyright (C) Institute of Physics Publishing 2002-2008 You may distribute under the terms of the GPL or the Artistic License, as distributed with Perl.