view release on metacpan or  search on metacpan

t/9070-examples.t  view on Meta::CPAN

# The demo is run IN-PROCESS (STDOUT captured to a temp file via a 2-arg
# dup), NOT as a child via `"$^X" ... 2>&1`.  Spawning a child depends on
# $^X resolution, -I propagation and shell quoting, none of which are
# portable to every Perl 5.005_03 host; the in-process form has no such
# dependency and runs identically everywhere.
my $DEMO     = 'check_compatibility.pl';
my $has_demo = -f "$ROOT/eg/$DEMO";

# F1 + 5 checks per file (+ 2 execution checks when the demo is present)
plan_tests(1 + scalar(@eg_files) * 5 + ($has_demo ? 2 : 0));

ok(scalar(@eg_files) > 0, 'F1: eg/*.pl example files exist');

for my $name (@eg_files) {
    my $path = "$ROOT/eg/$name";
    my $src  = _slurp($path);

    ok($src =~ /^use strict\b/m,           "F2: use strict in eg/$name");
    ok($src !~ /^#!/,                       "F3: no shebang in eg/$name");
    ok($src =~ /Perl500503Syntax::OrDie/,         "F4: mentions Perl500503Syntax::OrDie in eg/$name");
    ok($src !~ /[ \t]+\n/,                  "F5: no trailing whitespace in eg/$name");
    ok($src eq '' || $src =~ /\n\z/,        "F6: ends with newline in eg/$name");
}

if ($has_demo) {
    my $out = _run_demo("$ROOT/eg/$DEMO");

    # F7: the demo reports at least one detected violation.  The broken
    #     eval/$@ form produced no VIOLATION lines at all.
    #     (Match forced to scalar context: a failed list-context match
    #      returns the empty list and would shift ok()'s arguments.)
    my $f7 = ($out =~ /VIOLATION/) ? 1 : 0;
    ok($f7, "F7: $DEMO detects and reports violations");

    # F8: the 'our' example is detected, not shown as "(not detected)".
    my $f8 = ($out =~ /'our'/ && $out !~ /\(not detected\)/) ? 1 : 0;
    ok($f8, "F8: $DEMO flags the 'our' example via the return-value API");
}

# ------------------------------------------------------------------
# _run_demo($path) - run an eg/ demo script in-process with empty
# @ARGV, capturing its STDOUT and returning it as a string.
#
# Uses only 2-arg open (Perl 5.005_03 safe).  STDOUT is duplicated to
# a save handle, redirected to a temp file, restored afterwards.  The
# demo is loaded with do(); its own warnings go to the (untouched)
# STDERR and are intentionally not captured.
# ------------------------------------------------------------------
sub _run_demo {
    my $path = shift;
    my $tmp  = File::Spec->catfile($ROOT, 't', "_demo_out.$$");

    open(_SAVEOUT, ">&STDOUT") or return '';
    unless (open(STDOUT, "> $tmp")) {
        open(STDOUT, ">&_SAVEOUT");
        close _SAVEOUT;
        return '';
    }

    {
        local @ARGV = ();
        do $path;
    }

    open(STDOUT, ">&_SAVEOUT");
    close _SAVEOUT;

    my $out = _slurp($tmp);
    unlink $tmp;
    $out = '' unless defined $out;
    return $out;
}