File Coverage

blib/lib/Hash/AutoHash.pm

Criterion	Covered	Total	%
statement	280	286	97.9
branch	81	88	92.0
condition	16	18	88.8
subroutine	51	53	96.2
pod	1	1	100.0
total	429	446	96.1

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

#################################################################################
#
# Author:  Nat Goodman
# Created: 09-02-24
# $Id:
#
# Wrapper that provides accessor and mutator methods for hashes (real or tied)
#   Hash can be externally supplied or this object itself
#   Tying of hash can be done by application or by this class
#   Can also wrap object tied to hash
#   (actually, any object with suitable FETCH and STORE methods)
#
#################################################################################

use strict;
use Carp;
use vars qw($AUTOLOAD);
our @CONSTRUCTORS_EXPORT_OK=
  qw(autohash_new autohash_hash autohash_tie autohash_wrap autohash_wrapobj autohash_wraptie);
our @SUBCLASS_EXPORT_OK=
  qw(autohash_clear autohash_delete autohash_each autohash_exists autohash_keys autohash_values
     autohash_get autohash_set autohash_count autohash_empty autohash_notempty
     autohash_alias autohash_tied
     autohash_destroy autohash_untie);
our @EXPORT_OK=(@CONSTRUCTORS_EXPORT_OK,@SUBCLASS_EXPORT_OK);

# following are used by subclasses
our @RENAME_EXPORT_OK=();
our %RENAME_EXPORT_OK=();

# our @EXPORT_OK=qw(autohash_new autohash_tie
# 		  autohash_wraphash autohash_wraptie autohash_wrapobject
# 		  autohash2hash autohash2object
# 		  autohash_clear autohash_delete autohash_exists autohash_keys autohash_values
# 		  autohash_count autohash_empty autohash_notempty
# 		  autohash_destroy autohash_untie
# 		  autohash_get autohash_set);

sub import {
  my $class_or_self=shift;
  if (ref $class_or_self) {
    # called as object method. access hash slot via AUTOLOAD
    $AUTOLOAD='import';
    return $class_or_self->AUTOLOAD(@_);
  }
  # called as class method. do regular 'import'
  my $caller=caller;
  my $helper_class=$class_or_self.'::helper';
  $helper_class->_import($class_or_self,$caller,@_);
}
sub new {
  my $class_or_self=shift;
  if (ref $class_or_self) {
    # called as object method. access hash slot via AUTOLOAD
    $AUTOLOAD='new';
    return $class_or_self->AUTOLOAD(@_);
  }
  # called as class method. do regular 'new' via helper class
  my $helper_class=$class_or_self.'::helper';
  $helper_class->_new($class_or_self,@_);
}
# NG 12-09-02: no longer possible to use method notation for keys with same names as methods
#              inherited from UNIVERSAL. 'Cuz as of Perl 5.9.3, calling UNIVERSAL methods as
#              functions is deprecated and developers encouraged to use method form instead.
# sub can {
#   my $class_or_self=shift;
#   if (ref $class_or_self) {
#     # called as object method. access hash slot via AUTOLOAD
#     $AUTOLOAD='can';
#     return $class_or_self->AUTOLOAD(@_);
#   }
#   # called as class method. do regular 'can' via base class
#   return $class_or_self->SUPER::can(@_);
# }
# sub isa {
#   my $class_or_self=shift;
#   if (ref $class_or_self) {
#     # called as object method. access hash slot via AUTOLOAD
#     $AUTOLOAD='isa';
#     return $class_or_self->AUTOLOAD(@_);
#   }
#   # called as function or class method. do regular 'isa' via base class
#   return $class_or_self->SUPER::isa(@_);
# }
# sub DOES {			# in perl 5.10, UNIVERSAL provides this
#   my $class_or_self=shift;
#   if (ref $class_or_self) {
#     # called as object method. access hash slot via AUTOLOAD
#     $AUTOLOAD='DOES';
#     return $class_or_self->AUTOLOAD(@_);
#   }
#   # called as function or class method. do regular 'DOES' via base class
#   # illegal and will die in perls < 5.10
#   return $class_or_self->SUPER::DOES(@_);
# }
# sub VERSION {
#   my $class_or_self=shift;
#   if (ref $class_or_self) {
#     # called as object method. access hash slot via AUTOLOAD
#     $AUTOLOAD='VERSION';
#     return $class_or_self->AUTOLOAD(@_);
#   }
#   # called as function or class method. do regular 'VERSION' via base class
#   return $class_or_self->SUPER::VERSION(@_);
# }
sub DESTROY  {
  # CAUTION: do NOT shift - need $_[0] intact
  if (ref($_[0])) {
    # called as object method. inish up in helper class where namespace more complete
    my $helper_class=ref($_[0]).'::helper';
    my $helper_function=__PACKAGE__.'::helper::_destroy';
    return $helper_class->$helper_function(@_);
  }
  # called as class method. pass to base class. not sure this ever happens...
  my $class_or_self=shift;
  return $class_or_self->SUPER::DESTROY(@_);
}

