The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
package Data::Babel::HAH_MultiValued;
#################################################################################
#
# Author:  Nat Goodman
# Created: 12-09-21
# $Id: 
#
# Specialized Hash::AutoHash::MultiValued that allows undef values
#
#################################################################################
use strict;
use Carp;
use base qw(Hash::AutoHash::MultiValued);

our @NORMAL_EXPORT_OK=@Hash::AutoHash::MultiValued::EXPORT_OK;
my $helper_class=__PACKAGE__.'::helper';
our @EXPORT_OK=$helper_class->EXPORT_OK;
our @SUBCLASS_EXPORT_OK=$helper_class->SUBCLASS_EXPORT_OK;

#################################################################################
# helper package exists to avoid polluting main package namespace with
#   subs that would mask accessor/mutator AUTOLOADs
# functions herein (except _new) are exportable by Hash::AutoHash::Args
#################################################################################
package Data::Babel::HAH_MultiValued::helper;
use strict;
use Carp;
BEGIN {
  our @ISA=qw(Hash::AutoHash::MultiValued::helper);
}
use Hash::AutoHash::MultiValued qw(autohash_tie);

sub _new {
  my($helper_class,$class,@args)=@_;
  my $self=autohash_tie Data::Babel::HAH_MultiValued::tie,@args;
  bless $self,$class;
}

#################################################################################
# Tied hash which implements Data::Babel::HAH_MultiValued
#################################################################################
package Data::Babel::HAH_MultiValued::tie;
use strict;
our @ISA=qw(Hash::AutoHash::MultiValued::tie);
use constant STORAGE=>0;
use constant UNIQUE=>1;
use constant FILTER=>2;

sub FETCH {
  my($self,$key)=@_;
  my $storage=$self->[STORAGE];
  if (defined $storage->{$key}) {
    my $values=$storage->{$key};
    return wantarray? @$values: $values;
  } 
  return wantarray? (): undef;
}
sub STORE {
  my($self,$key,@new_values)=@_;
  my $storage=$self->[STORAGE];
  if (@new_values==1 && !defined $new_values[0] && !exists $storage->{$key}) { 
    # special case - store undef
    $storage->{$key}=undef;
    return wantarray? (): undef;
  }
  if (exists $storage->{$key} && !defined $storage->{$key}) {
    # special case - existing value is undef
    unshift(@new_values,undef);
  }
  # regular MultiValued STORE
  $self->SUPER::STORE($key,@new_values);
}

1;