xref: /onnv-gate/usr/src/cmd/perl/5.8.4/distrib/t/op/magic.t (revision 0:68f95e015346) 
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..54\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
51$PERL = ($Is_NetWare            ? 'perl'   :
52	 ($Is_MacOS || $Is_VMS) ? $^X      :
53	 $Is_MSWin32            ? '.\perl' :
54	 './perl');
55
56eval '$ENV{"FOO"} = "hi there";';	# check that ENV is inited inside eval
57# cmd.exe will echo 'variable=value' but 4nt will echo just the value
58# -- Nikola Knezevic
59if ($Is_MSWin32)  { ok `set FOO` =~ /^(?:FOO=)?hi there$/; }
60elsif ($Is_MacOS) { ok "1 # skipped", 1; }
61elsif ($Is_VMS)   { ok `write sys\$output f\$trnlnm("FOO")` eq "hi there\n"; }
62else              { ok `echo \$FOO` eq "hi there\n"; }
63
64unlink 'ajslkdfpqjsjfk';
65$! = 0;
66open(FOO,'ajslkdfpqjsjfk');
67ok $!, $!;
68close FOO; # just mention it, squelch used-only-once
69
70if ($Is_MSWin32 || $Is_NetWare || $Is_Dos || $Is_MPE || $Is_MacOS) {
71    skip('SIGINT not safe on this platform') for 1..4;
72}
73else {
74  # the next tests are done in a subprocess because sh spits out a
75  # newline onto stderr when a child process kills itself with SIGINT.
76  # We use a pipe rather than system() because the VMS command buffer
77  # would overflow with a command that long.
78
79    open( CMDPIPE, "| $PERL");
80
81    print CMDPIPE <<'END';
82
83    $| = 1;		# command buffering
84
85    $SIG{"INT"} = "ok3";     kill "INT",$$; sleep 1;
86    $SIG{"INT"} = "IGNORE";  kill "INT",$$; sleep 1; print "ok 4\n";
87    $SIG{"INT"} = "DEFAULT"; kill "INT",$$; sleep 1; print "not ok 4\n";
88
89    sub ok3 {
90	if (($x = pop(@_)) eq "INT") {
91	    print "ok 3\n";
92	}
93	else {
94	    print "not ok 3 ($x @_)\n";
95	}
96    }
97
98END
99
100    close CMDPIPE;
101
102    open( CMDPIPE, "| $PERL");
103    print CMDPIPE <<'END';
104
105    { package X;
106	sub DESTROY {
107	    kill "INT",$$;
108	}
109    }
110    sub x {
111	my $x=bless [], 'X';
112	return sub { $x };
113    }
114    $| = 1;		# command buffering
115    $SIG{"INT"} = "ok5";
116    {
117	local $SIG{"INT"}=x();
118	print ""; # Needed to expose failure in 5.8.0 (why?)
119    }
120    sleep 1;
121    delete $SIG{"INT"};
122    kill "INT",$$; sleep 1;
123    sub ok5 {
124	print "ok 5\n";
125    }
126END
127    close CMDPIPE;
128    $? >>= 8 if $^O eq 'VMS'; # POSIX status hiding in 2nd byte
129    my $todo = ($^O eq 'os2' ? ' # TODO: EMX v0.9d_fix4 bug: wrong nibble? ' : '');
130    print $? & 0xFF ? "ok 6$todo\n" : "not ok 6$todo\n";
131
132    $test += 4;
133}
134
135# can we slice ENV?
136@val1 = @ENV{keys(%ENV)};
137@val2 = values(%ENV);
138ok join(':',@val1) eq join(':',@val2);
139ok @val1 > 1;
140
141# regex vars
142'foobarbaz' =~ /b(a)r/;
143ok $` eq 'foo', $`;
144ok $& eq 'bar', $&;
145ok $' eq 'baz', $';
146ok $+ eq 'a', $+;
147
148# $"
149@a = qw(foo bar baz);
150ok "@a" eq "foo bar baz", "@a";
151{
152    local $" = ',';
153    ok "@a" eq "foo,bar,baz", "@a";
154}
155
156# $;
157%h = ();
158$h{'foo', 'bar'} = 1;
159ok((keys %h)[0] eq "foo\034bar", (keys %h)[0]);
160{
161    local $; = 'x';
162    %h = ();
163    $h{'foo', 'bar'} = 1;
164    ok((keys %h)[0] eq 'fooxbar', (keys %h)[0]);
165}
166
167# $?, $@, $$
168if ($Is_MacOS) {
169    skip('$? + system are broken on MacPerl') for 1..2;
170}
171else {
172    system qq[$PERL "-I../lib" -e "use vmsish qw(hushed); exit(0)"];
173    ok $? == 0, $?;
174    system qq[$PERL "-I../lib" -e "use vmsish qw(hushed); exit(1)"];
175    ok $? != 0, $?;
176}
177
178eval { die "foo\n" };
179ok $@ eq "foo\n", $@;
180
181ok $$ > 0, $$;
182eval { $$++ };
183ok $@ =~ /^Modification of a read-only value attempted/;
184
185# $^X and $0
186{
187    if ($^O eq 'qnx') {
188	chomp($wd = `/usr/bin/fullpath -t`);
189    }
190    elsif($Is_Cygwin || $Config{'d_procselfexe'}) {
191       # Cygwin turns the symlink into the real file
192       chomp($wd = `pwd`);
193       $wd =~ s#/t$##;
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 $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    if ($^O eq 'os390' or $^O eq 'posix-bc' or $^O eq 'vmesa') {  # no shebang
236	$headmaybe = <<EOH ;
237    eval 'exec ./perl -S \$0 \${1+"\$\@"}'
238        if 0;
239EOH
240    }
241    $s1 = "\$^X is $perl, \$0 is $script\n";
242    ok open(SCRIPT, ">$script"), $!;
243    ok print(SCRIPT $headmaybe . <<EOB . <<'EOF' . $tailmaybe), $!;
244#!$wd/perl
245EOB
246print "\$^X is $^X, \$0 is $0\n";
247EOF
248    ok close(SCRIPT), $!;
249    ok chmod(0755, $script), $!;
250    $_ = ($Is_MacOS || $Is_VMS) ? `$perl $script` : `$script`;
251    s/\.exe//i if $Is_Dos or $Is_Cygwin or $Is_os2;
252    s{\bminiperl\b}{perl}; # so that test doesn't fail with miniperl
253    s{is perl}{is $perl}; # for systems where $^X is only a basename
254    s{\\}{/}g;
255    ok((($Is_MSWin32 || $Is_os2) ? uc($_) eq uc($s1) : $_ eq $s1), " :$_:!=:$s1:");
256    $_ = `$perl $script`;
257    s/\.exe//i if $Is_Dos or $Is_os2;
258    s{\\}{/}g;
259    ok((($Is_MSWin32 || $Is_os2) ? uc($_) eq uc($s1) : $_ eq $s1), " :$_:!=:$s1: after `$perl $script`");
260    ok unlink($script), $!;
261}
262
263# $], $^O, $^T
264ok $] >= 5.00319, $];
265ok $^O;
266ok $^T > 850000000, $^T;
267
268if ($Is_VMS || $Is_Dos || $Is_MacOS) {
269    skip("%ENV manipulations fail or aren't safe on $^O") for 1..4;
270}
271else {
272	if ($ENV{PERL_VALGRIND}) {
273	    skip("clearing \%ENV is not safe when running under valgrind");
274	} else {
275	    $PATH = $ENV{PATH};
276	    $PDL = $ENV{PERL_DESTRUCT_LEVEL} || 0;
277	    $ENV{foo} = "bar";
278	    %ENV = ();
279	    $ENV{PATH} = $PATH;
280	    $ENV{PERL_DESTRUCT_LEVEL} = $PDL || 0;
281	    ok ($Is_MSWin32 ? (`set foo 2>NUL` eq "")
282			    : (`echo \$foo` eq "\n") );
283	}
284
285	$ENV{__NoNeSuCh} = "foo";
286	$0 = "bar";
287# cmd.exe will echo 'variable=value' but 4nt will echo just the value
288# -- Nikola Knezevic
289       ok ($Is_MSWin32 ? (`set __NoNeSuCh` =~ /^(?:__NoNeSuCh=)?foo$/)
290			    : (`echo \$__NoNeSuCh` eq "foo\n") );
291	if ($^O =~ /^(linux|freebsd)$/ &&
292	    open CMDLINE, "/proc/$$/cmdline") {
293	    chomp(my $line = scalar <CMDLINE>);
294	    my $me = (split /\0/, $line)[0];
295	    ok($me eq $0, 'altering $0 is effective (testing with /proc/)');
296	    close CMDLINE;
297            # perlbug #22811
298            my $mydollarzero = sub {
299              my($arg) = shift;
300              $0 = $arg if defined $arg;
301	      # In FreeBSD the ps -o command= will cause
302	      # an empty header line, grab only the last line.
303              my $ps = (`ps -o command= -p $$`)[-1];
304              return if $?;
305              chomp $ps;
306              printf "# 0[%s]ps[%s]\n", $0, $ps;
307              $ps;
308            };
309            my $ps = $mydollarzero->("x");
310            ok(!$ps  # we allow that something goes wrong with the ps command
311	       # In Linux 2.4 we would get an exact match ($ps eq 'x') but
312	       # in Linux 2.2 there seems to be something funny going on:
313	       # it seems as if the original length of the argv[] would
314	       # be stored in the proc struct and then used by ps(1),
315	       # no matter what characters we use to pad the argv[].
316	       # (And if we use \0:s, they are shown as spaces.)  Sigh.
317               || $ps =~ /^x\s*$/
318	       # FreeBSD cannot get rid of both the leading "perl :"
319	       # and the trailing " (perl)": some FreeBSD versions
320	       # can get rid of the first one.
321	       || ($^O eq 'freebsd' && $ps =~ m/^(?:perl: )?x(?: \(perl\))?$/),
322		       'altering $0 is effective (testing with `ps`)');
323	} else {
324	    skip("\$0 check only on Linux and FreeBSD") for 0, 1;
325	}
326}
327
328{
329    my $ok = 1;
330    my $warn = '';
331    local $SIG{'__WARN__'} = sub { $ok = 0; $warn = join '', @_; };
332    $! = undef;
333    ok($ok, $warn, $Is_VMS ? "'\$!=undef' does throw a warning" : '');
334}
335
336# test case-insignificance of %ENV (these tests must be enabled only
337# when perl is compiled with -DENV_IS_CASELESS)
338if ($Is_MSWin32 || $Is_NetWare) {
339    %ENV = ();
340    $ENV{'Foo'} = 'bar';
341    $ENV{'fOo'} = 'baz';
342    ok (scalar(keys(%ENV)) == 1);
343    ok exists($ENV{'FOo'});
344    ok (delete($ENV{'foO'}) eq 'baz');
345    ok (scalar(keys(%ENV)) == 0);
346}
347else {
348    skip('no caseless %ENV support') for 1..4;
349}
350
351if ($Is_miniperl) {
352    skip ("miniperl can't rely on loading %Errno") for 1..2;
353} else {
354   no warnings 'void';
355
356# Make sure Errno hasn't been prematurely autoloaded
357
358   ok !defined %Errno::;
359
360# Test auto-loading of Errno when %! is used
361
362   ok scalar eval q{
363      %!;
364      defined %Errno::;
365   }, $@;
366}
367
368if ($Is_miniperl) {
369    skip ("miniperl can't rely on loading %Errno");
370} else {
371    # Make sure that Errno loading doesn't clobber $!
372
373    undef %Errno::;
374    delete $INC{"Errno.pm"};
375
376    open(FOO, "nonesuch"); # Generate ENOENT
377    my %errs = %{"!"}; # Cause Errno.pm to be loaded at run-time
378    ok ${"!"}{ENOENT};
379}
380
381ok $^S == 0 && defined $^S;
382eval { ok $^S == 1 };
383eval " BEGIN { ok ! defined \$^S } ";
384ok $^S == 0 && defined $^S;
385
386ok ${^TAINT} == 0;
387eval { ${^TAINT} = 1 };
388ok ${^TAINT} == 0;
389
390# 5.6.1 had a bug: @+ and @- were not properly interpolated
391# into double-quoted strings
392# 20020414 mjd-perl-patch+@plover.com
393"I like pie" =~ /(I) (like) (pie)/;
394ok "@-" eq  "0 0 2 7";
395ok "@+" eq "10 1 6 10";
396
397# Tests for the magic get of $\
398{
399    my $ok = 0;
400    # [perl #19330]
401    {
402	local $\ = undef;
403	$\++; $\++;
404	$ok = $\ eq 2;
405    }
406    ok $ok;
407    $ok = 0;
408    {
409	local $\ = "a\0b";
410	$ok = "a$\b" eq "aa\0bb";
411    }
412    ok $ok;
413}
414
415# Test for bug [perl #27839]
416{
417    my $x;
418    sub f {
419	"abc" =~ /(.)./;
420	$x = "@+";
421	return @+;
422    };
423    my @y = f();
424    ok( $x eq "@y", "return a magic array ($x) vs (@y)" );
425}
426