1#!./perl 2 3BEGIN { 4 $| = 1; 5 chdir 't' if -d 't'; 6 require './test.pl'; 7 set_up_inc( '../lib' ); 8 plan (tests => 195); # 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$/; } 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 ['powie::+', 'Tie::Hash::NamedCapture']) { 488 my ($symbol, $package) = @$_; 489 SKIP: { 490 (my $extension = $package) =~ s|::|/|g; 491 skip "$package is statically linked", 2 492 if $Config{static_ext} =~ m|\b\Q$extension\E\b|; 493 foreach my $scalar_first ('', '$$symbol;') { 494 my $desc = qq{Referencing %{"$symbol"}}; 495 $desc .= qq{ after mentioning \${"$symbol"}} if $scalar_first; 496 $desc .= " doesn't load $package"; 497 498 fresh_perl_is(<<"EOP", 0, {}, $desc); 499use strict qw(vars subs); 500my \$symbol = '$symbol'; 501$scalar_first; 5021 if %{\$symbol}; 503print scalar %${package}::; 504EOP 505 } 506 } 507} 508 509is $^S, 0; 510eval { is $^S,1 }; 511eval " BEGIN { ok ! defined \$^S } "; 512is $^S, 0; 513 514my $taint = ${^TAINT}; 515is ${^TAINT}, $taint; 516eval { ${^TAINT} = 1 }; 517is ${^TAINT}, $taint; 518 519# 5.6.1 had a bug: @+ and @- were not properly interpolated 520# into double-quoted strings 521# 20020414 mjd-perl-patch+@plover.com 522"I like pie" =~ /(I) (like) (pie)/; 523is "@-", "0 0 2 7"; 524is "@+", "10 1 6 10"; 525 526# Tests for the magic get of $\ 527{ 528 my $ok = 0; 529 # [perl #19330] 530 { 531 local $\ = undef; 532 $\++; $\++; 533 $ok = $\ eq 2; 534 } 535 ok $ok; 536 $ok = 0; 537 { 538 local $\ = "a\0b"; 539 $ok = "a$\b" eq "aa\0bb"; 540 } 541 ok $ok; 542} 543 544# Test for bug [perl #36434] 545# Can not do this test on VMS, and SYMBIAN according to comments 546# in mg.c/Perl_magic_clear_all_env() 547SKIP: { 548 skip('Can\'t make assignment to \%ENV on this system', 3) if $Is_VMS; 549 550 local @ISA; 551 local %ENV; 552 # This used to be __PACKAGE__, but that causes recursive 553 # inheritance, which is detected earlier now and broke 554 # this test 555 eval { push @ISA, __FILE__ }; 556 is $@, '', 'Push a constant on a magic array'; 557 $@ and print "# $@"; 558 eval { %ENV = (PATH => __PACKAGE__) }; 559 is $@, '', 'Assign a constant to a magic hash'; 560 $@ and print "# $@"; 561 eval { my %h = qw(A B); %ENV = (PATH => (keys %h)[0]) }; 562 is $@, '', 'Assign a shared key to a magic hash'; 563 $@ and print "# $@"; 564} 565 566# Tests for Perl_magic_clearsig 567foreach my $sig (qw(__WARN__ INT)) { 568 $SIG{$sig} = lc $sig; 569 is $SIG{$sig}, 'main::' . lc $sig, "Can assign to $sig"; 570 is delete $SIG{$sig}, 'main::' . lc $sig, "Can delete from $sig"; 571 is $SIG{$sig}, undef, "$sig is now gone"; 572 is delete $SIG{$sig}, undef, "$sig remains gone"; 573} 574 575# And now one which doesn't exist; 576{ 577 no warnings 'signal'; 578 $SIG{HUNGRY} = 'mmm, pie'; 579} 580is $SIG{HUNGRY}, 'mmm, pie', 'Can assign to HUNGRY'; 581is delete $SIG{HUNGRY}, 'mmm, pie', 'Can delete from HUNGRY'; 582is $SIG{HUNGRY}, undef, "HUNGRY is now gone"; 583is delete $SIG{HUNGRY}, undef, "HUNGRY remains gone"; 584 585# Test deleting signals that we never set 586foreach my $sig (qw(__DIE__ _BOGUS_HOOK KILL THIRSTY)) { 587 is $SIG{$sig}, undef, "$sig is not present"; 588 is delete $SIG{$sig}, undef, "delete of $sig returns undef"; 589} 590 591{ 592 $! = 9999; 593 is int $!, 9999, q{[perl #72850] Core dump in bleadperl from perl -e '$! = 9999; $a = $!;'}; 594 595} 596 597# %+ %- 598SKIP: { 599 skip_if_miniperl("No XS in miniperl", 2); 600 # Make sure defined(*{"+"}) before %+ does not stop %+ from working 601 is 602 runperl( 603 prog => 'BEGIN { defined *{q-+-} } print qq-ok\n- if tied %+', 604 ), 605 "ok\n", 606 'defined *{"+"} does not stop %+ from working'; 607 is 608 runperl( 609 prog => 'BEGIN { defined *{q=-=} } print qq-ok\n- if tied %-', 610 ), 611 "ok\n", 612 'defined *{"-"} does not stop %- from working'; 613} 614 615SKIP: { 616 skip_if_miniperl("No XS in miniperl", 2); 617 618 for ( [qw( %- Tie::Hash::NamedCapture )], 619 [qw( %! Errno )] ) { 620 my ($var, $mod) = @$_; 621 my $modfile = $mod =~ s|::|/|gr . ".pm"; 622 fresh_perl_is 623 qq 'sub UNIVERSAL::AUTOLOAD{} 624 $mod\::foo() if 0; 625 $var; 626 print "ok\\n" if \$INC{"$modfile"}', 627 "ok\n", 628 { switches => [ '-X' ] }, 629 "$var still loads $mod when stash and UNIVERSAL::AUTOLOAD exist"; 630 } 631} 632 633# ${^LAST_FH} 634() = tell STDOUT; 635is ${^LAST_FH}, \*STDOUT, '${^LAST_FH} after tell'; 636() = tell STDIN; 637is ${^LAST_FH}, \*STDIN, '${^LAST_FH} after another tell'; 638{ 639 my $fh = *STDOUT; 640 () = tell $fh; 641 is ${^LAST_FH}, \$fh, '${^LAST_FH} referencing lexical coercible glob'; 642} 643# This also tests that ${^LAST_FH} is a weak reference: 644is ${^LAST_FH}, undef, '${^LAST_FH} is undef when PL_last_in_gv is NULL'; 645 646# all of these would set PL_last_in_gv to a non-GV which would 647# assert when referenced by the magic for ${^LAST_FH}. 648# The approach to fixing this has changed (#128263), but it's still useful 649# to check each op. 650for my $code ('tell $0', 'sysseek $0, 0, 0', 'seek $0, 0, 0', 'eof $0') { 651 fresh_perl_is("$code; print defined \${^LAST_FH} ? qq(not ok\n) : qq(ok\n)", "ok\n", 652 undef, "check $code doesn't define \${^LAST_FH}"); 653} 654 655# $| 656fresh_perl_is 'print $| = ~$|', "1\n", {switches => ['-l']}, 657 '[perl #4760] print $| = ~$|'; 658fresh_perl_is 659 'select f; undef *f; ${q/|/}; print STDOUT qq|ok\n|', "ok\n", {}, 660 '[perl #115206] no crash when vivifying $| while *{+select}{IO} is undef'; 661 662# ${^OPEN} and $^H interaction 663# Setting ${^OPEN} causes $^H to change, but setting $^H would only some- 664# times make ${^OPEN} change, depending on whether it was in the same BEGIN 665# block. Don’t test actual values (subject to change); just test for 666# consistency. 667my @stuff; 668eval ' 669 BEGIN { ${^OPEN} = "a\0b"; $^H = 0; push @stuff, ${^OPEN} } 670 BEGIN { ${^OPEN} = "a\0b"; $^H = 0 } BEGIN { push @stuff, ${^OPEN} } 6711' or die $@; 672is $stuff[0], $stuff[1], '$^H modifies ${^OPEN} consistently'; 673 674# deleting $::{"\cH"} 675is runperl(prog => 'delete $::{qq-\cH-}; ${^OPEN}=foo; print qq-ok\n-'), 676 "ok\n", 677 'deleting $::{"\cH"}'; 678 679# Tests for some non-magic names: 680is ${^MPE}, undef, '${^MPE} starts undefined'; 681is ++${^MPE}, 1, '${^MPE} can be incremented'; 682 683# This one used to behave as ${^MATCH} due to a missing break: 684is ${^MPEN}, undef, '${^MPEN} starts undefined'; 685# This one used to croak due to that missing break: 686is ++${^MPEN}, 1, '${^MPEN} can be incremented'; 687 688{ 689 no warnings 'deprecated'; 690 eval { ${^E_NCODING} = 1 }; 691 is $@, "", 'Setting ${^E_NCODING} does nothing'; 692 $_ = ${^E_NCODING}; 693 pass('can read ${^E_NCODING} without blowing up'); 694 is $_, 1, '${^E_NCODING} is whatever it was set to'; 695} 696 697{ 698 my $warned = 0; 699 local $SIG{__WARN__} = sub { ++$warned if $_[0] =~ /Use of uninitialized value in unshift/; print "# @_"; }; 700 unshift @RT12608::A::ISA, qw(RT12608::B RT12608::C); 701 is $warned, 0, '[perl #126082] unshifting onto @ISA doesn\'t trigger set magic for each item'; 702} 703 704{ 705 my $warned = 0; 706 local $SIG{__WARN__} = sub { ++$warned if $_[0] =~ /Use of uninitialized value in unshift/; print "# @_"; }; 707 708 my $x; tie $x, 'RT12608::F'; 709 unshift @RT12608::X::ISA, $x, "RT12608::Z"; 710 is $warned, 0, '[perl #126082] PL_delaymagic correctly/saved restored when pushing/unshifting onto @ISA'; 711 712 package RT12608::F; 713 use parent 'Tie::Scalar'; 714 sub TIESCALAR { bless {}; } 715 sub FETCH { push @RT12608::G::ISA, "RT12608::H"; "RT12608::Y"; } 716} 717 718 719# ^^^^^^^^^ New tests go here ^^^^^^^^^ 720 721SKIP: { 722 skip("%ENV manipulations fail or aren't safe on $^O", 20) 723 if $Is_Dos; 724 skip "Win32 needs XS for env/shell tests", 20 725 if $Is_MSWin32 && is_miniperl; 726 727 SKIP: { 728 skip("clearing \%ENV is not safe when running under valgrind or on VMS") 729 if $ENV{PERL_VALGRIND} || $Is_VMS; 730 731 $PATH = $ENV{PATH}; 732 $SYSTEMROOT = $ENV{SYSTEMROOT} if exists $ENV{SYSTEMROOT}; # win32 733 $PDL = $ENV{PERL_DESTRUCT_LEVEL} || 0; 734 $ENV{foo} = "bar"; 735 %ENV = (); 736 $ENV{PATH} = $PATH; 737 $ENV{SYSTEMROOT} = $SYSTEMROOT if defined $SYSTEMROOT; 738 $ENV{PERL_DESTRUCT_LEVEL} = $PDL || 0; 739 if ($Is_MSWin32) { 740 is `set foo 2>NUL`, ""; 741 } else { 742 is `echo \$foo`, "\n"; 743 } 744 } 745 746 $ENV{__NoNeSuCh} = 'foo'; 747 $0 = 'bar'; 748 env_is(__NoNeSuCh => 'foo', 'setting $0 does not break %ENV'); 749 750 $ENV{__NoNeSuCh2} = 'foo'; 751 $ENV{__NoNeSuCh2} = undef; 752 env_is(__NoNeSuCh2 => '', 'setting a key as undef does not delete it'); 753 754 # stringify a glob 755 $ENV{foo} = *TODO; 756 env_is(foo => '*main::TODO', 'ENV store of stringified glob'); 757 758 # stringify a ref 759 my $ref = []; 760 $ENV{foo} = $ref; 761 env_is(foo => "$ref", 'ENV store of stringified ref'); 762 763 # downgrade utf8 when possible 764 $bytes = "eh zero \x{A0}"; 765 utf8::upgrade($chars = $bytes); 766 $forced = $ENV{foo} = $chars; 767 ok(!utf8::is_utf8($forced) && $forced eq $bytes, 'ENV store downgrades utf8 in SV'); 768 env_is(foo => $bytes, 'ENV store downgrades utf8 in setenv'); 769 770 # warn when downgrading utf8 is not possible 771 $chars = "X-Day \x{1998}"; 772 utf8::encode($bytes = $chars); 773 { 774 my $warned = 0; 775 local $SIG{__WARN__} = sub { ++$warned if $_[0] =~ /^Wide character in setenv/; print "# @_" }; 776 $forced = $ENV{foo} = $chars; 777 ok($warned == 1, 'ENV store warns about wide characters'); 778 } 779 ok(!utf8::is_utf8($forced) && $forced eq $bytes, 'ENV store encodes high utf8 in SV'); 780 env_is(foo => $bytes, 'ENV store encodes high utf8 in SV'); 781 782 # test local $ENV{foo} on existing foo 783 { 784 local $ENV{__NoNeSuCh}; 785 { local $TODO = 'exists on %ENV should reflect real env'; 786 ok(!exists $ENV{__NoNeSuCh}, 'not exists $ENV{existing} during local $ENV{existing}'); } 787 env_is(__NoNeLoCaL => ''); 788 } 789 ok(exists $ENV{__NoNeSuCh}, 'exists $ENV{existing} after local $ENV{existing}'); 790 env_is(__NoNeSuCh => 'foo'); 791 792 # test local $ENV{foo} on new foo 793 { 794 local $ENV{__NoNeLoCaL} = 'foo'; 795 ok(exists $ENV{__NoNeLoCaL}, 'exists $ENV{new} during local $ENV{new}'); 796 env_is(__NoNeLoCaL => 'foo'); 797 } 798 ok(!exists $ENV{__NoNeLoCaL}, 'not exists $ENV{new} after local $ENV{new}'); 799 env_is(__NoNeLoCaL => ''); 800 801 SKIP: { 802 skip("\$0 check only on Linux and FreeBSD", 2) 803 unless $^O =~ /^(linux|android|freebsd)$/ 804 && open CMDLINE, "/proc/$$/cmdline"; 805 806 chomp(my $line = scalar <CMDLINE>); 807 my $me = (split /\0/, $line)[0]; 808 is $me, $0, 'altering $0 is effective (testing with /proc/)'; 809 close CMDLINE; 810 skip("\$0 check with 'ps' only on Linux (but not Android) and FreeBSD", 1) if $^O eq 'android'; 811 # perlbug #22811 812 my $mydollarzero = sub { 813 my($arg) = shift; 814 $0 = $arg if defined $arg; 815 # In FreeBSD the ps -o command= will cause 816 # an empty header line, grab only the last line. 817 my $ps = (`ps -o command= -p $$`)[-1]; 818 return if $?; 819 chomp $ps; 820 printf "# 0[%s]ps[%s]\n", $0, $ps; 821 $ps; 822 }; 823 my $ps = $mydollarzero->("x"); 824 ok(!$ps # we allow that something goes wrong with the ps command 825 # In Linux 2.4 we would get an exact match ($ps eq 'x') but 826 # in Linux 2.2 there seems to be something funny going on: 827 # it seems as if the original length of the argv[] would 828 # be stored in the proc struct and then used by ps(1), 829 # no matter what characters we use to pad the argv[]. 830 # (And if we use \0:s, they are shown as spaces.) Sigh. 831 || $ps =~ /^x\s*$/ 832 # FreeBSD cannot get rid of both the leading "perl :" 833 # and the trailing " (perl)": some FreeBSD versions 834 # can get rid of the first one. 835 || ($^O eq 'freebsd' && $ps =~ m/^(?:perl: )?x(?: \(perl\))?$/), 836 'altering $0 is effective (testing with `ps`)'); 837 } 838} 839 840# test case-insignificance of %ENV (these tests must be enabled only 841# when perl is compiled with -DENV_IS_CASELESS) 842SKIP: { 843 skip('no caseless %ENV support', 4) unless $Is_MSWin32 || $Is_NetWare; 844 845 %ENV = (); 846 $ENV{'Foo'} = 'bar'; 847 $ENV{'fOo'} = 'baz'; 848 is scalar(keys(%ENV)), 1; 849 ok exists $ENV{'FOo'}; 850 is delete $ENV{'foO'}, 'baz'; 851 is scalar(keys(%ENV)), 0; 852} 853 854__END__ 855 856# Put new tests before the various ENV tests, as they blow %ENV away. 857