#   my $self=$_[0];		# CAUTION: do NOT shift - need $_[0] intact
#   return unless ref $self;	# shouldn't happen, but...
#   if (@_==1) {			# called as destructor or accessor
#     # perlobj says that $_[0] is read-only when DESTROY called as destructor
#     local $@=undef;
#     eval { $_[0]=undef };
#     return if $@;		# eval failed, so it's destructor.
#      $_[0]=$self;		# not destructor. restore $_[0]
#   }
#   # not destructor. access hash slot via AUTOLOAD
#   shift;			# now shift $self out of @_
#   $AUTOLOAD='DESTROY';
#   $self->AUTOLOAD(@_)

sub AUTOLOAD {
  my $self=shift;
  $AUTOLOAD=~s/^.*:://;		               # strip class qualification
  # return if $AUTOLOAD eq 'DESTROY';            # the books say you should do this
  my $key=$AUTOLOAD;
  defined $key or $key='AUTOLOAD';
  $AUTOLOAD=undef;		# reset for next time
  # finish up in helper class where namespace more complete
  my $helper_function=__PACKAGE__.'::helper::_autoload';
  $self->$helper_function($key,@_);
}

#################################################################################
# helper package exists to avoid polluting Hash::AutoHash namespace with
#   subs that would mask accessor/mutator AUTOLOADs
# functions herein (except _new, _autoload) are exportable by Hash::AutoHash
#################################################################################
package Hash::AutoHash::helper;
our $VERSION=$Hash::AutoHash::VERSION;
use strict;
use Carp;
use Scalar::Util qw(blessed readonly reftype);
use List::MoreUtils qw(uniq);
use Tie::ToObject;
use vars qw(%SELF2HASH %SELF2OBJECT %SELF2EACH %CLASS2ANCESTORS %EXPORT_OK);

sub _import {
  my($helper_class,$class,$caller,@want)=@_;
  $helper_class->EXPORT_OK;	# initializes %EXPORT_OK if necessary
  no strict 'refs';
  my %caller2export=%{$class.'::EXPORT_OK'};
  #   my @export_ok=keys %caller2export;
  for my $want (@want) {
    confess("\"$want\" not exported by $class module") unless exists $caller2export{$want};
    confess("\"$want\" not defined by $class module") unless defined $caller2export{$want};
    my $caller_sym=$caller.'::'.$want;
    my $export_sym=$caller2export{$want};
    no strict 'refs';
    *{$caller_sym}=\&{$export_sym};
  }
}

# front-end to autohash_new constructor function, which in turn is front-end
#   to other constructor functions.
sub _new {
  my($helper_class,$class)=splice @_,0,2;
  my $self=autohash_new(@_);
  bless $self,$class;		# re-bless in case called via subclass
}

sub _destroy {
  my $helper_class=shift;
  # $_[0] is now original object.
  # CAUTION: do NOT shift further - need $_[0] intact
  # perlobj says that $_[0] is read-only when DESTROY called as destructor
  return if @_==1 && readonly($_[0]); # destructor. nothing to do.
  # not destructor. access hash slot via AUTOLOAD
  my $self=shift;
  my $helper_function=__PACKAGE__.'::_autoload';
  $self->$helper_function('DESTROY',@_)
}

