File Coverage

blib/lib/Test/Effects.pm

Criterion	Covered	Total	%
statement	245	307	79.8
branch	103	170	60.5
condition	26	68	38.2
subroutine	38	43	88.3
pod	4	5	80.0
total	416	593	70.1

package Test::Effects;

use warnings;
use strict;
use 5.014;

our $VERSION = '0.002000';

use Test::More;
use Test::Trap;
use base 'Test::Builder::Module';

use match::smart 'match';

# Export the modules interface (and that of Test::More)...
our @EXPORT = (
    qw( effects_ok ),
    qw( ONLY VERBOSE TIME ),
    @Test::More::EXPORT,
);

our @EXPORT_OK = (
    @Test::More::Export_OK,
);

our %EXPORT_TAGS = (
    'minimal' => [ 'effects_ok' ],
    'more'    => [ 'effects_ok', @Test::More::EXPORT],
);

# Magic number tells Test::More how many stack levels to go up when reporting errors
# (Unfortunately, this depends on the internals of Test::More)
# [TODO: Send a patch for Test::More that autoskips a named class when reporting]
my $LEVEL_OFFSET = 6;
my $LEVEL_OFFSET_NESTED = 2 * $LEVEL_OFFSET + 1;


# Adjust tests used in the module to account for nesting...
sub _subtest {
    my ($desc) = @_;

    # Report problems as being in the appropriate place...
    local $Test::Builder::Level = $Test::Builder::Level + $LEVEL_OFFSET;

    &subtest(@_);
}

sub _fail {
    # Report problems as being in the appropriate place...
    local $Test::Builder::Level = $Test::Builder::Level + $LEVEL_OFFSET_NESTED;

    &fail(@_);
}

use Scalar::Util 'looks_like_number';

sub is_num { Test::Effects->builder->is_num(@_) }

sub _is_or_like {
    my ($got, $expected, $desc) = @_;

    # Report problems as being in the appropriate place...
    local $Test::Builder::Level = $Test::Builder::Level + $LEVEL_OFFSET_NESTED;

    for my $expected_type (ref $expected) {
        if ($expected_type eq 'CODE')   {
            no warnings;
            my $ok = \&Test::Builder::ok;
            local *Test::Builder::ok = sub { $_[2] = $desc unless defined $_[2]; $ok->(@_); };
            ok($expected->($got, $desc), $desc);
        }
        elsif ($expected_type eq 'Regexp')   { &like(@_);   }
        elsif (looks_like_number($expected)) { &is_num(@_); }
        else                                 { &is(@_);     }
    }
}

sub _is_deeply {
    my ($got, $expected, $desc) = @_;

    # Report problems as being in the appropriate place...
    local $Test::Builder::Level = $Test::Builder::Level + $LEVEL_OFFSET_NESTED;

    for my $expected_type (ref $expected) {
        if ($expected_type eq 'CODE')   {
            no warnings;
            my $ok = \&Test::Builder::ok;
            local *Test::Builder::ok = sub { $_[2] = $desc unless defined $_[2]; $ok->(@_); };
            ok($expected->($got, $desc), $desc);
        }
        else {
            &is_deeply(@_);
        }
    }
}

sub _is_like_or_deeply {
    my ($got, $expected, $desc) = @_;

    # Report problems as being in the appropriate place...
    local $Test::Builder::Level = $Test::Builder::Level + $LEVEL_OFFSET_NESTED;

    for my $expected_type (ref $expected) {
        if ($expected_type eq 'CODE')   {
            no warnings;
            my $ok = \&Test::Builder::ok;
            local *Test::Builder::ok = sub { $_[2] = $desc unless defined $_[2]; $ok->(@_); };
            ok($expected->($got, $desc), $desc);
        }
        elsif ($expected_type eq 'Regexp') {
            my $got_val = ref($got) eq 'ARRAY' && @{$got} == 1 ? $got->[0] : $got;
            like($got_val, $expected, $desc);
        }
        elsif ($expected_type eq q{}) {
            if (looks_like_number($expected)) { &is_num(@_) }
            else                              {     &is(@_) }
        }
        else {
            &is_deeply(@_);
        }
    }
}

