File Coverage

blib/lib/Permute/Named.pm

Criterion	Covered	Total	%
statement	38	41	92.6
branch	11	14	78.5
condition			n/a
subroutine	8	8	100.0
pod	1	1	100.0
total	58	64	90.6

use 5.008;
use strict;
use warnings;

package Permute::Named;
BEGIN {
  $Permute::Named::VERSION = '1.100980';
}

# ABSTRACT: permute multiple-valued key-value pairs
use Storable 'dclone';
use Exporter qw(import);
our @EXPORT = qw(permute_named);

sub permute_named {
    my $args;
    if (@_ == 1) {
        $args = shift;
    } else {
        $args = \@_;
    }
    if (ref $args eq 'HASH') {
        $args = [%$args];
    }
    if (ref $args ne 'ARRAY') {
        die "permute_named expects an array ref or a hash ref\n";
    }
    if (@$args % 2 == 1) {
        die "permute_named got an uneven-sized list of arguments\n";
    }
    my @permutations;
    my $permute;
    $permute = sub {
        my ($args, $done) = @_;
        my $done_clone = dclone $done;
        if (@$args == 0) {
            push @permutations => $done_clone;
            return;
        }
        my $args_clone = dclone $args;
        my ($key, $value) = splice @$args_clone, 0, 2;
        $value = [$value] unless ref $value eq 'ARRAY';
        for my $element (@$value) {
            $done_clone->{$key} = $element;
            $permute->($args_clone, $done_clone);
        }
    };
    $permute->($args, {});
    wantarray ? @permutations : \@permutations;
}
1;


__END__