This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
96f3a7eaedcc551b9de1632a1ca16aa61986a15a
[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{ -"Mvmsish=hushed"};
32 }
33
34
35 eval { require POSIX; &POSIX::WEXITSTATUS(0) };
36 if( $@ ) {
37     *exitstatus = sub { $_[0] >> 8 };
38 }
39 else {
40     *exitstatus = sub { POSIX::WEXITSTATUS($_[0]) }
41 }
42
43
44 # Some OS' will alter the exit code to their own native sense...
45 # sometimes.  Rather than deal with the exception we'll just
46 # build up the mapping.
47 print "# Building up a map of exit codes.  May take a while.\n";
48 my %Exit_Map;
49
50 open my $fh, ">", "exit_map_test" or die $!;
51 print $fh <<'DONE';
52 if ($^O eq 'VMS') {
53     require vmsish;
54     import vmsish qw(hushed);
55 }
56 my $exit = shift;
57 print "exit $exit\n";
58 END { $? = $exit };
59 DONE
60
61 close $fh;
62 END { 1 while unlink "exit_map_test" }
63
64 for my $exit (0..255) {
65     # This correctly emulates Test::Builder's behavior.
66     my $out = qx[$Perl exit_map_test $exit];
67     $TB->like( $out, qr/^exit $exit\n/, "exit map test for $exit" );
68     $Exit_Map{$exit} = exitstatus($?);
69 }
70 print "# Done.\n";
71
72
73 my %Tests = (
74              # File                        Exit Code
75              'success.plx'              => 0,
76              'one_fail.plx'             => 1,
77              'two_fail.plx'             => 2,
78              'five_fail.plx'            => 5,
79              'extras.plx'               => 2,
80              'too_few.plx'              => 255,
81              'too_few_fail.plx'         => 2,
82              'death.plx'                => 255,
83              'last_minute_death.plx'    => 255,
84              'pre_plan_death.plx'       => 'not zero',
85              'death_in_eval.plx'        => 0,
86              'require.plx'              => 0,
87              'death_with_handler.plx'   => 255,
88              'exit.plx'                 => 1,
89             );
90
91 chdir 't';
92 my $lib = File::Spec->catdir(qw(lib Test Simple sample_tests));
93 while( my($test_name, $exit_code) = each %Tests ) {
94     my $file = File::Spec->catfile($lib, $test_name);
95     my $wait_stat = system(qq{$Perl -"I../blib/lib" -"I../lib" -"I../t/lib" $file});
96     my $actual_exit = exitstatus($wait_stat);
97
98     if( $exit_code eq 'not zero' ) {
99         $TB->isnt_num( $actual_exit, $Exit_Map{0},
100                       "$test_name exited with $actual_exit ".
101                       "(expected non-zero)");
102     }
103     else {
104         $TB->is_num( $actual_exit, $Exit_Map{$exit_code}, 
105                       "$test_name exited with $actual_exit ".
106                       "(expected $Exit_Map{$exit_code})");
107     }
108 }
109
110 $TB->done_testing( scalar keys(%Tests) + 256 );
111
112 # So any END block file cleanup works.
113 chdir $Orig_Dir;