File Coverage

blib/lib/Test/ManyParams.pm

Criterion	Covered	Total	%
statement	125	125	100.0
branch	41	42	97.6
condition	2	3	66.6
subroutine	26	26	100.0
pod	7	9	77.7
total	201	205	98.0

package Test::ManyParams;

use 5.006;
use strict;
use warnings;

require Exporter;

our @ISA = qw(Exporter);

our @EXPORT = qw/
    all_ok
    all_are all_arent
    any_ok
    any_is any_isnt

    most_ok

    set_seed
/;

our $VERSION = '0.10';

use Test::Builder;
use Set::CrossProduct;
use Data::Dumper;
our $seed;

my $Tester = Test::Builder->new();

sub does_all {
    my ($sub, $params) = @_;
    my $failed_param = undef;
    if (ref($params->[0]) eq 'ARRAY') {
        if (grep {ref($params->[$_]) ne 'ARRAY'} (1 .. @$params-1)) {
            die "If the first parameter is an arrayref, all other parameters must be also. " .
                "Called with Parameter-Ref: " . _dump_params($params);
        }
        $failed_param = @$params > 1
            ? _try_all_of_xproduct($sub, Set::CrossProduct->new( $params ))
            : _try_all_of_the_list($sub, @{$params->[0]});
    } else {
        $failed_param = _try_all_of_the_list($sub, @$params);
    }
    my $ok = not defined($failed_param);
    my @diag = $ok
        ? ()
        : ("Tests with the parameters: " . _dump_params($params),
           "Failed first using these parameters: " . _dump_params($failed_param));
    return ($ok, @diag);
}

sub does_most {
    my ($sub, $params, $nr) = @_;
    my $failed_param = undef;
    $nr =~ /^\d+$/ or die "The number of tests that shall be done must be an integer, not '$nr'";
    if (ref($params->[0]) eq 'ARRAY') {
        if (grep {ref($params->[$_]) ne 'ARRAY'} (1 .. @$params-1)) {
            die "If the first parameter is an arrayref, all other parameters must be also. " .
                "Called with Parameter-Ref: " . _dump_params($params);
        }
        $failed_param = @$params > 1
            ? _try_most_of_xproduct($sub,$nr, Set::CrossProduct->new( $params ))
            : _try_most_of_the_list($sub,$nr, @{$params->[0]});
    } else {
        $failed_param = _try_most_of_the_list($sub,$nr, @$params);
    }
    my $ok = not defined($failed_param);
    my @diag = $ok
        ? ()
        : ("Tests with most ($nr) of the parameters: " . _dump_params($params),
           "Failed using these parameters: " . _dump_params($failed_param));
    return ($ok, @diag);
}


sub all_ok(&$;$) {
    my ($sub, $params, $test_name) = @_;
    my ($ok, @diag) = does_all(@_);
    $Tester->ok( $ok, $test_name ) or do { $Tester->diag($_) for @diag };
    return $ok;
}

sub most_ok(&$$;$) {
    my ($sub, $params, $nr, $test_name) = @_;
    my ($ok, @diag) = does_most(@_);
    $Tester->ok( $ok, $test_name ) or do { $Tester->diag($_) for @diag };
    return $ok;
}


sub any_ok(&$;$) {
    my ($sub, $params, $test_name) = @_;

    # Please recognise the logic
    # To find out if any of the tests is O.K.,
    # I ask whether all tests fail
    # If so there isn't any_ok, otherwise there is at least one ok
    my ($all_arent_ok) = does_all(sub {!$sub->(@_)}, $params, $test_name);
    my $ok = !$all_arent_ok;
    $Tester->ok( $ok, $test_name );
    return $ok;
}

sub any_is(&$$;$) {
    my ($sub, $expected_value, $params, $test_name) = @_;
    my ($all_arent_ok, @diag) =
        does_all(sub {!($sub->(@_) eq $expected_value)}, $params, $test_name);
    my $ok = !$all_arent_ok;
    $Tester->ok( $ok, $test_name)
    or do {
        $Tester->diag($_) for @diag;
        $Tester->diag("Expected: " . _dump_params($expected_value));
        $Tester->diag("but didn't found it with at least one parameter");
    };
}

sub any_isnt(&$$;$) {
    my ($sub, $expected_value, $params, $test_name) = @_;
    my ($all_arent_ok, @diag) =
        does_all(sub {!($sub->(@_) ne $expected_value)}, $params, $test_name);
    my $ok = !$all_arent_ok;
    $Tester->ok( $ok, $test_name)
    or do {
        $Tester->diag($_) for @diag;
        $Tester->diag("Expected to find any parameter where result is different to " . _dump_params($expected_value));
        $Tester->diag("but didn't found such parameters");
    };
}

sub all_are(&$$;$) {
    my ($sub, $expected, $params, $test_name) = @_;
    my $found = undef;
    my ($ok, @diag) =
        does_all( sub { $found = $sub->(@_); $found eq $expected }, $params);
    $Tester->ok($ok, $test_name)
    or do {
        $Tester->diag($_) for @diag;
        $Tester->diag("Expected: " . _dump_params($expected));
        $Tester->diag("but found: " . _dump_params($found));
    };
}

sub all_arent(&$$;$) {
    my ($sub, $unexpected, $params, $test_name) = @_;
    my $found = undef;
    my ($ok, @diag) =
        does_all( sub { $found = $sub->(@_); $found ne $unexpected }, $params);
    $Tester->ok($ok, $test_name)
    or do {
        $Tester->diag($_) for @diag;
        $Tester->diag("Expected not to find " . _dump_params($unexpected) . " but found it");
    };
}

sub _try_all_of_the_list {
    my ($sub, @param) = @_;
    foreach my $p (@param) {
        local $_ = $p;
        $sub->($_) or return [$_];
    }
    return undef;
}

sub _try_most_of_the_list {
    my ($sub,$nr,@param) = @_;
    while ($nr-- > 0) {
        local $_ = $param[rand @param];
        $sub->($_) or return [$_];
    }
    return undef;
}


sub _try_all_of_xproduct {
    my ($sub, $iterator) = @_;
    my $tuple = undef;
    while ($tuple = $iterator->get()) {
        $sub->(@$tuple) or last;
    }
    return $tuple;
}

sub _try_most_of_xproduct {
    my ($sub, $nr, $iterator) = @_;
    while ($nr-- > 0) {
        my $tuple = $iterator->random;
        $sub->(@$tuple) or return $tuple;
    }
    return undef;
}

sub _dump_params {
    local $_ = Dumper($_[0]);
    s/\s+//gs;   # remove all indents, but I didn't want to set
                 # $Data::Dumper::Indent as it could have global effects
    s/^.*? = //; # remove the variable name of the dumped output
    return $_;
}

sub import {
    my @import_arg;
    my $seed_now = time ^ $$;               # default value for the seed
    while (local $_ = shift @_) {
            /seed/    && do { $seed_now = shift();
                              $seed_now =~ /^\d+$/ or die "The seed must be an integer";
                            }
        or  "DEFAULT" && push @import_arg, $_;
    }
    srand($seed_now);
    #Readonly::Scalar $seed => $seed_now;
    $seed = $seed_now;
    Test::ManyParams->export_to_level(1, @import_arg);
}

1;

__END__