File Coverage

blib/lib/Hash/Typed.pm

Criterion	Covered	Total	%
statement	112	112	100.0
branch	36	36	100.0
condition	17	17	100.0
subroutine	17	17	100.0
pod	0	3	0.0
total	182	185	98.3

package Hash::Typed;
use strict; use warnings; our $VERSION = '0.05';
use Carp qw/croak/; use Tie::Hash; our (@ISA);

BEGIN {
	@ISA = qw(Tie::Hash);
}

sub new {
	my ($package) = (shift);

	my $self = { };

	tie %{$self}, 'Hash::Typed', @_;

	bless $self, $package;
}

sub TIEHASH {
	my ($pkg) = shift;
	my($self) = [];
	push @{$self}, {}, [], [], 0;
	$self = bless $self, $pkg;
	if (ref $_[0]) {
		my $spec = $self->PARSE(shift);
		push @{$self}, $spec;
	}
	while (@_) {
		$self->STORE(shift, shift);
	}
	if ($self->[4] && $self->[4]->{required}) {
		if (ref $self->[4]->{required}) {
			$self->REQUIRED($self->[4]->{required});
		} else {
			$self->REQUIRED([keys %{$self->[4]->{ordered_keys}}]);
		}
	}
	return $self;
}

sub FETCH {
	my($self, $key) = (shift, shift);
	return exists( $self->[0]{$key} ) ? $self->[2][ $self->[0]{$key} ] : undef;
}

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

	if ($self->[4]) {
		my $described = $self->[4]->{keys}->{$key};

		if ($self->[4]->{strict} && !$described) {
			croak "Strict mode enabled and passed key \"${key}\" does not exist in the specification.";
		}

		$value = $described->($value)
			if ($described);
	}

	if (exists $self->[0]{$key}) {
		my($i) = $self->[0]{$key};
		$self->[1][$i] = $key;
		$self->[2][$i] = $value;
		$self->[0]{$key} = $i;
	} elsif ($self->[4] && defined $self->[4]{ordered_keys}{$key} && $self->[4]{ordered_keys}{$key} <= scalar @{$self->[1]}) {
		my $i = $self->[4]{ordered_keys}{$key};
		my $before = $self->[1]->[$i - 1];
		$i = $i == 0 ? $i : --$i if ($before && ($self->[4]{ordered_keys}{$before} || -1) >= $i);
		splice(@{$self->[1]}, $i, 0, $key);
		splice(@{$self->[2]}, $i, 0, $value);
		$self->[0]{$key} = $i;
		$self->[0]{ $self->[1][$_] }++
			for ($i+1..$#{$self->[1]});
	} else {
		push(@{$self->[1]}, $key);
		push(@{$self->[2]}, $value);
		$self->[0]{$key} = $#{$self->[1]};
	}
}

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

	if (exists $self->[0]{$key}) {
		my($i) = $self->[0]{$key};
		$self->[0]{ $self->[1][$_] }--
			for ($i+1..$#{$self->[1]});
		$self->[3]--  if ( $i == $self->[3]-1 );
		delete $self->[0]{$key};
		splice @{$self->[1]}, $i, 1;
		return (splice(@{$self->[2]}, $i, 1))[0];
	}
	return undef;
}

sub CLEAR {
	my ($self) = @_;
	push @{$self}, {}, [], [], 0;
}

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

sub FIRSTKEY {
	$_[0][3] = 0;
  	&NEXTKEY;
}

sub NEXTKEY {
	return $_[0][1][ $_[0][3]++ ] if ($_[0][3] <= $#{ $_[0][1] } );
  	return undef;
}

sub SCALAR { scalar(@{$_[0]->[1]}); }

sub PARSE {
	my ($self, $spec) = @_;
	my (%keys, %described);
	tie(%described, 'Hash::Typed');
	while (@{$spec}) {
		my ($key, $value) = (shift @{$spec}, shift @{$spec});
		if ($key eq 'keys') {
			if (ref $value eq 'ARRAY') {
				($value) = $self->PARSE($value);
				my $i = 0;
				%keys = map { $_ => $i++ } keys %{$value};
			} else {
				croak "keys spec must currently be an ARRAY";
			}
		}
		$described{$key} = $value;
	}
	$described{ordered_keys} = \%keys if scalar keys %keys;
	return \%described;
}

sub REQUIRED {
	my ($self, $keys) = @_;
	for my $key (@{$keys}) {
		if (! defined $self->[0]{$key}) {
			croak "Required key $key not set.";
		}
	}
}

1;

__END__;