File Coverage

blib/lib/Tie/TwoLevelHash.pm

Criterion	Covered	Total	%
statement	123	222	55.4
branch	45	96	46.8
condition	5	10	50.0
subroutine	10	16	62.5
pod	0	1	0.0
total	183	345	53.0

package Tie::TwoLevelHash;

# $Id: TwoLevelHash.pm,v 1.2 1998/10/30 13:52:04 kmeltz Exp kmeltz $

# $Log: TwoLevelHash.pm,v $
# Revision 1.2  1998/10/30 13:52:04  kmeltz
# Fixed FETCH so it will return correctly when doing %foo = %bar; when using a tie to a HoH's. Still not working right for hash in the HoH's, so the GetHash method stays.
#
#
# Revision 1.1  1998/10/27 15:43:47  kmeltz
# Changed croaks to carps for Hash Invalid warning. May need to continue script, so let script die and module return undef.
# Changed CLEAR to not erase TLH file when clearing hash in HoH's, or resetting it.
# Added exported method GetHash. This allows for user to import hash values into their script, and change values before setting them to TLH file.
# Changed a bunch in the POD.
#

use FileHandle;
use Carp;
use vars qw($VERSION @ISA @EXPORT);
@ISA = qw(Exporter);
@EXPORT = qw();
use strict;

($VERSION = substr(q$Revision: 1.2 $, 10)) =~ s/\s+$//;

sub TIEHASH {
	my $self = shift;
	my $path = shift;
	my $mode = shift || 'r';
	my $oneHash = "";
	my ($comment, %tlhash, %unihash, $key);
	my $single=0;

	# Check to see if $path has two elements
	if ($path =~ /,/) {
		($path, $oneHash) = split(/,/,$path);
	}

	if (@_) {
		croak ("usage: tie(\%hash, \$file[, Hash name], [mode])");
	}

	# Nice-ify $path:
	$path =~ s#/$##;

	# Can we make changes to the database?
	my $clobber = ($mode eq 'rw' ? 1 : 0);

	unless (-e $path) {
		if ($clobber) {
			# Create the tlh if it does not exist
			unless (open(FH,">$path")) {croak("Can't create $path: $!");}
		} else {
			croak("$path does not exist");
		}
	#croak "File does not exist\n";
	}
	close FH;

	# Get a filehandle and open the file:
	my $fh = new FileHandle;
	open($fh, $path) or croak("can't open $path: $!");

	my $tlh;

	# Showing one hash
	if ($oneHash ne "") {
		$oneHash =~ s/^\s//;
		($comment, %unihash) = $self->_get_HoH($path);
		#%tlhash = $self->_get_SingHash("$oneHash", $path);
		foreach $key (keys %unihash) {
			if ($key eq $oneHash) {
				%tlhash->{$key} = $unihash{$key};
			}
		}
		$single=1;
	# Show HoH's
	}else{
		($comment, %tlhash) = $self->_get_HoH($path);
	}

	my $node = {
		PATH    => $path,
		CLOBBER	=> $clobber,
		HANDLE	=> $fh,
		SINGLEHASH => $single,
	};
		$node->{BIHASH} = \%tlhash;
		$node->{UNIHASH} = \%unihash if defined(%unihash);
		$node->{UNIHASHNAME} = $oneHash if defined(%unihash);
		$node->{COMMENTS} = $comment if defined($comment);

if ($oneHash ne "" ) { $node->{SINGLEHASH} = 1; }else{$node->{SINGLEHASH} = 0;}

	return bless $node => $self;

}

#-------------------------------------------------------#