sub _is_like_or_list {
    my ($got, $expected, $desc) = @_;

    # Report problems as being in the appropriate place...
    local $Test::Builder::Level = $Test::Builder::Level + $LEVEL_OFFSET_NESTED;

    for my $expected_type (ref $expected) {
        if ($expected_type eq 'CODE')   {
            no warnings;
            my $ok = \&Test::Builder::ok;
            local *Test::Builder::ok = sub { $_[2] = $desc unless defined $_[2]; $ok->(@_); };
            ok($expected->($got, $desc), $desc);
        }
        elsif ($expected_type eq 'Regexp') {
            my $got_val = ref($got) eq 'ARRAY' && @{$got} == 1 ? $got->[0] : $got;
            like($got_val, $expected, $desc);
        }
        elsif ($expected_type eq q{} && looks_like_number($expected)) {
            &is_num(@_);
        }
        elsif ($expected_type eq q{}) {
            &is(@_);
        }
        elsif ($expected_type eq q{ARRAY}) {
            for my $n (0..$#{$expected}) {
                _is_or_like($got->[$n], $expected->[$n], "$desc [warning $n]");
            }
        }
        else {
            &is_deeply(@_);
        }
    }
}


# Utility sub: dump values...

sub _explain {
    use Data::Dumper 'Dumper';
    local $Data::Dumper::Terse = 1;
    local $Data::Dumper::Indent = 0;
    return Dumper(shift) =~ s/\s+/ /gr
                         =~ s/\s+$//gr;
}


# Utility subs: build subs that append the right verb, when requested....

sub _was_were_sub {
    my ($desc) = @_;

    return sub {
        my (undef, $was_were) = @_;

        return $desc if !$was_were;
        return "$desc was";
    };
}

sub _was_were_warn_sub {
    return sub {
        my ($expected, $was_were) = @_;

        my $count = eval{ @{$expected} } // 1;

        return $count == 1 ? 'warning'  . ($was_were ? ' was'  : q{})
                           : 'warnings' . ($was_were ? ' were' : q{});
    }
}


# Utility sub: load carp() and croak() only on demand...
sub _croak {
    if (eval{ require Carp }) { Carp::croak(@_); }
    else                      { die @_; }
}


# Module is largely table-driven (from these tables)...

my (%TEST_FOR, %NULL_VALUE_FOR, %BAD_NULL_VALUE_FOR, %DESCRIBE);

BEGIN {
    %TEST_FOR = (
        'stdout' => \&_is_or_like,
        'stderr' => \&_is_or_like,
        'warn'   => \&_is_like_or_list,
        'die'    => \&_is_or_like,
        'exit'   => \&_is_or_like,
    );

    %NULL_VALUE_FOR = (
        'stdout' => q{},
        'stderr' => q{},
        'warn'   => [],
        'die'    => undef,
        'exit'   => undef,
    );

    %BAD_NULL_VALUE_FOR = (
        'stdout' => undef,
        'stderr' => undef,
        'warn'   => undef,
        'die'    => q{},
        'exit'   => q{},
    );

    %DESCRIBE = (
        'stdout' => _was_were_sub( 'output to STDOUT' ),
        'stderr' => _was_were_sub( 'output to STDERR' ),
        'warn'   => _was_were_warn_sub(),
        'die'    => _was_were_sub( 'exception' ),
        'exit'   => _was_were_sub( 'call to exit()' ),
    );
}


# Make a copy of a hash with an appropriate flag added...
sub ONLY    (+)  { return { ONLY    => 1, %{shift()} } }
sub VERBOSE (+)  { return { VERBOSE => 1, %{shift()} } }
sub TIME    (+)  { return { TIME    => 1, %{shift()} } }

my $MS_THRESHHOLD = 0.1; # seconds (anything less reported in ms)

