################################################################################
# Example tied hash for testing
# Based on Tie::Hash::MultiValue from CPAN
# Lets TIEHASH accept initial values. Does not support 'unique'.
# Lets FETCH return array in array context
################################################################################
package TieMV;
use strict;
use Tie::Hash;
use Scalar::Util qw(refaddr);
our @ISA = qw(Tie::StdHash);
our %DESTROYED; # for DESTROY tests
our $TIEHASH_PARAM; # for testing TIEHASH params vs. initial values in autohash_new
sub TIEHASH {
my($class,@hash)=@_;
my $self=bless {},$class;
if (@hash==1) { # for testing TIEHASH params vs. initial values in autohash_new
$TIEHASH_PARAM=shift @hash;
} else {
while (@hash>1) {
my($key,$value)=splice @hash,0,2; # shift 1st two elements
$self->STORE($key,$value);
}}
$DESTROYED{refaddr($self)}=0; # for DESTROY tests
$self;
}
sub FETCH {
my($self,$key)=@_;
my $value=$self->{$key};
if (wantarray) {
return defined $value? @$value: ();
}
$value;
}
sub STORE {
my($self,$key,@values)=@_;
push @{$self->{$key}}, @values;
}
sub DESTROY { # for DESTROY tests
my $self=shift;
$DESTROYED{refaddr($self)}++;
}
1;