File Coverage

blib/lib/Class/PseudoHash.pm

Criterion	Covered	Total	%
statement	56	69	81.1
branch	4	16	25.0
condition			n/a
subroutine	19	25	76.0
pod	0	1	0.0
total	79	111	71.1

package Class::PseudoHash;
$Class::PseudoHash::VERSION = '1.10';

use 5.005;
use strict;
use vars qw/$FixedKeys $Obj $Proxy/;
use constant NO_SUCH_FIELD => 'No such pseudohash field "%s"';
use constant NO_SUCH_INDEX => 'Bad index while coercing array into hash';
use overload (
    '%{}'  => sub { $$Obj = $_[0]; return $Proxy },
    '""'   => sub { overload::AddrRef($_[0]) },
    '0+'   => sub {
	my $str = overload::AddrRef($_[0]);
	hex(substr($str, index($str, '(') + 1, -1));
    },
    'bool' => sub { 1 },
    'cmp'  => sub { "$_[0]" cmp "$_[1]" },
    '<=>'  => sub { "$_[0]" cmp "$_[1]" }, # for completeness' sake
    'fallback' => 1,
);

$FixedKeys = 1;

sub import {
    no strict 'refs';

    my $class = shift;
    tie %{$Proxy}, $class;

    *{'fields::phash'} = sub {
	$class->new(@_);
    } unless defined $_[0];
}

sub new {
    my $class = shift;
    my @array = undef;

    if (UNIVERSAL::isa($_[0], 'ARRAY')) {
	foreach my $k (@{$_[0]}) {
	    $array[$array[0]{$k} = @array] = $_[1][$#array];
	}
    }
    else {
	while (my ($k, $v) = splice(@_, 0, 2)) {
	    $array[$array[0]{$k} = @array] = $v;
	}
    }

    bless(\@array, $class);
}

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

    $self = $$$self;

    return $self->[
	$self->[0]{$key} >= 1
	    ? $self->[0]{$key} :
	defined($self->[0]{$key})
	    ? _croak(NO_SUCH_INDEX) :
	$FixedKeys
	    ? _croak(NO_SUCH_FIELD, $key) :
	@$self
    ];
}

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

    $self = $$$self;

    return $self->[
	$self->[0]{$key} >= 1
	    ? $self->[0]{$key} :
	defined($self->[0]{$key})
	    ? _croak(NO_SUCH_INDEX) :
	$FixedKeys
	    ? _croak(NO_SUCH_FIELD, $key) :
	@$self
    ] = $value;
}

sub _croak {
    require Carp;
    Carp::croak(sprintf(shift, @_));
}

sub TIEHASH {
    bless \$Obj => shift;
}

sub FIRSTKEY {
    scalar keys %{$${$_[0]}->[0]};
    each %{$${$_[0]}->[0]};
}

sub NEXTKEY {
    each %{$${$_[0]}->[0]};
}

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

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

sub CLEAR {
    @{$${$_[0]}} = ();
}

1;

__END__