File Coverage

blib/lib/AsciiDB/TagFile.pm

Criterion	Covered	Total	%
statement	108	114	94.7
branch	29	38	76.3
condition	9	16	56.2
subroutine	20	20	100.0
pod	0	7	0.0
total	166	195	85.1

package AsciiDB::TagFile;

# Copyright (c) 1997-2001 Jose A. Rodriguez. All rights reserved.
# This program is free software; you can redistribute it and/or modify it
# under the same terms as Perl itself.

require Tie::Hash;
@ISA = (Tie::Hash);

use Cwd;

use vars qw($VERSION $catPathFileName);

BEGIN {
	eval "use File::Spec";
	$catPathFileName = ($@) ?
		sub { join('/', @_) } : # Unix way
		sub { File::Spec->catfile(@_) }; # Portable way
}

$VERSION = '1.06';

use Carp;
use AsciiDB::TagRecord;

sub TIEHASH {
	my $class = shift;
	my %params = @_;

	my $self = {};
	$self->{_DIRECTORY} = $params{DIRECTORY} || cwd;
	$self->{_SUFIX} = $params{SUFIX} || '';
	$self->{_SCHEMA} = $params{SCHEMA};
	$self->{_READONLY} = $params{READONLY};
	$self->{_FILEMODE} = $params{FILEMODE};
	$self->{_LOCK} = $params{LOCK} || 0;
	$self->{_CACHESIZE} = $params{CACHESIZE};

	unless (-d $self->{_DIRECTORY}) {
		croak "Directory '$params{DIRECTORY}' does not exist";
	}

	if (defined $self->{_CACHESIZE}) {
		$self->{_CACHESIZE} = int($self->{_CACHESIZE});

		if ($self->{_CACHESIZE} == 0) {
			undef $self->{_CACHESIZE};
		} elsif ($self->{_CACHESIZE} < 1) {
			croak "Cache size should be >= 0 (0 means no cache)";
			$self->{_CACHESIZE} = 1;
		}
	}

	# Number of internal keys (ie. '_key')
	$self->{_INTKEYCOUNT} = 1 + keys %$self;

	bless $self, $class;
}

sub FETCH {
	my ($self, $key) = @_;

	return $self->{$key} if exists ($self->{$key});

	return $self->newRecord($key);
}

sub STORE {
	my ($self, $key, $value) = @_;

	# Return if the user is assigning an object to itself ($a{A} = $a{A})
	return if exists $self->{$key} && $self->{$key} == $value;

	$self->newRecord($key) unless (exists $self->{$key});

	my $field;
	foreach $field (keys %{$self->{$key}}) {
		$self->{$key}{$field} = $value->{$field};
	}
}

sub FIRSTKEY {
	my $self = shift;

	# Current keys are the union of saved keys and new created but
	# not saved keys
	my %currentKeys;

	my $sufix = $self->{_SUFIX};

	map { $currentKeys{$_} = 1 }
		map { $self->decodeKey($_) }
		grep { $_  =~ /(.+)\Q$sufix\E$/; $_ = $1 }
		$self->getDirFiles();
	map { $currentKeys{$_} = 1 } grep(!/^_/, keys %$self);

	my @currentKeys = keys %currentKeys;
	$self->{_ITERATOR} = \@currentKeys;

	shift @{$self->{_ITERATOR}};
}

sub NEXTKEY {
	my $self = shift;

	shift @{$self->{_ITERATOR}};
}

sub EXISTS {
	my ($self, $key) = @_;

	$self->{$key} || -f $self->fileName($key) || 0;
}

sub DELETE {
	my ($self, $key) = @_;

	return if $self->{_READONLY};

	unlink $self->fileName($key);

	tied(%{$self->{$key}})->deleteRecord()
		if tied(%{$self->{$key}});

	delete $self->{$key} if exists $self->{$key};
}

sub sync {
	my $self = shift;

	my @recordsToSync = grep {
		ref $_ && ref($_) eq 'HASH' && tied(%$_)
	} values %{$self};

	my $record;
	foreach $record (@recordsToSync) {
		tied(%$record)->sync();
	}
}

sub purge {
	my $self = shift;
	my ($cacheSize) = @_;

	if (defined($cacheSize)) {
		my $dataRecords = scalar(keys %$self) - $self->{_INTKEYCOUNT};
		return if $dataRecords < $cacheSize;
	}

	# This works in 5.004 no 5.003
	#delete @$self{grep !/^_/, keys %{$self}};
	# instead we use this...
	foreach (grep !/^_/, keys %{$self}) {
		delete $self->{$_};
	}
}

sub newRecord {
	my $self = shift;
	my ($key) = @_;

	$self->purge($self->{_CACHESIZE}) if defined($self->{_CACHESIZE});

	my %record;
	tie %record, 'AsciiDB::TagRecord',
        	FILENAME => $self->fileName($key),
        	SCHEMA => $self->{_SCHEMA},
		READONLY => $self->{_READONLY},
		FILEMODE => $self->{_FILEMODE};

	$self->{$key} = \%record;
}

sub encodeKey {
	my $self = shift;
	my ($key) = @_;

	my $encodeSub = $self->{_SCHEMA}{KEY}{ENCODE};
	($encodeSub) ? &$encodeSub($key) : $key;
}

sub decodeKey {
	my $self = shift;
	my ($key) = @_;

	my $decodeSub = $self->{_SCHEMA}{KEY}{DECODE};
	($decodeSub) ? &$decodeSub($key) : $key;
}

sub fileName {
	my $self = shift;
	my ($key) = $self->encodeKey(@_);

	&$catPathFileName($$self{_DIRECTORY}, "$key$$self{_SUFIX}")
}

sub getDirFiles {
	my $self = shift;

	local *DIR;
	opendir(DIR, $$self{_DIRECTORY})
		|| die "Can't opendir $$self{_DIRECTORY}: $!";
	my @files = grep { -f &$catPathFileName($$self{_DIRECTORY}, $_) }
		readdir(DIR);
	closedir DIR;

	@files;
}

1;
__END__