diff -r 22486c9c7b15 -r 378360dbbdba releasing/cbrtools/perl/MLDBM/Sync.pm --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/releasing/cbrtools/perl/MLDBM/Sync.pm Wed Jun 30 11:35:58 2010 +0800 @@ -0,0 +1,596 @@ +# 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. + + +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)