File Coverage

blib/lib/Params/Smart.pm

Criterion	Covered	Total	%
statement	160	182	87.9
branch	63	90	70.0
condition	47	62	75.8
subroutine	13	13	100.0
pod	0	6	0.0
total	283	353	80.1

package Params::Smart;

use 5.006;
use strict;
use warnings; # ::register __PACKAGE__;

use Carp;
use Regexp::Common qw( delimited );

require Exporter;

our @ISA         = qw( Exporter );
our @EXPORT      = qw( Params );
our @EXPORT_OK   = qw( Params ParamsNC );
our %EXPORT_TAGS = ( all => \@EXPORT_OK );

our $VERSION = '0.08';

sub parse_param {
  my $self  = shift;
  my $param = shift;

  local ($_);
  if (ref($param) eq "HASH") {
    # we only want to pass supported parameters
    my $info = {
      _parsed => 0,
    };
    foreach (qw(
         name type default required name_only slurp
         callback comment needs
     )) {
      $info->{$_} = $param->{$_};
    }
    return $info;
  } elsif (!ref($param)) {
    $param =~ /^([\?\+\*]+)?([\@\$\%\&])?([\w\|]+)(\=.+)?/;
    my $mod  = $1 || "";
    my $type = $2;
    my $name = $3;
    my $def  = substr($4,1) if (defined $4);

    if ((defined $def) &&
	($def =~ /$RE{quoted}{-keep}/)) {
      $def = $3;
    }

    unless (defined $name) {
      croak "malformed parameter $param";
    }
    if ($name =~ /^\_\w+/) {
      croak "parameter $name cannot begin with an underscore";
    }

    if (exists $self->{names}->{$name}) {
      croak "parameter $name already specified";
    }
    else {
      my $info = {
        name      => $name,
        type      => $type,
        default   => $def,
        required  => (($mod !~ /\?/) || 0),
        name_only => (($mod =~ /\+/) || 0),
	slurp     => (($mod =~ /\*/) || 0),
        callback  => undef, # sub { return $_[2]; },
        comment   => $name,
        needs     => undef,
        _parsed   => 1,
      };
      return $info;
    }
  } else {
    croak "invalid parameter";
  }
  return;
}

sub set_param {
  my $self = shift;
  my $info = shift;
  croak "invalid parameter" unless (ref($info) eq "HASH");

  # TODO - name_only should be set if this is dynamic

  $self->{dynamic}   ||= ($self->{lock});
  $info->{name_only} ||= ($self->{dynamic});

  my @names = split /\|/, $info->{name};
  $info->{name} = undef;

  do {
    my $name = shift @names;
    $info->{name} = $name, unless (defined $info->{name});
    if (exists $self->{names}->{$name}) {
      $self->{names}->{$name} = $info;
    }
    else {
      my $index = scalar(@{$self->{order}});
      unless ($info->{name_only}) {
        $info->{_index} = $index;
        $self->{order}->[$index] = $name;
      }
      $self->{names}->{$name} = $info;
    }
    if (@names) {
      $info->{name_only} ||= 1;
      $info->{required}    = 0;
      delete $info->{default};
    }
  } while (@names);
  return $info;
}

sub new {
  my $class = shift;
  my $self  = {
    names   => { },
    order   => [ ],
    lock    => 0,
    dynamic => 0,
  };
  bless $self, $class;

  my $index = 0;
  my $last;
 SLURP: while (my $param = shift) {

    my $info = $self->parse_param($param);
    if ($info) {
      if ($info->{slurp}) {
	croak "no parameters can follow a slurp" if (@_);
      }
      if ($last && $info->{required} && (!$last->{required})) {
	croak "a required parameter cannot follow an optional parameter";
      }
      if ($info->{name_only} && $info->{slurp}) {
	croak "a parameter cannot be named_only and a slurp";
      }
      if ($last && ($info->{_parsed} != $last->{_parsed})) {
        croak "cannot mix parsed and non-parsed parameters";
      }
      $self->set_param($info);
      $last = $info;
    }
    else {
      croak "unknown error";
    }
    $index++;
  }

  $self->{lock} = 1;
  return $self;
}

# We have the exported Params() function rather than requiring calls
# to Params::Smart->new() so that the code looks a lot cleaner.  It's
# also a wrapper for a home-grown memoization function. (We cannot use
# Memoize because callbacks become problematic.)

my %Memoization = ( );

sub Params {
  my $key = join $;, map { $_||""} (caller);
  return  $Memoization{$key} ||= __PACKAGE__->new(@_);
}

sub ParamsNC {
  return __PACKAGE__->new(@_);
}

# Note: usage does not display aliases, nor named_only parameters

