File Coverage

blib/lib/MLDBM/Sync.pm

Criterion	Covered	Total	%
statement	131	165	79.3
branch	37	80	46.2
condition	11	20	55.0
subroutine	23	24	95.8
pod	0	8	0.0
total	202	297	68.0

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__