This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Remove CR characters from raw input in op/magic.t on Windows
[perl5.git] / t / op / magic.t
1 #!./perl
2
3 BEGIN {
4     $| = 1;
5     chdir 't' if -d 't';
6     @INC = '../lib';
7     require './test.pl';
8     plan (tests => 171);
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 {
17     # not available in miniperl
18     my %non_mini = map { $_ => 1 } qw(+ - [);
19     for (qw(
20         SIG ^OPEN ^TAINT ^UNICODE ^UTF8LOCALE ^WARNING_BITS 1 2 3 4 5 6 7 8
21         9 42 & ` ' : ? ! _ - [ ^ ~ = % . ( ) < > \ / $ | + ; ] ^A ^C ^D
22         ^E ^F ^H ^I ^L ^N ^O ^P ^S ^T ^V ^W ^UTF8CACHE ::12345 main::98732
23     )) {
24         my $v = $_;
25         # avoid using any global vars here:
26         if ($v =~ s/^\^(?=.)//) {
27             for(substr $v, 0, 1) {
28                 $_ = chr ord() - 64;
29             }
30         }
31         SKIP:
32         {
33             skip_if_miniperl("the module for *$_ may not be available in "
34                              . "miniperl", 1) if $non_mini{$_};
35             ok defined *$v, "*$_ appears to be defined at the outset";
36         }
37     }
38 }
39
40 # This must be in a separate BEGIN block, as the mere mention of ${^TAINT}
41 # will invalidate the test for it.
42 BEGIN {
43     $ENV{PATH} = '/bin' if ${^TAINT};
44     $SIG{__WARN__} = sub { die "Dying on warning: ", @_ };
45 }
46
47 use warnings;
48 use Config;
49
50
51 $Is_MSWin32  = $^O eq 'MSWin32';
52 $Is_NetWare  = $^O eq 'NetWare';
53 $Is_VMS      = $^O eq 'VMS';
54 $Is_Dos      = $^O eq 'dos';
55 $Is_os2      = $^O eq 'os2';
56 $Is_Cygwin   = $^O eq 'cygwin';
57 $Is_MPE      = $^O eq 'mpeix';          
58 $Is_BeOS     = $^O eq 'beos';
59
60 $PERL = $ENV{PERL}
61     || ($Is_NetWare           ? 'perl'   :
62        $Is_VMS                ? $^X      :
63        $Is_MSWin32            ? '.\perl' :
64        './perl');
65
66 sub env_is {
67     my ($key, $val, $desc) = @_;
68
69     use open IN => ":raw";
70     if ($Is_MSWin32) {
71         # cmd.exe will echo 'variable=value' but 4nt will echo just the value
72         # -- Nikola Knezevic
73         (my $set = `set $key`) =~ s/\r\n$/\n/;
74         like $set, qr/^(?:\Q$key\E=)?\Q$val\E$/, $desc;
75     } elsif ($Is_VMS) {
76         is `write sys\$output f\$trnlnm("\Q$key\E")`, "$val\n", $desc;
77     } else {
78         is `echo \$\Q$key\E`, "$val\n", $desc;
79     }
80 }
81
82 END {
83     # On VMS, environment variable changes are peristent after perl exits
84     if ($Is_VMS) {
85         delete $ENV{'FOO'};
86         delete $ENV{'__NoNeSuCh'};
87     }
88 }
89
90 eval '$ENV{"FOO"} = "hi there";';       # check that ENV is inited inside eval
91 # cmd.exe will echo 'variable=value' but 4nt will echo just the value
92 # -- Nikola Knezevic
93 if ($Is_MSWin32)  { like `set FOO`, qr/^(?:FOO=)?hi there$/; }
94 elsif ($Is_VMS)   { is `write sys\$output f\$trnlnm("FOO")`, "hi there\n"; }
95 else              { is `echo \$FOO`, "hi there\n"; }
96
97 unlink_all 'ajslkdfpqjsjfk';
98 $! = 0;
99 open(FOO,'ajslkdfpqjsjfk');
100 isnt($!, 0);
101 close FOO; # just mention it, squelch used-only-once
102
103 SKIP: {
104     skip('SIGINT not safe on this platform', 5)
105         if $Is_MSWin32 || $Is_NetWare || $Is_Dos || $Is_MPE;
106   # the next tests are done in a subprocess because sh spits out a
107   # newline onto stderr when a child process kills itself with SIGINT.
108   # We use a pipe rather than system() because the VMS command buffer
109   # would overflow with a command that long.
110
111     # For easy interpolation of test numbers:
112     $next_test = curr_test() - 1;
113     sub TIEARRAY {bless[]}
114     sub FETCH { $next_test + pop }
115     tie my @tn, __PACKAGE__;
116
117     open( CMDPIPE, "| $PERL");
118
119     print CMDPIPE "\$t1 = $tn[1]; \$t2 = $tn[2];\n", <<'END';
120
121     $| = 1;             # command buffering
122
123     $SIG{"INT"} = "ok1";     kill "INT",$$; sleep 1;
124     $SIG{"INT"} = "IGNORE";  kill "INT",$$; sleep 1; print "ok $t2\n";
125     $SIG{"INT"} = "DEFAULT"; kill "INT",$$; sleep 1; print" not ok $t2\n";
126
127     sub ok1 {
128         if (($x = pop(@_)) eq "INT") {
129             print "ok $t1\n";
130         }
131         else {
132             print "not ok $t1 ($x @_)\n";
133         }
134     }
135
136 END
137
138     close CMDPIPE;
139
140     open( CMDPIPE, "| $PERL");
141     print CMDPIPE "\$t3 = $tn[3];\n", <<'END';
142
143     { package X;
144         sub DESTROY {
145             kill "INT",$$;
146         }
147     }
148     sub x {
149         my $x=bless [], 'X';
150         return sub { $x };
151     }
152     $| = 1;             # command buffering
153     $SIG{"INT"} = "ok3";
154     {
155         local $SIG{"INT"}=x();
156         print ""; # Needed to expose failure in 5.8.0 (why?)
157     }
158     sleep 1;
159     delete $SIG{"INT"};
160     kill "INT",$$; sleep 1;
161     sub ok3 {
162         print "ok $t3\n";
163     }
164 END
165     close CMDPIPE;
166     $? >>= 8 if $^O eq 'VMS'; # POSIX status hiding in 2nd byte
167     my $todo = ($^O eq 'os2' ? ' # TODO: EMX v0.9d_fix4 bug: wrong nibble? ' : '');
168     print $? & 0xFF ? "ok $tn[4]$todo\n" : "not ok $tn[4]$todo\n";
169
170     open(CMDPIPE, "| $PERL");
171     print CMDPIPE <<'END';
172
173     sub PVBM () { 'foo' }
174     index 'foo', PVBM;
175     my $pvbm = PVBM;
176
177     sub foo { exit 0 }
178
179     $SIG{"INT"} = $pvbm;
180     kill "INT", $$; sleep 1;
181 END
182     close CMDPIPE;
183     $? >>= 8 if $^O eq 'VMS';
184     print $? ? "not ok $tn[5]\n" : "ok $tn[5]\n";
185
186     curr_test(curr_test() + 5);
187 }
188
189 # can we slice ENV?
190 @val1 = @ENV{keys(%ENV)};
191 @val2 = values(%ENV);
192 is join(':',@val1), join(':',@val2);
193 cmp_ok @val1, '>', 1;
194
195 # regex vars
196 'foobarbaz' =~ /b(a)r/;
197 is $`, 'foo';
198 is $&, 'bar';
199 is $', 'baz';
200 is $+, 'a';
201
202 # [perl #24237]
203 for (qw < ` & ' >) {
204  fresh_perl_is
205   qq < \@$_; q "fff" =~ /(?!^)./; print "[\$$_]\\n" >,
206   "[f]\n", {},
207   "referencing \@$_ before \$$_ etc. still saws off ampersands";
208 }
209
210 # $"
211 @a = qw(foo bar baz);
212 is "@a", "foo bar baz";
213 {
214     local $" = ',';
215     is "@a", "foo,bar,baz";
216 }
217
218 # $;
219 %h = ();
220 $h{'foo', 'bar'} = 1;
221 is((keys %h)[0], "foo\034bar");
222 {
223     local $; = 'x';
224     %h = ();
225     $h{'foo', 'bar'} = 1;
226     is((keys %h)[0], 'fooxbar');
227 }
228
229 # $?, $@, $$
230 system qq[$PERL "-I../lib" -e "use vmsish qw(hushed); exit(0)"];
231 is $?, 0;
232 system qq[$PERL "-I../lib" -e "use vmsish qw(hushed); exit(1)"];
233 isnt $?, 0;
234
235 eval { die "foo\n" };
236 is $@, "foo\n";
237
238 cmp_ok($$, '>', 0);
239 my $pid = $$;
240 eval { $$ = 42 };
241 is $$, 42, '$$ can be modified';
242 SKIP: {
243     skip "no fork", 1 unless $Config{d_fork};
244     (my $kidpid = open my $fh, "-|") // skip "cannot fork: $!", 1;
245     if($kidpid) { # parent
246         my $kiddollars = <$fh>;
247         close $fh or die "cannot close pipe from kid proc: $!";
248         is $kiddollars, $kidpid, '$$ is reset on fork';
249     }
250     else { # child
251         print $$;
252         $::NO_ENDING = 1; # silence "Looks like you only ran..."
253         exit;
254     }
255 }
256 $$ = $pid; # Tests below use $$
257
258 # $^X and $0
259 {
260     my $is_abs = $Config{d_procselfexe} || $Config{usekernprocpathname}
261       || $Config{usensgetexecutablepath};
262     if ($^O eq 'qnx') {
263         chomp($wd = `/usr/bin/fullpath -t`);
264     }
265     elsif($Is_Cygwin || $is_abs) {
266        # Cygwin turns the symlink into the real file
267        chomp($wd = `pwd`);
268        $wd =~ s#/t$##;
269        $wd =~ /(.*)/; $wd = $1; # untaint
270        if ($Is_Cygwin) {
271            $wd = Cygwin::win_to_posix_path(Cygwin::posix_to_win_path($wd, 1));
272        }
273     }
274     elsif($Is_os2) {
275        $wd = Cwd::sys_cwd();
276     }
277     else {
278         $wd = '.';
279     }
280     my $perl = $Is_VMS || $is_abs ? $^X : "$wd/perl";
281     my $headmaybe = '';
282     my $middlemaybe = '';
283     my $tailmaybe = '';
284     $script = "$wd/show-shebang";
285     if ($Is_MSWin32) {
286         chomp($wd = `cd`);
287         $wd =~ s|\\|/|g;
288         $perl = "$wd/perl.exe";
289         $script = "$wd/show-shebang.bat";
290         $headmaybe = <<EOH ;
291 \@rem ='
292 \@echo off
293 $perl -x \%0
294 goto endofperl
295 \@rem ';
296 EOH
297         $tailmaybe = <<EOT ;
298
299 __END__
300 :endofperl
301 EOT
302     }
303     elsif ($Is_os2) {
304       $script = "./show-shebang";
305     }
306     elsif ($Is_VMS) {
307       $script = "[]show-shebang";
308     }
309     elsif ($Is_Cygwin) {
310       $middlemaybe = <<'EOX'
311 $^X = Cygwin::win_to_posix_path(Cygwin::posix_to_win_path($^X, 1));
312 $0 = Cygwin::win_to_posix_path(Cygwin::posix_to_win_path($0, 1));
313 EOX
314     }
315     if ($^O eq 'os390' or $^O eq 'posix-bc' or $^O eq 'vmesa') {  # no shebang
316         $headmaybe = <<EOH ;
317     eval 'exec ./perl -S \$0 \${1+"\$\@"}'
318         if 0;
319 EOH
320     }
321     $s1 = "\$^X is $perl, \$0 is $script\n";
322     ok open(SCRIPT, ">$script") or diag "Can't write to $script: $!";
323     ok print(SCRIPT $headmaybe . <<EOB . $middlemaybe . <<'EOF' . $tailmaybe) or diag $!;
324 #!$perl
325 EOB
326 print "\$^X is $^X, \$0 is $0\n";
327 EOF
328     ok close(SCRIPT) or diag $!;
329     ok chmod(0755, $script) or diag $!;
330     $_ = $Is_VMS ? `$perl $script` : `$script`;
331     s/\.exe//i if $Is_Dos or $Is_Cygwin or $Is_os2;
332     s{./$script}{$script} if $Is_BeOS; # revert BeOS execvp() side-effect
333     s{is perl}{is $perl}; # for systems where $^X is only a basename
334     s{\\}{/}g;
335     if ($Is_MSWin32 || $Is_os2) {
336         is uc $_, uc $s1;
337     } else {
338         is $_, $s1;
339     }
340     $_ = `$perl $script`;
341     s/\.exe//i if $Is_Dos or $Is_os2 or $Is_Cygwin;
342     s{./$perl}{$perl} if $Is_BeOS; # revert BeOS execvp() side-effect
343     s{\\}{/}g;
344     if ($Is_MSWin32 || $Is_os2) {
345         is uc $_, uc $s1;
346     } else {
347         is $_, $s1;
348     }
349     ok unlink($script) or diag $!;
350     # CHECK
351     # Could this be replaced with:
352     # unlink_all($script);
353 }
354
355 # $], $^O, $^T
356 cmp_ok $], '>=', 5.00319;
357 ok $^O;
358 cmp_ok $^T, '>', 850000000;
359
360 # Test change 25062 is working
361 my $orig_osname = $^O;
362 {
363 local $^I = '.bak';
364 is $^O, $orig_osname, 'Assigning $^I does not clobber $^O';
365 }
366 $^O = $orig_osname;
367
368 {
369     #RT #72422
370     foreach my $p (0, 1) {
371         fresh_perl_is(<<"EOP", '2 4 8', undef, "test \$^P = $p");
372 \$DB::single = 2;
373 \$DB::trace = 4;
374 \$DB::signal = 8;
375 \$^P = $p;
376 print "\$DB::single \$DB::trace \$DB::signal";
377 EOP
378     }
379 }
380
381 # Check that assigning to $0 on Linux sets the process name with both
382 # argv[0] assignment and by calling prctl()
383 {
384   SKIP: {
385     skip "We don't have prctl() here", 2 unless $Config{d_prctl_set_name};
386
387     # We don't really need these tests. prctl() is tested in the
388     # Kernel, but test it anyway for our sanity. If something doesn't
389     # work (like if the system doesn't have a ps(1) for whatever
390     # reason) just bail out gracefully.
391     my $maybe_ps = sub {
392         my ($cmd) = @_;
393         local ($?, $!);
394
395         no warnings;
396         my $res = `$cmd`;
397         skip "Couldn't shell out to '$cmd', returned code $?", 2 if $?;
398         return $res;
399     };
400
401     my $name = "Good Morning, Dave";
402     $0 = $name;
403
404     chomp(my $argv0 = $maybe_ps->("ps h $$"));
405     chomp(my $prctl = $maybe_ps->("ps hc $$"));
406
407     like($argv0, $name, "Set process name through argv[0] ($argv0)");
408     like($prctl, substr($name, 0, 15), "Set process name through prctl() ($prctl)");
409   }
410 }
411
412 {
413     my $ok = 1;
414     my $warn = '';
415     local $SIG{'__WARN__'} = sub { $ok = 0; $warn = join '', @_; $warn =~ s/\n$//; };
416     $! = undef;
417     local $TODO = $Is_VMS ? "'\$!=undef' does throw a warning" : '';
418     ok($ok, $warn);
419 }
420
421 SKIP: {
422     skip_if_miniperl("miniperl can't rely on loading %Errno", 2);
423    no warnings 'void';
424
425 # Make sure Errno hasn't been prematurely autoloaded
426
427    ok !keys %Errno::;
428
429 # Test auto-loading of Errno when %! is used
430
431    ok scalar eval q{
432       %!;
433       scalar %Errno::;
434    }, $@;
435 }
436
437 SKIP:  {
438     skip_if_miniperl("miniperl can't rely on loading %Errno", 2);
439     # Make sure that Errno loading doesn't clobber $!
440
441     undef %Errno::;
442     delete $INC{"Errno.pm"};
443
444     open(FOO, "nonesuch"); # Generate ENOENT
445     my %errs = %{"!"}; # Cause Errno.pm to be loaded at run-time
446     ok ${"!"}{ENOENT};
447
448     # Make sure defined(*{"!"}) before %! does not stop %! from working
449     is
450       runperl(
451         prog => 'BEGIN { defined *{q-!-} } print qq-ok\n- if tied %!',
452       ),
453      "ok\n",
454      'defined *{"!"} does not stop %! from working';
455 }
456
457 # Check that we don't auto-load packages
458 SKIP: {
459     skip "staticly linked; may be preloaded", 4 unless $Config{usedl};
460     foreach (['powie::!', 'Errno'],
461              ['powie::+', 'Tie::Hash::NamedCapture']) {
462         my ($symbol, $package) = @$_;
463         foreach my $scalar_first ('', '$$symbol;') {
464             my $desc = qq{Referencing %{"$symbol"}};
465             $desc .= qq{ after mentioning \${"$symbol"}} if $scalar_first;
466             $desc .= " doesn't load $package";
467
468             fresh_perl_is(<<"EOP", 0, {}, $desc);
469 use strict qw(vars subs);
470 my \$symbol = '$symbol';
471 $scalar_first;
472 1 if %{\$symbol};
473 print scalar %${package}::;
474 EOP
475         }
476     }
477 }
478
479 is $^S, 0;
480 eval { is $^S,1 };
481 eval " BEGIN { ok ! defined \$^S } ";
482 is $^S, 0;
483
484 my $taint = ${^TAINT};
485 is ${^TAINT}, $taint;
486 eval { ${^TAINT} = 1 };
487 is ${^TAINT}, $taint;
488
489 # 5.6.1 had a bug: @+ and @- were not properly interpolated
490 # into double-quoted strings
491 # 20020414 mjd-perl-patch+@plover.com
492 "I like pie" =~ /(I) (like) (pie)/;
493 is "@-",  "0 0 2 7";
494 is "@+", "10 1 6 10";
495
496 # Tests for the magic get of $\
497 {
498     my $ok = 0;
499     # [perl #19330]
500     {
501         local $\ = undef;
502         $\++; $\++;
503         $ok = $\ eq 2;
504     }
505     ok $ok;
506     $ok = 0;
507     {
508         local $\ = "a\0b";
509         $ok = "a$\b" eq "aa\0bb";
510     }
511     ok $ok;
512 }
513
514 # Test for bug [perl #36434]
515 # Can not do this test on VMS, EPOC, and SYMBIAN according to comments
516 # in mg.c/Perl_magic_clear_all_env()
517 SKIP: {
518     skip('Can\'t make assignment to \%ENV on this system', 3) if $Is_VMS;
519
520     local @ISA;
521     local %ENV;
522     # This used to be __PACKAGE__, but that causes recursive
523     #  inheritance, which is detected earlier now and broke
524     #  this test
525     eval { push @ISA, __FILE__ };
526     is $@, '', 'Push a constant on a magic array';
527     $@ and print "# $@";
528     eval { %ENV = (PATH => __PACKAGE__) };
529     is $@, '', 'Assign a constant to a magic hash';
530     $@ and print "# $@";
531     eval { my %h = qw(A B); %ENV = (PATH => (keys %h)[0]) };
532     is $@, '', 'Assign a shared key to a magic hash';
533     $@ and print "# $@";
534 }
535
536 # Tests for Perl_magic_clearsig
537 foreach my $sig (qw(__WARN__ INT)) {
538     $SIG{$sig} = lc $sig;
539     is $SIG{$sig}, 'main::' . lc $sig, "Can assign to $sig";
540     is delete $SIG{$sig}, 'main::' . lc $sig, "Can delete from $sig";
541     is $SIG{$sig}, undef, "$sig is now gone";
542     is delete $SIG{$sig}, undef, "$sig remains gone";
543 }
544
545 # And now one which doesn't exist;
546 {
547     no warnings 'signal';
548     $SIG{HUNGRY} = 'mmm, pie';
549 }
550 is $SIG{HUNGRY}, 'mmm, pie', 'Can assign to HUNGRY';
551 is delete $SIG{HUNGRY}, 'mmm, pie', 'Can delete from HUNGRY';
552 is $SIG{HUNGRY}, undef, "HUNGRY is now gone";
553 is delete $SIG{HUNGRY}, undef, "HUNGRY remains gone";
554
555 # Test deleting signals that we never set
556 foreach my $sig (qw(__DIE__ _BOGUS_HOOK KILL THIRSTY)) {
557     is $SIG{$sig}, undef, "$sig is not present";
558     is delete $SIG{$sig}, undef, "delete of $sig returns undef";
559 }
560
561 {
562     $! = 9999;
563     is int $!, 9999, q{[perl #72850] Core dump in bleadperl from perl -e '$! = 9999; $a = $!;'};
564
565 }
566
567 # %+ %-
568 SKIP: {
569     skip_if_miniperl("No XS in miniperl", 2);
570     # Make sure defined(*{"+"}) before %+ does not stop %+ from working
571     is
572       runperl(
573         prog => 'BEGIN { defined *{q-+-} } print qq-ok\n- if tied %+',
574       ),
575      "ok\n",
576      'defined *{"+"} does not stop %+ from working';
577     is
578       runperl(
579         prog => 'BEGIN { defined *{q=-=} } print qq-ok\n- if tied %-',
580       ),
581      "ok\n",
582      'defined *{"-"} does not stop %- from working';
583 }
584
585 SKIP: {
586     skip_if_miniperl("No XS in miniperl", 3);
587
588     for ( [qw( %- Tie::Hash::NamedCapture )], [qw( $[ arybase )],
589           [qw( %! Errno )] ) {
590         my ($var, $mod) = @$_;
591         my $modfile = $mod =~ s|::|/|gr . ".pm";
592         fresh_perl_is
593            qq 'sub UNIVERSAL::AUTOLOAD{}
594                $mod\::foo() if 0;
595                $var;
596                print "ok\\n" if \$INC{"$modfile"}',
597           "ok\n",
598            { switches => [ '-X' ] },
599           "$var still loads $mod when stash and UNIVERSAL::AUTOLOAD exist";
600     }
601 }
602
603 # ^^^^^^^^^ New tests go here ^^^^^^^^^
604
605 SKIP: {
606     skip("%ENV manipulations fail or aren't safe on $^O", 19)
607         if $Is_Dos;
608
609  SKIP: {
610         skip("clearing \%ENV is not safe when running under valgrind or on VMS")
611             if $ENV{PERL_VALGRIND} || $Is_VMS;
612
613             $PATH = $ENV{PATH};
614             $PDL = $ENV{PERL_DESTRUCT_LEVEL} || 0;
615             $ENV{foo} = "bar";
616             %ENV = ();
617             $ENV{PATH} = $PATH;
618             $ENV{PERL_DESTRUCT_LEVEL} = $PDL || 0;
619             if ($Is_MSWin32) {
620                 is `set foo 2>NUL`, "";
621             } else {
622                 is `echo \$foo`, "\n";
623             }
624         }
625
626         $ENV{__NoNeSuCh} = 'foo';
627         $0 = 'bar';
628         env_is(__NoNeSuCh => 'foo', 'setting $0 does not break %ENV');
629
630         # stringify a glob
631         $ENV{foo} = *TODO;
632         env_is(foo => '*main::TODO', 'ENV store of stringified glob');
633
634         # stringify a ref
635         my $ref = [];
636         $ENV{foo} = $ref;
637         env_is(foo => "$ref", 'ENV store of stringified ref');
638
639         # downgrade utf8 when possible
640         $bytes = "eh zero \x{A0}";
641         utf8::upgrade($chars = $bytes);
642         $forced = $ENV{foo} = $chars;
643         ok(!utf8::is_utf8($forced) && $forced eq $bytes, 'ENV store downgrades utf8 in SV');
644         env_is(foo => $bytes, 'ENV store downgrades utf8 in setenv');
645
646         # warn when downgrading utf8 is not possible
647         $chars = "X-Day \x{1998}";
648         utf8::encode($bytes = $chars);
649         {
650           my $warned = 0;
651           local $SIG{__WARN__} = sub { ++$warned if $_[0] =~ /^Wide character in setenv/; print "# @_" };
652           $forced = $ENV{foo} = $chars;
653           ok($warned == 1, 'ENV store warns about wide characters');
654         }
655         ok(!utf8::is_utf8($forced) && $forced eq $bytes, 'ENV store encodes high utf8 in SV');
656         env_is(foo => $bytes, 'ENV store encodes high utf8 in SV');
657
658         # test local $ENV{foo} on existing foo
659         {
660           local $ENV{__NoNeSuCh};
661           { local $TODO = 'exists on %ENV should reflect real env';
662             ok(!exists $ENV{__NoNeSuCh}, 'not exists $ENV{existing} during local $ENV{existing}'); }
663           env_is(__NoNeLoCaL => '');
664         }
665         ok(exists $ENV{__NoNeSuCh}, 'exists $ENV{existing} after local $ENV{existing}');
666         env_is(__NoNeSuCh => 'foo');
667
668         # test local $ENV{foo} on new foo
669         {
670           local $ENV{__NoNeLoCaL} = 'foo';
671           ok(exists $ENV{__NoNeLoCaL}, 'exists $ENV{new} during local $ENV{new}');
672           env_is(__NoNeLoCaL => 'foo');
673         }
674         ok(!exists $ENV{__NoNeLoCaL}, 'not exists $ENV{new} after local $ENV{new}');
675         env_is(__NoNeLoCaL => '');
676
677     SKIP: {
678             skip("\$0 check only on Linux and FreeBSD", 2)
679                 unless $^O =~ /^(linux|freebsd)$/
680                     && open CMDLINE, "/proc/$$/cmdline";
681
682             chomp(my $line = scalar <CMDLINE>);
683             my $me = (split /\0/, $line)[0];
684             is $me, $0, 'altering $0 is effective (testing with /proc/)';
685             close CMDLINE;
686             # perlbug #22811
687             my $mydollarzero = sub {
688               my($arg) = shift;
689               $0 = $arg if defined $arg;
690               # In FreeBSD the ps -o command= will cause
691               # an empty header line, grab only the last line.
692               my $ps = (`ps -o command= -p $$`)[-1];
693               return if $?;
694               chomp $ps;
695               printf "# 0[%s]ps[%s]\n", $0, $ps;
696               $ps;
697             };
698             my $ps = $mydollarzero->("x");
699             ok(!$ps  # we allow that something goes wrong with the ps command
700                # In Linux 2.4 we would get an exact match ($ps eq 'x') but
701                # in Linux 2.2 there seems to be something funny going on:
702                # it seems as if the original length of the argv[] would
703                # be stored in the proc struct and then used by ps(1),
704                # no matter what characters we use to pad the argv[].
705                # (And if we use \0:s, they are shown as spaces.)  Sigh.
706                || $ps =~ /^x\s*$/
707                # FreeBSD cannot get rid of both the leading "perl :"
708                # and the trailing " (perl)": some FreeBSD versions
709                # can get rid of the first one.
710                || ($^O eq 'freebsd' && $ps =~ m/^(?:perl: )?x(?: \(perl\))?$/),
711                        'altering $0 is effective (testing with `ps`)');
712         }
713 }
714
715 # test case-insignificance of %ENV (these tests must be enabled only
716 # when perl is compiled with -DENV_IS_CASELESS)
717 SKIP: {
718     skip('no caseless %ENV support', 4) unless $Is_MSWin32 || $Is_NetWare;
719
720     %ENV = ();
721     $ENV{'Foo'} = 'bar';
722     $ENV{'fOo'} = 'baz';
723     is scalar(keys(%ENV)), 1;
724     ok exists $ENV{'FOo'};
725     is delete $ENV{'foO'}, 'baz';
726     is scalar(keys(%ENV)), 0;
727 }
728
729 __END__
730
731 # Put new tests before the various ENV tests, as they blow %ENV away.