File Coverage

blib/lib/Hash/WithDefaults.pm

Criterion	Covered	Total	%
statement	21	357	5.8
branch	0	166	0.0
condition	0	24	0.0
subroutine	11	47	23.4
pod	2	3	66.6
total	34	597	5.7

package Hash::WithDefaults;
use strict;
use Carp;
require Tie::Hash;
use vars qw(@ISA $VERSION);
@ISA = qw(Tie::StdHash);
$VERSION = '0.04';

sub DATA () {0}
sub DEFAULTS () {1}
sub ACTDEFAULT () {2}
sub SEEN () {3}

sub makeTIEHASH {
	my ($class, $set) = @_;
	$class = 'Hash::WithDefaults::' . $class;
	eval "sub ${class}::TIEHASH {" . <<'*END*' . "\t\t\t" . $set . <<'*END*' . "\t\t\t" . $set . <<'*END*';
	my $class = shift();
	my $data = {};

	if (! @_) {
		# no parameters
		return bless [ $data, []], $class;
	}

	if (@_ == 1 and ref $_[0] eq 'HASH') {
		my $input=$_[0];
		my ($key,$value);
		while (($key,$value) = each(%$input)) {
*END*

		}
	} else {
		my ($i, $arr) = (0);
		if (ref $_[0] eq 'ARRAY') {
			$arr = $_[0];
		} elsif (@_ % 2 == 0) {
			$arr = \@_;
		} else {
			croak "Ussage: tie %hashname, $class, \%hash\n or tie %hashname, $class, \\\%hash\n or tie %hashname, $class, \\\@array\n";
		}
		while ($i <= $#$arr) {
			my ($key,$value)=($arr->[$i],$arr->[$i+1]); $i+=2;
*END*

		}
	}

	bless [$data, []];
}
*END*
}

makeTIEHASH 'sensitive', '$data->{$key} = $value;';
makeTIEHASH 'tolower', '$data->{lc $key} = $value;';
makeTIEHASH 'toupper', '$data->{uc $key} = $value;';
makeTIEHASH 'lower', '$data->{lc $key} = $value;';
makeTIEHASH 'upper', '$data->{uc $key} = $value;';
makeTIEHASH 'preserve', '$data->{lc $key} = [$key,$value];';

sub TIEHASH {
	shift(); # shift out class name
	if (@_ == 0) {
		# no parameters
		unshift @_, 'Hash::WithDefaults::preserve';
		goto &Hash::WithDefaults::preserve::TIEHASH;
	}

	if (!ref $_[0] and (ref $_[1] eq 'HASH' or @_ % 2 == 1)) {
		# type plus either \%hash or %hash
		my $type = lc(splice(@_, 0, 1));
		if ($type =~ /^(?:sensitive|preserve|lower|upper|tolower|toupper)$/) {
			unshift @_, 'Hash::WithDefaults::' . $type;
			no strict 'refs';
			goto &{"Hash::WithDefaults::".$type."::TIEHASH"};
		} else {
			croak "Unknown type '$type'! Use one of:\n\tsensitive, preserve, lower, upper, tolower, toupper";
		}
	} else {
		unshift @_, 'Hash::WithDefaults::preserve';
		goto &Hash::WithDefaults::preserve::TIEHASH;
	}
}

sub AddDefault {
	push @{$_[0]->[DEFAULTS]}, $_[1];
	return 1;
}

sub GetDefaults {
	my $self = shift;
	return $self->[DEFAULTS];
}

sub CLEAR {
	my $self = shift;
	undef $self->[SEEN];
	undef $self->[ACTDEFAULT];
	$self
}


#############################

package Hash::WithDefaults::preserve;
BEGIN {*Hash::WithDefaults::Preserve:: = \%Hash::WithDefaults::preserve::;}
@Hash::WithDefaults::preserve::ISA = qw(Hash::WithDefaults);
sub DATA () {0}
sub DEFAULTS () {1}
sub ACTDEFAULT () {2}
sub SEEN () {3}

sub TIEHASH {
	splice( @_, 1, 0, 'preserve');
	goto &Hash::WithDefaults::TIEHASH;
}

sub STORE {
    $_[0]->[DATA]->{lc $_[1]} = [$_[1],$_[2]];
}

