37a1754022b1ab9c946c7d12f4dea3e4d71031d6
[perl.git] / t / op / magic.t
1 #!./perl
2
3 BEGIN {
4     $| = 1;
5     chdir 't' if -d 't';
6     @INC = '../lib';
7     require './test.pl';
8     plan (tests => 145);
9 }
10
11 # Test that defined() returns true for magic variables created on the fly,
12 # even before they have been created.
13 # This must come first, even before turning on warnings or setting up
14 # $SIG{__WARN__}, to avoid invalidating the tests.  warnings.pm currently
15 # does not mention any special variables, but that could easily change.
16 BEGIN {
17     for (qw(
18         SIG ^OPEN ^TAINT ^UNICODE ^UTF8LOCALE ^WARNING_BITS 1 2 3 4 5 6 7 8
19         9 42 & ` ' : ? ! _ - # [ ^ ~ = % . ( ) < > \ / $ | + ; ] ^A ^C ^D
20         ^E ^F ^H ^I ^L ^N ^O ^P ^S ^T ^V ^W
21     )) {
22         my $v = $_;
23         # avoid using any global vars here:
24         if ($v =~ s/^\^(?=.)//) {
25             for(substr $v, 0, 1) {
26                 $_ = chr ord() - 64;
27             }
28         }
29         ok defined *$v, "*$_ appears to be defined at the outset"
30     }
31 }
32
33 # This must be in a separate BEGIN block, as the mere mention of ${^TAINT}
34 # will invalidate the test for it.
35 BEGIN {
36     $ENV{PATH} = '/bin' if ${^TAINT};
37     $SIG{__WARN__} = sub { die "Dying on warning: ", @_ };
38 }
39
40 use warnings;
41 use Config;
42
43
44 $Is_MSWin32  = $^O eq 'MSWin32';
45 $Is_NetWare  = $^O eq 'NetWare';
46 $Is_VMS      = $^O eq 'VMS';
47 $Is_Dos      = $^O eq 'dos';
48 $Is_os2      = $^O eq 'os2';
49 $Is_Cygwin   = $^O eq 'cygwin';
50 $Is_MPE      = $^O eq 'mpeix';          
51 $Is_BeOS     = $^O eq 'beos';
52
53 $PERL = $ENV{PERL}
54     || ($Is_NetWare           ? 'perl'   :
55        $Is_VMS                ? $^X      :
56        $Is_MSWin32            ? '.\perl' :
57        './perl');
58
59 END {
60     # On VMS, environment variable changes are peristent after perl exits
61     delete $ENV{'FOO'} if $Is_VMS;
62 }
63
64 eval '$ENV{"FOO"} = "hi there";';       # check that ENV is inited inside eval
65 # cmd.exe will echo 'variable=value' but 4nt will echo just the value
66 # -- Nikola Knezevic
67 if ($Is_MSWin32)  { like `set FOO`, qr/^(?:FOO=)?hi there$/; }
68 elsif ($Is_VMS)   { is `write sys\$output f\$trnlnm("FOO")`, "hi there\n"; }
69 else              { is `echo \$FOO`, "hi there\n"; }
70
71 unlink_all 'ajslkdfpqjsjfk';
72 $! = 0;
73 open(FOO,'ajslkdfpqjsjfk');
74 isnt($!, 0);
75 close FOO; # just mention it, squelch used-only-once
76
77 SKIP: {
78     skip('SIGINT not safe on this platform', 5)
79         if $Is_MSWin32 || $Is_NetWare || $Is_Dos || $Is_MPE;
80   # the next tests are done in a subprocess because sh spits out a
81   # newline onto stderr when a child process kills itself with SIGINT.
82   # We use a pipe rather than system() because the VMS command buffer
83   # would overflow with a command that long.
84
85     # For easy interpolation of test numbers:
86     $next_test = curr_test() - 1;
87     sub TIEARRAY {bless[]}
88     sub FETCH { $next_test + pop }
89     tie my @tn, __PACKAGE__;
90
91     open( CMDPIPE, "| $PERL");
92
93     print CMDPIPE "\$t1 = $tn[1]; \$t2 = $tn[2];\n", <<'END';
94
95     $| = 1;             # command buffering
96
97     $SIG{"INT"} = "ok1";     kill "INT",$$; sleep 1;
98     $SIG{"INT"} = "IGNORE";  kill "INT",$$; sleep 1; print "ok $t2\n";
99     $SIG{"INT"} = "DEFAULT"; kill "INT",$$; sleep 1; print" not ok $t2\n";
100
101     sub ok1 {
102         if (($x = pop(@_)) eq "INT") {
103             print "ok $t1\n";
104         }
105         else {
106             print "not ok $t1 ($x @_)\n";
107         }
108     }
109
110 END
111
112     close CMDPIPE;
113
114     open( CMDPIPE, "| $PERL");
115     print CMDPIPE "\$t3 = $tn[3];\n", <<'END';
116
117     { package X;
118         sub DESTROY {
119             kill "INT",$$;
120         }
121     }
122     sub x {
123         my $x=bless [], 'X';
124         return sub { $x };
125     }
126     $| = 1;             # command buffering
127     $SIG{"INT"} = "ok3";
128     {
129         local $SIG{"INT"}=x();
130         print ""; # Needed to expose failure in 5.8.0 (why?)
131     }
132     sleep 1;
133     delete $SIG{"INT"};
134     kill "INT",$$; sleep 1;
135     sub ok3 {
136         print "ok $t3\n";
137     }
138 END
139     close CMDPIPE;
140     $? >>= 8 if $^O eq 'VMS'; # POSIX status hiding in 2nd byte
141     my $todo = ($^O eq 'os2' ? ' # TODO: EMX v0.9d_fix4 bug: wrong nibble? ' : '');
142     print $? & 0xFF ? "ok $tn[4]$todo\n" : "not ok $tn[4]$todo\n";
143
144     open(CMDPIPE, "| $PERL");
145     print CMDPIPE <<'END';
146
147     sub PVBM () { 'foo' }
148     index 'foo', PVBM;
149     my $pvbm = PVBM;
150
151     sub foo { exit 0 }
152
153     $SIG{"INT"} = $pvbm;
154     kill "INT", $$; sleep 1;
155 END
156     close CMDPIPE;
157     $? >>= 8 if $^O eq 'VMS';
158     print $? ? "not ok $tn[5]\n" : "ok $tn[5]\n";
159
160     curr_test(curr_test() + 5);
161 }
162
163 # can we slice ENV?
164 @val1 = @ENV{keys(%ENV)};
165 @val2 = values(%ENV);
166 is join(':',@val1), join(':',@val2);
167 cmp_ok @val1, '>', 1;
168
169 # regex vars
170 'foobarbaz' =~ /b(a)r/;
171 is $`, 'foo';
172 is $&, 'bar';
173 is $', 'baz';
174 is $+, 'a';
175
176 # $"
177 @a = qw(foo bar baz);
178 is "@a", "foo bar baz";
179 {
180     local $" = ',';
181     is "@a", "foo,bar,baz";
182 }
183
184 # $;
185 %h = ();
186 $h{'foo', 'bar'} = 1;
187 is((keys %h)[0], "foo\034bar");
188 {
189     local $; = 'x';
190     %h = ();
191     $h{'foo', 'bar'} = 1;
192     is((keys %h)[0], 'fooxbar');
193 }
194
195 # $?, $@, $$
196 system qq[$PERL "-I../lib" -e "use vmsish qw(hushed); exit(0)"];
197 is $?, 0;
198 system qq[$PERL "-I../lib" -e "use vmsish qw(hushed); exit(1)"];
199 isnt $?, 0;
200
201 eval { die "foo\n" };
202 is $@, "foo\n";
203
204 cmp_ok($$, '>', 0);
205 my $pid = $$;
206 eval { $$ = 42 };
207 is $$, 42, '$$ can be modified';
208 SKIP: {
209     skip "no fork", 1 unless $Config{d_fork};
210     (my $kidpid = open my $fh, "-|") // skip "cannot fork: $!", 1;
211     if($kidpid) { # parent
212         my $kiddollars = <$fh>;
213         close $fh or die "cannot close pipe from kid proc: $!";
214         is $kiddollars, $kidpid, '$$ is reset on fork';
215     }
216     else { # child
217         print $$;
218         $::NO_ENDING = 1; # silence "Looks like you only ran..."
219         exit;
220     }
221 }
222 $$ = $pid; # Tests below use $$
223
224 # $^X and $0
225 {
226     if ($^O eq 'qnx') {
227         chomp($wd = `/usr/bin/fullpath -t`);
228     }
229     elsif($Is_Cygwin || $Config{'d_procselfexe'}) {
230        # Cygwin turns the symlink into the real file
231        chomp($wd = `pwd`);
232        $wd =~ s#/t$##;
233        $wd =~ /(.*)/; $wd = $1; # untaint
234        if ($Is_Cygwin) {
235            $wd = Cygwin::win_to_posix_path(Cygwin::posix_to_win_path($wd, 1));
236        }
237     }
238     elsif($Is_os2) {
239        $wd = Cwd::sys_cwd();
240     }
241     else {
242         $wd = '.';
243     }
244     my $perl = $Is_VMS || $Config{d_procselfexe} ? $^X : "$wd/perl";
245     my $headmaybe = '';
246     my $middlemaybe = '';
247     my $tailmaybe = '';
248     $script = "$wd/show-shebang";
249     if ($Is_MSWin32) {
250         chomp($wd = `cd`);
251         $wd =~ s|\\|/|g;
252         $perl = "$wd/perl.exe";
253         $script = "$wd/show-shebang.bat";
254         $headmaybe = <<EOH ;
255 \@rem ='
256 \@echo off
257 $perl -x \%0
258 goto endofperl
259 \@rem ';
260 EOH
261         $tailmaybe = <<EOT ;
262
263 __END__
264 :endofperl
265 EOT
266     }
267     elsif ($Is_os2) {
268       $script = "./show-shebang";
269     }
270     elsif ($Is_VMS) {
271       $script = "[]show-shebang";
272     }
273     elsif ($Is_Cygwin) {
274       $middlemaybe = <<'EOX'
275 $^X = Cygwin::win_to_posix_path(Cygwin::posix_to_win_path($^X, 1));
276 $0 = Cygwin::win_to_posix_path(Cygwin::posix_to_win_path($0, 1));
277 EOX
278     }
279     if ($^O eq 'os390' or $^O eq 'posix-bc' or $^O eq 'vmesa') {  # no shebang
280         $headmaybe = <<EOH ;
281     eval 'exec ./perl -S \$0 \${1+"\$\@"}'
282         if 0;
283 EOH
284     }
285     $s1 = "\$^X is $perl, \$0 is $script\n";
286     ok open(SCRIPT, ">$script") or diag "Can't write to $script: $!";
287     ok print(SCRIPT $headmaybe . <<EOB . $middlemaybe . <<'EOF' . $tailmaybe) or diag $!;
288 #!$perl
289 EOB
290 print "\$^X is $^X, \$0 is $0\n";
291 EOF
292     ok close(SCRIPT) or diag $!;
293     ok chmod(0755, $script) or diag $!;
294     $_ = $Is_VMS ? `$perl $script` : `$script`;
295     s/\.exe//i if $Is_Dos or $Is_Cygwin or $Is_os2;
296     s{./$script}{$script} if $Is_BeOS; # revert BeOS execvp() side-effect
297     s{is perl}{is $perl}; # for systems where $^X is only a basename
298     s{\\}{/}g;
299     if ($Is_MSWin32 || $Is_os2) {
300         is uc $_, uc $s1;
301     } else {
302         is $_, $s1;
303     }
304     $_ = `$perl $script`;
305     s/\.exe//i if $Is_Dos or $Is_os2 or $Is_Cygwin;
306     s{./$perl}{$perl} if $Is_BeOS; # revert BeOS execvp() side-effect
307     s{\\}{/}g;
308     if ($Is_MSWin32 || $Is_os2) {
309         is uc $_, uc $s1;
310     } else {
311         is $_, $s1;
312     }
313     ok unlink($script) or diag $!;
314     # CHECK
315     # Could this be replaced with:
316     # unlink_all($script);
317 }
318
319 # $], $^O, $^T
320 cmp_ok $], '>=', 5.00319;
321 ok $^O;
322 cmp_ok $^T, '>', 850000000;
323
324 # Test change 25062 is working
325 my $orig_osname = $^O;
326 {
327 local $^I = '.bak';
328 is $^O, $orig_osname, 'Assigning $^I does not clobber $^O';
329 }
330 $^O = $orig_osname;
331
332 {
333     #RT #72422
334     foreach my $p (0, 1) {
335         fresh_perl_is(<<"EOP", '2 4 8', undef, "test \$^P = $p");
336 \$DB::single = 2;
337 \$DB::trace = 4;
338 \$DB::signal = 8;
339 \$^P = $p;
340 print "\$DB::single \$DB::trace \$DB::signal";
341 EOP
342     }
343 }
344
345 # Check that assigning to $0 on Linux sets the process name with both
346 # argv[0] assignment and by calling prctl()
347 {
348   SKIP: {
349     skip "We don't have prctl() here", 2 unless $Config{d_prctl_set_name};
350
351     # We don't really need these tests. prctl() is tested in the
352     # Kernel, but test it anyway for our sanity. If something doesn't
353     # work (like if the system doesn't have a ps(1) for whatever
354     # reason) just bail out gracefully.
355     my $maybe_ps = sub {
356         my ($cmd) = @_;
357         local ($?, $!);
358
359         no warnings;
360         my $res = `$cmd`;
361         skip "Couldn't shell out to `$cmd', returned code $?", 2 if $?;
362         return $res;
363     };
364
365     my $name = "Good Morning, Dave";
366     $0 = $name;
367
368     chomp(my $argv0 = $maybe_ps->("ps h $$"));
369     chomp(my $prctl = $maybe_ps->("ps hc $$"));
370
371     like($argv0, $name, "Set process name through argv[0] ($argv0)");
372     like($prctl, substr($name, 0, 15), "Set process name through prctl() ($prctl)");
373   }
374 }
375
376 {
377     my $ok = 1;
378     my $warn = '';
379     local $SIG{'__WARN__'} = sub { $ok = 0; $warn = join '', @_; $warn =~ s/\n$//; };
380     $! = undef;
381     local $TODO = $Is_VMS ? "'\$!=undef' does throw a warning" : '';
382     ok($ok, $warn);
383 }
384
385 SKIP: {
386     skip_if_miniperl("miniperl can't rely on loading %Errno", 2);
387    no warnings 'void';
388
389 # Make sure Errno hasn't been prematurely autoloaded
390
391    ok !keys %Errno::;
392
393 # Test auto-loading of Errno when %! is used
394
395    ok scalar eval q{
396       %!;
397       scalar %Errno::;
398    }, $@;
399 }
400
401 SKIP:  {
402     skip_if_miniperl("miniperl can't rely on loading %Errno", 1);
403     # Make sure that Errno loading doesn't clobber $!
404
405     undef %Errno::;
406     delete $INC{"Errno.pm"};
407
408     open(FOO, "nonesuch"); # Generate ENOENT
409     my %errs = %{"!"}; # Cause Errno.pm to be loaded at run-time
410     ok ${"!"}{ENOENT};
411 }
412
413 # Check that we don't auto-load packages
414 SKIP: {
415     skip "staticly linked; may be preloaded", 4 unless $Config{usedl};
416     foreach (['powie::!', 'Errno'],
417              ['powie::+', 'Tie::Hash::NamedCapture']) {
418         my ($symbol, $package) = @$_;
419         foreach my $scalar_first ('', '$$symbol;') {
420             my $desc = qq{Referencing %{"$symbol"}};
421             $desc .= qq{ after mentioning \${"$symbol"}} if $scalar_first;
422             $desc .= " doesn't load $package";
423
424             fresh_perl_is(<<"EOP", 0, {}, $desc);
425 use strict qw(vars subs);
426 my \$symbol = '$symbol';
427 $scalar_first;
428 1 if %{\$symbol};
429 print scalar %${package}::;
430 EOP
431         }
432     }
433 }
434
435 is $^S, 0;
436 eval { is $^S,1 };
437 eval " BEGIN { ok ! defined \$^S } ";
438 is $^S, 0;
439
440 my $taint = ${^TAINT};
441 is ${^TAINT}, $taint;
442 eval { ${^TAINT} = 1 };
443 is ${^TAINT}, $taint;
444
445 # 5.6.1 had a bug: @+ and @- were not properly interpolated
446 # into double-quoted strings
447 # 20020414 mjd-perl-patch+@plover.com
448 "I like pie" =~ /(I) (like) (pie)/;
449 is "@-",  "0 0 2 7";
450 is "@+", "10 1 6 10";
451
452 # Tests for the magic get of $\
453 {
454     my $ok = 0;
455     # [perl #19330]
456     {
457         local $\ = undef;
458         $\++; $\++;
459         $ok = $\ eq 2;
460     }
461     ok $ok;
462     $ok = 0;
463     {
464         local $\ = "a\0b";
465         $ok = "a$\b" eq "aa\0bb";
466     }
467     ok $ok;
468 }
469
470 # Test for bug [perl #36434]
471 # Can not do this test on VMS, EPOC, and SYMBIAN according to comments
472 # in mg.c/Perl_magic_clear_all_env()
473 SKIP: {
474     skip('Can\'t make assignment to \%ENV on this system', 3) if $Is_VMS;
475
476     local @ISA;
477     local %ENV;
478     # This used to be __PACKAGE__, but that causes recursive
479     #  inheritance, which is detected earlier now and broke
480     #  this test
481     eval { push @ISA, __FILE__ };
482     is $@, '', 'Push a constant on a magic array';
483     $@ and print "# $@";
484     eval { %ENV = (PATH => __PACKAGE__) };
485     is $@, '', 'Assign a constant to a magic hash';
486     $@ and print "# $@";
487     eval { my %h = qw(A B); %ENV = (PATH => (keys %h)[0]) };
488     is $@, '', 'Assign a shared key to a magic hash';
489     $@ and print "# $@";
490 }
491
492 # Tests for Perl_magic_clearsig
493 foreach my $sig (qw(__WARN__ INT)) {
494     $SIG{$sig} = lc $sig;
495     is $SIG{$sig}, 'main::' . lc $sig, "Can assign to $sig";
496     is delete $SIG{$sig}, 'main::' . lc $sig, "Can delete from $sig";
497     is $SIG{$sig}, undef, "$sig is now gone";
498     is delete $SIG{$sig}, undef, "$sig remains gone";
499 }
500
501 # And now one which doesn't exist;
502 {
503     no warnings 'signal';
504     $SIG{HUNGRY} = 'mmm, pie';
505 }
506 is $SIG{HUNGRY}, 'mmm, pie', 'Can assign to HUNGRY';
507 is delete $SIG{HUNGRY}, 'mmm, pie', 'Can delete from HUNGRY';
508 is $SIG{HUNGRY}, undef, "HUNGRY is now gone";
509 is delete $SIG{HUNGRY}, undef, "HUNGRY remains gone";
510
511 # Test deleting signals that we never set
512 foreach my $sig (qw(__DIE__ _BOGUS_HOOK KILL THIRSTY)) {
513     is $SIG{$sig}, undef, "$sig is not present";
514     is delete $SIG{$sig}, undef, "delete of $sig returns undef";
515 }
516
517 {
518     $! = 9999;
519     is int $!, 9999, q{[perl #72850] Core dump in bleadperl from perl -e '$! = 9999; $a = $!;'};
520
521 }
522
523 # ^^^^^^^^^ New tests go here ^^^^^^^^^
524
525 SKIP: {
526     skip("%ENV manipulations fail or aren't safe on $^O", 4)
527         if $Is_VMS || $Is_Dos;
528
529  SKIP: {
530         skip("clearing \%ENV is not safe when running under valgrind")
531             if $ENV{PERL_VALGRIND};
532
533             $PATH = $ENV{PATH};
534             $PDL = $ENV{PERL_DESTRUCT_LEVEL} || 0;
535             $ENV{foo} = "bar";
536             %ENV = ();
537             $ENV{PATH} = $PATH;
538             $ENV{PERL_DESTRUCT_LEVEL} = $PDL || 0;
539             if ($Is_MSWin32) {
540                 is `set foo 2>NUL`, "";
541             } else {
542                 is `echo \$foo`, "\n";
543             }
544         }
545
546         $ENV{__NoNeSuCh} = "foo";
547         $0 = "bar";
548 # cmd.exe will echo 'variable=value' but 4nt will echo just the value
549 # -- Nikola Knezevic
550         if ($Is_MSWin32) {
551             like `set __NoNeSuCh`, qr/^(?:__NoNeSuCh=)?foo$/;
552         } else {
553             is `echo \$__NoNeSuCh`, "foo\n";
554         }
555     SKIP: {
556             skip("\$0 check only on Linux and FreeBSD", 2)
557                 unless $^O =~ /^(linux|freebsd)$/
558                     && open CMDLINE, "/proc/$$/cmdline";
559
560             chomp(my $line = scalar <CMDLINE>);
561             my $me = (split /\0/, $line)[0];
562             is $me, $0, 'altering $0 is effective (testing with /proc/)';
563             close CMDLINE;
564             # perlbug #22811
565             my $mydollarzero = sub {
566               my($arg) = shift;
567               $0 = $arg if defined $arg;
568               # In FreeBSD the ps -o command= will cause
569               # an empty header line, grab only the last line.
570               my $ps = (`ps -o command= -p $$`)[-1];
571               return if $?;
572               chomp $ps;
573               printf "# 0[%s]ps[%s]\n", $0, $ps;
574               $ps;
575             };
576             my $ps = $mydollarzero->("x");
577             ok(!$ps  # we allow that something goes wrong with the ps command
578                # In Linux 2.4 we would get an exact match ($ps eq 'x') but
579                # in Linux 2.2 there seems to be something funny going on:
580                # it seems as if the original length of the argv[] would
581                # be stored in the proc struct and then used by ps(1),
582                # no matter what characters we use to pad the argv[].
583                # (And if we use \0:s, they are shown as spaces.)  Sigh.
584                || $ps =~ /^x\s*$/
585                # FreeBSD cannot get rid of both the leading "perl :"
586                # and the trailing " (perl)": some FreeBSD versions
587                # can get rid of the first one.
588                || ($^O eq 'freebsd' && $ps =~ m/^(?:perl: )?x(?: \(perl\))?$/),
589                        'altering $0 is effective (testing with `ps`)');
590         }
591 }
592
593 # test case-insignificance of %ENV (these tests must be enabled only
594 # when perl is compiled with -DENV_IS_CASELESS)
595 SKIP: {
596     skip('no caseless %ENV support', 4) unless $Is_MSWin32 || $Is_NetWare;
597
598     %ENV = ();
599     $ENV{'Foo'} = 'bar';
600     $ENV{'fOo'} = 'baz';
601     is scalar(keys(%ENV)), 1;
602     ok exists $ENV{'FOo'};
603     is delete $ENV{'foO'}, 'baz';
604     is scalar(keys(%ENV)), 0;
605 }
606
607 __END__
608
609 # Put new tests before the various ENV tests, as they blow %ENV away.