File Coverage

blib/lib/Hash/AutoHash/Record.pm

Criterion	Covered	Total	%
statement	204	204	100.0
branch	81	86	94.1
condition	16	18	88.8
subroutine	39	39	100.0
pod			n/a
total	340	347	97.9

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

#################################################################################
#
# Author:  Nat Goodman
# Created: 09-03-05
# $Id:
#
# Flat and hierarchical record structures of the type encountered in Data::Pipeline
#
#################################################################################
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;

#################################################################################
# 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::Record::helper;
our $VERSION=$Hash::AutoHash::Record::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::Record::tie,@args;
  bless $self,$class;
}
# Override autohash_clear to allow clearing of specific keys
sub autohash_clear {
  my $record=shift;
  tied(%$record)->CLEAR(@_);
}

#################################################################################
# Tied hash which implements Hash::AutoHash::Record
#################################################################################
package Hash::AutoHash::Record::tie;
our $VERSION=$Hash::AutoHash::Record::VERSION;
use strict;
use Carp;
use Tie::Hash;
use Scalar::Util qw(reftype);
use List::MoreUtils qw(uniq);
use Storable qw(dclone);
use Hash::AutoHash qw(autohash_alias);
use Hash::AutoHash::AVPairsSingle;
use Hash::AutoHash::AVPairsMulti;
our @ISA=qw(Tie::ExtraHash);

my $i=0;
use constant STORAGE=>$i++;
use constant DEFAULTS=>$i++;
use constant DEFAULT_TYPE_SCALAR=>$i++;
use constant DEFAULT_TYPE_ARRAY=>$i++;
use constant DEFAULT_TYPE_HASH=>$i++;
use constant UNIQUE=>$i++;
use constant FILTER=>$i++;
# use constant FIELDS=>$i++;
# use constant TYPES=>$i++;

# # undef means no type conversion
# our $default_type_scalar;	# no type conversion
# our $default_type_array;	# no type conversion
# our $default_type_hash='Hash::AutoHash';
# our $default_type_refhash='Hash::AutoHash::AVPairsMulti';

sub TIEHASH {
  my($class,@hash)=@_;
  my $self=bless [],$class;
  # use initial values (possibly flattened) as defaults
  my $defaults=$self->defaults(_flatten(@hash));
  $self->[STORAGE]=$defaults? dclone($defaults): {};
  $self;
}
sub FETCH {
  my($self,$key)=@_;
  my $storage=$self->[STORAGE];
  my $value=$storage->{$key};
  if (wantarray) {
# NG 09-10-12: line below was holdover from MultiValued.  Not correct here
#    return () unless defined $value;
    return @$value if 'ARRAY' eq reftype($value);
    return %$value if 'HASH' eq reftype($value);
    return ($value);
  }
  $value;
}
# FUTURE possibility: check whether hash locked & key exists

sub STORE {
  my($self,$key,@values)=@_;
  my $storage=$self->[STORAGE];
  $self->_store($storage,$key,@values);
  $self->FETCH($key);
}
sub CLEAR {
  my($self,@keys)=@_;
  my $defaults=$self->defaults;
  unless (@keys) {
    $self->[STORAGE]=$defaults? dclone($defaults): {}
  } else {				# clear specific keys
    my $storage=$self->[STORAGE];
    my $defaults=$self->[DEFAULTS];
    for my $key (@keys) {
      my $default=$defaults->{$key};
      my $new=$self->_convert_initial_value($default);
      $storage->{$key}=$default;
    }}
  my $unique=$self->unique;
  $self->_unique($unique) if $unique;
}
*clear=\&CLEAR;

# default values.
# can be set from initial values suppled to TIEHASH, or explicitly
sub defaults {
  my $self=shift;
  my $defaults;
  if (@_) {			# set new value
    my @hash=(@_==1 && 'ARRAY' eq ref $_[0])? @{$_[0]}: (@_==1 && 'HASH' eq ref $_[0])? %{$_[0]}:
      @_;
    $defaults={};
    while (@hash>1) {		        # store initial values
      my($key,$value)=splice @hash,0,2; # shift 1st two elements
      $self->_store($defaults,$key,$value);
    }
    $self->[DEFAULTS]=$defaults; # set object attribute
  } else {			 # get defaults from object
    $defaults=$self->[DEFAULTS];
  }
  wantarray? %{$defaults || {}}: $defaults;
}

# forcibly assign value or set to undef
sub force {
  my($self,$key)=splice @_,0,2;	# shift 1st 2 elements
  my $storage=$self->[STORAGE];
  $storage->{$key}=undef;	# once field is undef, _store can do the rest
  $self->_store($storage,$key,@_) if @_;
  $self->FETCH($key);
}

# code adapted from Hash::AutoHash::MultiValued
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;
  $self->_unique($unique) if $unique;
  $unique;
}
sub _unique {
  my($self,$unique)=@_;
  my $storage=$self->[STORAGE];
  my @values=grep {defined $_ && 'ARRAY' eq reftype($_)} 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;
    }}
}
# code adapted from Hash::AutoHash::MultiValued
sub filter {
  my $self=shift;
  my $filter=@_? $self->[FILTER]=shift: $self->[FILTER];
  if ($filter) {		# apply to existing values -- ARRAYs only
    $filter=$self->[FILTER]=\&uniq unless 'CODE' eq ref $filter;
    my $storage=$self->[STORAGE];
    my @values=grep {defined $_ && 'ARRAY' eq reftype($_)} values %$storage;
    map {@$_=&$filter(@$_)} @values; # updates each list in-place
  }
  $filter;
}

