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