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__ |