sub _autoload {
  my($self,$key)=splice(@_,0,2);
  if (my $object=tied %$self) {	# tied hash, so invoke FETCH/STORE methods
    return @_==0? $object->FETCH($key): $object->STORE($key,@_);
  } else {			# regular hash
    return @_==0? ($self->{$key}): ($self->{$key}=$_[0]);
  }
}

# use vars qw(%CLASS2ANCESTORS);
sub _ancestors {
  my($class,$visited)=@_;
  my $ancestors=$CLASS2ANCESTORS{$class};
  defined $visited or $visited={};
  unless (defined($ancestors) || $visited->{$class}) {
    # first call, so compute it
    $ancestors=[$class];	# include self
    $visited->{$class}++;
    my @isa;
    {no strict "refs"; @isa = @{ $class . '::ISA' };}
    for my $super (@isa) {
      push(@$ancestors,_ancestors($super,$visited));
    }
    @$ancestors=uniq(@$ancestors);
    $CLASS2ANCESTORS{$class}=$ancestors
  }
  wantarray? @$ancestors: $ancestors;
}

sub EXPORT_OK {
  my $helper_class=shift;
  my($class)=$helper_class=~/^(.*)::helper$/;
  # for Hash::AutoHash::helper, @EXPORT_OK is given and function computes %EXPORT_OK
  if ($helper_class eq __PACKAGE__) { # NOTE: change this if you copy-and-paste into subclass
    no strict 'refs';
    my $export_ok_list=\@{$class.'::EXPORT_OK'};
    my $export_ok_hash=\%{$class.'::EXPORT_OK'};
    unless(%$export_ok_hash) {
      my $ancestors=$helper_class->_ancestors;
      for my $func (@$export_ok_list) {
	$export_ok_hash->{$func}=_export_sym($func,$class,$ancestors);
      }}
    return @$export_ok_list;
  }
  # for subclasses, @EXPORT_OK and %EXPORT_OK must both be computed
  my($export_ok_list,$export_ok_hash,@isa,@normal_export_ok,@rename_export_ok,%rename_export_ok);
  {
    no strict 'refs';
    $export_ok_list=\@{$class.'::EXPORT_OK'};
    # NG 12-11-29: 'defined @array' deprecated in 5.16 or so
    # return @$export_ok_list if defined @$export_ok_list;
    return @$export_ok_list if @$export_ok_list;
    $export_ok_hash=\%{$class.'::EXPORT_OK'};
    @isa=@{$helper_class.'::ISA'};
    @normal_export_ok=@{$class.'::NORMAL_EXPORT_OK'};
    @rename_export_ok=@{$class.'::RENAME_EXPORT_OK'};
    %rename_export_ok=%{$class.'::RENAME_EXPORT_OK'};
  };
  map {$_->EXPORT_OK} @isa;  # mqke sure EXPORT_OK setup in ancestors
  my $ancestors=$helper_class->_ancestors;

  for my $func (@normal_export_ok) {
    $export_ok_hash->{$func}=_export_sym($func,$class,$ancestors);
  }
  while(my($caller_func,$our_func)=each %rename_export_ok) {
    $export_ok_hash->{$caller_func}=_export_sym($our_func,$class,$ancestors);
  }
  if (@rename_export_ok) {
    my($sub,@our_funcs)=@rename_export_ok;
    my %skip;
    unless (@our_funcs) {	# rename list empty, so use default
      # start with all subclass-exportable functions from base classes
      @our_funcs=uniq
	map {UNIVERSAL::can($_,'SUBCLASS_EXPORT_OK')? $_->SUBCLASS_EXPORT_OK: ()} @isa;
      # %skip contains ones dealt with in @NORMAL_EXPORT_OK or %RENAME_EXPORT_OK
      @skip{@normal_export_ok}=(1) x @normal_export_ok;
      @skip{keys %rename_export_ok}=(1) x keys %rename_export_ok;
      # @skip{values %rename_export_ok}=(1) x values %rename_export_ok;
    }
    for my $our_func (@our_funcs) {
      local $_=$our_func;
      my $caller_func=&$sub();	# sub operates on $_
      next if $skip{$caller_func};
      $export_ok_hash->{$caller_func}=_export_sym($our_func,$class,$ancestors);
    }
  }
  @$export_ok_list=keys %$export_ok_hash;
}
sub SUBCLASS_EXPORT_OK {
  my $helper_class=shift;
  my($class)=$helper_class=~/^(.*)::helper$/;
  no strict 'refs';
  # for Hash::AutoHash::helper, @SUBCLASS_EXPORT_OK is given
  if ($helper_class eq __PACKAGE__) { # NOTE: change this if you copy-and-paste into subclass
    return @{$class.'::SUBCLASS_EXPORT_OK'};
  }
  # for subclasses, @SUBCLASS_EXPORT_OK must be computed
  my $subclass_export_ok=\@{$class.'::SUBCLASS_EXPORT_OK'};
  # NG 12-11-29: 'defined @array' deprecated in 5.16 or so
  # return @$subclass_export_ok if defined @$subclass_export_ok;
  return @$subclass_export_ok if @$subclass_export_ok;
  return @$subclass_export_ok=$helper_class->EXPORT_OK;
}

