Commit | Line | Data |
---|---|---|
8d063cd8 LW |
1 | #!./perl |
2 | ||
90ce63d5 | 3 | BEGIN { |
90ce63d5 RS |
4 | $| = 1; |
5 | chdir 't' if -d 't'; | |
5e9f035f | 6 | require './test.pl'; |
624c42e2 | 7 | set_up_inc( '../lib' ); |
2d3b3561 | 8 | plan (tests => 208); # some tests are run in BEGIN block |
5e9f035f FC |
9 | } |
10 | ||
11 | # Test that defined() returns true for magic variables created on the fly, | |
12 | # even before they have been created. | |
13 | # This must come first, even before turning on warnings or setting up | |
14 | # $SIG{__WARN__}, to avoid invalidating the tests. warnings.pm currently | |
15 | # does not mention any special variables, but that could easily change. | |
16 | BEGIN { | |
811a7562 | 17 | # not available in miniperl |
b82b06b8 | 18 | my %non_mini = map { $_ => 1 } qw(+ - [); |
5e9f035f FC |
19 | for (qw( |
20 | SIG ^OPEN ^TAINT ^UNICODE ^UTF8LOCALE ^WARNING_BITS 1 2 3 4 5 6 7 8 | |
23496c6e | 21 | 9 42 & ` ' : ? ! _ - [ ^ ~ = % . ( ) < > \ / $ | + ; ] ^A ^C ^D |
b4155db2 | 22 | ^E ^F ^H ^I ^L ^N ^O ^P ^S ^T ^V ^W ^UTF8CACHE ::12345 main::98732 |
8561ea1d | 23 | ^LAST_FH |
5e9f035f FC |
24 | )) { |
25 | my $v = $_; | |
26 | # avoid using any global vars here: | |
27 | if ($v =~ s/^\^(?=.)//) { | |
28 | for(substr $v, 0, 1) { | |
73676ccb | 29 | $_ = chr(utf8::native_to_unicode(ord($_)) - 64); |
5e9f035f FC |
30 | } |
31 | } | |
811a7562 TC |
32 | SKIP: |
33 | { | |
34 | skip_if_miniperl("the module for *$_ may not be available in " | |
35 | . "miniperl", 1) if $non_mini{$_}; | |
36 | ok defined *$v, "*$_ appears to be defined at the outset"; | |
37 | } | |
5e9f035f FC |
38 | } |
39 | } | |
40 | ||
41 | # This must be in a separate BEGIN block, as the mere mention of ${^TAINT} | |
42 | # will invalidate the test for it. | |
43 | BEGIN { | |
0409250f | 44 | $ENV{PATH} = '/bin' if ${^TAINT}; |
774d564b | 45 | $SIG{__WARN__} = sub { die "Dying on warning: ", @_ }; |
90ce63d5 | 46 | } |
8d063cd8 | 47 | |
9f1b1f2d | 48 | use warnings; |
04fee9b5 | 49 | use Config; |
9f1b1f2d | 50 | |
0bee926d | 51 | |
43651d81 | 52 | $Is_MSWin32 = $^O eq 'MSWin32'; |
43651d81 | 53 | $Is_VMS = $^O eq 'VMS'; |
43651d81 NC |
54 | $Is_os2 = $^O eq 'os2'; |
55 | $Is_Cygwin = $^O eq 'cygwin'; | |
be708cc0 | 56 | |
463c96de | 57 | $PERL = |
2eb109a4 | 58 | ($Is_VMS ? $^X : |
60acf818 MB |
59 | $Is_MSWin32 ? '.\perl' : |
60 | './perl'); | |
68dc0745 | 61 | |
624c42e2 | 62 | |
613c63b4 CS |
63 | sub env_is { |
64 | my ($key, $val, $desc) = @_; | |
e2e1d5ce TC |
65 | |
66 | use open IN => ":raw"; | |
613c63b4 CS |
67 | if ($Is_MSWin32) { |
68 | # cmd.exe will echo 'variable=value' but 4nt will echo just the value | |
69 | # -- Nikola Knezevic | |
1070c8d6 SH |
70 | require Win32; |
71 | my $cp = Win32::GetConsoleOutputCP(); | |
72 | Win32::SetConsoleOutputCP(Win32::GetACP()); | |
615e2f77 | 73 | (my $set = `set $key 2>nul`) =~ s/\r\n$/\n/; |
1070c8d6 | 74 | Win32::SetConsoleOutputCP($cp); |
5ceaabe8 | 75 | like $set, qr/^(?:\Q$key\E=)?\Q$val\E$/, $desc; |
f8c6801b | 76 | } elsif ($Is_VMS) { |
95725928 CB |
77 | my $eqv = `write sys\$output f\$trnlnm("\Q$key\E")`; |
78 | # A single null byte in the equivalence string means | |
79 | # an undef value for Perl, so mimic that here. | |
80 | $eqv = "\n" if length($eqv) == 2 and $eqv eq "\000\n"; | |
81 | is $eqv, "$val\n", $desc; | |
613c63b4 | 82 | } else { |
ef41c525 BF |
83 | my @env = `env`; |
84 | SKIP: { | |
85 | skip("env doesn't work on this android", 1) if !@env && $^O =~ /android/; | |
86 | chomp (my @env = grep { s/^$key=// } @env); | |
87 | is "@env", $val, $desc; | |
88 | } | |
613c63b4 CS |
89 | } |
90 | } | |
91 | ||
8df0e0ed JM |
92 | END { |
93 | # On VMS, environment variable changes are peristent after perl exits | |
f8c6801b CB |
94 | if ($Is_VMS) { |
95 | delete $ENV{'FOO'}; | |
96 | delete $ENV{'__NoNeSuCh'}; | |
95725928 | 97 | delete $ENV{'__NoNeSuCh2'}; |
f8c6801b | 98 | } |
8df0e0ed JM |
99 | } |
100 | ||
39e571d4 | 101 | eval '$ENV{"FOO"} = "hi there";'; # check that ENV is inited inside eval |
26f6e342 NK |
102 | # cmd.exe will echo 'variable=value' but 4nt will echo just the value |
103 | # -- Nikola Knezevic | |
43e5ab2e | 104 | if ($Is_MSWin32) { like `set FOO`, qr/^(?:FOO=)?hi there$/m; } |
b2978f4e NC |
105 | elsif ($Is_VMS) { is `write sys\$output f\$trnlnm("FOO")`, "hi there\n"; } |
106 | else { is `echo \$FOO`, "hi there\n"; } | |
8d063cd8 | 107 | |
ba2406eb | 108 | unlink_all 'ajslkdfpqjsjfk'; |
8d063cd8 | 109 | $! = 0; |
90ce63d5 | 110 | open(FOO,'ajslkdfpqjsjfk'); |
18b6b0bf | 111 | isnt($!, 0, "Unlinked file can't be opened"); |
90ce63d5 | 112 | close FOO; # just mention it, squelch used-only-once |
8d063cd8 | 113 | |
b2978f4e NC |
114 | SKIP: { |
115 | skip('SIGINT not safe on this platform', 5) | |
4457f3fc | 116 | if $Is_MSWin32; |
c363d00c CB |
117 | # the next tests are done in a subprocess because sh spits out a |
118 | # newline onto stderr when a child process kills itself with SIGINT. | |
04fee9b5 | 119 | # We use a pipe rather than system() because the VMS command buffer |
c363d00c CB |
120 | # would overflow with a command that long. |
121 | ||
5e9f035f FC |
122 | # For easy interpolation of test numbers: |
123 | $next_test = curr_test() - 1; | |
124 | sub TIEARRAY {bless[]} | |
125 | sub FETCH { $next_test + pop } | |
126 | tie my @tn, __PACKAGE__; | |
127 | ||
0ef4ffa9 | 128 | open( CMDPIPE, "|-", $PERL); |
c363d00c | 129 | |
5e9f035f | 130 | print CMDPIPE "\$t1 = $tn[1]; \$t2 = $tn[2];\n", <<'END'; |
378cc40b | 131 | |
79072805 | 132 | $| = 1; # command buffering |
378cc40b | 133 | |
5e9f035f FC |
134 | $SIG{"INT"} = "ok1"; kill "INT",$$; sleep 1; |
135 | $SIG{"INT"} = "IGNORE"; kill "INT",$$; sleep 1; print "ok $t2\n"; | |
136 | $SIG{"INT"} = "DEFAULT"; kill "INT",$$; sleep 1; print" not ok $t2\n"; | |
79072805 | 137 | |
5e9f035f | 138 | sub ok1 { |
79072805 | 139 | if (($x = pop(@_)) eq "INT") { |
5e9f035f | 140 | print "ok $t1\n"; |
79072805 LW |
141 | } |
142 | else { | |
5e9f035f | 143 | print "not ok $t1 ($x @_)\n"; |
79072805 LW |
144 | } |
145 | } | |
146 | ||
147 | END | |
c363d00c CB |
148 | |
149 | close CMDPIPE; | |
150 | ||
0ef4ffa9 | 151 | open( CMDPIPE, "|-", $PERL); |
5e9f035f | 152 | print CMDPIPE "\$t3 = $tn[3];\n", <<'END'; |
2d4fcd5e AJ |
153 | |
154 | { package X; | |
155 | sub DESTROY { | |
156 | kill "INT",$$; | |
157 | } | |
158 | } | |
159 | sub x { | |
160 | my $x=bless [], 'X'; | |
161 | return sub { $x }; | |
162 | } | |
163 | $| = 1; # command buffering | |
5e9f035f | 164 | $SIG{"INT"} = "ok3"; |
2d4fcd5e AJ |
165 | { |
166 | local $SIG{"INT"}=x(); | |
167 | print ""; # Needed to expose failure in 5.8.0 (why?) | |
168 | } | |
169 | sleep 1; | |
170 | delete $SIG{"INT"}; | |
171 | kill "INT",$$; sleep 1; | |
5e9f035f FC |
172 | sub ok3 { |
173 | print "ok $t3\n"; | |
2d4fcd5e AJ |
174 | } |
175 | END | |
176 | close CMDPIPE; | |
bb4e15c8 | 177 | $? >>= 8 if $^O eq 'VMS'; # POSIX status hiding in 2nd byte |
639cf43b | 178 | my $todo = ($^O eq 'os2' ? ' # TODO: EMX v0.9d_fix4 bug: wrong nibble? ' : ''); |
b5b6faf3 | 179 | $todo = ($Config{usecrosscompile} ? '# TODO: Not sure whats going on here when cross-compiling' : ''); |
5e9f035f | 180 | print $? & 0xFF ? "ok $tn[4]$todo\n" : "not ok $tn[4]$todo\n"; |
2d4fcd5e | 181 | |
0ef4ffa9 | 182 | open(CMDPIPE, "|-", $PERL); |
6e592b3a BM |
183 | print CMDPIPE <<'END'; |
184 | ||
185 | sub PVBM () { 'foo' } | |
186 | index 'foo', PVBM; | |
187 | my $pvbm = PVBM; | |
188 | ||
189 | sub foo { exit 0 } | |
190 | ||
191 | $SIG{"INT"} = $pvbm; | |
192 | kill "INT", $$; sleep 1; | |
193 | END | |
194 | close CMDPIPE; | |
195 | $? >>= 8 if $^O eq 'VMS'; | |
5e9f035f | 196 | print $? ? "not ok $tn[5]\n" : "ok $tn[5]\n"; |
6e592b3a | 197 | |
b2978f4e | 198 | curr_test(curr_test() + 5); |
68dc0745 | 199 | } |
a687059c | 200 | |
68dc0745 | 201 | # can we slice ENV? |
202 | @val1 = @ENV{keys(%ENV)}; | |
a687059c | 203 | @val2 = values(%ENV); |
b2978f4e NC |
204 | is join(':',@val1), join(':',@val2); |
205 | cmp_ok @val1, '>', 1; | |
90ce63d5 | 206 | |
cf93a474 FC |
207 | # deleting $::{ENV} |
208 | is runperl(prog => 'delete $::{ENV}; chdir; print qq-ok\n-'), "ok\n", | |
209 | 'deleting $::{ENV}'; | |
210 | ||
90ce63d5 RS |
211 | # regex vars |
212 | 'foobarbaz' =~ /b(a)r/; | |
b2978f4e NC |
213 | is $`, 'foo'; |
214 | is $&, 'bar'; | |
215 | is $', 'baz'; | |
216 | is $+, 'a'; | |
90ce63d5 | 217 | |
a289ef89 FC |
218 | # [perl #24237] |
219 | for (qw < ` & ' >) { | |
220 | fresh_perl_is | |
221 | qq < \@$_; q "fff" =~ /(?!^)./; print "[\$$_]\\n" >, | |
222 | "[f]\n", {}, | |
223 | "referencing \@$_ before \$$_ etc. still saws off ampersands"; | |
224 | } | |
225 | ||
90ce63d5 RS |
226 | # $" |
227 | @a = qw(foo bar baz); | |
b2978f4e | 228 | is "@a", "foo bar baz"; |
90ce63d5 RS |
229 | { |
230 | local $" = ','; | |
b2978f4e | 231 | is "@a", "foo,bar,baz"; |
90ce63d5 | 232 | } |
a687059c | 233 | |
90ce63d5 RS |
234 | # $; |
235 | %h = (); | |
236 | $h{'foo', 'bar'} = 1; | |
b2978f4e | 237 | is((keys %h)[0], "foo\034bar"); |
90ce63d5 RS |
238 | { |
239 | local $; = 'x'; | |
240 | %h = (); | |
241 | $h{'foo', 'bar'} = 1; | |
b2978f4e | 242 | is((keys %h)[0], 'fooxbar'); |
90ce63d5 | 243 | } |
ed6116ce | 244 | |
90ce63d5 | 245 | # $?, $@, $$ |
7b903762 RGS |
246 | system qq[$PERL "-I../lib" -e "use vmsish qw(hushed); exit(0)"]; |
247 | is $?, 0; | |
248 | system qq[$PERL "-I../lib" -e "use vmsish qw(hushed); exit(1)"]; | |
249 | isnt $?, 0; | |
90ce63d5 RS |
250 | |
251 | eval { die "foo\n" }; | |
b2978f4e | 252 | is $@, "foo\n"; |
90ce63d5 | 253 | |
d456e3f4 FC |
254 | ok !*@{HASH}, 'no %@'; |
255 | ||
b2978f4e | 256 | cmp_ok($$, '>', 0); |
41e07bbc | 257 | my $pid = $$; |
9cdac2a2 FC |
258 | eval { $$ = 42 }; |
259 | is $$, 42, '$$ can be modified'; | |
260 | SKIP: { | |
261 | skip "no fork", 1 unless $Config{d_fork}; | |
262 | (my $kidpid = open my $fh, "-|") // skip "cannot fork: $!", 1; | |
263 | if($kidpid) { # parent | |
264 | my $kiddollars = <$fh>; | |
265 | close $fh or die "cannot close pipe from kid proc: $!"; | |
266 | is $kiddollars, $kidpid, '$$ is reset on fork'; | |
267 | } | |
268 | else { # child | |
269 | print $$; | |
270 | $::NO_ENDING = 1; # silence "Looks like you only ran..." | |
271 | exit; | |
272 | } | |
273 | } | |
41e07bbc | 274 | $$ = $pid; # Tests below use $$ |
90ce63d5 RS |
275 | |
276 | # $^X and $0 | |
ed37317b | 277 | { |
ae60cb46 NC |
278 | my $is_abs = $Config{d_procselfexe} || $Config{usekernprocpathname} |
279 | || $Config{usensgetexecutablepath}; | |
3e3baf6d | 280 | if ($^O eq 'qnx') { |
7fbf1995 | 281 | chomp($wd = `/usr/bin/fullpath -t`); |
68dc0745 | 282 | } |
b58c24b0 BF |
283 | elsif($^O =~ /android/) { |
284 | chomp($wd = `sh -c 'pwd'`); | |
285 | } | |
2982a345 | 286 | elsif($Is_Cygwin || $is_abs) { |
1cab015a EF |
287 | # Cygwin turns the symlink into the real file |
288 | chomp($wd = `pwd`); | |
289 | $wd =~ s#/t$##; | |
0409250f | 290 | $wd =~ /(.*)/; $wd = $1; # untaint |
6178c52a JH |
291 | if ($Is_Cygwin) { |
292 | $wd = Cygwin::win_to_posix_path(Cygwin::posix_to_win_path($wd, 1)); | |
293 | } | |
1cab015a | 294 | } |
ed344e4f IZ |
295 | elsif($Is_os2) { |
296 | $wd = Cwd::sys_cwd(); | |
297 | } | |
68dc0745 | 298 | else { |
299 | $wd = '.'; | |
300 | } | |
2982a345 | 301 | my $perl = $Is_VMS || $is_abs ? $^X : "$wd/perl"; |
ed37317b | 302 | my $headmaybe = ''; |
6178c52a | 303 | my $middlemaybe = ''; |
ed37317b | 304 | my $tailmaybe = ''; |
68dc0745 | 305 | $script = "$wd/show-shebang"; |
ed37317b TB |
306 | if ($Is_MSWin32) { |
307 | chomp($wd = `cd`); | |
8ac9c18d GS |
308 | $wd =~ s|\\|/|g; |
309 | $perl = "$wd/perl.exe"; | |
310 | $script = "$wd/show-shebang.bat"; | |
ed37317b TB |
311 | $headmaybe = <<EOH ; |
312 | \@rem =' | |
313 | \@echo off | |
314 | $perl -x \%0 | |
315 | goto endofperl | |
316 | \@rem '; | |
317 | EOH | |
318 | $tailmaybe = <<EOT ; | |
319 | ||
320 | __END__ | |
321 | :endofperl | |
322 | EOT | |
323 | } | |
ed344e4f IZ |
324 | elsif ($Is_os2) { |
325 | $script = "./show-shebang"; | |
326 | } | |
c363d00c CB |
327 | elsif ($Is_VMS) { |
328 | $script = "[]show-shebang"; | |
be708cc0 | 329 | } |
6178c52a JH |
330 | elsif ($Is_Cygwin) { |
331 | $middlemaybe = <<'EOX' | |
332 | $^X = Cygwin::win_to_posix_path(Cygwin::posix_to_win_path($^X, 1)); | |
333 | $0 = Cygwin::win_to_posix_path(Cygwin::posix_to_win_path($0, 1)); | |
334 | EOX | |
335 | } | |
043fec90 | 336 | if ($^O eq 'os390' or $^O eq 'posix-bc') { # no shebang |
9d116dd7 JH |
337 | $headmaybe = <<EOH ; |
338 | eval 'exec ./perl -S \$0 \${1+"\$\@"}' | |
339 | if 0; | |
340 | EOH | |
341 | } | |
2eecd615 | 342 | $s1 = "\$^X is $perl, \$0 is $script\n"; |
0409250f | 343 | ok open(SCRIPT, ">$script") or diag "Can't write to $script: $!"; |
b2978f4e | 344 | ok print(SCRIPT $headmaybe . <<EOB . $middlemaybe . <<'EOF' . $tailmaybe) or diag $!; |
0f77baf6 | 345 | #!$perl |
774d564b | 346 | EOB |
90ce63d5 RS |
347 | print "\$^X is $^X, \$0 is $0\n"; |
348 | EOF | |
b2978f4e NC |
349 | ok close(SCRIPT) or diag $!; |
350 | ok chmod(0755, $script) or diag $!; | |
7b903762 | 351 | $_ = $Is_VMS ? `$perl $script` : `$script`; |
4457f3fc | 352 | s/\.exe//i if $Is_Cygwin or $Is_os2; |
ed37317b | 353 | s{is perl}{is $perl}; # for systems where $^X is only a basename |
a6c40364 | 354 | s{\\}{/}g; |
b2978f4e NC |
355 | if ($Is_MSWin32 || $Is_os2) { |
356 | is uc $_, uc $s1; | |
357 | } else { | |
d18d7217 PG |
358 | SKIP: |
359 | { | |
360 | skip "# TODO: Hit bug posix-2058; exec does not setup argv[0] correctly." if ($^O eq "vos"); | |
361 | is $_, $s1; | |
362 | } | |
b2978f4e | 363 | } |
ed37317b | 364 | $_ = `$perl $script`; |
4457f3fc | 365 | s/\.exe//i if $Is_os2 or $Is_Cygwin; |
a6c40364 | 366 | s{\\}{/}g; |
b2978f4e NC |
367 | if ($Is_MSWin32 || $Is_os2) { |
368 | is uc $_, uc $s1; | |
369 | } else { | |
370 | is $_, $s1; | |
371 | } | |
372 | ok unlink($script) or diag $!; | |
ba2406eb BG |
373 | # CHECK |
374 | # Could this be replaced with: | |
375 | # unlink_all($script); | |
68dc0745 | 376 | } |
ed6116ce | 377 | |
90ce63d5 | 378 | # $], $^O, $^T |
b2978f4e | 379 | cmp_ok $], '>=', 5.00319; |
0bee926d | 380 | ok $^O; |
b2978f4e | 381 | cmp_ok $^T, '>', 850000000; |
66b1d557 | 382 | |
881ddac4 SH |
383 | # Test change 25062 is working |
384 | my $orig_osname = $^O; | |
385 | { | |
386 | local $^I = '.bak'; | |
b2978f4e | 387 | is $^O, $orig_osname, 'Assigning $^I does not clobber $^O'; |
881ddac4 SH |
388 | } |
389 | $^O = $orig_osname; | |
390 | ||
065144c6 TC |
391 | { |
392 | #RT #72422 | |
393 | foreach my $p (0, 1) { | |
394 | fresh_perl_is(<<"EOP", '2 4 8', undef, "test \$^P = $p"); | |
395 | \$DB::single = 2; | |
396 | \$DB::trace = 4; | |
397 | \$DB::signal = 8; | |
398 | \$^P = $p; | |
399 | print "\$DB::single \$DB::trace \$DB::signal"; | |
400 | EOP | |
401 | } | |
402 | } | |
403 | ||
7636ea95 AB |
404 | # Check that assigning to $0 on Linux sets the process name with both |
405 | # argv[0] assignment and by calling prctl() | |
406 | { | |
407 | SKIP: { | |
fca083c4 | 408 | skip "We don't have prctl() here, or we're on Android", 2 unless $Config{d_prctl_set_name} && $^O ne 'android'; |
7636ea95 AB |
409 | |
410 | # We don't really need these tests. prctl() is tested in the | |
411 | # Kernel, but test it anyway for our sanity. If something doesn't | |
412 | # work (like if the system doesn't have a ps(1) for whatever | |
413 | # reason) just bail out gracefully. | |
414 | my $maybe_ps = sub { | |
415 | my ($cmd) = @_; | |
416 | local ($?, $!); | |
417 | ||
418 | no warnings; | |
419 | my $res = `$cmd`; | |
3a46d15c | 420 | skip "Couldn't shell out to '$cmd', returned code $?", 2 if $?; |
7636ea95 AB |
421 | return $res; |
422 | }; | |
423 | ||
424 | my $name = "Good Morning, Dave"; | |
425 | $0 = $name; | |
426 | ||
427 | chomp(my $argv0 = $maybe_ps->("ps h $$")); | |
428 | chomp(my $prctl = $maybe_ps->("ps hc $$")); | |
429 | ||
aaa63dae | 430 | my $name_substr = substr($name, 0, 15); |
72d0a0a0 TC |
431 | my $argv0_match = (grep(/$name/, split /\n/, $argv0), "")[0]; |
432 | my $prctl_match = (grep(/$name_substr/, split /\n/, $prctl), "")[0]; | |
433 | ||
434 | like($argv0, qr/$name/, "Set process name through argv[0] ($argv0_match)"); | |
435 | like($prctl, qr/$name_substr/, "Set process name through prctl() ($prctl_match)"); | |
7636ea95 AB |
436 | } |
437 | } | |
438 | ||
2d3b3561 | 439 | # Check that assigning to $0 properly handles UTF-8-stored strings: |
855c15d3 | 440 | SKIP: |
2d3b3561 | 441 | { |
855c15d3 TC |
442 | # setproctitle() misbehaves on dragonfly |
443 | # https://bugs.dragonflybsd.org/issues/3319 | |
444 | # https://github.com/Perl/perl5/issues/19894 | |
445 | skip "setproctitle() is flaky on DragonflyBSD", 11 | |
446 | if $^O eq "dragonfly"; | |
2d3b3561 FG |
447 | # Test both ASCII and EBCDIC systems: |
448 | my $char = chr( utf8::native_to_unicode(0xe9) ); | |
449 | ||
450 | # We want $char_with_utf8_pv's PV to be UTF-8-encoded because we need to | |
451 | # test that Perl translates UTF-8-stored code points to plain octets when | |
452 | # assigning to $0. | |
453 | # | |
454 | my $char_with_utf8_pv = $char; | |
455 | utf8::upgrade($char_with_utf8_pv); | |
456 | ||
457 | # This will be the same logical code point as $char_with_utf8_pv, but | |
458 | # implemented in Perl internally as a raw byte rather than UTF-8. | |
459 | # (NB: $char is *probably* already utf8::downgrade()d, but let's not | |
460 | # assume that to be the case.) | |
461 | # | |
462 | my $char_with_plain_pv = $char; | |
463 | utf8::downgrade($char_with_plain_pv); | |
464 | ||
465 | $0 = $char_with_utf8_pv; | |
466 | ||
467 | # In case the assignment to $0 changed $char_with_utf8_pv, ensure that | |
468 | # it is still interally double-UTF-8-encoded: | |
469 | # | |
470 | utf8::upgrade($char_with_utf8_pv); | |
471 | ||
472 | is ($0, $char_with_utf8_pv, 'compare $0 to UTF8-flagged'); | |
473 | is ($0, $char_with_plain_pv, 'compare $0 to non-UTF8-flagged'); | |
474 | ||
475 | my $linux_cmdline_cr = sub { | |
ebd227f2 YO |
476 | my $skip = shift // 1; |
477 | open my $rfh, '<', "/proc/$$/cmdline" | |
478 | or skip "failed to read '/proc/$$/cmdline': $!", $skip; | |
479 | my $got = do { local $/; <$rfh> }; | |
4cae439d FG |
480 | |
481 | # Some kernels leave a trailing NUL on. Some add a bunch of spaces | |
482 | # after that NUL. We want neither. | |
8c2d1e72 FG |
483 | # |
484 | # A selection of kernels/distros tested: | |
485 | # | |
486 | # 4.18.0-348.20.1.el8_5.x86_64 (AlmaLinux 8.5): NUL then spaces | |
06d31977 | 487 | # 4.18.0-348.23.1.el8_5.x86_64 (AlmaLinux 8.5): NUL, spaces, then NUL |
8c2d1e72 FG |
488 | # 3.10.0-1160.62.1.el7.x86_64 (CentOS 7.9.2009): no NUL nor spaces |
489 | # 2.6.32-954.3.5.lve1.4.87.el6.x86_64 (CloudLinux 6.10): ^^ ditto | |
490 | # | |
491 | # 5.13.0-1025-raspi (Ubuntu 21.10): NUL only | |
492 | # 5.10.103-v7+ (RaspiOS 10): NUL only | |
493 | # | |
06d31977 | 494 | $got =~ s/\0[\s\0]*\z//; |
4cae439d | 495 | |
ebd227f2 | 496 | return $got; |
2d3b3561 FG |
497 | }; |
498 | ||
499 | SKIP: { | |
ebd227f2 YO |
500 | my $skip_tests = 2; |
501 | skip "Test is for Linux, not $^O", $skip_tests if $^O ne 'linux'; | |
502 | my $slurp = $linux_cmdline_cr->($skip_tests); | |
503 | is( $slurp, $char_with_utf8_pv, | |
504 | '/proc cmdline shows as expected (compare to UTF8-flagged)' ); | |
505 | is( $slurp, $char_with_plain_pv, | |
506 | '/proc cmdline shows as expected (compare to non-UTF8-flagged)' ); | |
2d3b3561 FG |
507 | } |
508 | ||
509 | my $name_unicode = "haha\x{100}hoho"; | |
510 | ||
511 | my $name_utf8_bytes = $name_unicode; | |
512 | utf8::encode($name_utf8_bytes); | |
513 | ||
514 | my @warnings; | |
515 | { | |
516 | local $SIG{'__WARN__'} = sub { push @warnings, @_ }; | |
517 | $0 = $name_unicode; | |
518 | } | |
519 | ||
520 | is( 0 + @warnings, 1, 'warning after assignment of wide character' ); | |
521 | like( $warnings[0], qr<wide>i, '.. and the warning is about a wide character' ); | |
522 | is( $0, $name_utf8_bytes, '.. and the UTF-8 version is written' ); | |
523 | ||
524 | SKIP: { | |
ebd227f2 | 525 | my $skip_tests = 1; |
2d3b3561 | 526 | skip "Test is for Linux, not $^O" if $^O ne 'linux'; |
ebd227f2 | 527 | is( $linux_cmdline_cr->($skip_tests), $name_utf8_bytes, '.. and /proc cmdline shows that'); |
2d3b3561 FG |
528 | } |
529 | ||
530 | @warnings = (); | |
531 | local $SIG{'__WARN__'} = sub { push @warnings, @_ }; | |
532 | { local $0 = "alpha"; } | |
533 | is( 0 + @warnings, 0, '$0 from wide -> local non-wide: no warning'); | |
534 | ||
535 | { local $0 = "$name_unicode-redux" } | |
536 | is( 0 + @warnings, 1, 'one warning: wide -> local wide' ); | |
537 | ||
538 | $0 = "aaaa"; | |
539 | @warnings = (); | |
540 | { local $0 = "$name_unicode-redux" } | |
541 | is( 0 + @warnings, 1, 'one warning: non-wide -> local wide' ); | |
542 | } | |
543 | ||
c7213721 | 544 | { |
a45269de MS |
545 | my $ok = 1; |
546 | my $warn = ''; | |
ae8ade65 | 547 | local $SIG{'__WARN__'} = sub { $ok = 0; $warn = join '', @_; $warn =~ s/\n$//; }; |
78987ded | 548 | $! = undef; |
b2978f4e NC |
549 | local $TODO = $Is_VMS ? "'\$!=undef' does throw a warning" : ''; |
550 | ok($ok, $warn); | |
78987ded HS |
551 | } |
552 | ||
b2978f4e | 553 | SKIP: { |
d3d1232e | 554 | skip_if_miniperl("miniperl can't rely on loading %Errno", 2); |
126c71c8 YST |
555 | no warnings 'void'; |
556 | ||
d2c93421 RH |
557 | # Make sure Errno hasn't been prematurely autoloaded |
558 | ||
b79f7545 | 559 | ok !keys %Errno::; |
d2c93421 RH |
560 | |
561 | # Test auto-loading of Errno when %! is used | |
562 | ||
126c71c8 YST |
563 | ok scalar eval q{ |
564 | %!; | |
902fde96 | 565 | scalar %Errno::; |
126c71c8 YST |
566 | }, $@; |
567 | } | |
d2c93421 | 568 | |
b2978f4e | 569 | SKIP: { |
ffdb8bcd | 570 | skip_if_miniperl("miniperl can't rely on loading %Errno", 2); |
43651d81 | 571 | # Make sure that Errno loading doesn't clobber $! |
d2c93421 | 572 | |
43651d81 NC |
573 | undef %Errno::; |
574 | delete $INC{"Errno.pm"}; | |
e94ea821 | 575 | delete $::{"!"}; |
d2c93421 | 576 | |
43651d81 NC |
577 | open(FOO, "nonesuch"); # Generate ENOENT |
578 | my %errs = %{"!"}; # Cause Errno.pm to be loaded at run-time | |
579 | ok ${"!"}{ENOENT}; | |
ffdb8bcd FC |
580 | |
581 | # Make sure defined(*{"!"}) before %! does not stop %! from working | |
582 | is | |
583 | runperl( | |
584 | prog => 'BEGIN { defined *{q-!-} } print qq-ok\n- if tied %!', | |
585 | ), | |
586 | "ok\n", | |
587 | 'defined *{"!"} does not stop %! from working'; | |
43651d81 | 588 | } |
a4268c0a | 589 | |
ccdda9cb | 590 | # Check that we don't auto-load packages |
d88d17cb | 591 | foreach (['powie::!', 'Errno']) { |
88348cbd SH |
592 | my ($symbol, $package) = @$_; |
593 | SKIP: { | |
594 | (my $extension = $package) =~ s|::|/|g; | |
595 | skip "$package is statically linked", 2 | |
596 | if $Config{static_ext} =~ m|\b\Q$extension\E\b|; | |
976bd1ee DM |
597 | foreach my $scalar_first ('', '$$symbol;') { |
598 | my $desc = qq{Referencing %{"$symbol"}}; | |
599 | $desc .= qq{ after mentioning \${"$symbol"}} if $scalar_first; | |
600 | $desc .= " doesn't load $package"; | |
601 | ||
602 | fresh_perl_is(<<"EOP", 0, {}, $desc); | |
ccdda9cb NC |
603 | use strict qw(vars subs); |
604 | my \$symbol = '$symbol'; | |
605 | $scalar_first; | |
606 | 1 if %{\$symbol}; | |
607 | print scalar %${package}::; | |
608 | EOP | |
976bd1ee | 609 | } |
ccdda9cb NC |
610 | } |
611 | } | |
612 | ||
b2978f4e NC |
613 | is $^S, 0; |
614 | eval { is $^S,1 }; | |
b0e6f864 | 615 | eval " BEGIN { ok ! defined \$^S } "; |
b2978f4e | 616 | is $^S, 0; |
7c36658b | 617 | |
0409250f RGS |
618 | my $taint = ${^TAINT}; |
619 | is ${^TAINT}, $taint; | |
7c36658b | 620 | eval { ${^TAINT} = 1 }; |
0409250f | 621 | is ${^TAINT}, $taint; |
9aa702ec MJD |
622 | |
623 | # 5.6.1 had a bug: @+ and @- were not properly interpolated | |
624 | # into double-quoted strings | |
625 | # 20020414 mjd-perl-patch+@plover.com | |
b64ebf53 | 626 | "I like pie" =~ /(I) (like) (pie)/; |
b2978f4e NC |
627 | is "@-", "0 0 2 7"; |
628 | is "@+", "10 1 6 10"; | |
9aa702ec | 629 | |
f28098ff RGS |
630 | # Tests for the magic get of $\ |
631 | { | |
632 | my $ok = 0; | |
633 | # [perl #19330] | |
634 | { | |
635 | local $\ = undef; | |
636 | $\++; $\++; | |
637 | $ok = $\ eq 2; | |
638 | } | |
639 | ok $ok; | |
640 | $ok = 0; | |
641 | { | |
642 | local $\ = "a\0b"; | |
643 | $ok = "a$\b" eq "aa\0bb"; | |
644 | } | |
645 | ok $ok; | |
646 | } | |
547d1dd8 | 647 | |
4c9140ed | 648 | # Test for bug [perl #36434] |
822c8b4d | 649 | # Can not do this test on VMS according to comments |
b2978f4e NC |
650 | # in mg.c/Perl_magic_clear_all_env() |
651 | SKIP: { | |
652 | skip('Can\'t make assignment to \%ENV on this system', 3) if $Is_VMS; | |
653 | ||
4c9140ed RGS |
654 | local @ISA; |
655 | local %ENV; | |
e1a479c5 BB |
656 | # This used to be __PACKAGE__, but that causes recursive |
657 | # inheritance, which is detected earlier now and broke | |
658 | # this test | |
659 | eval { push @ISA, __FILE__ }; | |
b2978f4e | 660 | is $@, '', 'Push a constant on a magic array'; |
4c9140ed RGS |
661 | $@ and print "# $@"; |
662 | eval { %ENV = (PATH => __PACKAGE__) }; | |
b2978f4e | 663 | is $@, '', 'Assign a constant to a magic hash'; |
d8084ca5 DM |
664 | $@ and print "# $@"; |
665 | eval { my %h = qw(A B); %ENV = (PATH => (keys %h)[0]) }; | |
b2978f4e | 666 | is $@, '', 'Assign a shared key to a magic hash'; |
4c9140ed RGS |
667 | $@ and print "# $@"; |
668 | } | |
179c85a2 NC |
669 | |
670 | # Tests for Perl_magic_clearsig | |
671 | foreach my $sig (qw(__WARN__ INT)) { | |
672 | $SIG{$sig} = lc $sig; | |
673 | is $SIG{$sig}, 'main::' . lc $sig, "Can assign to $sig"; | |
674 | is delete $SIG{$sig}, 'main::' . lc $sig, "Can delete from $sig"; | |
675 | is $SIG{$sig}, undef, "$sig is now gone"; | |
676 | is delete $SIG{$sig}, undef, "$sig remains gone"; | |
677 | } | |
678 | ||
679 | # And now one which doesn't exist; | |
680 | { | |
681 | no warnings 'signal'; | |
682 | $SIG{HUNGRY} = 'mmm, pie'; | |
683 | } | |
684 | is $SIG{HUNGRY}, 'mmm, pie', 'Can assign to HUNGRY'; | |
685 | is delete $SIG{HUNGRY}, 'mmm, pie', 'Can delete from HUNGRY'; | |
686 | is $SIG{HUNGRY}, undef, "HUNGRY is now gone"; | |
687 | is delete $SIG{HUNGRY}, undef, "HUNGRY remains gone"; | |
688 | ||
689 | # Test deleting signals that we never set | |
c8be058c | 690 | foreach my $sig (qw(__DIE__ _BOGUS_HOOK KILL THIRSTY)) { |
179c85a2 NC |
691 | is $SIG{$sig}, undef, "$sig is not present"; |
692 | is delete $SIG{$sig}, undef, "delete of $sig returns undef"; | |
693 | } | |
be1cf43c NC |
694 | |
695 | { | |
696 | $! = 9999; | |
697 | is int $!, 9999, q{[perl #72850] Core dump in bleadperl from perl -e '$! = 9999; $a = $!;'}; | |
698 | ||
699 | } | |
4c0f30d6 | 700 | |
213084e4 FC |
701 | # %+ %- |
702 | SKIP: { | |
afb8fe69 | 703 | skip_if_miniperl("No XS in miniperl", 2); |
213084e4 FC |
704 | # Make sure defined(*{"+"}) before %+ does not stop %+ from working |
705 | is | |
706 | runperl( | |
707 | prog => 'BEGIN { defined *{q-+-} } print qq-ok\n- if tied %+', | |
708 | ), | |
709 | "ok\n", | |
710 | 'defined *{"+"} does not stop %+ from working'; | |
711 | is | |
712 | runperl( | |
713 | prog => 'BEGIN { defined *{q=-=} } print qq-ok\n- if tied %-', | |
714 | ), | |
715 | "ok\n", | |
716 | 'defined *{"-"} does not stop %- from working'; | |
717 | } | |
718 | ||
0ea03996 | 719 | SKIP: { |
d88d17cb | 720 | skip_if_miniperl("No XS in miniperl", 1); |
0ea03996 | 721 | |
d88d17cb | 722 | for ( [qw( %! Errno )] ) { |
0ea03996 FC |
723 | my ($var, $mod) = @$_; |
724 | my $modfile = $mod =~ s|::|/|gr . ".pm"; | |
725 | fresh_perl_is | |
726 | qq 'sub UNIVERSAL::AUTOLOAD{} | |
727 | $mod\::foo() if 0; | |
728 | $var; | |
729 | print "ok\\n" if \$INC{"$modfile"}', | |
730 | "ok\n", | |
731 | { switches => [ '-X' ] }, | |
732 | "$var still loads $mod when stash and UNIVERSAL::AUTOLOAD exist"; | |
733 | } | |
734 | } | |
735 | ||
8561ea1d FC |
736 | # ${^LAST_FH} |
737 | () = tell STDOUT; | |
738 | is ${^LAST_FH}, \*STDOUT, '${^LAST_FH} after tell'; | |
739 | () = tell STDIN; | |
740 | is ${^LAST_FH}, \*STDIN, '${^LAST_FH} after another tell'; | |
741 | { | |
742 | my $fh = *STDOUT; | |
743 | () = tell $fh; | |
744 | is ${^LAST_FH}, \$fh, '${^LAST_FH} referencing lexical coercible glob'; | |
745 | } | |
746 | # This also tests that ${^LAST_FH} is a weak reference: | |
747 | is ${^LAST_FH}, undef, '${^LAST_FH} is undef when PL_last_in_gv is NULL'; | |
748 | ||
745e740c TC |
749 | # all of these would set PL_last_in_gv to a non-GV which would |
750 | # assert when referenced by the magic for ${^LAST_FH}. | |
745e740c TC |
751 | # The approach to fixing this has changed (#128263), but it's still useful |
752 | # to check each op. | |
753 | for my $code ('tell $0', 'sysseek $0, 0, 0', 'seek $0, 0, 0', 'eof $0') { | |
754 | fresh_perl_is("$code; print defined \${^LAST_FH} ? qq(not ok\n) : qq(ok\n)", "ok\n", | |
755 | undef, "check $code doesn't define \${^LAST_FH}"); | |
756 | } | |
8561ea1d | 757 | |
8f25f6c0 | 758 | # $| |
60acf818 | 759 | fresh_perl_is 'print $| = ~$|', "1\n", {switches => ['-l']}, |
8f25f6c0 | 760 | '[perl #4760] print $| = ~$|'; |
4505a31f | 761 | fresh_perl_is |
60acf818 | 762 | 'select f; undef *f; ${q/|/}; print STDOUT qq|ok\n|', "ok\n", {}, |
4505a31f | 763 | '[perl #115206] no crash when vivifying $| while *{+select}{IO} is undef'; |
8f25f6c0 | 764 | |
1c75beb8 FC |
765 | # ${^OPEN} and $^H interaction |
766 | # Setting ${^OPEN} causes $^H to change, but setting $^H would only some- | |
767 | # times make ${^OPEN} change, depending on whether it was in the same BEGIN | |
768 | # block. Don’t test actual values (subject to change); just test for | |
769 | # consistency. | |
770 | my @stuff; | |
771 | eval ' | |
772 | BEGIN { ${^OPEN} = "a\0b"; $^H = 0; push @stuff, ${^OPEN} } | |
773 | BEGIN { ${^OPEN} = "a\0b"; $^H = 0 } BEGIN { push @stuff, ${^OPEN} } | |
774 | 1' or die $@; | |
775 | is $stuff[0], $stuff[1], '$^H modifies ${^OPEN} consistently'; | |
776 | ||
4639d557 FC |
777 | # deleting $::{"\cH"} |
778 | is runperl(prog => 'delete $::{qq-\cH-}; ${^OPEN}=foo; print qq-ok\n-'), | |
779 | "ok\n", | |
780 | 'deleting $::{"\cH"}'; | |
781 | ||
66230c86 NC |
782 | # Tests for some non-magic names: |
783 | is ${^MPE}, undef, '${^MPE} starts undefined'; | |
784 | is ++${^MPE}, 1, '${^MPE} can be incremented'; | |
785 | ||
53f775c2 | 786 | # This one used to behave as ${^MATCH} due to a missing break: |
66230c86 | 787 | is ${^MPEN}, undef, '${^MPEN} starts undefined'; |
53f775c2 | 788 | # This one used to croak due to that missing break: |
66230c86 | 789 | is ++${^MPEN}, 1, '${^MPEN} can be incremented'; |
8f25f6c0 | 790 | |
a15a3d9b FC |
791 | { |
792 | no warnings 'deprecated'; | |
793 | eval { ${^E_NCODING} = 1 }; | |
794 | is $@, "", 'Setting ${^E_NCODING} does nothing'; | |
795 | $_ = ${^E_NCODING}; | |
796 | pass('can read ${^E_NCODING} without blowing up'); | |
797 | is $_, 1, '${^E_NCODING} is whatever it was set to'; | |
798 | } | |
199670db | 799 | |
39539141 DIM |
800 | { |
801 | my $warned = 0; | |
802 | local $SIG{__WARN__} = sub { ++$warned if $_[0] =~ /Use of uninitialized value in unshift/; print "# @_"; }; | |
803 | unshift @RT12608::A::ISA, qw(RT12608::B RT12608::C); | |
804 | is $warned, 0, '[perl #126082] unshifting onto @ISA doesn\'t trigger set magic for each item'; | |
805 | } | |
806 | ||
807 | { | |
808 | my $warned = 0; | |
809 | local $SIG{__WARN__} = sub { ++$warned if $_[0] =~ /Use of uninitialized value in unshift/; print "# @_"; }; | |
810 | ||
811 | my $x; tie $x, 'RT12608::F'; | |
812 | unshift @RT12608::X::ISA, $x, "RT12608::Z"; | |
813 | is $warned, 0, '[perl #126082] PL_delaymagic correctly/saved restored when pushing/unshifting onto @ISA'; | |
814 | ||
815 | package RT12608::F; | |
816 | use parent 'Tie::Scalar'; | |
817 | sub TIESCALAR { bless {}; } | |
818 | sub FETCH { push @RT12608::G::ISA, "RT12608::H"; "RT12608::Y"; } | |
819 | } | |
820 | ||
624c42e2 | 821 | |
61ec922c NC |
822 | # ^^^^^^^^^ New tests go here ^^^^^^^^^ |
823 | ||
824 | SKIP: { | |
1eea96ba TC |
825 | skip "Win32 needs XS for env/shell tests", 20 |
826 | if $Is_MSWin32 && is_miniperl; | |
61ec922c NC |
827 | |
828 | SKIP: { | |
f8c6801b CB |
829 | skip("clearing \%ENV is not safe when running under valgrind or on VMS") |
830 | if $ENV{PERL_VALGRIND} || $Is_VMS; | |
61ec922c NC |
831 | |
832 | $PATH = $ENV{PATH}; | |
15dd0034 | 833 | $SYSTEMROOT = $ENV{SYSTEMROOT} if exists $ENV{SYSTEMROOT}; # win32 |
61ec922c NC |
834 | $PDL = $ENV{PERL_DESTRUCT_LEVEL} || 0; |
835 | $ENV{foo} = "bar"; | |
836 | %ENV = (); | |
837 | $ENV{PATH} = $PATH; | |
15dd0034 | 838 | $ENV{SYSTEMROOT} = $SYSTEMROOT if defined $SYSTEMROOT; |
61ec922c NC |
839 | $ENV{PERL_DESTRUCT_LEVEL} = $PDL || 0; |
840 | if ($Is_MSWin32) { | |
841 | is `set foo 2>NUL`, ""; | |
842 | } else { | |
843 | is `echo \$foo`, "\n"; | |
844 | } | |
845 | } | |
846 | ||
613c63b4 CS |
847 | $ENV{__NoNeSuCh} = 'foo'; |
848 | $0 = 'bar'; | |
849 | env_is(__NoNeSuCh => 'foo', 'setting $0 does not break %ENV'); | |
850 | ||
efeca31e | 851 | $ENV{__NoNeSuCh2} = 'foo'; |
888a67f6 KF |
852 | $ENV{__NoNeSuCh2} = undef; |
853 | env_is(__NoNeSuCh2 => '', 'setting a key as undef does not delete it'); | |
854 | ||
613c63b4 CS |
855 | # stringify a glob |
856 | $ENV{foo} = *TODO; | |
857 | env_is(foo => '*main::TODO', 'ENV store of stringified glob'); | |
858 | ||
859 | # stringify a ref | |
860 | my $ref = []; | |
861 | $ENV{foo} = $ref; | |
862 | env_is(foo => "$ref", 'ENV store of stringified ref'); | |
863 | ||
864 | # downgrade utf8 when possible | |
865 | $bytes = "eh zero \x{A0}"; | |
866 | utf8::upgrade($chars = $bytes); | |
867 | $forced = $ENV{foo} = $chars; | |
868 | ok(!utf8::is_utf8($forced) && $forced eq $bytes, 'ENV store downgrades utf8 in SV'); | |
869 | env_is(foo => $bytes, 'ENV store downgrades utf8 in setenv'); | |
50352f16 FG |
870 | fail 'chars should still be wide!' if !utf8::is_utf8($chars); |
871 | $ENV{$chars} = 'widekey'; | |
872 | env_is("eh zero \x{A0}" => 'widekey', 'ENV store downgrades utf8 key in setenv'); | |
873 | fail 'chars should still be wide!' if !utf8::is_utf8($chars); | |
874 | is( delete($ENV{$chars}), 'widekey', 'delete(%ENV) downgrades utf8 key' ); | |
613c63b4 CS |
875 | |
876 | # warn when downgrading utf8 is not possible | |
877 | $chars = "X-Day \x{1998}"; | |
878 | utf8::encode($bytes = $chars); | |
879 | { | |
880 | my $warned = 0; | |
881 | local $SIG{__WARN__} = sub { ++$warned if $_[0] =~ /^Wide character in setenv/; print "# @_" }; | |
882 | $forced = $ENV{foo} = $chars; | |
883 | ok($warned == 1, 'ENV store warns about wide characters'); | |
50352f16 FG |
884 | |
885 | fail 'chars should still be wide!' if !utf8::is_utf8($chars); | |
886 | $ENV{$chars} = 'widekey'; | |
887 | env_is($forced => 'widekey', 'ENV store takes utf8-encoded key in setenv'); | |
888 | ||
889 | ok($warned == 2, 'ENV key store warns about wide characters'); | |
61ec922c | 890 | } |
613c63b4 CS |
891 | ok(!utf8::is_utf8($forced) && $forced eq $bytes, 'ENV store encodes high utf8 in SV'); |
892 | env_is(foo => $bytes, 'ENV store encodes high utf8 in SV'); | |
893 | ||
894 | # test local $ENV{foo} on existing foo | |
895 | { | |
896 | local $ENV{__NoNeSuCh}; | |
897 | { local $TODO = 'exists on %ENV should reflect real env'; | |
898 | ok(!exists $ENV{__NoNeSuCh}, 'not exists $ENV{existing} during local $ENV{existing}'); } | |
899 | env_is(__NoNeLoCaL => ''); | |
900 | } | |
901 | ok(exists $ENV{__NoNeSuCh}, 'exists $ENV{existing} after local $ENV{existing}'); | |
902 | env_is(__NoNeSuCh => 'foo'); | |
903 | ||
904 | # test local $ENV{foo} on new foo | |
905 | { | |
906 | local $ENV{__NoNeLoCaL} = 'foo'; | |
907 | ok(exists $ENV{__NoNeLoCaL}, 'exists $ENV{new} during local $ENV{new}'); | |
908 | env_is(__NoNeLoCaL => 'foo'); | |
909 | } | |
910 | ok(!exists $ENV{__NoNeLoCaL}, 'not exists $ENV{new} after local $ENV{new}'); | |
911 | env_is(__NoNeLoCaL => ''); | |
912 | ||
61ec922c | 913 | SKIP: { |
2a64b184 JK |
914 | skip("\$0 check only on Linux, Dragonfly BSD and FreeBSD", 2) |
915 | unless $^O =~ /^(linux|android|dragonfly|freebsd)$/; | |
916 | ||
917 | SKIP: { | |
918 | skip("No procfs cmdline support", 1) | |
919 | unless open CMDLINE, "/proc/$$/cmdline"; | |
920 | ||
921 | chomp(my $line = scalar <CMDLINE>); | |
922 | my $me = (split /\0/, $line)[0]; | |
923 | is $me, $0, 'altering $0 is effective (testing with /proc/)'; | |
924 | close CMDLINE; | |
925 | } | |
926 | skip("No \$0 check with 'ps' on Android", 1) if $^O eq 'android'; | |
927 | # perlbug #22811 | |
928 | my $mydollarzero = sub { | |
929 | my($arg) = shift; | |
930 | $0 = $arg if defined $arg; | |
931 | # In FreeBSD the ps -o command= will cause | |
932 | # an empty header line, grab only the last line. | |
72d0a0a0 | 933 | my $ps = (`ps -o command= -p $$ 2>&1`)[-1]; |
2a64b184 JK |
934 | return if $?; |
935 | chomp $ps; | |
936 | $ps; | |
937 | }; | |
938 | my $ps = $mydollarzero->("x"); | |
939 | # we allow that something goes wrong with the ps command | |
940 | !$ps && skip("The ps command failed", 1); | |
941 | my $ps_re = ( $^O =~ /^(dragonfly|freebsd)$/ ) | |
942 | # FreeBSD cannot get rid of both the leading "perl :" | |
943 | # and the trailing " (perl)": some FreeBSD versions | |
944 | # can get rid of the first one. | |
4a026b43 | 945 | ? qr/^(?:(?:mini)?perl: )?x(?: \((?:mini)?perl\))?$/ |
2a64b184 JK |
946 | # In Linux 2.4 we would get an exact match ($ps eq 'x') but |
947 | # in Linux 2.2 there seems to be something funny going on: | |
948 | # it seems as if the original length of the argv[] would | |
949 | # be stored in the proc struct and then used by ps(1), | |
950 | # no matter what characters we use to pad the argv[]. | |
951 | # (And if we use \0:s, they are shown as spaces.) Sigh. | |
952 | : qr/^x\s*$/ | |
953 | ; | |
954 | like($ps, $ps_re, 'altering $0 is effective (testing with `ps`)'); | |
955 | } | |
61ec922c NC |
956 | } |
957 | ||
d8ec4617 YO |
958 | # in some situations $SIG{ALRM} might be 'IGNORE', eg: |
959 | # git rebase --exec='perl -e "print \$SIG{ALRM}" && git co -f' HEAD~2 | |
960 | # will print out 'IGNORE' | |
961 | my $sig_alarm_expect= $SIG{ALRM}; | |
55f5e765 LT |
962 | { |
963 | local %SIG = (%SIG, ALRM => sub {}) | |
964 | }; | |
d8ec4617 | 965 | is $SIG{ALRM}, $sig_alarm_expect, '$SIG{ALRM} is as expected'; |
55f5e765 | 966 | |
61ec922c NC |
967 | # test case-insignificance of %ENV (these tests must be enabled only |
968 | # when perl is compiled with -DENV_IS_CASELESS) | |
969 | SKIP: { | |
2eb109a4 | 970 | skip('no caseless %ENV support', 4) unless $Is_MSWin32; |
61ec922c NC |
971 | |
972 | %ENV = (); | |
973 | $ENV{'Foo'} = 'bar'; | |
974 | $ENV{'fOo'} = 'baz'; | |
975 | is scalar(keys(%ENV)), 1; | |
976 | ok exists $ENV{'FOo'}; | |
977 | is delete $ENV{'foO'}, 'baz'; | |
978 | is scalar(keys(%ENV)), 0; | |
979 | } | |
980 | ||
981 | __END__ | |
982 | ||
983 | # Put new tests before the various ENV tests, as they blow %ENV away. |