File Coverage

blib/lib/Hash/AutoHash/MultiValued.pm

Criterion	Covered	Total	%
statement	99	99	100.0
branch	33	38	86.8
condition	6	6	100.0
subroutine	21	21	100.0
pod			n/a
total	159	164	96.9

package Hash::AutoHash::MultiValued;
our $VERSION='1.17_01';
$VERSION=eval $VERSION;		# I think this is the accepted idiom..

#################################################################################
#
# Author:  Nat Goodman
# Created: 09-03-05
# $Id:
#
# AutoHash with multivalued elements
# Inspired by Tie::Hash::Multivalue
#
#################################################################################
use strict;
use Carp;
use Hash::AutoHash;
use base qw(Hash::AutoHash);

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

# sub new {
#   my $class_or_self=@_>0 && shift;
#   # send to parent if called as object method. will access hash slot via AUTOLOAD
#   return $class_or_self->SUPER::new(@_) if ref $class_or_self;
#   # do regular 'new' via helper class if called as class method.
#   my $helper_class=$class_or_self.'::helper';
#   $helper_class->_new($class_or_self,@_);
# }

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

sub _new {
  my($helper_class,$class,@args)=@_;
  my $self=autohash_tie Hash::AutoHash::MultiValued::tie,@args;
  bless $self,$class;
}

#################################################################################
# Tied hash which implements Hash::AutoHash::MultiValued
#################################################################################
package Hash::AutoHash::MultiValued::tie;
our $VERSION=$Hash::AutoHash::MultiValued::VERSION;
use strict;
use Tie::Hash;
use List::MoreUtils qw(uniq);
our @ISA=qw(Tie::ExtraHash);
use constant STORAGE=>0;
use constant UNIQUE=>1;
use constant FILTER=>2;

sub TIEHASH {
  my($class,@hash)=@_;
  my $self=bless [{}],$class;
  if (@hash==1) {		# flatten if ARRAY or HASH
    my $hash=shift @hash;
    @hash=('ARRAY' eq ref $hash)? @$hash: ('HASH' eq ref $hash)? %$hash: ();
  }
  while (@hash>1) {		      # store initial values
    my($key,$value)=splice @hash,0,2; # shift 1st two elements
      $self->STORE($key,$value);
  }
  $self;
}
sub FETCH {
  my($self,$key)=@_;
  my $storage=$self->[STORAGE];
  my $values=$storage->{$key};
  wantarray? (defined $values? @$values: ()): $values;
}
sub STORE {
  my($self,$key,@new_values)=@_;
  my $storage=$self->[STORAGE];
  my $values=$storage->{$key};
  if (@new_values) {
    @new_values=@{$new_values[0]} if @new_values==1 && 'ARRAY' eq ref $new_values[0];
    if (my $unique=$self->[UNIQUE]) {
      my($a,$b);
      for $a (@new_values) {
	push(@$values,$a) unless grep {$b=$_; &$unique($a,$b)} @$values;
      }}
    else {
      push(@$values,@new_values);
    }
    $storage->{$key}=$values;
  }
  wantarray? (defined $values? @$values: ()): $values;
}
sub unique {
  my $self=shift;
  return $self->[UNIQUE] unless @_;
  my $unique=$self->[UNIQUE]=shift;
  $unique=$self->[UNIQUE]=sub {$_[0] eq $_[1]} if $unique && 'CODE' ne ref $unique;
  if ($unique) {		# apply to existing values
    my $storage=$self->[STORAGE];
    my @values=grep {defined $_} values %$storage;
    for my $values (@values) {
      next unless @$values;
      # leave 1st value in @$values. put rest in @new_values
      my @new_values=splice(@$values,1);
      my($a,$b);
      for $a (@new_values) {
	push(@$values,$a) unless grep {$b=$_; &$unique($a,$b)} @$values;
      }}
  }
  $unique;
}
sub filter {
  my $self=shift;
  my $filter=@_? $self->[FILTER]=shift: $self->[FILTER];
  if ($filter) {		# appy filter to existing values
    $filter=$self->[FILTER]=\&uniq unless 'CODE' eq ref $filter;
    my $storage=$self->[STORAGE];
    my @values=grep {defined $_} values %$storage;
    map {@$_=&$filter(@$_)} @values; # updates each list in-place
  }
  $filter;
}

1;
__END__