File Coverage

blib/lib/DirDB.pm

Criterion	Covered	Total	%
statement	170	254	66.9
branch	66	146	45.2
condition	5	12	41.6
subroutine	19	26	73.0
pod	1	4	25.0
total	261	442	59.0

package DirDB;

require 5.005_62;
use strict;
use warnings;
use Carp;

our $VERSION = '0.12';

my $DefaultArrayImpl = ['Tie::File' =>DATAPATH => recsep => "\0"]; # may change
my %ArrayImpl;
sub TIEHASH {
	my $self = shift;
	my $rootpath = shift or croak "we need a rootpath";
	$rootpath =~ s#/+$##; # lose trailing slash(es)
	-d $rootpath or
	   mkdir $rootpath, 0777 or
	     croak "could not create dir $rootpath: $!";
	my $me = bless \"$rootpath/", $self;

	my %moreargs = @_;
	$ArrayImpl{$me} = $moreargs{ARRAY} || $DefaultArrayImpl;
	$me;
};

sub TIEARRAY {
	confess "DirDB does not support arrays yet, although as of version 0.11 you may store and retrieve array references";
};

sub TIESCALAR {
	confess "DirDB does not support scalars yet -- try Tie::Slurp";
};


sub EXISTS {
	my $rootpath = ${+shift};
	my $key = shift;
	$key =~ s/^ /  /; #escape leading space into two spaces
	# defined (my $key = shift) or return undef;
	$key eq '' and $key = ' EMPTY';
	-e "$rootpath$key" or -e "$rootpath LOCK$key";
};

sub recursive_delete($);
sub recursive_delete($){
# unlink a file or rm -rf a directory tree
	my $path = shift;
	unless ( -d $path and ! -l $path ){
		unlink $path;
		-e $path and die "Could not unlink [$path]: $!\n";
		return;
	};
	opendir FSDBFH, $path or croak "opendir $path: $!";
	my @DirEnts = (readdir FSDBFH);
	#warn "direrctoy $path contains [@DirEnts]";
	closedir FSDBFH;
	while(defined(my $entity = shift @DirEnts )){
		$entity =~ /^\.\.?\Z/ and next;
		 recursive_delete "$path/$entity";
	};
#1 && do{
#	opendir FSDBFH, $path or croak "opendir $path: $!";
#	my @DirEnts = (readdir FSDBFH);
#	warn "after deleting, direrctoy $path contains [@DirEnts]";
#	closedir FSDBFH;
#      };
	rmdir $path or die "could not rmdir [$path]: $!\n";

};

sub FETCH {
	my $ref = shift;
	defined (my $rootpath = $$ref) or croak "undefined rootpath";
	my $key = shift;
#	warn "fetching $key from $rootpath";
	$key =~ s/^ /  /; #escape leading space into two spaces
	# defined (my $key = shift) or return undef;
	$key eq '' and $key = ' EMPTY';
	sleep 1 while -e "$rootpath LOCK$key";
	-e "$rootpath$key" or return undef;
	if(-d "$rootpath$key"){

		tie my %newhash, ref($ref),"$rootpath$key";
		-f "$rootpath$key/ ARRAY" and do {
			my @TieArgs= split /\n/,tied(%newhash)->FETCHMETA('ARRAY');
			my $classname = shift @TieArgs;
			my @newarr;
		   eval{
			tie @newarr, $classname,
			map {
				$_ eq 'DATAPATH' ?
				"$rootpath$key/DATA" : $_
			} @TieArgs or die <
Tie <<$classname, @TieArgs>> Failed with error <<$!>>
EOF
		   }; $@ and croak "string tie problem: $@";
			return
				-f "$rootpath$key/ BLESS"
				?
				bless \@newarr, tied(%newhash)->FETCHMETA('BLESS')
				:
				 \@newarr;

		};
		$ArrayImpl{tied %newhash} = $ArrayImpl{$ref};
 		return
			-f "$rootpath$key/ BLESS"
			?
			bless \%newhash, tied(%newhash)->FETCHMETA('BLESS')
			:
			 \%newhash;
	};

	local *FSDBFH;
	open FSDBFH, "<$rootpath$key"
	   or croak "cannot open $rootpath$key: $!";

	local $/ = undef;
	;
};

