This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
d19132313f647fa1409ef685c0d8633d4102acf5
[perl5.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     require './test.pl';
11 }
12
13 use warnings;
14
15 plan( tests => 236 );
16
17 # type coercion on assignment
18 $foo = 'foo';
19 $bar = *main::foo;
20 $bar = $foo;
21 is(ref(\$bar), 'SCALAR');
22 $foo = *main::bar;
23
24 # type coercion (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 {
36  no warnings;
37  ${\*$foo} = undef;
38  is(ref(\$foo), 'GLOB', 'no type coercion when assigning to *{} retval');
39  $::{phake} = *bar;
40  is(
41    \$::{phake}, \*{"phake"},
42    'symbolic *{} returns symtab entry when FAKE'
43  );
44  ${\*{"phake"}} = undef;
45  is(
46    ref(\$::{phake}), 'GLOB',
47   'no type coercion when assigning to retval of symbolic *{}'
48  );
49  $::{phaque} = *bar;
50  eval '
51    is(
52      \$::{phaque}, \*phaque,
53      "compile-time *{} returns symtab entry when FAKE"
54    );
55    ${\*phaque} = undef;
56  ';
57  is(
58    ref(\$::{phaque}), 'GLOB',
59   'no type coercion when assigning to retval of compile-time *{}'
60  );
61 }
62
63 # type coercion on substitutions that match
64 $a = *main::foo;
65 $b = $a;
66 $a =~ s/^X//;
67 is(ref(\$a), 'GLOB');
68 $a =~ s/^\*//;
69 is($a, 'main::foo');
70 is(ref(\$b), 'GLOB');
71
72 # typeglobs as lvalues
73 substr($foo, 0, 1) = "XXX";
74 is(ref(\$foo), 'SCALAR');
75 is($foo, 'XXXmain::bar');
76
77 # returning glob values
78 sub foo {
79   local($bar) = *main::foo;
80   $foo = *main::bar;
81   return ($foo, $bar);
82 }
83
84 ($fuu, $baa) = foo();
85 ok(defined $fuu);
86 is(ref(\$fuu), 'GLOB');
87
88
89 ok(defined $baa);
90 is(ref(\$baa), 'GLOB');
91
92 # nested package globs
93 # NOTE:  It's probably OK if these semantics change, because the
94 #        fact that %X::Y:: is stored in %X:: isn't documented.
95 #        (I hope.)
96
97 { package Foo::Bar; no warnings 'once'; $test=1; }
98 ok(exists $Foo::{'Bar::'});
99 is($Foo::{'Bar::'}, '*Foo::Bar::');
100
101
102 # test undef operator clearing out entire glob
103 $foo = 'stuff';
104 @foo = qw(more stuff);
105 %foo = qw(even more random stuff);
106 undef *foo;
107 is ($foo, undef);
108 is (scalar @foo, 0);
109 is (scalar %foo, 0);
110
111 {
112     # test warnings from assignment of undef to glob
113     my $msg = '';
114     local $SIG{__WARN__} = sub { $msg = $_[0] };
115     use warnings;
116     *foo = 'bar';
117     is($msg, '');
118     *foo = undef;
119     like($msg, qr/Undefined value assigned to typeglob/);
120
121     no warnings 'once';
122     # test warnings for converting globs to other forms
123     my $copy = *PWOMPF;
124     foreach ($copy, *SKREEE) {
125         $msg = '';
126         my $victim = sprintf "%d", $_;
127         like($msg, qr/Argument "\*main::[A-Z]{6}" isn't numeric in sprintf/,
128              "Warning on conversion to IV");
129         is($victim, 0);
130
131         $msg = '';
132         $victim = sprintf "%u", $_;
133         like($msg, qr/Argument "\*main::[A-Z]{6}" isn't numeric in sprintf/,
134              "Warning on conversion to UV");
135         is($victim, 0);
136
137         $msg = '';
138         $victim = sprintf "%e", $_;
139         like($msg, qr/Argument "\*main::[A-Z]{6}" isn't numeric in sprintf/,
140              "Warning on conversion to NV");
141         like($victim, qr/^0\.0+E\+?00/i, "Expect floating point zero");
142
143         $msg = '';
144         $victim = sprintf "%s", $_;
145         is($msg, '', "No warning on stringification");
146         is($victim, '' . $_);
147     }
148 }
149
150 my $test = curr_test();
151 # test *glob{THING} syntax
152 $x = "ok $test\n";
153 ++$test;
154 @x = ("ok $test\n");
155 ++$test;
156 %x = ("ok $test" => "\n");
157 ++$test;
158 sub x { "ok $test\n" }
159 print ${*x{SCALAR}}, @{*x{ARRAY}}, %{*x{HASH}}, &{*x{CODE}};
160 # This needs to go here, after the print, as sub x will return the current
161 # value of test
162 ++$test;
163 format x =
164 XXX This text isn't used. Should it be?
165 .
166 curr_test($test);
167
168 is (ref *x{FORMAT}, "FORMAT");
169 *x = *STDOUT;
170 is (*{*x{GLOB}}, "*main::STDOUT");
171
172 {
173     my $test = curr_test();
174
175     print {*x{IO}} "ok $test\n";
176     ++$test;
177
178     my $warn;
179     local $SIG{__WARN__} = sub {
180         $warn .= $_[0];
181     };
182     my $val = *x{FILEHANDLE};
183     print {*x{IO}} ($warn =~ /is deprecated/
184                     ? "ok $test\n" : "not ok $test\n");
185     curr_test(++$test);
186 }
187
188
189 {
190     # test if defined() doesn't create any new symbols
191
192     my $a = "SYM000";
193     ok(!defined *{$a});
194
195     ok(!defined @{$a});
196     ok(!defined *{$a});
197
198     {
199         no warnings 'deprecated';
200         ok(!defined %{$a});
201     }
202     ok(!defined *{$a});
203
204     ok(!defined ${$a});
205     ok(!defined *{$a});
206
207     ok(!defined &{$a});
208     ok(!defined *{$a});
209
210     my $state = "not";
211     *{$a} = sub { $state = "ok" };
212     ok(defined &{$a});
213     ok(defined *{$a});
214     &{$a};
215     is ($state, 'ok');
216 }
217
218 {
219     # although it *should* if you're talking about magicals
220
221     my $a = "]";
222     ok(defined *{$a});
223     ok(defined ${$a});
224
225     $a = "1";
226     "o" =~ /(o)/;
227     ok(${$a});
228     ok(defined *{$a});
229     $a = "2";
230     ok(!${$a});
231     ok(defined *{$a});
232     $a = "1x";
233     ok(!defined ${$a});
234     ok(!defined *{$a});
235     $a = "11";
236     "o" =~ /(((((((((((o)))))))))))/;
237     ok(${$a});
238     ok(defined *{$a});
239 }
240
241 # [ID 20010526.001] localized glob loses value when assigned to
242
243 $j=1; %j=(a=>1); @j=(1); local *j=*j; *j = sub{};
244
245 is($j, 1);
246 is($j{a}, 1);
247 is($j[0], 1);
248
249 {
250     # does pp_readline() handle glob-ness correctly?
251     my $g = *foo;
252     $g = <DATA>;
253     is ($g, "Perl\n");
254 }
255
256 {
257     my $w = '';
258     local $SIG{__WARN__} = sub { $w = $_[0] };
259     sub abc1 ();
260     local *abc1 = sub { };
261     is ($w, '');
262     sub abc2 ();
263     local *abc2;
264     *abc2 = sub { };
265     is ($w, '');
266     sub abc3 ();
267     *abc3 = sub { };
268     like ($w, qr/Prototype mismatch/);
269 }
270
271 {
272     # [17375] rcatline to formerly-defined undef was broken. Fixed in
273     # do_readline by checking SvOK. AMS, 20020918
274     my $x = "not ";
275     $x  = undef;
276     $x .= <DATA>;
277     is ($x, "Rules\n");
278 }
279
280 {
281     # test the assignment of a GLOB to an LVALUE
282     my $e = '';
283     local $SIG{__DIE__} = sub { $e = $_[0] };
284     my %v;
285     sub f { $_[0] = 0; $_[0] = "a"; $_[0] = *DATA }
286     f($v{v});
287     is ($v{v}, '*main::DATA');
288     is (ref\$v{v}, 'GLOB', 'lvalue assignment preserves globs');
289     my $x = readline $v{v};
290     is ($x, "perl\n");
291     is ($e, '', '__DIE__ handler never called');
292 }
293
294 {
295     my $e = '';
296     # GLOB assignment to tied element
297     local $SIG{__DIE__} = sub { $e = $_[0] };
298     sub T::TIEARRAY  { bless [] => "T" }
299     sub T::STORE     { $_[0]->[ $_[1] ] = $_[2] }
300     sub T::FETCH     { $_[0]->[ $_[1] ] }
301     sub T::FETCHSIZE { @{$_[0]} }
302     tie my @ary => "T";
303     $ary[0] = *DATA;
304     is ($ary[0], '*main::DATA');
305     is (
306       ref\tied(@ary)->[0], 'GLOB',
307      'tied elem assignment preserves globs'
308     );
309     is ($e, '', '__DIE__ handler not called');
310     my $x = readline $ary[0];
311     is($x, "rocks\n");
312     is ($e, '', '__DIE__ handler never called');
313 }
314
315 {
316     # Need some sort of die or warn to get the global destruction text if the
317     # bug is still present
318     my $output = runperl(prog => <<'EOPROG');
319 package M;
320 $| = 1;
321 sub DESTROY {eval {die qq{Farewell $_[0]}}; print $@}
322 package main;
323
324 bless \$A::B, q{M};
325 *A:: = \*B::;
326 EOPROG
327     like($output, qr/^Farewell M=SCALAR/, "DESTROY was called");
328     unlike($output, qr/global destruction/,
329            "unreferenced symbol tables should be cleaned up immediately");
330 }
331
332 # Possibly not the correct test file for these tests.
333 # There are certain space optimisations implemented via promotion rules to
334 # GVs
335
336 foreach (qw (oonk ga_shloip)) {
337     ok(!exists $::{$_}, "no symbols of any sort to start with for $_");
338 }
339
340 # A string in place of the typeglob is promoted to the function prototype
341 $::{oonk} = "pie";
342 my $proto = eval 'prototype \&oonk';
343 die if $@;
344 is ($proto, "pie", "String is promoted to prototype");
345
346
347 # A reference to a value is used to generate a constant subroutine
348 foreach my $value (3, "Perl rules", \42, qr/whatever/, [1,2,3], {1=>2},
349                    \*STDIN, \&ok, \undef, *STDOUT) {
350     delete $::{oonk};
351     $::{oonk} = \$value;
352     $proto = eval 'prototype \&oonk';
353     die if $@;
354     is ($proto, '', "Prototype for a constant subroutine is empty");
355
356     my $got = eval 'oonk';
357     die if $@;
358     is (ref $got, ref $value, "Correct type of value (" . ref($value) . ")");
359     is ($got, $value, "Value is correctly set");
360 }
361
362 delete $::{oonk};
363 $::{oonk} = \"Value";
364
365 *{"ga_shloip"} = \&{"oonk"};
366
367 is (ref $::{ga_shloip}, 'SCALAR', "Export of proxy constant as is");
368 is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original");
369 is (eval 'ga_shloip', "Value", "Constant has correct value");
370 is (ref $::{ga_shloip}, 'SCALAR',
371     "Inlining of constant doesn't change representation");
372
373 delete $::{ga_shloip};
374
375 eval 'sub ga_shloip (); 1' or die $@;
376 is ($::{ga_shloip}, '', "Prototype is stored as an empty string");
377
378 # Check that a prototype expands.
379 *{"ga_shloip"} = \&{"oonk"};
380
381 is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original");
382 is (eval 'ga_shloip', "Value", "Constant has correct value");
383 is (ref \$::{ga_shloip}, 'GLOB', "Symbol table has full typeglob");
384
385
386 @::zwot = ('Zwot!');
387
388 # Check that assignment to an existing typeglob works
389 {
390   my $w = '';
391   local $SIG{__WARN__} = sub { $w = $_[0] };
392   *{"zwot"} = \&{"oonk"};
393   is($w, '', "Should be no warning");
394 }
395
396 is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original");
397 is (eval 'zwot', "Value", "Constant has correct value");
398 is (ref \$::{zwot}, 'GLOB', "Symbol table has full typeglob");
399 is (join ('!', @::zwot), 'Zwot!', "Existing array still in typeglob");
400
401 sub spritsits () {
402     "Traditional";
403 }
404
405 # Check that assignment to an existing subroutine works
406 {
407   my $w = '';
408   local $SIG{__WARN__} = sub { $w = $_[0] };
409   *{"spritsits"} = \&{"oonk"};
410   like($w, qr/^Constant subroutine main::spritsits redefined/,
411        "Redefining a constant sub should warn");
412 }
413
414 is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original");
415 is (eval 'spritsits', "Value", "Constant has correct value");
416 is (ref \$::{spritsits}, 'GLOB', "Symbol table has full typeglob");
417
418 # Check that assignment to an existing typeglob works
419 {
420   my $w = '';
421   local $SIG{__WARN__} = sub { $w = $_[0] };
422   *{"plunk"} = [];
423   *{"plunk"} = \&{"oonk"};
424   is($w, '', "Should be no warning");
425 }
426
427 is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original");
428 is (eval 'plunk', "Value", "Constant has correct value");
429 is (ref \$::{plunk}, 'GLOB', "Symbol table has full typeglob");
430
431 my $gr = eval '\*plunk' or die;
432
433 {
434   my $w = '';
435   local $SIG{__WARN__} = sub { $w = $_[0] };
436   *{$gr} = \&{"oonk"};
437   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)");
438 }
439
440 is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original");
441 is (eval 'plunk', "Value", "Constant has correct value");
442 is (ref \$::{plunk}, 'GLOB', "Symbol table has full typeglob");
443
444 # Non-void context should defeat the optimisation, and will cause the original
445 # to be promoted (what change 26482 intended)
446 my $result;
447 {
448   my $w = '';
449   local $SIG{__WARN__} = sub { $w = $_[0] };
450   $result = *{"awkkkkkk"} = \&{"oonk"};
451   is($w, '', "Should be no warning");
452 }
453
454 is (ref \$result, 'GLOB',
455     "Non void assignment should still return a typeglob");
456
457 is (ref \$::{oonk}, 'GLOB', "This export does affect original");
458 is (eval 'plunk', "Value", "Constant has correct value");
459 is (ref \$::{plunk}, 'GLOB', "Symbol table has full typeglob");
460
461 delete $::{oonk};
462 $::{oonk} = \"Value";
463
464 sub non_dangling {
465   my $w = '';
466   local $SIG{__WARN__} = sub { $w = $_[0] };
467   *{"zap"} = \&{"oonk"};
468   is($w, '', "Should be no warning");
469 }
470
471 non_dangling();
472 is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original");
473 is (eval 'zap', "Value", "Constant has correct value");
474 is (ref $::{zap}, 'SCALAR', "Exported target is also a PCS");
475
476 sub dangling {
477   local $SIG{__WARN__} = sub { die $_[0] };
478   *{"biff"} = \&{"oonk"};
479 }
480
481 dangling();
482 is (ref \$::{oonk}, 'GLOB', "This export does affect original");
483 is (eval 'biff', "Value", "Constant has correct value");
484 is (ref \$::{biff}, 'GLOB', "Symbol table has full typeglob");
485
486 {
487     use vars qw($glook $smek $foof);
488     # Check reference assignment isn't affected by the SV type (bug #38439)
489     $glook = 3;
490     $smek = 4;
491     $foof = "halt and cool down";
492
493     my $rv = \*smek;
494     is($glook, 3);
495     *glook = $rv;
496     is($glook, 4);
497
498     my $pv = "";
499     $pv = \*smek;
500     is($foof, "halt and cool down");
501     *foof = $pv;
502     is($foof, 4);
503 }
504
505 format =
506 .
507
508 foreach my $value ([1,2,3], {1=>2}, *STDOUT{IO}, \&ok, *STDOUT{FORMAT}) {
509     # *STDOUT{IO} returns a reference to a PVIO. As it's blessed, ref returns
510     # IO::Handle, which isn't what we want.
511     my $type = $value;
512     $type =~ s/.*=//;
513     $type =~ s/\(.*//;
514     delete $::{oonk};
515     $::{oonk} = $value;
516     $proto = eval 'prototype \&oonk';
517     like ($@, qr/^Cannot convert a reference to $type to typeglob/,
518           "Cannot upgrade ref-to-$type to typeglob");
519 }
520
521 {
522     no warnings qw(once uninitialized);
523     my $g = \*clatter;
524     my $r = eval {no strict; ${*{$g}{SCALAR}}};
525     is ($@, '', "PERL_DONT_CREATE_GVSV shouldn't affect thingy syntax");
526
527     $g = \*vowm;
528     $r = eval {use strict; ${*{$g}{SCALAR}}};
529     is ($@, '',
530         "PERL_DONT_CREATE_GVSV shouldn't affect thingy syntax under strict");
531 }
532
533 {
534     # Bug reported by broquaint on IRC
535     *slosh::{HASH}->{ISA}=[];
536     slosh->import;
537     pass("gv_fetchmeth coped with the unexpected");
538
539     # An audit found these:
540     {
541         package slosh;
542         sub rip {
543             my $s = shift;
544             $s->SUPER::rip;
545         }
546     }
547     eval {slosh->rip;};
548     like ($@, qr/^Can't locate object method "rip"/, "Even with SUPER");
549
550     is(slosh->isa('swoosh'), '');
551
552     $CORE::GLOBAL::{"lock"}=[];
553     eval "no warnings; lock";
554     like($@, qr/^Not enough arguments for lock/,
555        "Can't trip up general keyword overloading");
556
557     $CORE::GLOBAL::{"readline"}=[];
558     eval "<STDOUT> if 0";
559     is($@, '', "Can't trip up readline overloading");
560
561     $CORE::GLOBAL::{"readpipe"}=[];
562     eval "`` if 0";
563     is($@, '', "Can't trip up readpipe overloading");
564 }
565
566 {
567     die if exists $::{BONK};
568     $::{BONK} = \"powie";
569     *{"BONK"} = \&{"BONK"};
570     eval 'is(BONK(), "powie",
571              "Assignment works when glob created midway (bug 45607)"); 1'
572         or die $@;
573 }
574
575 # For now these tests are here, but they would probably be better in a file for
576 # tests for croaks. (And in turn, that probably deserves to be in a different
577 # directory. Gerard Goossen has a point about the layout being unclear
578
579 sub coerce_integer {
580     no warnings 'numeric';
581     $_[0] |= 0;
582 }
583 sub coerce_number {
584     no warnings 'numeric';
585     $_[0] += 0;
586 }
587 sub coerce_string {
588     $_[0] .= '';
589 }
590
591 foreach my $type (qw(integer number string)) {
592     my $prog = "coerce_$type(*STDERR)";
593     is (scalar eval "$prog; 1", undef, "$prog failed...");
594     like ($@, qr/Can't coerce GLOB to $type in/,
595           "with the correct error message");
596 }
597
598 # RT #60954 anonymous glob should be defined, and not coredump when
599 # stringified. The behaviours are:
600 #
601 #        defined($glob)    "$glob"
602 # 5.8.8     false           "" with uninit warning
603 # 5.10.0    true            (coredump)
604 # 5.12.0    true            ""
605
606 {
607     my $io_ref = *STDOUT{IO};
608     my $glob = *$io_ref;
609     ok(defined $glob, "RT #60954 anon glob should be defined");
610
611     my $warn = '';
612     local $SIG{__WARN__} = sub { $warn = $_[0] };
613     use warnings;
614     my $str = "$glob";
615     is($warn, '', "RT #60954 anon glob stringification shouldn't warn");
616     is($str,  '', "RT #60954 anon glob stringification should be empty");
617 }
618
619 # [perl #71254] - Assigning a glob to a variable that has a current
620 # match position. (We are testing that Perl_magic_setmglob respects globs'
621 # special used of SvSCREAM.)
622 {
623     $m = 2; $m=~s/./0/gems; $m= *STDERR;
624     is(
625         "$m", "*main::STDERR",
626         '[perl #71254] assignment of globs to vars with pos'
627     );
628 }
629
630 # [perl #72740] - indirect object syntax, heuristically imputed due to
631 # the non-existence of a function, should not cause a stash entry to be
632 # created for the non-existent function.
633 {
634         package RT72740a;
635         my $f = bless({}, RT72740b);
636         sub s1 { s2 $f; }
637         our $s4;
638         sub s3 { s4 $f; }
639 }
640 {
641         package RT72740b;
642         sub s2 { "RT72740b::s2" }
643         sub s4 { "RT72740b::s4" }
644 }
645 ok(exists($RT72740a::{s1}), "RT72740a::s1 exists");
646 ok(!exists($RT72740a::{s2}), "RT72740a::s2 does not exist");
647 ok(exists($RT72740a::{s3}), "RT72740a::s3 exists");
648 ok(exists($RT72740a::{s4}), "RT72740a::s4 exists");
649 is(RT72740a::s1(), "RT72740b::s2", "RT72740::s1 parsed correctly");
650 is(RT72740a::s3(), "RT72740b::s4", "RT72740::s3 parsed correctly");
651
652 # [perl #71686] Globs that are in symbol table can be un-globbed
653 $sym = undef;
654 $::{fake} = *sym;
655 is (eval 'local *::fake = \"chuck"; $fake', 'chuck',
656         "Localized glob didn't coerce into a RV");
657 is ($@, '', "Can localize FAKE glob that's present in stash");
658 is (scalar $::{fake}, "*main::sym",
659         "Localized FAKE glob's value was correctly restored");
660
661 # [perl #1804] *$x assignment when $x is a copy of another glob
662 # And [perl #77508] (same thing with list assignment)
663 {
664     no warnings 'once';
665     my $x = *_random::glob_that_is_not_used_elsewhere;
666     *$x = sub{};
667     is(
668       "$x", '*_random::glob_that_is_not_used_elsewhere',
669       '[perl #1804] *$x assignment when $x is FAKE',
670     );
671     $x = *_random::glob_that_is_not_used_elsewhere;
672     (my $dummy, *$x) = (undef,[]);
673     is(
674       "$x", '*_random::glob_that_is_not_used_elsewhere',
675       '[perl #77508] *$x list assignment when $x is FAKE',
676     ) or require Devel::Peek, Devel::Peek::Dump($x);
677 }
678
679 # [perl #76540]
680 # this caused panics or 'Attempt to free unreferenced scalar'
681 # (its a compile-time issue, so the die lets us skip the prints)
682 {
683     my @warnings;
684     local $SIG{__WARN__} = sub { push @warnings, @_ };
685
686     eval <<'EOF';
687 BEGIN { $::{FOO} = \'bar' }
688 die "made it";
689 print FOO, "\n";
690 print FOO, "\n";
691 EOF
692
693     like($@, qr/made it/, "#76540 - no panic");
694     ok(!@warnings, "#76540 - no 'Attempt to free unreferenced scalar'");
695 }
696
697 # [perl #77362] various bugs related to globs as PVLVs
698 {
699  no warnings qw 'once void';
700  my %h; # We pass a key of this hash to the subroutine to get a PVLV.
701  sub { for(shift) {
702   # Set up our glob-as-PVLV
703   $_ = *hon;
704
705   # Bad symbol for array
706   ok eval{ @$_; 1 }, 'PVLV glob slots can be autovivified' or diag $@;
707
708   # This should call TIEHANDLE, not TIESCALAR
709   *thext::TIEHANDLE = sub{};
710   ok eval{ tie *$_, 'thext'; 1 }, 'PVLV globs can be tied as handles'
711    or diag $@;
712
713   # Assigning undef to the glob should not overwrite it...
714   {
715    my $w;
716    local $SIG{__WARN__} = sub { $w = shift };
717    *$_ = undef;
718    is $_, "*main::hon", 'PVLV: assigning undef to the glob does nothing';
719    like $w, qr\Undefined value assigned to typeglob\,
720     'PVLV: assigning undef to the glob warns';
721   }
722
723   # Neither should reference assignment.
724   *$_ = [];
725   is $_, "*main::hon", "PVLV: arrayref assignment assigns to the AV slot";
726
727   # Concatenation should still work.
728   ok eval { $_ .= 'thlew' }, 'PVLV concatenation does not die' or diag $@;
729   is $_, '*main::honthlew', 'PVLV concatenation works';
730
731   # And we should be able to overwrite it with a string, number, or refer-
732   # ence, too, if we omit the *.
733   $_ = *hon; $_ = 'tzor';
734   is $_, 'tzor', 'PVLV: assigning a string over a glob';
735   $_ = *hon; $_ = 23;
736   is $_, 23, 'PVLV: assigning an integer over a glob';
737   $_ = *hon; $_ = 23.23;
738   is $_, 23.23, 'PVLV: assigning a float over a glob';
739   $_ = *hon; $_ = \my $sthat;
740   is $_, \$sthat, 'PVLV: assigning a reference over a glob';
741
742   # This bug was found by code inspection. Could this ever happen in
743   # real life? :-)
744   # This duplicates a file handle, accessing it through a PVLV glob, the
745   # glob having been removed from the symbol table, so a stringified form
746   # of it does not work. This checks that sv_2io does not stringify a PVLV.
747   $_ = *quin;
748   open *quin, "test.pl"; # test.pl is as good a file as any
749   delete $::{quin};
750   ok eval { open my $zow, "<&", $_ }, 'PVLV: sv_2io stringifieth not'
751    or diag $@;
752
753   # Similar tests to make sure sv_2cv etc. do not stringify.
754   *$_ = sub { 1 };
755   ok eval { &$_ }, "PVLV glob can be called as a sub" or diag $@;
756   *flelp = sub { 2 };
757   $_ = 'flelp';
758   is eval { &$_ }, 2, 'PVLV holding a string can be called as a sub'
759    or diag $@;
760
761   # Coderef-to-glob assignment when the glob is no longer accessible
762   # under its name: These tests are to make sure the OPpASSIGN_CV_TO_GV
763   # optimisation takes PVLVs into account, which is why the RHSs have to be
764   # named subs.
765   use constant gheen => 'quare';
766   $_ = *ming;
767   delete $::{ming};
768   *$_ = \&gheen;
769   is eval { &$_ }, 'quare',
770    'PVLV: constant assignment when the glob is detached from the symtab'
771     or diag $@;
772   $_ = *bength;
773   delete $::{bength};
774   *gheck = sub { 'lon' };
775   *$_ = \&gheck;
776   is eval { &$_ }, 'lon',
777    'PVLV: coderef assignment when the glob is detached from the symtab'
778     or diag $@;
779
780 SKIP: {
781     skip_if_miniperl("no dynamic loading on miniperl, so can't load PerlIO::scalar", 1);
782     # open should accept a PVLV as its first argument
783     $_ = *hon;
784     ok eval { open $_,'<', \my $thlext }, 'PVLV can be the first arg to open'
785         or diag $@;
786   }
787
788   # -t should not stringify
789   $_ = *thlit; delete $::{thlit};
790   *$_ = *STDOUT{IO};
791   ok defined -t $_, 'PVLV: -t does not stringify';
792
793   # neither should -T
794   # but some systems don’t support this on file handles
795   my $pass;
796   ok
797     eval {
798      open my $quile, "<", 'test.pl';
799      $_ = *$quile;
800      $pass = -T $_;
801      1
802     } ? $pass : $@ =~ /not implemented on filehandles/,
803    "PVLV: -T does not stringify";
804   
805   # Unopened file handle
806   {
807    my $w;
808    local $SIG{__WARN__} = sub { $w .= shift };
809    $_ = *vor;
810    close $_;
811    like $w, qr\unopened filehandle vor\,
812     'PVLV globs get their names reported in unopened error messages';
813   }
814
815  }}->($h{k});
816 }
817
818 *aieee = 4;
819 pass('Can assign integers to typeglobs');
820 *aieee = 3.14;
821 pass('Can assign floats to typeglobs');
822 *aieee = 'pi';
823 pass('Can assign strings to typeglobs');
824
825 {
826   package thrext;
827   sub TIESCALAR{bless[]}
828   sub STORE{ die "No!"}
829   sub FETCH{ no warnings 'once'; *thrit }
830   tie my $a, "thrext";
831   () = "$a"; # do a fetch; now $a holds a glob
832   eval { *$a = sub{} };
833   untie $a;
834   eval { $a = "bar" };
835   ::is $a, "bar",
836     "[perl #77812] Globs in tied scalars can be reified if STORE dies"
837 }
838
839 # These two crashed prior to 5.13.6. In 5.13.6 they were fatal errors. They
840 # were fixed in 5.13.7.
841 ok eval {
842   my $glob = \*heen::ISA;
843   delete $::{"heen::"};
844   *$glob = *bar; 
845 }, "glob-to-*ISA assignment works when *ISA has lost its stash";
846 ok eval {
847   my $glob = \*slare::ISA;
848   delete $::{"slare::"};
849   *$glob = []; 
850 }, "array-to-*ISA assignment works when *ISA has lost its stash";
851 # These two crashed in 5.13.6. They were likewise fixed in 5.13.7.
852 ok eval {
853   sub greck;
854   my $glob = do { no warnings "once"; \*phing::foo};
855   delete $::{"phing::"};
856   *$glob = *greck; 
857 }, "Assigning a glob-with-sub to a glob that has lost its stash warks";
858 ok eval {
859   sub pon::foo;
860   my $glob = \*pon::foo;
861   delete $::{"pon::"};
862   *$glob = *foo; 
863 }, "Assigning a glob to a glob-with-sub that has lost its stash warks";
864
865 {
866   package Tie::Alias;
867   sub TIESCALAR{ bless \\pop }
868   sub FETCH { $${$_[0]} }
869   sub STORE { $${$_[0]} = $_[1] }
870   package main;
871   tie my $alias, 'Tie::Alias', my $var;
872   no warnings 'once';
873   $var = *galobbe;
874   {
875     local *$alias = [];
876     $var = 3;
877     is $alias, 3, "[perl #77926] Glob reification during localisation";
878   }
879 }
880
881 # This code causes gp_free to call a destructor when a glob is being
882 # restored on scope exit. The destructor used to see SVs with a refcount of
883 # zero inside the glob, which could result in crashes (though not in this
884 # test case, which just panics).
885 {
886  no warnings 'once';
887  my $survived;
888  *Trit::DESTROY = sub {
889    $thwext = 42;  # panic
890    $survived = 1;
891  };
892  {
893   local *thwext;
894   $thwext = bless[],'Trit';
895   ();
896  }
897  ok $survived,
898   'no error when gp_free calls a destructor that assigns to the gv';
899 }
900
901 # *{undef}
902 eval { *{my $undef} = 3 };
903 like $@, qr/^Can't use an undefined value as a symbol reference at /,
904   '*{ $undef } assignment';
905 eval { *{;undef} = 3 };
906 like $@, qr/^Can't use an undefined value as a symbol reference at /,
907   '*{ ;undef } assignment';
908
909 __END__
910 Perl
911 Rules
912 perl
913 rocks