1#!./perl
2#
3# Tests for Perl run-time environment variable settings
4# Clone of t/run/runenv.t but without the forking, and with cmd.exe-friendly -e syntax.
5#
6# $PERL5OPT, $PERL5LIB, etc.
7
8BEGIN {
9    chdir 't' if -d 't';
10    @INC = '../lib';
11    require Config; import Config;
12    require File::Temp; import File::Temp qw/:POSIX/;
13
14    require Win32;
15    ($::os_id, $::os_major) = ( Win32::GetOSVersion() )[ 4, 1 ];
16    if ($::os_id == 2 and $::os_major == 6) {    # Vista, Server 2008 (incl R2), 7
17	$::tests = 45;
18    }
19    else {
20	$::tests = 42;
21    }
22
23    require './test.pl';
24}
25
26skip_all "requires compilation with PERL_IMPLICIT_SYS"
27  unless $Config{ccflags} =~/(?:\A|\s)-DPERL_IMPLICIT_SYS\b/;
28
29plan tests => $::tests;
30
31my $PERL = '.\perl';
32my $NL = $/;
33
34delete $ENV{PERLLIB};
35delete $ENV{PERL5LIB};
36delete $ENV{PERL5OPT};
37
38
39# Run perl with specified environment and arguments, return (STDOUT, STDERR)
40sub runperl_and_capture {
41  my ($env, $args) = @_;
42
43  # Clear out old env
44  local %ENV = %ENV;
45  delete $ENV{PERLLIB};
46  delete $ENV{PERL5LIB};
47  delete $ENV{PERL5OPT};
48
49  # Populate with our desired env
50  for my $k (keys %$env) {
51     $ENV{$k} = $env->{$k};
52  }
53
54  # This is slightly expensive, but this is more reliable than
55  # trying to emulate fork(), and we still get STDERR and STDOUT individually.
56  my $stderr_cache = tmpnam();
57  my $stdout = `$PERL @$args 2>$stderr_cache`;
58  my $stderr = '';
59  if (-s $stderr_cache) {
60    open(my $stderr_cache_fh, "<", $stderr_cache)
61      or die "Could not retrieve STDERR output: $!";
62    while ( defined(my $s_line = <$stderr_cache_fh>) ) {
63      $stderr .= $s_line;
64    }
65    close $stderr_cache_fh;
66    unlink $stderr_cache;
67  }
68
69  return ($stdout, $stderr);
70}
71
72sub try {
73  my ($env, $args, $stdout, $stderr, $name) = @_;
74  my ($actual_stdout, $actual_stderr) = runperl_and_capture($env, $args);
75  $name ||= "";
76  local $::Level = $::Level + 1;
77  is $actual_stdout, $stdout, "$name - stdout";
78  is $actual_stderr, $stderr, "$name - stderr";
79}
80
81#  PERL5OPT    Command-line options (switches).  Switches in
82#                    this variable are taken as if they were on
83#                    every Perl command line.  Only the -[DIMUdmtw]
84#                    switches are allowed.  When running taint
85#                    checks (because the program was running setuid
86#                    or setgid, or the -T switch was used), this
87#                    variable is ignored.  If PERL5OPT begins with
88#                    -T, tainting will be enabled, and any
89#                    subsequent options ignored.
90
91try({PERL5OPT => '-w'}, ['-e', '"print $::x"'],
92    "",
93    qq(Name "main::x" used only once: possible typo at -e line 1.${NL}Use of uninitialized value \$x in print at -e line 1.${NL}));
94
95try({PERL5OPT => '-Mstrict'}, ['-I..\lib', '-e', '"print $::x"'],
96    "", "");
97
98try({PERL5OPT => '-Mstrict'}, ['-I..\lib', '-e', '"print $x"'],
99    "",
100    qq(Global symbol "\$x" requires explicit package name (did you forget to declare "my \$x"?) at -e line 1.${NL}Execution of -e aborted due to compilation errors.${NL}));
101
102# Fails in 5.6.0
103try({PERL5OPT => '-Mstrict -w'}, ['-I..\lib', '-e', '"print $x"'],
104    "",
105    qq(Global symbol "\$x" requires explicit package name (did you forget to declare "my \$x"?) at -e line 1.${NL}Execution of -e aborted due to compilation errors.${NL}));
106
107# Fails in 5.6.0
108try({PERL5OPT => '-w -Mstrict'}, ['-I..\lib', '-e', '"print $::x"'],
109    "",
110    <<ERROR
111Name "main::x" used only once: possible typo at -e line 1.
112Use of uninitialized value \$x in print at -e line 1.
113ERROR
114    );
115
116# Fails in 5.6.0
117try({PERL5OPT => '-w -Mstrict'}, ['-I..\lib', '-e', '"print $::x"'],
118    "",
119    <<ERROR
120Name "main::x" used only once: possible typo at -e line 1.
121Use of uninitialized value \$x in print at -e line 1.
122ERROR
123    );
124
125try({PERL5OPT => '-MExporter'}, ['-I..\lib', '-e0'],
126    "",
127    "");
128
129# Fails in 5.6.0
130try({PERL5OPT => '-MExporter -MExporter'}, ['-I..\lib', '-e0'],
131    "",
132    "");
133
134try({PERL5OPT => '-Mstrict -Mwarnings'},
135    ['-I..\lib', '-e', '"print \"ok\" if $INC{\"strict.pm\"} and $INC{\"warnings.pm\"}"'],
136    "ok",
137    "");
138
139open my $fh, ">", "Oooof.pm" or die "Can't write Oooof.pm: $!";
140print $fh "package Oooof; 1;\n";
141close $fh;
142END { 1 while unlink "Oooof.pm" }
143
144try({PERL5OPT => '-I. -MOooof'},
145    ['-e', '"print \"ok\" if $INC{\"Oooof.pm\"} eq \"Oooof.pm\""'],
146    "ok",
147    "");
148
149try({PERL5OPT => '-w -w'},
150    ['-e', '"print $ENV{PERL5OPT}"'],
151    '-w -w',
152    '');
153
154try({PERL5OPT => '-t'},
155    ['-e', '"print ${^TAINT}"'],
156    '-1',
157    '');
158
159try({PERL5OPT => '-W'},
160    ['-I..\lib','-e', '"local $^W = 0;  no warnings;  print $x"'],
161    '',
162    <<ERROR
163Name "main::x" used only once: possible typo at -e line 1.
164Use of uninitialized value \$x in print at -e line 1.
165ERROR
166);
167
168try({PERLLIB => "foobar$Config{path_sep}42"},
169    ['-e', '"print grep { $_ eq \"foobar\" } @INC"'],
170    'foobar',
171    '');
172
173try({PERLLIB => "foobar$Config{path_sep}42"},
174    ['-e', '"print grep { $_ eq \"42\" } @INC"'],
175    '42',
176    '');
177
178try({PERL5LIB => "foobar$Config{path_sep}42"},
179    ['-e', '"print grep { $_ eq \"foobar\" } @INC"'],
180    'foobar',
181    '');
182
183try({PERL5LIB => "foobar$Config{path_sep}42"},
184    ['-e', '"print grep { $_ eq \"42\" } @INC"'],
185    '42',
186    '');
187
188try({PERL5LIB => "foo",
189     PERLLIB => "bar"},
190    ['-e', '"print grep { $_ eq \"foo\" } @INC"'],
191    'foo',
192    '');
193
194try({PERL5LIB => "foo",
195     PERLLIB => "bar"},
196    ['-e', '"print grep { $_ eq \"bar\" } @INC"'],
197    '',
198    '');
199
200{
201    # 131665
202    # crashes without the fix
203    my $longname = "X" x 2048;
204    try({ $longname => 1 },
205        [ '-e', '"print q/ok/"' ],
206        'ok', '',
207        'very long env var names' );
208}
209
210# Tests for S_incpush_use_sep():
211
212my @dump_inc = ('-e', '"print \"$_\n\" foreach @INC"');
213
214my ($out, $err) = runperl_and_capture({}, [@dump_inc]);
215
216is ($err, '', 'No errors when determining @INC');
217
218my @default_inc = split /\n/, $out;
219
220if ($Config{default_inc_excludes_dot}) {
221    ok !(grep { $_ eq '.' } @default_inc), '. is not in @INC';
222}
223else {
224    is ($default_inc[-1], '.', '. is last in @INC');
225}
226
227my $sep = $Config{path_sep};
228my @test_cases = (
229	 ['nothing', ''],
230	 ['something', 'zwapp', 'zwapp'],
231	 ['two things', "zwapp${sep}bam", 'zwapp', 'bam'],
232	 ['two things, ::', "zwapp${sep}${sep}bam", 'zwapp', 'bam'],
233	 [': at start', "${sep}zwapp", 'zwapp'],
234	 [': at end', "zwapp${sep}", 'zwapp'],
235	 [':: sandwich ::', "${sep}${sep}zwapp${sep}${sep}", 'zwapp'],
236	 [':', "${sep}"],
237	 ['::', "${sep}${sep}"],
238	 [':::', "${sep}${sep}${sep}"],
239	 ['two things and :', "zwapp${sep}bam${sep}", 'zwapp', 'bam'],
240	 [': and two things', "${sep}zwapp${sep}bam", 'zwapp', 'bam'],
241	 [': two things :', "${sep}zwapp${sep}bam${sep}", 'zwapp', 'bam'],
242	 ['three things', "zwapp${sep}bam${sep}${sep}owww",
243	  'zwapp', 'bam', 'owww'],
244);
245
246# This block added to verify fix for RT #87322
247if ($::os_id == 2 and $::os_major == 6) {    # Vista, Server 2008 (incl R2), 7
248  my @big_perl5lib = ('z' x 16) x 2049;
249    push @testcases, [
250        'enough items so PERL5LIB val is longer than 32k',
251        join($sep, @big_perl5lib), @big_perl5lib,
252    ];
253}
254
255foreach ( @testcases ) {
256  my ($name, $lib, @expect) = @$_;
257  push @expect, @default_inc;
258
259  ($out, $err) = runperl_and_capture({PERL5LIB => $lib}, [@dump_inc]);
260
261  is ($err, '', "No errors when determining \@INC for $name");
262
263  my @inc = split /\n/, $out;
264
265  is (scalar @inc, scalar @expect,
266      "expected number of elements in \@INC for $name");
267
268  is ("@inc", "@expect", "expected elements in \@INC for $name");
269}
270