{
my %CircleTracker;
sub STORE {
	my ($ref , $key, $value,$Xbless) = @_;
	my $rootpath = $$ref;
	my ($bless, $underly);
	# print "Storing $value to $key in $$ref\n";
	my $rnd = join 'X',$$,time,rand(10000);

	$key =~ s/^ /  /; #escape leading space into two spaces
	$key eq '' and $key = ' EMPTY';
	my $refvalue = ref $value;
	if ($refvalue){

		if ($refvalue eq 'ARRAY'){
			my %newhash;
			tie %newhash, DirDB=>"$rootpath A$rnd";
			tied(%newhash)->STOREMETA('ARRAY', join "\n", @{$ArrayImpl{$ref}});
			my @TieArgs = map {
				$_ eq 'DATAPATH' ? "$rootpath$key/DATA" : $_
			} @{$ArrayImpl{$ref}};
			$Xbless and
				tied(%newhash)->STOREMETA('BLESS', $Xbless);
		 	sleep 1 while !mkdir "$rootpath LOCK$key",0777;
		 	{
			  no warnings;
			  rename "$rootpath$key", "$rootpath GARBAGE$rnd";
			};
			rename "$rootpath A$rnd","$rootpath$key";
			my @NewArr = @$value;
			my $CN = shift @TieArgs;
		    eval{
			tie @$value,
				# $TieArgs[0],@TieArgs[1..$#TieArgs]
				$CN,@TieArgs
			or die "array tie to <<$CN, @TieArgs>> failed <<$!>>\n";
			@$value = @NewArr;
		    }; my $ERR = $@;
			rmdir "$rootpath LOCK$key";
		    $ERR and croak "DirDB arrayref store problem: $ERR";
			eval {recursive_delete "$rootpath GARBAGE$rnd"};
		 	if($@){
				croak "GC problem: $@";
		 	};
		 	return;
		};

		if ( $CircleTracker{$value}++ ){
	          croak "$ref version $VERSION cannot store circular structures\n";
		};


		unless ($refvalue eq 'HASH'){
		  ($bless,$underly) = ( "$value" =~ /^(.+)=([A-Z]+)\(/ );
		  {
			 no warnings; #suppress uninitalized value warning
			$underly eq 'HASH' and goto gottahash;
			$underly eq 'ARRAY' and do{
				STORE($ref, $key, [@$value],$bless);
				return;
			};
	          croak
		   "$ref version $VERSION only stores references to HASH, not $underly blessed to $refvalue\n";
		  }

		};
		gottahash:
		if (tied (%$value)){
			# recursive copy
		 tie my %tmp, ref($ref), "$rootpath TMP$rnd" or
		   croak "tie failed: $!";
		 eval{
		 	# %tmp = %$value

			my ($k,$v);
			while(($k,$v) = each %$value){
				$tmp{$k}=$v;
			};
		 };
		 # print "$rootpath TMP$rnd should now contain @{[%$value]}\n";
		 if($@){
		    my $message = $@;
		    eval {recursive_delete "$rootpath TMP$rnd"};
		    croak "trouble writing [$value] to [$rootpath$key]: $message";

		};

		# print "lock (tied)";
		 sleep 1 while !mkdir "$rootpath LOCK$key",0777;
		 {
		  no warnings;
		  rename "$rootpath$key", "$rootpath GARBAGE$rnd";
		 };
		 rename "$rootpath TMP$rnd", "$rootpath$key";

		}else{ # not tied

			# cache, bless, restore
			my @cache = %$value;
			%$value = ();
		# print "lock (untied)";
			while( !mkdir "$rootpath LOCK$key",0777){
				# print "lock conflivt: $!";
				sleep 1;
			};
			{
			 no warnings;
		         rename "$rootpath$key", "$rootpath GARBAGE$rnd";
		        };
		        tie %$value, ref($ref), "$rootpath$key" or
		          warn "tie to [$rootpath$key] failed: $!";
		# print "assignment";
		};

		if(defined($bless)){
			tied(%$value)->STOREMETA('BLESS',$bless);
			# bless $value, $bless; not needed; this is why we are here!
		};

		GC:

		rmdir "$rootpath LOCK$key";

		delete $CircleTracker{$value};
		# print "GC";
		 eval {recursive_delete "$rootpath GARBAGE$rnd"};
		 if($@){
			croak "GC problem: $@";
		 };

		 return;

	}; # if refvalue

	# store a scalar using write-to-temp-and-rename
	local *FSDBFH;
	open FSDBFH,">$rootpath TMP$rnd" or croak $!;
	# defined $value and print FSDBFH $value;
	# this will work under -l without spurious newlines
	defined $value and syswrite FSDBFH, $value;
	# print FSDBFH qq{$value};
	close FSDBFH;
	rename "$rootpath TMP$rnd" , "$rootpath$key" or
	  croak
	     " could not rename temp file to [$rootpath$key]: $!";
};
};

sub FETCHMETA {
	my $ref = shift;
	defined (my $rootpath = $$ref) or croak "undefined rootpath";
	my $key = ' '.shift;
	-e "$rootpath$key" or return undef;
	if(-d "$rootpath$key"){

		confess "Complex metadata not supported in DirDB version $VERSION";

	};

	local $/ = undef;
	open FSDBFH, "<$rootpath$key"
	   or croak "cannot open $rootpath$key: $!";
	my $result = ;
	close FSDBFH;
	$result;
};

sub STOREMETA {
	my $rootpath = ${+shift}; # RTFM! :)
	my $key = ' '.shift;
	my $value = shift;
	ref $value and croak "DirDB does not support storing references in metadata at version $VERSION";
	open FSDBFH,">$rootpath${$}TEMP$key" or croak $!;
	defined $value and syswrite FSDBFH, $value;
	# print FSDBFH $value;
	close FSDBFH;
	rename "$rootpath${$}TEMP$key", "$rootpath$key" or croak $!;
};

sub DELETE {
	my $ref = shift;
	my $rootpath = ${$ref};
	my $key = shift;
	my $value;
	$key =~ s/^ /  /; #escape leading space into two spaces
	$key eq '' and $key = ' EMPTY';

	-e "$rootpath$key" or return undef;
#warn "DELETING $rootpath$key";
	-d "$rootpath$key" and do {
#warn "DELETING directory $rootpath$key";

	  rename "$rootpath$key", "$rootpath DELETIA$key" or die "rename: $!";

	  if(defined wantarray){

		my %rethash;
		tie my %tmp, ref($ref), "$rootpath DELETIA$key";
		my @keys = keys %tmp;
		my $k;
		for $k (@keys){
			$rethash{$k} = delete $tmp{$k};
		};

		eval {recursive_delete "$rootpath DELETIA$key"};
		$@ and croak "could not delete directory $rootpath$key: $@";
		return \%rethash;

	  }else{
		eval {recursive_delete "$rootpath DELETIA$key"};
		$@ and croak "could not delete directory $rootpath$key: $@";
		return {};
	  };
	};

	if(defined wantarray){
		local $/ = undef;
		open FSDBFH, "<$rootpath$key";
		$value = ;
		close FSDBFH;
	};
	unlink "$rootpath$key" or die "could not unlink $rootpath$key: $!";
	$value;
};

sub CLEAR{
	my $ref = shift;
	my $path = $$ref;
	opendir FSDBFH, $path or croak "opendir $path: $!";
	my @ents = (readdir FSDBFH );
	while(defined(my $entity = shift @ents )){
		$entity =~ /^\.\.?\Z/ and next;
		$entity = join('',$path,$entity);
		if(-d $entity){
		   eval {recursive_delete $entity};
		   $@ and  croak "could not delete (sub-container?) directory $entity: $@";
		};
		unlink $entity;
	};
};

{

   my %IteratorListings;

   sub FIRSTKEY {
	my $ref = shift;
	my $path = $$ref;
	opendir FSDBFH, $path or croak "opendir $path: $!";
	$IteratorListings{$ref} = [ grep { defined $_ and !($_ =~ /^\.\.?\Z/)} readdir FSDBFH ];

	#print "Keys in path <$path> will be shifted from <@{$IteratorListings{$ref}}>\n";

	$ref->NEXTKEY;
   };

   sub NEXTKEY{
	my $ref = shift;
	#print "next key in path <$$ref> will be shifted from <@{$IteratorListings{$ref}}>\n";
	@{$IteratorListings{$ref}} or return undef;
	# warn join '|','BEGIN',@{$IteratorListings{$ref}},"END";
	my $key = shift @{$IteratorListings{$ref}};
	# warn "key: <$key>";
	if ($key =~ s/^ //){
		# warn "key: <$key>";
		if ($key =~ m/^ /){
			# we have unescaped a leading space.
		}elsif ($key eq 'EMPTY'){
			$key = ''
		#}elsif($key eq 'REF'){
		# 	return $ref->NEXTKEY();	# next
		#}elsif($key =~ m/^ARRAY){
		# 	return $ref->NEXTKEY();	# next
		}else{
			# per-container metadata does not
			# appear in iterations through data.
			return $ref->NEXTKEY();	# next
		}
	};
	wantarray or return $key;
	return @{[$key, $ref->FETCH($key)]};
   };

   sub DESTROY{
       delete $IteratorListings{$_[0]};
       delete $ArrayImpl{$_[0]};
   };

}; # end visibility of %IteratorListings

sub lock{
	my $path = ${shift @_};
	my $key= '';
	if(@_){
		$key = shift;
		length $key or $key = ' EMPTY';
	};
	return obtain DirDB::lock "$path$key";
};

package DirDB::lock;
use Carp;
my %OldLocks;
sub obtain{
	my $path = shift;
	while(!mkdir "$path LOCK",0777){
		select(undef,undef,undef,0.2);
	};
	bless \$path;
};
sub release{
	rmdir "$$_[0] LOCK" or croak "failure releasing $$_[0]: $!";
	$OldLocks{"$_[0]"} = 1;
};
sub DESTROY{
	delete $OldLocks{"$_[0]"} or
	rmdir "$$_[0] LOCK" or croak "failure releasing $$_[0]: $!";
};

1;
__END__