sub FETCH {
	my $lc_key = lc $_[1];
	return ${$_[0]->[DATA]->{$lc_key}}[1]
		if exists $_[0]->[DATA]->{$lc_key};

	foreach my $default (@{$_[0]->[DEFAULTS]}) {
		return $default->{$_[1]}
			if exists($default->{$_[1]});
	}

	return;
}

sub EXISTS {
	return 1
		if exists $_[0]->[DATA]->{lc $_[1]};

	foreach my $default (@{$_[0]->[DEFAULTS]}) {
		return 1
			if exists($default->{$_[1]});
	}

	return;
}

sub DELETE {
	delete $_[0]->[DATA]->{lc $_[1]}
}

sub FIRSTKEY {
	my $self = $_[0];
	undef $self->[ACTDEFAULT];
	$self->[SEEN] = {};
	keys %{$self->[DATA]};
	my ($key,$val);
	if (($key,$val) = each %{$self->[DATA]}) {
		$self->[SEEN]->{$key}=1;
		return wantarray ? ($val->[0], $val->[1]) : $val->[0];
	} elsif (@{$self->[DEFAULTS]}) {
		return $self->NEXTKEY();
	} else {
		return;
	}
}

sub NEXTKEY {
	my $self = $_[0];
	my $seen = $self->[SEEN];
	my ($key,$val);
	if (!defined $self->[ACTDEFAULT]) {
		# processing the base hash
		if (($key,$val) = each %{$self->[DATA]}) {
			$seen->{$key}=1;
			return wantarray ? ($val->[0], $val->[1]) : $val->[0];
		} else {
			# base hash done
			if (! @{$self->[DEFAULTS]}) {
				# no defaults
				return;
			} else {
				$self->[ACTDEFAULT]=0;
				# reset the first default
				keys %{$self->[DEFAULTS]->[0]};
			}
		}
	}

	while (exists $self->[DEFAULTS]->[$self->[ACTDEFAULT]]) {
		while (($key,$val) = each %{$self->[DEFAULTS]->[$self->[ACTDEFAULT]]}) {
			return wantarray ? ($key, $val) : $key
				unless $seen->{lc $key}++;
		}

		$self->[ACTDEFAULT]++;
		keys %{$self->[DEFAULTS]->[$self->[ACTDEFAULT]]}
			if exists $self->[DEFAULTS]->[$self->[ACTDEFAULT]];
	}

	# all hashes done. Cleanup
	undef $self->[SEEN];
	undef $self->[ACTDEFAULT];
	return;
}

#############################

package Hash::WithDefaults::lower;
BEGIN {*Hash::WithDefaults::Lower:: = \%Hash::WithDefaults::lower::;}
@Hash::WithDefaults::lower::ISA = qw(Hash::WithDefaults::preserve);
sub DATA () {0}
sub DEFAULTS () {1}
sub ACTDEFAULT () {2}
sub SEEN () {3}

sub TIEHASH {
	splice( @_, 1, 0, 'lower');
	goto &Hash::WithDefaults::TIEHASH;
}

sub STORE {
    $_[0]->[DATA]->{lc $_[1]} = $_[2];
}

sub FETCH {
	return $_[0]->[DATA]->{lc $_[1]}
		if exists $_[0]->[DATA]->{lc $_[1]};

	foreach my $default (@{$_[0]->[DEFAULTS]}) {
		return $default->{$_[1]}
			if exists($default->{$_[1]});
	}

	return;
}

sub EXISTS {
	return 1
		if exists $_[0]->[DATA]->{lc $_[1]};

	foreach my $default (@{$_[0]->[DEFAULTS]}) {
		return 1
			if exists($default->{$_[1]});
	}

	return;
}

sub DELETE {
	delete $_[0]->[DATA]->{lc $_[1]}
}

sub FIRSTKEY {
	my $self = $_[0];
	$self->[ACTDEFAULT] = -1;
	$self->[SEEN] = {};
	keys %{$self->[DATA]};
	my ($key,$val);
	if (($key,$val) = each %{$self->[DATA]}) {
		$self->[SEEN]->{$key}=1;
		return wantarray ? ($key, $val) : $key;
	} elsif (@{$self->[DEFAULTS]}) {
		return $self->NEXTKEY();
	} else {
		return;
	}
}

