—

              
#
# Copyright (c) 2013-2021 Christian Jaeger, copying@christianjaeger.ch
#
# This is free software, offered under either the same terms as perl 5
# or the terms of the Artistic License version 2 or the terms of the
# MIT License (Expat version). See the file COPYING.md that came
# bundled with this file.
#
HideShow 63 lines of Pod
=head1 NAME
Chj::TEST
=head1 SYNOPSIS
    use Chj::TEST;
    # or
    use Chj::TEST use => 'Method::Signatures'
        #, use => ['Foo::Bar', qw(bar baz)],
        #, require => 'CGI'
        ;
    # ^ this will use or require the indicated modules, and if RUN_TESTS
    # is set and they fail, will gracefully fail with a SKIP testing message
    # (if RUN_TESTS is not set, it will die as normally).
    TEST { 1+1 } 2; # success
    TEST { 1+1 } "2"; # fails,
        # because equality is compared on the result of Data::Dumper
    # compute also result lazily:
    TEST { 1+1 } GIVES {3-1}; # success
    TEST_STDOUT { print "Hello" } "Hello";
    TEST_EXCEPTION { die "Hello" } "Hello"; # " at .. line .." and
                                            # backtrace are cut off
    use Chj::TEST ':all';
    my $result = run_tests(__PACKAGE__);
    is $result->failures, 0; # 0 failures
    is $result->successes > 0, 1;
    #run_tests;
    #  or
    #run_tests __PACKAGE__, "Another::Package";
    #  or
    #run_tests_ packages => __PACKAGE__, numbers => [2..4];
    #   aliases package, number, no also accepted
    #  For conditional running the tests as part of a global test suite:
    #perhaps_run_tests "main" or do_something_else;
    #  This will run run_tests("main") iff the RUN_TESTS environment
    #  variable is true, otherwise run do_something_else.
=head1 DESCRIPTION
If the `TEST` environmental variable is set to false (as opposed to
not set at all), tests are dropped. This saves the memory otherwise
required to hold the test code and results.
=head1 SEE ALSO
L<Chj::noTEST>
=head1 NOTE
This is alpha software! Read the status section in the package README
or on the L<website|http://functional-perl.org/>.
=cut
package Chj::TEST;
use strict;
use warnings;
use warnings FATAL => 'uninitialized';
use base "Exporter";
our @EXPORT      = qw(TEST TEST_STDOUT TEST_EXCEPTION GIVES perhaps_run_tests);
our @EXPORT_OK   = qw(run_tests run_tests_ no_tests);
our %EXPORT_TAGS = (all => [@EXPORT, @EXPORT_OK]);
use Carp;
use FP::Carp;
use Chj::singlequote;
# get the style
sub run_tests_style {    # "old" or "tap"
    if (my $rt = $ENV{RUN_TESTS}) {
        (
            $rt =~ /(old|pod_snippets)/i ? "old"
            :
                #$rt =~ /(new|tap)/i ? "tap" :
                "tap"
        )
    } else {
        # Use from the repl can't run "tap" style as that one will
        # fail on re-runs
        "old"
    }
}
our $run_tests_style;    # used internally only, see sub run_tests_style
                         # ($ENV{RUN_TESTS}) how to set it. OK?