sub _usage {
  my $self  = shift;
  my $error = shift;
  my $named = shift || 0;

  local($_);

  my $caller = (caller(2))[3] || "";

  my $usage = $error . ";\nusage: $caller(";

  # TODO - handle named parameters etc.

  $usage .=
      join(", ", map {
        my $name = $_;
        $name = "?$name", unless ($self->{names}->{$name}->{required});
        $name = "*$name", if ($self->{names}->{$name}->{slurp});
        $name;
      } @{$self->{order}}) . ") ";


  croak $usage;
}

# The callback is expected to coerce the data or return an error

sub _run_callback {
  my $self = $_[0];
  my $name = $_[1];
  my $callback = $_[0]->{names}->{$name}->{callback};
  if (ref($callback) eq "CODE") {
    return &{$callback}(@_);
  }
  else {
    croak "expected code reference for callback";
  }
}

sub args {
  my $self = shift;

  # TODO - return a reference to $self in the values

  my %vals = ( );

  # $vals{_args} = [ @_ ];

  my $named = !(@_ % 2);

  # For even number positional parameter with undef in them.
  for (my $i=0; ($named && ($i < @_)); $i += 2) {
    if (!defined $_[$i]) { $named = 0 }
  }

  if ($named) {
    my %unknown = ( );
    my $i = 0;
    while ($named && ($i < @_)) {
      my $n = $_[$i];
      $n = substr($n,1) if ($n =~ /^\-/);
      if (exists $self->{names}->{$n}) {
        my $truename = $self->{names}->{$n}->{name};
	$vals{$truename} = $_[$i+1];
        if ($self->{names}->{$truename}->{callback}) {
	  $@ = undef;
	  eval {
	    $vals{$truename} =
	      $self->_run_callback($truename, $vals{$truename}, \%vals);
	  };
	  $self->_usage($@,$named) if ($@);
	}
      } else {
	$unknown{$n} = $i;
      }
      $i += 2;
    }

    # As long as there are unknown keys and dynamically-added
    # parameters, we'll keep re-checking.

    while ($self->{dynamic}) {
      $self->{dynamic} = 0;
      if ($named && (keys %unknown)) {
        foreach my $n (keys %unknown) {
	  if (exists $self->{names}->{$n}) {
            my $truename = $self->{names}->{$n}->{name};
	    $vals{$truename} = $_[$unknown{$n}+1];
	    if ($self->{names}->{$truename}->{callback}) {
	      $@ = undef;
	      eval {
		$vals{$truename} =
		  $self->_run_callback($truename, $vals{$truename}, \%vals);
	      };
	      $self->_usage($@,$named) if ($@);
	    }
	    delete $unknown{$n};
	  }
        }
      }
    }

    if ($named && (keys %unknown) && (keys %vals)) {
      $self->_usage("unrecognized parameters: " .
	join(" ", map { "\"$_\"" } keys %unknown), $named);
    }
    elsif ($named && (keys %unknown)) {
      $named = 0;
      %vals = ( );
    }
  }

  unless ($named) {
    my $i = 0;
    while ($i < @_) {
      my $n = $self->{order}->[$i];
      unless (defined $n) {
	$self->_usage("too many arguments",$named);
      }
      my $truename = $self->{names}->{$n}->{name};
      if ($self->{names}->{$truename}->{slurp}) {
	$vals{$truename} = [ @_[$i..$#_] ];
	$i = $#_; # we don't want to use 'last'
      } else {
	$vals{$truename} = $_[$i];
      }
      if ($self->{names}->{$truename}->{callback}) {
	$@ = undef;
	eval {
	  $vals{$truename} =
	    $self->_run_callback($truename, $vals{$truename}, \%vals);
	};
	$self->_usage($@,$named) if ($@);
      }
      $i++;
    }
  }

  # validation stage

  foreach my $name (keys %{ $self->{names} }) {
    my $info = $self->{names}->{$name};
    unless (exists($vals{$name})) {
      $vals{$name} = $info->{default},
        if (($name eq $info->{name}) && (defined $info->{default}));
    }
    if ($info->{required} && !exists($vals{$name})) {
      $self->_usage("missing required parameter \"$name\"", $named);
    }
    if (defined $info->{needs}) {
      # convert a scalar into a list with one element
      if (!ref $info->{needs}) { $info->{needs} = [ $info->{needs} ] }

      foreach my $dep (@{ $info->{needs} }) {
        unless (exists($vals{$dep})) {
          $self->_usage("missing required parameter \"$dep\" (needed by \"$name\")", $named);
        }
      }

    }
  }

  $vals{_named} = $named;

  return %vals;
}


1;

__END__