File Coverage

blib/lib/PDL/NamedArgs.pm

Criterion	Covered	Total	%
statement	28	31	90.3
branch	11	14	78.5
condition	2	3	66.6
subroutine	3	3	100.0
pod	1	1	100.0
total	45	52	86.5

package PDL::NamedArgs;

use 5.006;
#use strict;
use warnings;

require Exporter;

our @ISA = qw(Exporter);

# Items to export into callers namespace by default. Note: do not export
# names by default without a very good reason. Use EXPORT_OK instead.
# Do not simply export all your public functions/methods/constants.

# This allows declaration	use PDL::NamedArgs ':all';
# If you do not need this, moving things directly into @EXPORT or @EXPORT_OK
# will save memory.
our %EXPORT_TAGS = ( 'all' => [ qw(
	parseArgs
) ] );

our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );

our @EXPORT = qw(
	parseArgs
);
our $VERSION = '0.12';

sub parseArgs
{
   my($funcDef)=shift;
   my(%named,@unnamed,@arg_names);
   my($status,$i)=(0);

   # Build up the arg_names array and the arg_defaults hash
   for $i (split(/[ ,]+/,$funcDef))
   {
     if ($i =~ m/^([a-zA-Z]\w*)=(.*)$/)
        { push(@arg_names,lc($1)); $arg_defaults{lc($1)}=$2; }
     else
        { push(@arg_names,lc($i)); }
   }

   # Walk thru the arguments passed and separate into %named & @unnamed arguments
   while ($#_>=0)
   {
      $i=shift;
      if (!ref($i) && grep(/^$i$/i,@arg_names))    # Named argument
       {
         if (exists($named{$i}))
           { return ("Error: Argument $i multiple definitions"); }   # Whoops, somebody went overboard...
         $named{$i}=shift;
       }
     else                    # Unnamed argument
       { push @unnamed,$i; }
   }

   # Walk thru the argument names & make sure they are set, if not use the default if defined
   for $i (@arg_names)
   {
     if (exists($named{$i}))               # Argument already defined via named argument (Priority #1)
       { next; }

     # Argument is not defined
     if (@unnamed)
       { $named{$i}=shift(@unnamed); }    # Grab one of the unnamed list if available (Priority #2)
     elsif (exists($arg_defaults{$i}))
       { $named{$i}=$arg_defaults{$i}; }  # Set to the default value if defined (Priority #3)
     else
       { return ("Error: Missing $i argument"); }  # Whoops, somebody forgot something...
   }
   if (@unnamed)
     { return ("Error: Too many arguments"); }     # Whoops, somebody went overboard...

   return ($status,%named);
}

1;
__END__