view release on metacpan or  search on metacpan

t/lib/INA_CPAN_Check.pm  view on Meta::CPAN

# ships its own perl5compat / pod / readme test file should leave them out
# rather than assert the same things twice.
#
# selfcheck_suite() is separate from the letters.  It runs the whole test
# suite in a child Perl at 'pmake dist' time and verifies the TAP each file
# emits, which is the only way to catch a plan line in the wrong place.
#
######################################################################

use strict;
BEGIN { if ($] < 5.006 && !defined(&warnings::import)) {
        $INC{'warnings.pm'} = 'stub'; eval 'package warnings; sub import {}' } }
use warnings; local $^W = 1;
BEGIN { pop @INC if $INC[-1] eq '.' }

use vars qw($VERSION @EXPORT_OK);
use Exporter ();
use vars qw(@ISA);
@ISA = qw(Exporter);

$VERSION = '0.43';
$VERSION = $VERSION;

@EXPORT_OK = qw(
    ok plan_tests diag plan_skip end_testing
    _slurp _slurp_lines _scan_code _code_only
    _manifest_files _manifest_pm_and_t _text_files _find_pm_t
    _primary_pm _lib_pm_files _pm_version _post_5005_modules
    _yaml_str _json_str
    check_A count_A
    check_B count_B
    check_C count_C
    check_D count_D
    check_E count_E
    check_F count_F
    check_G count_G
    check_H count_H
    check_I count_I
    check_J count_J
    check_K count_K
    check_L count_L
);

use vars qw($T_PLAN $T_RUN $T_FAIL
            $T_PLANNED $T_SKIPPED $T_DOUBLE $T_FINALIZED);
($T_PLAN, $T_RUN, $T_FAIL) = (0, 0, 0);
# Regression guards for two defect classes that previously slipped through
# (a test passing when run by hand but FAILing under a real TAP harness):
#   $T_PLANNED  -- a "1..N" (or SKIP) plan line has already been emitted
#   $T_SKIPPED  -- the plan was a "1..0 # SKIP"
#   $T_DOUBLE   -- plan_tests()/plan_skip() was called after a plan existed
#   $T_FINALIZED-- _finalize() has already run (END + explicit end_testing)
($T_PLANNED, $T_SKIPPED, $T_DOUBLE, $T_FINALIZED) = (0, 0, 0, 0);

use File::Spec ();

# Export all symbols into caller's namespace by default
sub import {
    my $class = shift;
    no strict 'refs';
    my $pkg = caller(0);
    for my $sym (@EXPORT_OK) {
        *{"${pkg}::${sym}"} = \&{"INA_CPAN_Check::${sym}"};
    }
}

######################################################################
# TAP helpers
######################################################################

sub plan_tests {
    # A plan line must be emitted at most once per test file. Emitting a
    # second "1..N" corrupts the TAP stream ("More than one plan found in
    # TAP output") and makes the file FAIL under a real harness even though
    # every "ok" line passes when the script is run by hand. If a plan was
    # already emitted, do NOT print another one; record the error so that
    # _finalize() reports a clear, immediate failure instead.
    if ($T_PLANNED) {
        $T_DOUBLE++;
        diag("plan_tests($_[0]) called after a plan of $T_PLAN was already "
           . "emitted; ignoring the extra plan");
        return;
    }
    $T_PLAN    = $_[0];
    $T_PLANNED = 1;
    print "1..$T_PLAN\n";
}

sub ok ($;$) {
    my ($ok, $name) = @_;
    $T_RUN++;
    $T_FAIL++ unless $ok;
    print +($ok ? '' : 'not ') . "ok $T_RUN"
        . (defined($name) && $name ne '' ? " - $name" : '') . "\n";
    return $ok;
}

sub diag {
    print "# $_[0]\n";
}

sub plan_skip {
    my ($reason) = @_;
    if ($T_PLANNED) {
        $T_DOUBLE++;
        diag("plan_skip() called after a plan was already emitted; ignoring");
        return;
    }
    $T_PLANNED = 1;
    $T_SKIPPED = 1;
    print "1..0 # SKIP $reason\n";
    exit 0;
}

# Reconcile the emitted plan with the number of assertions actually run, and
# signal failure to the harness through the exit status only. This is the
# safety net that turns the two historical defects -- a duplicate plan line
# and a plan count that does not match the number of ok() calls -- into a
# loud, immediate failure on the author's own machine, with no TAP harness
# required. exit() is never called from here: doing so from an END block
# makes Perl 5.6 and earlier abort with "Callback called exit.", which is