1#!./perl 2 3BEGIN { 4 $| = 1; 5 chdir 't' if -d 't'; 6 @INC = '../lib'; 7 $ENV{PATH} = '/bin' if ${^TAINT}; 8 $SIG{__WARN__} = sub { die "Dying on warning: ", @_ }; 9 require './test.pl'; 10} 11 12use warnings; 13use Config; 14 15plan (tests => 80); 16 17$Is_MSWin32 = $^O eq 'MSWin32'; 18$Is_NetWare = $^O eq 'NetWare'; 19$Is_VMS = $^O eq 'VMS'; 20$Is_Dos = $^O eq 'dos'; 21$Is_os2 = $^O eq 'os2'; 22$Is_Cygwin = $^O eq 'cygwin'; 23$Is_MPE = $^O eq 'mpeix'; 24$Is_miniperl = $ENV{PERL_CORE_MINITEST}; 25$Is_BeOS = $^O eq 'beos'; 26 27$PERL = $ENV{PERL} 28 || ($Is_NetWare ? 'perl' : 29 $Is_VMS ? $^X : 30 $Is_MSWin32 ? '.\perl' : 31 './perl'); 32 33END { 34 # On VMS, environment variable changes are peristent after perl exits 35 delete $ENV{'FOO'} if $Is_VMS; 36} 37 38eval '$ENV{"FOO"} = "hi there";'; # check that ENV is inited inside eval 39# cmd.exe will echo 'variable=value' but 4nt will echo just the value 40# -- Nikola Knezevic 41if ($Is_MSWin32) { like `set FOO`, qr/^(?:FOO=)?hi there$/; } 42elsif ($Is_VMS) { is `write sys\$output f\$trnlnm("FOO")`, "hi there\n"; } 43else { is `echo \$FOO`, "hi there\n"; } 44 45unlink 'ajslkdfpqjsjfk'; 46$! = 0; 47open(FOO,'ajslkdfpqjsjfk'); 48isnt($!, 0); 49close FOO; # just mention it, squelch used-only-once 50 51SKIP: { 52 skip('SIGINT not safe on this platform', 5) 53 if $Is_MSWin32 || $Is_NetWare || $Is_Dos || $Is_MPE; 54 # the next tests are done in a subprocess because sh spits out a 55 # newline onto stderr when a child process kills itself with SIGINT. 56 # We use a pipe rather than system() because the VMS command buffer 57 # would overflow with a command that long. 58 59 open( CMDPIPE, "| $PERL"); 60 61 print CMDPIPE <<'END'; 62 63 $| = 1; # command buffering 64 65 $SIG{"INT"} = "ok3"; kill "INT",$$; sleep 1; 66 $SIG{"INT"} = "IGNORE"; kill "INT",$$; sleep 1; print "ok 4\n"; 67 $SIG{"INT"} = "DEFAULT"; kill "INT",$$; sleep 1; print "not ok 4\n"; 68 69 sub ok3 { 70 if (($x = pop(@_)) eq "INT") { 71 print "ok 3\n"; 72 } 73 else { 74 print "not ok 3 ($x @_)\n"; 75 } 76 } 77 78END 79 80 close CMDPIPE; 81 82 open( CMDPIPE, "| $PERL"); 83 print CMDPIPE <<'END'; 84 85 { package X; 86 sub DESTROY { 87 kill "INT",$$; 88 } 89 } 90 sub x { 91 my $x=bless [], 'X'; 92 return sub { $x }; 93 } 94 $| = 1; # command buffering 95 $SIG{"INT"} = "ok5"; 96 { 97 local $SIG{"INT"}=x(); 98 print ""; # Needed to expose failure in 5.8.0 (why?) 99 } 100 sleep 1; 101 delete $SIG{"INT"}; 102 kill "INT",$$; sleep 1; 103 sub ok5 { 104 print "ok 5\n"; 105 } 106END 107 close CMDPIPE; 108 $? >>= 8 if $^O eq 'VMS'; # POSIX status hiding in 2nd byte 109 my $todo = ($^O eq 'os2' ? ' # TODO: EMX v0.9d_fix4 bug: wrong nibble? ' : ''); 110 print $? & 0xFF ? "ok 6$todo\n" : "not ok 6$todo\n"; 111 112 open(CMDPIPE, "| $PERL"); 113 print CMDPIPE <<'END'; 114 115 sub PVBM () { 'foo' } 116 index 'foo', PVBM; 117 my $pvbm = PVBM; 118 119 sub foo { exit 0 } 120 121 $SIG{"INT"} = $pvbm; 122 kill "INT", $$; sleep 1; 123END 124 close CMDPIPE; 125 $? >>= 8 if $^O eq 'VMS'; 126 print $? ? "not ok 7\n" : "ok 7\n"; 127 128 curr_test(curr_test() + 5); 129} 130 131# can we slice ENV? 132@val1 = @ENV{keys(%ENV)}; 133@val2 = values(%ENV); 134is join(':',@val1), join(':',@val2); 135cmp_ok @val1, '>', 1; 136 137# regex vars 138'foobarbaz' =~ /b(a)r/; 139is $`, 'foo'; 140is $&, 'bar'; 141is $', 'baz'; 142is $+, 'a'; 143 144# $" 145@a = qw(foo bar baz); 146is "@a", "foo bar baz"; 147{ 148 local $" = ','; 149 is "@a", "foo,bar,baz"; 150} 151 152# $; 153%h = (); 154$h{'foo', 'bar'} = 1; 155is((keys %h)[0], "foo\034bar"); 156{ 157 local $; = 'x'; 158 %h = (); 159 $h{'foo', 'bar'} = 1; 160 is((keys %h)[0], 'fooxbar'); 161} 162 163# $?, $@, $$ 164system qq[$PERL "-I../lib" -e "use vmsish qw(hushed); exit(0)"]; 165is $?, 0; 166system qq[$PERL "-I../lib" -e "use vmsish qw(hushed); exit(1)"]; 167isnt $?, 0; 168 169eval { die "foo\n" }; 170is $@, "foo\n"; 171 172cmp_ok($$, '>', 0); 173eval { $$++ }; 174like ($@, qr/^Modification of a read-only value attempted/); 175 176# $^X and $0 177{ 178 if ($^O eq 'qnx') { 179 chomp($wd = `/usr/bin/fullpath -t`); 180 } 181 elsif($Is_Cygwin || $Config{'d_procselfexe'}) { 182 # Cygwin turns the symlink into the real file 183 chomp($wd = `pwd`); 184 $wd =~ s#/t$##; 185 $wd =~ /(.*)/; $wd = $1; # untaint 186 if ($Is_Cygwin) { 187 $wd = Cygwin::win_to_posix_path(Cygwin::posix_to_win_path($wd, 1)); 188 } 189 } 190 elsif($Is_os2) { 191 $wd = Cwd::sys_cwd(); 192 } 193 else { 194 $wd = '.'; 195 } 196 my $perl = $Is_VMS ? $^X : "$wd/perl"; 197 my $headmaybe = ''; 198 my $middlemaybe = ''; 199 my $tailmaybe = ''; 200 $script = "$wd/show-shebang"; 201 if ($Is_MSWin32) { 202 chomp($wd = `cd`); 203 $wd =~ s|\\|/|g; 204 $perl = "$wd/perl.exe"; 205 $script = "$wd/show-shebang.bat"; 206 $headmaybe = <<EOH ; 207\@rem =' 208\@echo off 209$perl -x \%0 210goto endofperl 211\@rem '; 212EOH 213 $tailmaybe = <<EOT ; 214 215__END__ 216:endofperl 217EOT 218 } 219 elsif ($Is_os2) { 220 $script = "./show-shebang"; 221 } 222 elsif ($Is_VMS) { 223 $script = "[]show-shebang"; 224 } 225 elsif ($Is_Cygwin) { 226 $middlemaybe = <<'EOX' 227$^X = Cygwin::win_to_posix_path(Cygwin::posix_to_win_path($^X, 1)); 228$0 = Cygwin::win_to_posix_path(Cygwin::posix_to_win_path($0, 1)); 229EOX 230 } 231 if ($^O eq 'os390' or $^O eq 'posix-bc' or $^O eq 'vmesa') { # no shebang 232 $headmaybe = <<EOH ; 233 eval 'exec ./perl -S \$0 \${1+"\$\@"}' 234 if 0; 235EOH 236 } 237 $s1 = "\$^X is $perl, \$0 is $script\n"; 238 ok open(SCRIPT, ">$script") or diag "Can't write to $script: $!"; 239 ok print(SCRIPT $headmaybe . <<EOB . $middlemaybe . <<'EOF' . $tailmaybe) or diag $!; 240#!$wd/perl 241EOB 242print "\$^X is $^X, \$0 is $0\n"; 243EOF 244 ok close(SCRIPT) or diag $!; 245 ok chmod(0755, $script) or diag $!; 246 $_ = $Is_VMS ? `$perl $script` : `$script`; 247 s/\.exe//i if $Is_Dos or $Is_Cygwin or $Is_os2; 248 s{./$script}{$script} if $Is_BeOS; # revert BeOS execvp() side-effect 249 s{\bminiperl\b}{perl}; # so that test doesn't fail with miniperl 250 s{is perl}{is $perl}; # for systems where $^X is only a basename 251 s{\\}{/}g; 252 if ($Is_MSWin32 || $Is_os2) { 253 is uc $_, uc $s1; 254 } else { 255 is $_, $s1; 256 } 257 $_ = `$perl $script`; 258 s/\.exe//i if $Is_Dos or $Is_os2 or $Is_Cygwin; 259 s{./$perl}{$perl} if $Is_BeOS; # revert BeOS execvp() side-effect 260 s{\\}{/}g; 261 if ($Is_MSWin32 || $Is_os2) { 262 is uc $_, uc $s1; 263 } else { 264 is $_, $s1; 265 } 266 ok unlink($script) or diag $!; 267} 268 269# $], $^O, $^T 270cmp_ok $], '>=', 5.00319; 271ok $^O; 272cmp_ok $^T, '>', 850000000; 273 274# Test change 25062 is working 275my $orig_osname = $^O; 276{ 277local $^I = '.bak'; 278is $^O, $orig_osname, 'Assigning $^I does not clobber $^O'; 279} 280$^O = $orig_osname; 281 282SKIP: { 283 skip("%ENV manipulations fail or aren't safe on $^O", 4) 284 if $Is_VMS || $Is_Dos; 285 286 SKIP: { 287 skip("clearing \%ENV is not safe when running under valgrind") 288 if $ENV{PERL_VALGRIND}; 289 290 $PATH = $ENV{PATH}; 291 $PDL = $ENV{PERL_DESTRUCT_LEVEL} || 0; 292 $ENV{foo} = "bar"; 293 %ENV = (); 294 $ENV{PATH} = $PATH; 295 $ENV{PERL_DESTRUCT_LEVEL} = $PDL || 0; 296 if ($Is_MSWin32) { 297 is `set foo 2>NUL`, ""; 298 } else { 299 is `echo \$foo`, "\n"; 300 } 301 } 302 303 $ENV{__NoNeSuCh} = "foo"; 304 $0 = "bar"; 305# cmd.exe will echo 'variable=value' but 4nt will echo just the value 306# -- Nikola Knezevic 307 if ($Is_MSWin32) { 308 like `set __NoNeSuCh`, qr/^(?:__NoNeSuCh=)?foo$/; 309 } else { 310 is `echo \$__NoNeSuCh`, "foo\n"; 311 } 312 SKIP: { 313 skip("\$0 check only on Linux and FreeBSD", 2) 314 unless $^O =~ /^(linux|freebsd)$/ 315 && open CMDLINE, "/proc/$$/cmdline"; 316 317 chomp(my $line = scalar <CMDLINE>); 318 my $me = (split /\0/, $line)[0]; 319 is $me, $0, 'altering $0 is effective (testing with /proc/)'; 320 close CMDLINE; 321 # perlbug #22811 322 my $mydollarzero = sub { 323 my($arg) = shift; 324 $0 = $arg if defined $arg; 325 # In FreeBSD the ps -o command= will cause 326 # an empty header line, grab only the last line. 327 my $ps = (`ps -o command= -p $$`)[-1]; 328 return if $?; 329 chomp $ps; 330 printf "# 0[%s]ps[%s]\n", $0, $ps; 331 $ps; 332 }; 333 my $ps = $mydollarzero->("x"); 334 ok(!$ps # we allow that something goes wrong with the ps command 335 # In Linux 2.4 we would get an exact match ($ps eq 'x') but 336 # in Linux 2.2 there seems to be something funny going on: 337 # it seems as if the original length of the argv[] would 338 # be stored in the proc struct and then used by ps(1), 339 # no matter what characters we use to pad the argv[]. 340 # (And if we use \0:s, they are shown as spaces.) Sigh. 341 || $ps =~ /^x\s*$/ 342 # FreeBSD cannot get rid of both the leading "perl :" 343 # and the trailing " (perl)": some FreeBSD versions 344 # can get rid of the first one. 345 || ($^O eq 'freebsd' && $ps =~ m/^(?:perl: )?x(?: \(perl\))?$/), 346 'altering $0 is effective (testing with `ps`)'); 347 } 348} 349 350{ 351 my $ok = 1; 352 my $warn = ''; 353 local $SIG{'__WARN__'} = sub { $ok = 0; $warn = join '', @_; $warn =~ s/\n$//; }; 354 $! = undef; 355 local $TODO = $Is_VMS ? "'\$!=undef' does throw a warning" : ''; 356 ok($ok, $warn); 357} 358 359# test case-insignificance of %ENV (these tests must be enabled only 360# when perl is compiled with -DENV_IS_CASELESS) 361SKIP: { 362 skip('no caseless %ENV support', 4) unless $Is_MSWin32 || $Is_NetWare; 363 364 %ENV = (); 365 $ENV{'Foo'} = 'bar'; 366 $ENV{'fOo'} = 'baz'; 367 is scalar(keys(%ENV)), 1; 368 ok exists $ENV{'FOo'}; 369 is delete $ENV{'foO'}, 'baz'; 370 is scalar(keys(%ENV)), 0; 371} 372 373SKIP: { 374 skip ("miniperl can't rely on loading %Errno", 2) if $Is_miniperl; 375 no warnings 'void'; 376 377# Make sure Errno hasn't been prematurely autoloaded 378 379 ok !keys %Errno::; 380 381# Test auto-loading of Errno when %! is used 382 383 ok scalar eval q{ 384 %!; 385 scalar %Errno::; 386 }, $@; 387} 388 389SKIP: { 390 skip ("miniperl can't rely on loading %Errno") if $Is_miniperl; 391 # Make sure that Errno loading doesn't clobber $! 392 393 undef %Errno::; 394 delete $INC{"Errno.pm"}; 395 396 open(FOO, "nonesuch"); # Generate ENOENT 397 my %errs = %{"!"}; # Cause Errno.pm to be loaded at run-time 398 ok ${"!"}{ENOENT}; 399} 400 401is $^S, 0; 402eval { is $^S,1 }; 403eval " BEGIN { ok ! defined \$^S } "; 404is $^S, 0; 405 406my $taint = ${^TAINT}; 407is ${^TAINT}, $taint; 408eval { ${^TAINT} = 1 }; 409is ${^TAINT}, $taint; 410 411# 5.6.1 had a bug: @+ and @- were not properly interpolated 412# into double-quoted strings 413# 20020414 mjd-perl-patch+@plover.com 414"I like pie" =~ /(I) (like) (pie)/; 415is "@-", "0 0 2 7"; 416is "@+", "10 1 6 10"; 417 418# Tests for the magic get of $\ 419{ 420 my $ok = 0; 421 # [perl #19330] 422 { 423 local $\ = undef; 424 $\++; $\++; 425 $ok = $\ eq 2; 426 } 427 ok $ok; 428 $ok = 0; 429 { 430 local $\ = "a\0b"; 431 $ok = "a$\b" eq "aa\0bb"; 432 } 433 ok $ok; 434} 435 436# Test for bug [perl #27839] 437{ 438 my $x; 439 sub f { 440 "abc" =~ /(.)./; 441 $x = "@+"; 442 return @+; 443 }; 444 my @y = f(); 445 is $x, "@y", "return a magic array ($x) vs (@y)"; 446} 447 448# Test for bug [perl #36434] 449# Can not do this test on VMS, EPOC, and SYMBIAN according to comments 450# in mg.c/Perl_magic_clear_all_env() 451SKIP: { 452 skip('Can\'t make assignment to \%ENV on this system', 3) if $Is_VMS; 453 454 local @ISA; 455 local %ENV; 456 # This used to be __PACKAGE__, but that causes recursive 457 # inheritance, which is detected earlier now and broke 458 # this test 459 eval { push @ISA, __FILE__ }; 460 is $@, '', 'Push a constant on a magic array'; 461 $@ and print "# $@"; 462 eval { %ENV = (PATH => __PACKAGE__) }; 463 is $@, '', 'Assign a constant to a magic hash'; 464 $@ and print "# $@"; 465 eval { my %h = qw(A B); %ENV = (PATH => (keys %h)[0]) }; 466 is $@, '', 'Assign a shared key to a magic hash'; 467 $@ and print "# $@"; 468} 469 470# Tests for Perl_magic_clearsig 471foreach my $sig (qw(__WARN__ INT)) { 472 $SIG{$sig} = lc $sig; 473 is $SIG{$sig}, 'main::' . lc $sig, "Can assign to $sig"; 474 is delete $SIG{$sig}, 'main::' . lc $sig, "Can delete from $sig"; 475 is $SIG{$sig}, undef, "$sig is now gone"; 476 is delete $SIG{$sig}, undef, "$sig remains gone"; 477} 478 479# And now one which doesn't exist; 480{ 481 no warnings 'signal'; 482 $SIG{HUNGRY} = 'mmm, pie'; 483} 484is $SIG{HUNGRY}, 'mmm, pie', 'Can assign to HUNGRY'; 485is delete $SIG{HUNGRY}, 'mmm, pie', 'Can delete from HUNGRY'; 486is $SIG{HUNGRY}, undef, "HUNGRY is now gone"; 487is delete $SIG{HUNGRY}, undef, "HUNGRY remains gone"; 488 489# Test deleting signals that we never set 490foreach my $sig (qw(__DIE__ _BOGUS_HOOK KILL THIRSTY)) { 491 is $SIG{$sig}, undef, "$sig is not present"; 492 is delete $SIG{$sig}, undef, "delete of $sig returns undef"; 493} 494 495{ 496 $! = 9999; 497 is int $!, 9999, q{[perl #72850] Core dump in bleadperl from perl -e '$! = 9999; $a = $!;'}; 498 499} 500