1#!./perl 2 3BEGIN { 4 $| = 1; 5 chdir 't' if -d 't'; 6 require './test.pl'; 7 set_up_inc( '../lib' ); 8 plan (tests => 196); # some tests are run in BEGIN block 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. 16BEGIN { 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 ^LAST_FH 24 )) { 25 my $v = $_; 26 # avoid using any global vars here: 27 if ($v =~ s/^\^(?=.)//) { 28 for(substr $v, 0, 1) { 29 $_ = chr(utf8::native_to_unicode(ord($_)) - 64); 30 } 31 } 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 } 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. 43BEGIN { 44 $ENV{PATH} = '/bin' if ${^TAINT}; 45 $SIG{__WARN__} = sub { die "Dying on warning: ", @_ }; 46} 47 48use warnings; 49use Config; 50 51 52$Is_MSWin32 = $^O eq 'MSWin32'; 53$Is_NetWare = $^O eq 'NetWare'; 54$Is_VMS = $^O eq 'VMS'; 55$Is_Dos = $^O eq 'dos'; 56$Is_os2 = $^O eq 'os2'; 57$Is_Cygwin = $^O eq 'cygwin'; 58 59$PERL = 60 ($Is_NetWare ? 'perl' : 61 $Is_VMS ? $^X : 62 $Is_MSWin32 ? '.\perl' : 63 './perl'); 64 65 66sub 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 require Win32; 74 my $cp = Win32::GetConsoleOutputCP(); 75 Win32::SetConsoleOutputCP(Win32::GetACP()); 76 (my $set = `set $key 2>nul`) =~ s/\r\n$/\n/; 77 Win32::SetConsoleOutputCP($cp); 78 like $set, qr/^(?:\Q$key\E=)?\Q$val\E$/, $desc; 79 } elsif ($Is_VMS) { 80 my $eqv = `write sys\$output f\$trnlnm("\Q$key\E")`; 81 # A single null byte in the equivalence string means 82 # an undef value for Perl, so mimic that here. 83 $eqv = "\n" if length($eqv) == 2 and $eqv eq "\000\n"; 84 is $eqv, "$val\n", $desc; 85 } else { 86 my @env = `env`; 87 SKIP: { 88 skip("env doesn't work on this android", 1) if !@env && $^O =~ /android/; 89 chomp (my @env = grep { s/^$key=// } @env); 90 is "@env", $val, $desc; 91 } 92 } 93} 94 95END { 96 # On VMS, environment variable changes are peristent after perl exits 97 if ($Is_VMS) { 98 delete $ENV{'FOO'}; 99 delete $ENV{'__NoNeSuCh'}; 100 delete $ENV{'__NoNeSuCh2'}; 101 } 102} 103 104eval '$ENV{"FOO"} = "hi there";'; # check that ENV is inited inside eval 105# cmd.exe will echo 'variable=value' but 4nt will echo just the value 106# -- Nikola Knezevic 107if ($Is_MSWin32) { like `set FOO`, qr/^(?:FOO=)?hi there$/m; } 108elsif ($Is_VMS) { is `write sys\$output f\$trnlnm("FOO")`, "hi there\n"; } 109else { is `echo \$FOO`, "hi there\n"; } 110 111unlink_all 'ajslkdfpqjsjfk'; 112$! = 0; 113open(FOO,'ajslkdfpqjsjfk'); 114isnt($!, 0, "Unlinked file can't be opened"); 115close FOO; # just mention it, squelch used-only-once 116 117SKIP: { 118 skip('SIGINT not safe on this platform', 5) 119 if $Is_MSWin32 || $Is_NetWare || $Is_Dos; 120 # the next tests are done in a subprocess because sh spits out a 121 # newline onto stderr when a child process kills itself with SIGINT. 122 # We use a pipe rather than system() because the VMS command buffer 123 # would overflow with a command that long. 124 125 # For easy interpolation of test numbers: 126 $next_test = curr_test() - 1; 127 sub TIEARRAY {bless[]} 128 sub FETCH { $next_test + pop } 129 tie my @tn, __PACKAGE__; 130 131 open( CMDPIPE, "|-", $PERL); 132 133 print CMDPIPE "\$t1 = $tn[1]; \$t2 = $tn[2];\n", <<'END'; 134 135 $| = 1; # command buffering 136 137 $SIG{"INT"} = "ok1"; kill "INT",$$; sleep 1; 138 $SIG{"INT"} = "IGNORE"; kill "INT",$$; sleep 1; print "ok $t2\n"; 139 $SIG{"INT"} = "DEFAULT"; kill "INT",$$; sleep 1; print" not ok $t2\n"; 140 141 sub ok1 { 142 if (($x = pop(@_)) eq "INT") { 143 print "ok $t1\n"; 144 } 145 else { 146 print "not ok $t1 ($x @_)\n"; 147 } 148 } 149 150END 151 152 close CMDPIPE; 153 154 open( CMDPIPE, "|-", $PERL); 155 print CMDPIPE "\$t3 = $tn[3];\n", <<'END'; 156 157 { package X; 158 sub DESTROY { 159 kill "INT",$$; 160 } 161 } 162 sub x { 163 my $x=bless [], 'X'; 164 return sub { $x }; 165 } 166 $| = 1; # command buffering 167 $SIG{"INT"} = "ok3"; 168 { 169 local $SIG{"INT"}=x(); 170 print ""; # Needed to expose failure in 5.8.0 (why?) 171 } 172 sleep 1; 173 delete $SIG{"INT"}; 174 kill "INT",$$; sleep 1; 175 sub ok3 { 176 print "ok $t3\n"; 177 } 178END 179 close CMDPIPE; 180 $? >>= 8 if $^O eq 'VMS'; # POSIX status hiding in 2nd byte 181 my $todo = ($^O eq 'os2' ? ' # TODO: EMX v0.9d_fix4 bug: wrong nibble? ' : ''); 182 $todo = ($Config{usecrosscompile} ? '# TODO: Not sure whats going on here when cross-compiling' : ''); 183 print $? & 0xFF ? "ok $tn[4]$todo\n" : "not ok $tn[4]$todo\n"; 184 185 open(CMDPIPE, "|-", $PERL); 186 print CMDPIPE <<'END'; 187 188 sub PVBM () { 'foo' } 189 index 'foo', PVBM; 190 my $pvbm = PVBM; 191 192 sub foo { exit 0 } 193 194 $SIG{"INT"} = $pvbm; 195 kill "INT", $$; sleep 1; 196END 197 close CMDPIPE; 198 $? >>= 8 if $^O eq 'VMS'; 199 print $? ? "not ok $tn[5]\n" : "ok $tn[5]\n"; 200 201 curr_test(curr_test() + 5); 202} 203 204# can we slice ENV? 205@val1 = @ENV{keys(%ENV)}; 206@val2 = values(%ENV); 207is join(':',@val1), join(':',@val2); 208cmp_ok @val1, '>', 1; 209 210# deleting $::{ENV} 211is runperl(prog => 'delete $::{ENV}; chdir; print qq-ok\n-'), "ok\n", 212 'deleting $::{ENV}'; 213 214# regex vars 215'foobarbaz' =~ /b(a)r/; 216is $`, 'foo'; 217is $&, 'bar'; 218is $', 'baz'; 219is $+, 'a'; 220 221# [perl #24237] 222for (qw < ` & ' >) { 223 fresh_perl_is 224 qq < \@$_; q "fff" =~ /(?!^)./; print "[\$$_]\\n" >, 225 "[f]\n", {}, 226 "referencing \@$_ before \$$_ etc. still saws off ampersands"; 227} 228 229# $" 230@a = qw(foo bar baz); 231is "@a", "foo bar baz"; 232{ 233 local $" = ','; 234 is "@a", "foo,bar,baz"; 235} 236 237# $; 238%h = (); 239$h{'foo', 'bar'} = 1; 240is((keys %h)[0], "foo\034bar"); 241{ 242 local $; = 'x'; 243 %h = (); 244 $h{'foo', 'bar'} = 1; 245 is((keys %h)[0], 'fooxbar'); 246} 247 248# $?, $@, $$ 249system qq[$PERL "-I../lib" -e "use vmsish qw(hushed); exit(0)"]; 250is $?, 0; 251system qq[$PERL "-I../lib" -e "use vmsish qw(hushed); exit(1)"]; 252isnt $?, 0; 253 254eval { die "foo\n" }; 255is $@, "foo\n"; 256 257ok !*@{HASH}, 'no %@'; 258 259cmp_ok($$, '>', 0); 260my $pid = $$; 261eval { $$ = 42 }; 262is $$, 42, '$$ can be modified'; 263SKIP: { 264 skip "no fork", 1 unless $Config{d_fork}; 265 (my $kidpid = open my $fh, "-|") // skip "cannot fork: $!", 1; 266 if($kidpid) { # parent 267 my $kiddollars = <$fh>; 268 close $fh or die "cannot close pipe from kid proc: $!"; 269 is $kiddollars, $kidpid, '$$ is reset on fork'; 270 } 271 else { # child 272 print $$; 273 $::NO_ENDING = 1; # silence "Looks like you only ran..." 274 exit; 275 } 276} 277$$ = $pid; # Tests below use $$ 278 279# $^X and $0 280{ 281 my $is_abs = $Config{d_procselfexe} || $Config{usekernprocpathname} 282 || $Config{usensgetexecutablepath}; 283 if ($^O eq 'qnx') { 284 chomp($wd = `/usr/bin/fullpath -t`); 285 } 286 elsif($^O =~ /android/) { 287 chomp($wd = `sh -c 'pwd'`); 288 } 289 elsif($Is_Cygwin || $is_abs) { 290 # Cygwin turns the symlink into the real file 291 chomp($wd = `pwd`); 292 $wd =~ s#/t$##; 293 $wd =~ /(.*)/; $wd = $1; # untaint 294 if ($Is_Cygwin) { 295 $wd = Cygwin::win_to_posix_path(Cygwin::posix_to_win_path($wd, 1)); 296 } 297 } 298 elsif($Is_os2) { 299 $wd = Cwd::sys_cwd(); 300 } 301 else { 302 $wd = '.'; 303 } 304 my $perl = $Is_VMS || $is_abs ? $^X : "$wd/perl"; 305 my $headmaybe = ''; 306 my $middlemaybe = ''; 307 my $tailmaybe = ''; 308 $script = "$wd/show-shebang"; 309 if ($Is_MSWin32) { 310 chomp($wd = `cd`); 311 $wd =~ s|\\|/|g; 312 $perl = "$wd/perl.exe"; 313 $script = "$wd/show-shebang.bat"; 314 $headmaybe = <<EOH ; 315\@rem =' 316\@echo off 317$perl -x \%0 318goto endofperl 319\@rem '; 320EOH 321 $tailmaybe = <<EOT ; 322 323__END__ 324:endofperl 325EOT 326 } 327 elsif ($Is_os2) { 328 $script = "./show-shebang"; 329 } 330 elsif ($Is_VMS) { 331 $script = "[]show-shebang"; 332 } 333 elsif ($Is_Cygwin) { 334 $middlemaybe = <<'EOX' 335$^X = Cygwin::win_to_posix_path(Cygwin::posix_to_win_path($^X, 1)); 336$0 = Cygwin::win_to_posix_path(Cygwin::posix_to_win_path($0, 1)); 337EOX 338 } 339 if ($^O eq 'os390' or $^O eq 'posix-bc') { # no shebang 340 $headmaybe = <<EOH ; 341 eval 'exec ./perl -S \$0 \${1+"\$\@"}' 342 if 0; 343EOH 344 } 345 $s1 = "\$^X is $perl, \$0 is $script\n"; 346 ok open(SCRIPT, ">$script") or diag "Can't write to $script: $!"; 347 ok print(SCRIPT $headmaybe . <<EOB . $middlemaybe . <<'EOF' . $tailmaybe) or diag $!; 348#!$perl 349EOB 350print "\$^X is $^X, \$0 is $0\n"; 351EOF 352 ok close(SCRIPT) or diag $!; 353 ok chmod(0755, $script) or diag $!; 354 $_ = $Is_VMS ? `$perl $script` : `$script`; 355 s/\.exe//i if $Is_Dos or $Is_Cygwin or $Is_os2; 356 s{is perl}{is $perl}; # for systems where $^X is only a basename 357 s{\\}{/}g; 358 if ($Is_MSWin32 || $Is_os2) { 359 is uc $_, uc $s1; 360 } else { 361 SKIP: 362 { 363 skip "# TODO: Hit bug posix-2058; exec does not setup argv[0] correctly." if ($^O eq "vos"); 364 is $_, $s1; 365 } 366 } 367 $_ = `$perl $script`; 368 s/\.exe//i if $Is_Dos or $Is_os2 or $Is_Cygwin; 369 s{\\}{/}g; 370 if ($Is_MSWin32 || $Is_os2) { 371 is uc $_, uc $s1; 372 } else { 373 is $_, $s1; 374 } 375 ok unlink($script) or diag $!; 376 # CHECK 377 # Could this be replaced with: 378 # unlink_all($script); 379} 380 381# $], $^O, $^T 382cmp_ok $], '>=', 5.00319; 383ok $^O; 384cmp_ok $^T, '>', 850000000; 385 386# Test change 25062 is working 387my $orig_osname = $^O; 388{ 389local $^I = '.bak'; 390is $^O, $orig_osname, 'Assigning $^I does not clobber $^O'; 391} 392$^O = $orig_osname; 393 394{ 395 #RT #72422 396 foreach my $p (0, 1) { 397 fresh_perl_is(<<"EOP", '2 4 8', undef, "test \$^P = $p"); 398\$DB::single = 2; 399\$DB::trace = 4; 400\$DB::signal = 8; 401\$^P = $p; 402print "\$DB::single \$DB::trace \$DB::signal"; 403EOP 404 } 405} 406 407# Check that assigning to $0 on Linux sets the process name with both 408# argv[0] assignment and by calling prctl() 409{ 410 SKIP: { 411 skip "We don't have prctl() here, or we're on Android", 2 unless $Config{d_prctl_set_name} && $^O ne 'android'; 412 413 # We don't really need these tests. prctl() is tested in the 414 # Kernel, but test it anyway for our sanity. If something doesn't 415 # work (like if the system doesn't have a ps(1) for whatever 416 # reason) just bail out gracefully. 417 my $maybe_ps = sub { 418 my ($cmd) = @_; 419 local ($?, $!); 420 421 no warnings; 422 my $res = `$cmd`; 423 skip "Couldn't shell out to '$cmd', returned code $?", 2 if $?; 424 return $res; 425 }; 426 427 my $name = "Good Morning, Dave"; 428 $0 = $name; 429 430 chomp(my $argv0 = $maybe_ps->("ps h $$")); 431 chomp(my $prctl = $maybe_ps->("ps hc $$")); 432 433 like($argv0, qr/$name/, "Set process name through argv[0] ($argv0)"); 434 my $name_substr = substr($name, 0, 15); 435 like($prctl, qr/$name_substr/, "Set process name through prctl() ($prctl)"); 436 } 437} 438 439{ 440 my $ok = 1; 441 my $warn = ''; 442 local $SIG{'__WARN__'} = sub { $ok = 0; $warn = join '', @_; $warn =~ s/\n$//; }; 443 $! = undef; 444 local $TODO = $Is_VMS ? "'\$!=undef' does throw a warning" : ''; 445 ok($ok, $warn); 446} 447 448SKIP: { 449 skip_if_miniperl("miniperl can't rely on loading %Errno", 2); 450 no warnings 'void'; 451 452# Make sure Errno hasn't been prematurely autoloaded 453 454 ok !keys %Errno::; 455 456# Test auto-loading of Errno when %! is used 457 458 ok scalar eval q{ 459 %!; 460 scalar %Errno::; 461 }, $@; 462} 463 464SKIP: { 465 skip_if_miniperl("miniperl can't rely on loading %Errno", 2); 466 # Make sure that Errno loading doesn't clobber $! 467 468 undef %Errno::; 469 delete $INC{"Errno.pm"}; 470 delete $::{"!"}; 471 472 open(FOO, "nonesuch"); # Generate ENOENT 473 my %errs = %{"!"}; # Cause Errno.pm to be loaded at run-time 474 ok ${"!"}{ENOENT}; 475 476 # Make sure defined(*{"!"}) before %! does not stop %! from working 477 is 478 runperl( 479 prog => 'BEGIN { defined *{q-!-} } print qq-ok\n- if tied %!', 480 ), 481 "ok\n", 482 'defined *{"!"} does not stop %! from working'; 483} 484 485# Check that we don't auto-load packages 486foreach (['powie::!', 'Errno']) { 487 my ($symbol, $package) = @$_; 488 SKIP: { 489 (my $extension = $package) =~ s|::|/|g; 490 skip "$package is statically linked", 2 491 if $Config{static_ext} =~ m|\b\Q$extension\E\b|; 492 foreach my $scalar_first ('', '$$symbol;') { 493 my $desc = qq{Referencing %{"$symbol"}}; 494 $desc .= qq{ after mentioning \${"$symbol"}} if $scalar_first; 495 $desc .= " doesn't load $package"; 496 497 fresh_perl_is(<<"EOP", 0, {}, $desc); 498use strict qw(vars subs); 499my \$symbol = '$symbol'; 500$scalar_first; 5011 if %{\$symbol}; 502print scalar %${package}::; 503EOP 504 } 505 } 506} 507 508is $^S, 0; 509eval { is $^S,1 }; 510eval " BEGIN { ok ! defined \$^S } "; 511is $^S, 0; 512 513my $taint = ${^TAINT}; 514is ${^TAINT}, $taint; 515eval { ${^TAINT} = 1 }; 516is ${^TAINT}, $taint; 517 518# 5.6.1 had a bug: @+ and @- were not properly interpolated 519# into double-quoted strings 520# 20020414 mjd-perl-patch+@plover.com 521"I like pie" =~ /(I) (like) (pie)/; 522is "@-", "0 0 2 7"; 523is "@+", "10 1 6 10"; 524 525# Tests for the magic get of $\ 526{ 527 my $ok = 0; 528 # [perl #19330] 529 { 530 local $\ = undef; 531 $\++; $\++; 532 $ok = $\ eq 2; 533 } 534 ok $ok; 535 $ok = 0; 536 { 537 local $\ = "a\0b"; 538 $ok = "a$\b" eq "aa\0bb"; 539 } 540 ok $ok; 541} 542 543# Test for bug [perl #36434] 544# Can not do this test on VMS according to comments 545# in mg.c/Perl_magic_clear_all_env() 546SKIP: { 547 skip('Can\'t make assignment to \%ENV on this system', 3) if $Is_VMS; 548 549 local @ISA; 550 local %ENV; 551 # This used to be __PACKAGE__, but that causes recursive 552 # inheritance, which is detected earlier now and broke 553 # this test 554 eval { push @ISA, __FILE__ }; 555 is $@, '', 'Push a constant on a magic array'; 556 $@ and print "# $@"; 557 eval { %ENV = (PATH => __PACKAGE__) }; 558 is $@, '', 'Assign a constant to a magic hash'; 559 $@ and print "# $@"; 560 eval { my %h = qw(A B); %ENV = (PATH => (keys %h)[0]) }; 561 is $@, '', 'Assign a shared key to a magic hash'; 562 $@ and print "# $@"; 563} 564 565# Tests for Perl_magic_clearsig 566foreach my $sig (qw(__WARN__ INT)) { 567 $SIG{$sig} = lc $sig; 568 is $SIG{$sig}, 'main::' . lc $sig, "Can assign to $sig"; 569 is delete $SIG{$sig}, 'main::' . lc $sig, "Can delete from $sig"; 570 is $SIG{$sig}, undef, "$sig is now gone"; 571 is delete $SIG{$sig}, undef, "$sig remains gone"; 572} 573 574# And now one which doesn't exist; 575{ 576 no warnings 'signal'; 577 $SIG{HUNGRY} = 'mmm, pie'; 578} 579is $SIG{HUNGRY}, 'mmm, pie', 'Can assign to HUNGRY'; 580is delete $SIG{HUNGRY}, 'mmm, pie', 'Can delete from HUNGRY'; 581is $SIG{HUNGRY}, undef, "HUNGRY is now gone"; 582is delete $SIG{HUNGRY}, undef, "HUNGRY remains gone"; 583 584# Test deleting signals that we never set 585foreach my $sig (qw(__DIE__ _BOGUS_HOOK KILL THIRSTY)) { 586 is $SIG{$sig}, undef, "$sig is not present"; 587 is delete $SIG{$sig}, undef, "delete of $sig returns undef"; 588} 589 590{ 591 $! = 9999; 592 is int $!, 9999, q{[perl #72850] Core dump in bleadperl from perl -e '$! = 9999; $a = $!;'}; 593 594} 595 596# %+ %- 597SKIP: { 598 skip_if_miniperl("No XS in miniperl", 2); 599 # Make sure defined(*{"+"}) before %+ does not stop %+ from working 600 is 601 runperl( 602 prog => 'BEGIN { defined *{q-+-} } print qq-ok\n- if tied %+', 603 ), 604 "ok\n", 605 'defined *{"+"} does not stop %+ from working'; 606 is 607 runperl( 608 prog => 'BEGIN { defined *{q=-=} } print qq-ok\n- if tied %-', 609 ), 610 "ok\n", 611 'defined *{"-"} does not stop %- from working'; 612} 613 614SKIP: { 615 skip_if_miniperl("No XS in miniperl", 1); 616 617 for ( [qw( %! Errno )] ) { 618 my ($var, $mod) = @$_; 619 my $modfile = $mod =~ s|::|/|gr . ".pm"; 620 fresh_perl_is 621 qq 'sub UNIVERSAL::AUTOLOAD{} 622 $mod\::foo() if 0; 623 $var; 624 print "ok\\n" if \$INC{"$modfile"}', 625 "ok\n", 626 { switches => [ '-X' ] }, 627 "$var still loads $mod when stash and UNIVERSAL::AUTOLOAD exist"; 628 } 629} 630 631# ${^LAST_FH} 632() = tell STDOUT; 633is ${^LAST_FH}, \*STDOUT, '${^LAST_FH} after tell'; 634() = tell STDIN; 635is ${^LAST_FH}, \*STDIN, '${^LAST_FH} after another tell'; 636{ 637 my $fh = *STDOUT; 638 () = tell $fh; 639 is ${^LAST_FH}, \$fh, '${^LAST_FH} referencing lexical coercible glob'; 640} 641# This also tests that ${^LAST_FH} is a weak reference: 642is ${^LAST_FH}, undef, '${^LAST_FH} is undef when PL_last_in_gv is NULL'; 643 644# all of these would set PL_last_in_gv to a non-GV which would 645# assert when referenced by the magic for ${^LAST_FH}. 646# The approach to fixing this has changed (#128263), but it's still useful 647# to check each op. 648for my $code ('tell $0', 'sysseek $0, 0, 0', 'seek $0, 0, 0', 'eof $0') { 649 fresh_perl_is("$code; print defined \${^LAST_FH} ? qq(not ok\n) : qq(ok\n)", "ok\n", 650 undef, "check $code doesn't define \${^LAST_FH}"); 651} 652 653# $| 654fresh_perl_is 'print $| = ~$|', "1\n", {switches => ['-l']}, 655 '[perl #4760] print $| = ~$|'; 656fresh_perl_is 657 'select f; undef *f; ${q/|/}; print STDOUT qq|ok\n|', "ok\n", {}, 658 '[perl #115206] no crash when vivifying $| while *{+select}{IO} is undef'; 659 660# ${^OPEN} and $^H interaction 661# Setting ${^OPEN} causes $^H to change, but setting $^H would only some- 662# times make ${^OPEN} change, depending on whether it was in the same BEGIN 663# block. Don’t test actual values (subject to change); just test for 664# consistency. 665my @stuff; 666eval ' 667 BEGIN { ${^OPEN} = "a\0b"; $^H = 0; push @stuff, ${^OPEN} } 668 BEGIN { ${^OPEN} = "a\0b"; $^H = 0 } BEGIN { push @stuff, ${^OPEN} } 6691' or die $@; 670is $stuff[0], $stuff[1], '$^H modifies ${^OPEN} consistently'; 671 672# deleting $::{"\cH"} 673is runperl(prog => 'delete $::{qq-\cH-}; ${^OPEN}=foo; print qq-ok\n-'), 674 "ok\n", 675 'deleting $::{"\cH"}'; 676 677# Tests for some non-magic names: 678is ${^MPE}, undef, '${^MPE} starts undefined'; 679is ++${^MPE}, 1, '${^MPE} can be incremented'; 680 681# This one used to behave as ${^MATCH} due to a missing break: 682is ${^MPEN}, undef, '${^MPEN} starts undefined'; 683# This one used to croak due to that missing break: 684is ++${^MPEN}, 1, '${^MPEN} can be incremented'; 685 686{ 687 no warnings 'deprecated'; 688 eval { ${^E_NCODING} = 1 }; 689 is $@, "", 'Setting ${^E_NCODING} does nothing'; 690 $_ = ${^E_NCODING}; 691 pass('can read ${^E_NCODING} without blowing up'); 692 is $_, 1, '${^E_NCODING} is whatever it was set to'; 693} 694 695{ 696 my $warned = 0; 697 local $SIG{__WARN__} = sub { ++$warned if $_[0] =~ /Use of uninitialized value in unshift/; print "# @_"; }; 698 unshift @RT12608::A::ISA, qw(RT12608::B RT12608::C); 699 is $warned, 0, '[perl #126082] unshifting onto @ISA doesn\'t trigger set magic for each item'; 700} 701 702{ 703 my $warned = 0; 704 local $SIG{__WARN__} = sub { ++$warned if $_[0] =~ /Use of uninitialized value in unshift/; print "# @_"; }; 705 706 my $x; tie $x, 'RT12608::F'; 707 unshift @RT12608::X::ISA, $x, "RT12608::Z"; 708 is $warned, 0, '[perl #126082] PL_delaymagic correctly/saved restored when pushing/unshifting onto @ISA'; 709 710 package RT12608::F; 711 use parent 'Tie::Scalar'; 712 sub TIESCALAR { bless {}; } 713 sub FETCH { push @RT12608::G::ISA, "RT12608::H"; "RT12608::Y"; } 714} 715 716 717# ^^^^^^^^^ New tests go here ^^^^^^^^^ 718 719SKIP: { 720 skip("%ENV manipulations fail or aren't safe on $^O", 20) 721 if $Is_Dos; 722 skip "Win32 needs XS for env/shell tests", 20 723 if $Is_MSWin32 && is_miniperl; 724 725 SKIP: { 726 skip("clearing \%ENV is not safe when running under valgrind or on VMS") 727 if $ENV{PERL_VALGRIND} || $Is_VMS; 728 729 $PATH = $ENV{PATH}; 730 $SYSTEMROOT = $ENV{SYSTEMROOT} if exists $ENV{SYSTEMROOT}; # win32 731 $PDL = $ENV{PERL_DESTRUCT_LEVEL} || 0; 732 $ENV{foo} = "bar"; 733 %ENV = (); 734 $ENV{PATH} = $PATH; 735 $ENV{SYSTEMROOT} = $SYSTEMROOT if defined $SYSTEMROOT; 736 $ENV{PERL_DESTRUCT_LEVEL} = $PDL || 0; 737 if ($Is_MSWin32) { 738 is `set foo 2>NUL`, ""; 739 } else { 740 is `echo \$foo`, "\n"; 741 } 742 } 743 744 $ENV{__NoNeSuCh} = 'foo'; 745 $0 = 'bar'; 746 env_is(__NoNeSuCh => 'foo', 'setting $0 does not break %ENV'); 747 748 $ENV{__NoNeSuCh2} = 'foo'; 749 $ENV{__NoNeSuCh2} = undef; 750 env_is(__NoNeSuCh2 => '', 'setting a key as undef does not delete it'); 751 752 # stringify a glob 753 $ENV{foo} = *TODO; 754 env_is(foo => '*main::TODO', 'ENV store of stringified glob'); 755 756 # stringify a ref 757 my $ref = []; 758 $ENV{foo} = $ref; 759 env_is(foo => "$ref", 'ENV store of stringified ref'); 760 761 # downgrade utf8 when possible 762 $bytes = "eh zero \x{A0}"; 763 utf8::upgrade($chars = $bytes); 764 $forced = $ENV{foo} = $chars; 765 ok(!utf8::is_utf8($forced) && $forced eq $bytes, 'ENV store downgrades utf8 in SV'); 766 env_is(foo => $bytes, 'ENV store downgrades utf8 in setenv'); 767 fail 'chars should still be wide!' if !utf8::is_utf8($chars); 768 $ENV{$chars} = 'widekey'; 769 env_is("eh zero \x{A0}" => 'widekey', 'ENV store downgrades utf8 key in setenv'); 770 fail 'chars should still be wide!' if !utf8::is_utf8($chars); 771 is( delete($ENV{$chars}), 'widekey', 'delete(%ENV) downgrades utf8 key' ); 772 773 # warn when downgrading utf8 is not possible 774 $chars = "X-Day \x{1998}"; 775 utf8::encode($bytes = $chars); 776 { 777 my $warned = 0; 778 local $SIG{__WARN__} = sub { ++$warned if $_[0] =~ /^Wide character in setenv/; print "# @_" }; 779 $forced = $ENV{foo} = $chars; 780 ok($warned == 1, 'ENV store warns about wide characters'); 781 782 fail 'chars should still be wide!' if !utf8::is_utf8($chars); 783 $ENV{$chars} = 'widekey'; 784 env_is($forced => 'widekey', 'ENV store takes utf8-encoded key in setenv'); 785 786 ok($warned == 2, 'ENV key store warns about wide characters'); 787 } 788 ok(!utf8::is_utf8($forced) && $forced eq $bytes, 'ENV store encodes high utf8 in SV'); 789 env_is(foo => $bytes, 'ENV store encodes high utf8 in SV'); 790 791 # test local $ENV{foo} on existing foo 792 { 793 local $ENV{__NoNeSuCh}; 794 { local $TODO = 'exists on %ENV should reflect real env'; 795 ok(!exists $ENV{__NoNeSuCh}, 'not exists $ENV{existing} during local $ENV{existing}'); } 796 env_is(__NoNeLoCaL => ''); 797 } 798 ok(exists $ENV{__NoNeSuCh}, 'exists $ENV{existing} after local $ENV{existing}'); 799 env_is(__NoNeSuCh => 'foo'); 800 801 # test local $ENV{foo} on new foo 802 { 803 local $ENV{__NoNeLoCaL} = 'foo'; 804 ok(exists $ENV{__NoNeLoCaL}, 'exists $ENV{new} during local $ENV{new}'); 805 env_is(__NoNeLoCaL => 'foo'); 806 } 807 ok(!exists $ENV{__NoNeLoCaL}, 'not exists $ENV{new} after local $ENV{new}'); 808 env_is(__NoNeLoCaL => ''); 809 810 SKIP: { 811 skip("\$0 check only on Linux, Dragonfly BSD and FreeBSD", 2) 812 unless $^O =~ /^(linux|android|dragonfly|freebsd)$/; 813 814 SKIP: { 815 skip("No procfs cmdline support", 1) 816 unless open CMDLINE, "/proc/$$/cmdline"; 817 818 chomp(my $line = scalar <CMDLINE>); 819 my $me = (split /\0/, $line)[0]; 820 is $me, $0, 'altering $0 is effective (testing with /proc/)'; 821 close CMDLINE; 822 } 823 skip("No \$0 check with 'ps' on Android", 1) if $^O eq 'android'; 824 # perlbug #22811 825 my $mydollarzero = sub { 826 my($arg) = shift; 827 $0 = $arg if defined $arg; 828 # In FreeBSD the ps -o command= will cause 829 # an empty header line, grab only the last line. 830 my $ps = (`ps -o command= -p $$`)[-1]; 831 return if $?; 832 chomp $ps; 833 $ps; 834 }; 835 my $ps = $mydollarzero->("x"); 836 # we allow that something goes wrong with the ps command 837 !$ps && skip("The ps command failed", 1); 838 my $ps_re = ( $^O =~ /^(dragonfly|freebsd)$/ ) 839 # FreeBSD cannot get rid of both the leading "perl :" 840 # and the trailing " (perl)": some FreeBSD versions 841 # can get rid of the first one. 842 ? qr/^(?:(?:mini)?perl: )?x(?: \((?:mini)?perl\))?$/ 843 # In Linux 2.4 we would get an exact match ($ps eq 'x') but 844 # in Linux 2.2 there seems to be something funny going on: 845 # it seems as if the original length of the argv[] would 846 # be stored in the proc struct and then used by ps(1), 847 # no matter what characters we use to pad the argv[]. 848 # (And if we use \0:s, they are shown as spaces.) Sigh. 849 : qr/^x\s*$/ 850 ; 851 like($ps, $ps_re, 'altering $0 is effective (testing with `ps`)'); 852 } 853} 854 855# test case-insignificance of %ENV (these tests must be enabled only 856# when perl is compiled with -DENV_IS_CASELESS) 857SKIP: { 858 skip('no caseless %ENV support', 4) unless $Is_MSWin32 || $Is_NetWare; 859 860 %ENV = (); 861 $ENV{'Foo'} = 'bar'; 862 $ENV{'fOo'} = 'baz'; 863 is scalar(keys(%ENV)), 1; 864 ok exists $ENV{'FOo'}; 865 is delete $ENV{'foO'}, 'baz'; 866 is scalar(keys(%ENV)), 0; 867} 868 869__END__ 870 871# Put new tests before the various ENV tests, as they blow %ENV away. 872