File Coverage

File:local/lib/perl5/Data/OptList.pm
Coverage:85.2%

linestmtbrancondsubtimecode
1
6
6
6
6
11
5
77
use strict;
2
6
6
6
6
11
3
114
use warnings;
3package Data::OptList;
4{
5  $Data::OptList::VERSION = '0.109';
6}
7# ABSTRACT: parse and validate simple name/value option pairs
8
9
6
6
6
6
11
5
28
use List::Util ();
10
6
6
6
6
865
4
70
use Params::Util ();
11
6
6
6
6
699
65
138
use Sub::Install 0.921 ();
12
13
14my %test_for;
15BEGIN {
16
6
6
1459
  %test_for = (
17    CODE   => \&Params::Util::_CODELIKE,  ## no critic
18    HASH   => \&Params::Util::_HASHLIKE,  ## no critic
19    ARRAY  => \&Params::Util::_ARRAYLIKE, ## no critic
20    SCALAR => \&Params::Util::_SCALAR0,   ## no critic
21  );
22}
23
24sub __is_a {
25
42
42
19
  my ($got, $expected) = @_;
26
27
42
24
100
24
101
27
  return List::Util::first { __is_a($got, $_) } @$expected if ref $expected;
28
29  return defined (
30
24
50
69
    exists($test_for{$expected})
31    ? $test_for{$expected}->($got)
32    : Params::Util::_INSTANCE($got, $expected) ## no critic
33  );
34}
35
36sub mkopt {
37
40
40
27
  my ($opt_list) = shift;
38
39
40
20
  my ($moniker, $require_unique, $must_be); # the old positional args
40
0
0
  my $name_test;
41
42
40
50
67
57
  if (@_ == 1 and Params::Util::_HASHLIKE($_[0])) {
43
0
0
    my $arg = $_[0];
44
0
0
    ($moniker, $require_unique, $must_be, $name_test)
45      = @$arg{ qw(moniker require_unique must_be name_test) };
46  } else {
47
40
31
    ($moniker, $require_unique, $must_be) = @_;
48  }
49
50
40
100
43
  $moniker = 'unnamed' unless defined $moniker;
51
52
40
50
30
  return [] unless $opt_list;
53
54
40
84
50
84
94
73
  $name_test ||= sub { ! ref $_[0] };
55
56
12
50
26
  $opt_list = [
57
40
100
56
    map { $_ => (ref $opt_list->{$_} ? $opt_list->{$_} : ()) } keys %$opt_list
58  ] if ref $opt_list eq 'HASH';
59
60
40
19
  my @return;
61  my %seen;
62
63
40
50
  for (my $i = 0; $i < @$opt_list; $i++) { ## no critic
64
96
48
    my $name = $opt_list->[$i];
65
96
40
    my $value;
66
67
96
100
66
    if ($require_unique) {
68
72
50
77
      Carp::croak "multiple definitions provided for $name" if $seen{$name}++;
69    }
70
71
96
12
100
50
100
136
9
    if    ($i == $#$opt_list)               { $value = undef;            }
72
0
0
0
0
    elsif (not defined $opt_list->[$i+1])   { $value = undef; $i++       }
73
60
30
    elsif ($name_test->($opt_list->[$i+1])) { $value = undef;            }
74
24
11
    else                                    { $value = $opt_list->[++$i] }
75
76
96
100
100
143
    if ($must_be and defined $value) {
77
18
50
20
      unless (__is_a($value, $must_be)) {
78
0
0
        my $ref = ref $value;
79
0
0
        Carp::croak "$ref-ref values are not valid in $moniker opt list";
80      }
81    }
82
83
96
152
    push @return, [ $name => $value ];
84  }
85
86
40
70
  return \@return;
87}
88
89
90sub mkopt_hash {
91
36
36
29
  my ($opt_list, $moniker, $must_be) = @_;
92
36
100
49
  return {} unless $opt_list;
93
94
24
18
  $opt_list = mkopt($opt_list, $moniker, 1, $must_be);
95
24
72
19
69
  my %hash = map { $_->[0] => $_->[1] } @$opt_list;
96
24
49
  return \%hash;
97}
98
99
100BEGIN {
101
6
6
15
  *import = Sub::Install::exporter {
102    exports => [qw(mkopt mkopt_hash)],
103  };
104}
105
1061;
107