Commit | Line | Data |
4ea8f8fb |
1 | #!./perl |
2 | # |
3 | # Tests for Perl run-time environment variable settings |
4 | # |
5 | # $PERL5OPT, $PERL5LIB, etc. |
6 | |
7 | BEGIN { |
8 | chdir 't' if -d 't'; |
9 | @INC = '../lib'; |
27dd2420 |
10 | unless ($Config{'d_fork'}) { |
11 | print "1..0 # Skip: no fork\n"; |
12 | exit 0; |
13 | } |
4ea8f8fb |
14 | } |
15 | |
16 | my $STDOUT = './results-0'; |
17 | my $STDERR = './results-1'; |
18 | my $PERL = './perl'; |
19 | my $FAILURE_CODE = 119; |
20 | |
21 | print "1..9\n"; |
22 | |
23 | # Run perl with specified environment and arguments returns a list. |
24 | # First element is true iff Perl's stdout and stderr match the |
25 | # supplied $stdout and $stderr argument strings exactly. |
26 | # second element is an explanation of the failure |
27 | sub runperl { |
28 | local *F; |
29 | my ($env, $args, $stdout, $stderr) = @_; |
30 | |
31 | unshift @$args, '-I../lib'; |
32 | |
33 | $stdout = '' unless defined $stdout; |
34 | $stderr = '' unless defined $stderr; |
35 | my $pid = fork; |
36 | return (0, "Couldn't fork: $!") unless defined $pid; # failure |
37 | if ($pid) { # parent |
38 | my ($actual_stdout, $actual_stderr); |
39 | wait; |
40 | return (0, "Failure in child.\n") if ($?>>8) == $FAILURE_CODE; |
41 | |
42 | open F, "< $STDOUT" or return (0, "Couldn't read $STDOUT file"); |
43 | { local $/; $actual_stdout = <F> } |
44 | open F, "< $STDERR" or return (0, "Couldn't read $STDERR file"); |
45 | { local $/; $actual_stderr = <F> } |
46 | |
47 | if ($actual_stdout ne $stdout) { |
48 | return (0, "Stdout mismatch: expected [$stdout], saw [$actual_stdout]"); |
49 | } elsif ($actual_stderr ne $stderr) { |
50 | return (0, "Stderr mismatch: expected [$stderr], saw [$actual_stderr]"); |
51 | } else { |
52 | return 1; # success |
53 | } |
54 | } else { # child |
55 | for my $k (keys %$env) { |
56 | $ENV{$k} = $env->{$k}; |
57 | } |
58 | open STDOUT, "> $STDOUT" or exit $FAILURE_CODE; |
59 | open STDERR, "> $STDERR" or it_didnt_work(); |
60 | { exec $PERL, @$args } |
61 | it_didnt_work(); |
62 | } |
63 | } |
64 | |
65 | |
66 | sub it_didnt_work { |
67 | print STDOUT "IWHCWJIHCI\cNHJWCJQWKJQJWCQW\n"; |
68 | exit $FAILURE_CODE; |
69 | } |
70 | |
71 | sub try { |
72 | my $testno = shift; |
73 | my ($success, $reason) = runperl(@_); |
74 | if ($success) { |
75 | print "ok $testno\n"; |
76 | } else { |
77 | $reason =~ s/\n/\\n/g; |
78 | print "not ok $testno # $reason\n"; |
79 | } |
80 | } |
81 | |
82 | # PERL5OPT Command-line options (switches). Switches in |
83 | # this variable are taken as if they were on |
84 | # every Perl command line. Only the -[DIMUdmw] |
85 | # switches are allowed. When running taint |
86 | # checks (because the program was running setuid |
87 | # or setgid, or the -T switch was used), this |
88 | # variable is ignored. If PERL5OPT begins with |
89 | # -T, tainting will be enabled, and any |
90 | # subsequent options ignored. |
91 | |
92 | my $T = 1; |
93 | try($T++, {PERL5OPT => '-w'}, ['-e', 'print $::x'], |
94 | "", |
95 | qq{Name "main::x" used only once: possible typo at -e line 1.\nUse of uninitialized value in print at -e line 1.\n}); |
96 | |
97 | try($T++, {PERL5OPT => '-Mstrict'}, ['-e', 'print $::x'], |
98 | "", ""); |
99 | |
100 | try($T++, {PERL5OPT => '-Mstrict'}, ['-e', 'print $x'], |
101 | "", |
102 | qq{Global symbol "\$x" requires explicit package name at -e line 1.\nExecution of -e aborted due to compilation errors.\n}); |
103 | |
104 | # Fails in 5.6.0 |
105 | try($T++, {PERL5OPT => '-Mstrict -w'}, ['-e', 'print $x'], |
106 | "", |
107 | qq{Global symbol "\$x" requires explicit package name at -e line 1.\nExecution of -e aborted due to compilation errors.\n}); |
108 | |
109 | # Fails in 5.6.0 |
110 | try($T++, {PERL5OPT => '-w -Mstrict'}, ['-e', 'print $::x'], |
111 | "", |
112 | <<ERROR |
113 | Name "main::x" used only once: possible typo at -e line 1. |
114 | Use of uninitialized value in print at -e line 1. |
115 | ERROR |
116 | ); |
117 | |
118 | # Fails in 5.6.0 |
119 | try($T++, {PERL5OPT => '-w -Mstrict'}, ['-e', 'print $::x'], |
120 | "", |
121 | <<ERROR |
122 | Name "main::x" used only once: possible typo at -e line 1. |
123 | Use of uninitialized value in print at -e line 1. |
124 | ERROR |
125 | ); |
126 | |
127 | try($T++, {PERL5OPT => '-MExporter'}, ['-e0'], |
128 | "", |
129 | ""); |
130 | |
131 | # Fails in 5.6.0 |
132 | try($T++, {PERL5OPT => '-MExporter -MExporter'}, ['-e0'], |
133 | "", |
134 | ""); |
135 | |
136 | try($T++, {PERL5OPT => '-Mstrict -Mwarnings'}, |
137 | ['-e', 'print "ok" if $INC{"strict.pm"} and $INC{"warnings.pm"}'], |
138 | "ok", |
139 | ""); |
140 | |
141 | print "# ", $T-1, " tests total.\n"; |
27dd2420 |
142 | |
143 | END { |
144 | 1 while unlink $STDOUT; |
145 | 1 while unlink $STDERR; |
146 | } |