File Coverage

lib/Tie/HashDefaults.pm

Criterion	Covered	Total	%
statement	50	61	81.9
branch	4	8	50.0
condition	1	3	33.3
subroutine	13	15	86.6
pod	0	2	0.0
total	68	89	76.4

#
# Strangely enough, the CLEAR method does not actually cause a subsequent
# FIRSTKEY to return nil.
#

package Tie::HashDefaults;

	use Carp;
	use strict;
	use vars qw( $VERSION );
	$VERSION = '0.01';


	sub TIEHASH {
		my $pkg = shift;
		my %values;
		my @defaults;

		if ( @_ == 1 && UNIVERSAL::isa($_[0],'Tie::HashDefaults') ) {
			# copy constructor
			@defaults = $_[0]->get_defaults_list;
			%values = %{ $_[0][1] };
		}
		else {
			# plain list of default sources (hashrefs)
			@defaults = map {
				is_hashref($_) or croak <
Bad arg: '$_'\n\tExpected another Tie::HashDefaults (ref), or a list of default sources (hashrefs).
EOF
				$_
			} @_;
		}

		bless( [ undef, \%values, \@defaults ], $pkg );
	}

			sub is_hashref {
				local $_ = '' . shift;
				s/.*=//;
				/^HASH\(/
			}

	sub get_defaults_list {
		my $self = shift;
		$self->_delete_iteration_hash;
		$self->[2];
	}

	sub _get_sources_list {
		my $self = shift;
		my $deflist = $self->get_defaults_list;
		( $self->[1], @$deflist )
	}

	sub _delete_iteration_hash {
		my $self = shift;
		$self->[0] = undef;
	}

	sub EXISTS {
		my( $self, $key ) = @_;
		for ( $self->_get_sources_list ) {
			exists $_->{$key} and return(1);
		}
		return(); # not found
	}

	sub FETCH {
		my( $self, $key ) = @_;
		for ( $self->_get_sources_list ) {
			exists $_->{$key} and return( $_->{$key} );
		}
		return(); # not found
	}

	sub DELETE {
		my( $self, $key ) = @_;
		$self->_delete_iteration_hash;
		delete $self->[1]{$key};
	}

	sub STORE {
		my( $self, $key, $val ) = @_;
		$self->_delete_iteration_hash;
		$self->[1]{$key} = $val;
	}

	sub CLEAR {
		my( $self ) = @_;
		$self->_delete_iteration_hash;
		%{ $self->[1] } = ();
		$self
	}

	sub FIRSTKEY {
		my( $self ) = @_;
		$self->_delete_iteration_hash;
		my %iter;
		for ( reverse $self->_get_sources_list ) {
			while ( my($k,$v) = each %$_ ) {
				$iter{$k} = $v;
			}
		}
		$self->[0] = \%iter;
		each %{$self->[0]}
	}

	sub NEXTKEY {
		my( $self ) = @_;
		each %{$self->[0]}
	}

1;

__END__