sub FETCH {
	my $self = shift;
	my $key	= shift;

	# If showing one hash
	if ($self->{SINGLEHASH}) {
		my $uniname = $self->{UNIHASHNAME};
	if ($key eq $uniname) {
		my %return = $self->GetHash();
		return \%return;
	}
	        unless (exists $self->{BIHASH}->{$uniname}->{$key}) {
			carp "Hash invalid";
			return undef;
            	 }
		if (defined $self->{BIHASH}->{$uniname}->{$key}) {
        		return $self->{BIHASH}->{$uniname}->{$key};
       		 } else {
        	       return carp("Fetch failed for $key");
       		 }
	}

	# If showing HoH's
        unless (exists $self->{BIHASH}->{$key}) {
		carp "Hash invalid";
		return undef;
             }
	if (defined $self->{BIHASH}->{$key}) {
        	return $self->{BIHASH}->{$key};
        } else {
               return carp("Fetch failed for $key");
        }
}

#-------------------------------------------------------#

sub STORE {
	my $self = shift;
	my $key	= shift;
	my $value;# = shift || "";
	my ($inKey);
	my $file = $self->{PATH};
	my ($foo,$val,$bar,$str, %value);
	my (%foo);
	my $single = $self->{SINGLEHASH};
	my %bihash = %{$self->{'BIHASH'}};
	my (%unihash);

	if ($single) {%unihash = %{$self->{'UNIHASH'}}; $value = shift;}else{$value=shift || "";}

	# HoH's AND no value/undef
	if (!$single && $value eq "") {
		if (!$self->EXISTS($key)) {
			carp("Tried deleting $key which doesn't exist");
			return 0;
		}

		if (!$self->_deleteRecord($key)) {
			return 0;
		} else {
			return 1;
		}
	}

	if (!$single) {
		%value = %$value;
	}

	unless ($self->{CLOBBER}) {
		carp ("No write access for $self->{'PATH'}");
		return;
	}

	my $fh;
	unless ($fh = new FileHandle(">$file")) {
	#unless ($fh = new FileHandle("$file")) { # DEBUG
		croak ("Can't open $file: $!");
	}

	# Set the new value in original hash
	if (!$single) {
		foreach $inKey (sort keys %value) {
		#print "$inKey $value{$inKey}\n"; # DEBUG
			if ($inKey eq "") {
				undef $bihash{$key}{$inKey};
				next;
			}
		$bihash{$key}{$inKey} = $value{$inKey};
		}
	} else {
		if (!defined($value)) {
		undef $unihash{$self->{UNIHASHNAME}}{$key};
		undef $bihash{$key};

		}

	$unihash{$self->{UNIHASHNAME}}{$key} = $value;
	$bihash{$key} = $value;

	}# endif

	# If there were comments on the top, re-write them first
	if (defined($self->{COMMENTS})) {
		my $comment = $self->{COMMENTS};
		$str .= "$comment";
	}


	# Run through HoH from memory and get out each Hash in %zog
	if (!$single) {
		foreach $foo (sort keys %bihash) {
			$str .= "\n$foo\n";
			my $zog = $bihash{$foo};
			my %zog=%$zog;
			# Get all values in %zog
				foreach $bar (sort keys %zog) {
					$str .= "\t$bar\: $zog{$bar}\n" unless !defined($zog{$bar});
				}
		}
	} else {
		foreach $foo (sort keys %unihash) {
			$str .= "\n$foo\n";
			my $zog = $unihash{$foo};
			my %zog=%$zog;
			# Get all values in %zog
				foreach $bar (sort keys %zog) {
					$str .= "\t$bar\: $zog{$bar}\n" unless !defined($zog{$bar});
				}
		}
	}
	$self->{'UNIHASH'} = \%unihash if defined(%unihash);
	$self->{'BIHASH'} = \%bihash;
	print $fh $str;
	close $fh;
	return 1;
}

#-------------------------------------------------------#

sub DELETE {
	my ($self) = shift;
	my ($key) = shift;
	if ($self->{SINGLEHASH}) {
		delete $self->{UNIHASH}->{$key};
		delete $self->{BIHASH}->{$key};
	}else{
		delete $self->{BIHASH}->{$key};
	}
}

#-------------------------------------------------------#

