File Coverage

blib/lib/PERLANCAR/Permute/Named.pm
Criterion Covered Total %
statement 33 35 94.2
branch 7 12 58.3
condition n/a
subroutine 5 5 100.0
pod 1 1 100.0
total 46 53 86.7


line stmt bran cond sub pod time code
1             package PERLANCAR::Permute::Named;
2              
3             our $DATE = '2016-09-25'; # DATE
4             our $VERSION = '0.03'; # VERSION
5              
6 1     1   664 use 5.010001;
  1         4  
7 1     1   5 use strict 'subs', 'vars';
  1         2  
  1         32  
8 1     1   4 use warnings;
  1         1  
  1         31  
9              
10 1     1   4 use Exporter qw(import);
  1         1  
  1         349  
11             our @EXPORT = qw(
12             permute_named
13             );
14              
15             sub permute_named {
16 2 50   2 1 15 die "Please supply a non-empty list of key-specification pairs" unless @_;
17 2 50       5 die "Please supply an even-sized list" unless @_ % 2 == 0;
18              
19 2         3 my @keys;
20             my @values;
21 2         8 while (my ($key, $values) = splice @_, 0, 2) {
22 4         6 push @keys, $key;
23 4 100       8 $values = [$values] unless ref($values) eq 'ARRAY';
24 4 50       8 die "$key cannot contain empty values" unless @$values;
25 4         9 push @values, $values;
26             }
27 2         1 my @res;
28 2         3 my $code = '{ my @j;';
29 2         15 for my $i (0..$#keys) {
30 4         11 $code .= " local \$main::_j$i;";
31             }
32 2         5 for my $i (0..$#keys) {
33 4         7 $code .= " for \$main::_j$i (0..". $#{$values[$i]} . ") {";
  4         11  
34             }
35 2         5 $code .= " my \$h = {}; for my \$k (0..". $#keys . ") { \$h->{\$keys[\$k]} = \$values[\$k][ \${\"main::_j\$k\"} ]; } push \@res, \$h;";
36 2         4 for my $i (0..$#keys) {
37 4         6 $code .= ' }';
38             }
39 2         3 $code .= " }";
40             #say $code;
41 2 50       276 eval $code; if ($@) { warn "$code\n"; die }
  2         9  
  0         0  
  0         0  
42 2 50       23 wantarray ? @res : \@res;
43             }
44              
45             1;
46             # ABSTRACT: Permute multiple-valued key-value pairs
47              
48             __END__