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