t/op/magic.t

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