view release on metacpan or  search on metacpan

DirDB.pm  view on Meta::CPAN

	if(defined wantarray){
		local $/ = undef;
		open FSDBFH, "<$rootpath$key";
		$value = <FSDBFH>;
		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__

=head1 NAME

DirDB - use a directory as a persistence back end for (multi-level) (blessed) hashes (that may contain array references) (and can be advisorialy locked)

=head1 SYNOPSIS

  use DirDB;
  tie my %session, 'DirDB', "./data/session";
  $session{$sessionID}{email} = get_emailaddress();
  $session{$sessionID}{objectcache}{fribble} ||= new fribble;
  #
  use Tie::File; # see below -- any array-in-a-filesystem representation
                 # is supported
  push @{$session{$sessionID}{events}}, $event;