File Coverage

blib/lib/Data/OptList.pm

Criterion	Covered	Total	%
statement	62	62	100.0
branch	33	34	97.0
condition	7	8	87.5
subroutine	12	12	100.0
pod	2	2	100.0
total	116	118	98.3

use strict;
use warnings;
package Data::OptList;
# ABSTRACT: parse and validate simple name/value option pairs
$Data::OptList::VERSION = '0.112';
use List::Util ();
use Params::Util ();
use Sub::Install 0.921 ();

#pod =head1 SYNOPSIS
#pod
#pod   use Data::OptList;
#pod
#pod   my $options = Data::OptList::mkopt([
#pod     qw(key1 key2 key3 key4),
#pod     key5 => { ... },
#pod     key6 => [ ... ],
#pod     key7 => sub { ... },
#pod     key8 => { ... },
#pod     key8 => [ ... ],
#pod   ]);
#pod
#pod ...is the same thing, more or less, as:
#pod
#pod   my $options = [
#pod     [ key1 => undef,        ],
#pod     [ key2 => undef,        ],
#pod     [ key3 => undef,        ],
#pod     [ key4 => undef,        ],
#pod     [ key5 => { ... },      ],
#pod     [ key6 => [ ... ],      ],
#pod     [ key7 => sub { ... },  ],
#pod     [ key8 => { ... },      ],
#pod     [ key8 => [ ... ],      ],
#pod   ]);
#pod
#pod =head1 DESCRIPTION
#pod
#pod Hashes are great for storing named data, but if you want more than one entry
#pod for a name, you have to use a list of pairs.  Even then, this is really boring
#pod to write:
#pod
#pod   $values = [
#pod     foo => undef,
#pod     bar => undef,
#pod     baz => undef,
#pod     xyz => { ... },
#pod   ];
#pod
#pod Just look at all those undefs!  Don't worry, we can get rid of those:
#pod
#pod   $values = [
#pod     map { $_ => undef } qw(foo bar baz),
#pod     xyz => { ... },
#pod   ];
#pod
#pod Aaaauuugh!  We've saved a little typing, but now it requires thought to read,
#pod and thinking is even worse than typing... and it's got a bug!  It looked right,
#pod didn't it?  Well, the C<< xyz => { ... } >> gets consumed by the map, and we
#pod don't get the data we wanted.
#pod
#pod With Data::OptList, you can do this instead:
#pod
#pod   $values = Data::OptList::mkopt([
#pod     qw(foo bar baz),
#pod     xyz => { ... },
#pod   ]);
#pod
#pod This works by assuming that any defined scalar is a name and any reference
#pod following a name is its value.
#pod
#pod =func mkopt
#pod
#pod   my $opt_list = Data::OptList::mkopt($input, \%arg);
#pod
#pod Valid arguments are:
#pod
#pod   moniker        - a word used in errors to describe the opt list; encouraged
#pod   require_unique - if true, no name may appear more than once
#pod   must_be        - types to which opt list values are limited (described below)
#pod   name_test      - a coderef used to test whether a value can be a name
#pod                    (described below, but you probably don't want this)
#pod
#pod This produces an array of arrays; the inner arrays are name/value pairs.
#pod Values will be either "undef" or a reference.
#pod
#pod Positional parameters may be used for compatibility with the old C
#pod interface:
#pod
#pod   my $opt_list = Data::OptList::mkopt($input, $moniker, $req_uni, $must_be);
#pod
#pod Valid values for C<$input>:
#pod
#pod  undef    -> []
#pod  hashref  -> [ [ key1 => value1 ] ... ] # non-ref values become undef
#pod  arrayref -> every name followed by a non-name becomes a pair: [ name => ref ]
#pod              every name followed by undef becomes a pair: [ name => undef ]
#pod              otherwise, it becomes [ name => undef ] like so:
#pod              [ "a", "b", [ 1, 2 ] ] -> [ [ a => undef ], [ b => [ 1, 2 ] ] ]
#pod
#pod By default, a I is any defined non-reference.  The C parameter
#pod can be a code ref that tests whether the argument passed it is a name or not.
#pod This should be used rarely.  Interactions between C and
#pod C are not yet particularly elegant, as C just tests
#pod string equality.  B
#pod
#pod The C parameter is either a scalar or array of scalars; it defines
#pod what kind(s) of refs may be values.  If an invalid value is found, an exception
#pod is thrown.  If no value is passed for this argument, any reference is valid.
#pod If C specifies that values must be CODE, HASH, ARRAY, or SCALAR, then
#pod Params::Util is used to check whether the given value can provide that
#pod interface.  Otherwise, it checks that the given value is an object of the kind.
#pod
#pod In other words:
#pod
#pod   [ qw(SCALAR HASH Object::Known) ]
#pod
#pod Means:
#pod
#pod   _SCALAR0($value) or _HASH($value) or _INSTANCE($value, 'Object::Known')
#pod
#pod =cut