sub CLEAR {
	my ($self) = shift;
	my ($key);
	my ($file) = $self->{'PATH'};

	if ($self->{SINGLEHASH}) {
		foreach $key (keys %{$self->{BIHASH}}) {
			$self->DELETE($key);
		}
	return 1;
	}
	foreach $key (keys %{$self->{BIHASH}}) {
        	$self->DELETE($key);
        }


	# Erase file, since it is being cleared

	unless ($self->{SINGLEHASH}) {
	my $fh;
		unless ($fh = new FileHandle(">$file")) {
		#unless ($fh = new FileHandle("$file")) { # DEBUG
			croak ("Can't open $file: $!");
		}
	close $fh;
	}
	# File erased, if tied to HoH

}

#-------------------------------------------------------#

sub EXISTS {
	my $self = shift;
	my $key	= shift;

        return exists $self->{BIHASH}->{$key};
}

#-------------------------------------------------------#

sub DESTROY {
	my $self = shift;
	my $node = {};
}

#-------------------------------------------------------#

sub FIRSTKEY {
        my $self = shift;
        my $a = keys %{$self->{BIHASH}};
        each %{$self->{BIHASH}}
}

#-------------------------------------------------------#

sub NEXTKEY {
	my $self = shift;
        return each %{$self->{BIHASH}}
}

#-------------------------------------------------------#

sub _deleteRecord {
	my $self = shift;
	my $record = shift;
	if (!defined($record)) {
		carp("Not enough args passed to _deleteRecord");
		return 0;
	}
	my $file = $self->{PATH};
	my ($foo,$str,$bar);
	my $fh;
	unless ($fh = new FileHandle(">$file")) {
	#unless ($fh = new FileHandle("$file")) { # DEBUG
		croak ("can't open $file: $!");
	}
	my %bihash = %{$self->{'BIHASH'}};
	$str .= $self->{'COMMENTS'} if defined($self->{'COMMENTS'});

	foreach $foo (sort keys %bihash) {
		#print "$foo $bihash{$foo} d\n";
		if ($foo eq $record) {
		#$bihash{$foo} = undef;
			next;
		}
		$str .= "\n$foo\n";
		my $zog = $bihash{$foo};
		my %zog=%$zog;
		# Get all values in %zog
			foreach $bar (sort keys %zog) {
				$str .= "\t$bar\: $zog{$bar}\n" unless !defined($zog{$bar});
			}
	}

	$self->{'BIHASH'} = \%bihash;
print $fh $str;
close $fh;
return 1;
}

#-----------------------------------------------------------#

sub _get_HoH {
	my ($self) = shift;
	my ($slh) = shift;
	my ($key, $val);
	my ($name, @lines, $rec, $line);
	my (%HoH);
	my ($FH) = new FileHandle;

	if (!open($FH,"$slh")) {
		croak "Cannot open $FH $slh: $!";
	}

local $/ = "";

my @records = <$FH>;

# Make sure comments at top of TLH file stay
my $comment;
if ($records[0] && $records[0] =~ /^#/) {
	$comment = $records[0];
	chop $comment;
	shift @records;
}
	foreach $rec (@records) {

    ($name, @lines) = split /\n[\s]*/, $rec;

    foreach $line (@lines) {
        ($key, $val) = split /:\s*/, $line;
	$HoH{$name}->{$key} = $val;

    }
}
	if (!close($FH)) {
		croak "Cannot close $FH: $!";
	}

return ($comment, %HoH);
} # end _get_HoH

#-----------------------------------------------------------#

sub GetHash {
	my ($self) = shift;
	my ($hash, %hash);
	my $name = $self->{UNIHASHNAME} if ($self->{UNIHASHNAME} ne "");

	if (defined($name)) {
		$hash = $self->{BIHASH}->{$name};
	}else{
		$hash = $self->{BIHASH};
	}
	%hash = %$hash;

	return %hash;
}

#-----------------------------------------------------------#

1;

__END__