1#!/usr/bin/perl -w
2# HARNESS-NO-STREAM
3
4# Can't use Test.pm, that's a 5.005 thing.
5package My::Test;
6
7BEGIN {
8    if( $ENV{PERL_CORE} ) {
9        chdir 't';
10        @INC = '../lib';
11    }
12}
13
14require Test::Builder;
15my $TB = Test::Builder->create();
16$TB->level(0);
17
18
19package main;
20
21use Cwd;
22use File::Spec;
23
24my $Orig_Dir = cwd;
25
26my $Perl = File::Spec->rel2abs($^X);
27if( $^O eq 'VMS' ) {
28    # VMS can't use its own $^X in a system call until almost 5.8
29    $Perl = "MCR $^X" if $] < 5.007003;
30
31    # Quiet noisy 'SYS$ABORT'
32    $Perl .= q{ -"I../lib"} if $ENV{PERL_CORE};
33    $Perl .= q{ -"Mvmsish=hushed"};
34} else {
35    $Perl = qq("$Perl"); # protect from shell if spaces
36}
37
38eval { require POSIX; &POSIX::WEXITSTATUS(0) };
39if( $@ ) {
40    *exitstatus = sub { $_[0] >> 8 };
41}
42else {
43    *exitstatus = sub { POSIX::WEXITSTATUS($_[0]) }
44}
45
46
47# Some OS' will alter the exit code to their own native sense...
48# sometimes.  Rather than deal with the exception we'll just
49# build up the mapping.
50print "# Building up a map of exit codes.  May take a while.\n";
51my %Exit_Map;
52
53open my $fh, ">", "exit_map_test" or die $!;
54print $fh <<'DONE';
55if ($^O eq 'VMS') {
56    require vmsish;
57    import vmsish qw(hushed);
58}
59my $exit = shift;
60print "exit $exit\n";
61END { $? = $exit };
62DONE
63
64close $fh;
65END { 1 while unlink "exit_map_test" }
66
67for my $exit (0..255) {
68    # This correctly emulates Test::Builder's behavior.
69    my $out = qx[$Perl exit_map_test $exit];
70    $TB->like( $out, qr/^exit $exit\n/, "exit map test for $exit" );
71    $Exit_Map{$exit} = exitstatus($?);
72}
73print "# Done.\n";
74
75
76my %Tests = (
77             # File                        Exit Code
78             'success.plx'              => 0,
79             'one_fail.plx'             => 1,
80             'two_fail.plx'             => 2,
81             'five_fail.plx'            => 5,
82             'extras.plx'               => 2,
83             'too_few.plx'              => 255,
84             'too_few_fail.plx'         => 2,
85             'death.plx'                => 255,
86             'last_minute_death.plx'    => 255,
87             'pre_plan_death.plx'       => 'not zero',
88             'death_in_eval.plx'        => 0,
89             'require.plx'              => 0,
90             'death_with_handler.plx'   => 255,
91             'exit.plx'                 => 1,
92             'one_fail_without_plan.plx'    => 1,
93             'missing_done_testing.plx'     => 254,
94            );
95
96chdir 't';
97my $lib = File::Spec->catdir(qw(lib Test Simple sample_tests));
98while( my($test_name, $exit_code) = each %Tests ) {
99    my $file = File::Spec->catfile($lib, $test_name);
100    my $wait_stat = system(qq{$Perl -"I../blib/lib" -"I../lib" -"I../t/lib" $file});
101    my $actual_exit = exitstatus($wait_stat);
102
103    if( $exit_code eq 'not zero' ) {
104        $TB->isnt_num( $actual_exit, $Exit_Map{0},
105                      "$test_name exited with $actual_exit ".
106                      "(expected non-zero)");
107    }
108    else {
109        $TB->is_num( $actual_exit, $Exit_Map{$exit_code},
110                      "$test_name exited with $actual_exit ".
111                      "(expected $Exit_Map{$exit_code})");
112    }
113}
114
115$TB->done_testing( scalar keys(%Tests) + 256 );
116
117# So any END block file cleanup works.
118chdir $Orig_Dir;
119