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