my %test_for;
BEGIN {
  %test_for = (
    CODE   => \&Params::Util::_CODELIKE,  ## no critic
    HASH   => \&Params::Util::_HASHLIKE,  ## no critic
    ARRAY  => \&Params::Util::_ARRAYLIKE, ## no critic
    SCALAR => \&Params::Util::_SCALAR0,   ## no critic
  );
}

sub mkopt {
  my ($opt_list) = shift;

  my ($moniker, $require_unique, $must_be); # the old positional args
  my ($name_test, $is_a);

  if (@_) {
    if (@_ == 1 and Params::Util::_HASHLIKE($_[0])) {
      ($moniker, $require_unique, $must_be, $name_test)
        = @{$_[0]}{ qw(moniker require_unique must_be name_test) };
    } else {
      ($moniker, $require_unique, $must_be) = @_;
    }

    # Transform the $must_be specification into a closure $is_a
    # that will check if a value matches the spec

    if (defined $must_be) {
      $must_be = [ $must_be ] unless ref $must_be;
      my @checks = map {
          my $class = $_;
          $test_for{$class}
          || sub { Params::Util::_INSTANCE($_[0], $class) }
      } @$must_be;

      $is_a = (@checks == 1)
            ? $checks[0]
            : sub {
                my $value = $_[0];
                List::Util::first { defined($_->($value)) } @checks
              };

      $moniker = 'unnamed' unless defined $moniker;
    }
  }

  return [] unless $opt_list;

  $name_test ||= sub { ! ref $_[0] };

  $opt_list = [
    map { $_ => (ref $opt_list->{$_} ? $opt_list->{$_} : ()) } keys %$opt_list
  ] if ref $opt_list eq 'HASH';

  my @return;
  my %seen;

  for (my $i = 0; $i < @$opt_list; $i++) { ## no critic
    my $name = $opt_list->[$i];

    if ($require_unique) {
      Carp::croak "multiple definitions provided for $name" if $seen{$name}++;
    }

    my $value;

    if ($i < $#$opt_list) {
      if (not defined $opt_list->[$i+1]) {
        $i++
      } elsif (! $name_test->($opt_list->[$i+1])) {
        $value = $opt_list->[++$i];
        if ($is_a && !$is_a->($value)) {
          my $ref = ref $value;
          Carp::croak "$ref-ref values are not valid in $moniker opt list";
        }
      }
    }

    push @return, [ $name => $value ];
  }

  return \@return;
}

#pod =func mkopt_hash
#pod
#pod   my $opt_hash = Data::OptList::mkopt_hash($input, $moniker, $must_be);
#pod
#pod Given valid C> input, this routine returns a reference to a hash.  It
#pod will throw an exception if any name has more than one value.
#pod
#pod =cut

sub mkopt_hash {
  my ($opt_list, $moniker, $must_be) = @_;
  return {} unless $opt_list;

  $opt_list = mkopt($opt_list, $moniker, 1, $must_be);
  my %hash = map { $_->[0] => $_->[1] } @$opt_list;
  return \%hash;
}

#pod =head1 EXPORTS
#pod
#pod Both C and C may be exported on request.
#pod
#pod =cut

BEGIN {
  *import = Sub::Install::exporter {
    exports => [qw(mkopt mkopt_hash)],
  };
}

1;

__END__