view release on metacpan or  search on metacpan

lib/Test/Effects.pm  view on Meta::CPAN

# Test all trapped info, as requested...
sub effects_ok (&;+$) {
    my ($block, $expected, $desc) = @_;
    my $expected_ref = ref $expected;

    # Handle case where hash is missing, but description isn't...
    if (@_ == 2 && !$expected_ref) {
        $desc     = "$expected";
        $expected = undef;
    }

    # Expectations are passed in a hash...
    $expected //= {};
    if (ref($expected) ne 'HASH') {
        _croak 'Second argument to effects_ok() must be hash or hash reference, not '
             . lc(ref($expected) || 'scalar value');
    }

    # If there's a timing request, the value has to make sense...
    my $timing;
    if (exists $expected->{'timing'}) {
        my $spec = $expected->{'timing'};
        my $valid_time =  ref($spec) =~ m{ \A (?: HASH | ARRAY ) \Z}xms
                      || !ref($spec) && looks_like_number($spec);
        if (!$valid_time) {
            _croak("Invalid timing specification: timing => '$spec'");
        }
    }

    # Get lexical hints...
    my %lexical_hint = %{ (caller 0)[10] // {} };

    # Fill in default tests, unless requested not to...
    my $is_only
        = exists $expected->{'ONLY'} ? $expected->{'ONLY'}
        :                              $lexical_hint{'Test::Effects::ONLY'};

    # Time the test, if requested
    my $timed_test
        = exists $expected->{'TIME'} ? $expected->{'TIME'}
        :                              $lexical_hint{'Test::Effects::TIME'};

    if (!$is_only) {
        my $warn = $expected->{'warn'};
        $expected = {
            %NULL_VALUE_FOR,
            'stderr' => (ref $warn eq 'ARRAY' ? join(q{}, @{$warn}) : $warn),
            %{$expected},
        };
    }

    # Correct common mispecifications...
    for my $option (keys %BAD_NULL_VALUE_FOR) {
        next if !exists $expected->{$option};
        if (match( $expected->{$option}, $BAD_NULL_VALUE_FOR{$option} )) {
            $expected->{$option} = $NULL_VALUE_FOR{$option};
        }
    }

    # Ensure there's a description...
    $desc //= sprintf "Testing effects_ok() at %s line %d", (caller)[1,2];

    # Are we echoing this test???
    my $is_terse
        = exists $expected->{'VERBOSE'} ? !$expected->{'VERBOSE'}
        :                                 !$lexical_hint{'Test::Effects::VERBOSE'};

    # Show the description...
    my $preview_desc = !$is_terse || exists $expected->{'timing'};
    if ($preview_desc) {
        note '_' x (3 + length $desc);
        note exists $expected->{'timing'}
                ? "$desc (being timed)..."
                : "$desc...";
    }

    # Redirect test output, so we can retrospectively de-terse on errors...
    my $tests_output;
    for my $builder (Test::Builder->new()) {
        $builder->output(\$tests_output);
        $builder->failure_output(\$tests_output);
        $builder->todo_output(\$tests_output);
    }

    # Preview description under terse too, in case of failures...
    if (!$preview_desc) {
        note '_' x (3 + length $desc);
        note "$desc...";
    }

    # Are we WITHOUT any modules in this test???
    my @real_INC = @INC;
    local @INC = @INC;
    local %INC = %INC;
    if (exists $expected->{'WITHOUT'}) {
        my $without_list = $expected->{'WITHOUT'};

        # Normalize list...
        if (ref $without_list ne 'ARRAY') {
            $without_list = [ $without_list ];
        }

        # Translate list to filepaths...
        for my $module_name ( @{$without_list} ) {
            # Classify the argument...
            my $is_pattern = ref $module_name eq 'Regexp';
            my $is_libpath = $module_name =~ m{/};

            # Modules get translated to paths...
            if (!$is_libpath) {
                if (not $module_name =~ s{::}{/}gxms) {
                    diag "WARNING: ambiguous WITHOUT => "
                       . ($is_pattern ? "qr{$module_name}" : "'$module_name'")
                       . "\ntreated as module name (not library path)"
                       . "\n(use "
                       . ($is_pattern ? "qr{::$module_name}" : "'::$module_name'")
                       . " or "
                       . ($is_pattern ? "qr{$module_name/}" : "'$module_name/'")
                       . " to silence this warning)";
                }
                if (!$is_pattern) {