File Coverage

blib/lib/Class/AutoClass/Args.pm

Criterion	Covered	Total	%
statement	56	63	88.8
branch	24	40	60.0
condition	11	18	61.1
subroutine	11	14	78.5
pod	0	8	0.0
total	102	143	71.3

package Class::AutoClass::Args;
use strict;
use Carp;

sub new {
  my($class,@args)=@_;
  $class=(ref $class)||$class;
  my $self=bless _fix_args(@args), $class;
}
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;
  wantarray? @results: $results[0];
}
sub getall_args {
  my $self = shift;
  wantarray? %$self: {%$self};
}
sub set_args {
  my($self,@args)=@_;
  my $args=_fix_args(@args);
  while(my($key,$value)=each %$args) {
    $self->$key($value);
  }
}
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]!~/^-/;}

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 ref $args[0];
  @args=%{$args[0]} if @args==1 && $args[0]=~/HASH/; # treat object like HASH
  confess("Malformed keyword argument list (odd number of elements): @args") if @args%2;
  my $args={};
  my %counts;
  while(@args) {
    my($keyword,$value)=(fix_keyword(shift @args),shift @args);
    $args->{$keyword}=$value if $counts{$keyword}==0;
    $args->{$keyword}=[$args->{$keyword},$value] if $counts{$keyword}==1;
    push(@{$args->{$keyword}},$value) if $counts{$keyword}>1;
    $counts{$keyword}++;
  }
  $args;
}
use vars qw($AUTOLOAD);
sub AUTOLOAD {
  my $self=shift;
  $AUTOLOAD=~s/^.*:://;		    # strip class qualification
  return if $AUTOLOAD eq 'DESTROY'; # the books say you should do this
  my $keyword=fix_keyword($AUTOLOAD);
  return if @_==0 && !exists $self->{$keyword};
  my $result;
  return $self->{$keyword} if @_==0;
  return $self->{$keyword}=$_[0] if @_==1;
  return $self->{$keyword}=[@_] if @_>1;
}

1;

__END__