sub style_switch {
    my $choices = shift;
    my $handler = $choices->{$run_tests_style}
        or die "missing choice for style '$run_tests_style'";
    goto $handler
}
# remove 'use' and 'require' arguments from import list, run them,
# then delegate to Exporter
sub import {
    my $class = shift;
    my ($package, $filename, $line) = caller;
    my @args;
    for (my $i = 0; $i < @_; $i++) {
        my $v = $_[$i];
        if ($v eq "use" or $v eq "require") {
            my $val = $_[$i + 1];
            defined $val or croak "undef given as 'require' parameter";
            my ($module, @args) = do {
                if (ref($val) eq "ARRAY") {
                    @$val
                } elsif (length $val) {
                    ($val)
                } else {
                    croak
                        "value given as 'require' parameter must be a string or array";
                }
            };
            my $smallcode
                = ("$v $module " . join(",", map { singlequote $_} @args));
            $filename =~ /[\r\n]/
                and die
                "possible security issue";    # XXX: how to do it fully right?
            my $code = "#line $line $filename\npackage $package; $smallcode; 1";
            if (eval $code) {
                # ok
            } else {
                if (my $rt = $ENV{RUN_TESTS}) {
                    if ($rt =~ /pod_snippets/i) {
                        die "TEST use<$module> failed: $smallcode";
                    } else {
                        require Test::More;
                        Test::More::plan(skip_all => "could not $smallcode");
                        exit 1;               # necessary?
                    }
                } else {
                    die $@
                }
            }
            $i++;
        } else {
            push @args, $v
        }
    }
    my $sub = $class->can("SUPER::import")
        or die "$class does not have an 'import' procedure";
    @_ = ($class, @args);
    goto &$sub;
}
use Chj::xIO 'capture_stdout_';
our $tests_by_package = {};
our $num_by_package   = {};
our $dropped_tests = 0;
sub no_tests {
    @_ == 0 or fp_croak_arity 0;
    exists $ENV{TEST} and !$ENV{TEST}
}
sub _TEST {
    my ($proc, $res) = @_;
    if (no_tests) {
        $dropped_tests++;
    } else {
        my ($package, $filename, $line) = caller(1);
        $$num_by_package{$package}++;
        push @{ $$tests_by_package{$package} },
            [
            $proc, $res,
            $$num_by_package{$package}, ($package, $filename, $line)
            ];
    }
}
sub TEST (&$) {
    _TEST(@_)
}
sub TEST_STDOUT (&$) {
    my ($proc, $res) = @_;
    _TEST(sub { capture_stdout_($proc) }, $res);
}
sub TEST_EXCEPTION (&$) {
    my ($proc, $res) = @_;
    _TEST(
        sub {
            if (
                eval {
                    &$proc();
                    1
                }
                )
            {
                undef
            } else {
                my $msg = "$@";
                $msg =~ s| at .*? line \d*.*||s;
                $msg
            }
        },
        $res
    );
}
sub GIVES (&) {
    my ($thunk) = @_;
    bless $thunk, "Chj::TEST::GIVES";
}
package Chj::TEST::Test::Builder {
    our @ISA = qw(Test::Builder);
    # sub level {
    #      my( $self, $level ) = @_;
    #      # original just sets $Level in Test::Builder to $level if
    #      # defined; returns $Level
    #      18
    # }
    # Ah, ^ that won't ever work since the sub at the right location
    # already returned after value generation.  So, fake it
    # completely instead:
    our $fake_caller;
    sub caller {
        my ($self, $height) = @_;
        if ($fake_caller) {
            wantarray ? @$fake_caller : $$fake_caller[0]    ## no critic
        } else {
            my $m = $self->can("SUPER::caller") or die "bug";
            goto $m
        }
    }
}
use FP::Equal qw(relaxedequal);
use FP::Show;
sub eval_test {
    @_ == 2 or fp_croak_arity 2;
    my ($t, $stat) = @_;
    my ($proc, $res, $num, $package, $filename, $line) = @$t;
    style_switch {
        old => sub {
            print "running test $num..";
        },
        tap => sub {
            # say nothing, the ok at the end will say it; XXX: capture
            # output! then present that after the "not ok" output.
        },
    };
    my ($got, $maybe_e);
    my $action = sub {
        $got = &$proc;
        if (ref($res) eq 'Chj::TEST::GIVES') {
            $res = &$res;
        }
    };
    style_switch {
        old => $action,
        tap => sub {
            eval {
                &$action;
                1
            } || do {
                $maybe_e = [$@];    # box it to ensure not undef
            }
        },
    };
    my $location     = "at $filename line $line";
    my $nicelocation = "line $line";
    if (!$maybe_e and relaxedequal($got, $res)) {
        style_switch {
            old => sub {
                print "ok\n";
            },
            tap => sub {
                pass($nicelocation);
            },
        };
        $$stat{successes}++
    } else {
        my $gotstr = show $got;
        my $resstr = show $res;
        style_switch {
            old => sub {
                die "bug, shouldn't happen in this mode" if defined $maybe_e;
                print "FAIL $location:\n";
                print "       got: $gotstr\n";
                print "  expected: $resstr\n";
            },
            tap => sub {
          # fail($location);
          # want to avoid it reporting this file as the location, thus use this:
                my $tb = Test::More->builder;
                (
                           ref($tb) eq 'Test::Builder'
                        or ref($tb) eq 'Chj::TEST::Test::Builder'
                        or die "unexpected class of: $tb"
                );
                bless $tb, 'Chj::TEST::Test::Builder';
                # NOTE: Test::More->builder is a singleton and
                # *remains* blessed!
                local $Chj::TEST::Test::Builder::fake_caller
                    = [$package, $filename, $line];
                #$tb->ok( 0, $nicelocation);
                # On some systems (Test::Builder versions?), the above
                # hackery doesn't work (sigh, move to Test2::*?), thus
                # provide the full location info anyway:
                $tb->ok(0, $location);
                if (defined $maybe_e) {
                    diag("Exception: $$maybe_e[0]");
                } else {
                    diag("       got: $gotstr\n" . "  expected: $resstr\n");
                }
            },
        };
        $$stat{failures}++
    }
}
sub run_tests_for_package {
    my ($package, $stat, $maybe_testnumbers) = @_;
    my $action = sub {
        if (my $tests = $$tests_by_package{$package}) {
            if (defined $maybe_testnumbers) {
                style_switch {
                    old => sub {
                        print
                            "=== running selected tests in package '$package'\n";
                    },
                    tap => sub {
                        # XX better?
                        warn
                            "=== running selected tests in package '$package'\n";
                    },
                };
                for my $number (@$maybe_testnumbers) {
                    if (    $number =~ /^\d+\z/
                        and $number > 0
                        and (my $test = $$tests[$number - 1]))
                    {
                        eval_test $test, $stat
                    } else {
                        warn "ignoring invalid test number '$number'";
                    }
                }
            } else {
                my $action = sub {
                    for my $test (@$tests) {
                        eval_test $test, $stat
                    }
                };
                style_switch {
                    old => sub {
                        print "=== running tests in package '$package'\n";
                        &$action;
                    },
                    tap => sub {
                        plan(tests => scalar @$tests);
                        &$action;
                        done_testing();
                    }
                };
            }
        } else {
            style_switch {
                old => sub {
                    print "=== no tests for package '$package'\n";
                },
                tap => sub {
                    # Can't do 0 tests, planning for it throws an
                    # exception right away, and not planning will fail
                    # in the upper level instead. Thus, fake test result:
                    plan(tests => 1);
                    pass("no tests for package '$package'");
                    done_testing();
                },
            };
        }
    };
    style_switch {
        old => $action,
        tap => sub {
            subtest("Package $package" => $action);
        },
    };
}
sub unify_values {
    my $maybe_values;
    for (@_) {
        if (ref $_) {
            push @$maybe_values, @$_
        } elsif (defined $_) {
            push @$maybe_values, $_
        }
    }
    $maybe_values
}
package Chj::TEST::Result {
    my $accessor = sub {
        my ($field) = @_;
        sub { my $s = shift; $$s{$field} }
    };
    *failures  = $accessor->("failures");
    *successes = $accessor->("successes");
}
sub run_tests_ {
    @_ % 2 and die "need even number of arguments";
    my $args           = +{@_};
    my $maybe_packages = unify_values delete $$args{packages},
        delete $$args{package};
    my $maybe_testnumbers = unify_values delete $$args{numbers},
        delete $$args{number}, delete $$args{no};
    for (sort keys %$args) { warn "run_tests_: unknown argument '$_'" }
    local $run_tests_style //= run_tests_style;
    local $| = 1;
    style_switch {
        old => sub {
            print "==== run_tests in $run_tests_style style ====\n";
        },
        tap => sub {
            # if run_tests is called from perhaps_run_tests this was
            # already done but can't count on that:
            require Test::More;
            import Test::More;
        },
    };
    my $stat = bless { successes => 0, failures => 0 }, "Chj::TEST::Result";
    my $packages = do {
        if (defined $maybe_packages and @$maybe_packages) {
            $maybe_packages;
        } else {
            [sort keys %$tests_by_package]
        }
    };
    my $action = sub {
        run_tests_for_package $_, $stat, $maybe_testnumbers for @$packages;
    };
    style_switch {
        old => sub {
            &$action;
            print "===\n";
            print " => $$stat{successes} success(es), "
                . "$$stat{failures} failure(s)\n";
        },
        tap => sub {
            plan(tests => scalar @$packages);
            &$action;
            done_testing();
        },
    };
    $stat
}
sub run_tests {
    my $packages = [@_];
    run_tests_ packages => $packages;
}
# run tests for test suite:
sub perhaps_run_tests {
    my $args = [@_];
    if ($ENV{RUN_TESTS}) {
        # run TEST forms (called as part of test suite)
        die "Tests were dropped due to the TEST environmental "
            . "variable being set to false"
            if $dropped_tests;
        local $run_tests_style //= run_tests_style;
        require Test::More;
        import Test::More;
        style_switch {
            old => sub {
                # Outer single TAP wrapper around the running of the
                # whole test suite. # XX could still report individual
                # failures by collecting them up, perhaps even simply
                # via Capture::Tiny. Not currently done.
                is(
                    eval { run_tests(@$args)->failures }
                        // do { diag($@); undef },
                    0, "run_tests"
                );
                done_testing();
            },
            tap => sub {
                # Run each test as a TAP test.
                # Handle exceptions at each individual test, OK?
                run_tests(@$args);
            },
        };
        1    # so that one can write  `perhaps_run_tests or something_else;`
    } else {
        ()
    }
}
1