sub NEXTKEY {
	my $self = $_[0];
	my $seen = $self->[SEEN];
	my $defaults = $self->[DEFAULTS];
	my ($key,$val);
	if ($self->[ACTDEFAULT] == -1) {
		# processing the base hash
		if (($key,$val) = each %{$self->[DATA]}) {
			$seen->{$key}=1;
			return wantarray ? ($key, $val) : $key;
		} else {
			# base hash done
			$self->[ACTDEFAULT]=0;
			if (! @$defaults) {
				# no defaults
				return;
			} else {
				# reset the first default
				keys %{$defaults->[0]};
			}
		}
	}
	while (exists $defaults->[$self->[ACTDEFAULT]]) {
		while (($key,$val) = each %{$defaults->[$self->[ACTDEFAULT]]}) {
			return wantarray ? ($key, $val) : $key
				unless $seen->{lc $key}++;
		}

		$self->[ACTDEFAULT]++;
		keys %{$defaults->[$self->[ACTDEFAULT]]}
			if exists $defaults->[$self->[ACTDEFAULT]];
	}

	# all hashes done. Cleanup
	undef $self->[SEEN];
	undef $self->[ACTDEFAULT];
	return;
}

#############################

package Hash::WithDefaults::upper;
BEGIN {*Hash::WithDefaults::Upper:: = \%Hash::WithDefaults::upper::;}
@Hash::WithDefaults::upper::ISA = qw(Hash::WithDefaults::preserve);
sub DATA () {0}
sub DEFAULTS () {1}
sub ACTDEFAULT () {2}
sub SEEN () {3}

sub TIEHASH {
	splice( @_, 1, 0, 'upper');
	goto &Hash::WithDefaults::TIEHASH;
}

sub STORE {
    $_[0]->[DATA]->{uc $_[1]} = $_[2];
}

sub FETCH {
	return $_[0]->[DATA]->{uc $_[1]}
		if exists $_[0]->[DATA]->{uc $_[1]};

	foreach my $default (@{$_[0]->[DEFAULTS]}) {
		return $default->{$_[1]}
			if exists($default->{$_[1]});
	}

	return;
}

sub EXISTS {
	return 1
		if exists $_[0]->[DATA]->{uc $_[1]};

	foreach my $default (@{$_[0]->[DEFAULTS]}) {
		return 1
			if exists($default->{$_[1]});
	}

	return;
}

sub DELETE {
	delete $_[0]->[DATA]->{uc $_[1]}
}

sub FIRSTKEY {
	my $self = $_[0];
	$self->[ACTDEFAULT] = -1;
	$self->[SEEN] = {};
	keys %{$self->[DATA]};
	my ($key,$val);
	if (($key,$val) = each %{$self->[DATA]}) {
		$self->[SEEN]->{$key}=1;
		return wantarray ? ($key, $val) : $key;
	} elsif (@{$self->[DEFAULTS]}) {
		return $self->NEXTKEY();
	} else {
		return;
	}
}

sub NEXTKEY {
	my $self = $_[0];
	my $seen = $self->[SEEN];
	my $defaults = $self->[DEFAULTS];
	my ($key,$val);
	if ($self->[ACTDEFAULT] == -1) {
		# processing the base hash
		if (($key,$val) = each %{$self->[DATA]}) {
			$seen->{$key}=1;
			return wantarray ? ($key, $val) : $key;
		} else {
			# base hash done
			$self->[ACTDEFAULT]=0;
			if (! @$defaults) {
				# no defaults
				return;
			} else {
				# reset the first default
				keys %{$defaults->[0]};
			}
		}
	}
	while (exists $defaults->[$self->[ACTDEFAULT]]) {
		while (($key,$val) = each %{$defaults->[$self->[ACTDEFAULT]]}) {
			return wantarray ? ($key, $val) : $key
				unless $seen->{uc $key}++;
		}

		$self->[ACTDEFAULT]++;
		keys %{$defaults->[$self->[ACTDEFAULT]]}
			if exists $defaults->[$self->[ACTDEFAULT]];
	}

	# all hashes done. Cleanup
	undef $self->[SEEN];
	undef $self->[ACTDEFAULT];
	return;
}


