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