# 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) {
                    $module_name .= '.pm';
                }
                else {
                    $module_name = qr{$module_name};
                }
            }
            # Libpaths winnow @INC directly...
            elsif (!$is_pattern && $is_libpath) {
                $module_name =~ s{/\Z}{}xms;
                if ($module_name =~ m{\A /}x) {
                    @INC = grep { !m{\A $module_name /? \Z}x } @INC;
                }
                else {
                    @INC = grep { !m{\A (?: [.]/ )? $module_name /? \Z}x } @INC;
                }
            }
            else { # Pattern spec for libpath
                @INC = grep { !m{$module_name} } @INC;
            }

            # Libpaths then don't need to be checked with @INC...
            if ($is_libpath) {
                $module_name = undef;
            }
        }

        # Put an interceptor sub at the start of @INC...
        unshift @INC, sub {
            my ($self, $target) = @_;

            # If what you're looking for is WITHOUT'd, pretend to fail...
            if (match($target, $without_list) || match("/$target", $without_list)) {
                _croak "Can't locate $target in \@INC (\@INC contains: @real_INC)";
            }
            return;
        };
    }

    # Test in a subtest...
    my $failed = _subtest $desc => sub {
        # Find the specified return value (if any)...
        my @return_specs = grep /return/, keys %{$expected};
        if (@return_specs > 1) {
            _fail "Ambiguous specification for testing of return value.";
            diag "ERROR: Found request for " . scalar(@return_specs),
                 " mutually exclusive tests:\n",
                 "       {\n",
                 (map { "          '$_' => " . _explain($expected->{$_}) . ",\n" } @return_specs),
                 "       }\n",
                 "       Call to effects_ok() terminated without testing anything.";
            return;
        }

        # Infer context, if necessary...
        if (exists $expected->{'return'}) {
            for my $return_type (ref $expected->{'return'}) {
                if ($return_type eq 'ARRAY') {
                    $expected->{'list_return'}   = delete $expected->{'return'};
                }
                else {
                    $expected->{'scalar_return'} = delete $expected->{'return'};
                }
            }
        }

        # Call the block and test the return value in the appropriate context...
        # 1. Explicit void context...
        if (exists $expected->{'void_return'}) {
            if (defined $expected->{'void_return'}) {
                note "WARNING: Meaningless option {void_return => '$expected->{void_return}'} ignored.\n"
                   . "         To silence this warning, either remove the option entirely\n"
                   . "         or replace it with: {void_return => undef})";
            }
            if ($timed_test) {
                _time_calls_to($block, $timed_test => $timing);
            }
            else {
                trap { $block->() };
            }
            pass 'Tested in void context, so ignored return value'
        }
        # 2. Explicit scalar context...
        elsif (exists $expected->{'scalar_return'}) {
            my $return_val = do {
                if ($timed_test) {
                    _time_calls_to($block, $timed_test => $timing);
                }
                else {
                    trap { $block->() };
                }
            };
            _is_like_or_deeply $return_val, $expected->{'scalar_return'}
                            => 'Scalar context return value was as expected';
        }
        # 3. Explicit list context...
        elsif (exists $expected->{'list_return'}) {
            my @return_vals = do {
                if ($timed_test) {
                    _time_calls_to($block, $timed_test => $timing);
                }
                else {
                    trap { $block->() };
                }
            };
            _is_deeply \@return_vals, $expected->{'list_return'}
                    => 'List context return value was as expected';
        }
        # 4. Implied void context...
        else {
            if ($timed_test) {
                _time_calls_to($block, $timed_test => $timing);
            }
            else {
                trap { $block->() };
            }
            pass 'No return value specified, so tested in void context';
        }

        # Test side-effects...
        for my $info (qw< stdout stderr warn die exit>) {
            if (exists $expected->{$info}) {
                no strict 'refs';
                my $desc = match($expected->{$info}, $NULL_VALUE_FOR{$info})
                            ? 'No ' . $DESCRIBE{$info}->($expected->{$info}) . ' (as expected)'
                            : ucfirst $DESCRIBE{$info}->($expected->{$info},'was') . ' as expected';

                $TEST_FOR{$info}->($trap->$info, $expected->{$info}, $desc);
            }
        }

        # Do timing, if requested...

        if (exists $expected->{'timing'}) {

            # Work out the parameters...
            my $time_spec = $expected->{'timing'};
            my $spec_type = ref $time_spec;

            my $min = $spec_type eq 'HASH'  ? $time_spec->{'min'} // 0
                    : $spec_type eq 'ARRAY' ? $time_spec->[0]     // 0
                    :                         0;

            state $INF = 0 + 'inf';
            my $max = $spec_type eq 'HASH'          ? $time_spec->{'max'} // $INF
                    : $spec_type eq 'ARRAY'         ? $time_spec->[-1]    // $INF
                    :                                 0+$time_spec;

            # Run the test...
            my $duration = _time_calls_to($block);

            # Compute a handy alternate measure of performance...
            my $speed = $duration ? 1/$duration : 0;
               $speed = $speed > 1 ? sprintf('(%1.0lf/sec)', $speed)
                      : $speed > 0 ? sprintf('(%0.4g/sec)', $speed)
                      :              '(unmeasurably fast)';

            # Was the result acceptable???
            my $in_range = $min <= $duration && $duration <= $max;

            # Report outcome...
            ok $in_range => $duration > $MS_THRESHHOLD
                ? sprintf('Ran in %0.3f sec %s', $duration, $speed)
                : sprintf('Ran in %dms %s', 1000*$duration, $speed);

            # Clean up report...
            if (!$in_range) {
                $tests_output =~ s{\N*\n\N*\n\z}{}xms;
            }

            # Report any problems (as being in the appropriate place)...
            local $Test::Builder::Level = $Test::Builder::Level + $LEVEL_OFFSET_NESTED - 1;
            if (!$in_range) {
                diag sprintf "         Expected to run in: $min to $max sec", $min, $max;
            }
        }

    };

    # Clean up...
    my $builder = Test::Builder->new;
    $builder->reset_outputs;

    # Report outcomes...
    my $passed = ($builder->summary)[-1];
    # If passed in terse mode, just print the summary (i.e. last line)...
    if ( $is_terse && $passed ) {
        $tests_output =~ s{ .* \n (?= .*\n )}{}xms;
    }
    # Otherwise print the probems...
    elsif ( $is_terse ) {
        $tests_output =~ s{^ \s*+ (?! not | [#] ) [^\n]* \n}{}gxms;
    }

    # Add the timing info, if requested...
    if ($timed_test) {
        $tests_output =~ s{^ ( (?:not|ok) \s \N*) }{$1\t$timing}xms;
    }

    print {$builder->output} $tests_output;

    return $passed;
}


BEGIN { eval{ require Time::HiRes and Time::HiRes->import('time') } }

sub _time_calls_to {
    my ($block, $time_one_call) = @_;

    state $MAX_CPU_TIME              = 1;
    state $MIN_CREDIBLE_UTILIZATION  = 0.1;

    my ($cpu_time, $wall_time) = (0,0);
    my $count = 0;

    my (@start, @end);
    my $wantarray = wantarray;
    my (@result, $result);

    while (1) {
        if ($time_one_call && $wantarray) {
            @start = (time, times);
            @result = trap { $block->() };
            @end   = (time, times);
        }
        elsif ($time_one_call && defined $wantarray) {
            @start = (time, times);
            $result = trap { $block->() };
            @end   = (time, times);
        }
        else {
            @start = (time, times);
            trap { $block->() };
            @end   = (time, times);
        }

        $wall_time += $end[0] - $start[0];
        $cpu_time  += $end[$_] - $start[$_] for 1..4;

        $count++;

        last if $cpu_time  > $MAX_CPU_TIME
             || $wall_time > 2 * $MAX_CPU_TIME
             || $time_one_call;
    }

    my $utilization = $cpu_time / ($wall_time||1);
    my $timing = !$cpu_time || $utilization < $MIN_CREDIBLE_UTILIZATION
                    ? $wall_time / $count
                    : $cpu_time  / $count;

    if ($time_one_call) {
        if ($timing < $MS_THRESHHOLD) {
            $_[2] = '[' . int($timing * 1000) . 'ms]';
        }
        else {
            $_[2] = sprintf '[%0.2lf sec]', $timing;
        }
        return $wantarray ? @result : $result;
    }
    else {
        return $timing;
    }
}


1; # Magic true value required at end of module
__END__