MLDBM-Sync-0.30/0040755000000000000000000000000007510526312011704 5ustar rootrootMLDBM-Sync-0.30/README0100755000076400007640000002757207510526165012227 0ustar jobjobNAME MLDBM::Sync - safe concurrent access to MLDBM databases SYNOPSIS use MLDBM::Sync; # this gets the default, SDBM_File use MLDBM qw(DB_File Storable); # use Storable for serializing use MLDBM qw(MLDBM::Sync::SDBM_File); # use extended SDBM_File, handles values > 1024 bytes use Fcntl qw(:DEFAULT); # import symbols O_CREAT & O_RDWR for use with DBMs # NORMAL PROTECTED read/write with implicit locks per i/o request my $sync_dbm_obj = tie %cache, 'MLDBM::Sync' [..other DBM args..] or die $!; $cache{"AAAA"} = "BBBB"; my $value = $cache{"AAAA"}; # SERIALIZED PROTECTED read/write with explicit lock for both i/o requests my $sync_dbm_obj = tie %cache, 'MLDBM::Sync', '/tmp/syncdbm', O_CREAT|O_RDWR, 0640; $sync_dbm_obj->Lock; $cache{"AAAA"} = "BBBB"; my $value = $cache{"AAAA"}; $sync_dbm_obj->UnLock; # SERIALIZED PROTECTED READ access with explicit read lock for both reads $sync_dbm_obj->ReadLock; my @keys = keys %cache; my $value = $cache{'AAAA'}; $sync_dbm_obj->UnLock; # MEMORY CACHE LAYER with Tie::Cache $sync_dbm_obj->SyncCacheSize('100K'); # KEY CHECKSUMS, for lookups on MD5 checksums on large keys my $sync_dbm_obj = tie %cache, 'MLDBM::Sync', '/tmp/syncdbm', O_CREAT|O_RDWR, 0640; $sync_dbm_obj->SyncKeysChecksum(1); my $large_key = "KEY" x 10000; $sync{$large_key} = "LARGE"; my $value = $sync{$large_key}; DESCRIPTION This module wraps around the MLDBM interface, by handling concurrent access to MLDBM databases with file locking, and flushes i/o explicity per lock/unlock. The new [Read]Lock()/UnLock() API can be used to serialize requests logically and improve performance for bundled reads & writes. my $sync_dbm_obj = tie %cache, 'MLDBM::Sync', '/tmp/syncdbm', O_CREAT|O_RDWR, 0640; # Write locked critical section $sync_dbm_obj->Lock; ... all accesses to DBM LOCK_EX protected, and go to same tied file handles $cache{'KEY'} = 'VALUE'; $sync_dbm_obj->UnLock; # Read locked critical section $sync_dbm_obj->ReadLock; ... all read accesses to DBM LOCK_SH protected, and go to same tied files ... WARNING, cannot write to DBM in ReadLock() section, will die() ... WARNING, my $v = $cache{'KEY'}{'SUBKEY'} will trigger a write so not safe ... to use in ReadLock() section my $value = $cache{'KEY'}; $sync_dbm_obj->UnLock; # Normal access OK too, without explicity locking $cache{'KEY'} = 'VALUE'; my $value = $cache{'KEY'}; MLDBM continues to serve as the underlying OO layer that serializes complex data structures to be stored in the databases. See the MLDBM the BUGS manpage section for important limitations. MLDBM::Sync also provides built in RAM caching with Tie::Cache md5 key checksum functionality. INSTALL Like any other CPAN module, either use CPAN.pm, or perl -MCPAN "-e" shell, or get the file MLDBM-Sync-x.xx.tar.gz, unzip, untar and: perl Makefile.PL make make test make install LOCKING The MLDBM::Sync wrapper protects MLDBM databases by locking and unlocking around read and write requests to the databases. Also necessary is for each new lock to tie() to the database internally, untie()ing when unlocking. This flushes any i/o for the dbm to the operating system, and allows for concurrent read/write access to the databases. Without any extra effort from the developer, an existing MLDBM database will benefit from MLDBM::sync. my $dbm_obj = tie %dbm, ...; $dbm{"key"} = "value"; As a write or STORE operation, the above will automatically cause the following: $dbm_obj->Lock; # also ties $dbm{"key"} = "value"; $dbm_obj->UnLock; # also unties Just so, a read or FETCH operation like: my $value = $dbm{"key"}; will really trigger: $dbm_obj->ReadLock; # also ties my $value = $dbm{"key"}; $dbm_obj->Lock; # also unties However, these lock operations are expensive because of the underlying tie()/untie() that occurs for i/o flushing, so when bundling reads & writes, a developer may explicitly use this API for greater performance: # tie once to database, write 100 times $dbm_obj->Lock; for (1..100) { $dbm{$_} = $_ * 100; ... } $dbm_obj->UnLock; # only tie once to database, and read 100 times $dbm_obj->ReadLock; for(1..100) { my $value = $dbm{$_}; ... } $dbm_obj->UnLock; CACHING I built MLDBM::Sync to serve as a fast and robust caching layer for use in multi-process environments like mod_perl. In order to provide an additional speed boost when caching static data, I have added an RAM caching layer with Tie::Cache, which regulates the size of the memory used with its MaxBytes setting. To activate this caching, just: my $dbm = tie %cache, 'MLDBM::Sync', '/tmp/syncdbm', O_CREAT|O_RDWR, 0640; $dbm->SyncCacheSize(100000); # 100000 bytes max memory used $dbm->SyncCacheSize('100K'); # 100 Kbytes max memory used $dbm->SyncCacheSize('1M'); # 1 Megabyte max memory used The ./bench/bench_sync.pl, run like "bench_sync.pl "-c"" will run the tests with caching turned on creating a benchmark with 50% cache hits. One run without caching was: === INSERT OF 50 BYTE RECORDS === Time for 100 writes + 100 reads for SDBM_File 0.16 seconds 12288 bytes Time for 100 writes + 100 reads for MLDBM::Sync::SDBM_File 0.17 seconds 12288 bytes Time for 100 writes + 100 reads for GDBM_File 3.37 seconds 17980 bytes Time for 100 writes + 100 reads for DB_File 4.45 seconds 20480 bytes And with caching, with 50% cache hits: === INSERT OF 50 BYTE RECORDS === Time for 100 writes + 100 reads for SDBM_File 0.11 seconds 12288 bytes Time for 100 writes + 100 reads for MLDBM::Sync::SDBM_File 0.11 seconds 12288 bytes Time for 100 writes + 100 reads for GDBM_File 2.49 seconds 17980 bytes Time for 100 writes + 100 reads for DB_File 2.55 seconds 20480 bytes Even for SDBM_File, this speedup is near 33%. KEYS CHECKSUM A common operation on database lookups is checksumming the key, prior to the lookup, because the key could be very large, and all one really wants is the data it maps too. To enable this functionality automatically with MLDBM::Sync, just: my $sync_dbm_obj = tie %cache, 'MLDBM::Sync', '/tmp/syncdbm', O_CREAT|O_RDWR, 0640; $sync_dbm_obj->SyncKeysChecksum(1); !! WARNING: keys() & each() do not work on these databases !! as of v.03, so the developer will not be fooled into thinking !! the stored key values are meaningful to the calling application !! and will die() if called. !! !! This behavior could be relaxed in the future. An example of this might be to cache a XSLT conversion, which are typically very expensive. You have the XML data and the XSLT data, so all you do is: # $xml_data, $xsl_data are strings my $xslt_output; unless ($xslt_output = $cache{$xml_data.'&&&&'.$xsl_data}) { ... do XSLT conversion here for $xslt_output ... $cache{$xml_data.'&&&&'.xsl_data} = $xslt_output; } What you save by doing this is having to create HUGE keys to lookup on, which no DBM is likely to do efficiently. This is the same method that File::Cache uses internally to hash its file lookups in its directories. New MLDBM::Sync::SDBM_File SDBM_File, the default used for MLDBM and therefore MLDBM::Sync has a limit of 1024 bytes for the size of a record. SDBM_File is also an order of magnitude faster for small records to use with MLDBM::Sync, than DB_File or GDBM_File, because the tie()/untie() to the dbm is much faster. Therefore, bundled with MLDBM::Sync release is a MLDBM::Sync::SDBM_File layer which works around this 1024 byte limit. To use, just: use MLDBM qw(MLDBM::Sync::SDBM_File); It works by breaking up up the STORE() values into small 128 byte segments, and spreading those segments across many records, creating a virtual record layer. It also uses Compress::Zlib to compress STORED data, reducing the number of these 128 byte records. In benchmarks, 128 byte record segments seemed to be a sweet spot for space/time efficiency, as SDBM_File created very bloated *.pag files for 128+ byte records. BENCHMARKS In the distribution ./bench directory is a bench_sync.pl script that can benchmark using the various DBMs with MLDBM::Sync. The MLDBM::Sync::SDBM_File DBM is special because is uses SDBM_File for fast small inserts, but slows down linearly with the size of the data being inserted and read. The results for a dual PIII-450 linux 2.4.7, with a ext3 file system blocksize 4096 mounted async on a RAID-1 2xIDE 7200 RPM disk were as follows: === INSERT OF 50 BYTE RECORDS === Time for 100 writes + 100 reads for SDBM_File 0.16 seconds 12288 bytes Time for 100 writes + 100 reads for MLDBM::Sync::SDBM_File 0.19 seconds 12288 bytes Time for 100 writes + 100 reads for GDBM_File 1.09 seconds 18066 bytes Time for 100 writes + 100 reads for DB_File 0.67 seconds 12288 bytes Time for 100 writes + 100 reads for Tie::TextDir .04 0.31 seconds 13192 bytes === INSERT OF 500 BYTE RECORDS === (skipping test for SDBM_File 100 byte limit) Time for 100 writes + 100 reads for MLDBM::Sync::SDBM_File 0.52 seconds 110592 bytes Time for 100 writes + 100 reads for GDBM_File 1.20 seconds 63472 bytes Time for 100 writes + 100 reads for DB_File 0.66 seconds 86016 bytes Time for 100 writes + 100 reads for Tie::TextDir .04 0.32 seconds 58192 bytes === INSERT OF 5000 BYTE RECORDS === (skipping test for SDBM_File 100 byte limit) Time for 100 writes + 100 reads for MLDBM::Sync::SDBM_File 1.41 seconds 1163264 bytes Time for 100 writes + 100 reads for GDBM_File 1.38 seconds 832400 bytes Time for 100 writes + 100 reads for DB_File 1.21 seconds 831488 bytes Time for 100 writes + 100 reads for Tie::TextDir .04 0.58 seconds 508192 bytes === INSERT OF 20000 BYTE RECORDS === (skipping test for SDBM_File 100 byte limit) (skipping test for MLDBM::Sync db size > 1M) Time for 100 writes + 100 reads for GDBM_File 2.23 seconds 2063912 bytes Time for 100 writes + 100 reads for DB_File 1.89 seconds 2060288 bytes Time for 100 writes + 100 reads for Tie::TextDir .04 1.26 seconds 2008192 bytes === INSERT OF 50000 BYTE RECORDS === (skipping test for SDBM_File 100 byte limit) (skipping test for MLDBM::Sync db size > 1M) Time for 100 writes + 100 reads for GDBM_File 3.66 seconds 5337944 bytes Time for 100 writes + 100 reads for DB_File 3.64 seconds 5337088 bytes Time for 100 writes + 100 reads for Tie::TextDir .04 2.80 seconds 5008192 bytes AUTHORS Copyright (c) 2001-2002 Joshua Chamas, Chamas Enterprises Inc. All rights reserved. Sponsored by development on NodeWorks http://www.nodeworks.com and Apache::ASP http://www.apache-asp.org This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. SEE ALSO MLDBM(3), SDBM_File(3), DB_File(3), GDBM_File(3) MLDBM-Sync-0.30/MANIFEST0100644000000000000000000000036207510526144013036 0ustar rootrootCHANGES MANIFEST This list of files MANIFEST.SKIP MANIFEST.bak Makefile Makefile.PL README Sync.pm bench/bench_sync.pl lib/MLDBM/Sync/SDBM_File.pm t/T.pm t/cache.t t/general.t t/key_checksum.t t/locks.t t/sdbm_big_rec.t t/taint.t t/zdone.t MLDBM-Sync-0.30/CHANGES0100755000076400007640000001243107510526275012330 0ustar jobjob$MODULE = "MLDBM::Sync"; $VERSION = '.30'; $DATE = '2002/07/03'; + Added MLDBM to the list of PREREQ_PM modules for better CPAN installation $MODULE = "MLDBM::Sync"; $VERSION = .27; $DATE = '2002/06/23'; + Added note to error for Lock upgrade during ReadLock for case of doing unintentional write with construct like: tied(%dbm)->ReadLock; my $v = $dbm{'key'}{'key2'}; # will error with write !! ^^^^^^^^^ Thanks to Steve Keith for noting this bizarre perl behavior. + bench/bench_sync.pl now creates a test dbm in the local directory being run instead of /tmp ... benchmark results were being skewed since /tmp could be a fast RAM cache file system like tmpfs on Linux + Added MANIFEST.SKIP for building + t/taint.t perl taint check test added. + escape inbound file parameter for safe taint checking $MODULE = "MLDBM::Sync"; $VERSION = .25; $DATE = '2001/11/11'; + Honors the $MLDBM::RemoveTaint setting when MLDBM::Sync object is created, storing for later creation of the MLDBM tied object $MODULE = "MLDBM::Sync"; $VERSION = .23; $DATE = '2001/11/08'; + Updated AUTHORS section with perl license reference. + ./bench/bench_sync.pl has -n argument to specify # of reads/writes where default is 100 + ./bench/bench_sync.pl has --bundle argument to allows for reads/writes in locked sections of that #, which improves performance. + $dbm->Size() for Tie::TextDir now adds size of directory as reported by OS. This still does not seem to take into account the extra file inode overhead on a file system like ext2 linux but its better now at least. $MODULE = "MLDBM::Sync"; $VERSION = .21; $DATE = '2001/10/31'; + Added support in CLEAR() & SyncSize() for a tie directory based data structure like Tie::TextDir $MODULE = "MLDBM::Sync"; $VERSION = .19; $DATE = '2001/10/15'; - Fixed keys(%hash), where one of the keys was boolean FALSE like '', or 0. Bug found by Elliot Glaysher. $MODULE = "MLDBM::Sync"; $VERSION = .17; $DATE = '2001/10/11'; - Make EXISTS safe after explicity tied hash ReadLock() - For loops in MLDBM::Sync::SDBM_File that are friendlier to perl5.004_04 - Better Lock() return value, whether or not a lock has previously been acquired $MODULE = "MLDBM::Sync"; $VERSION = .15; $DATE = '2001/09/21'; - API fixes for easier integration with Apache::ASP - Made $sync_dbm->UnLock() repeatable, with the next $sync_dbm->Lock() still working. $MODULE = "MLDBM::Sync"; $VERSION = .11; $DATE = '2001/09/12'; ++ Taking module out of BETA. Been using it in production for 3 months, and in development for 6. - Bug fix for undefined warning in MLDBM::Sync::SDBM_File - MLDBM::Sync::SDBM_File STORE() now deletes prior key parts before storing the value, which will result in more correct behavior, there was a possible bug here. Added a test in t/sdbm_rec_big.t testing for this possible error. + Deletion of lock file when calling CLEAR(), or %dbm = () Do this after unlock, which _might_ have a race condition but haven't seen in in heavy load testing... MLDBM::Sync recreates the lock file every time if necessary, so this may not be an issue anyway. Might be good to unlink before unlocking, but this might only work on *nix platformns, now Win32. $MODULE = "MLDBM::Sync"; $VERSION = .09; $DATE = '2001/07/31'; - Bug fix for undefined warning in MLDBM::Sync::SDBM_File $MODULE = "MLDBM::Sync"; $VERSION = .07; $DATE = '2001/03/18'; + $dbm->SyncCacheSize() API activates 2nd layer RAM cache via Tie::Cache with MaxBytes set. + CACHE documentation, cache.t test, sample benchmarks with ./bench/bench_sync.pl -c $MODULE = "MLDBM::Sync"; $VERSION = .05; $DATE = '2001/03/13'; + Simpler use of locking. - Read locking works on Solaris, had to open lock file in read/write mode. Linux/NT didn't care. $MODULE = "MLDBM::Sync"; $VERSION = .03; $DATE = 'TBA'; + $dbm_obj->SyncKeysChecksum(1) API documented. New internal format that does not store the original key with keys() & each() throwing errors now if used on this kind of database. + ReadLock() API added, that does a LOCK_SH internally. Also uses ReadLock() for FETCH and *KEY operations. ** WARNING: one may not ReadLock() and then write to the dbm, or that will die in an error. Must UnLock() first. Writes may only occur in a Lock() section, which does a LOCK_EX internally. + Better backward compatibility with old SDBM_Files for MLDBM::Sync::SDBM_File, also new format not compatible with .01 format. + Better test for MLDBM::Sync::SDBM_File, using keys with odd characters. $MODULE = "MLDBM::Sync"; $VERSION = .01; $DATE = '2001/02/07'; + Initial release with flock concurrent access control to MLDBM databases. + Also MLDBM::Sync::SDBM_File wrapper for getting around the 1024 byte / record limitation for sDBM_File. Writes data in segments of 128 bytes. This was created because SDBM_File access is an order of magnitude faster than DB_File on Linux with tie/untie per write in the MLDBM::Sync model, which is for i/o flushing do dbms don't get corrupt. But, then one has to worry about exceeding the 1024 byte limit, which can happen for serializing larger objects. Well worry no more! MLDBM-Sync-0.30/Makefile.PL0100755000076400007640000000026307510515234013300 0ustar jobjob#!/usr/local/bin/perl use ExtUtils::MakeMaker; &WriteMakefile( NAME => "MLDBM::Sync", VERSION_FROM => 'Sync.pm', PREREQ_PM => { MLDBM => 1, }, ); MLDBM-Sync-0.30/t/0040755000000000000000000000000007510526312012147 5ustar rootrootMLDBM-Sync-0.30/t/taint.t0100644000000000000000000000147507505512073013462 0ustar rootroot#!/usr/local/bin/perl -T use lib qw(. t); use strict; use MLDBM::Sync; use Fcntl; use T; use Carp; $SIG{__WARN__} = \&Carp::cluck; my $t = T->new(); my %db; my $sync = tie %db, 'MLDBM::Sync', 'test_dbm', O_RDWR|O_CREAT, 0640; %db = (); $t->eok($sync, "can't tie to MLDBM::Sync"); for(1..99) { my $key = $_; my $value = rand; $db{$key} = $value; $t->eok($db{$key} eq $value, "can't fetch key $key value $value from db"); } $db{''} = ''; $t->eok(scalar(keys %db) == 100, "key count not successful"); $db{"DEL"} = "DEL"; $t->eok($db{"DEL"}, "failed to add key to delete"); delete $db{"DEL"}; $t->eok(! $db{"DEL"}, "failed to delete key"); $t->eok(scalar(keys %db) == 100, "key count not successful"); %db = (); $t->eok(scalar(keys %db) == 0, "CLEAR not successful"); $t->done; MLDBM-Sync-0.30/t/general.t0100755000076400007640000000144307505521441013375 0ustar jobjob use lib qw(. t); use strict; use MLDBM::Sync; use Fcntl; use T; use Carp; $SIG{__WARN__} = \&Carp::cluck; my $t = T->new(); my %db; my $sync = tie %db, 'MLDBM::Sync', 'test_dbm', O_RDWR|O_CREAT, 0640; %db = (); $t->eok($sync, "can't tie to MLDBM::Sync"); for(1..99) { my $key = $_; my $value = rand; $db{$key} = $value; $t->eok($db{$key} eq $value, "can't fetch key $key value $value from db"); } $db{''} = ''; $t->eok(scalar(keys %db) == 100, "key count not successful"); $db{"DEL"} = "DEL"; $t->eok($db{"DEL"}, "failed to add key to delete"); delete $db{"DEL"}; $t->eok(! $db{"DEL"}, "failed to delete key"); $t->eok(scalar(keys %db) == 100, "key count not successful"); %db = (); $t->eok(scalar(keys %db) == 0, "CLEAR not successful"); $t->done; MLDBM-Sync-0.30/t/cache.t0100755000076400007640000000204607255054003013020 0ustar jobjob use lib qw(. t); use strict; use MLDBM::Sync; use Fcntl; use T; use Carp; $SIG{__WARN__} = \&Carp::cluck; my $t = T->new(); eval "use Tie::Cache"; if($@) { $t->skip('Tie::Cache not installed'); } my %db; my $sync = tie %db, 'MLDBM::Sync', 'test_dbm', O_RDWR|O_CREAT, 0640; for my $cache_size (10240, '10K', '.01M') { eval { $sync->SyncCacheSize($cache_size); }; $t->eok($sync->{cache}{max_bytes} == 10240, "failed to init cache of 10240 bytes"); } %db = (); $t->eok($sync, "can't tie to MLDBM::Sync"); for(1..100) { my $key = $_; my $value = rand; $db{$key} = $value; $t->eok($db{$key} eq $value, "can't fetch key $key value $value from db"); } $t->eok(scalar(keys %db) == 100, "key count not successful"); $db{"DEL"} = "DEL"; $t->eok($db{"DEL"}, "failed to add key to delete"); delete $db{"DEL"}; $t->eok(! $db{"DEL"}, "failed to delete key"); $t->eok(scalar(keys %db) == 100, "key count not successful"); %db = (); $t->eok(scalar(keys %db) == 0, "CLEAR not successful"); $t->done; MLDBM-Sync-0.30/t/zdone.t0100644000000000000000000000046507375244713013470 0ustar rootroot use lib qw(. t); use strict; use MLDBM::Sync; use Fcntl; use T; use Carp; $SIG{__WARN__} = \&Carp::cluck; my $t = T->new(); my %db; my $sync = tie %db, 'MLDBM::Sync', 'test_dbm', O_RDWR|O_CREAT, 0640; %db = (); $t->eok(! glob('test_dbm*'), "can't use %db = () to delete files!"); $t->done; MLDBM-Sync-0.30/t/sdbm_big_rec.t0100755000076400007640000000243407347765577014410 0ustar jobjob use lib qw(. t); use strict; use MLDBM::Sync; use MLDBM qw(MLDBM::Sync::SDBM_File); use Fcntl; use T; use Carp; $SIG{__DIE__} = \&Carp::confess; $SIG{__WARN__} = \&Carp::cluck; my $t = T->new(); my %db; my $sync = tie %db, 'MLDBM::Sync', 'test_dbm', O_RDWR|O_CREAT, 0640; %db = (); $t->eok($sync, "can't tie to MLDBM::Sync"); for(1..10) { my $key = $_; my $value = ('G}'.rand().'*%**') x 200; $db{$key} = $value; $t->eok($db{$key} eq $value, "can't fetch key $key value $value from db, got $db{$key}"); } $t->eok(scalar(keys %db) == 10, "key count not successful"); my $del_value = "DELETED".join('', map { rand() } 1..100); $db{"DEL"} = $del_value; $t->eok($db{"DEL"} eq $del_value, "failed to add key to delete"); $t->eok(delete $db{"DEL"} eq $del_value, "failed to get right delete return value"); my $short_del = substr($del_value,0,100); $db{"DEL"} = $del_value; $db{"DEL"} = $short_del; $t->eok($db{"DEL"} eq $short_del, "failed to add short value to delete"); $t->eok(delete $db{"DEL"} eq $short_del, "failed to get right short delete return value"); $t->eok(! $db{"DEL"}, "failed to delete key"); $t->eok(scalar(keys %db) == 10, "key count not successful"); %db = (); $t->eok(scalar(keys %db) == 0, "CLEAR not successful"); $t->done; MLDBM-Sync-0.30/t/locks.t0100755000076400007640000000215307360416675013105 0ustar jobjob use lib qw(. t); use strict; use MLDBM::Sync; use Fcntl; use T; use Carp; $SIG{__WARN__} = \&Carp::cluck; my $t = T->new(); my %db; my $sync = tie %db, 'MLDBM::Sync', 'test_dbm', O_RDWR|O_CREAT, 0640; %db = (); $t->eok($sync, "can't tie to MLDBM::Sync"); my %keys; $sync->Lock; for(1..100) { my $key = $_; my $value = rand; $db{$key} = $value; $keys{$key} = $value; } $sync->UnLock; # test for all in read block $sync->ReadLock; for my $key (keys %keys) { $t->eok($keys{$key} eq $db{$key}, "can't fetch right value for key $key"); $t->eok(exists $keys{$key}, "can't exists for key $key in ReadLock() section"); } $sync->UnLock; # mix write/read locks $sync->Lock; $t->eok(scalar(keys %db) == 100, "key count not successful"); $sync->UnLock; # read lock then write, should cause error eval { $sync->ReadLock; $db{"DEL"} = "DEL"; # should error here $sync->UnLock; }; $t->eok($@, "no error thrown for Read... Write"); $sync->UnLock; # clear the read lock record %db = (); $t->eok(scalar(keys %db) == 0, "CLEAR not successful"); $t->done; MLDBM-Sync-0.30/t/T.pm0100755000076400007640000000311207255052072012330 0ustar jobjob#!perl -w package T; use Carp qw(cluck); no strict 'vars'; sub new { my($class, $data, $input) = @_; $class ||= 'T'; bless { 'data' => $data, 'input' => $input, 't' => 0 }, $class; } sub skip { my($self, $message) = @_; $message ||= ''; $self->{t}++; $self->{buffer} .= "ok $self->{t} # skip\n"; print STDERR "skipping test: $message; "; $self->done; exit; } sub ok { my $self = shift; $self->{t}++; $self->{buffer} .= "ok $self->{t}\n"; } *not = *not_ok; sub not_ok { my($self, $warn) = @_; if($warn) { die "[failure] $warn"; } $self->{t}++; $self->{buffer} .= "not ok\n"; } sub add { $_[0]->{buffer} .= "$_[1]\n"; } sub test { my($self) = @_; my($k, $v); while(($k, $v) = each %{$self->{data}}) { $test = "$k=$v"; if($self->{input} =~ /\[\[$test\]\]/) { $self->ok(); } else { $self->not_ok(); print "$test data not found\n"; } } } sub done { my $self = shift; return if $self->{done}++; print "1..$self->{t}\n"; print $self->{buffer}; } sub do { my($class, $data, $input) = @_; my $self = new($class, $data, $input); $self->test(); $self->done(); 1; } *eok = *eval_ok; sub eval_ok { my($self, $test, $error) = @_; my $result = (ref($test) =~ /CODE/) ? eval { &$test } : eval { $test }; if($result) { $self->ok(); } else { my $tail = $@ ? ", $@" : ''; $self->not($error.$tail); } $result; } 1; MLDBM-Sync-0.30/t/key_checksum.t0100755000076400007640000000170707250560072014435 0ustar jobjob use lib qw(. t); use strict; use MLDBM::Sync; use Fcntl; use T; use Carp; $SIG{__WARN__} = \&Carp::cluck; my $t = T->new(); my %db; my $sync = tie %db, 'MLDBM::Sync', 'test_dbm', O_RDWR|O_CREAT, 0640; $sync->SyncKeysChecksum(1); %db = (); $t->eok($sync, "can't tie to MLDBM::Sync"); my %keys; $sync->Lock; for(1..100) { my $key = $_ x 1000; # only checksumming will work for this my $value = rand; $db{$key} = $value; $keys{$key} = $value; } $sync->UnLock; my @keys = eval { keys %db; }; my $error = $@; $t->eok(! scalar(@keys), "keys should return undef"); $t->eok($error, "keys should return an error on a SyncKeysChecksum(1) database"); # test for all in read block $sync->ReadLock; for my $key (keys %keys) { $t->eok($keys{$key} eq $db{$key}, "can't fetch right value for key $key"); } $sync->UnLock; %db = (); $t->eok($sync->SyncSize == 0, 'dbm size should be 0 bytes after clear'); $t->done; MLDBM-Sync-0.30/lib/0040755000000000000000000000000007510526312012452 5ustar rootrootMLDBM-Sync-0.30/lib/MLDBM/0040755000000000000000000000000007510526312013305 5ustar rootrootMLDBM-Sync-0.30/lib/MLDBM/Sync/0040755000000000000000000000000007510526312014221 5ustar rootrootMLDBM-Sync-0.30/lib/MLDBM/Sync/SDBM_File.pm0100755000076400007640000000664107361406515015700 0ustar jobjob package MLDBM::Sync::SDBM_File; $VERSION = .17; use SDBM_File; use strict; use vars qw(@ISA $MaxSegments $MaxSegmentLength %KEYS $Zlib $VERSION); @ISA = qw(SDBM_File); $MaxSegments = 8192; # to a 1M limit # leave room for key index pad $MaxSegmentLength = 128; eval "use Compress::Zlib"; $Zlib = $@ ? 0 : 1; sub FETCH { my($self, $key) = @_; my $segment_length = $MaxSegmentLength; my $total_rv; for(my $index = 0; $index < $MaxSegments; $index++) { my $rv = $self->SUPER::FETCH(_index_key($key, $index)); if(defined $rv) { $total_rv ||= ''; $total_rv .= $rv; last if length($rv) < $segment_length; } else { last; } } if(defined $total_rv) { $total_rv =~ s/^(..)//s; my $type = $1; if($type eq 'G}') { $total_rv = uncompress($total_rv); } elsif ($type eq 'N}') { # nothing } else { # old SDBM_File ? $total_rv = $type . $total_rv; } } $total_rv; } sub STORE { my($self, $key, $value) = @_; my $segment_length = $MaxSegmentLength; # DELETE KEYS FIRST for(my $index = 0; $index < $MaxSegments; $index++) { my $index_key = _index_key($key, $index); my $rv = $self->SUPER::FETCH($index_key); if(defined $rv) { $self->SUPER::DELETE($index_key); } else { last; } last if length($rv) < $segment_length; } # G - Gzip compression # N - No compression # my $old_value = $value; $value = ($Zlib && (length($value) >= $segment_length/2)) ? "G}".compress($value) : "N}".$value; my($total_rv, $last_index); for(my $index = 0; $index < $MaxSegments; $index++) { if($index == $MaxSegments) { die("can't store more than $MaxSegments segments of $MaxSegmentLength bytes per key in ".__PACKAGE__); } $value =~ s/^(.{0,$segment_length})//so; my $segment = $1; last if length($segment) == 0; # print "STORING "._index_key($key, $index)." $segment\n"; my $rv = $self->SUPER::STORE(_index_key($key, $index), $segment); $total_rv .= $segment; $last_index = $index; } # use Time::HiRes; # print "[".&Time::HiRes::time()."] STORED ".($last_index+1)." segments for length ". # length($total_rv)." bytes for value ".length($old_value)."\n"; $old_value; } sub DELETE { my($self, $key) = @_; my $segment_length = $MaxSegmentLength; my $total_rv; for(my $index = 0; $index < $MaxSegments; $index++) { my $index_key = _index_key($key, $index); my $rv = $self->SUPER::FETCH($index_key) || ''; $self->SUPER::DELETE($index_key); $total_rv ||= ''; $total_rv .= $rv; last if length($rv) < $segment_length; } $total_rv =~ s/^(..)//s; my $type = $1; if($type eq 'G}') { $total_rv = uncompress($total_rv); } elsif ($type eq 'N}') { # normal } else { # old SDBM_File $total_rv = $type.$total_rv; } $total_rv; } sub FIRSTKEY { my $self = shift; my $key = $self->SUPER::FIRSTKEY(); my @keys = (); if (defined $key) { do { if($key !~ /\*\*\d+$/s) { if(my $new_key = _decode_key($key)) { push(@keys, $new_key); } } } while($key = $self->SUPER::NEXTKEY($key)); } $KEYS{$self} = \@keys; $self->NEXTKEY; } sub NEXTKEY { my $self = shift; shift(@{$KEYS{$self}}); } sub _index_key { my($key, $index) = @_; $key =~ s/([\%\*])/uc sprintf("%%%02x",ord($1))/esg; $index ? $key.'**'.$index : $key; } sub _decode_key { my $key = shift; $key =~ s/%([0-9a-fA-F]{2})/pack("c",hex($1))/ge; $key; } 1; MLDBM-Sync-0.30/Makefile0100644000000000000000000004371007510526302013345 0ustar rootroot# This Makefile is for the MLDBM::Sync extension to perl. # # It was generated automatically by MakeMaker version # 5.45 (Revision: 1.222) from the contents of # Makefile.PL. Don't edit this file, edit Makefile.PL instead. # # ANY CHANGES MADE HERE WILL BE LOST! # # MakeMaker ARGV: () # # MakeMaker Parameters: # NAME => q[MLDBM::Sync] # PREREQ_PM => { MLDBM=>q[1] } # VERSION_FROM => q[Sync.pm] # --- MakeMaker post_initialize section: # --- MakeMaker const_config section: # These definitions are from config.sh (via /usr/local/lib/perl5/5.6.1/i686-linux/Config.pm) # They may have been overridden via Makefile.PL or on the command line AR = ar CC = cc CCCDLFLAGS = -fpic CCDLFLAGS = -rdynamic DLEXT = so DLSRC = dl_dlopen.xs LD = cc LDDLFLAGS = -shared -L/usr/local/lib LDFLAGS = -L/usr/local/lib LIBC = /lib/libc-2.2.4.so LIB_EXT = .a OBJ_EXT = .o OSNAME = linux OSVERS = 2.4.7-10smp RANLIB = : SO = so EXE_EXT = FULL_AR = /usr/bin/ar # --- MakeMaker constants section: AR_STATIC_ARGS = cr NAME = MLDBM::Sync DISTNAME = MLDBM-Sync NAME_SYM = MLDBM_Sync VERSION = 0.30 VERSION_SYM = 0_30 XS_VERSION = 0.30 INST_BIN = blib/bin INST_EXE = blib/script INST_LIB = blib/lib INST_ARCHLIB = blib/arch INST_SCRIPT = blib/script PREFIX = /usr/local INSTALLDIRS = site INSTALLPRIVLIB = $(PREFIX)/lib/perl5/5.6.1 INSTALLARCHLIB = $(PREFIX)/lib/perl5/5.6.1/i686-linux INSTALLSITELIB = $(PREFIX)/lib/perl5/site_perl/5.6.1 INSTALLSITEARCH = $(PREFIX)/lib/perl5/site_perl/5.6.1/i686-linux INSTALLBIN = $(PREFIX)/bin INSTALLSCRIPT = $(PREFIX)/bin PERL_LIB = /usr/local/lib/perl5/5.6.1 PERL_ARCHLIB = /usr/local/lib/perl5/5.6.1/i686-linux SITELIBEXP = /usr/local/lib/perl5/site_perl/5.6.1 SITEARCHEXP = /usr/local/lib/perl5/site_perl/5.6.1/i686-linux LIBPERL_A = libperl.a FIRST_MAKEFILE = Makefile MAKE_APERL_FILE = Makefile.aperl PERLMAINCC = $(CC) PERL_INC = /usr/local/lib/perl5/5.6.1/i686-linux/CORE PERL = /usr/local/bin/perl FULLPERL = /usr/local/bin/perl FULL_AR = /usr/bin/ar VERSION_MACRO = VERSION DEFINE_VERSION = -D$(VERSION_MACRO)=\"$(VERSION)\" XS_VERSION_MACRO = XS_VERSION XS_DEFINE_VERSION = -D$(XS_VERSION_MACRO)=\"$(XS_VERSION)\" PERL_MALLOC_DEF = -DPERL_EXTMALLOC_DEF -Dmalloc=Perl_malloc -Dfree=Perl_mfree -Drealloc=Perl_realloc -Dcalloc=Perl_calloc MAKEMAKER = /usr/local/lib/perl5/5.6.1/ExtUtils/MakeMaker.pm MM_VERSION = 5.45 # FULLEXT = Pathname for extension directory (eg Foo/Bar/Oracle). # BASEEXT = Basename part of FULLEXT. May be just equal FULLEXT. (eg Oracle) # ROOTEXT = Directory part of FULLEXT with leading slash (eg /DBD) !!! Deprecated from MM 5.32 !!! # PARENT_NAME = NAME without BASEEXT and no trailing :: (eg Foo::Bar) # DLBASE = Basename part of dynamic library. May be just equal BASEEXT. FULLEXT = MLDBM/Sync BASEEXT = Sync PARENT_NAME = MLDBM DLBASE = $(BASEEXT) VERSION_FROM = Sync.pm OBJECT = LDFROM = $(OBJECT) LINKTYPE = dynamic # Handy lists of source code files: XS_FILES= C_FILES = O_FILES = H_FILES = HTMLLIBPODS = HTMLSCRIPTPODS = MAN1PODS = MAN3PODS = Sync.pm HTMLEXT = html INST_MAN1DIR = blib/man1 INSTALLMAN1DIR = $(PREFIX)/man/man1 MAN1EXT = 1 INST_MAN3DIR = blib/man3 INSTALLMAN3DIR = $(PREFIX)/man/man3 MAN3EXT = 3 PERM_RW = 644 PERM_RWX = 755 # work around a famous dec-osf make(1) feature(?): makemakerdflt: all .SUFFIXES: .xs .c .C .cpp .cxx .cc $(OBJ_EXT) # Nick wanted to get rid of .PRECIOUS. I don't remember why. I seem to recall, that # some make implementations will delete the Makefile when we rebuild it. Because # we call false(1) when we rebuild it. So make(1) is not completely wrong when it # does so. Our milage may vary. # .PRECIOUS: Makefile # seems to be not necessary anymore .PHONY: all config static dynamic test linkext manifest # Where is the Config information that we are using/depend on CONFIGDEP = $(PERL_ARCHLIB)/Config.pm $(PERL_INC)/config.h # Where to put things: INST_LIBDIR = $(INST_LIB)/MLDBM INST_ARCHLIBDIR = $(INST_ARCHLIB)/MLDBM INST_AUTODIR = $(INST_LIB)/auto/$(FULLEXT) INST_ARCHAUTODIR = $(INST_ARCHLIB)/auto/$(FULLEXT) INST_STATIC = INST_DYNAMIC = INST_BOOT = EXPORT_LIST = PERL_ARCHIVE = PERL_ARCHIVE_AFTER = TO_INST_PM = Sync.pm \ lib/MLDBM/Sync/SDBM_File.pm PM_TO_BLIB = Sync.pm \ $(INST_LIBDIR)/Sync.pm \ lib/MLDBM/Sync/SDBM_File.pm \ $(INST_LIB)/MLDBM/Sync/SDBM_File.pm # --- MakeMaker tool_autosplit section: # Usage: $(AUTOSPLITFILE) FileToSplit AutoDirToSplitInto AUTOSPLITFILE = $(PERL) "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" -e 'use AutoSplit;autosplit($$ARGV[0], $$ARGV[1], 0, 1, 1) ;' # --- MakeMaker tool_xsubpp section: # --- MakeMaker tools_other section: SHELL = /bin/sh CHMOD = chmod CP = cp LD = cc MV = mv NOOP = $(SHELL) -c true RM_F = rm -f RM_RF = rm -rf TEST_F = test -f TOUCH = touch UMASK_NULL = umask 0 DEV_NULL = > /dev/null 2>&1 # The following is a portable way to say mkdir -p # To see which directories are created, change the if 0 to if 1 MKPATH = $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Command -e mkpath # This helps us to minimize the effect of the .exists files A yet # better solution would be to have a stable file in the perl # distribution with a timestamp of zero. But this solution doesn't # need any changes to the core distribution and works with older perls EQUALIZE_TIMESTAMP = $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Command -e eqtime # Here we warn users that an old packlist file was found somewhere, # and that they should call some uninstall routine WARN_IF_OLD_PACKLIST = $(PERL) -we 'exit unless -f $$ARGV[0];' \ -e 'print "WARNING: I have found an old package in\n";' \ -e 'print "\t$$ARGV[0].\n";' \ -e 'print "Please make sure the two installations are not conflicting\n";' UNINST=0 VERBINST=0 MOD_INSTALL = $(PERL) -I$(INST_LIB) -I$(PERL_LIB) -MExtUtils::Install \ -e "install({@ARGV},'$(VERBINST)',0,'$(UNINST)');" DOC_INSTALL = $(PERL) -e '$$\="\n\n";' \ -e 'print "=head2 ", scalar(localtime), ": C<", shift, ">", " L<", $$arg=shift, "|", $$arg, ">";' \ -e 'print "=over 4";' \ -e 'while (defined($$key = shift) and defined($$val = shift)){print "=item *";print "C<$$key: $$val>";}' \ -e 'print "=back";' UNINSTALL = $(PERL) -MExtUtils::Install \ -e 'uninstall($$ARGV[0],1,1); print "\nUninstall is deprecated. Please check the";' \ -e 'print " packlist above carefully.\n There may be errors. Remove the";' \ -e 'print " appropriate files manually.\n Sorry for the inconveniences.\n"' # --- MakeMaker dist section: DISTVNAME = $(DISTNAME)-$(VERSION) TAR = tar TARFLAGS = cvf ZIP = zip ZIPFLAGS = -r COMPRESS = gzip --best SUFFIX = .gz SHAR = shar PREOP = @$(NOOP) POSTOP = @$(NOOP) TO_UNIX = @$(NOOP) CI = ci -u RCS_LABEL = rcs -Nv$(VERSION_SYM): -q DIST_CP = best DIST_DEFAULT = tardist # --- MakeMaker macro section: # --- MakeMaker depend section: # --- MakeMaker cflags section: # --- MakeMaker const_loadlibs section: # --- MakeMaker const_cccmd section: # --- MakeMaker post_constants section: # --- MakeMaker pasthru section: PASTHRU = LIB="$(LIB)"\ LIBPERL_A="$(LIBPERL_A)"\ LINKTYPE="$(LINKTYPE)"\ PREFIX="$(PREFIX)"\ OPTIMIZE="$(OPTIMIZE)" # --- MakeMaker c_o section: # --- MakeMaker xs_c section: # --- MakeMaker xs_o section: # --- MakeMaker top_targets section: #all :: config $(INST_PM) subdirs linkext manifypods all :: pure_all htmlifypods manifypods @$(NOOP) pure_all :: config pm_to_blib subdirs linkext @$(NOOP) subdirs :: $(MYEXTLIB) @$(NOOP) config :: Makefile $(INST_LIBDIR)/.exists @$(NOOP) config :: $(INST_ARCHAUTODIR)/.exists @$(NOOP) config :: $(INST_AUTODIR)/.exists @$(NOOP) $(INST_AUTODIR)/.exists :: /usr/local/lib/perl5/5.6.1/i686-linux/CORE/perl.h @$(MKPATH) $(INST_AUTODIR) @$(EQUALIZE_TIMESTAMP) /usr/local/lib/perl5/5.6.1/i686-linux/CORE/perl.h $(INST_AUTODIR)/.exists -@$(CHMOD) $(PERM_RWX) $(INST_AUTODIR) $(INST_LIBDIR)/.exists :: /usr/local/lib/perl5/5.6.1/i686-linux/CORE/perl.h @$(MKPATH) $(INST_LIBDIR) @$(EQUALIZE_TIMESTAMP) /usr/local/lib/perl5/5.6.1/i686-linux/CORE/perl.h $(INST_LIBDIR)/.exists -@$(CHMOD) $(PERM_RWX) $(INST_LIBDIR) $(INST_ARCHAUTODIR)/.exists :: /usr/local/lib/perl5/5.6.1/i686-linux/CORE/perl.h @$(MKPATH) $(INST_ARCHAUTODIR) @$(EQUALIZE_TIMESTAMP) /usr/local/lib/perl5/5.6.1/i686-linux/CORE/perl.h $(INST_ARCHAUTODIR)/.exists -@$(CHMOD) $(PERM_RWX) $(INST_ARCHAUTODIR) config :: $(INST_MAN3DIR)/.exists @$(NOOP) $(INST_MAN3DIR)/.exists :: /usr/local/lib/perl5/5.6.1/i686-linux/CORE/perl.h @$(MKPATH) $(INST_MAN3DIR) @$(EQUALIZE_TIMESTAMP) /usr/local/lib/perl5/5.6.1/i686-linux/CORE/perl.h $(INST_MAN3DIR)/.exists -@$(CHMOD) $(PERM_RWX) $(INST_MAN3DIR) help: perldoc ExtUtils::MakeMaker Version_check: @$(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) \ -MExtUtils::MakeMaker=Version_check \ -e "Version_check('$(MM_VERSION)')" # --- MakeMaker linkext section: linkext :: $(LINKTYPE) @$(NOOP) # --- MakeMaker dlsyms section: # --- MakeMaker dynamic section: ## $(INST_PM) has been moved to the all: target. ## It remains here for awhile to allow for old usage: "make dynamic" #dynamic :: Makefile $(INST_DYNAMIC) $(INST_BOOT) $(INST_PM) dynamic :: Makefile $(INST_DYNAMIC) $(INST_BOOT) @$(NOOP) # --- MakeMaker dynamic_bs section: BOOTSTRAP = # --- MakeMaker dynamic_lib section: # --- MakeMaker static section: ## $(INST_PM) has been moved to the all: target. ## It remains here for awhile to allow for old usage: "make static" #static :: Makefile $(INST_STATIC) $(INST_PM) static :: Makefile $(INST_STATIC) @$(NOOP) # --- MakeMaker static_lib section: # --- MakeMaker htmlifypods section: htmlifypods : pure_all @$(NOOP) # --- MakeMaker manifypods section: POD2MAN_EXE = /usr/local/bin/pod2man POD2MAN = $(PERL) -we '%m=@ARGV;for (keys %m){' \ -e 'next if -e $$m{$$_} && -M $$m{$$_} < -M $$_ && -M $$m{$$_} < -M "Makefile";' \ -e 'print "Manifying $$m{$$_}\n";' \ -e 'system(qq[$$^X ].q["-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" $(POD2MAN_EXE) ].qq[$$_>$$m{$$_}])==0 or warn "Couldn\047t install $$m{$$_}\n";' \ -e 'chmod(oct($(PERM_RW))), $$m{$$_} or warn "chmod $(PERM_RW) $$m{$$_}: $$!\n";}' manifypods : pure_all Sync.pm @$(POD2MAN) \ Sync.pm \ $(INST_MAN3DIR)/MLDBM::Sync.$(MAN3EXT) # --- MakeMaker processPL section: # --- MakeMaker installbin section: # --- MakeMaker subdirs section: # none # --- MakeMaker clean section: # Delete temporary files but do not touch installed files. We don't delete # the Makefile here so a later make realclean still has a makefile to use. clean :: -rm -rf ./blib $(MAKE_APERL_FILE) $(INST_ARCHAUTODIR)/extralibs.all perlmain.c mon.out core core.*perl.*.? *perl.core so_locations pm_to_blib *$(OBJ_EXT) *$(LIB_EXT) perl.exe $(BOOTSTRAP) $(BASEEXT).bso $(BASEEXT).def $(BASEEXT).exp -mv Makefile Makefile.old $(DEV_NULL) # --- MakeMaker realclean section: # Delete temporary files (via clean) and also delete installed files realclean purge :: clean rm -rf $(INST_AUTODIR) $(INST_ARCHAUTODIR) rm -f $(INST_LIBDIR)/Sync.pm $(INST_LIB)/MLDBM/Sync/SDBM_File.pm rm -rf Makefile Makefile.old # --- MakeMaker dist_basics section: distclean :: realclean distcheck distcheck : $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Manifest=fullcheck \ -e fullcheck skipcheck : $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Manifest=skipcheck \ -e skipcheck manifest : $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Manifest=mkmanifest \ -e mkmanifest veryclean : realclean $(RM_F) *~ *.orig */*~ */*.orig # --- MakeMaker dist_core section: dist : $(DIST_DEFAULT) @$(PERL) -le 'print "Warning: Makefile possibly out of date with $$vf" if ' \ -e '-e ($$vf="$(VERSION_FROM)") and -M $$vf < -M "Makefile";' tardist : $(DISTVNAME).tar$(SUFFIX) zipdist : $(DISTVNAME).zip $(DISTVNAME).tar$(SUFFIX) : distdir $(PREOP) $(TO_UNIX) $(TAR) $(TARFLAGS) $(DISTVNAME).tar $(DISTVNAME) $(RM_RF) $(DISTVNAME) $(COMPRESS) $(DISTVNAME).tar $(POSTOP) $(DISTVNAME).zip : distdir $(PREOP) $(ZIP) $(ZIPFLAGS) $(DISTVNAME).zip $(DISTVNAME) $(RM_RF) $(DISTVNAME) $(POSTOP) uutardist : $(DISTVNAME).tar$(SUFFIX) uuencode $(DISTVNAME).tar$(SUFFIX) \ $(DISTVNAME).tar$(SUFFIX) > \ $(DISTVNAME).tar$(SUFFIX)_uu shdist : distdir $(PREOP) $(SHAR) $(DISTVNAME) > $(DISTVNAME).shar $(RM_RF) $(DISTVNAME) $(POSTOP) # --- MakeMaker dist_dir section: distdir : $(RM_RF) $(DISTVNAME) $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Manifest=manicopy,maniread \ -e "manicopy(maniread(),'$(DISTVNAME)', '$(DIST_CP)');" # --- MakeMaker dist_test section: disttest : distdir cd $(DISTVNAME) && $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) Makefile.PL cd $(DISTVNAME) && $(MAKE) cd $(DISTVNAME) && $(MAKE) test # --- MakeMaker dist_ci section: ci : $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Manifest=maniread \ -e "@all = keys %{ maniread() };" \ -e 'print("Executing $(CI) @all\n"); system("$(CI) @all");' \ -e 'print("Executing $(RCS_LABEL) ...\n"); system("$(RCS_LABEL) @all");' # --- MakeMaker install section: install :: all pure_install doc_install install_perl :: all pure_perl_install doc_perl_install install_site :: all pure_site_install doc_site_install install_ :: install_site @echo INSTALLDIRS not defined, defaulting to INSTALLDIRS=site pure_install :: pure_$(INSTALLDIRS)_install doc_install :: doc_$(INSTALLDIRS)_install @echo Appending installation info to $(INSTALLARCHLIB)/perllocal.pod pure__install : pure_site_install @echo INSTALLDIRS not defined, defaulting to INSTALLDIRS=site doc__install : doc_site_install @echo INSTALLDIRS not defined, defaulting to INSTALLDIRS=site pure_perl_install :: @$(MOD_INSTALL) \ read $(PERL_ARCHLIB)/auto/$(FULLEXT)/.packlist \ write $(INSTALLARCHLIB)/auto/$(FULLEXT)/.packlist \ $(INST_LIB) $(INSTALLPRIVLIB) \ $(INST_ARCHLIB) $(INSTALLARCHLIB) \ $(INST_BIN) $(INSTALLBIN) \ $(INST_SCRIPT) $(INSTALLSCRIPT) \ $(INST_HTMLLIBDIR) $(INSTALLHTMLPRIVLIBDIR) \ $(INST_HTMLSCRIPTDIR) $(INSTALLHTMLSCRIPTDIR) \ $(INST_MAN1DIR) $(INSTALLMAN1DIR) \ $(INST_MAN3DIR) $(INSTALLMAN3DIR) @$(WARN_IF_OLD_PACKLIST) \ $(SITEARCHEXP)/auto/$(FULLEXT) pure_site_install :: @$(MOD_INSTALL) \ read $(SITEARCHEXP)/auto/$(FULLEXT)/.packlist \ write $(INSTALLSITEARCH)/auto/$(FULLEXT)/.packlist \ $(INST_LIB) $(INSTALLSITELIB) \ $(INST_ARCHLIB) $(INSTALLSITEARCH) \ $(INST_BIN) $(INSTALLBIN) \ $(INST_SCRIPT) $(INSTALLSCRIPT) \ $(INST_HTMLLIBDIR) $(INSTALLHTMLSITELIBDIR) \ $(INST_HTMLSCRIPTDIR) $(INSTALLHTMLSCRIPTDIR) \ $(INST_MAN1DIR) $(INSTALLMAN1DIR) \ $(INST_MAN3DIR) $(INSTALLMAN3DIR) @$(WARN_IF_OLD_PACKLIST) \ $(PERL_ARCHLIB)/auto/$(FULLEXT) doc_perl_install :: -@$(MKPATH) $(INSTALLARCHLIB) -@$(DOC_INSTALL) \ "Module" "$(NAME)" \ "installed into" "$(INSTALLPRIVLIB)" \ LINKTYPE "$(LINKTYPE)" \ VERSION "$(VERSION)" \ EXE_FILES "$(EXE_FILES)" \ >> $(INSTALLARCHLIB)/perllocal.pod doc_site_install :: -@$(MKPATH) $(INSTALLARCHLIB) -@$(DOC_INSTALL) \ "Module" "$(NAME)" \ "installed into" "$(INSTALLSITELIB)" \ LINKTYPE "$(LINKTYPE)" \ VERSION "$(VERSION)" \ EXE_FILES "$(EXE_FILES)" \ >> $(INSTALLARCHLIB)/perllocal.pod uninstall :: uninstall_from_$(INSTALLDIRS)dirs uninstall_from_perldirs :: @$(UNINSTALL) $(PERL_ARCHLIB)/auto/$(FULLEXT)/.packlist uninstall_from_sitedirs :: @$(UNINSTALL) $(SITEARCHEXP)/auto/$(FULLEXT)/.packlist # --- MakeMaker force section: # Phony target to force checking subdirectories. FORCE: @$(NOOP) # --- MakeMaker perldepend section: # --- MakeMaker makefile section: # We take a very conservative approach here, but it\'s worth it. # We move Makefile to Makefile.old here to avoid gnu make looping. Makefile : Makefile.PL $(CONFIGDEP) @echo "Makefile out-of-date with respect to $?" @echo "Cleaning current config before rebuilding Makefile..." -@$(RM_F) Makefile.old -@$(MV) Makefile Makefile.old -$(MAKE) -f Makefile.old clean $(DEV_NULL) || $(NOOP) $(PERL) "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" Makefile.PL @echo "==> Your Makefile has been rebuilt. <==" @echo "==> Please rerun the make command. <==" false # To change behavior to :: would be nice, but would break Tk b9.02 # so you find such a warning below the dist target. #Makefile :: $(VERSION_FROM) # @echo "Warning: Makefile possibly out of date with $(VERSION_FROM)" # --- MakeMaker staticmake section: # --- MakeMaker makeaperl section --- MAP_TARGET = perl FULLPERL = /usr/local/bin/perl $(MAP_TARGET) :: static $(MAKE_APERL_FILE) $(MAKE) -f $(MAKE_APERL_FILE) $@ $(MAKE_APERL_FILE) : $(FIRST_MAKEFILE) @echo Writing \"$(MAKE_APERL_FILE)\" for this $(MAP_TARGET) @$(PERL) -I$(INST_ARCHLIB) -I$(INST_LIB) -I$(PERL_ARCHLIB) -I$(PERL_LIB) \ Makefile.PL DIR= \ MAKEFILE=$(MAKE_APERL_FILE) LINKTYPE=static \ MAKEAPERL=1 NORECURS=1 CCCDLFLAGS= # --- MakeMaker test section: TEST_VERBOSE=0 TEST_TYPE=test_$(LINKTYPE) TEST_FILE = test.pl TEST_FILES = t/*.t TESTDB_SW = -d testdb :: testdb_$(LINKTYPE) test :: $(TEST_TYPE) test_dynamic :: pure_all PERL_DL_NONLAZY=1 $(FULLPERL) -I$(INST_ARCHLIB) -I$(INST_LIB) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -e 'use Test::Harness qw(&runtests $$verbose); $$verbose=$(TEST_VERBOSE); runtests @ARGV;' $(TEST_FILES) testdb_dynamic :: pure_all PERL_DL_NONLAZY=1 $(FULLPERL) $(TESTDB_SW) -I$(INST_ARCHLIB) -I$(INST_LIB) -I$(PERL_ARCHLIB) -I$(PERL_LIB) $(TEST_FILE) test_ : test_dynamic test_static :: test_dynamic testdb_static :: testdb_dynamic # --- MakeMaker ppd section: # Creates a PPD (Perl Package Description) for a binary distribution. ppd: @$(PERL) -e "print qq{\n}. qq{\tMLDBM-Sync\n}. qq{\t\n}. qq{\t\n}. qq{\t\n}. qq{\t\t\n}. qq{\t\t\n}. qq{\t\t\n}. qq{\t\t\n}. qq{\t\n}. qq{\n}" > MLDBM-Sync.ppd # --- MakeMaker pm_to_blib section: pm_to_blib: $(TO_INST_PM) @$(PERL) "-I$(INST_ARCHLIB)" "-I$(INST_LIB)" \ "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" -MExtUtils::Install \ -e "pm_to_blib({qw{$(PM_TO_BLIB)}},'$(INST_LIB)/auto','$(PM_FILTER)')" @$(TOUCH) $@ # --- MakeMaker selfdocument section: # --- MakeMaker postamble section: # End. MLDBM-Sync-0.30/bench/0040755000000000000000000000000007510526312012763 5ustar rootrootMLDBM-Sync-0.30/bench/bench_sync.pl0100755000076400007640000000537407505516765015103 0ustar jobjob#!/usr/bin/perl -w use lib qw(.. . lib ../lib); eval "use Sync"; print $@; use Fcntl; use Time::HiRes qw(time); use Carp qw(confess); use strict; use Getopt::Long; my $INSERTS = 25; my $PIDS = 4; my $BASE = $INSERTS * $PIDS; my $parent = $$; $SIG{__DIE__} = \&confess; srand(0); $MLDBM::UseDB = $MLDBM::UseDB; # supress warning use vars qw($opt_cache $opt_number $opt_bundle); &GetOptions('c' => \$opt_cache, 'n=i' => \$opt_number, 'bundle=i' => \$opt_bundle); if(! $opt_number or $opt_number < $BASE) { $opt_number = $BASE; } $opt_number = int( $opt_number / $BASE ) * $BASE; if($^O =~ /win32/i) { $PIDS = 1; } if($opt_number) { $opt_number /= $PIDS; } else { $opt_number = $INSERTS; } print "NUMBER OF PROCESSES IN TEST: $PIDS\n"; for my $SIZE (50, 500, 5000, 20000, 50000) { print "\n=== INSERT OF $SIZE BYTE RECORDS ===\n"; for my $DB ('SDBM_File', 'MLDBM::Sync::SDBM_File', 'GDBM_File', 'DB_File', 'Tie::TextDir .04') { eval "use $DB"; next if $@; if($DB eq 'SDBM_File' and $SIZE > 100) { print " (skipping test for SDBM_File 100 byte limit)\n"; next; }; if($DB eq 'MLDBM::Sync::SDBM_File' and ($SIZE * $opt_number * $PIDS) > (1 * 1024 * 1024)) { print " (skipping test for MLDBM::Sync db size > 1M)\n"; next; } my $real_db = $DB; $real_db =~ s/\s+\.\d+$//isg; local $MLDBM::UseDB = $real_db; my $file_suffix = $real_db; $file_suffix =~ s/\W/_/isg; my %mldbm; my $sync = tie(%mldbm, 'MLDBM::Sync', "MLDBM_SYNC_BENCH_".$file_suffix, O_CREAT|O_RDWR, 0666) || die("can't tie to /tmp/bench_mldbm: $!"); if($opt_cache) { $sync->SyncCacheSize('1000K'); } %mldbm = (); my $time = time; if($PIDS > 1) { # 4 processes in all fork; fork; } my $bundle = 0; for(0..($opt_number-1)) { my $rand; for(1..($SIZE/10)) { $rand .= ''.rand().rand(); last if length($rand) > $SIZE; } $rand = substr($rand, 0, $SIZE); my $key = "$$.$_"; # add lock & unlock to increase performance # $sync->Lock; if($opt_bundle && ( ! ($_ % $opt_bundle ))) { # print "LOCK $$ $_\n"; $bundle++; $sync->UnLock; $sync->Lock; } $mldbm{$key} = $rand; ($mldbm{$key} eq $rand) || warn("can't fetch written value for $key => $mldbm{$key} === $rand"); # $sync->UnLock; } $opt_bundle && $sync->UnLock; if($^O !~ /win32/i) { while(wait != -1) {} } if($$ == $parent) { my $total_time = time() - $time; my $num_keys = scalar(keys %mldbm); ($num_keys % $INSERTS) && warn("error, $num_keys should be a multiple of $INSERTS"); my $bundles_print = $bundle ? "locks/pid=$bundle" : ''; printf " Time for $num_keys writes + $num_keys reads for %-24s %6.2f seconds %8d bytes $bundles_print\n", $DB, $total_time, $sync->SyncSize; } else { exit; } %mldbm = (); } } MLDBM-Sync-0.30/MANIFEST.bak0100644000000000000000000000033507505517577013610 0ustar rootrootCHANGES MANIFEST MANIFEST.SKIP MANIFEST.bak Makefile Makefile.PL README Sync.pm bench/bench_sync.pl lib/MLDBM/Sync/SDBM_File.pm t/T.pm t/cache.t t/general.t t/key_checksum.t t/locks.t t/sdbm_big_rec.t t/taint.t t/zdone.t MLDBM-Sync-0.30/MANIFEST.SKIP0100644000000000000000000000010507510526135013576 0ustar rootroottest_dbm MLDBM_SYNC MLDBM-Sync-\d Makefile\.old$ \~$ blib pm_to_blib MLDBM-Sync-0.30/Sync.pm0100755000076400007640000004363307510526242012611 0ustar jobjob package MLDBM::Sync; $VERSION = '0.30'; use MLDBM; use MLDBM::Sync::SDBM_File; use Data::Dumper; use Fcntl qw(:flock); use Digest::MD5 qw(md5_hex); use strict; use Carp qw(confess); no strict qw(refs); use vars qw($AUTOLOAD @EXT $CACHE_ERR $LOCK_SH $LOCK_EX $LOCK_UN); eval "use Tie::Cache;"; if (($@)) { $CACHE_ERR = $@; } $LOCK_SH = LOCK_SH; $LOCK_UN = LOCK_UN; $LOCK_EX = LOCK_EX; @EXT = ('.pag', '.dir', ''); sub TIEHASH { my($class, $file, @args) = @_; $file =~ /^(.*)$/s; $file = $1; my $fh = $file.".lock"; my $self = bless { 'file' => $file, 'args' => [ $file, @args ], 'lock_fh' => $fh, 'lock_file' => $fh, 'lock_num' => 0, 'md5_keys' => 0, 'pid' => $$, 'keys' => [], 'db_type' => $MLDBM::UseDB, 'serializer' => $MLDBM::Serializer, 'remove_taint' => $MLDBM::RemoveTaint, }; $self; } sub DESTROY { my $self = shift; if($self->{lock_num}) { $self->{lock_num} = 1; $self->UnLock; } } sub AUTOLOAD { my($self, $key, $value) = @_; $AUTOLOAD =~ /::([^:]+)$/; my $func = $1; grep($func eq $_, ('FETCH', 'STORE', 'EXISTS', 'DELETE')) || die("$func not handled by object $self"); ## CHECKSUM KEYS if(defined $key && $self->{md5_keys}) { $key = $self->SyncChecksum($key); } # CACHE, short circuit if found in cache on FETCH/EXISTS # after checksum, since that's what we store my $cache = (defined $key) ? $self->{cache} : undef; if($cache && ($func eq 'FETCH' or $func eq 'EXISTS')) { my $rv = $cache->$func($key); defined($rv) && return($rv); } my $rv; if ($func eq 'FETCH' or $func eq 'EXISTS') { $self->read_lock; } else { $self->lock; } { local $MLDBM::RemoveTaint = $self->{remove_taint}; if (defined $value) { $rv = $self->{dbm}->$func($key, $value); } else { $rv = $self->{dbm}->$func($key); } } $self->unlock; # do after lock critical section, no point taking # any extra time there $cache && $cache->$func($key, $value); $rv; } sub CLEAR { my $self = shift; $self->lock; $self->{dbm}->CLEAR; $self->{dbm} = undef; # delete the files to free disk space my $unlinked = 0; for (@EXT) { my $file = $self->{file}.$_; next if(! -e $file); if(-d $file) { rmdir($file) || warn("can't unlink dir $file: $!"); } else { unlink($file) || die("can't unlink file $file: $!"); } $unlinked++; } if($self->{lock_num} > 1) { $self->SyncTie; # recreate, not done with it yet } $self->unlock; if($self->{lock_num} == 0) { # only unlink if we are clear of all the locks unlink($self->{lock_file}); } $self->{cache} && $self->{cache}->CLEAR; 1; }; # don't bother with cache for first/next key since it'll kill # the cache anyway likely sub FIRSTKEY { my $self = shift; if($self->{md5_keys}) { confess("can't get keys() or each() on MLDBM::Sync database ". "with SyncKeysChecksum(1) set"); } $self->read_lock; my $key = $self->{dbm}->FIRSTKEY(); my @keys; while(1) { last if ! defined($key); push(@keys, $key); $key = $self->{dbm}->NEXTKEY($key); } $self->unlock; $self->{'keys'} = \@keys; $self->NEXTKEY; } sub NEXTKEY { my $self = shift; if($self->{md5_keys}) { confess("can't get keys() or each() on MLDBM::Sync database ". "with SyncKeysChecksum(1) set"); } my $rv = shift(@{$self->{'keys'}}); } sub SyncChecksum { my($self, $key) = @_; if(ref $key) { join('g', md5_hex($$key), sprintf("%07d",length($$key))); } else { join('g', md5_hex($key), sprintf("%07d", length($key))); } } sub SyncCacheSize { my($self, $size) = @_; $CACHE_ERR && die("need Tie::Cache installed to use this feature: $@"); if ($size =~ /^(\d+)(M|K)$/) { my($num, $type) = ($1, $2); if (($type eq 'M')) { $size = $num * 1024 * 1024; } elsif (($type eq 'K')) { $size = $num * 1024; } else { die "$type symbol not understood for $size"; } } else { ($size =~ /^\d+$/) or die("$size must be bytes size for cache"); } if ($self->{cache}) { $self->{cache}->CLEAR(); # purge old cache, to free up RAM maybe for mem leaks } my %cache; my $cache = tie %cache, 'Tie::Cache', { MaxBytes => $size }; $self->{cache} = $cache; # use non tied interface, faster } sub SyncTie { my $self = shift; my %temp_hash; my $args = $self->{args}; local $MLDBM::UseDB = $self->{db_type}; local $MLDBM::Serializer = $self->{serializer}; local $MLDBM::RemoveTaint = $self->{remove_taint}; $self->{dbm} = tie(%temp_hash, 'MLDBM', @$args) || die("can't tie to MLDBM with args: ".join(',', @$args)."; error: $!"); $self->{dbm}; } #### DOCUMENTED API ################################################################ sub SyncKeysChecksum { my($self, $setting) = @_; if(defined $setting) { $self->{md5_keys} = $setting; } else { $self->{md5_keys}; } } *read_lock = *ReadLock; sub ReadLock { shift->Lock(1); } *lock = *SyncLock = *Lock; sub Lock { my($self, $read_lock) = @_; if($self->{lock_num}++ == 0) { my $file = $self->{lock_file}; open($self->{lock_fh}, "+>$file") || die("can't open file $file: $!"); flock($self->{lock_fh}, ($read_lock ? $LOCK_SH : $LOCK_EX)) || die("can't ". ($read_lock ? "read" : "write") ." lock $file: $!"); $self->{read_lock} = $read_lock; $self->SyncTie; } else { if ($self->{read_lock} and ! $read_lock) { $self->{lock_num}--; # roll back lock count # confess here to help developer track this down confess("Can't upgrade lock type from LOCK_SH to LOCK_EX! ". "This could happen if you tried to write to the MLDBM ". "in a critical section locked by ReadLock(). ". "Also the read expression my \$v = \$db{'key1'}{'key2'} will trigger a write ". "if \$db{'key1'} does not already exist, so this will error in a ReadLock() section" ); } 1; } } *unlock = *SyncUnLock = *UnLock; sub UnLock { my $self = shift; if($self->{lock_num} && $self->{lock_num}-- == 1) { $self->{lock_num} = 0; undef $self->{dbm}; flock($self->{'lock_fh'}, $LOCK_UN) || die("can't unlock $self->{'lock_file'}: $!"); close($self->{'lock_fh'}) || die("can't close $self->{'lock_file'}"); $self->{read_lock} = undef; 1; } else { 1; } } sub SyncSize { my $self = shift; my $size = 0; for (@EXT) { my $file = $self->{file}.$_; next unless -e $file; $size += (stat($file))[7]; if(-d $file) { $size += (stat($file))[7]; opendir(DIR, $file) || next; my @files = readdir(DIR); for my $dir_file (@files) { next if $dir_file =~ /^\.\.?$/; $size += (stat("$file/$dir_file"))[7]; } closedir(DIR); } } $size; } 1; __END__ =head1 NAME MLDBM::Sync - safe concurrent access to MLDBM databases =head1 SYNOPSIS use MLDBM::Sync; # this gets the default, SDBM_File use MLDBM qw(DB_File Storable); # use Storable for serializing use MLDBM qw(MLDBM::Sync::SDBM_File); # use extended SDBM_File, handles values > 1024 bytes use Fcntl qw(:DEFAULT); # import symbols O_CREAT & O_RDWR for use with DBMs # NORMAL PROTECTED read/write with implicit locks per i/o request my $sync_dbm_obj = tie %cache, 'MLDBM::Sync' [..other DBM args..] or die $!; $cache{"AAAA"} = "BBBB"; my $value = $cache{"AAAA"}; # SERIALIZED PROTECTED read/write with explicit lock for both i/o requests my $sync_dbm_obj = tie %cache, 'MLDBM::Sync', '/tmp/syncdbm', O_CREAT|O_RDWR, 0640; $sync_dbm_obj->Lock; $cache{"AAAA"} = "BBBB"; my $value = $cache{"AAAA"}; $sync_dbm_obj->UnLock; # SERIALIZED PROTECTED READ access with explicit read lock for both reads $sync_dbm_obj->ReadLock; my @keys = keys %cache; my $value = $cache{'AAAA'}; $sync_dbm_obj->UnLock; # MEMORY CACHE LAYER with Tie::Cache $sync_dbm_obj->SyncCacheSize('100K'); # KEY CHECKSUMS, for lookups on MD5 checksums on large keys my $sync_dbm_obj = tie %cache, 'MLDBM::Sync', '/tmp/syncdbm', O_CREAT|O_RDWR, 0640; $sync_dbm_obj->SyncKeysChecksum(1); my $large_key = "KEY" x 10000; $sync{$large_key} = "LARGE"; my $value = $sync{$large_key}; =head1 DESCRIPTION This module wraps around the MLDBM interface, by handling concurrent access to MLDBM databases with file locking, and flushes i/o explicity per lock/unlock. The new [Read]Lock()/UnLock() API can be used to serialize requests logically and improve performance for bundled reads & writes. my $sync_dbm_obj = tie %cache, 'MLDBM::Sync', '/tmp/syncdbm', O_CREAT|O_RDWR, 0640; # Write locked critical section $sync_dbm_obj->Lock; ... all accesses to DBM LOCK_EX protected, and go to same tied file handles $cache{'KEY'} = 'VALUE'; $sync_dbm_obj->UnLock; # Read locked critical section $sync_dbm_obj->ReadLock; ... all read accesses to DBM LOCK_SH protected, and go to same tied files ... WARNING, cannot write to DBM in ReadLock() section, will die() ... WARNING, my $v = $cache{'KEY'}{'SUBKEY'} will trigger a write so not safe ... to use in ReadLock() section my $value = $cache{'KEY'}; $sync_dbm_obj->UnLock; # Normal access OK too, without explicity locking $cache{'KEY'} = 'VALUE'; my $value = $cache{'KEY'}; MLDBM continues to serve as the underlying OO layer that serializes complex data structures to be stored in the databases. See the MLDBM L section for important limitations. MLDBM::Sync also provides built in RAM caching with Tie::Cache md5 key checksum functionality. =head1 INSTALL Like any other CPAN module, either use CPAN.pm, or perl -MCPAN C<-e> shell, or get the file MLDBM-Sync-x.xx.tar.gz, unzip, untar and: perl Makefile.PL make make test make install =head1 LOCKING The MLDBM::Sync wrapper protects MLDBM databases by locking and unlocking around read and write requests to the databases. Also necessary is for each new lock to tie() to the database internally, untie()ing when unlocking. This flushes any i/o for the dbm to the operating system, and allows for concurrent read/write access to the databases. Without any extra effort from the developer, an existing MLDBM database will benefit from MLDBM::sync. my $dbm_obj = tie %dbm, ...; $dbm{"key"} = "value"; As a write or STORE operation, the above will automatically cause the following: $dbm_obj->Lock; # also ties $dbm{"key"} = "value"; $dbm_obj->UnLock; # also unties Just so, a read or FETCH operation like: my $value = $dbm{"key"}; will really trigger: $dbm_obj->ReadLock; # also ties my $value = $dbm{"key"}; $dbm_obj->Lock; # also unties However, these lock operations are expensive because of the underlying tie()/untie() that occurs for i/o flushing, so when bundling reads & writes, a developer may explicitly use this API for greater performance: # tie once to database, write 100 times $dbm_obj->Lock; for (1..100) { $dbm{$_} = $_ * 100; ... } $dbm_obj->UnLock; # only tie once to database, and read 100 times $dbm_obj->ReadLock; for(1..100) { my $value = $dbm{$_}; ... } $dbm_obj->UnLock; =head1 CACHING I built MLDBM::Sync to serve as a fast and robust caching layer for use in multi-process environments like mod_perl. In order to provide an additional speed boost when caching static data, I have added an RAM caching layer with Tie::Cache, which regulates the size of the memory used with its MaxBytes setting. To activate this caching, just: my $dbm = tie %cache, 'MLDBM::Sync', '/tmp/syncdbm', O_CREAT|O_RDWR, 0640; $dbm->SyncCacheSize(100000); # 100000 bytes max memory used $dbm->SyncCacheSize('100K'); # 100 Kbytes max memory used $dbm->SyncCacheSize('1M'); # 1 Megabyte max memory used The ./bench/bench_sync.pl, run like "bench_sync.pl C<-c>" will run the tests with caching turned on creating a benchmark with 50% cache hits. One run without caching was: === INSERT OF 50 BYTE RECORDS === Time for 100 writes + 100 reads for SDBM_File 0.16 seconds 12288 bytes Time for 100 writes + 100 reads for MLDBM::Sync::SDBM_File 0.17 seconds 12288 bytes Time for 100 writes + 100 reads for GDBM_File 3.37 seconds 17980 bytes Time for 100 writes + 100 reads for DB_File 4.45 seconds 20480 bytes And with caching, with 50% cache hits: === INSERT OF 50 BYTE RECORDS === Time for 100 writes + 100 reads for SDBM_File 0.11 seconds 12288 bytes Time for 100 writes + 100 reads for MLDBM::Sync::SDBM_File 0.11 seconds 12288 bytes Time for 100 writes + 100 reads for GDBM_File 2.49 seconds 17980 bytes Time for 100 writes + 100 reads for DB_File 2.55 seconds 20480 bytes Even for SDBM_File, this speedup is near 33%. =head1 KEYS CHECKSUM A common operation on database lookups is checksumming the key, prior to the lookup, because the key could be very large, and all one really wants is the data it maps too. To enable this functionality automatically with MLDBM::Sync, just: my $sync_dbm_obj = tie %cache, 'MLDBM::Sync', '/tmp/syncdbm', O_CREAT|O_RDWR, 0640; $sync_dbm_obj->SyncKeysChecksum(1); !! WARNING: keys() & each() do not work on these databases !! as of v.03, so the developer will not be fooled into thinking !! the stored key values are meaningful to the calling application !! and will die() if called. !! !! This behavior could be relaxed in the future. An example of this might be to cache a XSLT conversion, which are typically very expensive. You have the XML data and the XSLT data, so all you do is: # $xml_data, $xsl_data are strings my $xslt_output; unless ($xslt_output = $cache{$xml_data.'&&&&'.$xsl_data}) { ... do XSLT conversion here for $xslt_output ... $cache{$xml_data.'&&&&'.xsl_data} = $xslt_output; } What you save by doing this is having to create HUGE keys to lookup on, which no DBM is likely to do efficiently. This is the same method that File::Cache uses internally to hash its file lookups in its directories. =head1 New MLDBM::Sync::SDBM_File SDBM_File, the default used for MLDBM and therefore MLDBM::Sync has a limit of 1024 bytes for the size of a record. SDBM_File is also an order of magnitude faster for small records to use with MLDBM::Sync, than DB_File or GDBM_File, because the tie()/untie() to the dbm is much faster. Therefore, bundled with MLDBM::Sync release is a MLDBM::Sync::SDBM_File layer which works around this 1024 byte limit. To use, just: use MLDBM qw(MLDBM::Sync::SDBM_File); It works by breaking up up the STORE() values into small 128 byte segments, and spreading those segments across many records, creating a virtual record layer. It also uses Compress::Zlib to compress STORED data, reducing the number of these 128 byte records. In benchmarks, 128 byte record segments seemed to be a sweet spot for space/time efficiency, as SDBM_File created very bloated *.pag files for 128+ byte records. =head1 BENCHMARKS In the distribution ./bench directory is a bench_sync.pl script that can benchmark using the various DBMs with MLDBM::Sync. The MLDBM::Sync::SDBM_File DBM is special because is uses SDBM_File for fast small inserts, but slows down linearly with the size of the data being inserted and read. The results for a dual PIII-450 linux 2.4.7, with a ext3 file system blocksize 4096 mounted async on a RAID-1 2xIDE 7200 RPM disk were as follows: === INSERT OF 50 BYTE RECORDS === Time for 100 writes + 100 reads for SDBM_File 0.16 seconds 12288 bytes Time for 100 writes + 100 reads for MLDBM::Sync::SDBM_File 0.19 seconds 12288 bytes Time for 100 writes + 100 reads for GDBM_File 1.09 seconds 18066 bytes Time for 100 writes + 100 reads for DB_File 0.67 seconds 12288 bytes Time for 100 writes + 100 reads for Tie::TextDir .04 0.31 seconds 13192 bytes === INSERT OF 500 BYTE RECORDS === (skipping test for SDBM_File 100 byte limit) Time for 100 writes + 100 reads for MLDBM::Sync::SDBM_File 0.52 seconds 110592 bytes Time for 100 writes + 100 reads for GDBM_File 1.20 seconds 63472 bytes Time for 100 writes + 100 reads for DB_File 0.66 seconds 86016 bytes Time for 100 writes + 100 reads for Tie::TextDir .04 0.32 seconds 58192 bytes === INSERT OF 5000 BYTE RECORDS === (skipping test for SDBM_File 100 byte limit) Time for 100 writes + 100 reads for MLDBM::Sync::SDBM_File 1.41 seconds 1163264 bytes Time for 100 writes + 100 reads for GDBM_File 1.38 seconds 832400 bytes Time for 100 writes + 100 reads for DB_File 1.21 seconds 831488 bytes Time for 100 writes + 100 reads for Tie::TextDir .04 0.58 seconds 508192 bytes === INSERT OF 20000 BYTE RECORDS === (skipping test for SDBM_File 100 byte limit) (skipping test for MLDBM::Sync db size > 1M) Time for 100 writes + 100 reads for GDBM_File 2.23 seconds 2063912 bytes Time for 100 writes + 100 reads for DB_File 1.89 seconds 2060288 bytes Time for 100 writes + 100 reads for Tie::TextDir .04 1.26 seconds 2008192 bytes === INSERT OF 50000 BYTE RECORDS === (skipping test for SDBM_File 100 byte limit) (skipping test for MLDBM::Sync db size > 1M) Time for 100 writes + 100 reads for GDBM_File 3.66 seconds 5337944 bytes Time for 100 writes + 100 reads for DB_File 3.64 seconds 5337088 bytes Time for 100 writes + 100 reads for Tie::TextDir .04 2.80 seconds 5008192 bytes =head1 AUTHORS Copyright (c) 2001-2002 Joshua Chamas, Chamas Enterprises Inc. All rights reserved. Sponsored by development on NodeWorks http://www.nodeworks.com and Apache::ASP http://www.apache-asp.org This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO MLDBM(3), SDBM_File(3), DB_File(3), GDBM_File(3)