# sub _default_type_scalar  {shift->_default_type('scalar',@_);}
# sub _default_type_array   {shift->_default_type('array',@_);}
# sub _default_type_hash    {shift->_default_type('hash',@_);}
# sub _default_type_refhash {shift->_default_type('refhash',@_);}
# sub _default_type {
#   my($self,$type)=splice @_,0,2;
#   my $default;
#   if (@_) {			# set new value in object
#       $default=$self->[uc "default_type_$type"]=$_[0];
#     } else {			# get defaults from object if possible, else from class
#       $default=$self->[uc "default_type_$type"];
#       unless (defined $default) { # now look in class
# 	my $class=ref $self;
# 	no strict 'refs';
# 	my $class_var=$class."::default_type_$type";
# 	$default=${$class_var};
#       }}
#   $default;
# }
# sub _convert_initial_value {
#   my($self,$value)=@_;
#   my $type=
#     (!ref $value)? 'scalar':
#       ('ARRAY' eq ref $value)? 'array':
# 	('HASH' eq ref $value)? 'hash':
# 	  ('REF' eq ref $value && 'HASH' eq ref $$value)? 'refhash':
# 	  undef;
#   my $class=$self->_default_type($type) if $type;
#   $value=$class? new $class $value: $value;
#   $value;
# }
sub _convert_initial_value {
  my($self,$value)=@_;
  if ('HASH' eq ref $value) {
    # attribute-single-value pair if no refs
    # else attribute-multi-value pair if only refs are ARRAY
    # else use as is
    my @values=values %$value;
    # CAUTION: doing grep below w/o map seems to stringify refs to things like ARRAY(0x1163510)
    my @refs=grep {$_} map {ref $_} @values;
    if (!@refs) {
      $value=new Hash::AutoHash::AVPairsSingle $value;
    } elsif (!grep !/^ARRAY$/,@refs) {
      $value=new Hash::AutoHash::AVPairsMulti $value;
    }
  } elsif ('REF' eq ref $value && 'HASH' eq ref $$value) {
    my @values=values %$$value;
    # CAUTION: doing grep below w/o map seems to stringify refs to things like ARRAY(0x1163510)
    my @refs=grep {$_} map {ref $_} @values;
    if (!grep !/^ARRAY$/,@refs) {
      $value=new Hash::AutoHash::AVPairsMulti $$value;
    }}
  $value;
}

# logic: check type of old value and new value
# old undef. anything goes. new value replaces old w/ initial value conversion
# old scalar && new scalar. new value replaces old
# old ARRAY && new any value. multi-valued field. new pushed onto old & possibly uniqued
# old Hash::AutoHash. new must be HASH or ARRAY or list of key=>value pairs.
#  new elements set in old using method notation
# old anything else.  new value replaces old

sub _store {
  my($self,$storage,$key,@new)=@_;
  return unless @new;
  my $old=$storage->{$key};
  if (!defined $old) {	               # old undef. anything goes. new replaces old.
    if (@new==1 && 'ARRAY' eq ref $new[0]) { # new multi-valued field
      $storage->{$key}=[];	       # initialize to empty ARRAY. recursion will do the rest
    } else {
      my $new1=shift @new;
      $new1=$self->_convert_initial_value($new1);
      $storage->{$key}=$new1;
    }
    $self->_store($storage,$key,@new); # recurse
  } elsif (!ref $old) {	               # old scalar. new replaces old. must be scalar
    my $new=shift @new;
    $new=$self->_convert_initial_value($new);
    confess "Trying to store multiple values in single-valued field $key" if @new;
    confess "Trying to store reference in single-valued field $key" if ref $new;
    $storage->{$key}=$new;
  } elsif ('ARRAY' eq ref $old) {       # old ARRAY. push new onto old. must be scalar
#    $self->_store_multi($old,@new);
    # code adapted from Hash::AutoHash::MultiValued
    @new=@{$new[0]} if @new==1 && 'ARRAY' eq ref $new[0];
    confess "Trying to store reference in multi-valued field $key" if grep {ref($_)} @new;
    if (my $unique=$self->unique) {
      my($a,$b);
      for $a (@new) {
	push(@$old,$a) unless grep {$b=$_; &$unique($a,$b)} @$old;
      }} else {
	push(@$old,@new);
      }
  } elsif (UNIVERSAL::isa($old,'Hash::AutoHash')) { # old Hash::AutoHash
    @new=_flatten(@new);
    while (@new>1) {		        # store initial values
      my($key,$value)=splice @new,0,2;	# shift 1st two elements
      $old->$key($value);		# store using hash notation
    }
  } else {				# old anything else.
    $storage->{$key}=$new[0];		# new replaces old
  }
}
# # store into multi-valued field, or store multi-value into undef field
# sub _store_multi {
#   my($self,$old,@new)=@_;
#   # code adapted from Hash::AutoHash::MultiValued
#   @new=@{$new[0]} if @new==1 && 'ARRAY' eq ref $new[0];
#   if (my $unique=$self->unique) {
#     my($a,$b);
#     for $a (@new) {
#       push(@$old,$a) unless grep {$b=$_; &$unique($a,$b)} @$old;
#     }} else {
#       push(@$old,@new);
#     }
# }
sub _flatten {
  if (@_==1) {
    return ('ARRAY' eq ref $_[0])? @{$_[0]}: ('HASH' eq ref $_[0])? %{$_[0]}: @_;
  }
  @_;
}

1;

__END__