Move test for #76540 to op/gv.t
[perl.git] / t / op / gv.t
1 #!./perl
2
3 #
4 # various typeglob tests
5 #
6
7 BEGIN {
8     chdir 't' if -d 't';
9     @INC = '../lib';
10 }
11
12 use warnings;
13
14 require './test.pl';
15 plan( tests => 194 );
16
17 # type coersion on assignment
18 $foo = 'foo';
19 $bar = *main::foo;
20 $bar = $foo;
21 is(ref(\$bar), 'SCALAR');
22 $foo = *main::bar;
23
24 # type coersion (not) on misc ops
25
26 ok($foo);
27 is(ref(\$foo), 'GLOB');
28
29 unlike ($foo, qr/abcd/);
30 is(ref(\$foo), 'GLOB');
31
32 is($foo, '*main::bar');
33 is(ref(\$foo), 'GLOB');
34
35 # type coersion on substitutions that match
36 $a = *main::foo;
37 $b = $a;
38 $a =~ s/^X//;
39 is(ref(\$a), 'GLOB');
40 $a =~ s/^\*//;
41 is($a, 'main::foo');
42 is(ref(\$b), 'GLOB');
43
44 # typeglobs as lvalues
45 substr($foo, 0, 1) = "XXX";
46 is(ref(\$foo), 'SCALAR');
47 is($foo, 'XXXmain::bar');
48
49 # returning glob values
50 sub foo {
51   local($bar) = *main::foo;
52   $foo = *main::bar;
53   return ($foo, $bar);
54 }
55
56 ($fuu, $baa) = foo();
57 ok(defined $fuu);
58 is(ref(\$fuu), 'GLOB');
59
60
61 ok(defined $baa);
62 is(ref(\$baa), 'GLOB');
63
64 # nested package globs
65 # NOTE:  It's probably OK if these semantics change, because the
66 #        fact that %X::Y:: is stored in %X:: isn't documented.
67 #        (I hope.)
68
69 { package Foo::Bar; no warnings 'once'; $test=1; }
70 ok(exists $Foo::{'Bar::'});
71 is($Foo::{'Bar::'}, '*Foo::Bar::');
72
73
74 # test undef operator clearing out entire glob
75 $foo = 'stuff';
76 @foo = qw(more stuff);
77 %foo = qw(even more random stuff);
78 undef *foo;
79 is ($foo, undef);
80 is (scalar @foo, 0);
81 is (scalar %foo, 0);
82
83 {
84     # test warnings from assignment of undef to glob
85     my $msg = '';
86     local $SIG{__WARN__} = sub { $msg = $_[0] };
87     use warnings;
88     *foo = 'bar';
89     is($msg, '');
90     *foo = undef;
91     like($msg, qr/Undefined value assigned to typeglob/);
92
93     no warnings 'once';
94     # test warnings for converting globs to other forms
95     my $copy = *PWOMPF;
96     foreach ($copy, *SKREEE) {
97         $msg = '';
98         my $victim = sprintf "%d", $_;
99         like($msg, qr/Argument "\*main::[A-Z]{6}" isn't numeric in sprintf/,
100              "Warning on conversion to IV");
101         is($victim, 0);
102
103         $msg = '';
104         $victim = sprintf "%u", $_;
105         like($msg, qr/Argument "\*main::[A-Z]{6}" isn't numeric in sprintf/,
106              "Warning on conversion to UV");
107         is($victim, 0);
108
109         $msg = '';
110         $victim = sprintf "%e", $_;
111         like($msg, qr/Argument "\*main::[A-Z]{6}" isn't numeric in sprintf/,
112              "Warning on conversion to NV");
113         like($victim, qr/^0\.0+E\+?00/i, "Expect floating point zero");
114
115         $msg = '';
116         $victim = sprintf "%s", $_;
117         is($msg, '', "No warning on stringification");
118         is($victim, '' . $_);
119     }
120 }
121
122 my $test = curr_test();
123 # test *glob{THING} syntax
124 $x = "ok $test\n";
125 ++$test;
126 @x = ("ok $test\n");
127 ++$test;
128 %x = ("ok $test" => "\n");
129 ++$test;
130 sub x { "ok $test\n" }
131 print ${*x{SCALAR}}, @{*x{ARRAY}}, %{*x{HASH}}, &{*x{CODE}};
132 # This needs to go here, after the print, as sub x will return the current
133 # value of test
134 ++$test;
135 format x =
136 XXX This text isn't used. Should it be?
137 .
138 curr_test($test);
139
140 is (ref *x{FORMAT}, "FORMAT");
141 *x = *STDOUT;
142 is (*{*x{GLOB}}, "*main::STDOUT");
143
144 {
145     my $test = curr_test();
146
147     print {*x{IO}} "ok $test\n";
148     ++$test;
149
150     my $warn;
151     local $SIG{__WARN__} = sub {
152         $warn .= $_[0];
153     };
154     my $val = *x{FILEHANDLE};
155     print {*x{IO}} ($warn =~ /is deprecated/
156                     ? "ok $test\n" : "not ok $test\n");
157     curr_test(++$test);
158 }
159
160
161 {
162     # test if defined() doesn't create any new symbols
163
164     my $a = "SYM000";
165     ok(!defined *{$a});
166
167     ok(!defined @{$a});
168     ok(!defined *{$a});
169
170     {
171         no warnings 'deprecated';
172         ok(!defined %{$a});
173     }
174     ok(!defined *{$a});
175
176     ok(!defined ${$a});
177     ok(!defined *{$a});
178
179     ok(!defined &{$a});
180     ok(!defined *{$a});
181
182     my $state = "not";
183     *{$a} = sub { $state = "ok" };
184     ok(defined &{$a});
185     ok(defined *{$a});
186     &{$a};
187     is ($state, 'ok');
188 }
189
190 {
191     # although it *should* if you're talking about magicals
192
193     my $a = "]";
194     ok(defined ${$a});
195     ok(defined *{$a});
196
197     $a = "1";
198     "o" =~ /(o)/;
199     ok(${$a});
200     ok(defined *{$a});
201     $a = "2";
202     ok(!${$a});
203     ok(defined *{$a});
204     $a = "1x";
205     ok(!defined ${$a});
206     ok(!defined *{$a});
207     $a = "11";
208     "o" =~ /(((((((((((o)))))))))))/;
209     ok(${$a});
210     ok(defined *{$a});
211 }
212
213 # [ID 20010526.001] localized glob loses value when assigned to
214
215 $j=1; %j=(a=>1); @j=(1); local *j=*j; *j = sub{};
216
217 is($j, 1);
218 is($j{a}, 1);
219 is($j[0], 1);
220
221 {
222     # does pp_readline() handle glob-ness correctly?
223     my $g = *foo;
224     $g = <DATA>;
225     is ($g, "Perl\n");
226 }
227
228 {
229     my $w = '';
230     local $SIG{__WARN__} = sub { $w = $_[0] };
231     sub abc1 ();
232     local *abc1 = sub { };
233     is ($w, '');
234     sub abc2 ();
235     local *abc2;
236     *abc2 = sub { };
237     is ($w, '');
238     sub abc3 ();
239     *abc3 = sub { };
240     like ($w, qr/Prototype mismatch/);
241 }
242
243 {
244     # [17375] rcatline to formerly-defined undef was broken. Fixed in
245     # do_readline by checking SvOK. AMS, 20020918
246     my $x = "not ";
247     $x  = undef;
248     $x .= <DATA>;
249     is ($x, "Rules\n");
250 }
251
252 {
253     # test the assignment of a GLOB to an LVALUE
254     my $e = '';
255     local $SIG{__DIE__} = sub { $e = $_[0] };
256     my $v;
257     sub f { $_[0] = 0; $_[0] = "a"; $_[0] = *DATA }
258     f($v);
259     is ($v, '*main::DATA');
260     my $x = <$v>;
261     is ($x, "perl\n");
262 }
263
264 {
265     $e = '';
266     # GLOB assignment to tied element
267     local $SIG{__DIE__} = sub { $e = $_[0] };
268     sub T::TIEARRAY  { bless [] => "T" }
269     sub T::STORE     { $_[0]->[ $_[1] ] = $_[2] }
270     sub T::FETCH     { $_[0]->[ $_[1] ] }
271     sub T::FETCHSIZE { @{$_[0]} }
272     tie my @ary => "T";
273     $ary[0] = *DATA;
274     is ($ary[0], '*main::DATA');
275     is ($e, '');
276     my $x = readline $ary[0];
277     is($x, "rocks\n");
278 }
279
280 {
281     # Need some sort of die or warn to get the global destruction text if the
282     # bug is still present
283     my $output = runperl(prog => <<'EOPROG');
284 package M;
285 $| = 1;
286 sub DESTROY {eval {die qq{Farewell $_[0]}}; print $@}
287 package main;
288
289 bless \$A::B, 'M';
290 *A:: = \*B::;
291 EOPROG
292     like($output, qr/^Farewell M=SCALAR/, "DESTROY was called");
293     unlike($output, qr/global destruction/,
294            "unreferenced symbol tables should be cleaned up immediately");
295 }
296
297 # Possibly not the correct test file for these tests.
298 # There are certain space optimisations implemented via promotion rules to
299 # GVs
300
301 foreach (qw (oonk ga_shloip)) {
302     ok(!exists $::{$_}, "no symbols of any sort to start with for $_");
303 }
304
305 # A string in place of the typeglob is promoted to the function prototype
306 $::{oonk} = "pie";
307 my $proto = eval 'prototype \&oonk';
308 die if $@;
309 is ($proto, "pie", "String is promoted to prototype");
310
311
312 # A reference to a value is used to generate a constant subroutine
313 foreach my $value (3, "Perl rules", \42, qr/whatever/, [1,2,3], {1=>2},
314                    \*STDIN, \&ok, \undef, *STDOUT) {
315     delete $::{oonk};
316     $::{oonk} = \$value;
317     $proto = eval 'prototype \&oonk';
318     die if $@;
319     is ($proto, '', "Prototype for a constant subroutine is empty");
320
321     my $got = eval 'oonk';
322     die if $@;
323     is (ref $got, ref $value, "Correct type of value (" . ref($value) . ")");
324     is ($got, $value, "Value is correctly set");
325 }
326
327 delete $::{oonk};
328 $::{oonk} = \"Value";
329
330 *{"ga_shloip"} = \&{"oonk"};
331
332 is (ref $::{ga_shloip}, 'SCALAR', "Export of proxy constant as is");
333 is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original");
334 is (eval 'ga_shloip', "Value", "Constant has correct value");
335 is (ref $::{ga_shloip}, 'SCALAR',
336     "Inlining of constant doesn't change represenatation");
337
338 delete $::{ga_shloip};
339
340 eval 'sub ga_shloip (); 1' or die $@;
341 is ($::{ga_shloip}, '', "Prototype is stored as an empty string");
342
343 # Check that a prototype expands.
344 *{"ga_shloip"} = \&{"oonk"};
345
346 is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original");
347 is (eval 'ga_shloip', "Value", "Constant has correct value");
348 is (ref \$::{ga_shloip}, 'GLOB', "Symbol table has full typeglob");
349
350
351 @::zwot = ('Zwot!');
352
353 # Check that assignment to an existing typeglob works
354 {
355   my $w = '';
356   local $SIG{__WARN__} = sub { $w = $_[0] };
357   *{"zwot"} = \&{"oonk"};
358   is($w, '', "Should be no warning");
359 }
360
361 is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original");
362 is (eval 'zwot', "Value", "Constant has correct value");
363 is (ref \$::{zwot}, 'GLOB', "Symbol table has full typeglob");
364 is (join ('!', @::zwot), 'Zwot!', "Existing array still in typeglob");
365
366 sub spritsits () {
367     "Traditional";
368 }
369
370 # Check that assignment to an existing subroutine works
371 {
372   my $w = '';
373   local $SIG{__WARN__} = sub { $w = $_[0] };
374   *{"spritsits"} = \&{"oonk"};
375   like($w, qr/^Constant subroutine main::spritsits redefined/,
376        "Redefining a constant sub should warn");
377 }
378
379 is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original");
380 is (eval 'spritsits', "Value", "Constant has correct value");
381 is (ref \$::{spritsits}, 'GLOB', "Symbol table has full typeglob");
382
383 # Check that assignment to an existing typeglob works
384 {
385   my $w = '';
386   local $SIG{__WARN__} = sub { $w = $_[0] };
387   *{"plunk"} = [];
388   *{"plunk"} = \&{"oonk"};
389   is($w, '', "Should be no warning");
390 }
391
392 is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original");
393 is (eval 'plunk', "Value", "Constant has correct value");
394 is (ref \$::{plunk}, 'GLOB', "Symbol table has full typeglob");
395
396 my $gr = eval '\*plunk' or die;
397
398 {
399   my $w = '';
400   local $SIG{__WARN__} = sub { $w = $_[0] };
401   *{$gr} = \&{"oonk"};
402   is($w, '', "Redefining a constant sub to another constant sub with the same underlying value should not warn (It's just re-exporting, and that was always legal)");
403 }
404
405 is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original");
406 is (eval 'plunk', "Value", "Constant has correct value");
407 is (ref \$::{plunk}, 'GLOB', "Symbol table has full typeglob");
408
409 # Non-void context should defeat the optimisation, and will cause the original
410 # to be promoted (what change 26482 intended)
411 my $result;
412 {
413   my $w = '';
414   local $SIG{__WARN__} = sub { $w = $_[0] };
415   $result = *{"awkkkkkk"} = \&{"oonk"};
416   is($w, '', "Should be no warning");
417 }
418
419 is (ref \$result, 'GLOB',
420     "Non void assignment should still return a typeglob");
421
422 is (ref \$::{oonk}, 'GLOB', "This export does affect original");
423 is (eval 'plunk', "Value", "Constant has correct value");
424 is (ref \$::{plunk}, 'GLOB', "Symbol table has full typeglob");
425
426 delete $::{oonk};
427 $::{oonk} = \"Value";
428
429 sub non_dangling {
430   my $w = '';
431   local $SIG{__WARN__} = sub { $w = $_[0] };
432   *{"zap"} = \&{"oonk"};
433   is($w, '', "Should be no warning");
434 }
435
436 non_dangling();
437 is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original");
438 is (eval 'zap', "Value", "Constant has correct value");
439 is (ref $::{zap}, 'SCALAR', "Exported target is also a PCS");
440
441 sub dangling {
442   local $SIG{__WARN__} = sub { die $_[0] };
443   *{"biff"} = \&{"oonk"};
444 }
445
446 dangling();
447 is (ref \$::{oonk}, 'GLOB', "This export does affect original");
448 is (eval 'biff', "Value", "Constant has correct value");
449 is (ref \$::{biff}, 'GLOB', "Symbol table has full typeglob");
450
451 {
452     use vars qw($glook $smek $foof);
453     # Check reference assignment isn't affected by the SV type (bug #38439)
454     $glook = 3;
455     $smek = 4;
456     $foof = "halt and cool down";
457
458     my $rv = \*smek;
459     is($glook, 3);
460     *glook = $rv;
461     is($glook, 4);
462
463     my $pv = "";
464     $pv = \*smek;
465     is($foof, "halt and cool down");
466     *foof = $pv;
467     is($foof, 4);
468 }
469
470 format =
471 .
472
473 foreach my $value ([1,2,3], {1=>2}, *STDOUT{IO}, \&ok, *STDOUT{FORMAT}) {
474     # *STDOUT{IO} returns a reference to a PVIO. As it's blessed, ref returns
475     # IO::Handle, which isn't what we want.
476     my $type = $value;
477     $type =~ s/.*=//;
478     $type =~ s/\(.*//;
479     delete $::{oonk};
480     $::{oonk} = $value;
481     $proto = eval 'prototype \&oonk';
482     like ($@, qr/^Cannot convert a reference to $type to typeglob/,
483           "Cannot upgrade ref-to-$type to typeglob");
484 }
485
486 {
487     no warnings qw(once uninitialized);
488     my $g = \*clatter;
489     my $r = eval {no strict; ${*{$g}{SCALAR}}};
490     is ($@, '', "PERL_DONT_CREATE_GVSV shouldn't affect thingy syntax");
491
492     $g = \*vowm;
493     $r = eval {use strict; ${*{$g}{SCALAR}}};
494     is ($@, '',
495         "PERL_DONT_CREATE_GVSV shouldn't affect thingy syntax under strict");
496 }
497
498 {
499     # Bug reported by broquaint on IRC
500     *slosh::{HASH}->{ISA}=[];
501     slosh->import;
502     pass("gv_fetchmeth coped with the unexpected");
503
504     # An audit found these:
505     {
506         package slosh;
507         sub rip {
508             my $s = shift;
509             $s->SUPER::rip;
510         }
511     }
512     eval {slosh->rip;};
513     like ($@, qr/^Can't locate object method "rip"/, "Even with SUPER");
514
515     is(slosh->isa('swoosh'), '');
516
517     $CORE::GLOBAL::{"lock"}=[];
518     eval "no warnings; lock";
519     like($@, qr/^Not enough arguments for lock/,
520        "Can't trip up general keyword overloading");
521
522     $CORE::GLOBAL::{"readline"}=[];
523     eval "<STDOUT> if 0";
524     is($@, '', "Can't trip up readline overloading");
525
526     $CORE::GLOBAL::{"readpipe"}=[];
527     eval "`` if 0";
528     is($@, '', "Can't trip up readpipe overloading");
529 }
530
531 {
532     die if exists $::{BONK};
533     $::{BONK} = \"powie";
534     *{"BONK"} = \&{"BONK"};
535     eval 'is(BONK(), "powie",
536              "Assigment works when glob created midway (bug 45607)"); 1'
537         or die $@;
538 }
539
540 # For now these tests are here, but they would probably be better in a file for
541 # tests for croaks. (And in turn, that probably deserves to be in a different
542 # directory. Gerard Goossen has a point about the layout being unclear
543
544 sub coerce_integer {
545     no warnings 'numeric';
546     $_[0] |= 0;
547 }
548 sub coerce_number {
549     no warnings 'numeric';
550     $_[0] += 0;
551 }
552 sub coerce_string {
553     $_[0] .= '';
554 }
555
556 foreach my $type (qw(integer number string)) {
557     my $prog = "coerce_$type(*STDERR)";
558     is (scalar eval "$prog; 1", undef, "$prog failed...");
559     like ($@, qr/Can't coerce GLOB to $type in/,
560           "with the correct error message");
561 }
562
563 # RT #60954 anonymous glob should be defined, and not coredump when
564 # stringified. The behaviours are:
565 #
566 #        defined($glob)    "$glob"
567 # 5.8.8     false           "" with uninit warning
568 # 5.10.0    true            (coredump)
569 # 5.12.0    true            ""
570
571 {
572     my $io_ref = *STDOUT{IO};
573     my $glob = *$io_ref;
574     ok(defined $glob, "RT #60954 anon glob should be defined");
575
576     my $warn = '';
577     local $SIG{__WARN__} = sub { $warn = $_[0] };
578     use warnings;
579     my $str = "$glob";
580     is($warn, '', "RT #60954 anon glob stringification shouln't warn");
581     is($str,  '', "RT #60954 anon glob stringification should be empty");
582 }
583
584 # [perl #71254] - Assigning a glob to a variable that has a current
585 # match position. (We are testing that Perl_magic_setmglob respects globs'
586 # special used of SvSCREAM.)
587 {
588     $m = 2; $m=~s/./0/gems; $m= *STDERR;
589     is(
590         "$m", "*main::STDERR",
591         '[perl #71254] assignment of globs to vars with pos'
592     );
593 }
594
595 # [perl #72740] - indirect object syntax, heuristically imputed due to
596 # the non-existence of a function, should not cause a stash entry to be
597 # created for the non-existent function.
598 {
599         package RT72740a;
600         my $f = bless({}, RT72740b);
601         sub s1 { s2 $f; }
602         our $s4;
603         sub s3 { s4 $f; }
604 }
605 {
606         package RT72740b;
607         sub s2 { "RT72740b::s2" }
608         sub s4 { "RT72740b::s4" }
609 }
610 ok(exists($RT72740a::{s1}), "RT72740a::s1 exists");
611 ok(!exists($RT72740a::{s2}), "RT72740a::s2 does not exist");
612 ok(exists($RT72740a::{s3}), "RT72740a::s3 exists");
613 ok(exists($RT72740a::{s4}), "RT72740a::s4 exists");
614 is(RT72740a::s1(), "RT72740b::s2", "RT72740::s1 parsed correctly");
615 is(RT72740a::s3(), "RT72740b::s4", "RT72740::s3 parsed correctly");
616
617 # [perl #71686] Globs that are in symbol table can be un-globbed
618 $sym = undef;
619 $::{fake} = *sym;
620 is (eval 'local *::fake = \"chuck"; $fake', 'chuck',
621         "Localized glob didn't coerce into a RV");
622 is ($@, '', "Can localize FAKE glob that's present in stash");
623 is (scalar $::{fake}, "*main::sym",
624         "Localized FAKE glob's value was correctly restored");
625
626 # [perl #1804] *$x assignment when $x is a copy of another glob
627 {
628     no warnings 'once';
629     my $x = *_random::glob_that_is_not_used_elsewhere;
630     *$x = sub{};
631     is(
632       "$x", '*_random::glob_that_is_not_used_elsewhere',
633       '[perl #1804] *$x assignment when $x is FAKE',
634     );
635 }
636
637 # [perl #76540]
638 # this caused panics or 'Attempt to free unreferenced scalar'
639 # (its a compile-time issue, so the die lets us skip the prints)
640 {
641     my @warnings;
642     local $SIG{__WARN__} = sub { push @warnings, @_ };
643
644     eval <<'EOF';
645 BEGIN { $::{FOO} = \'bar' }
646 die "made it";
647 print FOO, "\n";
648 print FOO, "\n";
649 EOF
650
651     like($@, qr/made it/, "#76540 - no panic");
652     ok(!@warnings, "#76540 - no 'Attempt to free unreferenced scalar'");
653 }
654
655 __END__
656 Perl
657 Rules
658 perl
659 rocks