#############################

package Hash::WithDefaults::sensitive;
BEGIN {*Hash::WithDefaults::Sensitive:: = \%Hash::WithDefaults::sensitive::;}
@Hash::WithDefaults::sensitive::ISA = qw(Hash::WithDefaults);
sub DATA () {0}
sub DEFAULTS () {1}
sub ACTDEFAULT () {2}
sub SEEN () {3}

sub TIEHASH {
	splice( @_, 1, 0, 'sensitive');
	goto &Hash::WithDefaults::TIEHASH;
}

sub STORE {
    $_[0]->[DATA]->{$_[1]} = $_[2];
}

sub FETCH {
	return $_[0]->[DATA]->{$_[1]}
		if exists $_[0]->[DATA]->{$_[1]};

	foreach my $default (@{$_[0]->[DEFAULTS]}) {
		return $default->{$_[1]}
			if exists($default->{$_[1]});
	}

	return;
}

sub EXISTS {
	return 1
		if exists $_[0]->[DATA]->{$_[1]};

	foreach my $default (@{$_[0]->[DEFAULTS]}) {
		return 1
			if exists($default->{$_[1]});
	}

	return;
}

sub DELETE {
	delete $_[0]->[DATA]->{$_[1]}
}

sub FIRSTKEY {
	my $self = $_[0];
	$self->[ACTDEFAULT] = -1;
	$self->[SEEN] = {};
	keys %{$self->[DATA]};
	my ($key,$val);
	if (($key,$val) = each %{$self->[DATA]}) {
		$self->[SEEN]->{$key}=1;
		return wantarray ? ($key, $val) : $key;
	} elsif (@{$self->[DEFAULTS]}) {
		return $self->NEXTKEY();
	} else {
		return;
	}
}

sub NEXTKEY {
	my $self = $_[0];
	my $seen = $self->[SEEN];
	my $defaults = $self->[DEFAULTS];
	my ($key,$val);
	if ($self->[ACTDEFAULT] == -1) {
		# processing the base hash
		if (($key,$val) = each %{$self->[DATA]}) {
			$seen->{$key}=1;
			return wantarray ? ($key, $val) : $key;
		} else {
			# base hash done
			$self->[ACTDEFAULT]=0;
			if (! @$defaults) {
				# no defaults
				return;
			} else {
				# reset the first default
				keys %{$defaults->[0]};
			}
		}
	}
	while (exists $defaults->[$self->[ACTDEFAULT]]) {
		while (($key,$val) = each %{$defaults->[$self->[ACTDEFAULT]]}) {
			return wantarray ? ($key, $val) : $key
				unless $seen->{$key}++;
		}

		$self->[ACTDEFAULT]++;
		keys %{$defaults->[$self->[ACTDEFAULT]]}
			if exists $defaults->[$self->[ACTDEFAULT]];
	}

	# all hashes done. Cleanup
	undef $self->[SEEN];
	undef $self->[ACTDEFAULT];
	return;
}


#############################

package Hash::WithDefaults::toupper;
BEGIN {*Hash::WithDefaults::Toupper:: = \%Hash::WithDefaults::toupper::;}
@Hash::WithDefaults::toupper::ISA = qw(Hash::WithDefaults::sensitive);
sub DATA () {0}
sub DEFAULTS () {1}
sub ACTDEFAULT () {2}
sub SEEN () {3}

sub TIEHASH {
	splice( @_, 1, 0, 'toupper');
	goto &Hash::WithDefaults::TIEHASH;
}

sub STORE {
    $_[0]->[DATA]->{uc $_[1]} = $_[2];
}

#############################

package Hash::WithDefaults::tolower;
BEGIN {*Hash::WithDefaults::Tolower:: = \%Hash::WithDefaults::tolower::;}
@Hash::WithDefaults::tolower::ISA = qw(Hash::WithDefaults::sensitive);
sub DATA () {0}
sub DEFAULTS () {1}
sub ACTDEFAULT () {2}
sub SEEN () {3}

sub TIEHASH {
	splice( @_, 1, 0, 'tolower');
	goto &Hash::WithDefaults::TIEHASH;
}

sub STORE {
    $_[0]->[DATA]->{lc $_[1]} = $_[2];
}

1;

__END__