File Coverage

blib/lib/Tie/Hash/MultiValueOrdered.pm

Criterion	Covered	Total	%
statement	60	105	57.1
branch	6	14	42.8
condition	1	2	50.0
subroutine	18	29	62.0
pod	13	13	100.0
total	98	163	60.1

use 5.008;
use strict;
use warnings;

{
	package Tie::Hash::MultiValueOrdered;

	our $AUTHORITY = 'cpan:TOBYINK';
	our $VERSION   = '0.004';

	use constant {
		IDX_DATA  => 0,
		IDX_ORDER => 1,
		IDX_LAST  => 2,
		IDX_SEEN  => 3,
		IDX_MODE  => 4,
		NEXT_IDX  => 5,
	};
	use constant {
		MODE_LAST  => -1,
		MODE_FIRST => 0,
		MODE_REF   => 'ref',
		MODE_ITER  => 'iter',
	};

	sub fetch_first    { $_[0][IDX_MODE] = MODE_FIRST }
	sub fetch_last     { $_[0][IDX_MODE] = MODE_LAST }
	sub fetch_list     { $_[0][IDX_MODE] = MODE_REF }
	sub fetch_iterator { $_[0][IDX_MODE] = MODE_ITER }

	use Storable qw( dclone );
	sub TIEHASH {
		my $class = shift;
		bless [{}, [], 0, {}, -1], $class;
	}
	sub STORE {
		my ($tied, $key, $value) = @_;
		$key = "$key";
		push @{$tied->[IDX_ORDER]}, $key;
		push @{$tied->[IDX_DATA]{$key}}, $value;
	}
	sub FETCH {
		my ($tied, $key) = @_;
		my $mode = $tied->[IDX_MODE];
		if ($mode eq 'ref')
		{
			return $tied->[IDX_DATA]{$key} || [];
		}
		elsif ($mode eq 'iter')
		{
			my @values = @{ $tied->[IDX_DATA]{$key} || [] };
			return sub { shift @values };
		}
		else
		{
			return unless exists $tied->[IDX_DATA]{"$key"};
			return $tied->[IDX_DATA]{$key}[$mode];
		}
	}
	sub EXISTS {
		my ($tied, $key) = @_;
		return exists $tied->[IDX_DATA]{"$key"};
	}
	sub DELETE {
		my ($tied, $key) = @_;
		my $r = delete $tied->[IDX_DATA]{"$key"};
		return $r->[-1] if $r;
		return;
	}
	sub CLEAR {
		my $tied = shift;
		$tied->[IDX_DATA]  = {};
		$tied->[IDX_ORDER] = [];
		$tied->[IDX_LAST]  = 0;
		$tied->[IDX_SEEN]  = {};
		return;
	}
	sub FIRSTKEY {
		my $tied = shift;
		$tied->[IDX_LAST] = -1;
		$tied->[IDX_SEEN] = {};
		return $tied->NEXTKEY;
	}
	sub NEXTKEY {
		no warnings qw(uninitialized);
		my $tied = shift;
		my $i = ++$tied->[IDX_LAST];
		$i++ while $tied->[IDX_SEEN]{ $tied->[IDX_ORDER][$i] };
		$tied->[IDX_SEEN]{ $tied->[IDX_ORDER][$i] }++;
		my $key = $tied->[IDX_ORDER][$i];
		if (wantarray) {
			return (
				$tied->[IDX_ORDER][$i],
				$tied->FETCH( $tied->[IDX_ORDER][$i] ),
			);
		}
		return $tied->[IDX_ORDER][$i];
	}
	sub get {
		my ($tied, $key) = @_;
		return my @list = @{ $tied->[IDX_DATA]{"$key"} || [] };
	}
	sub pairs {
		my $tied = shift;
		my $clone = dclone( $tied->[IDX_DATA] );
		return map {
			$_, shift @{$clone->{$_}}
		} @{$tied->[IDX_ORDER]}
	}
	sub pair_refs {
		my $tied = shift;
		my $clone = dclone( $tied->[IDX_DATA] );
		return map {
			[ $_, shift @{$clone->{$_}} ]
		} @{$tied->[IDX_ORDER]}
	}
	sub all_keys {
		my $tied = shift;
		return @{$tied->[IDX_ORDER]};
	}
	sub keys {
		my $tied = shift;
		my %seen;
		return grep { not $seen{$_}++ } @{$tied->[IDX_ORDER]};
	}
	sub rr_keys {
		my $tied = shift;
		my %seen;
		return reverse grep { not $seen{$_}++ } reverse @{$tied->[IDX_ORDER]};
	}
	sub all_values {
		my $tied = shift;
		my $alt = 1;
		return grep { $alt=!$alt } $tied->pairs;
	}
	sub values {
		my $tied = shift;
		return map { $tied->[IDX_DATA]{$_}[-1] } $tied->keys;
	}
	sub rr_values {
		my $tied = shift;
		return map { $tied->[IDX_DATA]{$_}[0] } $tied->keys;
	}
}

1;


__END__