File Coverage

blib/lib/Hash/AutoHash/Args.pm

Criterion	Covered	Total	%
statement	107	108	99.0
branch	28	32	87.5
condition	13	18	72.2
subroutine	33	33	100.0
pod			n/a
total	181	191	94.7

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

#################################################################################
#
# Author:  Nat Goodman
# Created: 09-03-05
# $Id:
#
# Simplifies processing of keyward argument lists.
# Replaces Class::AutoClass::Args using Class::AutoClass:Hash and tied hash to
# provide cleaner, more powerful interface.
# NOT completely compatible with Class::AutoClass::Args.
# Use Hash::AutoHash::Args::V0 if compatibility with Class::AutoClass::Args needed
#
#################################################################################
use strict;
use Carp;
use Hash::AutoHash;
use base qw(Hash::AutoHash);

our @NORMAL_EXPORT_OK=
  qw(get_args getall_args set_args fix_args fix_keyword fix_keywords is_keyword is_positional
     autoargs_get autoargs_set);
our @RENAME_EXPORT_OK=sub {s/^autohash/autoargs/; $_};
# our @EXPORT_OK=Hash::AutoHash::Args::helper->EXPORT_OK;
# our @SUBCLASS_EXPORT_OK=Hash::AutoHash::Args::helper->SUBCLASS_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::Args::helper;
our $VERSION=$Hash::AutoHash::Args::VERSION;
use strict;
use Carp;
use Scalar::Util qw(reftype);
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::Args::tie,@args;
  bless $self,$class;
}

#################################################################################
# functions from Class::AutoClass::Args
# get_args, set_args are redundant w/ autoargs_get, autoargs_set
# getall_args is trivial wrapper for %$args....
#################################################################################
sub get_args {
  my($self,@args)=@_;
  @args=@{$args[0]} if @args==1 && 'ARRAY' eq ref $args[0];
  @args=fix_keyword(@args);
  my @results=map {$self->{$_}} @args;
# NG 09-03-12: line below is ancient bug. see POD. scary it wasn't caught sooner
#   wantarray? @results: $results[0];
  wantarray? @results: \@results;
}
sub autoargs_get { get_args(@_); } # do it this way so defined at compile-time
# *autoargs_get=\&get_args;        # NOT this way!

sub getall_args {
  my $self = shift;
  wantarray? %$self: {%$self};
}
sub set_args {
  my $self=shift;
 if (@_==2 && 'ARRAY' eq ref $_[0] && 'ARRAY' eq ref $_[1]) { # separate arrays form
   my($keys,$values)=@_;
   my @keys=fix_keywords(@$keys);
   my @values=@$values;
   for (my $i=0; $i<@keys; $i++) {
     my($key,$value)=($keys[$i],$values[$i]);
     $self->{$key}=$value;
   }} else {
     my $args=fix_args(@_);
     while(my($key,$value)=each %$args) {
       $self->$key($value);
     }}
  $self;
}
sub autoargs_set { set_args(@_); } # do it this way so defined at compile-time
# *autoargs_set=\&set_args;        # NOT this way!

sub fix_args {
  no warnings;
  my(@args)=@_;
  @args=@{$args[0]} if @args==1 && 'ARRAY' eq ref $args[0];
  @args=%{$args[0]} if @args==1 && 'HASH' eq reftype $args[0];
  confess("Malformed keyword argument list (odd number of elements): @args") if @args%2;
  my $args={};
  while(@args) {
    my($keyword,$value)=(fix_keyword(shift @args),shift @args);
    $args->{$keyword}=$value,next unless exists $args->{$keyword};
    my $old=$args->{$keyword};
    # NG 09-12-31: breaks if $old is object.
    # $args->{$keyword}=[$old,$value],next unless ref $old; # grow scalar slot into ARRAY
    $args->{$keyword}=[$old,$value],next unless 'ARRAY' eq ref $old; # grow scalar slot into ARRAY
    push(@$old,$value);					  # else add new value to ARRAY slot
  }
  $args;
}
sub fix_keyword {
  my @keywords=@_;		# copies input, so update-in-place doesn't munge it
  for my $keyword (@keywords) {
    next unless defined $keyword;
    $keyword=~s/^-*(.*)$/\L$1/ unless ref $keyword; # updates in place
  }
  wantarray? @keywords: $keywords[0];
}
sub fix_keywords {fix_keyword(@_);}
sub is_keyword {!(@_%2) && $_[0]=~/^-/;}
sub is_positional {@_%2 || $_[0]!~/^-/;}

#################################################################################
# Tied hash which provides the core capabilities of Hash::AutoHash::Args
#################################################################################
package Hash::AutoHash::Args::tie;
our $VERSION=$Hash::AutoHash::Args::VERSION;
use strict;
use Carp;
use Tie::Hash;
our @ISA=qw(Tie::StdHash);
*fix_args=\&Hash::AutoHash::Args::helper::fix_args;
*fix_keyword=\&Hash::AutoHash::Args::helper::fix_keyword;

sub TIEHASH {
  my($class,@args)=@_;
  $class=(ref $class)||$class;
  bless Hash::AutoHash::Args::helper::fix_args(@args), $class;
}
# following code adapted from Tie::StdHash
# sub TIEHASH  { bless {}, $_[0] }
# sub STORE    { $_[0]->{fix_keyword($_[1])} = $_[2] }
sub STORE    {
  my $self=shift;
  my $keyword=fix_keyword(shift);
  my $value=@_==1? $_[0]: [@_];
  $self->{$keyword}=$value;
}
sub FETCH    {
  my $self=shift;
  my $keyword=fix_keyword(shift);
  # non-existent arg should return nothing. not undef! this works when accessing the
  #  object directly or using autoloaded methods from the main class. when accessing
  #  via the tied hash interface, Perl converts the result to undef anyway :(
  return unless exists $self->{$keyword};
  return $self->{$keyword};
}
sub FIRSTKEY { my $a = scalar keys %{$_[0]}; each %{$_[0]} }
sub NEXTKEY  { each %{$_[0]} }
sub EXISTS   { exists $_[0]->{fix_keyword($_[1])} }
sub DELETE   { delete $_[0]->{fix_keyword($_[1])} }
sub CLEAR    { %{$_[0]} = () }
sub SCALAR   { scalar %{$_[0]} }

1;

__END__