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

package PERLANCAR::Permute::Named;

our $DATE = '2015-10-02'; # DATE
our $VERSION = '0.02'; # VERSION

use 5.010001;
use strict 'subs', 'vars';
use warnings;

use Exporter qw(import);
our @EXPORT = qw(
                    permute_named
            );

sub permute_named {
    die "Please supply a non-empty list of key-specification pairs" unless @_;
    die "Please supply an even-sized list" unless @_ % 2 == 0;

    my @keys;
    my @values;
    while (my ($key, $values) = splice @_, 0, 2) {
        push @keys, $key;
        $values = [$values] unless ref($values) eq 'ARRAY';
        die "$key cannot contain empty values" unless @$values;
        push @values, $values;
    }
    my @res;
    my $code = '{ my @j;';
    for my $i (0..$#keys) {
        $code .= " local \$main::_j$i;";
    }
    for my $i (0..$#keys) {
        $code .= " for \$main::_j$i (0..". $#{$values[$i]} . ") {";
    }
    $code .= " my \$h = {}; for my \$k (0..". $#keys . ") { \$h->{\$keys[\$k]} = \$values[\$k][ \${\"main::_j\$k\"} ]; } push \@res, \$h;";
    for my $i (0..$#keys) {
        $code .= ' }';
    }
    $code .= " }";
    #say $code;
    eval $code; if ($@) { warn "$code\n"; die }
    wantarray ? @res : \@res;
}

1;
# ABSTRACT: Permute multiple-valued key-value pairs

__END__