sub _export_sym {
  my($func,$class,$ancestors)=@_;
  for my $export_class (@$ancestors) { # @$ancestors includes self
    no strict 'refs';
    my $export_sym=$export_class.'::'.$func;
    return $export_sym if defined *{$export_sym}{CODE};
    # see if ancestor renames it
    my($class)=$export_class=~/^(.*)::helper$/;
    my $export_sym=${$class.'::EXPORT_OK'}{$func};
    return $export_sym if defined $export_sym;
  }
  undef;
}

#################################################################################
# constructor functions. recommended over 'new'
#################################################################################
# make real autohash
# any extra params are key=>value pairs stored in object
sub autohash_hash {
  my(@hash)=@_;
  # store params in self. can do in one step since no special semantics to worry about
  my $self=bless {@hash},'Hash::AutoHash';
  $self;
}
# tie autohash
# any extra params passed to tie
sub autohash_tie (*@) {
  my($hash_class,@hash_params)=@_;
  my $self=bless {},'Hash::AutoHash';
  tie %$self,$hash_class,@hash_params;
  $self;
}
# wrap pre-existing hash.
# any extra params are key=>value pairs passed to hash
sub autohash_wrap (\%@) {
  my($hash,@hash)=@_;
  # pass params to hash in loop in case it's tied hash with special semantics
  while (@hash>1) {
    my($key,$value)=splice @hash,0,2; # shift 1st two elements
    $hash->{$key}=$value;
  }
  my $self=bless {},'Hash::AutoHash';
  # if $hash is real, tie to 'alias', so autohash will alias hash
  if (my $object=tied(%$hash)) {
    tie %$self,'Tie::ToObject',$object;
  } else {
    tie %$self,'Hash::AutoHash::alias',$hash;
  }
  $self;
}
# wrap pre-existing tied object. (ie, object returned by tie),
# any extra params are key=>value pairs passed to object's STORE method
sub autohash_wrapobj {
  my($object,@hash)=@_;
  # pass params to hash in loop in case it's tied hash with special semantics
  while (@hash>1) {
    my($key,$value)=splice @hash,0,2; # shift 1st two elements
    $object->STORE($key,$value);
  }
  my $self=bless {},'Hash::AutoHash';
  tie %$self,'Tie::ToObject',$object;
  $self;
}
# tie and wrap hash in one step. any extra params passed to tie
# kinda silly, but oh well...
sub autohash_wraptie (\%*@) {
  my($hash,$hash_class,@hash_params)=@_;
  my $object=tie %$hash,$hash_class,@hash_params;
  my $self=bless {},'Hash::AutoHash';
  tie %$self,'Tie::ToObject',$object;
  $self;
}
# autohash_new - CAUTION: must come after other constructors because of prototypes
# front-end to other constructor functions
# cases:
# 1) 0 params - autohash_hash
# 2) >0 params - 1st param unblessed ARRAY - autohash_tie or autohash_wraptie
#     0th element scalar - autohash_tie
#     0th element HASH - autohash_wraptie
# 3) >0 params - 1st param unblessed HASH - autohash_wrap
# 4) >0 params - 1st param blessed HASH apparently not tied hash - autohash_wrap
# 5) >0 params - 1st param blessed and looks like tied hash object - autohash_wrapobj
# 6) other - autohash_hash
sub autohash_new {
  if (@_) {
    if ('ARRAY' eq ref $_[0]) {	# autohash_tie or autohash_wraptie
      my $autohash;
      my $params=shift;
      my $class_or_hash=shift @$params;
      unless (ref $class_or_hash) { # it's a class. so tie it
	$autohash=autohash_tie($class_or_hash,@$params);
      } else {			    # it's a hash. next param is class
	my $hash=$class_or_hash;
	my $class=shift @$params;
	$autohash=autohash_wraptie(%$hash,$class,@$params);
      }
      return autohash_set($autohash,@_);
    }
    if ('HASH' eq reftype($_[0]) && !_looks_wrappable($_[0])) {
      my $hash=shift;
      return autohash_wrap(%$hash,@_);
    }
    if (_looks_wrappable($_[0])) {
      return autohash_wrapobj(@_);
    }}
  # none of the above, so must be real
  autohash_hash(@_);
}

