view release on metacpan or  search on metacpan

t/0007-extcmd-env.t  view on Meta::CPAN

    my ($mode) = @_;
    my $root = File::Spec->catdir($FindBin::Bin, File::Spec->updir);
    my @hits;
    # Directories scanned (relative to the distribution root), plus the
    # top-level README.  Covers executable code (t/, eg/), the module
    # POD samples (lib/), and the 21-language reference docs (doc/), so a
    # non-portable inline-Perl one-liner cannot be reintroduced anywhere.
    my @relfiles;
    for my $sub ('t', 'eg', 'doc', 'lib', 'lib/BATsh') {
        my $dir = File::Spec->catdir($root, split(m{/}, $sub));
        next unless -d $dir;
        local *EE_DIR;
        next unless opendir(EE_DIR, $dir);
        my @names = sort grep { $_ !~ /\A\./ } readdir(EE_DIR);
        closedir(EE_DIR);
        for my $name (@names) {
            # Only canonical source files; skip backups / editor files
            # (e.g. *-OLD, *-OLD2, *.bak, *~) that may sit in the tree.
            my $ok = 0;
            if    ($sub eq 't')   { $ok = ($name =~ /\.t\z/) }
            elsif ($sub eq 'eg')  { $ok = ($name =~ /\.(?:batsh|pl)\z/) }
            elsif ($sub eq 'doc') { $ok = ($name =~ /\.txt\z/) }
            else                  { $ok = ($name =~ /\.pm\z/) }   # lib, lib/BATsh
            next unless $ok;
            push @relfiles, "$sub/$name";
        }
    }
    push @relfiles, 'README';

    for my $rel (@relfiles) {
        # This regression file documents the hazards in prose on purpose,
        # so it must not scan itself.
        next if $rel =~ /0007-extcmd-env\.t\z/;
        my $path = File::Spec->catfile($root, split(m{/}, $rel));
        next unless -f $path;
        local *EE_FH;
        next unless open(EE_FH, $path);
        my $lineno = 0;
        while (<EE_FH>) {
            $lineno++;
            my $line = $_;
            $line =~ s/[\r\n]+\z//;
            # Skip full-line comments (Perl/SH '#', CMD '::' / 'REM') so
            # prose that merely mentions perl one-liners is ignored.
            next if $line =~ /\A\s*#/;
            next if $line =~ /\A\s*::/;
            next if $line =~ /\A\s*(?:REM|rem)\b/;
            # Normalise escaped quotes from .t string literals.
            my $eff = $line;
            $eff =~ s/\\"/"/g;
            $eff =~ s/\\'/'/g;
            my $bad = 0;
            if ($mode eq 'SQ') {
                # perl <flags ending in e> followed by a single quote
                $bad = 1 if $eff =~ /\bperl\b[^|<>;&`]*?-\w*e\b\s*'/;
            }
            else {
                # perl <flags ending in e> "double-quoted-code"
                if ($eff =~ /\bperl\b[^|<>;&`]*?-\w*e\b\s*"([^"]*)"/) {
                    my $code = $1;
                    $bad = 1 if $code =~ /\$[A-Za-z_0-9{]/;
                }
            }
            push @hits, "$rel:$lineno: $line" if $bad;
        }
        close(EE_FH);
    }
    return @hits;
}

sub _capture {
    my ($code) = @_;
    my $tmpfile = File::Spec->catfile(
        File::Spec->tmpdir(), "batsh_cap7_$$\.tmp");
    open(_CAP_OLD, '>&STDOUT') or return '';
    open(_CAP_FH,  ">$tmpfile") or do { open(STDOUT, '>&_CAP_OLD'); return '' };
    open(STDOUT, '>&_CAP_FH');
    close(_CAP_FH);
    eval { $code->() };
    open(STDOUT, '>&_CAP_OLD');
    close(_CAP_OLD);
    my $buf = '';
    if (open(_CAP_RFH, "< $tmpfile")) {
        local $/;
        $buf = <_CAP_RFH>;
        close(_CAP_RFH);
    }
    unlink $tmpfile;
    $buf = '' unless defined $buf;
    return $buf;
}

print "1.." . scalar(@tests) . "\n";
my ($run, $fail) = (0, 0);
sub _ok {
    my ($ok, $name) = @_;
    $run++; $fail++ unless $ok;
    $name = '' unless defined $name;
    print +($ok ? '' : 'not ') . "ok $run - $name\n";
}
$_->() for @tests;
END { $? = 1 if $fail }