File Coverage

blib/lib/Syntax/Feature/EachOnArray.pm

Criterion	Covered	Total	%
statement	38	75	50.6
branch	1	10	10.0
condition	0	6	0.0
subroutine	13	23	56.5
pod	0	2	0.0
total	52	116	44.8

package Syntax::Feature::EachOnArray; # don't confuse dzil?
our $VERSION = '0.04'; # VERSION
# BEGIN PORTION (c) Toby Inkster
{
	package Tie::ArrayAsHash;

	use strict;
	no warnings;
	use Carp;
	use Hash::FieldHash qw(fieldhash);
	use Scalar::Util qw(reftype);

	use base qw(Exporter);
	BEGIN {
		our @EXPORT_OK = 'aeach';
		$INC{'Tie/ArrayAsHash.pm'} = __FILE__;
	};

	use constant {
		IDX_DATA  => 0,
		IDX_EACH  => 1,
		NEXT_IDX  => 2,
	};

	fieldhash our %cache;

	sub aeach (\[@%])
	{
		my $thing = shift;
		return each %$thing
			if reftype $thing eq 'HASH';
		confess "should be passed a HASH or ARRAY"
			unless reftype $thing eq 'ARRAY';

		my $thing_h = $cache{$thing} ||= do {
			tie my %h, __PACKAGE__, $thing;
			\%h
		};

		each %$thing_h;
	}

	sub TIEHASH
	{
		my ($class, $arrayref) = @_;
		bless [$arrayref, 0] => $class;
	}

	sub STORE
	{
		my ($self, $k, $v) = @_;
		$self->[IDX_DATA][$k] = $v;
	}

	sub FETCH
	{
		my ($self, $k) = @_;
		$self->[IDX_DATA][$k];
	}

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

	sub NEXTKEY
	{
		my ($self) = @_;
		my $curr = $self->[IDX_EACH]++;
		return if $curr >= @{ $self->[IDX_DATA] };
		return $curr;
	}

	sub EXISTS
	{
		my ($self, $k) = @_;
		!!($k eq $k+0
			and $k < @{ $self->[IDX_DATA] }
		);
	}

	sub DELETE
	{
		my ($self, $k) = @_;
		return pop @{ $self->[IDX_DATA] }
			if @{ $self->[IDX_DATA] } == $k + 1;
		confess "DELETE not fully implemented";
	}

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

	sub SCALAR
	{
		my ($self) = @_;
		my %tmp =
			map { $_ => $self->[IDX_DATA][$_] }
			0 .. $#{ $self->[IDX_DATA] };
		return scalar(%tmp);
	}
}
# END PORTION

package Syntax::Feature::EachOnArray;

use strict;
use warnings;
use Tie::ArrayAsHash qw(aeach);

sub install {
    my $class = shift;
    my %args = @_;

    return unless $^V lt 5.12.0;
    no strict 'refs';
    *{"$args{into}::each"} = \&aeach;
}

# XXX on uninstall, delete symbol

1;
# ABSTRACT: Emulate each(@array) on Perl < 5.12


__END__