# try to decide if object tied to hash. very approximate...
# say yes if blessed and has TIEHASH method
sub _looks_wrappable {blessed($_[0]) && UNIVERSAL::can($_[0],'TIEHASH');}

#################################################################################
# following functions provide standard hash operations on Hash::AutoHash
# objects. they delegate to wrapped goodie
#################################################################################
sub autohash_clear {%{$_[0]}=()}
sub autohash_delete {
  my $self=shift;
  delete @$self{@_};
}
sub autohash_each {each %{$_[0]}}
sub autohash_exists {exists $_[0]->{$_[1]}}
sub autohash_keys {keys %{$_[0]}}
sub autohash_values {values %{$_[0]}}

#################################################################################
# convenience methods easily be built on top of keys
#################################################################################
sub autohash_count {scalar(keys %{$_[0]}) || 0}
sub autohash_empty {scalar(%{$_[0]})? undef: 1}
sub autohash_notempty {scalar(%{$_[0]})? 1: undef}

################################################################################
# alias - connect autohash to hash - can be used to do the opposite of wrap
################################################################################
sub autohash_alias (\$\%@) {
  my($autohash_ref,$hash,@hash)=@_;
  if (!defined $$autohash_ref) { # no autohash, so create alias from hash to autohash
    return $$autohash_ref=autohash_wrap(%$hash,@hash);
  } else {		         # create alias from autohash to hash
    my $autohash=$$autohash_ref;
    autohash_set($autohash,@hash);
    tie %$hash,'Hash::AutoHash::alias',$autohash;
  }
}
################################################################################
# functional access to tied object. works on aliased hash, also
################################################################################
# sub autohash_options (\[$%]) {
#   my($ref)=@_;
#   my $autohash;
#   if ('REF' eq ref $ref) {	# it's autohash (we hope :)
#     $autohash=$$ref;		# dereference to get autohash
#     my $object=tied %$autohash;
#     return undef unless $object;                            # real hash
#     return undef if 'Hash::AutoHash::alias' eq ref $object; # aliased to real
#     return $object;                                         # tied or aliased to tied
#   } elsif ('HASH' eq ref $ref) { # HASH may be tied to 'real object or 'alias'
#     my $object=tied %$ref;
#     return undef unless $object;
#     return $object unless 'Hash::AutoHash::alias' eq ref $object;
#     # hash aliased to autohash. recurse to get underlying tied object
#     $autohash=$object->[0];	          # extract autohash from alias
#     return &autohash_options(\$autohash); # use old-style call to turn off prototyping
#   }
#   undef;
# }
# sub autohash_options (\[$%]) {
#   my($ref)=@_;
#   my($autohash,$hash);
#   $autohash=$$ref if 'REF' eq ref $ref;	# it's autohash (we hope :)
#   $hash=$ref if 'HASH' eq ref $ref;
#   if ($hash) { # do hash case first. sometimes falls into autohash case
#     my $object=tied %$ref;
#     return undef unless $object;
#     return $object unless 'Hash::AutoHash::alias' eq ref $object;
#     # hash aliased to autohash. extract autohash from alias and fall into authohash case
#     $autohash=$object->[0];
#   }
#   if ($autohash) {
#     my $object=tied %$autohash;
#     return undef unless $object;                            # real hash
#     return undef if 'Hash::AutoHash::alias' eq ref $object; # aliased to real
#     return $object;                                         # tied or aliased to tied
#   }
#   undef;
# }
# sub autohash_option (\[$%]@) {
#   my($ref,$option,@params)=@_;
#   my $object=&autohash_options($ref); # use old-style call to turn off prototyping
#   return undef unless $object;
#   $object->$option(@params);
# }
sub autohash_tied (\[$%]@) {
  my $ref=shift;
  my($autohash,$hash,$tied);
  $autohash=$$ref if 'REF' eq ref $ref;	# it's autohash (we hope :)
  $hash=$ref if 'HASH' eq ref $ref;
  if ($hash) { # do hash case first. sometimes falls into autohash case
    $tied=tied %$ref;
    # hash aliased to autohash. extract autohash from alias and fall into authohash case
    $autohash=$tied->[0] if 'Hash::AutoHash::alias' eq ref $tied;
  }
  if ($autohash) {
    $tied=tied %$autohash;
    $tied=undef if 'Hash::AutoHash::alias' eq ref $tied; # aliased to real
  }
  return $tied unless @_ && $tied;
  # have tied object and there are more params. this means 'run method on tied object'
  my($method,@params)=@_;
  $tied->$method(@params);
}

