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