File Coverage

blib/lib/Hash/MultiKey.pm

Criterion	Covered	Total	%
statement	43	43	100.0
branch	16	26	61.5
condition			n/a
subroutine	14	14	100.0
pod			n/a
total	73	83	87.9

package Hash::MultiKey;

use 5.006;
use strict;
use warnings;

use Carp;

use vars qw($VERSION);
$VERSION = '0.06';

# ---[ Implementation Overview ]----------------------------------------
#
# The first implementation of this module was based in an explicit tree.
# Right after its announcement in news:comp.lang.perl.modules Benjamin
# Goldberg suggested a radically different approach, far much simple and
# efficient. The current code is entirely based on his idea.
#
# Multi-key hashes are implemented now with a plain hash. There is no
# nesting involved.
#
# Lists of keys are converted to strings with pack():
#
#     $key = pack 'N' . ('w/a*' x @$keys), scalar(@$keys), @$keys;
#
# and that $key is what's used in the underlying hash. The first chunk
# stores the number of keys, to be used afterwards when we decode it.
# Then, pairs length_of_key/key follow.
#
# Conversely, to retrieve the original list of keys from a real key we
# use unpack():
#
#     $n = unpack 'N', $key;
#     [ unpack 'x4' . ('w/a*' x $n), $key ];
#
# Iteration is delegated to the iterator of the very hash.
#
# Knowing that the following code is crystal clear, so comments have
# been removed altogether.
#
# ----------------------------------------------------------------------


sub TIEHASH {
    bless {}, shift;
}

sub CLEAR {
    %{ shift() } = ();
}

sub FETCH {
    my ($self, $keys) = @_;
    $keys = [$keys eq '' ? ('') : split /$;/, $keys, -1] unless ref $keys eq 'ARRAY';
    @$keys or croak "Empty multi-key\n";
    $self->{pack 'N' . ('w/a*' x @$keys), scalar(@$keys), @$keys};
}

sub STORE {
    my ($self, $keys, $value) = @_;
    $keys = [$keys eq '' ? ('') : split /$;/, $keys, -1] unless ref $keys eq 'ARRAY';
    @$keys or croak "Empty multi-key\n";
    $self->{pack 'N' . ('w/a*' x @$keys), scalar(@$keys), @$keys} = $value;
}

sub DELETE {
    my ($self, $keys) = @_;
    $keys = [$keys eq '' ? ('') : split /$;/, $keys, -1] unless ref $keys eq 'ARRAY';
    @$keys or croak "Empty multi-key\n";
    delete $self->{pack 'N' . ('w/a*' x @$keys), scalar(@$keys), @$keys};
}

sub EXISTS {
    my ($self, $keys) = @_;
    $keys = [$keys eq '' ? ('') : split /$;/, $keys, -1] unless ref $keys eq 'ARRAY';
    @$keys or croak "Empty multi-key\n";
    exists $self->{pack 'N' . ('w/a*' x @$keys), scalar(@$keys), @$keys};
}

sub FIRSTKEY {
    my ($self) = @_;
    keys %$self; # reset iterator
    $self->NEXTKEY;
}

sub NEXTKEY {
    my ($self) = @_;
    defined(my $key = each %$self) or return;
    my $n = unpack 'N', $key;
    [ unpack 'x4' . ('w/a*' x $n), $key ];
}

sub SCALAR {
    my ($self) = @_;
    scalar %$self;
}

1;


__END__