#################################################################################
# get and set offer extended functionality for users of this interface.
# 'set' is the useful one. 'get' provided for symmetry
#################################################################################
# get values for one or more keys.
sub autohash_get  {
 my $self=shift;
 @$self{@_};
}
# set one or more key=>value pairs in hash
sub autohash_set {
 my $self=shift;
 if (@_==2 && 'ARRAY' eq ref $_[0] && 'ARRAY' eq ref $_[1]) { # separate arrays form
   my($keys,$values)=@_;
   for (my $i=0; $i<@$keys; $i++) {
     my($key,$value)=($keys->[$i],$values->[$i]);
     $self->{$key}=$value;
   }} else {			# key=>value form
   while (@_>1) {
     my($key,$value)=splice @_,0,2; # shift 1st two elements
     $self->{$key}=$value;
   }}
 $self;
}

#################################################################################
# destroy and untie rarely used but needed for full tied hash functionality.
# destroy nop. untie calls tied object's untie method
#################################################################################
sub autohash_destroy {}
sub autohash_untie {
  my $object=tied(%{$_[0]});
  $object->UNTIE() if $object;
}

# #################################################################################
# # this package used to 'dup' autohash to externally supplied real hash
# #   amazing that nothing in CPAN does this! I found several 'alias' packages but
# #   none could connect new variable to old one without changing the type of old
# #################################################################################
# package Hash::AutoHash::dup;
# use strict;
# use Tie::Hash;
# our @ISA=qw(Tie::ExtraHash);

# sub TIEHASH  {
#   my($class,$existing_hash)=@_;
#   bless [$existing_hash],$class;
# }
#################################################################################
# this package used to 'alias' hash to externally supplied hash
#   amazing that nothing in CPAN does this! I found several 'alias' packages but
#   none could connect new variable to old one without changing the type of old
#################################################################################
package Hash::AutoHash::alias;
our $VERSION=$Hash::AutoHash::VERSION;
use strict;
use Tie::Hash;
our @ISA=qw(Tie::ExtraHash);

sub TIEHASH  {
  my($class,$existing_autohash)=@_;
  bless [$existing_autohash],$class;
}
1;

__END__