t/op/magic.t

   1 #!./perl
   2
   3 BEGIN {
   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
  12 use warnings;
  13 use Config;
  14
  15 plan (tests => 79);
  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
  34 END {
  35     # On VMS, environment variable changes are peristent after perl exits
  36     delete $ENV{'FOO'} if $Is_VMS;
  37 }
  38
  39 eval '$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
  42 if ($Is_MSWin32)  { like `set FOO`, qr/^(?:FOO=)?hi there$/; }
  43 elsif ($Is_MacOS) { ok "1 # skipped", 1; }
  44 elsif ($Is_VMS)   { is `write sys\$output f\$trnlnm("FOO")`, "hi there\n"; }
  45 else              { is `echo \$FOO`, "hi there\n"; }
  46
  47 unlink 'ajslkdfpqjsjfk';
  48 $! = 0;
  49 open(FOO,'ajslkdfpqjsjfk');
  50 isnt($!, 0);
  51 close FOO; # just mention it, squelch used-only-once
  52
  53 SKIP: {
  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
  80 END
  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     }
 108 END
 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;
 125 END
 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);
 136 is join(':',@val1), join(':',@val2);
 137 cmp_ok @val1, '>', 1;
 138
 139 # regex vars
 140 'foobarbaz' =~ /b(a)r/;
 141 is $`, 'foo';
 142 is $&, 'bar';
 143 is $', 'baz';
 144 is $+, 'a';
 145
 146 # $"
 147 @a = qw(foo bar baz);
 148 is "@a", "foo bar baz";
 149 {
 150     local $" = ',';
 151     is "@a", "foo,bar,baz";
 152 }
 153
 154 # $;
 155 %h = ();
 156 $h{'foo', 'bar'} = 1;
 157 is((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 # $?, $@, $$
 166 SKIP:  {
 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
 174 eval { die "foo\n" };
 175 is $@, "foo\n";
 176
 177 cmp_ok($$, '>', 0);
 178 eval { $$++ };
 179 like ($@, 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        $wd =~ /(.*)/; $wd = $1; # untaint
 191        if ($Is_Cygwin) {
 192            $wd = Cygwin::win_to_posix_path(Cygwin::posix_to_win_path($wd, 1));
 193        }
 194     }
 195     elsif($Is_os2) {
 196        $wd = Cwd::sys_cwd();
 197     }
 198     elsif($Is_MacOS) {
 199        $wd = ':';
 200     }
 201     else {
 202         $wd = '.';
 203     }
 204     my $perl = ($Is_MacOS || $Is_VMS) ? $^X : "$wd/perl";
 205     my $headmaybe = '';
 206     my $middlemaybe = '';
 207     my $tailmaybe = '';
 208     $script = "$wd/show-shebang";
 209     if ($Is_MSWin32) {
 210         chomp($wd = `cd`);
 211         $wd =~ s|\\|/|g;
 212         $perl = "$wd/perl.exe";
 213         $script = "$wd/show-shebang.bat";
 214         $headmaybe = <<EOH ;
 215 \@rem ='
 216 \@echo off
 217 $perl -x \%0
 218 goto endofperl
 219 \@rem ';
 220 EOH
 221         $tailmaybe = <<EOT ;
 222
 223 __END__
 224 :endofperl
 225 EOT
 226     }
 227     elsif ($Is_os2) {
 228       $script = "./show-shebang";
 229     }
 230     elsif ($Is_MacOS) {
 231       $script = ":show-shebang";
 232     }
 233     elsif ($Is_VMS) {
 234       $script = "[]show-shebang";
 235     }
 236     elsif ($Is_Cygwin) {
 237       $middlemaybe = <<'EOX'
 238 $^X = Cygwin::win_to_posix_path(Cygwin::posix_to_win_path($^X, 1));
 239 $0 = Cygwin::win_to_posix_path(Cygwin::posix_to_win_path($0, 1));
 240 EOX
 241     }
 242     if ($^O eq 'os390' or $^O eq 'posix-bc' or $^O eq 'vmesa') {  # no shebang
 243         $headmaybe = <<EOH ;
 244     eval 'exec ./perl -S \$0 \${1+"\$\@"}'
 245         if 0;
 246 EOH
 247     }
 248     $s1 = "\$^X is $perl, \$0 is $script\n";
 249     ok open(SCRIPT, ">$script") or diag "Can't write to $script: $!";
 250     ok print(SCRIPT $headmaybe . <<EOB . $middlemaybe . <<'EOF' . $tailmaybe) or diag $!;
 251 #!$wd/perl
 252 EOB
 253 print "\$^X is $^X, \$0 is $0\n";
 254 EOF
 255     ok close(SCRIPT) or diag $!;
 256     ok chmod(0755, $script) or diag $!;
 257     $_ = ($Is_MacOS || $Is_VMS) ? `$perl $script` : `$script`;
 258     s/\.exe//i if $Is_Dos or $Is_Cygwin or $Is_os2;
 259     s{./$script}{$script} if $Is_BeOS; # revert BeOS execvp() side-effect
 260     s{\bminiperl\b}{perl}; # so that test doesn't fail with miniperl
 261     s{is perl}{is $perl}; # for systems where $^X is only a basename
 262     s{\\}{/}g;
 263     if ($Is_MSWin32 || $Is_os2) {
 264         is uc $_, uc $s1;
 265     } else {
 266         is $_, $s1;
 267     }
 268     $_ = `$perl $script`;
 269     s/\.exe//i if $Is_Dos or $Is_os2 or $Is_Cygwin;
 270     s{./$perl}{$perl} if $Is_BeOS; # revert BeOS execvp() side-effect
 271     s{\\}{/}g;
 272     if ($Is_MSWin32 || $Is_os2) {
 273         is uc $_, uc $s1;
 274     } else {
 275         is $_, $s1;
 276     }
 277     ok unlink($script) or diag $!;
 278 }
 279
 280 # $], $^O, $^T
 281 cmp_ok $], '>=', 5.00319;
 282 ok $^O;
 283 cmp_ok $^T, '>', 850000000;
 284
 285 # Test change 25062 is working
 286 my $orig_osname = $^O;
 287 {
 288 local $^I = '.bak';
 289 is $^O, $orig_osname, 'Assigning $^I does not clobber $^O';
 290 }
 291 $^O = $orig_osname;
 292
 293 SKIP: {
 294     skip("%ENV manipulations fail or aren't safe on $^O", 4)
 295         if $Is_VMS || $Is_Dos || $Is_MacOS;
 296
 297  SKIP: {
 298         skip("clearing \%ENV is not safe when running under valgrind")
 299             if $ENV{PERL_VALGRIND};
 300
 301             $PATH = $ENV{PATH};
 302             $PDL = $ENV{PERL_DESTRUCT_LEVEL} || 0;
 303             $ENV{foo} = "bar";
 304             %ENV = ();
 305             $ENV{PATH} = $PATH;
 306             $ENV{PERL_DESTRUCT_LEVEL} = $PDL || 0;
 307             if ($Is_MSWin32) {
 308                 is `set foo 2>NUL`, "";
 309             } else {
 310                 is `echo \$foo`, "\n";
 311             }
 312         }
 313
 314         $ENV{__NoNeSuCh} = "foo";
 315         $0 = "bar";
 316 # cmd.exe will echo 'variable=value' but 4nt will echo just the value
 317 # -- Nikola Knezevic
 318         if ($Is_MSWin32) {
 319             like `set __NoNeSuCh`, qr/^(?:__NoNeSuCh=)?foo$/;
 320         } else {
 321             is `echo \$__NoNeSuCh`, "foo\n";
 322         }
 323     SKIP: {
 324             skip("\$0 check only on Linux and FreeBSD", 2)
 325                 unless $^O =~ /^(linux|freebsd)$/
 326                     && open CMDLINE, "/proc/$$/cmdline";
 327
 328             chomp(my $line = scalar <CMDLINE>);
 329             my $me = (split /\0/, $line)[0];
 330             is $me, $0, 'altering $0 is effective (testing with /proc/)';
 331             close CMDLINE;
 332             # perlbug #22811
 333             my $mydollarzero = sub {
 334               my($arg) = shift;
 335               $0 = $arg if defined $arg;
 336               # In FreeBSD the ps -o command= will cause
 337               # an empty header line, grab only the last line.
 338               my $ps = (`ps -o command= -p $$`)[-1];
 339               return if $?;
 340               chomp $ps;
 341               printf "# 0[%s]ps[%s]\n", $0, $ps;
 342               $ps;
 343             };
 344             my $ps = $mydollarzero->("x");
 345             ok(!$ps  # we allow that something goes wrong with the ps command
 346                # In Linux 2.4 we would get an exact match ($ps eq 'x') but
 347                # in Linux 2.2 there seems to be something funny going on:
 348                # it seems as if the original length of the argv[] would
 349                # be stored in the proc struct and then used by ps(1),
 350                # no matter what characters we use to pad the argv[].
 351                # (And if we use \0:s, they are shown as spaces.)  Sigh.
 352                || $ps =~ /^x\s*$/
 353                # FreeBSD cannot get rid of both the leading "perl :"
 354                # and the trailing " (perl)": some FreeBSD versions
 355                # can get rid of the first one.
 356                || ($^O eq 'freebsd' && $ps =~ m/^(?:perl: )?x(?: \(perl\))?$/),
 357                        'altering $0 is effective (testing with `ps`)');
 358         }
 359 }
 360
 361 {
 362     my $ok = 1;
 363     my $warn = '';
 364     local $SIG{'__WARN__'} = sub { $ok = 0; $warn = join '', @_; $warn =~ s/\n$//; };
 365     $! = undef;
 366     local $TODO = $Is_VMS ? "'\$!=undef' does throw a warning" : '';
 367     ok($ok, $warn);
 368 }
 369
 370 # test case-insignificance of %ENV (these tests must be enabled only
 371 # when perl is compiled with -DENV_IS_CASELESS)
 372 SKIP: {
 373     skip('no caseless %ENV support', 4) unless $Is_MSWin32 || $Is_NetWare;
 374
 375     %ENV = ();
 376     $ENV{'Foo'} = 'bar';
 377     $ENV{'fOo'} = 'baz';
 378     is scalar(keys(%ENV)), 1;
 379     ok exists $ENV{'FOo'};
 380     is delete $ENV{'foO'}, 'baz';
 381     is scalar(keys(%ENV)), 0;
 382 }
 383
 384 SKIP: {
 385     skip ("miniperl can't rely on loading %Errno", 2) if $Is_miniperl;
 386    no warnings 'void';
 387
 388 # Make sure Errno hasn't been prematurely autoloaded
 389
 390    ok !keys %Errno::;
 391
 392 # Test auto-loading of Errno when %! is used
 393
 394    ok scalar eval q{
 395       %!;
 396       defined %Errno::;
 397    }, $@;
 398 }
 399
 400 SKIP:  {
 401     skip ("miniperl can't rely on loading %Errno") if $Is_miniperl;
 402     # Make sure that Errno loading doesn't clobber $!
 403
 404     undef %Errno::;
 405     delete $INC{"Errno.pm"};
 406
 407     open(FOO, "nonesuch"); # Generate ENOENT
 408     my %errs = %{"!"}; # Cause Errno.pm to be loaded at run-time
 409     ok ${"!"}{ENOENT};
 410 }
 411
 412 is $^S, 0;
 413 eval { is $^S,1 };
 414 eval " BEGIN { ok ! defined \$^S } ";
 415 is $^S, 0;
 416
 417 my $taint = ${^TAINT};
 418 is ${^TAINT}, $taint;
 419 eval { ${^TAINT} = 1 };
 420 is ${^TAINT}, $taint;
 421
 422 # 5.6.1 had a bug: @+ and @- were not properly interpolated
 423 # into double-quoted strings
 424 # 20020414 mjd-perl-patch+@plover.com
 425 "I like pie" =~ /(I) (like) (pie)/;
 426 is "@-",  "0 0 2 7";
 427 is "@+", "10 1 6 10";
 428
 429 # Tests for the magic get of $\
 430 {
 431     my $ok = 0;
 432     # [perl #19330]
 433     {
 434         local $\ = undef;
 435         $\++; $\++;
 436         $ok = $\ eq 2;
 437     }
 438     ok $ok;
 439     $ok = 0;
 440     {
 441         local $\ = "a\0b";
 442         $ok = "a$\b" eq "aa\0bb";
 443     }
 444     ok $ok;
 445 }
 446
 447 # Test for bug [perl #27839]
 448 {
 449     my $x;
 450     sub f {
 451         "abc" =~ /(.)./;
 452         $x = "@+";
 453         return @+;
 454     };
 455     my @y = f();
 456     is $x, "@y", "return a magic array ($x) vs (@y)";
 457 }
 458
 459 # Test for bug [perl #36434]
 460 # Can not do this test on VMS, EPOC, and SYMBIAN according to comments
 461 # in mg.c/Perl_magic_clear_all_env()
 462 SKIP: {
 463     skip('Can\'t make assignment to \%ENV on this system', 3) if $Is_VMS;
 464
 465     local @ISA;
 466     local %ENV;
 467     # This used to be __PACKAGE__, but that causes recursive
 468     #  inheritance, which is detected earlier now and broke
 469     #  this test
 470     eval { push @ISA, __FILE__ };
 471     is $@, '', 'Push a constant on a magic array';
 472     $@ and print "# $@";
 473     eval { %ENV = (PATH => __PACKAGE__) };
 474     is $@, '', 'Assign a constant to a magic hash';
 475     $@ and print "# $@";
 476     eval { my %h = qw(A B); %ENV = (PATH => (keys %h)[0]) };
 477     is $@, '', 'Assign a shared key to a magic hash';
 478     $@ and print "# $@";
 479 }
 480
 481 # Tests for Perl_magic_clearsig
 482 foreach my $sig (qw(__WARN__ INT)) {
 483     $SIG{$sig} = lc $sig;
 484     is $SIG{$sig}, 'main::' . lc $sig, "Can assign to $sig";
 485     is delete $SIG{$sig}, 'main::' . lc $sig, "Can delete from $sig";
 486     is $SIG{$sig}, undef, "$sig is now gone";
 487     is delete $SIG{$sig}, undef, "$sig remains gone";
 488 }
 489
 490 # And now one which doesn't exist;
 491 {
 492     no warnings 'signal';
 493     $SIG{HUNGRY} = 'mmm, pie';
 494 }
 495 is $SIG{HUNGRY}, 'mmm, pie', 'Can assign to HUNGRY';
 496 is delete $SIG{HUNGRY}, 'mmm, pie', 'Can delete from HUNGRY';
 497 is $SIG{HUNGRY}, undef, "HUNGRY is now gone";
 498 is delete $SIG{HUNGRY}, undef, "HUNGRY remains gone";
 499
 500 # Test deleting signals that we never set
 501 foreach my $sig (qw(__DIE__ _BOGUS_HOOK KILL THIRSTY)) {
 502     is $SIG{$sig}, undef, "$sig is not present";
 503     is delete $SIG{$sig}, undef, "delete of $sig returns undef";
 504 }