Cache-FastMmap-1.58/0000755000000000000000000000000015006062764012664 5ustar rootrootCache-FastMmap-1.58/META.json0000644000000000000000000000231115006062764014302 0ustar rootroot{ "abstract" : "Uses an mmap'ed file to act as a shared memory interprocess cache", "author" : [ "Rob Mueller " ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 7.64, CPAN::Meta::Converter version 2.150010", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : 2 }, "name" : "Cache-FastMmap", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "runtime" : { "requires" : { "Storable" : "0", "Test::Deep" : "0" } } }, "release_status" : "stable", "resources" : { "bugtracker" : { "web" : "https://github.com/robmueller/cache-fastmmap/issues" }, "repository" : { "url" : "https://github.com/robmueller/cache-fastmmap" } }, "version" : "1.58", "x_serialization_backend" : "JSON::PP version 4.07" } Cache-FastMmap-1.58/win32.c0000644000000000000000000001550615006060422013766 0ustar rootroot/* * AUTHOR * * Ash Berlin * * Based on code by * Rob Mueller * * COPYRIGHT AND LICENSE * * Copyright (C) 2007 by Ash Berlin * * This library is free software; you can redistribute it and/or modify * it under the same terms as Perl itself. * */ #include #include #include #include #include #include "mmap_cache.h" #include "mmap_cache_internals.h" #ifdef _MSC_VER #if _MSC_VER <= 1310 #define vsnprintf _vsnprintf #endif #endif char* _mmc_get_def_share_filename(mmap_cache * cache) { int ret; static char buf[MAX_PATH]; ret = GetTempPath(MAX_PATH, buf); if (ret > MAX_PATH) { _mmc_set_error(cache, GetLastError(), "Unable to get temp path"); return NULL; } return strcat(buf, "sharefile"); } int mmc_open_cache_file(mmap_cache* cache, int* do_init) { int i; void *tmp; HANDLE fh, fileMap, findHandle; WIN32_FIND_DATA statbuf; *do_init = 0; findHandle = FindFirstFile(cache->share_file, &statbuf); /* Create file if it doesn't exist */ if (findHandle == INVALID_HANDLE_VALUE) { fh = CreateFile(cache->share_file, GENERIC_WRITE, FILE_SHARE_WRITE, NULL, CREATE_ALWAYS, FILE_ATTRIBUTE_TEMPORARY, NULL); if (fh == INVALID_HANDLE_VALUE) { _mmc_set_error(cache, GetLastError(), "Create of share file %s failed", cache->share_file); return -1; } /* Fill file with 0's */ tmp = calloc(1, cache->c_page_size); if (!tmp) { _mmc_set_error(cache, GetLastError(), "Calloc of tmp space failed"); return -1; } for (i = 0; i < cache->c_num_pages; i++) { DWORD tmpOut; WriteFile(fh, tmp, cache->c_page_size, &tmpOut, NULL); } free(tmp); /* Later on initialise page structures */ *do_init = 1; CloseHandle(fh); } else { FindClose(findHandle); if (cache->init_file || (statbuf.nFileSizeLow != cache->c_size)) { *do_init = 1; fh = CreateFile(cache->share_file, GENERIC_WRITE, FILE_SHARE_WRITE, NULL, CREATE_ALWAYS, FILE_ATTRIBUTE_TEMPORARY, NULL); if (fh == INVALID_HANDLE_VALUE) { _mmc_set_error(cache, GetLastError(), "Truncate of existing share file %s failed", cache->share_file); return -1; } CloseHandle(fh); } } fh = CreateFile(cache->share_file, // File Name GENERIC_READ|GENERIC_WRITE, // Desired Access FILE_SHARE_READ|FILE_SHARE_WRITE, // Share mode NULL, // Security Rights OPEN_EXISTING, // Creation Mode FILE_ATTRIBUTE_TEMPORARY, // File Attribs NULL); // Template File if (fh == INVALID_HANDLE_VALUE) { _mmc_set_error(cache, GetLastError(), "Open of share file \"%s\" failed", cache->share_file); return -1; } cache->fh = fh; return 0; } int mmc_map_memory(mmap_cache * cache) { HANDLE fileMap = CreateFileMapping(cache->fh, NULL, PAGE_READWRITE, 0, cache->c_size, NULL); if (fileMap == NULL) { _mmc_set_error(cache, GetLastError(), "CreateFileMapping of %s failed", cache->share_file); CloseHandle(cache->fh); return -1; } cache->mm_var = MapViewOfFile(fileMap, FILE_MAP_WRITE|FILE_MAP_READ, 0,0,0); if (cache->mm_var == NULL) { _mmc_set_error(cache, GetLastError(), "Mmap of shared file %s failed", cache->share_file); CloseHandle(fileMap); CloseHandle(cache->fh); return -1; } /* If I read the docs right, this will do nothing untill the mm_var is unmapped */ if (CloseHandle(fileMap) == FALSE) { _mmc_set_error(cache, GetLastError(), "CloseHandle(fileMap) on shared file %s failed", cache->share_file); UnmapViewOfFile(cache->mm_var); CloseHandle(fileMap); CloseHandle(cache->fh); return -1; } return 0; } int mmc_check_fh(mmap_cache* cache) { return 1; } int mmc_close_fh(mmap_cache* cache) { int ret = CloseHandle(cache->fh); cache->fh = NULL; return ret; } int mmc_unmap_memory(mmap_cache* cache) { int res = UnmapViewOfFile(cache->mm_var); if (res == -1) { _mmc_set_error(cache, GetLastError(), "Unmmap of shared file %s failed", cache->share_file); } return res; } int mmc_lock_page(mmap_cache* cache, MU64 p_offset) { OVERLAPPED lock; DWORD lock_res, bytesTransfered; memset(&lock, 0, sizeof(lock)); lock.Offset = (DWORD)(p_offset & 0xffffffff); lock.OffsetHigh = (DWORD)((p_offset >> 32) & 0xffffffff); lock.hEvent = CreateEvent(NULL, TRUE, FALSE, NULL); if (LockFileEx(cache->fh, 0, 0, cache->c_page_size, 0, &lock) == 0) { _mmc_set_error(cache, GetLastError(), "LockFileEx failed"); return -1; } lock_res = WaitForSingleObjectEx(lock.hEvent, 10000, FALSE); if (lock_res != WAIT_OBJECT_0 || GetOverlappedResult(cache->fh, &lock, &bytesTransfered, FALSE) == FALSE) { CloseHandle(lock.hEvent); _mmc_set_error(cache, GetLastError(), "Overlapped Lock failed"); return -1; } return 0; } int mmc_unlock_page(mmap_cache* cache) { OVERLAPPED lock; memset(&lock, 0, sizeof(lock)); lock.Offset = cache->p_offset; lock.hEvent = 0; UnlockFileEx(cache->fh, 0, cache->c_page_size, 0, &lock); /* Set to bad value while page not locked */ cache->p_cur = NOPAGE; } /* * int _mmc_set_error(mmap_cache *cache, int err, char * error_string, ...) * * Set internal error string/state * */ int _mmc_set_error(mmap_cache *cache, int err, char * error_string, ...) { va_list ap; static char errbuf[1024]; char *msgBuff; va_start(ap, error_string); /* Make sure it's terminated */ errbuf[1023] = '\0'; /* Start with error string passed */ vsnprintf(errbuf, 1023, error_string, ap); /* Add system error code if passed */ if (err) { strncat(errbuf, ": ", 1023); FormatMessage( FORMAT_MESSAGE_ALLOCATE_BUFFER | FORMAT_MESSAGE_FROM_SYSTEM, NULL, err, MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), (LPTSTR) &msgBuff, 0, NULL ); strncat(errbuf, msgBuff, 1023); LocalFree(msgBuff); } /* Save in cache object */ cache->last_error = errbuf; va_end(ap); return -1; } Cache-FastMmap-1.58/FastMmap.xs0000644000000000000000000002600515006061651014745 0ustar rootroot#include "EXTERN.h" #include "perl.h" #include "XSUB.h" #include "ppport.h" #include "mmap_cache.h" #define FC_UTF8VAL (1<<31) #define FC_UTF8KEY (1<<30) #define FC_UNDEF (1<<29) #define FC_ENTRY \ mmap_cache * cache; \ if (!SvROK(obj)) { \ croak("Object not reference"); \ XSRETURN_UNDEF; \ } \ obj = SvRV(obj); \ if (!SvIOKp(obj)) { \ croak("Object not initialised correctly"); \ XSRETURN_UNDEF; \ } \ cache = INT2PTR(mmap_cache *, SvIV(obj) ); \ if (!cache) { \ croak("Object not created correctly"); \ XSRETURN_UNDEF; \ } MODULE = Cache::FastMmap PACKAGE = Cache::FastMmap PROTOTYPES: ENABLE SV * fc_new() INIT: mmap_cache * cache; SV * obj_pnt, * obj; CODE: cache = mmc_new(); /* Create integer which is pointer to cache object */ obj_pnt = newSViv(PTR2IV(cache)); /* Create reference to integer value. This will be the object */ obj = newRV_noinc((SV *)obj_pnt); RETVAL = obj; OUTPUT: RETVAL NO_OUTPUT int fc_set_param(obj, param, val) SV * obj; char * param; char * val; INIT: FC_ENTRY CODE: RETVAL = mmc_set_param(cache, param, val); POSTCALL: if (RETVAL != 0) { croak("%s", mmc_error(cache)); } NO_OUTPUT int fc_init(obj) SV * obj; INIT: FC_ENTRY CODE: RETVAL = mmc_init(cache); POSTCALL: if (RETVAL != 0) { croak("%s", mmc_error(cache)); } void fc_close(obj) SV * obj INIT: FC_ENTRY CODE: mmc_close(cache); sv_setiv(obj, 0); void fc_hash(obj, key); SV * obj; SV * key; INIT: int key_len; void * key_ptr; MU32 hash_page, hash_slot; STRLEN pl_key_len; FC_ENTRY PPCODE: /* Get key length, data pointer */ key_ptr = (void *)SvPV(key, pl_key_len); key_len = (int)pl_key_len; /* Hash key to get page and slot */ mmc_hash(cache, key_ptr, key_len, &hash_page, &hash_slot); XPUSHs(sv_2mortal(newSViv((IV)hash_page))); XPUSHs(sv_2mortal(newSViv((IV)hash_slot))); NO_OUTPUT int fc_lock(obj, page); SV * obj; UV page; INIT: FC_ENTRY CODE: RETVAL = mmc_lock(cache, (MU32)page); POSTCALL: if (RETVAL != 0) { croak("%s", mmc_error(cache)); } NO_OUTPUT int fc_unlock(obj); SV * obj; INIT: FC_ENTRY CODE: RETVAL = mmc_unlock(cache); POSTCALL: if (RETVAL != 0) { croak("%s", mmc_error(cache)); } int fc_is_locked(obj) SV * obj; INIT: FC_ENTRY CODE: /* Write value to cache */ RETVAL = mmc_is_locked(cache); OUTPUT: RETVAL void fc_read(obj, hash_slot, key) SV * obj; U32 hash_slot; SV * key; INIT: int key_len, val_len, found; void * key_ptr, * val_ptr; MU32 expire_on = 0; MU32 flags = 0; STRLEN pl_key_len; SV * val; FC_ENTRY PPCODE: /* Get key length, data pointer */ key_ptr = (void *)SvPV(key, pl_key_len); key_len = (int)pl_key_len; /* Get value data pointer */ found = mmc_read(cache, (MU32)hash_slot, key_ptr, key_len, &val_ptr, &val_len, &expire_on, &flags); /* If not found, use undef */ if (found == -1) { val = &PL_sv_undef; } else { /* Cached an undef value? */ if (flags & FC_UNDEF) { val = &PL_sv_undef; } else { /* Create PERL SV */ val = sv_2mortal(newSVpvn((const char *)val_ptr, val_len)); /* Make UTF8 if stored from UTF8 */ if (flags & FC_UTF8VAL) { SvUTF8_on(val); } } flags = flags & ~(FC_UTF8KEY | FC_UTF8VAL | FC_UNDEF); } XPUSHs(val); XPUSHs(sv_2mortal(newSViv((IV)flags))); XPUSHs(sv_2mortal(newSViv((IV)!found))); XPUSHs(sv_2mortal(newSViv((IV)expire_on))); int fc_write(obj, hash_slot, key, val, expire_on, in_flags) SV * obj; U32 hash_slot; SV * key; SV * val; U32 expire_on; U32 in_flags; INIT: int key_len, val_len; void * key_ptr, * val_ptr; STRLEN pl_key_len, pl_val_len; FC_ENTRY CODE: /* Get key length, data pointer */ key_ptr = (void *)SvPV(key, pl_key_len); key_len = (int)pl_key_len; /* Check for storing undef, and store empty string with undef flag set */ if (!SvOK(val)) { in_flags |= FC_UNDEF; val_ptr = ""; val_len = 0; } else { /* Get key length, data pointer */ val_ptr = (void *)SvPV(val, pl_val_len); val_len = (int)pl_val_len; /* Set UTF8-ness flag of stored value */ if (SvUTF8(val)) { in_flags |= FC_UTF8VAL; } if (SvUTF8(key)) { in_flags |= FC_UTF8KEY; } } /* Write value to cache */ RETVAL = mmc_write(cache, (MU32)hash_slot, key_ptr, key_len, val_ptr, val_len, (MU32)expire_on, (MU32)in_flags); OUTPUT: RETVAL int fc_delete(obj, hash_slot, key) SV * obj; U32 hash_slot; SV * key; INIT: MU32 out_flags; int key_len, did_delete; void * key_ptr; STRLEN pl_key_len; FC_ENTRY PPCODE: /* Get key length, data pointer */ key_ptr = (void *)SvPV(key, pl_key_len); key_len = (int)pl_key_len; /* Write value to cache */ did_delete = mmc_delete(cache, (MU32)hash_slot, key_ptr, key_len, &out_flags); XPUSHs(sv_2mortal(newSViv((IV)did_delete))); XPUSHs(sv_2mortal(newSViv((IV)out_flags))); void fc_get_page_details(obj) SV * obj; INIT: MU32 nreads = 0, nreadhits = 0; FC_ENTRY PPCODE: mmc_get_page_details(cache, &nreads, &nreadhits); XPUSHs(sv_2mortal(newSViv((IV)nreads))); XPUSHs(sv_2mortal(newSViv((IV)nreadhits))); NO_OUTPUT void fc_reset_page_details(obj) SV * obj; INIT: FC_ENTRY CODE: mmc_reset_page_details(cache); void fc_expunge(obj, mode, wb, len) SV * obj; int mode; int wb; int len; INIT: MU32 new_num_slots = 0, ** to_expunge = 0; int num_expunge, item; void * key_ptr, * val_ptr; int key_len, val_len; MU32 last_access, expire_on, flags; FC_ENTRY PPCODE: num_expunge = mmc_calc_expunge(cache, mode, len, &new_num_slots, &to_expunge); if (to_expunge) { /* Want list of expunged keys/values? */ if (wb) { for (item = 0; item < num_expunge; item++) { mmc_get_details(cache, to_expunge[item], &key_ptr, &key_len, &val_ptr, &val_len, &last_access, &expire_on, &flags); { HV * ih = (HV *)sv_2mortal((SV *)newHV()); SV * key = newSVpvn((const char *)key_ptr, key_len); SV * val; if (flags & FC_UTF8KEY) { SvUTF8_on(key); flags ^= FC_UTF8KEY; } if (flags & FC_UNDEF) { val = newSV(0); flags ^= FC_UNDEF; } else { val = newSVpvn((const char *)val_ptr, val_len); if (flags & FC_UTF8VAL) { SvUTF8_on(val); flags ^= FC_UTF8VAL; } } /* Store in hash ref */ hv_store(ih, "key", 3, key, 0); hv_store(ih, "value", 5, val, 0); hv_store(ih, "last_access", 11, newSViv((IV)last_access), 0); hv_store(ih, "expire_on", 9, newSViv((IV)expire_on), 0); hv_store(ih, "flags", 5, newSViv((IV)flags), 0); /* Create reference to hash */ XPUSHs(sv_2mortal(newRV((SV *)ih))); } } } if (!mmc_do_expunge(cache, num_expunge, new_num_slots, to_expunge)) { croak("%s", mmc_error(cache)); XSRETURN_UNDEF; } } void fc_get_keys(obj, mode) SV * obj; int mode; INIT: mmap_cache_it * it; MU32 * entry_ptr; void * key_ptr, * val_ptr; int key_len, val_len; MU32 last_access, expire_on, flags; FC_ENTRY PPCODE: it = mmc_iterate_new(cache); /* Iterate over all items */ while ((entry_ptr = mmc_iterate_next(it))) { SV * key; mmc_get_details(cache, entry_ptr, &key_ptr, &key_len, &val_ptr, &val_len, &last_access, &expire_on, &flags); /* Create key SV, and set UTF8'ness if needed */ key = newSVpvn((const char *)key_ptr, key_len); if (flags & FC_UTF8KEY) { SvUTF8_on(key); flags ^= FC_UTF8KEY; } /* Mode 0 is just list of keys */ if (mode == 0) { XPUSHs(sv_2mortal(key)); /* Mode 1/2 is list of hash-refs */ } else if (mode == 1 || mode == 2) { HV * ih = (HV *)sv_2mortal((SV *)newHV()); /* These things by default */ hv_store(ih, "key", 3, key, 0); hv_store(ih, "last_access", 11, newSViv((IV)last_access), 0); hv_store(ih, "expire_on", 9, newSViv((IV)expire_on), 0); hv_store(ih, "flags", 5, newSViv((IV)flags), 0); /* Add value to hash-ref if mode 2 */ if (mode == 2) { SV * val; if (flags & FC_UNDEF) { val = newSV(0); flags ^= FC_UNDEF; } else { val = newSVpvn((const char *)val_ptr, val_len); if (flags & FC_UTF8VAL) { SvUTF8_on(val); flags ^= FC_UTF8VAL; } } hv_store(ih, "value", 5, val, 0); } /* Create reference to hash */ XPUSHs(sv_2mortal(newRV((SV *)ih))); } } mmc_iterate_close(it); SV * fc_get(obj, key) SV * obj; SV * key; INIT: int key_len, val_len, found; void * key_ptr, * val_ptr; MU32 hash_page, hash_slot, expire_on, flags; STRLEN pl_key_len; SV * val; FC_ENTRY CODE: /* Get key length, data pointer */ key_ptr = (void *)SvPV(key, pl_key_len); key_len = (int)pl_key_len; /* Hash key to get page and slot */ mmc_hash(cache, key_ptr, key_len, &hash_page, &hash_slot); /* Get and lock the page */ mmc_lock(cache, hash_page); /* Get value data pointer */ found = mmc_read(cache, hash_slot, key_ptr, key_len, &val_ptr, &val_len, &expire_on, &flags); /* If not found, use undef */ if (found == -1) { val = &PL_sv_undef; } else { /* Create PERL SV */ val = newSVpvn((const char *)val_ptr, val_len); } mmc_unlock(cache); RETVAL = val; OUTPUT: RETVAL void fc_set(obj, key, val) SV * obj; SV * key; SV * val; INIT: int key_len, val_len; void * key_ptr, * val_ptr; MU32 hash_page, hash_slot, flags = 0; STRLEN pl_key_len, pl_val_len; FC_ENTRY CODE: /* Get key length, data pointer */ key_ptr = (void *)SvPV(key, pl_key_len); key_len = (int)pl_key_len; /* Get key length, data pointer */ val_ptr = (void *)SvPV(val, pl_val_len); val_len = (int)pl_val_len; /* Hash key to get page and slot */ mmc_hash(cache, key_ptr, key_len, &hash_page, &hash_slot); /* Get and lock the page */ mmc_lock(cache, hash_page); /* Get value data pointer */ mmc_write(cache, hash_slot, key_ptr, key_len, val_ptr, val_len, -1, flags); mmc_unlock(cache); NO_OUTPUT void fc_dump_page(obj); SV * obj; INIT: FC_ENTRY CODE: _mmc_dump_page(cache); NO_OUTPUT void fc_set_time_override(set_time); UV set_time; CODE: mmc_set_time_override((MU32)set_time); Cache-FastMmap-1.58/t/0000755000000000000000000000000015006062764013127 5ustar rootrootCache-FastMmap-1.58/t/5.t0000644000000000000000000000337115006056063013457 0ustar rootroot ######################### use Test::More tests => 9; BEGIN { use_ok('Cache::FastMmap') }; use strict; ######################### # Insert your test code below, the Test::More module is use()ed here so read # its man page ( perldoc Test::More ) for help writing this test script. # Test a backing store just made of a local hash my %BackingStore = ( foo => '123abc', bar => '456def' ); my %WrittenItems = %BackingStore; my $FC = Cache::FastMmap->new( serializer => '', init_file => 1, num_pages => 89, page_size => 2048, context => \%BackingStore, read_cb => sub { return $_[0]->{$_[1]}; }, write_cb => sub { $_[0]->{$_[1]} = $_[2]; }, delete_cb => sub { delete $_[0]->{$_[1]} }, write_action => 'write_through' ); ok( defined $FC ); srand(6543); # Put 3000 items in the cache for (1 .. 3000) { my ($Key, $Val) = (RandStr(10), RandStr(100)); $FC->set($Key, $Val); $WrittenItems{$Key} = $Val; } # Get values in cache my %CacheItems = map { $_->{key} => $_->{value} } $FC->get_keys(2); # Reality check approximate number of items in each ok( scalar(keys %BackingStore) == 3002, "backing store size 1" ); ok( scalar(keys %CacheItems) > 500, "backing store size 2" ); # Should be equal to all items we wrote ok( eq_hash(\%BackingStore, \%WrittenItems), "items match 1"); # Check we can get the items we wrote is( $FC->get('foo'), '123abc', "cb get 1"); is( $FC->get('bar'), '456def', "cb get 2"); # Read them forward and backward my $Failed = 0; for (keys %WrittenItems, reverse keys %WrittenItems) { $Failed++ if $FC->get($_) ne $WrittenItems{$_}; } ok( $Failed == 0, "got all written items" ); ok( eq_hash(\%WrittenItems, \%BackingStore), "items match 2"); sub RandStr { return join '', map { chr(ord('a') + rand(26)) } (1 .. $_[0]); } Cache-FastMmap-1.58/t/13.t0000644000000000000000000000502415006056063013533 0ustar rootrootuse strict; use warnings; use Test::More; use Data::Dumper; $Data::Dumper::Deparse = 1; BEGIN { note 'Compression testing'; use_ok('Cache::FastMmap'); } my %compressors = ( lz4 => 'Compress::LZ4', snappy => 'Compress::Snappy', zlib => 'Compress::Zlib', ); for my $compressor ( keys %compressors ) { note " Testing with $compressors{$compressor}"; # Avoid prototype mismatch warnings if ( ! eval "require $compressors{$compressor};" ) { note " Cannot load $compressors{$compressor}: skipping tests: reason: $@"; next; } my $FC = Cache::FastMmap->new( page_size => 8192, num_pages => 1, init_file => 1, serializer => '', compressor => $compressor ); ok( defined $FC, 'create compressing cache' ); my $FCNC = Cache::FastMmap->new( page_size => 8192, num_pages => 1, init_file => 1, serializer => '', ); ok( defined $FCNC, 'create non-compressing cache of same size' ); my $K1 = rand_str(10); my $K2 = rand_str(10); my $V = rand_str(10) x 1000; ok( $FC->set($K1, $V), 'set() with large value in compressing cache' ); ok( $FC->set($K2, $V), 'also set() same value with different key' ); ok( !$FCNC->set($K1, $V), 'cannot set() same value in non-compressing cache' ); ok( !$FCNC->set($K2, $V), 'also fail to set() with different key' ); my $CV1 = $FC->get($K1); my $CV2 = $FC->get($K2); is( $CV1, $V, 'get() same large value from compressing cache' ); is( $CV2, $V, 'also get() same value with second key used' ); $CV1 = $FCNC->get($K1); $CV2 = $FCNC->get($K2); ok( !defined $CV1, 'cannot get() anything from non-compressing cache' ); ok( !defined $CV2, 'also fail to get() with second key used' ); } note ' Check support for deprecated `compress` param'; for ( 1, 'Compress::NonExistent', 'Compress::LZ4' ) { my $DCNC = Cache::FastMmap->new( page_size => 8192, num_pages => 1, init_file => 1, serializer => '', compress => $_, ); ok( defined $DCNC, 'create cache with `compress` param: ' . $_ ); my $wanted1 = quotemeta('&$uncompress(my $Tmp = shift())'); # rt115043: older versions of Data::Dumper would output like below. my $wanted2 = quotemeta('&$uncompress(my $Tmp = shift @_)'); my $wanted = qr/$wanted1|$wanted2/; my $got = Dumper $DCNC->{uncompress}; like( $got, $wanted, 'using `Compress::Zlib` as compressor' ); } done_testing; sub rand_str { return join '', map { chr(rand(26) + ord('a')) } 1 .. int($_[0]); } __END__ Cache-FastMmap-1.58/t/14.t0000644000000000000000000000151215006056063013532 0ustar rootroot ######################### use Test::More tests => 110; BEGIN { use_ok('Cache::FastMmap') }; use strict; ######################### # Insert your test code below, the Test::More module is use()ed here so read # its man page ( perldoc Test::More ) for help writing this test script. my $FC = Cache::FastMmap->new( enable_stats => 1 ); ok( defined $FC ); ok( !defined $FC->get("a") ); $FC->set("a", "b"); ok( $FC->get("a") eq "b" ); # Get 100 times for (1 .. 100) { ok( $FC->get("a") eq "b" ); } my ($nreads, $nreadhits) = $FC->get_statistics(); cmp_ok( $nreads, '==', 102 ); cmp_ok( $nreadhits, '==', 101 ); ($nreads, $nreadhits) = $FC->get_statistics(1); cmp_ok( $nreads, '==', 102 ); cmp_ok( $nreadhits, '==', 101 ); ($nreads, $nreadhits) = $FC->get_statistics(1); cmp_ok( $nreads, '==', 0 ); cmp_ok( $nreadhits, '==', 0 ); Cache-FastMmap-1.58/t/20.t0000644000000000000000000000220115006056063013523 0ustar rootroot ######################### use Test::More; use strict; ######################### # Insert your test code below, the Test::More module is use()ed here so read # its man page ( perldoc Test::More ) for help writing this test script. if( $^O eq 'MSWin32' ) { plan skip_all => "permissions parameter is not supported on Windows"; } else { plan tests => 7; } require_ok('Cache::FastMmap'); my $old_umask = umask 0000; note( 'umask returns undef on this system, test results may not be reliable') unless defined $old_umask; my $FC = Cache::FastMmap->new(init_file => 1); ok( defined $FC ); my (undef, undef, $Mode) = stat($FC->{share_file}); $Mode = $Mode & 0777; is($Mode, 0640, "default persmissions 0640"); undef $FC; my $FC = Cache::FastMmap->new(init_file => 1, permissions => 0600); ok( defined $FC ); my (undef, undef, $Mode) = stat($FC->{share_file}); $Mode = $Mode & 0777; is($Mode, 0600, "can set to 0600"); undef $FC; my $FC = Cache::FastMmap->new(init_file => 1, permissions => 0666); ok( defined $FC ); my (undef, undef, $Mode) = stat($FC->{share_file}); $Mode = $Mode & 0777; is($Mode, 0666, "can set to 0666"); undef $FC; Cache-FastMmap-1.58/t/8.t0000644000000000000000000000263315006056063013462 0ustar rootroot ######################### use Test::More tests => 17; BEGIN { use_ok('Cache::FastMmap') }; use strict; ######################### # Insert your test code below, the Test::More module is use()ed here so read # its man page ( perldoc Test::More ) for help writing this test script. my $FC = Cache::FastMmap->new(init_file => 1); ok( defined $FC ); # Test empty cache ok( !defined $FC->get(''), "empty get('')" ); ok( $FC->set('123', 'abc'), "set('123', 'abc')" ); ok( $FC->get('123') eq 'abc', "get('123') eq 'abc'"); ok( $FC->set('123', undef), "set('123', undef)" ); ok( !defined $FC->get('123'), "!defined get('123')"); ok( $FC->set('123', [ 'abc' ]), "set('123', [ 'abc' ])" ); ok( eq_array($FC->get('123'), [ 'abc' ]), "get('123') eq [ 'abc' ]"); # Check UTF8 ok( $FC->set("key\x{263A}", [ "val\x{263A}" ]), "set utf8 key/val" ); ok( eq_array($FC->get("key\x{263A}"), [ "val\x{263A}" ]), "get utf8 key/val" ); is( join(",", sort $FC->get_keys), "123,key\x{263A}", "get_keys 1"); my %keys = map { $_->{key} => $_ } $FC->get_keys(2); is( scalar(keys %keys), 2, "get_keys 2" ); ok( eq_array($keys{123}->{value}, [ "abc" ]), "get_keys 3"); ok( eq_array($keys{"key\x{263A}"}->{value}, [ "val\x{263A}" ]), "get_keys 4"); # Check clearing actually works $FC->clear(); ok( !defined $FC->get('123'), "post clear 1" ); ok( !defined $FC->get("key\x{263A}"), "post clear 6" ); Cache-FastMmap-1.58/t/15.t0000644000000000000000000000252315006056063013536 0ustar rootroot ######################### use Test::More tests => 9; BEGIN { use_ok('Cache::FastMmap') }; use Data::Dumper; use strict; ######################### # Test writeback and cache_not_found option # Test a backing store just made of a local hash my %BackingStore = ( foo => { key1 => '123abc' }, bar => undef ); my %OrigBackingStore = %BackingStore; my $RCBCalled = 0; my $FC = Cache::FastMmap->new( cache_not_found => 1, init_file => 1, num_pages => 89, page_size => 1024, context => \%BackingStore, read_cb => sub { $RCBCalled++; return $_[0]->{$_[1]}; }, write_cb => sub { $_[0]->{$_[1]} = $_[2]; }, delete_cb => sub { delete $_[0]->{$_[1]} }, write_action => 'write_back' ); ok( defined $FC ); # Should pull from the backing store ok( eq_hash( $FC->get('foo'), { key1 => '123abc' } ), "cb get 1"); is( $FC->get('bar'), undef, "cb get 2"); is( $RCBCalled, 2, "cb get 2"); # Should be in the cache now ok( eq_hash( $FC->get('foo'), { key1 => '123abc' } ), "cb get 3"); is( $FC->get('bar'), undef, "cb get 4"); is( $RCBCalled, 2, "cb get 2"); # Need to make them dirty $FC->set('foo', { key1 => '123abc' }); $FC->set('bar', undef); # Should force cache data back to backing store %BackingStore = (); $FC->empty(); ok( eq_hash(\%BackingStore, \%OrigBackingStore), "items match 1" . Dumper(\%BackingStore, \%OrigBackingStore)); Cache-FastMmap-1.58/t/16.t0000644000000000000000000000140115006056063013531 0ustar rootroot ######################### use Test::More tests => 3; BEGIN { use_ok('Cache::FastMmap') }; use strict; ######################### # Insert your test code below, the Test::More module is use()ed here so read # its man page ( perldoc Test::More ) for help writing this test script. my $FC = Cache::FastMmap->new( init_file => 1, num_pages => 1, page_size => 2 ** 15, ); ok( defined $FC ); my @d; for (1 .. 20) { $FC->set($_, $d[$_]=$_) for 1 .. 100; for (1 .. 50) { $FC->remove($_*2); $d[$_*2] = undef; $FC->set($_, $_*2); $d[$_] = $_*2; for my $c (1 .. 100) { my $v = $FC->get($c); ($v || 0) == ($d[$c] || 0) || die "at offset $c, got $v expected $d[$c]"; } } } ok(1, "ordering santity tests complete"); Cache-FastMmap-1.58/t/10.t0000644000000000000000000000240715006056063013532 0ustar rootroot ######################### use Test::More tests => 9; BEGIN { use_ok('Cache::FastMmap') }; use Data::Dumper; use strict; ######################### # Test writeback and cache_not_found option # Test a backing store just made of a local hash my %BackingStore = ( foo => '123abc', bar => undef ); my %OrigBackingStore = %BackingStore; my $RCBCalled = 0; my $FC = Cache::FastMmap->new( cache_not_found => 1, serializer => '', init_file => 1, num_pages => 89, page_size => 1024, context => \%BackingStore, read_cb => sub { $RCBCalled++; return $_[0]->{$_[1]}; }, write_cb => sub { $_[0]->{$_[1]} = $_[2]; }, delete_cb => sub { delete $_[0]->{$_[1]} }, write_action => 'write_back' ); ok( defined $FC ); # Should pull from the backing store is( $FC->get('foo'), '123abc', "cb get 1"); is( $FC->get('bar'), undef, "cb get 2"); is( $RCBCalled, 2, "cb get 2"); # Should be in the cache now is( $FC->get('foo'), '123abc', "cb get 3"); is( $FC->get('bar'), undef, "cb get 4"); is( $RCBCalled, 2, "cb get 2"); $FC->set('foo', '123abc'); $FC->set('bar', undef); # Should force cache data back to backing store %BackingStore = (); $FC->empty(); ok( eq_hash(\%BackingStore, \%OrigBackingStore), "items match 1" . Dumper(\%BackingStore, \%OrigBackingStore)); Cache-FastMmap-1.58/t/23.t0000644000000000000000000000750615006056063013543 0ustar rootroot ######################### use Test::More tests => 27; use Test::Deep; BEGIN { use_ok('Cache::FastMmap') }; use Data::Dumper; use strict; ######################### # Test maintaining expire_on through get_and_set # Test a backing store just made of a local hash my %BackingStore = (); my $FC = Cache::FastMmap->new( serializer => '', init_file => 1, num_pages => 1, page_size => 8192, context => \%BackingStore, write_cb => sub { $_[0]->{$_[1]} = $_[2]; }, write_action => 'write_back', expire_time => 3, ); my $epoch = time; my $now = $epoch; Cache::FastMmap::_set_time_override($now); ok( defined $FC ); ok( $FC->set('foo', '123abc', 2), 'store item 1'); ok( $FC->set('bar', '456def', 3), 'store item 2'); ok( $FC->set('baz', '789ghi'), 'store item 3'); is( $FC->get('foo'), '123abc', "get item 1"); is( $FC->get('bar'), '456def', "get item 2"); is( $FC->get('baz'), '789ghi', "get item 3"); $now = $epoch+1; Cache::FastMmap::_set_time_override($now); sub cb { return ( (defined $_[1] ? $_[1] : 'boo') . 'a', { expire_on => $_[2]->{expire_on} }); }; sub cb2 { return ($_[1] . 'a'); }; is( $FC->get_and_set('foo', \&cb), '123abca', "get_and_set item 1 after sleep 1"); is( $FC->get_and_set('bar', \&cb), '456defa', "get_and_set item 2 after sleep 1"); is( $FC->get_and_set('baz', \&cb2), '789ghia', "get_and_set item 3 after sleep 1"); is( $FC->get_and_set('gah', \&cb), 'booa', "get_and_set item 4 after sleep 1"); my @e = $FC->get_keys(2); cmp_deeply( \@e, bag( superhashof({ key => 'foo', value => '123abca', last_access => num($now, 1), expire_on => num($now+1, 1) }), superhashof({ key => 'bar', value => '456defa', last_access => num($now, 1), expire_on => num($now+2, 1) }), superhashof({ key => 'baz', value => '789ghia', last_access => num($now, 1), expire_on => num($now+3, 1) }), superhashof({ key => 'gah', value => 'booa', last_access => num($now, 1), expire_on => num($now+3, 1) }), ), "got expected keys" ) || diag explain [ $now, \@e ]; $now = $epoch+2; Cache::FastMmap::_set_time_override($now); is( $FC->get('foo'), undef, "get item 1 after sleep 2"); is( $FC->get('bar'), '456defa', "get item 2 after sleep 2"); is( $FC->get('baz'), '789ghia', "get item 3 after sleep 2"); is( $FC->get_and_set('bar', \&cb), '456defaa', "get_and_set item 2 after sleep 2"); @e = $FC->get_keys(2); cmp_deeply( \@e, bag( superhashof({ key => 'bar', value => '456defaa', last_access => num($now, 1), expire_on => num($now+1, 1) }), superhashof({ key => 'baz', value => '789ghia', last_access => num($now, 1), expire_on => num($now+2, 1) }), superhashof({ key => 'gah', value => 'booa', last_access => num($now-1, 1), expire_on => num($now+2, 1) }), ), "got expected keys" ) || diag explain [ $now, \@e ]; $now = $epoch+3; Cache::FastMmap::_set_time_override($now); is( $FC->get('foo'), undef, "get item 1 after sleep 3"); is( $FC->get('bar'), undef, "get item 2 after sleep 3"); is( $FC->get('baz'), '789ghia', "get item 3 after sleep 3"); @e = $FC->get_keys(2); cmp_deeply( \@e, bag( superhashof({ key => 'baz', value => '789ghia', last_access => num($now, 1), expire_on => num($now+1, 1) }), superhashof({ key => 'gah', value => 'booa', last_access => num($now-2, 1), expire_on => num($now+1, 1) }), ), "got expected keys" ) || diag explain [ $now, \@e ]; $now = $epoch+4; Cache::FastMmap::_set_time_override($now); is( $FC->get('foo'), undef, "get item 1 after sleep 4"); is( $FC->get('bar'), undef, "get item 2 after sleep 4"); is( $FC->get('baz'), undef, "get item 3 after sleep 4"); @e = $FC->get_keys(2); cmp_deeply( \@e, bag(), "got expected keys (empty)" ) || diag explain [ $now, \@e ]; $FC->empty(1); ok( eq_hash(\%BackingStore, { foo => '123abca', bar => '456defaa', baz => '789ghia', gah => 'booa' }), "items match expire 2"); Cache-FastMmap-1.58/t/12.t0000644000000000000000000000305515006056063013534 0ustar rootroot ######################### our ($IsWin, $Tests); BEGIN { $IsWin = 0; $Tests = 7; if ($^O eq "MSWin32") { $IsWin = 1; $Tests -= 2; } } use Test::More tests => $Tests; BEGIN { use_ok('Cache::FastMmap') }; use strict; ######################### # Insert your test code below, the Test::More module is use()ed here so read # its man page ( perldoc Test::More ) for help writing this test script. my $FC = Cache::FastMmap->new(init_file => 1, serializer => ''); ok( defined $FC ); # Check get_and_set() ok( $FC->set("cnt", 1), "set counter" ); is( $FC->get_and_set("cnt", sub { return ++$_[1]; }), 2, "get_and_set 1" ); is( $FC->get_and_set("cnt", sub { return ++$_[1]; }), 3, "get_and_set 2" ); # Basic atomicness test my $loops = 5000; if (!$IsWin) { $FC->set("cnt", 0); if (my $pid = fork()) { for (1 .. $loops) { $FC->get_and_set("cnt", sub { return ++$_[1]; }); } waitpid($pid, 0); is( $FC->get("cnt"), $loops*2, "get_and_set 1"); } else { for (1 .. $loops) { $FC->get_and_set("cnt", sub { return ++$_[1]; }); } CORE::exit(0); } } # Check get_and_remove() if (!$IsWin) { my $got_but_didnt_remove = 0; if (my $pid = fork()) { for (1..$loops) { $FC->set("cnt", "data"); my ($got, $did_remove) = $FC->get_and_remove("cnt"); # With atomicity, we should never get something out, but fail to remove something: $got_but_didnt_remove++ if $got && !$did_remove; } waitpid($pid, 0); is( $got_but_didnt_remove, 0, "get_and_remove 1" ); } else { for (1..$loops) { $FC->remove("cnt"); } CORE::exit(0); } } Cache-FastMmap-1.58/t/2.t0000644000000000000000000000740515006056063013456 0ustar rootroot ######################### use Test::More tests => 51; use Test::Deep; BEGIN { use_ok('Cache::FastMmap') }; use strict; ######################### # Insert your test code below, the Test::More module is use()ed here so read # its man page ( perldoc Test::More ) for help writing this test script. my $FC = Cache::FastMmap->new(init_file => 1, expire_time => 3, serializer => ''); ok( defined $FC ); my $FC2 = Cache::FastMmap->new(init_file => 1, expire_time => 5, serializer => ''); ok( defined $FC2 ); my $epoch = time; my $now = $epoch; Cache::FastMmap::_set_time_override($now); ok( $FC->set('abc', '123'), "expire set 1"); is( $FC->get('abc'), '123', "expire get 2"); ok( $FC2->set('abc', '123'), "expire set 3"); ok( $FC2->set('def', '123', 3), "expire set 4"); ok( $FC2->set('ghi', '123', 'now'), "expire set 5"); ok( $FC2->set('jkl', '123', 'never'), "expire set 6"); is( $FC2->get('abc'), '123', "expire get 7"); is( $FC2->get('def'), '123', "expire get 8"); is( $FC2->get('ghi'), undef, "expire get 9"); is( $FC2->get('jkl'), '123', "expire get 10"); ok( $FC2->set('mno', '123'), "expire get_and_set 1"); is( scalar $FC2->get_and_set('mno', sub { return ("456", { expire_time => 1 }) }), '456', "expire get_and_set 2"); is( $FC2->get('mno'), '456', "expire get_and_set 3"); my @e = $FC2->get_keys(2); cmp_deeply( \@e, bag( superhashof({ key => 'abc', value => '123', last_access => num($now, 1), expire_on => num($now+5, 1) }), superhashof({ key => 'def', value => '123', last_access => num($now, 1), expire_on => num($now+3, 1) }), superhashof({ key => 'jkl', value => '123', last_access => num($now, 1), expire_on => 0 }), superhashof({ key => 'mno', value => '456', last_access => num($now, 1), expire_on => num($now+1, 1) }), ), "got expected keys" ) || diag explain [ $now, \@e ]; $now = $epoch+2; Cache::FastMmap::_set_time_override($now); ok( $FC->set('def', '456'), "expire set 11"); is( $FC->get('abc'), '123', "expire get 12"); is( $FC->get('def'), '456', "expire get 13"); is( $FC2->get('abc'), '123', "expire get 14"); is( $FC2->get('def'), '123', "expire get 15"); ok( !defined $FC2->get('ghi'), "expire get 16"); is( $FC2->get('jkl'), '123', "expire get 17"); ok( !defined $FC2->get('mno'), "expire get_and_set 4"); $now = $epoch+4; Cache::FastMmap::_set_time_override($now); ok( !defined $FC->get('abc'), "expire get 18"); is( $FC->get('def'), '456', "expire get 19"); is( $FC2->get('abc'), '123', "expire get 20"); ok( !defined $FC2->get('def'), "expire get 21"); ok( !defined $FC2->get('ghi'), "expire get 22"); is( $FC2->get('jkl'), '123', "expire get 23"); $now = $epoch+6; Cache::FastMmap::_set_time_override($now); ok( !defined $FC->get('abc'), "expire get 24"); ok( !defined $FC->get('def'), "expire get 25"); ok( !defined $FC2->get('abc'), "expire get 26"); ok( !defined $FC2->get('def'), "expire get 27"); ok( !defined $FC2->get('ghi'), "expire get 28"); is( $FC2->get('jkl'), '123', "expire get 29"); ok( $FC->set('abc', '123', '1s'), "expire set 31"); ok( $FC->set('abc', '123', '1m'), "expire set 32"); ok( $FC->set('abc', '123', '1d'), "expire set 33"); ok( $FC->set('abc', '123', '1w'), "expire set 34"); ok( $FC->set('abc', '123', '1 second'), "expire set 41"); ok( $FC->set('abc', '123', '1 minute'), "expire set 42"); ok( $FC->set('abc', '123', '1 day'), "expire set 43"); ok( $FC->set('abc', '123', '1 week'), "expire set 44"); ok( $FC->set('abc', '123', 'now'), "expire set 45"); ok( $FC->set('abc', '123', 'never'), "expire set 46"); ok( $FC->set('abc', '123', 's'), "expire set 47"); ok( $FC->set('abc', '123', ''), "expire set 48"); ok( $FC->set('abc', '123', -1), "expire set 49"); ok( $FC->set('abc', '123', 'garbage'), "expire set 50"); Cache-FastMmap-1.58/t/1.t0000644000000000000000000001061615006056063013453 0ustar rootroot ######################### use Test::More tests => 62; BEGIN { use_ok('Cache::FastMmap') }; use strict; ######################### # Insert your test code below, the Test::More module is use()ed here so read # its man page ( perldoc Test::More ) for help writing this test script. my $FC = Cache::FastMmap->new(init_file => 1, serializer => ''); ok( defined $FC ); # Test empty cache ok( !defined $FC->get(''), "empty get('')" ); ok( !defined $FC->get(' '), "empty get(' ')" ); ok( !defined $FC->get(' ' x 1024), "empty get(' ' x 1024)" ); ok( !defined $FC->get(' ' x 65536), "empty get(' ' x 65536)" ); # Test basic store/get on key sizes ok( $FC->set('', 'abc'), "set('', 'abc')" ); is( $FC->get(''), 'abc', "get('') eq 'abc'"); my ($R, $DidStore) = $FC->get_and_set('', sub { 'abcd' }); is ($R, "abcd", "get_and_set('', sub { 'abcd' })" ); is ($DidStore, 1, "get_and_set did store"); ok( $FC->set(' ', 'def'), "set(' ', 'def')" ); is( $FC->get(' '), 'def', "get(' ') eq 'def'"); ok( $FC->set(' ' x 1024, 'ghi'), "set(' ' x 1024, 'ghi')"); is( $FC->get(' ' x 1024), 'ghi', "get(' ' x 1024) eq 'ghi'"); my ($R, $DidStore) = $FC->get_and_set(' ' x 1024, sub { 'bcde' }); is($R, "bcde", "get_and_set(' ' x 1024, sub { 'bcde' })" ); is($DidStore, 1, "get_and_set did store"); # Bigger than the page size - should not work ok( !$FC->set(' ' x 65536, 'jkl'), "set(' ' x 65536, 'jkl')"); ok( !defined $FC->get(' ' x 65536), "empty get(' ' x 65536)"); my ($R, $DidStore) = $FC->get_and_set(' ' x 65536, sub { 'cdef' }); ok( !defined $FC->get(' ' x 65536), "empty get(' ' x 65536)" ); is($DidStore, 0, "get_and_set did not store"); # Test basic store/get on value sizes ok( $FC->set('abc', ''), "set('abc', '')"); is( $FC->get('abc'), '', "get('abc') eq ''"); ok( $FC->set('def', 'x'), "set('def', 'x')"); is( $FC->get('def'), 'x', "get('def') eq 'x'"); ok( $FC->set('ghi', 'x' . ('y' x 1024) . 'z'), "set('ghi', ...)"); is( $FC->get('ghi'), 'x' . ('y' x 1024) . 'z', "get('ghi') eq ..."); # Bigger than the page size - should not work ok( !$FC->set('jkl', 'x' . ('y' x 65536) . 'z'), "set('jkl', ...)"); ok( !defined $FC->get('jkl'), "empty get('jkl')" ); # Ref key should use 'stringy' version my $Ref = [ ]; ok( $FC->set($Ref, 'abcd'), "set($Ref)" ); is( $FC->get($Ref), 'abcd', "get($Ref)" ); is( $FC->get("$Ref"), 'abcd', "get(\"$Ref\")" ); # Check UTF8 ok( $FC->set("key\x{263A}", "val"), "set utf8 key" ); is( $FC->get("key\x{263A}"), "val", "get utf8 key" ); ok( $FC->set("key", "val\x{263A}"), "set utf8 val" ); is( $FC->get("key"), "val\x{263A}", "get utf8 val" ); ok( $FC->set("key2\x{263A}", "val2\x{263A}"), "set utf8 key/val" ); is( $FC->get("key2\x{263A}"), "val2\x{263A}", "get utf8 key/val" ); # Check clearing actually works $FC->clear(); ok( !defined $FC->get('abc'), "post clear 1" ); ok( !defined $FC->get('def'), "post clear 2" ); ok( !defined $FC->get('ghi'), "post clear 3" ); ok( !defined $FC->get('jkl'), "post clear 4" ); ok( !defined $FC->get("key"), "post clear 5" ); ok( !defined $FC->get("key\x{263A}"), "post clear 6" ); ok( !defined $FC->get("key2\x{263A}"), "post clear 7" ); # Check getting key/value lists ok( $FC->set("abc", "123"), "get_keys set 1" ); ok( $FC->set("bcd", "234"), "get_keys set 2" ); ok( $FC->set("cde", "345"), "get_keys set 3" ); is( join(",", sort $FC->get_keys), "abc,bcd,cde", "get_keys 1"); my %keys = map { $_->{key} => $_ } $FC->get_keys(2); is( scalar(keys %keys), 3, "get_keys 2" ); is($keys{abc}->{value}, "123", "get_keys 3"); is($keys{bcd}->{value}, "234", "get_keys 4"); is($keys{cde}->{value}, "345", "get_keys 5"); # Test getting key/value lists with UTF8 $FC->set("def\x{263A}", "456\x{263A}"); is( join(",", sort $FC->get_keys), "abc,bcd,cde,def\x{263A}", "get_keys 6"); %keys = map { $_->{key} => $_ } $FC->get_keys(2); is( scalar(keys %keys), 4 , "get_keys 7"); is($keys{abc}->{value}, "123", "get_keys 8"); is($keys{bcd}->{value}, "234", "get_keys 9"); is($keys{cde}->{value}, "345", "get_keys 10"); is($keys{"def\x{263A}"}->{value}, "456\x{263A}", "get_keys 11"); # basic multi_* tests $FC->multi_set("page1", { k1 => 1, k2 => 2 }); $FC->multi_set("page2", { k3 => 1, k4 => 2 }); my $R = $FC->multi_get("page1", [ qw(k1 k2) ]); is($R->{k1}, 1, "multi_get 1"); is($R->{k2}, 2, "multi_get 2"); $R = $FC->multi_get("page2", [ qw(k3 k4) ]); is($R->{k3}, 1, "multi_get 3"); is($R->{k4}, 2, "multi_get 4"); Cache-FastMmap-1.58/t/19.t0000644000000000000000000000263615006056063013547 0ustar rootroot ######################### use Test::More; BEGIN { eval "use JSON (); use Sereal ();"; if ($@) { plan skip_all => 'No JSON/Sereal, no json/sereal storage tests'; } else { plan tests => 5; } use_ok('Cache::FastMmap'); } use Time::HiRes qw(time); use Data::Dumper; use strict; ######################### my $FCStorable = Cache::FastMmap->new(serializer => 'storable', init_file => 1); ok( defined $FCStorable ); my $FCJson = Cache::FastMmap->new(serializer => 'json', init_file => 1); ok( defined $FCJson ); my $FCSereal = Cache::FastMmap->new(serializer => 'sereal', init_file => 1); ok( defined $FCSereal ); eval { $FCJson->set("foo2", { key1 => '123abc', key2 => \"bar" }); }; ok( $@ =~ /cannot encode reference to scalar/ ); my $StorableTime = DoTests($FCStorable); my $JsonTime = DoTests($FCJson); my $SerealTime = DoTests($FCSereal); # Lets not assume these everywhere as test breakers # ok ($StorableTime > $SerealTime, "Sereal faster than storable"); # ok ($StorableTime > $JsonTime, "Json faster than storable"); sub DoTests { my $FC = shift; for (1..10000) { $FC->set("foo$_", { key1 => 'boom', key2 => "woot$_" }); } my $Start = time; for (1..10000) { $FC->set("foo$_", { key1 => '123abc', key2 => "bar$_" }); my $H = $FC->get("foo$_"); keys %$H == 2 || die; $H->{key1} eq '123abc' || die; $H->{key2} eq "bar$_" || die; } my $End = time; return $End-$Start; } Cache-FastMmap-1.58/t/9.t0000644000000000000000000000305015006056063013455 0ustar rootroot ######################### use Test::More tests => 5; BEGIN { use_ok('Cache::FastMmap') }; use Storable qw(freeze thaw); use strict; ######################### # Insert your test code below, the Test::More module is use()ed here so read # its man page ( perldoc Test::More ) for help writing this test script. my $FC = Cache::FastMmap->new( page_size => 8192, num_pages => 3, init_file => 1, serializer => '' ); ok( defined $FC ); sub rand_str { return join '', map { chr(rand(26) + ord('a')) } 1 .. int($_[0]); } srand(123); my $Bad = 0; my @LastEntries; foreach my $i (1 .. 500) { my $K = rand_str(rand(10) + 10); my $V = rand_str(rand(20) + 20); $FC->set($K, $V); push @LastEntries, [ $K, $V ]; shift @LastEntries if @LastEntries > 25; foreach my $e (0 .. @LastEntries-1) { local $_ = $LastEntries[$e]; if ($_->[1] ne ($FC->get($_->[0]) || '')) { $Bad = 1; last; } } last if $Bad; select(undef, undef, undef, 0.01); } ok( !$Bad ); $FC = Cache::FastMmap->new( page_size => 8192, num_pages => 3, init_file => 1 ); ok( defined $FC ); $Bad = 0; @LastEntries = (); foreach my $i (1 .. 500) { my $K = rand_str(rand(10) + 10); my $V = [ rand_str(rand(20) + 20) ]; $FC->set($K, $V); push @LastEntries, [ $K, freeze($V) ]; shift @LastEntries if @LastEntries > 25; foreach my $e (0 .. @LastEntries-1) { local $_ = $LastEntries[$e]; if ($_->[1] ne freeze($FC->get($_->[0]) || [])) { $Bad = 1; last; } } last if $Bad; select(undef, undef, undef, 0.01); } ok( !$Bad ); Cache-FastMmap-1.58/t/6.t0000644000000000000000000000755415006056063013467 0ustar rootroot ######################### use Test::More; my $GetMem; BEGIN { eval "use GTop ();"; if (!$@) { my $GTop = GTop->new; $GetMem = sub { return $GTop->proc_mem($$)->size }; } elsif (-f "/proc/$$/status") { $GetMem = sub { open(my $Sh, "/proc/$$/status"); my ($S) = map { /(\d+) kB/ && $1*1024 } grep { /^VmSize:/ } <$Sh>; close($Sh); return $S; } } if ($GetMem) { plan tests => 10; } else { plan skip_all => 'No GTop or /proc/, no memory leak tests'; } use_ok('Cache::FastMmap'); } use strict; ######################### # Insert your test code below, the Test::More module is use()ed here so read # its man page ( perldoc Test::More ) for help writing this test script. our ($DidRead, $DidWrite, $DidDelete, $HitCount); our $FC; $FC = Cache::FastMmap->new(init_file => 0, serializer => ''); $FC = undef; TestLeak(\&NewLeak, "new - 1"); TestLeak(\&NewLeak, "new - 2"); TestLeak(\&NewLeak2, "new2 - 1"); TestLeak(\&NewLeak2, "new2 - 2"); $FC = Cache::FastMmap->new( init_file => 1, serializer => '', num_pages => 17, page_size => 65536, read_cb => sub { $DidRead++; return undef; }, write_cb => sub { $DidWrite++; }, delete_cb => sub { $DidDelete++; }, write_action => 'write_back' ); ok( defined $FC ); # Prefill cache to make sure all pages mapped for (1 .. 10000) { $FC->set(RandStr(20), RandStr(20)); } $FC->get('foo'); our $Key = "blah" x 100; our $Val = "\x{263A}" . RandStr(1000); our $IterCount = 100; our $StartKey = 1; SetLeak(); $StartKey = 1; GetLeak(); our $IterCount = 20000; $StartKey = 1; TestLeak(\&SetLeak, "set"); $StartKey = 1; TestLeak(\&GetLeak, "get"); $FC->clear(); $StartKey = 1; TestLeak(\&SetLeak, "set2"); our (@a, @b, @c); @a = $FC->get_keys(0); @b = $FC->get_keys(1); @c = $FC->get_keys(2); @a = @b = @c = (); ListLeak(); TestLeak(\&ListLeak, "list"); sub RandStr { return join '', map { chr(ord('a') + rand(26)) } (1 .. $_[0]); } sub TestLeak { my $Sub = shift; my $Test = shift; my $Before = $GetMem->(); eval { $Sub->(); }; if ($@) { ok(0, "leak test died: $@"); } my $After = $GetMem->(); my $Extra = ($After - $Before)/1024; ok( $Extra <= 500, "leak test $Extra > 500k - for $Test"); } sub NewLeak { for (1 .. 2000) { $FC = Cache::FastMmap->new( init_file => 0, serializer => '', num_pages => 17, page_size => 8192, read_cb => sub { $DidRead++; return undef; }, write_cb => sub { $DidWrite++; }, delete_cb => sub { $DidDelete++; }, write_action => 'write_back' ); } $FC = undef; } sub NewLeak2 { for (1 .. 2000) { $FC = Cache::FastMmap->new( init_file => 1, serializer => '', num_pages => 17, page_size => 8192, read_cb => sub { $DidRead++; return undef; }, write_cb => sub { $DidWrite++; }, delete_cb => sub { $DidDelete++; }, write_action => 'write_back' ); } $FC = undef; } sub SetLeak { for (1 .. $IterCount) { $Key = "blah" . $StartKey++ . "blah"; if ($_ % 10 < 6) { $Val = RandStr(int(rand(20))+2); } elsif ($_ % 10 < 8) { $Val = "\x{263A}" . RandStr(int(rand(20))+2); } else { $Val = undef; } $FC->set($Key, $Val); } } sub GetLeak { for (1 .. $IterCount) { $Key = "blah" . $StartKey++ . "blah"; $HitCount++ if $FC->get($Key); } } sub WBLeak { for (1 .. $IterCount) { $Key = "blah" . $StartKey++ . "blah"; if ($_ % 10 < 6) { $Val = RandStr(int(rand(20))+2); } elsif ($_ % 10 < 8) { $Val = "\x{263A}" . RandStr(int(rand(20))+2); } else { $Val = undef; } $FC->set($Key, $Val); my $PreDidWrite = $DidWrite; $FC->empty() if $_ % 10 == 0; $PreDidWrite + 1 == $DidWrite || die "write count mismatch"; $FC->get($Key) && die "get success"; } } sub ListLeak { for (1 .. 100) { @a = $FC->get_keys(0); @b = $FC->get_keys(1); @c = $FC->get_keys(2); @a = @b = @c = (); } } Cache-FastMmap-1.58/t/17.t0000644000000000000000000000124215006056063013535 0ustar rootroot ######################### use Test::More tests => 186; BEGIN { use_ok('Cache::FastMmap') }; use Storable qw(freeze thaw); use strict; ######################### # Test that we actually re-use deleted slots in a cache my $FC = Cache::FastMmap->new( page_size => 65536, num_pages => 1, init_file => 1, serializer => '', start_slots => 89, ); ok( defined $FC ); ok($FC->set("foo", "a" x 31000), "set foo"); ok($FC->set("bar", "b" x 31000), "set bar"); for (1 .. 90) { ok($FC->set("a", "$_"), "set $_"); ok($FC->get("a") eq "$_", "get $_"); $FC->remove("a"); } ok($FC->get("foo") eq "a" x 31000, "get foo"); ok($FC->get("bar") eq "b" x 31000, "get bar"); Cache-FastMmap-1.58/t/11.t0000644000000000000000000000154615006056063013536 0ustar rootroot ######################### use Test::More tests => 7; BEGIN { use_ok('Cache::FastMmap') }; use strict; ######################### # Test recursive cache use sub get_fc { my $FC; $FC = Cache::FastMmap->new( cache_not_found => 1, serializer => '', init_file => 1, num_pages => 89, page_size => 1024, read_cb => sub { $FC->get($_[1] . "1"); }, write_cb => sub { $FC->set($_[1] . "1", $_[2]); }, delete_cb => sub { $FC->delete($_[1]); }, write_action => 'write_back', @_ ); return $FC; } my $FC = get_fc(); ok( defined $FC ); $FC->set("foo1", "bar"); my $V = eval { $FC->get("foo"); }; ok(!$V, "no return"); like($@, qr/already locked/, "recurse fail"); $FC = undef; $FC = get_fc(allow_recursive => 1); ok( defined $FC ); $FC->set("foo1", "bar"); $V = eval { $FC->get("foo"); }; ok(!$@, "recurse success 1"); is($V, "bar", "recurse success 2"); Cache-FastMmap-1.58/t/21.t0000644000000000000000000000326115006056063013533 0ustar rootroot ######################### use Test::More; use strict; my $fs; BEGIN { my @fs = map { { /(\w+)="([^"]*)"/g } } split /\n/, `findmnt -t tmpfs -P -b -o TARGET,AVAIL | grep /tmp`; ($fs) = grep { $_->{AVAIL} > 2**33 } @fs; if (!$fs) { plan skip_all => 'Large file tests need tmpfs with at least 8G'; } } BEGIN { plan tests => 6; use_ok('Cache::FastMmap') }; ######################### # Insert your test code below, the Test::More module is use()ed here so read # its man page ( perldoc Test::More ) for help writing this test script. my $cache_file = $fs->{TARGET} . "/largecachetest.cache"; my %WrittenItems; my $FC = Cache::FastMmap->new( share_file => $cache_file, serializer => '', init_file => 1, num_pages => 8, page_size => 2**30, ); ok( defined $FC ); srand(6543); # Put 1000 items in the cache - should be big enough :) for (1 .. 1000) { my ($Key, $Val) = (RandStr(100), RandStr(1000)); $FC->set($Key, $Val); $WrittenItems{$Key} = $Val; } # Get values in cache should be 1000 my %CacheItems = map { $_->{key} => $_->{value} } $FC->get_keys(2); ok( scalar(keys %CacheItems) == 1000, "1000 items in cache"); # Should be able to read all items my ($Failed, $GetFailed) = (0, 0); for (keys %WrittenItems) { $Failed++ if $FC->get($_) ne $WrittenItems{$_}; $GetFailed++ if $FC->get($_) ne $CacheItems{$_}; } ok( $Failed == 0, "got all written items" ); ok( $GetFailed == 0, "got all get_keys items" ); # Now there should be nothing left $FC->clear(); %CacheItems = map { $_->{key} => $_->{value} } $FC->get_keys(2); ok( scalar(keys %CacheItems) == 0, "empty cache 2"); sub RandStr { return join '', map { chr(ord('a') + rand(26)) } (1 .. $_[0]); } Cache-FastMmap-1.58/t/FastMmapTest.pl0000755000000000000000000001444715006056063016044 0ustar rootroot#!/usr/local/bin/perl -w use lib '/home/mod_perl/hm/modules'; use ExtUtils::testlib; use Cache::FastMmap; use Data::Dumper; use POSIX ":sys_wait_h"; use strict; #EdgeTests(); my $FC = Cache::FastMmap->new( init_file => 1, raw_values => 1 ) || die "Could not create file cache"; BasicTests($FC); $FC->clear(); my @Keys; RepeatMixTest($FC, 0.0, \@Keys); RepeatMixTest($FC, 0.5, \@Keys); RepeatMixTest($FC, 0.8, \@Keys); ForkTests($FC); $FC = Cache::FastMmap->new( init_file => 1, page_size => 8192, raw_values => 1 ) || die "Could not create file cache"; BasicTests($FC); $FC->clear(); @Keys = (); RepeatMixTest($FC, 0.0, \@Keys); RepeatMixTest($FC, 0.5, \@Keys); RepeatMixTest($FC, 0.8, \@Keys); ForkTests($FC); print "All done\n"; exit(0); sub BasicTests { my $FC = shift; printf "Basic tests\n"; # Test empty !defined $FC->get('') || die "Not undef on empty get"; !defined $FC->get(' ') || die "Not undef on empty get"; !defined $FC->get(' ' x 1024) || die "Not undef on empty get"; !defined $FC->get(' ' x 65536) || die "Not undef on empty get"; # Test basic store/get on key sizes $FC->set('', 'abc'); $FC->get('') eq 'abc' || die "Get mismatch"; $FC->set(' ', 'def'); $FC->get(' ') eq 'def' || die "Get mismatch"; $FC->set(' ' x 1024, 'ghi'); $FC->get(' ' x 1024) eq 'ghi' || die "Get mismatch"; # Bigger than the page size - shouldn't work $FC->set(' ' x 65536, 'jkl'); !defined $FC->get(' ' x 65536) || die "Get mismatch"; # Test basic store/get on value sizes $FC->set('abc', ''); $FC->get('abc') eq '' || die "Get mismatch"; $FC->set('def', 'x'); $FC->get('def') eq 'x' || die "Get mismatch"; $FC->set('ghi', 'x' . ('y' x 1024) . 'z'); $FC->get('ghi') eq 'x' . ('y' x 1024) . 'z' || die "Get mismatch"; # Bigger than the page size - shouldn't work $FC->set('jkl', 'x' . ('y' x 65536) . 'z'); !defined $FC->get('jkl') || die "Get mismatch"; # Ref key should use 'stringy' version my $Ref = [ ]; $FC->set($Ref, 'abcd'); $FC->get($Ref) eq 'abcd' || die "Get mismatch"; $FC->get("$Ref") eq 'abcd' || die "Get mismatch"; # Check utf8 # eval { $FC->set("\x{263A}", "blah\x{263A}"); }; # $@ || die "Set utf8 succeeded, but should have failed: $@"; # eval { $FC->set("blah", "\x{263A}"); }; # $@ || die "Set utf8 succeeded, but should have failed: $@"; # eval { $FC->get("\x{263A}"); }; # $@ || die "Set utf8 succeeded, but should have failed: $@"; $FC->set("\x{263A}", "blah\x{263A}"); $FC->get("\x{263A}") eq "blah\x{263A}" || die "Get mismatch"; $FC->clear(); $FC->set("abc", "123"); $FC->set("bcd", "234"); $FC->set("cde", "345"); $FC->set("def", "456"); join(",", sort $FC->get_keys) eq "abc,bcd,cde,def" || die "get_keys mismatch"; $FC->set("efg\x{263A}", "567\x{263A}"); join(",", sort $FC->get_keys) eq "abc,bcd,cde,def,efg\x{263A}" || die "get_keys mismatch"; my %keys = map { $_->{key} => $_ } $FC->get_keys(2); $keys{abc}->{value} eq "123" || die "get_keys missing"; $keys{"efg\x{263A}"}->{value} eq "567\x{263A}" || die "get_keys missing"; } sub EdgeTests { my $FC = Cache::FastMmap->new( init_file => 1, num_pages => 1, raw_values => 1 ) || die "Could not create file cache"; printf "Edge tests. Assume implementation\n"; $FC->clear(); # bytes for kv data # 65536 - 8*4 - 4*4*89 = 64080 # adds 4*2 + 1 + 1 = 10 bytes, 64070 rem $FC->set('a', 'a'); $FC->get('a') eq 'a' || die "Get mismatch"; # Ensure oldest timestamp sleep 2; # adds 4*2 + 1 + 64051 = 64060, 10 rem $FC->set('b', 'b' x 64051); $FC->get('b') eq 'b' x 64051 || die "Get mismatch"; sleep 2; # adds 4*2 + 1 + 1 = 10 bytes, 0 rem $FC->set('c', 'c'); $FC->get('c') eq 'c' || die "Get mismatch"; $FC->get('b') eq 'b' x 64051 || die "Get mismatch"; $FC->get('a') eq 'a' || die "Get mismatch"; # adds 4*2 + 1 + 1 = 10 bytes, force expunge $FC->set('d', 'd'); !defined $FC->get('a') || die "Get mismatch"; !defined $FC->get('b') || die "Get mismatch"; $FC->get('d') eq 'd' || die "Get mismatch"; $FC->get('c') eq 'c' || die "Get mismatch"; # Try again $FC->clear(); # adds 4*2 + 1 + 1 = 10 bytes, 64070 rem $FC->set('a', 'a'); $FC->get('a') eq 'a' || die "Get mismatch"; # Ensure oldest timestamp sleep 2; # adds 4*2 + 1 + 64052 = 64061, 9 rem $FC->set('b', 'b' x 64052); $FC->get('b') eq 'b' x 64052 || die "Get mismatch"; sleep 2; # adds 4*2 + 1 + 1 = 10 bytes, -1 rem, force expunge $FC->set('c', 'c'); $FC->get('c') eq 'c' || die "Get mismatch"; !defined $FC->get('b') || die "Get mismatch"; !defined $FC->get('a') || die "Get mismatch"; # adds 4*2 + 1 + 1 = 10 bytes $FC->set('d', 'd'); $FC->get('d') eq 'd' || die "Get mismatch"; $FC->get('c') eq 'c' || die "Get mismatch"; } sub ForkTests { # Now fork several children to test cache concurrency my ($Pid, %Kids); for (my $j = 0; $j < 8; $j++) { if (!($Pid = fork())) { RepeatMixTest($FC, 0.4, \@Keys); exit; } $Kids{$Pid} = 1; select(undef, undef, undef, 0.001); } # Wait for children to finish my $Kid; do { $Kid = waitpid(-1, WNOHANG); delete $Kids{$Kid}; } until $Kid > 0 && !%Kids; } sub RepeatMixTest { my ($FC, $Ratio, $WroteKeys) = @_; print "Repeat mix tests\n"; my ($Read, $ReadHit); # Lots of random tests for (1 .. 10000) { # Read/write ratio if (rand() < $Ratio) { # Pick a key from known written ones my $K = $WroteKeys->[ rand(@$WroteKeys) ]; my $V = $FC->get($K); $Read++; # Skip if not found in cache next if !defined $V; $ReadHit++; # Offset of 10 past first chars of value are key substr($V, 10, length($K)) eq $K || die "Cache/key not equal: $K, $V"; } else { my $K = RandStr(16); my $V = RandStr(10) . $K . RandStr(int(rand(200))); push @$WroteKeys, $K; $FC->set($K, $V); } } printf "Read hit pct: %5.3f\n", ($ReadHit/$Read) if $Read; return; } sub RandStr { my $Len = shift; if (!$::URandom) { open($::URandom, '/dev/urandom') || die "Could not open /dev/urandom: $!"; } sysread($::URandom, my $D, $Len); $D =~ s/(.)/chr(ord($1) % 26 + ord('a'))/ge; return $D; } Cache-FastMmap-1.58/t/4.t0000644000000000000000000000407715006056063013462 0ustar rootroot ######################### use Test::More tests => 9; BEGIN { use_ok('Cache::FastMmap') }; use strict; ######################### # Insert your test code below, the Test::More module is use()ed here so read # its man page ( perldoc Test::More ) for help writing this test script. # Test a backing store just made of a local hash my %BackingStore = ( foo => '123abc', bar => '456def' ); my %WrittenItems = %BackingStore; my $FC = Cache::FastMmap->new( serializer => '', init_file => 1, num_pages => 3, page_size => 32768, context => \%BackingStore, read_cb => sub { return $_[0]->{$_[1]}; }, write_cb => sub { $_[0]->{$_[1]} = $_[2]; }, delete_cb => sub { delete $_[0]->{$_[1]} }, write_action => 'write_back' ); ok( defined $FC ); srand(6543); # Put 100 items in the cache (should be big enough) for (1 .. 100) { my ($Key, $Val) = (RandStr(10), RandStr(100)); $FC->set($Key, $Val); $WrittenItems{$Key} = $Val; } # Should only be 2 items in the backing store ok( scalar(keys %BackingStore) == 2, "items match 1"); # Should flush back all the items to backing store $FC->empty(); # Get values in cache should be empty my %CacheItems = map { $_->{key} => $_->{value} } $FC->get_keys(2); ok( scalar(keys %CacheItems) == 0, "empty cache"); # Backing store should be equal to all items we wrote ok( eq_hash(\%WrittenItems, \%BackingStore), "items match 1"); # Should be able to read all items my $Failed = 0; for (keys %WrittenItems) { $Failed++ if $FC->get($_) ne $WrittenItems{$_}; } ok( $Failed == 0, "got all written items 1" ); # Empty backing store %BackingStore = (); # Should still be able to read all items $Failed = 0; for (keys %WrittenItems) { $Failed++ if $FC->get($_) ne $WrittenItems{$_}; } ok( $Failed == 0, "got all written items 2" ); # Now there should be nothing left $FC->clear(); %CacheItems = map { $_->{key} => $_->{value} } $FC->get_keys(2); ok( scalar(keys %CacheItems) == 0, "empty cache 2"); ok( scalar(keys %BackingStore) == 0, "empty backing store 1"); sub RandStr { return join '', map { chr(ord('a') + rand(26)) } (1 .. $_[0]); } Cache-FastMmap-1.58/t/3.t0000644000000000000000000000351415006056063013454 0ustar rootroot ######################### use Test::More tests => 8; BEGIN { use_ok('Cache::FastMmap') }; use strict; ######################### # Insert your test code below, the Test::More module is use()ed here so read # its man page ( perldoc Test::More ) for help writing this test script. my $FC = Cache::FastMmap->new(init_file => 1, serializer => ''); ok( defined $FC ); my (@Keys, $HitRate); $HitRate = RepeatMixTest($FC, 1000, 0.0, \@Keys); ok( $HitRate == 0.0, "hit rate 1"); $HitRate = RepeatMixTest($FC, 1000, 0.5, \@Keys); ok( $HitRate == 1.0, "hit rate 2"); $HitRate = RepeatMixTest($FC, 1000, 0.8, \@Keys); ok( $HitRate == 1.0, "hit rate 3"); $FC = undef; @Keys = (); # Should be repeatable srand(123456); $FC = Cache::FastMmap->new( init_file => 1, page_size => 8192, serializer => '' ); ok( defined $FC ); $HitRate = RepeatMixTest($FC, 1000, 0.0, \@Keys); ok( $HitRate == 0.0, "hit rate 1"); $HitRate = RepeatMixTest($FC, 10000, 0.5, \@Keys); ok( $HitRate > 0.8 && $HitRate < 0.95, "hit rate 4 - $HitRate"); sub RepeatMixTest { my ($FC, $NItems, $Ratio, $WroteKeys) = @_; my ($Read, $ReadHit); # Lots of random tests for (1 .. $NItems) { # Read/write ratio if (rand() < $Ratio) { # Pick a key from known written ones my $K = $WroteKeys->[ rand(@$WroteKeys) ]; my $V = $FC->get($K); $Read++; # Skip if not found in cache next if !defined $V; $ReadHit++; # Offset of 10 past first chars of value are key substr($V, 10, length($K)) eq $K || die "Cache/key not equal: $K, $V"; } else { my $K = RandStr(16); my $V = RandStr(10) . $K . RandStr(int(rand(200))); push @$WroteKeys, $K; $FC->set($K, $V); } } return $Read ? ($ReadHit/$Read) : 0.0; } sub RandStr { return join '', map { chr(ord('a') + rand(26)) } (1 .. $_[0]); } Cache-FastMmap-1.58/t/7.t0000644000000000000000000000562415006056063013464 0ustar rootroot ######################### use Test::More tests => 13; BEGIN { use_ok('Cache::FastMmap') }; use strict; ######################### # Insert your test code below, the Test::More module is use()ed here so read # its man page ( perldoc Test::More ) for help writing this test script. # Test a backing store just made of a local hash my %BackingStore = ( foo => '123abc', bar => '456def' ); my %WrittenItems = %BackingStore; my $FC = Cache::FastMmap->new( serializer => '', init_file => 1, num_pages => 89, page_size => 1024, context => \%BackingStore, read_cb => sub { return $_[0]->{$_[1]}; }, write_cb => sub { $_[0]->{$_[1]} = $_[2]; }, delete_cb => sub { delete $_[0]->{$_[1]} }, write_action => 'write_back', empty_on_exit => 1 ); ok( defined $FC ); srand(6543); # Put 3000 items in the cache for (1 .. 3000) { my ($Key, $Val) = (RandStr(10), RandStr(100)); $FC->set($Key, $Val); $WrittenItems{$Key} = $Val; } # Get values in cache my %CacheItems = map { $_->{key} => $_->{value} } $FC->get_keys(2); # Reality check approximate number of items in each ok( scalar(keys %BackingStore) < 2700, "backing store size 1" ); ok( scalar(keys %CacheItems) > 300, "backing store size 2" ); # Merge with backing store items my %AllItems = (%BackingStore, %CacheItems); # Should be equal to all items we wrote ok( eq_hash(\%AllItems, \%WrittenItems), "items match 1"); # Check we can get the items we wrote is( $FC->get('foo'), '123abc', "cb get 1"); is( $FC->get('bar'), '456def', "cb get 2"); # Read them forward and backward, which should force # complete flush and read from backing store my $Failed = 0; for (keys %WrittenItems, reverse keys %WrittenItems) { $Failed++ if $FC->get($_) ne $WrittenItems{$_}; } ok( $Failed == 0, "got all written items 1" ); # Delete some items (should be random from cache/backing store) my @DelKeys = (keys %WrittenItems)[0 .. 300]; for (@DelKeys) { $FC->remove($_); delete $WrittenItems{$_}; } # Check it all matches again %CacheItems = map { $_->{key} => $_->{value} } $FC->get_keys(2); %AllItems = (%BackingStore, %CacheItems); ok( eq_hash(\%AllItems, \%WrittenItems), "items match 2"); $Failed = 0; for (keys %WrittenItems) { $Failed++ if $FC->get($_) ne $WrittenItems{$_}; } ok( $Failed == 0, "got all written items 2" ); # Force flushing of cache $FC->empty(); # So all written items should be in backing store ok( eq_hash(\%WrittenItems, \%BackingStore), "items match 3"); my @Keys = $FC->get_keys(0); ok( scalar(@Keys) == 0, "no items left in cache" ); %WrittenItems = %BackingStore = (); # Put 3000 items in the cache for (1 .. 3000) { my ($Key, $Val) = (RandStr(10), RandStr(100)); $FC->set($Key, $Val); $WrittenItems{$Key} = $Val; } # empty_on_exit is set, so this should push to backing store $FC = undef; ok( eq_hash(\%WrittenItems, \%BackingStore), "items match 4"); sub RandStr { return join '', map { chr(ord('a') + rand(26)) } (1 .. $_[0]); } Cache-FastMmap-1.58/t/22.t0000644000000000000000000000366015006056063013537 0ustar rootroot ######################### use Test::More tests => 19; BEGIN { use_ok('Cache::FastMmap') }; use Data::Dumper; use strict; ######################### # Test maintaining write back of expired items after get # Test a backing store just made of a local hash my %BackingStore = (); my $FC = Cache::FastMmap->new( serializer => '', init_file => 1, num_pages => 1, page_size => 8192, context => \%BackingStore, write_cb => sub { $_[0]->{$_[1]} = $_[2]; }, delete_cb => sub { delete $_[0]->{$_[1]} }, write_action => 'write_back' ); my $epoch = time; my $now = $epoch; Cache::FastMmap::_set_time_override($now); ok( defined $FC ); ok( $FC->set('foo', '123abc', 1), 'store item 1'); ok( $FC->set('bar', '456def', 2), 'store item 2'); ok( $FC->set('baz', '789ghi', 3), 'store item 3'); is( $FC->get('foo'), '123abc', "get item 1"); is( $FC->get('bar'), '456def', "get item 2"); is( $FC->get('baz'), '789ghi', "get item 3"); $now = $epoch+1; Cache::FastMmap::_set_time_override($now); is( $FC->get('foo'), undef, "get item 1 after sleep 1"); is( $FC->get('bar'), '456def', "get item 2 after sleep 1"); is( $FC->get('baz'), '789ghi', "get item 3 after sleep 1"); $FC->empty(1); ok( eq_hash(\%BackingStore, { foo => '123abc' }), "items match expire 1" ); $FC->expire('baz'); $FC->expire('dummy'); ok( eq_hash(\%BackingStore, { foo => '123abc', baz => '789ghi' }), "items match explicit expire" ); is( $FC->get('baz'), undef, "get item 3 after explicit expire"); $now = $epoch+2; Cache::FastMmap::_set_time_override($now); is( $FC->get('foo'), undef, "get item 1 after sleep 2"); is( $FC->get('bar'), undef, "get item 2 after sleep 2"); is( $FC->get('baz'), undef, "get item 3 after sleep 2"); $FC->empty(1); ok( eq_hash(\%BackingStore, { foo => '123abc', bar => '456def', baz => '789ghi' }), "items match expire 2"); $FC->remove('foo'); ok( eq_hash(\%BackingStore, { bar => '456def', baz => '789ghi' }), "items match remove 1"); Cache-FastMmap-1.58/t/18.t0000644000000000000000000000240715006056063013542 0ustar rootroot ######################### use Test::More; BEGIN { if ($^O eq "MSWin32") { plan skip_all => 'No FD_CLOEXEC tests, running on Windows'; } if (!-d "/proc/$$") { plan skip_all => 'No FD_CLOEXEC tests, no /proc filesystem'; } } use strict; use Fcntl; ######################### # Test fd's are closed on exec if (@ARGV) { my $PipeFd = shift @ARGV; my $FdCount = scalar(() = glob "/proc/$$/fd/*"); open(my $PipeFh, ">&=$PipeFd") || die "Could not reopen fd: $!"; print($PipeFh "$FdCount\n") || die "Could not print to pipe: $!"; exit(0); } require Cache::FastMmap; my @Caches = map { Cache::FastMmap->new( page_size => 4096, num_pages => 1, init_file => 1, serializer => '', ); } (1 .. 20); my $CacheCount = @Caches; my $FdCount = scalar(() = glob "/proc/$$/fd/*"); ok($FdCount > $CacheCount, "More fd's than caches: $FdCount > $CacheCount"); pipe(my $ReadPipeFh, my $WritePipeFh) || die "pipe failed: $!"; fcntl($ReadPipeFh, F_SETFD, 0); fcntl($WritePipeFh, F_SETFD, 0); if (!fork) { exec $^X, $0, fileno($WritePipeFh) || die "exec failed: $!"; } my $ChildFdCount = <$ReadPipeFh>; chomp $ChildFdCount; ok($ChildFdCount < $CacheCount, "Less fd's in child than caches: $ChildFdCount < $CacheCount"); done_testing(2); Cache-FastMmap-1.58/mmap_cache.h0000644000000000000000000001705715006056063015117 0ustar rootroot /* * AUTHOR * * Rob Mueller * * COPYRIGHT AND LICENSE * * Copyright (C) 2003 by FastMail IP Partners * * This library is free software; you can redistribute it and/or modify * it under the same terms as Perl itself. * * mmap_cache * * Uses an mmap'ed file to act as a shared memory interprocess cache * * The C interface is quite explicit in it's use, in that you have to * call individual functions to hash a key, lock a page, and find a * value. This allows a simpler higher level interface to be written * * #include * * mmap_cache * cache = mmc_new(); * cache->param = val; * mmc_init(cache); * * // Read a key * * // Hash get to find page and slot * mmc_hash(cache, (void *)key_ptr, (int)key_len, &hash_page, &hash_slot); * // Lock page * mmc_lock(cache, hash_page); * // Get pointer to value data * mmc_read(cache, hash_slot, (void *)key_ptr, (int)key_len, (void **)&val_ptr, (int *)val_len, &expire_time, &flags); * // Unlock page * mmc_unlock(cache); * * // Write a key * * // Hash get to find page and slot * mmc_hash(cache, (void *)key_ptr, (int)key_len, &hash_page, &hash_slot); * // Lock page * mmc_lock(cache, hash_page); * // Get pointer to value data * mmc_write(cache, hash_slot, (void *)key_ptr, (int)key_len, (void *)val_ptr, (int)val_len, expire_time, flags); * // Unlock page * mmc_unlock(cache); * * DESCRIPTION * * This class implements a shared memory cache through an mmap'ed file. It * uses locking to ensure multiple processes can safely access the cache * at the same time. It uses a basic LRU algorithm to keep the most used * entries in the cache. * * It tries to be quite efficient through a number of means: * * It uses multiple pages within a file, and uses Fcntl to only lock * a page at a time to reduce contention when multiple processes access * the cache. * * It uses a dual level hashing system (hash to find page, then hash * within each page to find a slot) to make most I calls O(1) and * fast * * On each I, if there are slots and page space available, only * the slot has to be updated and the data written at the end of the used * data space. If either runs out, a re-organisation of the page is * performed to create new slots/space which is done in an efficient way * * The locking is explicitly done in the C interface, so you can create * a 'read_many' or 'write_many' function that reduces the number of * locks required * * * IMPLEMENTATION * * Each file is made up of a number of 'pages'. The number of * pages and size of each page is specified when the class is * constructed. These values are stored in the cache class * and must be the same for each class connecting to the cache * file. * * NumPages - Number of 'pages' in the cache * PageSize - Size of each 'page' in the cache * * The layout of each page is: * * - Magic (4 bytes) - 0x92f7e3b1 magic page start marker * * - NumSlots (4 bytes) - Number of hash slots in this page * * - FreeSlots (4 bytes) - Number of free slots left in this page. * This includes all slots with a last access time of 0 * (empty and don't search past) or 1 (empty, but keep searching * because deleted slot) * * - OldSlots (4 bytes) - Of all the free slots, how many were in use * and are now deleted. This is slots with a last access time of 1 * * - FreeData (4 bytes) - Offset to free data area to place next item * * - FreeBytes (4 bytes) - Bytes left in free data area * * - N Reads (4 bytes) - Number of reads performed on this page * * - N Read Hits (4 bytes) - Number of reads on this page that have hit * something in the cache * * - Slots (4 bytes * NumSlots) - Hash slots * * - Data (to end of page) - Key/value data * * Each slot is made of: * * - Offset (4 bytes) - offset from start of page to actual data. This * is 0 if slot is empty, 1 if was used but now empty. This is needed * so deletes don't require a complete rehash with the linear * searching method we use * * Each data item is made of: * * - LastAccess (4 bytes) - Unix time data was last accessed * * - ExpireTime (4 bytes) - Unix time data should expire. This is 0 if it * should never expire * * - HashValue (4 bytes) - Value key was hashed to, so we don't have to * rehash on a re-organisation of the hash table * * - Flags (4 bytes) - Various flags * * - KeyLen (4 bytes) - Length of key * * - ValueLen (4 bytes) - Length of value * * - Key (KeyLen bytes) - Key data * * - Value (ValueLen bytes) - Value data * * Each set/get/delete operation involves: * * - Find the page for the key * - Lock the page * - Read the page header * - Find the hash slot for the key * * For get's: * * - Use linear probing to find correct key, or empty slot * * For set's: * * - Use linear probing to find empty slot * - If not enough free slots, do an 'expunge' run * - Store key/value at FreeData offset, update, and store in slot * - If not enough space at FreeData offset, do an 'expunge' run * then store data * * For delete's: * * - Use linear probing to find correct key, or empty slot * - Set slot to empty (data cleaned up in expunge run) * * An expunge run consists of: * * - Scan slots to find used key/value parts. Remove older items * - If ratio used/free slots too high, increase slot count * - Compact key/value data into one memory block * - Restore and update offsets in slots * */ #include /* Main cache structure passed as a pointer to each function */ typedef struct mmap_cache mmap_cache; /* Iterator structure for iterating over items in cache */ typedef struct mmap_cache_it mmap_cache_it; /* Unsigned 32 bit integer */ typedef uint32_t MU32; /* Unsigned 64 bit integer */ typedef uint64_t MU64; /* Magic value for no p_cur */ #define NOPAGE (~(MU32)0) /* Allow overriding "time" for tests */ void mmc_set_time_override(MU32); /* Initialisation/closing/error functions */ mmap_cache * mmc_new(); int mmc_init(mmap_cache *); int mmc_set_param(mmap_cache *, char *, char *); int mmc_get_param(mmap_cache *, char *); int mmc_close(mmap_cache *); char * mmc_error(mmap_cache *); /* Functions for find/locking a page */ int mmc_hash(mmap_cache *, void *, int, MU32 *, MU32 *); int mmc_lock(mmap_cache *, MU32); int mmc_unlock(mmap_cache *); int mmc_is_locked(mmap_cache *); /* Functions for getting/setting/deleting values in current page */ int mmc_read(mmap_cache *, MU32, void *, int, void **, int *, MU32 *, MU32 *); int mmc_write(mmap_cache *, MU32, void *, int, void *, int, MU32, MU32); int mmc_delete(mmap_cache *, MU32, void *, int, MU32 *); /* Functions of expunging values in current page */ int mmc_calc_expunge(mmap_cache *, int, int, MU32 *, MU32 ***); int mmc_do_expunge(mmap_cache *, int, MU32, MU32 **); /* Functions for iterating over items in a cache */ mmap_cache_it * mmc_iterate_new(mmap_cache *); MU32 * mmc_iterate_next(mmap_cache_it *); void mmc_iterate_close(mmap_cache_it *); /* Retrieve details of a cache page/entry */ void mmc_get_details(mmap_cache *, MU32 *, void **, int *, void **, int *, MU32 *, MU32 *, MU32 *); void mmc_get_page_details(mmap_cache * cache, MU32 * nreads, MU32 * nreadhits); void mmc_reset_page_details(mmap_cache * cache); /* Internal functions */ int _mmc_set_error(mmap_cache *, int, char *, ...); void _mmc_init_page(mmap_cache *, MU32); MU32 * _mmc_find_slot(mmap_cache * , MU32 , void *, int, int ); void _mmc_delete_slot(mmap_cache * , MU32 *); int _mmc_check_expunge(mmap_cache * , int); int _mmc_test_page(mmap_cache *); int _mmc_dump_page(mmap_cache *); Cache-FastMmap-1.58/lib/0000755000000000000000000000000015006062764013432 5ustar rootrootCache-FastMmap-1.58/lib/Cache/0000755000000000000000000000000015006062764014435 5ustar rootrootCache-FastMmap-1.58/lib/Cache/FastMmap.pm0000644000000000000000000013604115006062431016477 0ustar rootrootpackage Cache::FastMmap; =head1 NAME Cache::FastMmap - Uses an mmap'ed file to act as a shared memory interprocess cache =head1 SYNOPSIS use Cache::FastMmap; # Uses vaguely sane defaults $Cache = Cache::FastMmap->new(); # Uses Storable to serialize $Value to bytes for storage $Cache->set($Key, $Value); $Value = $Cache->get($Key); $Cache = Cache::FastMmap->new(serializer => ''); # Stores stringified bytes of $Value directly $Cache->set($Key, $Value); $Value = $Cache->get($Key); =head1 ABSTRACT A shared memory cache through an mmap'ed file. It's core is written in C for performance. It uses fcntl locking to ensure multiple processes can safely access the cache at the same time. It uses a basic LRU algorithm to keep the most used entries in the cache. =head1 DESCRIPTION In multi-process environments (eg mod_perl, forking daemons, etc), it's common to want to cache information, but have that cache shared between processes. Many solutions already exist, and may suit your situation better: =over 4 =item * L - acts as a database, data is not automatically expired, slow =item * L - hash implementation is broken, data is not automatically expired, slow =item * L - lots of features, slow =item * L - lots of features, VERY slow. Uses IPC::ShareLite which freeze/thaws ALL data at each read/write =item * L - use your favourite RDBMS. can perform well, need a DB server running. very global. socket connection latency =item * L - similar to this module, in pure perl. slows down with larger pages =item * L - very fast (data ends up mostly in shared memory cache) but acts as a database overall, so data is not automatically expired =back In the case I was working on, I needed: =over 4 =item * Automatic expiry and space management =item * Very fast access to lots of small items =item * The ability to fetch/store many items in one go =back Which is why I developed this module. It tries to be quite efficient through a number of means: =over 4 =item * Core code is written in C for performance =item * It uses multiple pages within a file, and uses Fcntl to only lock a page at a time to reduce contention when multiple processes access the cache. =item * It uses a dual level hashing system (hash to find page, then hash within each page to find a slot) to make most C calls O(1) and fast =item * On each C, if there are slots and page space available, only the slot has to be updated and the data written at the end of the used data space. If either runs out, a re-organisation of the page is performed to create new slots/space which is done in an efficient way =back The class also supports read-through, and write-back or write-through callbacks to access the real data if it's not in the cache, meaning that code like this: my $Value = $Cache->get($Key); if (!defined $Value) { $Value = $RealDataSource->get($Key); $Cache->set($Key, $Value) } Isn't required, you instead specify in the constructor: Cache::FastMmap->new( ... context => $RealDataSourceHandle, read_cb => sub { $_[0]->get($_[1]) }, write_cb => sub { $_[0]->set($_[1], $_[2]) }, ); And then: my $Value = $Cache->get($Key); $Cache->set($Key, $NewValue); Will just work and will be read/written to the underlying data source as needed automatically. =head1 PERFORMANCE If you're storing relatively large and complex structures into the cache, then you're limited by the speed of the Storable module. If you're storing simple structures, or raw data, then Cache::FastMmap has noticeable performance improvements. See L for some comparisons to other modules. =head1 COMPATIBILITY Cache::FastMmap uses mmap to map a file as the shared cache space, and fcntl to do page locking. This means it should work on most UNIX like operating systems. Ash Berlin has written a Win32 layer using MapViewOfFile et al. to provide support for Win32 platform. =head1 MEMORY SIZE Because Cache::FastMmap mmap's a shared file into your processes memory space, this can make each process look quite large, even though it's just mmap'd memory that's shared between all processes that use the cache, and may even be swapped out if the cache is getting low usage. However, the OS will think your process is quite large, which might mean you hit some BSD::Resource or 'ulimits' you set previously that you thought were sane, but aren't anymore, so be aware. =head1 CACHE FILES AND OS ISSUES Because Cache::FastMmap uses an mmap'ed file, when you put values into the cache, you are actually "dirtying" pages in memory that belong to the cache file. Your OS will want to write those dirty pages back to the file on the actual physical disk, but the rate it does that at is very OS dependent. In Linux, you have some control over how the OS writes those pages back using a number of parameters in /proc/sys/vm dirty_background_ratio dirty_expire_centisecs dirty_ratio dirty_writeback_centisecs How you tune these depends heavily on your setup. As an interesting point, if you use a highmem linux kernel, a change between 2.6.16 and 2.6.20 made the kernel flush memory a LOT more. There's details in this kernel mailing list thread: L In most cases, people are not actually concerned about the persistence of data in the cache, and so are happy to disable writing of any cache data back to disk at all. Baically what they want is an in memory only shared cache. The best way to do that is to use a "tmpfs" filesystem and put all cache files on there. For instance, all our machines have a /tmpfs mount point that we create in /etc/fstab as: none /tmpfs tmpfs defaults,noatime,size=1000M 0 0 And we put all our cache files on there. The tmpfs filesystem is smart enough to only use memory as required by files actually on the tmpfs, so making it 1G in size doesn't actually use 1G of memory, it only uses as much as the cache files we put on it. In all cases, we ensure that we never run out of real memory, so the cache files effectively act just as named access points to shared memory. Some people have suggested using anonymous mmaped memory. Unfortunately we need a file descriptor to do the fcntl locking on, so we'd have to create a separate file on a filesystem somewhere anyway. It seems easier to just create an explicit "tmpfs" filesystem. =head1 PAGE SIZE AND KEY/VALUE LIMITS To reduce lock contention, Cache::FastMmap breaks up the file into pages. When you get/set a value, it hashes the key to get a page, then locks that page, and uses a hash table within the page to get/store the actual key/value pair. One consequence of this is that you cannot store values larger than a page in the cache at all. Attempting to store values larger than a page size will fail (the set() function will return false). Also keep in mind that each page has it's own hash table, and that we store the key and value data of each item. So if you are expecting to store large values and/or keys in the cache, you should use page sizes that are definitely larger than your largest key + value size + a few kbytes for the overhead. =head1 USAGE Because the cache uses shared memory through an mmap'd file, you have to make sure each process connects up to the file. There's probably two main ways to do this: =over 4 =item * Create the cache in the parent process, and then when it forks, each child will inherit the same file descriptor, mmap'ed memory, etc and just work. This is the recommended way. (BEWARE: This only works under UNIX as Win32 has no concept of forking) =item * Explicitly connect up in each forked child to the share file. In this case, make sure the file already exists and the children connect with init_file => 0 to avoid deleting the cache contents and possible race corruption conditions. Also be careful that multiple children may race to create the file at the same time, each overwriting and corrupting content. Use a separate lock file if you must to ensure only one child creates the file. (This is the only possible way under Win32) =back The first way is usually the easiest. If you're using the cache in a Net::Server based module, you'll want to open the cache in the C, because that's executed before the fork, but after the process ownership has changed and any chroot has been done. In mod_perl, just open the cache at the global level in the appropriate module, which is executed as the server is starting and before it starts forking children, but you'll probably want to chmod or chown the file to the permissions of the apache process. =head1 RELIABILITY Cache::FastMmap is being used in an extensive number of systems at L and is regarded as extremely stable and reliable. Development has in general slowed because there are currently no known bugs and no additional needed features at this time. =head1 METHODS =over 4 =cut # Modules/Export/XSLoader {{{ use 5.006; use strict; use warnings; use bytes; our $VERSION = '1.58'; require XSLoader; XSLoader::load('Cache::FastMmap', $VERSION); # Track currently live caches so we can cleanup in END {} # if we have empty_on_exit set our %LiveCaches; # Global time override for testing my $time_override; use constant FC_ISDIRTY => 1; use File::Spec; # }}} =item I Create a new Cache::FastMmap object. Basic global parameters are: =over 4 =item * B File to mmap for sharing of data. default on unix: /tmp/sharefile-$pid-$time-$random default on windows: %TEMP%\sharefile-$pid-$time-$random =item * B Clear any existing values and re-initialise file. Useful to do in a parent that forks off children to ensure that file is empty at the start (default: 0) B This is quite important to do in the parent to ensure a consistent file structure. The shared file is not perfectly transaction safe, and so if a child is killed at the wrong instant, it might leave the cache file in an inconsistent state. =item * B Use a serialization library to serialize perl data structures before storing in the cache. If not set, the raw value in the variable passed to set() is stored as a string. You must set this if you want to store anything other than basic scalar values. Supported values are: '' for none 'storable' for 'Storable' 'sereal' for 'Sereal' 'json' for 'JSON' [ $s, $d ] for custom serializer/de-serializer If this parameter has a value the module will attempt to load the associated package and then use the API of that package to serialize data before storing in the cache, and deserialize it upon retrieval from the cache. (default: 'storable') You can use a custom serializer/de-serializer by passing an array-ref with two values. The first should be a subroutine reference that takes the data to serialize as a single argument and returns an octet stream to store. The second should be a subroutine reference that takes the octet stream as a single argument and returns the original data structure. One thing to note, the data structure passed to the serializer is always a *scalar* reference to the original data passed in to the ->set(...) call. If your serializer doesn't support that, you might need to dereference it first before storing, but rembember to return a reference again in the de-serializer. (Note: Historically this module only supported a boolean value for the `raw_values` parameter and defaulted to 0, which meant it used Storable to serialze all values.) =item * B Deprecated. Use B above =item * B Compress the value (but not the key) before storing into the cache, using the compression package identified by the value of the parameter. Supported values are: 'zlib' for 'Compress::Zlib' 'lz4' for 'Compress::LZ4' 'snappy' for 'Compress::Snappy' [ $c, $d ] for custom compressor/de-compressor If this parameter has a value the module will attempt to load the associated package and then use the API of that package to compress data before storing in the cache, and uncompress it upon retrieval from the cache. (default: undef) You can use a custom compressor/de-compressor by passing an array-ref with two values. The first should be a subroutine reference that takes the data to compress as a single octet stream argument and returns an octet stream to store. The second should be a subroutine reference that takes the compressed octet stream as a single argument and returns the original uncompressed data. (Note: Historically this module only supported a boolean value for the `compress` parameter and defaulted to use Compress::Zlib. The note for the old `compress` parameter stated: "Some initial testing shows that the uncompressing tends to be very fast, though the compressing can be quite slow, so it's probably best to use this option only if you know values in the cache are long-lived and have a high hit rate." Comparable test results for the other compression tools are not yet available; submission of benchmarks welcome. However, the documentation for the 'Snappy' library (http://google.github.io/snappy/) states: For instance, compared to the fastest mode of zlib, Snappy is an order of magnitude faster for most inputs, but the resulting compressed files are anywhere from 20% to 100% bigger. ) =item * B Deprecated. Please use B, see above. =item * B Enable some basic statistics capturing. When enabled, every read to the cache is counted, and every read to the cache that finds a value in the cache is also counted. You can then retrieve these values via the get_statistics() call. This causes every read action to do a write on a page, which can cause some more IO, so it's disabled by default. (default: 0) =item * B Maximum time to hold values in the cache in seconds. A value of 0 means does no explicit expiry time, and values are expired only based on LRU usage. Can be expressed as 1m, 1h, 1d for minutes/hours/days respectively. (default: 0) =back You may specify the cache size as: =over 4 =item * B Size of cache. Can be expresses as 1k, 1m for kilobytes or megabytes respectively. Automatically guesses page size/page count values. =back Or specify explicit page size/page count values. If none of these are specified, the values page_size = 64k and num_pages = 89 are used. =over 4 =item * B Size of each page. Must be a power of 2 between 4k and 1024k. If not, is rounded to the nearest value. =item * B Number of pages. Should be a prime number for best hashing =back The cache allows the use of callbacks for reading/writing data to an underlying data store. =over 4 =item * B Opaque reference passed as the first parameter to any callback function if specified =item * B Callback to read data from the underlying data store. Called as: $read_cb->($context, $Key) Should return the value to use. This value will be saved in the cache for future retrievals. Return undef if there is no value for the given key =item * B Callback to write data to the underlying data store. Called as: $write_cb->($context, $Key, $Value, $ExpiryTime) In 'write_through' mode, it's always called as soon as a I is called on the Cache::FastMmap class. In 'write_back' mode, it's called when a value is expunged from the cache if it's been changed by a I rather than read from the underlying store with the I above. Note: Expired items do result in the I being called if 'write_back' caching is enabled and the item has been changed. You can check the $ExpiryTime against C if you only want to write back values which aren't expired. Also remember that I may be called in a different process to the one that placed the data in the cache in the first place =item * B Callback to delete data from the underlying data store. Called as: $delete_cb->($context, $Key) Called as soon as I is called on the Cache::FastMmap class =item * B If set to true, then if the I is called and it returns undef to say nothing was found, then that information is stored in the cache, so that next time a I is called on that key, undef is returned immediately rather than again calling the I =item * B Either 'write_back' or 'write_through'. (default: write_through) =item * B If you're using a callback function, then normally the cache is not re-enterable, and attempting to call a get/set on the cache will cause an error. By setting this to one, the cache will unlock any pages before calling the callback. During the unlock time, other processes may change data in current cache page, causing possible unexpected effects. You shouldn't set this unless you know you want to be able to recall to the cache within a callback. (default: 0) =item * B When you have 'write_back' mode enabled, then you really want to make sure all values from the cache are expunged when your program exits so any changes are written back. The trick is that we only want to do this in the parent process, we don't want any child processes to empty the cache when they exit. So if you set this, it takes the PID via $$, and only calls empty in the DESTROY method if $$ matches the pid we captured at the start. (default: 0) =item * B Unlink the share file when the cache is destroyed. As with empty_on_exit, this will only unlink the file if the DESTROY occurs in the same PID that the cache was created in so that any forked children don't unlink the file. This value defaults to 1 if the share_file specified does not already exist. If the share_file specified does already exist, it defaults to 0. =item * B Sets an alarm(10) before each page is locked via fcntl(F_SETLKW) to catch any deadlock. This used to be the default behaviour, but it's not really needed in the default case and could clobber sub-second Time::HiRes alarms setup by other code. Defaults to 0. =back =cut sub new { my $Proto = shift; my $Class = ref($Proto) || $Proto; # If first item is a hash ref, use it as arguments my %Args = ref($_[0]) eq 'HASH' ? %{shift()} : @_; my $Self = {}; bless ($Self, $Class); # Work out cache file and whether to init my $share_file = $Args{share_file}; if (!$share_file) { my $tmp_dir = File::Spec->tmpdir; $share_file = File::Spec->catfile($tmp_dir, "sharefile"); $share_file .= "-" . $$ . "-" . time . "-" . int(rand(100000)); } !ref($share_file) || die "share_file argument was a reference"; $Self->{share_file} = $share_file; my $permissions = $Args{permissions}; my $init_file = $Args{init_file} ? 1 : 0; my $test_file = $Args{test_file} ? 1 : 0; my $enable_stats = $Args{enable_stats} ? 1 : 0; my $catch_deadlocks = $Args{catch_deadlocks} ? 1 : 0; # Worth out unlink default if not specified if (!exists $Args{unlink_on_exit}) { $Args{unlink_on_exit} = -f($share_file) ? 0 : 1; } # Serialise stored values? my $serializer = $Args{serializer}; $serializer = ($Args{raw_values} ? '' : 'storable') if !defined $serializer; if ($serializer) { if (ref $serializer eq 'ARRAY') { $Self->{serialize} = $serializer->[0]; $Self->{deserialize} = $serializer->[1]; } elsif ($serializer eq 'storable') { eval "require Storable;" || die "Could not load serialization package: Storable : $@"; $Self->{serialize} = Storable->can("freeze"); $Self->{deserialize} = Storable->can("thaw"); } elsif ($serializer eq 'sereal') { eval "require Sereal::Encoder; require Sereal::Decoder;" || die "Could not load serialization package: Sereal : $@"; my $SerealEnc = Sereal::Encoder->new(); my $SerealDec = Sereal::Decoder->new(); $Self->{serialize} = sub { $SerealEnc->encode(@_); }; $Self->{deserialize} = sub { $SerealDec->decode(@_); }; } elsif ($serializer eq 'json') { eval "require JSON;" || die "Could not load serialization package: JSON : $@"; my $JSON = JSON->new->utf8->allow_nonref; $Self->{serialize} = sub { $JSON->encode(${$_[0]}); }; $Self->{deserialize} = sub { \$JSON->decode($_[0]); }; } else { die "Unrecognized value >$serializer< for `serializer` parameter"; } } # Compress stored values? my $compressor = $Args{compressor}; $compressor = ($Args{compress} ? 'zlib' : 0) if !defined $compressor; my %known_compressors = ( zlib => 'Compress::Zlib', lz4 => 'Compress::LZ4', snappy => 'Compress::Snappy', ); if ( $compressor ) { if (ref $compressor eq 'ARRAY') { $Self->{compress} = $compressor->[0]; $Self->{uncompress} = $compressor->[1]; } elsif (my $compressor_module = $known_compressors{$compressor}) { eval "require $compressor_module;" || die "Could not load compression package: $compressor_module : $@"; # LZ4 and Snappy use same API if ($compressor_module eq 'Compress::LZ4' || $compressor_module eq 'Compress::Snappy') { $Self->{compress} = $compressor_module->can("compress"); $Self->{uncompress} = $compressor_module->can("uncompress"); } elsif ($compressor_module eq 'Compress::Zlib') { $Self->{compress} = $compressor_module->can("memGzip"); # (gunzip from tmp var: https://rt.cpan.org/Ticket/Display.html?id=72945) my $uncompress = $compressor_module->can("memGunzip"); $Self->{uncompress} = sub { &$uncompress(my $Tmp = shift) }; } } else { die "Unrecognized value >$compressor< for `compressor` parameter"; } } # If using empty_on_exit, need to track used caches my $empty_on_exit = $Self->{empty_on_exit} = int($Args{empty_on_exit} || 0); # Need Scalar::Util::weaken to track open caches if ($empty_on_exit) { eval "use Scalar::Util qw(weaken); 1;" || die "Could not load Scalar::Util module: $@"; } # Work out expiry time in seconds my $expire_time = $Self->{expire_time} = parse_expire_time($Args{expire_time}); # Function rounds to the nearest power of 2 sub RoundPow2 { return int(2 ** int(log($_[0])/log(2)) + 0.1); } # Work out cache size my ($cache_size, $num_pages, $page_size); my %Sizes = (k => 1024, m => 1024*1024); if ($cache_size = $Args{cache_size}) { $cache_size *= $Sizes{lc($1)} if $cache_size =~ s/([km])$//i; if ($num_pages = $Args{num_pages}) { $page_size = RoundPow2($cache_size / $num_pages); $page_size = 4096 if $page_size < 4096; } else { $page_size = $Args{page_size} || 65536; $page_size *= $Sizes{lc($1)} if $page_size =~ s/([km])$//i; $page_size = 4096 if $page_size < 4096; # Increase num_pages till we exceed $num_pages = 89; if ($num_pages * $page_size <= $cache_size) { while ($num_pages * $page_size <= $cache_size) { $num_pages = $num_pages * 2 + 1; } } else { while ($num_pages * $page_size > $cache_size) { $num_pages = int(($num_pages-1) / 2); } $num_pages = $num_pages * 2 + 1; } } } else { ($num_pages, $page_size) = @Args{qw(num_pages page_size)}; $num_pages ||= 89; $page_size ||= 65536; $page_size *= $Sizes{lc($1)} if $page_size =~ s/([km])$//i; $page_size = RoundPow2($page_size); } $cache_size = $num_pages * $page_size; @$Self{qw(cache_size num_pages page_size)} = ($cache_size, $num_pages, $page_size); # Number of slots to start in each page my $start_slots = int($Args{start_slots} || 0) || 89; # Save read through/write back/write through details my $write_back = ($Args{write_action} || 'write_through') eq 'write_back'; @$Self{qw(context read_cb write_cb delete_cb)} = @Args{qw(context read_cb write_cb delete_cb)}; @$Self{qw(cache_not_found allow_recursive write_back)} = (@Args{qw(cache_not_found allow_recursive)}, $write_back); @$Self{qw(unlink_on_exit enable_stats)} = (@Args{qw(unlink_on_exit)}, $enable_stats); # Save pid $Self->{pid} = $$; # Initialise C cache code my $Cache = fc_new(); $Self->{Cache} = $Cache; # Setup cache parameters fc_set_param($Cache, 'init_file', $init_file); fc_set_param($Cache, 'test_file', $test_file); fc_set_param($Cache, 'page_size', $page_size); fc_set_param($Cache, 'num_pages', $num_pages); fc_set_param($Cache, 'expire_time', $expire_time); fc_set_param($Cache, 'share_file', $share_file); fc_set_param($Cache, 'permissions', $permissions) if defined $permissions; fc_set_param($Cache, 'start_slots', $start_slots); fc_set_param($Cache, 'catch_deadlocks', $catch_deadlocks); fc_set_param($Cache, 'enable_stats', $enable_stats); # And initialise it fc_init($Cache); # Track cache if need to empty on exit weaken($LiveCaches{ref($Self)} = $Self) if $empty_on_exit; # All done, return PERL hash ref as class return $Self; } =item I Search cache for given Key. Returns undef if not found. If I specified and not found, calls the callback to try and find the value for the key, and if found (or 'cache_not_found' is set), stores it into the cache and returns the found value. I<%Options> is optional, and is used by get_and_set() to control the locking behaviour. For now, you should probably ignore it unless you read the code to understand how it works =cut sub get { my ($Self, $Cache) = ($_[0], $_[0]->{Cache}); # Hash value, lock page, read result my ($HashPage, $HashSlot) = fc_hash($Cache, $_[1]); my $Unlock = $Self->_lock_page($HashPage); my ($Val, $Flags, $Found, $ExpireOn) = fc_read($Cache, $HashSlot, $_[1]); # Value not found, check underlying data store if (!$Found && (my $read_cb = $Self->{read_cb})) { # Callback to read from underlying data store # (unlock page first if we allow recursive calls $Unlock = undef if $Self->{allow_recursive}; $Val = eval { $read_cb->($Self->{context}, $_[1]); }; my $Err = $@; $Unlock = $Self->_lock_page($HashPage) if $Self->{allow_recursive}; # Pass on any error die $Err if $Err; # If we found it, or want to cache not-found, store back into our cache if (defined $Val || $Self->{cache_not_found}) { # Are we doing writeback's? If so, need to mark as dirty in cache my $write_back = $Self->{write_back}; $Val = $Self->{serialize}(\$Val) if $Self->{serialize}; $Val = $Self->{compress}($Val) if $Self->{compress}; # Get key/value len (we've got 'use bytes'), and do expunge check to # create space if needed my $KVLen = length($_[1]) + (defined($Val) ? length($Val) : 0); $Self->_expunge_page(2, 1, $KVLen); fc_write($Cache, $HashSlot, $_[1], $Val, -1, 0); } } # Unlock page and return any found value # Unlock is done only if we're not in the middle of a get_set() operation. my $SkipUnlock = $_[2] && $_[2]->{skip_unlock}; $Unlock = undef unless $SkipUnlock; # If not using raw values, use thaw() to turn data back into object $Val = $Self->{uncompress}($Val) if defined($Val) && $Self->{compress}; $Val = ${$Self->{deserialize}($Val)} if defined($Val) && $Self->{deserialize}; # If explicitly asked to skip unlocking, we return the reference to the unlocker return ($Val, $Unlock, { $Found ? (expire_on => $ExpireOn) : () }) if $SkipUnlock; return $Val; } =item I Store specified key/value pair into cache I<%Options> is optional. If it's not a hash reference, it's assumed to be an explicit expiry time for the key being set, this is to make set() compatible with the Cache::Cache interface If a hash is passed, the only useful entries right now are expire_on to set an explicit expiry time for this entry (epoch seconds), or expire_time to set an explicit relative future expiry time for this entry in seconds/minutes/days in the same format as passed to the new constructor. Some other options are used internally, such as by get_and_set() to control the locking behaviour. For now, you should probably ignore it unless you read the code to understand how it works This method returns true if the value was stored in the cache, false otherwise. See the PAGE SIZE AND KEY/VALUE LIMITS section for more details. =cut sub set { my ($Self, $Cache) = ($_[0], $_[0]->{Cache}); my $Val = $Self->{serialize} ? $Self->{serialize}(\$_[2]) : $_[2]; $Val = $Self->{compress}($Val) if $Self->{compress}; # Get opts, make compatible with Cache::Cache interface my $Opts = defined($_[3]) ? (ref($_[3]) ? $_[3] : { expire_time => $_[3] }) : undef; # expire_on takes precedence, otherwise use expire_time if present my $expire_on = defined($Opts) ? ( defined $Opts->{expire_on} ? $Opts->{expire_on} : (defined $Opts->{expire_time} ? parse_expire_time($Opts->{expire_time}, _time()): -1) ) : -1; # Hash value, lock page my ($HashPage, $HashSlot) = fc_hash($Cache, $_[1]); # If skip_lock is passed, it's a *reference* to an existing lock we # have to take and delete so we can cleanup below before calling # the callback my $Unlock = $Opts && $Opts->{skip_lock}; if ($Unlock) { ($Unlock, $$Unlock) = ($$Unlock, undef); } else { $Unlock = $Self->_lock_page($HashPage); } # Are we doing writeback's? If so, need to mark as dirty in cache my $write_back = $Self->{write_back}; # Get key/value len (we've got 'use bytes'), and do expunge check to # create space if needed my $KVLen = length($_[1]) + (defined($Val) ? length($Val) : 0); $Self->_expunge_page(2, 1, $KVLen); # Now store into cache my $DidStore = fc_write($Cache, $HashSlot, $_[1], $Val, $expire_on, $write_back ? FC_ISDIRTY : 0); # Unlock page $Unlock = undef; # If we're doing write-through, or write-back and didn't get into cache, # write back to the underlying store if ((!$write_back || !$DidStore) && (my $write_cb = $Self->{write_cb})) { eval { $write_cb->($Self->{context}, $_[1], $_[2]); }; } return $DidStore; } =item I Atomically retrieve and set the value of a Key. The page is locked while retrieving the $Key and is unlocked only after the value is set, thus guaranteeing the value does not change between the get and set operations. $AtomicSub is a reference to a subroutine that is called to calculate the new value to store. $AtomicSub gets $Key, the current value from the cache, and an options hash as paramaters. Currently the only option passed is the expire_on of the item. It should return the new value to set in the cache for the given $Key, and an optional hash of arguments in the same format as would be passed to a C call. If $AtomicSub returns an empty list, no value is stored back in the cache. This avoids updating the expiry time on an entry if you want to do a "get if in cache, store if not present" type callback. For example: =over 4 =item * To atomically increment a value in the cache $Cache->get_and_set($Key, sub { return $_[1]+1; }); =item * To add an item to a cached list and set the expiry time depending on the size of the list $Cache->get_and_set($Key, sub ($, $v) { push @$v, $item; return ($v, { expire_time => @$v > 2 ? '10s' : '2m' }); }); =item * To update a counter, but maintain the original expiry time $Cache->get_and_set($Key, sub { return ($_[1]+1, { expire_on => $_[2]->{expire_on} ); }); =back In scalar context the return value from C, is the *new* value stored back into the cache. In list context, a two item array is returned; the new value stored back into the cache and a boolean that's true if the value was stored in the cache, false otherwise. See the PAGE SIZE AND KEY/VALUE LIMITS section for more details. Notes: =over 4 =item * Do not perform any get/set operations from the callback sub, as these operations lock the page and you may end up with a dead lock! =item * If your sub does a die/throws an exception, the page will correctly be unlocked (1.15 onwards) =back =cut sub get_and_set { my ($Self, $Cache) = ($_[0], $_[0]->{Cache}); my ($Value, $Unlock, $Opts) = $Self->get($_[1], { skip_unlock => 1 }); # If this throws an error, $Unlock ref will still unlock page my @NewValue = $_[2]->($_[1], $Value, $Opts); my $DidStore = 0; if (@NewValue) { ($Value, my $Opts) = @NewValue; $DidStore = $Self->set($_[1], $Value, { skip_lock => \$Unlock, %{$Opts || {}} }); } return wantarray ? ($Value, $DidStore) : $Value; } =item I Delete the given key from the cache I<%Options> is optional, and is used by get_and_remove() to control the locking behaviour. For now, you should probably ignore it unless you read the code to understand how it works =cut sub remove { my ($Self, $Cache) = ($_[0], $_[0]->{Cache}); # Hash value, lock page, read result my ($HashPage, $HashSlot) = fc_hash($Cache, $_[1]); # If skip_lock is passed, it's a *reference* to an existing lock we # have to take and delete so we can cleanup below before calling # the callback my $Unlock = $_[2] && $_[2]->{skip_lock}; if ($Unlock) { ($Unlock, $$Unlock) = ($$Unlock, undef); } else { $Unlock = $Self->_lock_page($HashPage); } my ($DidDel, $Flags) = fc_delete($Cache, $HashSlot, $_[1]); $Unlock = undef; # If we deleted from the cache, and it's not dirty, also delete # from underlying store if ((!$DidDel || ($DidDel && !($Flags & FC_ISDIRTY))) && (my $delete_cb = $Self->{delete_cb})) { eval { $delete_cb->($Self->{context}, $_[1]); }; } return $DidDel; } =item I Atomically retrieve value of a Key while removing it from the cache. The page is locked while retrieving the $Key and is unlocked only after the value is removed, thus guaranteeing the value stored by someone else isn't removed by us. =cut sub get_and_remove { my ($Self, $Cache) = ($_[0], $_[0]->{Cache}); my ($Value, $Unlock) = $Self->get($_[1], { skip_unlock => 1 }); my $DidDel = $Self->remove($_[1], { skip_lock => \$Unlock }); return wantarray ? ($Value, $DidDel) : $Value; } =item I Explicitly expire the given $Key. For a cache in write-back mode, this will cause the item to be written back to the underlying store if dirty, otherwise it's the same as removing the item. =cut sub expire { my ($Self, $Cache) = ($_[0], $_[0]->{Cache}); # Hash value, lock page, read result my ($HashPage, $HashSlot) = fc_hash($Cache, $_[1]); my $Unlock = $Self->_lock_page($HashPage); my ($Val, $Flags, $Found) = fc_read($Cache, $HashSlot, $_[1]); # If we found it, remove it if ($Found) { (undef, $Flags) = fc_delete($Cache, $HashSlot, $_[1]); } $Unlock = undef; # If it's dirty, write it back if (($Flags & FC_ISDIRTY) && (my $write_cb = $Self->{write_cb})) { eval { $write_cb->($Self->{context}, $_[1], $Val); }; } return $Found; } =item I Clear all items from the cache Note: If you're using callbacks, this has no effect on items in the underlying data store. No delete callbacks are made =cut sub clear { my $Self = shift; $Self->_expunge_all(1, 0); } =item I Clear all expired items from the cache Note: If you're using callbacks, this has no effect on items in the underlying data store. No delete callbacks are made, and no write callbacks are made for the expired data =cut sub purge { my $Self = shift; $Self->_expunge_all(0, 0); } =item I Empty all items from the cache, or if $OnlyExpired is true, only expired items. Note: If 'write_back' mode is enabled, any changed items are written back to the underlying store. Expired items are written back to the underlying store as well. =cut sub empty { my $Self = shift; $Self->_expunge_all($_[0] ? 0 : 1, 1); } =item I Get a list of keys/values held in the cache. May immediately be out of date because of the shared access nature of the cache If $Mode == 0, an array of keys is returned If $Mode == 1, then an array of hashrefs, with 'key', 'last_access', 'expire_on' and 'flags' keys is returned If $Mode == 2, then hashrefs also contain 'value' key =cut sub get_keys { my ($Self, $Cache) = ($_[0], $_[0]->{Cache}); my $Mode = $_[1] || 0; my ($Uncompress, $Deserialize) = @$Self{qw(uncompress deserialize)}; return fc_get_keys($Cache, $Mode) if $Mode <= 1 || ($Mode == 2 && !$Uncompress && !$Deserialize); # If we're getting values as well, and they're not raw, unfreeze them my @Details = fc_get_keys($Cache, 2); for (@Details) { my $Val = $_->{value}; if (defined $Val) { $Val = $Uncompress->($Val) if $Uncompress; $Val = ${$Deserialize->($Val)} if $Deserialize; $_->{value} = $Val; } } return @Details; } =item I Returns a two value list of (nreads, nreadhits). This only works if you passed enable_stats in the constructor nreads is the total number of read attempts done on the cache since it was created nreadhits is the total number of read attempts done on the cache since it was created that found the key/value in the cache If $Clear is true, the values are reset immediately after they are retrieved =cut sub get_statistics { my ($Self, $Cache) = ($_[0], $_[0]->{Cache}); my $Clear = $_[1]; my ($NReads, $NReadHits) = (0, 0); for (0 .. $Self->{num_pages}-1) { my $Unlock = $Self->_lock_page($_); my ($PNReads, $PNReadHits) = fc_get_page_details($Cache); $NReads += $PNReads; $NReadHits += $PNReadHits; fc_reset_page_details($Cache) if $Clear; $Unlock = undef; } return ($NReads, $NReadHits); } =item I The two multi_xxx routines act a bit differently to the other routines. With the multi_get, you pass a separate PageKey value and then multiple keys. The PageKey value is hashed, and that page locked. Then that page is searched for each key. It returns a hash ref of Key => Value items found in that page in the cache. The main advantage of this is just a speed one, if you happen to need to search for a lot of items on each call. For instance, say you have users and a bunch of pieces of separate information for each user. On a particular run, you need to retrieve a sub-set of that information for a user. You could do lots of get() calls, or you could use the 'username' as the page key, and just use one multi_get() and multi_set() call instead. A couple of things to note: =over 4 =item 1. This makes multi_get()/multi_set() and get()/set() incompatible. Don't mix calls to the two, because you won't find the data you're expecting =item 2. The writeback and callback modes of operation do not work with multi_get()/multi_set(). Don't attempt to use them together. =back =cut sub multi_get { my ($Self, $Cache) = ($_[0], $_[0]->{Cache}); # Hash value page key, lock page my ($HashPage, $HashSlot) = fc_hash($Cache, $_[1]); my $Unlock = $Self->_lock_page($HashPage); # For each key to find my ($Keys, %KVs) = ($_[2]); for (@$Keys) { # Hash key to get slot in this page and read my $FinalKey = "$_[1]-$_"; (undef, $HashSlot) = fc_hash($Cache, $FinalKey); my ($Val, $Flags, $Found, $ExpireOn) = fc_read($Cache, $HashSlot, $FinalKey); next unless $Found; # If not using raw values, use thaw() to turn data back into object $Val = $Self->{uncompress}($Val) if defined($Val) && $Self->{compress}; $Val = ${$Self->{deserialize}($Val)} if defined($Val) && $Self->{deserialize}; # Save to return $KVs{$_} = $Val; } # Unlock page and return any found value $Unlock = undef; return \%KVs; } =item I $Value1, $Key2 => $Value2, ... }, [ \%Options ])> Store specified key/value pair into cache =cut sub multi_set { my ($Self, $Cache) = ($_[0], $_[0]->{Cache}); # Get opts, make compatible with Cache::Cache interface my $Opts = defined($_[3]) ? (ref($_[3]) ? $_[3] : { expire_time => $_[3] }) : undef; # expire_on takes precedence, otherwise use expire_time if present my $expire_on = defined($Opts) ? ( defined $Opts->{expire_on} ? $Opts->{expire_on} : (defined $Opts->{expire_time} ? parse_expire_time($Opts->{expire_time}, _time()): -1) ) : -1; # Hash page key value, lock page my ($HashPage, $HashSlot) = fc_hash($Cache, $_[1]); my $Unlock = $Self->_lock_page($HashPage); # Loop over each key/value storing into this page my $KVs = $_[2]; while (my ($Key, $Val) = each %$KVs) { $Val = $Self->{serialize}(\$Val) if $Self->{serialize}; $Val = $Self->{compress}($Val) if $Self->{compress}; # Get key/value len (we've got 'use bytes'), and do expunge check to # create space if needed my $FinalKey = "$_[1]-$Key"; my $KVLen = length($FinalKey) + length($Val); $Self->_expunge_page(2, 1, $KVLen); # Now hash key and store into page (undef, $HashSlot) = fc_hash($Cache, $FinalKey); my $DidStore = fc_write($Cache, $HashSlot, $FinalKey, $Val, $expire_on, 0); } # Unlock page $Unlock = undef; return 1; } =back =cut =head1 INTERNAL METHODS =over 4 =cut =item I<_expunge_all($Mode, $WB)> Expunge all items from the cache Expunged items (that have not expired) are written back to the underlying store if write_back is enabled =cut sub _expunge_all { my ($Self, $Cache, $Mode, $WB) = ($_[0], $_[0]->{Cache}, $_[1], $_[2]); # Repeat expunge for each page for (0 .. $Self->{num_pages}-1) { my $Unlock = $Self->_lock_page($_); $Self->_expunge_page($Mode, $WB, -1); $Unlock = undef; } } =item I<_expunge_page($Mode, $WB, $Len)> Expunge items from the current page to make space for $Len bytes key/value items Expunged items (that have not expired) are written back to the underlying store if write_back is enabled =cut sub _expunge_page { my ($Self, $Cache, $Mode, $WB, $Len) = ($_[0], $_[0]->{Cache}, @_[1 .. 3]); # If writeback mode, need to get expunged items to write back my $write_cb = $Self->{write_back} && $WB ? $Self->{write_cb} : undef; my @WBItems = fc_expunge($Cache, $Mode, $write_cb ? 1 : 0, $Len); my ($Uncompress, $Deserialize) = @$Self{qw(uncompress deserialize)}; for (@WBItems) { next if !($_->{flags} & FC_ISDIRTY); my $Val = $_->{value}; if (defined $Val) { $Val = $Uncompress->($Val) if $Uncompress; $Val = ${$Deserialize->($Val)} if $Deserialize; } eval { $write_cb->($Self->{context}, $_->{key}, $Val, $_->{expire_on}); }; } } =item I<_lock_page($Page)> Lock a given page in the cache, and return an object reference that when DESTROYed, unlocks the page =cut sub _lock_page { my ($Self, $Cache) = ($_[0], $_[0]->{Cache}); my $Unlock = Cache::FastMmap::OnLeave->new(sub { fc_unlock($Cache) if fc_is_locked($Cache); }); fc_lock($Cache, $_[1]); return $Unlock; } sub _time { $time_override ? $time_override : time; } sub _set_time_override { my $Time = shift; $time_override = $Time; fc_set_time_override($Time || 0); } my %Times = ('' => 1, s => 1, m => 60, h => 60*60, d => 24*60*60, w => 7*24*60*60); sub parse_expire_time { my $expire_time = shift || ''; return 0 if $expire_time eq 'never'; return @_ ? shift : 1 if $expire_time eq 'now'; my $offset = $expire_time =~ /^(\d+)\s*([mhdws]?)/i ? $1 * $Times{lc($2)} : 0; return $offset + (@_ ? shift : 0); } sub cleanup { my ($Self, $Cache) = ($_[0], $_[0]->{Cache}); # Avoid potential double cleanup return if $Self->{cleaned}; $Self->{cleaned} = 1; # Expunge all entries on exit if requested and in parent process if ($Self->{empty_on_exit} && $Cache && $Self->{pid} == $$) { $Self->empty(); } if ($Cache) { fc_close($Cache); $Cache = undef; delete $Self->{Cache}; } unlink($Self->{share_file}) if $Self->{unlink_on_exit} && $Self->{pid} == $$; } sub DESTROY { my $Self = shift; $Self->cleanup(); delete $LiveCaches{ref($Self)} if $Self->{empty_on_exit}; } sub END { while (my (undef, $Self) = each %LiveCaches) { # Weak reference, might be undef already $Self->cleanup() if $Self; } %LiveCaches = (); } sub CLONE { die "Cache::FastMmap does not support threads sorry"; } 1; package Cache::FastMmap::OnLeave; use strict; sub new { my $Class = shift; my $Ref = \$_[0]; bless $Ref, $Class; return $Ref; } sub disable { ${$_[0]} = undef; } sub DESTROY { my $e = $@; # Save errors from code calling us eval { my $Ref = shift; $$Ref->() if $$Ref; }; # $e .= " (in cleanup) $@" if $@; $@ = $e; } 1; __END__ =back =cut =head1 INCOMPATIBLE CHANGES =over 4 =item * From 1.15 =over 4 =item * Default share_file name is no-longer /tmp/sharefile, but /tmp/sharefile-$pid-$time. This ensures that different runs/processes don't interfere with each other, but means you may not connect up to the file you expect. You should be choosing an explicit name in most cases. On Unix systems, you can pass in the environment variable TMPDIR to override the default directory of /tmp =item * The new option unlink_on_exit defaults to true if you pass a filename for the share_file which doesn't already exist. This means if you have one process that creates the file, and another that expects the file to be there, by default it won't be. Otherwise the defaults seem sensible to cleanup unneeded share files rather than leaving them around to accumulate. =back =item * From 1.29 =over 4 =item * Default share_file name is no longer /tmp/sharefile-$pid-$time but /tmp/sharefile-$pid-$time-$random. =back =item * From 1.31 =over 4 =item * Before 1.31, if you were using raw_values => 0 mode, then the write_cb would be called with raw frozen data, rather than the thawed object. From 1.31 onwards, it correctly calls write_cb with the thawed object value (eg what was passed to the ->set() call in the first place) =back =item * From 1.36 =over 4 =item * Before 1.36, an alarm(10) would be set before each attempt to lock a page. The only purpose of this was to detect deadlocks, which should only happen if the Cache::FastMmap code was buggy, or a callback function in get_and_set() made another call into Cache::FastMmap. However this added unnecessary extra system calls for every lookup, and for users using Time::HiRes, it could clobber any existing alarms that had been set with sub-second resolution. So this has now been made an optional feature via the catch_deadlocks option passed to new. =back =item * From 1.52 =over 4 =item * The term expire_time was overloaded in the code to sometimes mean a relative future time (e.g. as passed to new constructor) or an absolute unix epoch (e.g. as returned from get_keys(2)). To avoid this confusion, the code now uses expire_time to always means a relative future time, and expire_on to mean an absolute epoch time. You can use either as an optional argument to a set() call. Since expire_time was used in the constructor and is likely more commonly used, I changed the result of get_keys(2) so it now returns expire_on rather than expire_time. =back =back =cut =head1 SEE ALSO L, L, L, L, L, L, L Latest news/details can also be found at: L Available on github at: L =cut =head1 AUTHOR Rob Mueller L =cut =head1 COPYRIGHT AND LICENSE Copyright (C) 2003-2017 by FastMail Pty Ltd This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Cache-FastMmap-1.58/README0000644000000000000000000000146315006056063013543 0ustar rootrootCache::FastMmap =========================== A shared memory cache through an mmap'ed file. It's core is written in C for performance. It uses fcntl locking to ensure multiple processes can safely access the cache at the same time. It uses a basic LRU algorithm to keep the most used entries in the cache. INSTALLATION To install this module type the following: perl Makefile.PL make make test make install DEPENDENCIES Storable if you want to store complex structures AUTHOR Rob Mueller DOCUMENTATION See the POD documentation. Viewable online at CPAN https://metacpan.org/pod/Cache::FastMmap COPYRIGHT AND LICENCE Copyright (C) 2003-2020 by Fastmail Pty Ltd This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Cache-FastMmap-1.58/Makefile.PL0000644000000000000000000000143615006056063014635 0ustar rootrootuse 5.006; use ExtUtils::MakeMaker; WriteMakefile( 'NAME' => 'Cache::FastMmap', 'VERSION_FROM' => 'lib/Cache/FastMmap.pm', 'ABSTRACT_FROM' => 'lib/Cache/FastMmap.pm', 'AUTHOR' => 'Rob Mueller ', 'LICENSE' => 'perl', 'PREREQ_PM' => { 'Storable' => 0, 'Test::Deep' => 0, }, 'LIBS' => [''], 'INC' => '-I.', 'OBJECT' => 'FastMmap.o mmap_cache.o ' . ($^O eq 'MSWin32' ? 'win32.o' : 'unix.o'), 'META_MERGE' => { 'resources' => { 'bugtracker' => 'https://github.com/robmueller/cache-fastmmap/issues', 'repository' => 'https://github.com/robmueller/cache-fastmmap', }, }, # 'OPTIMIZE' => '-g -DDEBUG -ansi -pedantic', ); Cache-FastMmap-1.58/MANIFEST.SKIP0000644000000000000000000000014515006056063014555 0ustar rootroot^\.git ^Cache-FastMmap pm_to_blib blib \.o$ \.bs$ ^Makefile$ ^FastMmap\.c$ ^MYMETA\. ^MANIFEST\.bak$ Cache-FastMmap-1.58/META.yml0000644000000000000000000000135615006062764014142 0ustar rootroot--- abstract: "Uses an mmap'ed file to act as a shared memory interprocess cache" author: - 'Rob Mueller ' build_requires: ExtUtils::MakeMaker: '0' configure_requires: ExtUtils::MakeMaker: '0' dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 7.64, CPAN::Meta::Converter version 2.150010' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: Cache-FastMmap no_index: directory: - t - inc requires: Storable: '0' Test::Deep: '0' resources: bugtracker: https://github.com/robmueller/cache-fastmmap/issues repository: https://github.com/robmueller/cache-fastmmap version: '1.58' x_serialization_backend: 'CPAN::Meta::YAML version 0.018' Cache-FastMmap-1.58/Changes0000644000000000000000000002407415006062524014160 0ustar rootrootRevision history for Perl extension Cache::FastMmap. 1.57 Mon May 5 16:25 2025 - Catch a rare bug if someone closes our underlying file handle unexpectedly 1.57 Thu Sep 30 16:25 2021 - Add expire($key) method to allow explicitly expiring a key from the cache. In write-back mode, if the key is dirty it will be written back, in other modes it's the same as remove($key) 1.56 Mon Dec 14 14:35 2020 - Update MANIFEST to include all tests. It hasn't been updated in a while 1.55 Mon Dec 14 12:10 2020 - Add ability to override internal value of 'time' everywhere to make tests that check expiry of items faster and more robust 1.54 Sat Dec 12 13:40 2020 - Add Test::Deep as dependency to Makefile.PL 1.53 Thu Dec 10 13:40 2020 - Handle expire_on being undef (use cache default) and return undef if existing value not found in cache. Makes get_and_set which passes on expire_on just work in "doesn't exist" case 1.52 Thu Dec 10 12:20 2020 - Fix bug where a get() on a key that was expired would cause that key to be deleted and never written back even if it was dirty - Added new expire_on naming so that expire_time (relative future time) and expire_on (absolute unix epoch time) are now clear and distinct - Allow setting expire_on when doing a set() call, which is useful from get_and_set() to maintain an items absolute expiry time 1.51 Wed Nov 11 17:15 2020 - Skip JSON/Sereal tests if modules not present - Updated .gitignore Thanks to https://github.com/szabgab/ - GitHub Actions config file Thanks to https://github.com/szabgab/ 1.50 Fri Nov 6 20:40 2020 - Allow get_and_set sub to return an options hash passed to the internal set call 1.49 Tue Mar 24 10:15 2020 - Fix windows compilation and test warnings Thanks to hvn@radiatorsoftware.com 1.48 Thu Apr 11 11:30 2019 - Remove use of // so we should work on 5.8 again - Replace -1 with a NOPAGE constant - Use 64bit offsets so we support caches > 4G - Various valgrind code fixes Thanks to oschwald@gmail.com 1.47 Fri Apr 6 11:10 2018 - Allow custom serializer or compressor options - Update bugtracker link to github Thanks to toddr@cpan.org 1.46 Fri Jul 14 19:40 2017 - Fix tests on older perls (thanks stephanloyd9@gmail.com) - Use File::Spec for temp dir (thanks fraserbn@gmail.com) - Fix mmap_cache_internals.h include guard - Fix get_and_set() always returning 0 for DidStore - Allow setting permission when creating cache file - Tweak leak detection tests - Fix last_access/expire_time checks for impending 1500000000 seconds since epoch 1.45 Thu Mar 14 11:10 2017 - Deprecate raw_values and compress options, add new compressor and serializer options to allow different compressors and serializers. Initial compressor support: zlib, lz4, snappy Initial serializer support: storable, sereal, json Thanks to nickt@broadbean.com for initial work 1.44 Wed Jun 1 21:45 2016 - Set FD_CLOEXEC flag on cache files when opened. Particularly useful in Net::Server where HUPing a process causes it to exec() itself. Unless you undef the cache references, you'll leak fd's after each HUP 1.43 Fri Oct 23 14:00 2015 - Update copyright + version correctly everywhere 1.42 Fri Oct 23 13:30 2015 - Allow get_and_set callback to return an empty list which means "no change". This allows atomic "get, and set if not present" type action, but without resetting the expiry time on each get. This is basically the same as using the read_cb 1.41 Thu Aug 29 15:30 2013 - Actually reuse deleted slots. Meant that if you used ->remove() a lot, we would re-organise cache more than needed - Include typo and meta patches from dsteinbrunner 1.40 Mon Dec 5 10:30 2011 - Work around reference holding bug in Compress::Zlib 1.39 Mon Jul 18 09:50 2011 - Remove CImpl and simplify structure into just Cache::FastMmap module making all XS calls just function calls in Cache::FastMmap namespace 1.38 Sun Jul 17 18:30 2011 - Fix build process that was completely broken after moving files around into different directories 1.37 Fri Jul 15 16:30 2011 - Use a lock object with DESTROY method to avoid an alarm with a die leaving around a locked paged 1.36 Wed Sep 29 13:10 2010 - Disable wrapping fcntl() lock call in alarm, hurts people that use Time::HiRes::alarm() only to try and catch buggy deadlock code. Enable with catch_deadlocks option 1.35 Fri Feb 19 12:45 2010 - Fix for returning potential bug that returns old stored data. Could occur if you mix deletes (thanks Darrell Bishop) 1.34 Fri Jun 19 12:00 2009 - perldoc fix (thanks Jonathan Yu) 1.33 Thu Jun 18 12:00 2009 - Update version in META.yml 1.32 Thu Jun 18 11:55 2009 - Better LiveCaches tracking via DESTROY 1.31 Thu Jun 18 11:40 2009 - when in raw_values => 0 mode, the write_cb is now correctly called with thawed data, rather than the raw frozen data - empty_on_exit correctly called even when a global cache is left at interpreter exit time (required Scalar::Util qw(weaken) for object tracking) 1.30 Fri May 8 11:10 2009 - Fix for Mandriva compiler (thanks Jean-Christian Hassler) 1.29 Fri May 1 17:20 2009 - Support for Windows (thanks to Ash & kmx.at.volny.cz) (https://rt.cpan.org/Public/Bug/Display.html?id=45210) (https://rt.cpan.org/Public/Bug/Display.html?id=16501) 1.28 Fri Jun 27 11:05 2008 - get_and_set() returns new value + didstore boolean if called in list context 1.27 Wed Jun 18 17:15 2008 - Fix non-ansi C code - Remove debug flags 1.26 Thu May 22 14:50 2008 - Check for write failure when creating file thanks to Sam Vilain - Check for $ENV{TMP_DIR} thanks to Sam Vilain - Add compress option - Add basic statistics gathering 1.25 Mon Feb 04 13:20 2008 - Fix multi_set bug and add test (http://rt.cpan.org/Ticket/Display.html?id=32895) - Test share_file is not a reference (http://rt.cpan.org/Ticket/Display.html?id=32252) - Fix C variable declaration error (http://rt.cpan.org/Ticket/Display.html?id=31223) - Fix compile warnings in FreeBSD (http://rt.cpan.org/Ticket/Display.html?id=31900) - Thanks to all the people that contributed to the above bugs 1.24 Mon Oct 22 13:15 2007 - Add atomic get_and_remove() method thanks to Darrell Bishop 1.23 Wed Oct 17 16:00 2007 - Fix expire time parsing 1.22 Wed Oct 17 14:05 2007 - If third parameter to set() is not a references, treat it as a specify expiry time. Increases compatiability with Cache::Cache API. Helpful for Catalyst framework 1.21 Tue Oct 16 10:40 2007 - if first parameter to new() is a hash ref, use it as the options hash. Helpful for Catalyst framework 1.20 Thu Oct 2 13:40 2007 - add to documentation about page size and cache file locations - fix t/6.t test failure under new Test::More 1.19 Thu Aug 23 09:03 2007 - bad C declaration crept in again, now in svn 1.18 Thu Aug 22 17:30 2007 - fix use of $^O not to catch "darwin" (http://rt.cpan.org/Ticket/Display.html?id=28330) 1.17 Thu Aug 22 17:14 2007 - fix declaration in C code that wasn't legal C 1.16 Thu May 8 17:12 2007 - fix typo in Changes file (1.15 is 2007, not 2006) - fix get_keys(2) when undef values in cache - fix some leak detection tests 1.15 Thu May 8 17:12 2007 - catch and rethrow die/exceptions in get_and_set() callbacks - avoid undef warnings when using cache_not_found mode - use unique tempfile name rather than the same every time - add allow_recursive option to allow calls to cache from within a read/write callback sub - add checks to die if we try and lock a cache twice, rather than just causing mysterious errors - add unlink_on_exit to automatically delete the share_file when the cache exits. default to true if we created the share_file, false if we connected to an existing one - make empty_on_exit only call empty if the pid of the process we're cleaning up in is the same as the pid we were created in - die in CLONE, making it clear threads aren't supported 1.14 Thu Oct 20 11:45 2006 - alter calc_expunge to allow more efficient alternate implementation cases 1.13 Thu Oct 20 11:15 2006 - mention UNIX/Win32 compatiability in docs (http://rt.cpan.org/Ticket/Display.html?id=16501) - detect page corruption better and croak rather than segfault (http://rt.cpan.org/Ticket/Display.html?id=17335) - when running in raw_values => 0 mode, always store reference to data. Storable doesn't like freeze(SCALAR) (http://rt.cpan.org/Ticket/Display.html?id=16762) - Handle edge case of slot count increase when page already nearly full possibly causing corruption (can only happen if ->purge() called at just the wrong time) 1.12 Thu Oct 19 09:50 2006 - allow writing into a deleted slot 1.11 Web Oct 18 15:10 2006 - allow setting default slot count via start_slots argument 1.10 Web Oct 18 14:50 2006 - fc_lock() would segfault if no slots were available. Doesn't happen in normal usage, but can happen if cache behaviour altered by alternate code 1.09 Thu Feb 7 15:50 2005 - add get_and_set() routine to allow atomic reading and writing of a cache value (thanks to Sreeji Das) - fix some tests 1.08 Thu Aug 26 12:18 2004 - really remove dependency on perl 5.8 1.07 Thu Aug 19 22:18 2004 - add extra documentation - add parameter to empty() method - add ability to test integrity of cache file - remove dependency on perl 5.8 1.06 Thu May 10 17:18 2004 - add multi_set and multi_get methods 1.05 Sat Jan 31 17:24 2004 - fix another edge case where page would get full, but never expunged when storing references 1.04 Sun Jan 25 00:46 2004 - fix test file after new changes 1.03 Sun Jan 25 00:21 2004 - fix bad sorting when removing old cache entries 1.02 Sat Jan 24 17:05 2004 - fix edge case where page would get full, but never expunged 1.01 Sat Dec 13 18:17 2003 - fix leak from improper munmap call 1.00 Sat Dec 13 14:19 2003 - initial release Cache-FastMmap-1.58/mmap_cache_test.c0000644000000000000000000002026515006056063016144 0ustar rootroot#include #include #include #if !defined(WIN32) || defined(CYGWIN) #include #include #include #include #endif #ifdef DEBUG #define ASSERT(x) assert(x) #include #else #define ASSERT(x) #endif #ifndef WIN32 #include #else #include #include #include double last_rand; double drand48(void) { last_rand = rand() / (double)(RAND_MAX+1); ASSERT(last_rand < 1); return last_rand; } #endif #include #include "mmap_cache.h" void * Get(mmap_cache * cache, void * key_ptr, int key_len, int * val_len) { int found; void * val_ptr, * val_rtn_ptr = 0; MU32 hash_page, hash_slot, flags; /* Hash key to get page and slot */ mmc_hash(cache, key_ptr, key_len, &hash_page, &hash_slot); /* Get and lock the page */ mmc_lock(cache, hash_page); /* Get value data pointer */ found = mmc_read(cache, hash_slot, key_ptr, key_len, &val_ptr, val_len, &flags); /* If not found, use undef */ if (found == -1) { } else { /* Put into our own memory */ val_rtn_ptr = (void *)malloc(*val_len); memcpy(val_rtn_ptr, val_ptr, *val_len); } mmc_unlock(cache); return val_rtn_ptr; } void Set(mmap_cache * cache, void * key_ptr, int key_len, void * val_ptr, int val_len) { MU32 hash_page, hash_slot, flags = 0, new_num_slots, ** expunge_items = 0; int num_expunge; /* Hash key to get page and slot */ mmc_hash(cache, key_ptr, key_len, &hash_page, &hash_slot); /* Get and lock the page */ mmc_lock(cache, hash_page); num_expunge = mmc_calc_expunge(cache, 2, key_len + val_len, &new_num_slots, &expunge_items); if (expunge_items) { mmc_do_expunge(cache, num_expunge, new_num_slots, expunge_items); } /* Get value data pointer */ mmc_write(cache, hash_slot, key_ptr, key_len, val_ptr, val_len, 60, flags); mmc_unlock(cache); } char * rand_str(int nchar) { unsigned char * buf = (unsigned char *)malloc(nchar + 1); int i; for (i = 0; i < nchar; i++) { buf[i] = (char)(rand() % 26) + 'A'; } buf[i] = 0; return (char *)buf; } char buf[65537]; int BasicTests(mmap_cache * cache) { int val_len, i; void * val_ptr; printf("Basic tests\n"); /* Test empty */ ASSERT(!Get(cache, "", 0, &val_len)); ASSERT(!Get(cache, " ", 0, &val_len)); for (i = 0; i < 65536; i++) { buf[i] = ' '; } ASSERT(!Get(cache, buf, 1024, &val_len)); ASSERT(!Get(cache, buf, 65536, &val_len)); /* Test basic store/get on key sizes */ Set(cache, "", 0, "abc", 3); ASSERT(!memcmp(val_ptr = Get(cache, "", 0, &val_len), "abc", 3) && val_len == 3); free(val_ptr); Set(cache, " ", 1, "def", 3); ASSERT(!memcmp(val_ptr = Get(cache, " ", 1, &val_len), "def", 3) && val_len == 3); free(val_ptr); Set(cache, buf, 1024, "ghi", 3); ASSERT(!memcmp(val_ptr = Get(cache, buf, 1024, &val_len), "ghi", 3) && val_len == 3); free(val_ptr); /* Bigger than page size - shouldn't work */ Set(cache, buf, 65536, "jkl", 3); ASSERT(!Get(cache, buf, 65536, &val_len)); /* Test basic store/get on value sizes */ Set(cache, "abc", 3, "", 0); ASSERT((val_ptr = Get(cache, "abc", 3, &val_len)) && val_len == 0); free(val_ptr); Set(cache, "def", 3, "x", 1); ASSERT(!memcmp(val_ptr = Get(cache, "def", 3, &val_len), "x", 1) && val_len == 1); free(val_ptr); for (i = 0; i < 1024; i++) { buf[i] = 'y'; } buf[0] = 'z'; buf[1023] = 'w'; Set(cache, "ghi", 3, buf, 1024); ASSERT(!memcmp(val_ptr = Get(cache, "ghi", 3, &val_len), buf, 1024) && val_len == 1024); free(val_ptr); /* Bigger than page size - shouldn't work */ Set(cache, "jkl", 3, buf, 65536); ASSERT(!Get(cache, "jkl", 3, &val_len)); return 0; } int LinearTests(mmap_cache * cache) { int i, gl; char * str1, * str2, * str3; printf("Linear tests\n"); for (i = 0; i < 100000; i++) { str1 = rand_str(10); str2 = rand_str(10); Set(cache, str1, strlen(str1)+1, str2, strlen(str2)+1); str3 = Get(cache, str1, strlen(str1)+1, &gl); ASSERT(strlen(str2)+1 == gl); ASSERT(!memcmp(str2, str3, strlen(str2)+1)); free(str1); free(str2); free(str3); if (i % 1000 == 0) { printf("%d\n", i); } } } int EdgeTests() { return 0; } typedef struct key_list { int n_keys; int buf_size; char ** keys; } key_list; key_list * kl_new() { key_list * kl = (key_list *)malloc(sizeof(key_list)); kl->buf_size = 8; kl->keys = (char **)malloc(sizeof(char *) * kl->buf_size); kl->n_keys = 0; return kl; } void kl_push(key_list * kl, char * key) { if (kl->n_keys < kl->buf_size) { kl->keys[kl->n_keys++] = key; return; } kl->buf_size *= 2; kl->keys = (char **)realloc(kl->keys, sizeof(char *) * kl->buf_size); kl->keys[kl->n_keys++] = key; return; } void kl_free(key_list * kl) { int i; for (i = 0; i < kl->n_keys; i++) { free(kl->keys[i]); } } int urand_fh = 0; void RandSeed() { #ifdef WIN32 //randomize(); #else char buf[8]; if (!urand_fh) { urand_fh = open("/dev/urandom", O_RDONLY); } read(urand_fh, buf, 8); srand48(*(long int *)buf); #endif } int RepeatMixTests(mmap_cache * cache, double ratio, key_list * kl) { int i, val_len; int read = 0, read_hit = 0; char valbuf[256]; printf("Repeat mix tests\n"); for (i = 0; i < 10000; i++) { /* Read/write ratio */ if (drand48() < ratio) { /* Pick a key from known written ones */ char * k = kl->keys[(int)(drand48() * kl->n_keys)]; void * v = Get(cache, k, strlen(k), &val_len); read++; /* Skip if not found in cache */ if (!v) { continue; } read_hit++; /* Offset of 10 past first chars of value are key */ memcpy(valbuf, v+10, strlen(k)); valbuf[strlen(k)] = '\0'; ASSERT(!memcmp(valbuf, k, strlen(k))); free(v); } else { char * k = rand_str(10 + (int)(drand48() * 10)); char * v = rand_str(10); char * ve = rand_str((int)(drand48() * 200)); strcpy(valbuf, v); strcat(valbuf, k); strcat(valbuf, ve); kl_push(kl, k); Set(cache, k, strlen(k), valbuf, strlen(valbuf)); free(ve); free(v); } } if (read) { printf("Read hit pct: %5.3f\n", (double)read_hit/read); } return 1; } void IteratorTests(mmap_cache * cache) { MU32 * entry_ptr; void * key_ptr, * val_ptr; int key_len, val_len; MU32 last_access, expire_time, flags; mmap_cache_it * it = mmc_iterate_new(cache); printf("Iterator tests\n"); while ((entry_ptr = mmc_iterate_next(it))) { mmc_get_details(cache, entry_ptr, &key_ptr, &key_len, &val_ptr, &val_len, &last_access, &expire_time, &flags); ASSERT(key_len >= 10 && key_len <= 20); ASSERT(val_len >= 20 && val_len <= 240); ASSERT(last_access >= 1000000 && last_access <= time(0)); } mmc_iterate_close(it); } int ForkTests(mmap_cache * cache, key_list * kl) { #ifndef WIN32 int pid, j, k, kid, kids[20], nkids = 0, status; struct timeval timeout = { 0, 1000 }; for (j = 0; j < 8; j++) { if (!(pid = fork())) { RandSeed(); RepeatMixTests(cache, 0.4, kl); exit(0); } kids[nkids++] = pid; select(0, 0, 0, 0, &timeout); } do { kid = waitpid(-1, &status, 0); for (j = 0, k = 0; j < nkids; j++) { if (kids[j] != kid) { k++; } kids[j] = kids[k]; } nkids--; } while (kid > 0 && nkids); return 0; #else #endif } int main(int argc, char ** argv) { int res; key_list * kl; mmap_cache * cache; cache = mmc_new(); mmc_set_param(cache, "init_file", "1"); res = mmc_init(cache); kl = kl_new(); BasicTests(cache); LinearTests(cache); mmc_close(cache); cache = mmc_new(); mmc_set_param(cache, "init_file", "1"); res = mmc_init(cache); RepeatMixTests(cache, 0.0, kl); RepeatMixTests(cache, 0.5, kl); RepeatMixTests(cache, 0.8, kl); IteratorTests(cache); ForkTests(cache, kl); kl_free(kl); mmc_close(cache); cache = mmc_new(); mmc_set_param(cache, "init_file", "1"); mmc_set_param(cache, "page_size", "8192"); res = mmc_init(cache); kl = kl_new(); BasicTests(cache); RepeatMixTests(cache, 0.0, kl); RepeatMixTests(cache, 0.5, kl); RepeatMixTests(cache, 0.8, kl); ForkTests(cache, kl); kl_free(kl); mmc_close(cache); return 0; } Cache-FastMmap-1.58/unix.c0000644000000000000000000001352615006061764014021 0ustar rootroot /* * AUTHOR * * Rob Mueller * * COPYRIGHT AND LICENSE * * Copyright (C) 2003 by FastMail IP Partners * * This library is free software; you can redistribute it and/or modify * it under the same terms as Perl itself. * */ #include #include #include #include #include #include #include #include #include #include #include #include "mmap_cache.h" #include "mmap_cache_internals.h" char* _mmc_get_def_share_filename(mmap_cache * cache) { return def_share_file; } int mmc_open_cache_file(mmap_cache* cache, int * do_init) { int res, i, fh; void * tmp; struct stat statbuf; /* Check if file exists */ res = stat(cache->share_file, &statbuf); /* Remove if different size or remove requested */ if (!res && (cache->init_file || (statbuf.st_size != cache->c_size))) { res = remove(cache->share_file); if (res == -1 && errno != ENOENT) { return _mmc_set_error(cache, errno, "Unlink of existing share file %s failed", cache->share_file); } } /* Create file if it doesn't exist */ *do_init = 0; res = stat(cache->share_file, &statbuf); if (res == -1) { mode_t permissions = (mode_t)cache->permissions; res = open(cache->share_file, O_WRONLY | O_CREAT | O_EXCL | O_TRUNC | O_APPEND, permissions); if (res == -1) { return _mmc_set_error(cache, errno, "Create of share file %s failed", cache->share_file); } /* Fill file with 0's */ tmp = calloc(1, cache->c_page_size); if (!tmp) { return _mmc_set_error(cache, errno, "Calloc of tmp space failed"); } for (i = 0; i < cache->c_num_pages; i++) { int written = write(res, tmp, cache->c_page_size); if (written < 0) { free(tmp); return _mmc_set_error(cache, errno, "Write to share file %s failed", cache->share_file); } if (written < cache->c_page_size) { free(tmp); return _mmc_set_error(cache, 0, "Write to share file %s failed; short write (%d of %d bytes written)", cache->share_file, written, cache->c_page_size); } } free(tmp); /* Later on initialise page structures */ *do_init = 1; close(res); } /* Open for reading/writing */ fh = open(cache->share_file, O_RDWR); if (fh == -1) { return _mmc_set_error(cache, errno, "Open of share file %s failed", cache->share_file); } /* Automatically close cache fd on exec */ fcntl(fh, F_SETFD, FD_CLOEXEC); fstat(fh, &statbuf); cache->inode = statbuf.st_ino; cache->fh = fh; return 0; } /* * mmc_map_memory(mmap_cache * cache) * * maps the cache file into memory, and sets cache->mm_var as needed. */ int mmc_map_memory(mmap_cache* cache) { /* Map file into memory */ cache->mm_var = mmap(0, cache->c_size, PROT_READ | PROT_WRITE, MAP_SHARED, cache->fh, 0); if (cache->mm_var == (void *)MAP_FAILED) { _mmc_set_error(cache, errno, "Mmap of shared file %s failed", cache->share_file); mmc_close_fh(cache); return -1; } return 0; } /* * mmc_unmap_memory(mmap_cache * cache) * * Unmaps cache->mm_var */ int mmc_unmap_memory(mmap_cache* cache) { int res = munmap(cache->mm_var, cache->c_size); if (res == -1) { return _mmc_set_error(cache, errno, "Munmap of shared file %s failed", cache->share_file); } return res; } int mmc_check_fh(mmap_cache* cache) { struct stat statbuf; fstat(cache->fh, &statbuf); if (cache->inode != statbuf.st_ino) { _mmc_set_error(cache, 0, "Underlying cache file fd %d was inode %ld but now %ld, something messed up underlying file descriptors", cache->fh, cache->inode, statbuf.st_ino); return 0; } return 1; } int mmc_close_fh(mmap_cache* cache) { int res = close(cache->fh); return res; } int mmc_lock_page(mmap_cache* cache, MU64 p_offset) { struct flock lock; int old_alarm, alarm_left = 10; int lock_res = -1; /* Setup fcntl locking structure */ lock.l_type = F_WRLCK; lock.l_whence = SEEK_SET; lock.l_start = p_offset; lock.l_len = cache->c_page_size; if (cache->catch_deadlocks) old_alarm = alarm(alarm_left); while (lock_res != 0) { /* Lock the page (block till done, signal, or timeout) */ lock_res = fcntl(cache->fh, F_SETLKW, &lock); /* Continue immediately if success */ if (lock_res == 0) { if (cache->catch_deadlocks) alarm(old_alarm); break; } /* Turn off alarm for a moment */ if (cache->catch_deadlocks) alarm_left = alarm(0); /* Some signal interrupted, and it wasn't the alarm? Rerun lock */ if (lock_res == -1 && errno == EINTR && alarm_left) { if (cache->catch_deadlocks) alarm(alarm_left); continue; } /* Lock failed? */ _mmc_set_error(cache, errno, "Lock failed"); if (cache->catch_deadlocks) alarm(old_alarm); return -1; } return 0; } int mmc_unlock_page(mmap_cache * cache) { struct flock lock; /* Setup fcntl locking structure */ lock.l_type = F_UNLCK; lock.l_whence = SEEK_SET; lock.l_start = cache->p_offset; lock.l_len = cache->c_page_size; /* And unlock page */ fcntl(cache->fh, F_SETLKW, &lock); /* Set to bad value while page not locked */ cache->p_cur = NOPAGE; return 0; } /* * int _mmc_set_error(mmap_cache *cache, int err, char * error_string, ...) * * Set internal error string/state * */ int _mmc_set_error(mmap_cache *cache, int err, char * error_string, ...) { va_list ap; static char errbuf[1024]; va_start(ap, error_string); /* Make sure it's terminated */ errbuf[1023] = '\0'; /* Start with error string passed */ vsnprintf(errbuf, 1023, error_string, ap); /* Add system error code if passed */ if (err) { strncat(errbuf, ": ", 1023); strncat(errbuf, strerror(err), 1023); } /* Save in cache object */ cache->last_error = errbuf; va_end(ap); return -1; } Cache-FastMmap-1.58/ppport.h0000644000000000000000000003470515006056063014365 0ustar rootroot /* ppport.h -- Perl/Pollution/Portability Version 2.0002 * * Automatically Created by Devel::PPPort on Wed Nov 19 19:24:25 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-FastMmap-1.58/mmap_cache.c0000644000000000000000000010051015006061340015067 0ustar rootroot /* * AUTHOR * * Rob Mueller * * COPYRIGHT AND LICENSE * * Copyright (C) 2003 by FastMail IP Partners * * This library is free software; you can redistribute it and/or modify * it under the same terms as Perl itself. * */ #include #include #include #include #include #include #include "mmap_cache.h" #include "mmap_cache_internals.h" /* Global time_override */ MU32 time_override = 0; void mmc_set_time_override(MU32 set_time) { time_override = set_time; } /* Default values for a new cache */ char * def_share_file = "/tmp/sharefile"; MU32 def_init_file = 0; MU32 def_test_file = 0; MU32 def_expire_time = 0; MU32 def_c_num_pages = 89; MU32 def_c_page_size = 65536; MU32 def_start_slots = 89; /* * mmap_cache * mmc_new() * * Create a new cache object filled with default values. Values may * be changed and once ready, you should call mmc_init() to actually * open the cache file and mmap it. * */ mmap_cache * mmc_new() { mmap_cache * cache = (mmap_cache *)calloc(1, sizeof(mmap_cache)); cache->p_cur = NOPAGE; cache->c_num_pages = def_c_num_pages; cache->c_page_size = def_c_page_size; cache->start_slots = def_start_slots; cache->expire_time = def_expire_time; cache->share_file = _mmc_get_def_share_filename(cache); cache->permissions = 0640; cache->init_file = def_init_file; cache->test_file = def_test_file; return cache; } int mmc_set_param(mmap_cache * cache, char * param, char * val) { if (!strcmp(param, "init_file")) { cache->init_file = atoi(val); } else if (!strcmp(param, "test_file")) { cache->test_file = atoi(val); } else if (!strcmp(param, "page_size")) { cache->c_page_size = atoi(val); } else if (!strcmp(param, "num_pages")) { cache->c_num_pages = atoi(val); } else if (!strcmp(param, "expire_time")) { cache->expire_time = atoi(val); } else if (!strcmp(param, "share_file")) { cache->share_file = val; } else if (!strcmp(param, "permissions")) { cache->permissions = atoi(val); } else if (!strcmp(param, "start_slots")) { cache->start_slots = atoi(val); } else if (!strcmp(param, "catch_deadlocks")) { cache->catch_deadlocks = atoi(val); } else if (!strcmp(param, "enable_stats")) { cache->enable_stats = atoi(val); } else { return _mmc_set_error(cache, 0, "Bad set_param parameter: %s", param); } return 0; } int mmc_get_param(mmap_cache * cache, char * param) { if (!strcmp(param, "page_size")) { return (int)cache->c_page_size; } else if (!strcmp(param, "num_pages")) { return (int)cache->c_num_pages; } else if (!strcmp(param, "expire_time")) { return (int)cache->expire_time; } else { return _mmc_set_error(cache, 0, "Bad set_param parameter: %s", param); } } /* * int mmc_init(mmap_cache * cache) * * Initialise the cache object, opening the share file and mmap'ing any * memory. * */ int mmc_init(mmap_cache * cache) { int i, do_init; MU32 c_num_pages, c_page_size; MU64 c_size; /* Need a share file */ if (!cache->share_file) { return _mmc_set_error(cache, 0, "No share file specified"); } /* Basic cache params */ c_num_pages = cache->c_num_pages; ASSERT(c_num_pages >= 1 && c_num_pages <= 1000); c_page_size = cache->c_page_size; ASSERT(c_page_size >= 1024 && c_page_size <= 1024*1024*1024); ASSERT(cache->start_slots >= 10 && cache->start_slots <= 500); cache->c_size = c_size = (MU64)c_num_pages * c_page_size; if ( mmc_open_cache_file(cache, &do_init) == -1) return -1; /* Map file into memory */ if ( mmc_map_memory(cache) == -1) return -1; /* Initialise pages if new file */ if (do_init) { _mmc_init_page(cache, -1); /* Unmap and re-map to stop gtop telling us our memory usage is up */ if ( mmc_unmap_memory(cache) == -1) return -1; if ( mmc_map_memory(cache) == -1) return -1; } /* Test pages in file if asked */ if (cache->test_file) { for (i = 0; i < cache->c_num_pages; i++) { int lock_page = 0, bad_page = 0; /* Need to lock page, which tests header structure */ if (mmc_lock(cache, i)) { bad_page = 1; /* If lock succeeded, test page structure */ } else { lock_page = 1; if (!_mmc_test_page(cache)) { bad_page = 1; } } /* If we locked, unlock */ if (lock_page) { mmc_unlock(cache); } /* A bad page, initialise it */ if (bad_page) { _mmc_init_page(cache, i); /* Rerun test on this page, potential infinite loop if init_page is broken, but then things are really broken anyway */ i--; } } } return 0; } /* * int mmc_close(mmap_cache * cache) * * Close the given cache, unmmap'ing any memory and closing file * descriptors. * */ int mmc_close(mmap_cache *cache) { int res; /* Shouldn't call if not init'ed */ ASSERT(cache->fh); ASSERT(cache->mm_var); /* Shouldn't call if page still locked */ ASSERT(cache->p_cur == NOPAGE); /* Unlock any locked page */ if (cache->p_cur != NOPAGE) { mmc_unlock(cache); } /* Close file */ if (cache->fh) { mmc_close_fh(cache); } /* Unmap memory */ if (cache->mm_var) { res = mmc_unmap_memory(cache); if (res == -1) { return _mmc_set_error(cache, errno, "Mmap of shared file %s failed", cache->share_file); } } free(cache); return 0; } char * mmc_error(mmap_cache * cache) { if (cache->last_error) return cache->last_error; return "Unknown error"; } /* * mmc_lock( * cache_mmap * cache, MU32 p_cur * ) * * Lock the given page number using fcntl locking. Setup * cache->p_* fields with correct values for the given page * */ int mmc_lock(mmap_cache * cache, MU32 p_cur) { MU64 p_offset; void * p_ptr; /* Argument sanity check */ if (p_cur == NOPAGE || p_cur > cache->c_num_pages) return _mmc_set_error(cache, 0, "page %u is NOPAGE or larger than number of pages", p_cur); /* Check not already locked */ if (cache->p_cur != NOPAGE) return _mmc_set_error(cache, 0, "page %u is already locked, can't lock multiple pages", cache->p_cur); /* Setup page details */ p_offset = (MU64)p_cur * cache->c_page_size; p_ptr = PTR_ADD(cache->mm_var, p_offset); if (mmc_lock_page(cache, p_offset) == -1) return -1; if (!(P_Magic(p_ptr) == 0x92f7e3b1)) return _mmc_set_error(cache, 0, "magic page start marker not found. p_cur is %u, offset is %llu", p_cur, p_offset); /* Copy to cache structure */ cache->p_num_slots = P_NumSlots(p_ptr); cache->p_free_slots = P_FreeSlots(p_ptr); cache->p_old_slots = P_OldSlots(p_ptr); cache->p_free_data = P_FreeData(p_ptr); cache->p_free_bytes = P_FreeBytes(p_ptr); cache->p_n_reads = P_NReads(p_ptr); cache->p_n_read_hits = P_NReadHits(p_ptr); /* Reality check */ if (cache->p_num_slots < 89 || cache->p_num_slots > cache->c_page_size) return _mmc_set_error(cache, 0, "cache num_slots mistmatch"); if (cache->p_free_slots < 0 || cache->p_free_slots > cache->p_num_slots) return _mmc_set_error(cache, 0, "cache free slots mustmatch"); if (cache->p_old_slots > cache->p_free_slots) return _mmc_set_error(cache, 0, "cache old slots mistmatch"); if (cache->p_free_data + cache->p_free_bytes != cache->c_page_size) return _mmc_set_error(cache, 0, "cache free data mistmatch"); /* Check page header */ ASSERT(P_Magic(p_ptr) == 0x92f7e3b1); ASSERT(P_NumSlots(p_ptr) >= 89 && P_NumSlots(p_ptr) < cache->c_page_size); ASSERT(P_FreeSlots(p_ptr) >= 0 && P_FreeSlots(p_ptr) <= P_NumSlots(p_ptr)); ASSERT(P_OldSlots(p_ptr) <= P_FreeSlots(p_ptr)); ASSERT(P_FreeData(p_ptr) + P_FreeBytes(p_ptr) == cache->c_page_size); /* Setup page pointers */ cache->p_cur = p_cur; cache->p_offset = p_offset; cache->p_base = p_ptr; cache->p_base_slots = PTR_ADD(p_ptr, P_HEADERSIZE); ASSERT(_mmc_test_page(cache)); return 0; } /* * mmc_unlock( * cache_mmap * cache * ) * * Unlock any currently locked page * */ int mmc_unlock(mmap_cache * cache) { ASSERT(cache->p_cur != NOPAGE); /* If changed, save page header changes back */ if (cache->p_changed) { void * p_ptr = cache->p_base; /* Save any changed information back to page */ P_NumSlots(p_ptr) = cache->p_num_slots; P_FreeSlots(p_ptr) = cache->p_free_slots; P_OldSlots(p_ptr) = cache->p_old_slots; P_FreeData(p_ptr) = cache->p_free_data; P_FreeBytes(p_ptr) = cache->p_free_bytes; P_NReads(p_ptr) = cache->p_n_reads; P_NReadHits(p_ptr) = cache->p_n_read_hits; } /* Test before unlocking */ ASSERT(_mmc_test_page(cache)); mmc_unlock_page(cache); return 0; } /* * mmc_is_locked( * cache_mmap * cache * ) * * Return true if page is locked * */ int mmc_is_locked(mmap_cache * cache) { return cache->p_cur != NOPAGE ? 1 : 0; } /* * int mmc_hash( * cache_mmap * cache, * void *key_ptr, int key_len, * MU32 *hash_page, MU32 *hash_slot * ) * * Hashes the given key, and returns hash value, hash page and hash * slot part * */ int mmc_hash( mmap_cache *cache, void *key_ptr, int key_len, MU32 *hash_page, MU32 *hash_slot ) { MU32 h = 0x92f7e3b1; unsigned char * uc_key_ptr = (unsigned char *)key_ptr; unsigned char * uc_key_ptr_end = uc_key_ptr + key_len; while (uc_key_ptr != uc_key_ptr_end) { h = (h << 4) + (h >> 28) + *uc_key_ptr++; } *hash_page = h % cache->c_num_pages; *hash_slot = h / cache->c_num_pages; return 0; } /* * int mmc_read( * cache_mmap * cache, MU32 hash_slot, * void *key_ptr, int key_len, * void **val_ptr, int *val_len, * MU32 *expire_on, MU32 *flags * ) * * Read key from current page * */ int mmc_read( mmap_cache *cache, MU32 hash_slot, void *key_ptr, int key_len, void **val_ptr, int *val_len, MU32 *expire_on_p, MU32 *flags_p ) { MU32 * slot_ptr; /* Increase read count for page */ if (cache->enable_stats) { cache->p_changed = 1; cache->p_n_reads++; } /* Search slots for key */ slot_ptr = _mmc_find_slot(cache, hash_slot, key_ptr, key_len, 0); /* Did we find a value? */ if (!slot_ptr || *slot_ptr == 0) { /* Return -1 if not */ return -1; /* We found it! Check some other things... */ } else { MU32 * base_det = S_Ptr(cache->p_base, *slot_ptr); MU32 now = time_override ? time_override : (MU32)time(0); MU32 expire_on = S_ExpireOn(base_det); /* Sanity check hash matches */ ASSERT(S_SlotHash(base_det) == hash_slot); /* Value expired? */ if (expire_on && now >= expire_on) { /* Return not found, but leave slot. Might need writeback */ return -1; } /* Update hit time */ S_LastAccess(base_det) = now; /* Copy values to pointers */ *flags_p = S_Flags(base_det); *expire_on_p = expire_on; *val_len = S_ValLen(base_det); *val_ptr = S_ValPtr(base_det); /* Increase read hit count */ if (cache->enable_stats) cache->p_n_read_hits++; return 0; } } /* * int mmc_write( * cache_mmap * cache, MU32 hash_slot, * void *key_ptr, int key_len, * void *val_ptr, int val_len, * MU32 expire_on, MU32 flags * ) * * Write key to current page * */ int mmc_write( mmap_cache *cache, MU32 hash_slot, void *key_ptr, int key_len, void *val_ptr, int val_len, MU32 expire_on, MU32 flags ) { int did_store = 0; MU32 kvlen = KV_SlotLen(key_len, val_len); /* Search for slot with given key */ MU32 * slot_ptr = _mmc_find_slot(cache, hash_slot, key_ptr, key_len, 1); /* If all slots full, definitely can't store */ if (!slot_ptr) return 0; ROUNDLEN(kvlen); ASSERT(cache->p_cur != NOPAGE); /* If found, delete slot for new value */ if (*slot_ptr > 1) { _mmc_delete_slot(cache, slot_ptr); ASSERT(*slot_ptr == 1); } ASSERT(*slot_ptr <= 1); /* If there's space, store the key/value in the data section */ if (cache->p_free_bytes >= kvlen) { MU32 * base_det = PTR_ADD(cache->p_base, cache->p_free_data); MU32 now = time_override ? time_override : (MU32)time(0); /* Calculate expiry time */ if (expire_on == (MU32)-1) expire_on = cache->expire_time ? now + cache->expire_time : 0; /* Store info into slot */ S_LastAccess(base_det) = now; S_ExpireOn(base_det) = expire_on; S_SlotHash(base_det) = hash_slot; S_Flags(base_det) = flags; S_KeyLen(base_det) = (MU32)key_len; S_ValLen(base_det) = (MU32)val_len; /* Copy key/value to data section */ memcpy(S_KeyPtr(base_det), key_ptr, key_len); memcpy(S_ValPtr(base_det), val_ptr, val_len); /* Update used slots/free data info */ cache->p_free_slots--; if (*slot_ptr == 1) { cache->p_old_slots--; } /* Save new data offset */ *slot_ptr = cache->p_free_data; /* Update free space */ cache->p_free_bytes -= kvlen; cache->p_free_data += kvlen; /* Ensure changes are saved back */ cache->p_changed = 1; did_store = 1; } return did_store; } /* * int mmc_delete( * cache_mmap * cache, MU32 hash_slot, * void *key_ptr, int key_len * ) * * Delete key from current page * */ int mmc_delete( mmap_cache *cache, MU32 hash_slot, void *key_ptr, int key_len, MU32 * flags ) { /* Search slots for key */ MU32 * slot_ptr = _mmc_find_slot(cache, hash_slot, key_ptr, key_len, 2); /* Did we find a value? */ if (!slot_ptr || *slot_ptr == 0) { /* Return 0 if not deleted */ return 0; /* We found it, delete it */ } else { /* Store flags in output pointer */ MU32 * base_det = S_Ptr(cache->p_base, *slot_ptr); *flags = S_Flags(base_det); _mmc_delete_slot(cache, slot_ptr); return 1; } } int last_access_cmp(const void * a, const void * b) { MU32 av = S_LastAccess(*(MU32 **)a); MU32 bv = S_LastAccess(*(MU32 **)b); if (av < bv) return -1; if (av > bv) return 1; return 0; } /* * int mmc_calc_expunge( * cache_mmap * cache, int mode, int len, MU32 * new_num_slots, MU32 *** to_expunge * ) * * Calculate entries to expunge from current page. * * If len >= 0 * If space available for len bytes & >30% slots free, nothing is expunged * If len < 0 or not above * If mode == 0, only expired items are expunged * If mode == 1, all entries are expunged * If mode == 2, entries are expunged till 40% free space is created * * If expunged is non-null pointer, result is filled with * a list of slots to expunge * * Return value is number of items to expunge * */ int mmc_calc_expunge( mmap_cache * cache, int mode, int len, MU32 * new_num_slots, MU32 *** to_expunge ) { double slots_pct; ASSERT(cache->p_cur != NOPAGE); /* If len >= 0, and space available for len bytes, nothing is expunged */ if (len >= 0) { /* Length of key/value data when stored */ MU32 kvlen = KV_SlotLen(len, 0); ROUNDLEN(kvlen); slots_pct = (double)(cache->p_free_slots - cache->p_old_slots) / cache->p_num_slots; /* Nothing to do if hash table more than 30% free slots and enough free space */ if (slots_pct > 0.3 && cache->p_free_bytes >= kvlen) return 0; } { MU32 num_slots = cache->p_num_slots; MU32 used_slots = num_slots - cache->p_free_slots; MU32 * slot_ptr = cache->p_base_slots; MU32 * slot_end = slot_ptr + num_slots; /* Store pointers to used slots */ MU32 ** copy_base_det = (MU32 **)calloc(used_slots, sizeof(MU32 *)); MU32 ** copy_base_det_end = copy_base_det + used_slots; MU32 ** copy_base_det_out = copy_base_det; MU32 ** copy_base_det_in = copy_base_det + used_slots; MU32 page_data_size = cache->c_page_size - num_slots * 4 - P_HEADERSIZE; MU32 in_slots, data_thresh, used_data = 0; MU32 now = time_override ? time_override : (MU32)time(0); /* Loop for each existing slot, and store in a list */ for (; slot_ptr != slot_end; slot_ptr++) { MU32 data_offset = *slot_ptr; MU32 * base_det = S_Ptr(cache->p_base, data_offset); MU32 expire_on, kvlen; /* Ignore if if free slot */ if (data_offset <= 1) { continue; } /* Definitely out if mode == 1 which means expunge all */ if (mode == 1) { *copy_base_det_out++ = base_det; continue; } /* Definitely out if expired, and not dirty */ expire_on = S_ExpireOn(base_det); if (expire_on && now >= expire_on) { *copy_base_det_out++ = base_det; continue; } /* Track used space */ kvlen = S_SlotLen(base_det); ROUNDLEN(kvlen); ASSERT(kvlen <= page_data_size); used_data += kvlen; ASSERT(used_data <= page_data_size); /* Potentially in */ *--copy_base_det_in = base_det; } /* Check that definitely in and out slots add up to used slots */ ASSERT(copy_base_det_in == copy_base_det_out); ASSERT(mode != 1 || copy_base_det_out == copy_base_det_end); /* Increase slot count if free count is low and there's space to increase */ slots_pct = (double)(copy_base_det_end - copy_base_det_out) / num_slots; if (slots_pct > 0.3 && (page_data_size - used_data > (num_slots + 1) * 4 || mode == 2)) { num_slots = (num_slots * 2) + 1; } page_data_size = cache->c_page_size - num_slots * 4 - P_HEADERSIZE; /* If mode == 0 or 1, we've just worked out ones to keep and * which to dispose of, so return results */ if (mode == 0 || mode == 1) { *to_expunge = copy_base_det; *new_num_slots = num_slots; return (copy_base_det_out - copy_base_det); } /* mode == 2, sort by last access, and remove till enough free space */ /* Sort those potentially in by last access */ in_slots = copy_base_det_end - copy_base_det_in; qsort((void *)copy_base_det_in, in_slots, sizeof(MU32 *), &last_access_cmp); /* Throw out old slots till we have 40% free data space */ data_thresh = (MU32)(0.6 * page_data_size); while (copy_base_det_in != copy_base_det_end && used_data >= data_thresh) { MU32 * slot_ptr = *copy_base_det_in; MU32 kvlen = S_SlotLen(slot_ptr); ROUNDLEN(kvlen); ASSERT(kvlen <= page_data_size); used_data -= kvlen; ASSERT(used_data >= 0); copy_base_det_out = ++copy_base_det_in; } ASSERT(used_data < page_data_size); *to_expunge = copy_base_det; *new_num_slots = num_slots; return (copy_base_det_out - copy_base_det); } } /* * int mmc_do_expunge( * cache_mmap * cache, int num_expunge, MU32 new_num_slots, MU32 ** to_expunge * ) * * Expunge given entries from current page. * */ int mmc_do_expunge( mmap_cache * cache, int num_expunge, MU32 new_num_slots, MU32 ** to_expunge ) { MU32 * base_slots = cache->p_base_slots; MU32 ** to_keep = to_expunge + num_expunge; MU32 ** to_keep_end = to_expunge + (cache->p_num_slots - cache->p_free_slots); MU32 new_used_slots = (to_keep_end - to_keep); /* Build new slots data and KV data */ MU32 slot_data_size = new_num_slots * 4; MU32 * new_slot_data = (MU32 *)calloc(1, slot_data_size); MU32 page_data_size = cache->c_page_size - new_num_slots * 4 - P_HEADERSIZE; void * new_kv_data = calloc(1, page_data_size); MU32 new_offset = 0; /* Sanity check underlying fd is still the same file */ if (!mmc_check_fh(cache)) return 0; /* Start all new slots empty */ memset(new_slot_data, 0, slot_data_size); /* Copy entries to keep to new slot entires and data sections */ for (;to_keep < to_keep_end; to_keep++) { MU32 * old_base_det = *to_keep; MU32 * new_slot_ptr; MU32 kvlen; /* Hash key to find starting slot */ MU32 slot = S_SlotHash(old_base_det) % new_num_slots; #ifdef DEBUG /* Check hash actually matches stored value */ { MU32 hash_page_dummy, hash_slot; mmc_hash(cache, S_KeyPtr(old_base_det), S_KeyLen(old_base_det), &hash_page_dummy, &hash_slot); ASSERT(hash_slot == S_SlotHash(old_base_det)); } #endif /* Find free slot */ new_slot_ptr = new_slot_data + slot; while (*new_slot_ptr) { if (++slot >= new_num_slots) { slot = 0; } new_slot_ptr = new_slot_data + slot; } /* Copy slot and KV data */ kvlen = S_SlotLen(old_base_det); memcpy(PTR_ADD(new_kv_data, new_offset), old_base_det, kvlen); /* Store slot data and mark as used */ *new_slot_ptr = new_offset + new_num_slots * 4 + P_HEADERSIZE; ROUNDLEN(kvlen); new_offset += kvlen; } ASSERT(new_offset <= page_data_size); /* printf("page=%d\n", cache->p_cur); printf("old_slots=%d, new_slots=%d\n", old_num_slots, new_num_slots); printf("old_used_slots=%d, new_used_slots=%d\n", old_used_slots, new_used_slots);*/ /* Store back into mmap'ed file space */ memcpy(base_slots, new_slot_data, slot_data_size); memcpy(base_slots + new_num_slots, new_kv_data, new_offset); cache->p_num_slots = new_num_slots; cache->p_free_slots = new_num_slots - new_used_slots; cache->p_old_slots = 0; cache->p_free_data = new_offset + new_num_slots * 4 + P_HEADERSIZE; cache->p_free_bytes = page_data_size - new_offset; /* Make sure changes are saved back to mmap'ed file */ cache->p_changed = 1; /* Free allocated memory */ free(new_kv_data); free(new_slot_data); free(to_expunge); ASSERT(_mmc_test_page(cache)); return 1; } /* * void mmc_get_page_details(mmap_cache * cache, MU32 * n_reads, MU32 * n_read_hits) * * Return details about the current locked page. Currently just * number of reads and number of reads that hit * */ void mmc_get_page_details(mmap_cache * cache, MU32 * n_reads, MU32 * n_read_hits) { *n_reads = cache->p_n_reads; *n_read_hits = cache->p_n_read_hits; return; } /* * void mmc_reset_page_details(mmap_cache * cache) * * Reset any page details (currently just read hits) * */ void mmc_reset_page_details(mmap_cache * cache) { cache->p_n_reads = 0; cache->p_n_read_hits = 0; cache->p_changed = 1; return; } /* * mmap_cache_it * mmc_iterate_new(mmap_cache * cache) * * Setup a new iterator to iterate over stored items * in the cache * */ mmap_cache_it * mmc_iterate_new(mmap_cache * cache) { mmap_cache_it * it = (mmap_cache_it *)calloc(1, sizeof(mmap_cache_it)); it->cache = cache; it->p_cur = NOPAGE; return it; } /* * MU32 * mmc_iterate_next(mmap_cache_it * it) * * Move iterator to next item in the cache and return * pointer to details (0 if there is no next). * * You can retrieve details with mmc_get_details(...) * */ MU32 * mmc_iterate_next(mmap_cache_it * it) { mmap_cache * cache = it->cache; MU32 * slot_ptr = it->slot_ptr; MU32 * base_det; MU32 expire_on; MU32 now = time_override ? time_override : (MU32)time(0); /* Go until we find a slot or exit */ while (1) { /* End of page ... */ if (slot_ptr == it->slot_ptr_end) { if (it->p_cur == NOPAGE) { it->p_cur = 0; /* Unlock current page if any */ } else { mmc_unlock(it->cache); /* Move to the next page, return 0 if no more pages */ if (++it->p_cur == cache->c_num_pages) { it->p_cur = NOPAGE; it->slot_ptr = 0; return 0; } } /* Lock the new page number */ mmc_lock(it->cache, it->p_cur); /* Setup new pointers */ slot_ptr = cache->p_base_slots; it->slot_ptr_end = slot_ptr + cache->p_num_slots; /* Check again */ continue; } /* Slot not used */ if (*slot_ptr <= 1) { slot_ptr++; continue; } /* Get pointer to details for this entry */ base_det = S_Ptr(cache->p_base, *slot_ptr); /* Slot expired */ expire_on = S_ExpireOn(base_det); if (expire_on && now >= expire_on) { slot_ptr++; continue; } break; } /* Move to the next slot for next iteration */ it->slot_ptr = ++slot_ptr; /* Return that we found the next item */ return base_det; } /* * void mmc_iterate_close(mmap_cache_it * it) * * Finish and dispose of iterator memory * */ void mmc_iterate_close(mmap_cache_it * it) { /* Unlock page if locked */ if (it->p_cur != NOPAGE) { mmc_unlock(it->cache); } /* Free memory */ free(it); } /* * void mmc_get_details( * mmap_cache * cache, * MU32 * base_det, * void ** key_ptr, int * key_len, * void ** val_ptr, int * val_len, * MU32 * last_access, MU32 * expire_on, MU32 * flags * ) * * Given a base_det pointer to entries details * (as returned by mmc_iterate_next(...) and * mmc_calc_expunge(...)) return details of that * entry in the cache * */ void mmc_get_details( mmap_cache * cache, MU32 * base_det, void ** key_ptr, int * key_len, void ** val_ptr, int * val_len, MU32 * last_access, MU32 * expire_on, MU32 * flags ) { cache = cache; *key_ptr = S_KeyPtr(base_det); *key_len = S_KeyLen(base_det); *val_ptr = S_ValPtr(base_det); *val_len = S_ValLen(base_det); *last_access = S_LastAccess(base_det); *expire_on = S_ExpireOn(base_det); *flags = S_Flags(base_det); } /* * _mmc_delete_slot( * mmap_cache * cache, MU32 * slot_ptr * ) * * Delete details from the given slot * */ void _mmc_delete_slot( mmap_cache * cache, MU32 * slot_ptr ) { ASSERT(*slot_ptr > 1); ASSERT(cache->p_cur != NOPAGE); /* Set offset to 1 */ *slot_ptr = 1; /* Increase slot free counters */ cache->p_free_slots++; cache->p_old_slots++; /* Ensure changes are saved back */ cache->p_changed = 1; } /* * MU32 * _mmc_find_slot( * mmap_cache * cache, MU32 hash_slot, * void *key_ptr, int key_len, * int mode * ) * * Search current page for a particular 'key'. Use 'hash_slot' to * calculate starting slot. Return pointer to slot. * */ MU32 * _mmc_find_slot( mmap_cache * cache, MU32 hash_slot, void *key_ptr, int key_len, int mode ) { MU32 slots_left, * slots_end; /* Modulo hash_slot to find starting slot */ MU32 * slot_ptr = cache->p_base_slots + (hash_slot % cache->p_num_slots); MU32 * first_deleted = (MU32 *)0; /* Total slots and pointer to end of slot data to do wrapping */ slots_left = cache->p_num_slots; slots_end = cache->p_base_slots + slots_left; ASSERT(cache->p_cur != NOPAGE); /* Loop with integer probing till we find or don't */ while (slots_left--) { MU32 data_offset = *slot_ptr; ASSERT(data_offset == 0 || data_offset == 1 || ((data_offset >= P_HEADERSIZE + cache->p_num_slots*4) && (data_offset < cache->c_page_size) && ((data_offset & 3) == 0))); /* data_offset == 0 means empty slot, and no more beyond */ /* data_offset == 1 means deleted slot, we can reuse if writing */ if (data_offset == 0) { /* Return pointer to last checked slot */ break; } if (data_offset == 1 && mode == 1 && 0 == first_deleted) { /* Save pointer to first usable slot; if we don't find the key later, we'll fall back to returning this. */ first_deleted = slot_ptr; } /* deleted slot, keep looking */ if (data_offset == 1) { } else { /* Offset is from start of data area */ MU32 * base_det = S_Ptr(cache->p_base, data_offset); /* Two longs are key len and data len */ MU32 fkey_len = S_KeyLen(base_det); /* Key matches? */ if (fkey_len == (MU32)key_len && !memcmp(key_ptr, S_KeyPtr(base_det), key_len)) { /* Yep, found it! */ return slot_ptr; } } /* Linear probe and wrap at end of slot data... */ if (++slot_ptr == slots_end) { slot_ptr = cache->p_base_slots; } ASSERT(slot_ptr >= cache->p_base_slots && slot_ptr < slots_end); } /* No slot found */ if (++slots_left == 0) slot_ptr = 0; if (1 == mode && 0 != first_deleted) return first_deleted; else return slot_ptr; } /* * void _mmc_init_page(mmap_cache * cache, int page) * * Initialise the given page as empty * * If page == -1, init all pages * */ void _mmc_init_page(mmap_cache * cache, MU32 p_cur) { MU32 start_page = p_cur, end_page = p_cur+1; if (p_cur == NOPAGE) { start_page = 0; end_page = cache->c_num_pages; } for (p_cur = start_page; p_cur < end_page; p_cur++) { /* Setup page details */ MU64 p_offset = (MU64)p_cur * cache->c_page_size; void * p_ptr = PTR_ADD(cache->mm_var, p_offset); /* Initialise to all 0's */ memset(p_ptr, 0, cache->c_page_size); /* Setup header */ P_Magic(p_ptr) = 0x92f7e3b1; P_NumSlots(p_ptr) = cache->start_slots; P_FreeSlots(p_ptr) = cache->start_slots; P_OldSlots(p_ptr) = 0; P_FreeData(p_ptr) = P_HEADERSIZE + cache->start_slots * 4; P_FreeBytes(p_ptr) = cache->c_page_size - P_FreeData(p_ptr); P_NReads(p_ptr) = 0; P_NReadHits(p_ptr) = 0; } } /* * int _mmc_test_page(mmap_cache * cache) * * Test integrity of current page * */ int _mmc_test_page(mmap_cache * cache) { MU32 * slot_ptr = cache->p_base_slots; MU32 count_free = 0, count_old = 0, max_data_offset = 0; MU32 data_size = cache->c_page_size; ASSERT(cache->p_cur != NOPAGE); if (cache->p_cur == NOPAGE) return 0; for (; slot_ptr < cache->p_base_slots + cache->p_num_slots; slot_ptr++) { MU32 data_offset = *slot_ptr; ASSERT(data_offset == 0 || data_offset == 1 || (data_offset >= P_HEADERSIZE + cache->p_num_slots * 4 && data_offset < cache->c_page_size)); if (!(data_offset == 0 || data_offset == 1 || (data_offset >= P_HEADERSIZE + cache->p_num_slots * 4 && data_offset < cache->c_page_size))) return 0; if (data_offset == 1) { count_old++; } if (data_offset <= 1) { count_free++; continue; } if (data_offset > 1) { MU32 * base_det = S_Ptr(cache->p_base, data_offset); MU32 last_access = S_LastAccess(base_det); MU32 expire_on = S_ExpireOn(base_det); MU32 key_len = S_KeyLen(base_det); MU32 val_len = S_ValLen(base_det); MU32 kvlen = S_SlotLen(base_det); ROUNDLEN(kvlen); ASSERT(last_access > 1000000000); if (!(last_access > 1000000000)) return 0; ASSERT(expire_on == 0 || (expire_on > 1000000000)); if (!(expire_on == 0 || (expire_on > 1000000000))) return 0; ASSERT(key_len >= 0 && key_len < data_size); if (!(key_len >= 0 && key_len < data_size)) return 0; ASSERT(val_len >= 0 && val_len < data_size); if (!(val_len >= 0 && val_len < data_size)) return 0; ASSERT(kvlen >= 4*4 && kvlen < data_size); if (!(kvlen >= 4*4 && kvlen < data_size)) return 0; /* Keep track of largest end of data position */ if (data_offset + kvlen > max_data_offset) { max_data_offset = data_offset + kvlen; } /* Check if key lookup finds same thing */ { MU32 hash_page, hash_slot, * find_slot_ptr; /* Hash it */ mmc_hash(cache, S_KeyPtr(base_det), (int)key_len, &hash_page, &hash_slot); ASSERT(hash_slot == S_SlotHash(base_det)); if (!(hash_slot == S_SlotHash(base_det))) return 0; find_slot_ptr = _mmc_find_slot(cache, hash_slot, S_KeyPtr(base_det), key_len, 0); ASSERT(find_slot_ptr == slot_ptr); if (!(find_slot_ptr == slot_ptr)) return 0; } } } ASSERT(count_free == cache->p_free_slots); if (!(count_free == cache->p_free_slots)) return 0; ASSERT(count_old == cache->p_old_slots); if (!(count_old == cache->p_old_slots)) return 0; ASSERT(cache->p_free_data >= max_data_offset); if (!(cache->p_free_data >= max_data_offset)) return 0; return 1; } /* * int _mmc_dump_page(mmap_cache * cache) * * Dump text version of current page to STDOUT * */ int _mmc_dump_page(mmap_cache * cache) { MU32 slot; ASSERT(cache->p_cur != NOPAGE); printf("PageNum: %d\n", cache->p_cur); printf("\n"); printf("PageSize: %d\n", cache->c_page_size); printf("BasePage: %p\n", cache->p_base); printf("BaseSlots: %p\n", cache->p_base_slots); printf("\n"); printf("NumSlots: %d\n", cache->p_num_slots); printf("FreeSlots: %d\n", cache->p_free_slots); printf("OldSlots: %d\n", cache->p_old_slots); printf("FreeData: %d\n", cache->p_free_data); printf("FreeBytes: %d\n", cache->p_free_bytes); for (slot = 0; slot < cache->p_num_slots; slot++) { MU32 * slot_ptr = cache->p_base_slots + slot; printf("Slot: %d; OF=%d; ", slot, *slot_ptr); if (*slot_ptr > 1) { MU32 * base_det = S_Ptr(cache->p_base, *slot_ptr); MU32 key_len = S_KeyLen(base_det); MU32 val_len = S_ValLen(base_det); char key[256], val[256]; printf("LA=%d, ET=%d, HS=%d, FL=%d\n", S_LastAccess(base_det), S_ExpireOn(base_det), S_SlotHash(base_det), S_Flags(base_det)); /* Get data */ memcpy(key, S_KeyPtr(base_det), key_len > 256 ? 256 : key_len); key[key_len] = 0; memcpy(val, S_ValPtr(base_det), val_len > 256 ? 256 : val_len); val[val_len] = 0; printf(" K=%s, V=%s\n", key, val); } } return 0; } Cache-FastMmap-1.58/MANIFEST0000644000000000000000000000071315006062764014016 0ustar rootrootChanges FastMmap.xs lib/Cache/FastMmap.pm Makefile.PL MANIFEST This list of files MANIFEST.SKIP META.yml mmap_cache.c mmap_cache.h mmap_cache_internals.h mmap_cache_test.c ppport.h README t/1.t t/10.t t/11.t t/12.t t/13.t t/14.t t/15.t t/16.t t/17.t t/18.t t/19.t t/2.t t/20.t t/21.t t/22.t t/23.t t/3.t t/4.t t/5.t t/6.t t/7.t t/8.t t/9.t t/FastMmapTest.pl unix.c win32.c META.json Module JSON meta-data (added by MakeMaker) Cache-FastMmap-1.58/mmap_cache_internals.h0000644000000000000000000000623515006060471017170 0ustar rootroot#ifndef mmap_cache_internals_h #define mmap_cache_internals_h #ifdef DEBUG #define ASSERT(x) assert(x) #include #else #define ASSERT(x) #endif #ifdef WIN32 #include #endif /* Cache structure */ struct mmap_cache { /* Current page details */ void * p_base; MU32 * p_base_slots; MU32 p_cur; MU64 p_offset; MU32 p_num_slots; MU32 p_free_slots; MU32 p_old_slots; MU32 p_free_data; MU32 p_free_bytes; MU32 p_n_reads; MU32 p_n_read_hits; int p_changed; /* General page details */ MU32 c_num_pages; MU32 c_page_size; MU64 c_size; /* Pointer to mmapped area */ void * mm_var; /* Cache general details */ MU32 start_slots; MU32 expire_time; int catch_deadlocks; int enable_stats; /* Share mmap file details */ #ifdef WIN32 HANDLE fh; #else int fh; MU64 inode; #endif char * share_file; int permissions; int init_file; int test_file; int cache_not_found; /* Last error string */ char * last_error; }; struct mmap_cache_it { mmap_cache * cache; MU32 p_cur; MU32 * slot_ptr; MU32 * slot_ptr_end; }; /* Macros to access page entries */ #define PP(p) ((MU32 *)p) #define P_Magic(p) (*(PP(p)+0)) #define P_NumSlots(p) (*(PP(p)+1)) #define P_FreeSlots(p) (*(PP(p)+2)) #define P_OldSlots(p) (*(PP(p)+3)) #define P_FreeData(p) (*(PP(p)+4)) #define P_FreeBytes(p) (*(PP(p)+5)) #define P_NReads(p) (*(PP(p)+6)) #define P_NReadHits(p) (*(PP(p)+7)) #define P_HEADERSIZE 32 /* Macros to access cache slot entries */ #define SP(s) ((MU32 *)s) /* Offset pointer 'p' by 'o' bytes */ #define PTR_ADD(p,o) ((void *)((char *)p + o)) /* Given a data pointer, get key len, value len or combined len */ #define S_Ptr(b,s) ((MU32 *)PTR_ADD(b, s)) #define S_LastAccess(s) (*(s+0)) #define S_ExpireOn(s) (*(s+1)) #define S_SlotHash(s) (*(s+2)) #define S_Flags(s) (*(s+3)) #define S_KeyLen(s) (*(s+4)) #define S_ValLen(s) (*(s+5)) #define S_KeyPtr(s) ((void *)(s+6)) #define S_ValPtr(s) (PTR_ADD((void *)(s+6), S_KeyLen(s))) /* Length of slot data including key and value data */ #define S_SlotLen(s) (sizeof(MU32)*6 + S_KeyLen(s) + S_ValLen(s)) #define KV_SlotLen(k,v) (sizeof(MU32)*6 + k + v) /* Found key/val len to nearest 4 bytes */ #define ROUNDLEN(l) ((l) += 3 - (((l)-1) & 3)) /* Externs from mmap_cache.c */ extern char * def_share_file; extern MU32 def_init_file; extern MU32 def_test_file; extern MU32 def_expire_time; extern MU32 def_c_num_pages; extern MU32 def_c_page_size; extern MU32 def_start_slots; extern char* _mmc_get_def_share_filename(mmap_cache * cache); /* Platform specific functions defined in unix.c | win32.c */ int mmc_open_cache_file(mmap_cache* cache, int * do_init); int mmc_map_memory(mmap_cache* cache); int mmc_unmap_memory(mmap_cache* cache); int mmc_lock_page(mmap_cache* cache, MU64 p_offset); int mmc_unlock_page(mmap_cache * cache); int mmc_check_fh(mmap_cache* cache); int mmc_close_fh(mmap_cache* cache); int _mmc_set_error(mmap_cache *cache, int err, char * error_string, ...); char* _mmc_get_def_share_filename(mmap_cache * cache); #endif