This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[perl #77362] Assigning glob to lvalue causes stringification
[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 => 219 );
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{v});
259     is ($v{v}, '*main::DATA');
260     is (ref\$v{v}, 'GLOB', 'lvalue assignment preserves globs');
261     my $x = readline $v{v};
262     is ($x, "perl\n");
263 }
264
265 {
266     $e = '';
267     # GLOB assignment to tied element
268     local $SIG{__DIE__} = sub { $e = $_[0] };
269     sub T::TIEARRAY  { bless [] => "T" }
270     sub T::STORE     { $_[0]->[ $_[1] ] = $_[2] }
271     sub T::FETCH     { $_[0]->[ $_[1] ] }
272     sub T::FETCHSIZE { @{$_[0]} }
273     tie my @ary => "T";
274     $ary[0] = *DATA;
275     is ($ary[0], '*main::DATA');
276     is (
277       ref\tied(@ary)->[0], 'GLOB',
278      'tied elem assignment preserves globs'
279     );
280     is ($e, '');
281     my $x = readline $ary[0];
282     is($x, "rocks\n");
283 }
284
285 {
286     # Need some sort of die or warn to get the global destruction text if the
287     # bug is still present
288     my $output = runperl(prog => <<'EOPROG');
289 package M;
290 $| = 1;
291 sub DESTROY {eval {die qq{Farewell $_[0]}}; print $@}
292 package main;
293
294 bless \$A::B, q{M};
295 *A:: = \*B::;
296 EOPROG
297     like($output, qr/^Farewell M=SCALAR/, "DESTROY was called");
298     unlike($output, qr/global destruction/,
299            "unreferenced symbol tables should be cleaned up immediately");
300 }
301
302 # Possibly not the correct test file for these tests.
303 # There are certain space optimisations implemented via promotion rules to
304 # GVs
305
306 foreach (qw (oonk ga_shloip)) {
307     ok(!exists $::{$_}, "no symbols of any sort to start with for $_");
308 }
309
310 # A string in place of the typeglob is promoted to the function prototype
311 $::{oonk} = "pie";
312 my $proto = eval 'prototype \&oonk';
313 die if $@;
314 is ($proto, "pie", "String is promoted to prototype");
315
316
317 # A reference to a value is used to generate a constant subroutine
318 foreach my $value (3, "Perl rules", \42, qr/whatever/, [1,2,3], {1=>2},
319                    \*STDIN, \&ok, \undef, *STDOUT) {
320     delete $::{oonk};
321     $::{oonk} = \$value;
322     $proto = eval 'prototype \&oonk';
323     die if $@;
324     is ($proto, '', "Prototype for a constant subroutine is empty");
325
326     my $got = eval 'oonk';
327     die if $@;
328     is (ref $got, ref $value, "Correct type of value (" . ref($value) . ")");
329     is ($got, $value, "Value is correctly set");
330 }
331
332 delete $::{oonk};
333 $::{oonk} = \"Value";
334
335 *{"ga_shloip"} = \&{"oonk"};
336
337 is (ref $::{ga_shloip}, 'SCALAR', "Export of proxy constant as is");
338 is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original");
339 is (eval 'ga_shloip', "Value", "Constant has correct value");
340 is (ref $::{ga_shloip}, 'SCALAR',
341     "Inlining of constant doesn't change represenatation");
342
343 delete $::{ga_shloip};
344
345 eval 'sub ga_shloip (); 1' or die $@;
346 is ($::{ga_shloip}, '', "Prototype is stored as an empty string");
347
348 # Check that a prototype expands.
349 *{"ga_shloip"} = \&{"oonk"};
350
351 is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original");
352 is (eval 'ga_shloip', "Value", "Constant has correct value");
353 is (ref \$::{ga_shloip}, 'GLOB', "Symbol table has full typeglob");
354
355
356 @::zwot = ('Zwot!');
357
358 # Check that assignment to an existing typeglob works
359 {
360   my $w = '';
361   local $SIG{__WARN__} = sub { $w = $_[0] };
362   *{"zwot"} = \&{"oonk"};
363   is($w, '', "Should be no warning");
364 }
365
366 is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original");
367 is (eval 'zwot', "Value", "Constant has correct value");
368 is (ref \$::{zwot}, 'GLOB', "Symbol table has full typeglob");
369 is (join ('!', @::zwot), 'Zwot!', "Existing array still in typeglob");
370
371 sub spritsits () {
372     "Traditional";
373 }
374
375 # Check that assignment to an existing subroutine works
376 {
377   my $w = '';
378   local $SIG{__WARN__} = sub { $w = $_[0] };
379   *{"spritsits"} = \&{"oonk"};
380   like($w, qr/^Constant subroutine main::spritsits redefined/,
381        "Redefining a constant sub should warn");
382 }
383
384 is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original");
385 is (eval 'spritsits', "Value", "Constant has correct value");
386 is (ref \$::{spritsits}, 'GLOB', "Symbol table has full typeglob");
387
388 # Check that assignment to an existing typeglob works
389 {
390   my $w = '';
391   local $SIG{__WARN__} = sub { $w = $_[0] };
392   *{"plunk"} = [];
393   *{"plunk"} = \&{"oonk"};
394   is($w, '', "Should be no warning");
395 }
396
397 is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original");
398 is (eval 'plunk', "Value", "Constant has correct value");
399 is (ref \$::{plunk}, 'GLOB', "Symbol table has full typeglob");
400
401 my $gr = eval '\*plunk' or die;
402
403 {
404   my $w = '';
405   local $SIG{__WARN__} = sub { $w = $_[0] };
406   *{$gr} = \&{"oonk"};
407   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)");
408 }
409
410 is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original");
411 is (eval 'plunk', "Value", "Constant has correct value");
412 is (ref \$::{plunk}, 'GLOB', "Symbol table has full typeglob");
413
414 # Non-void context should defeat the optimisation, and will cause the original
415 # to be promoted (what change 26482 intended)
416 my $result;
417 {
418   my $w = '';
419   local $SIG{__WARN__} = sub { $w = $_[0] };
420   $result = *{"awkkkkkk"} = \&{"oonk"};
421   is($w, '', "Should be no warning");
422 }
423
424 is (ref \$result, 'GLOB',
425     "Non void assignment should still return a typeglob");
426
427 is (ref \$::{oonk}, 'GLOB', "This export does affect original");
428 is (eval 'plunk', "Value", "Constant has correct value");
429 is (ref \$::{plunk}, 'GLOB', "Symbol table has full typeglob");
430
431 delete $::{oonk};
432 $::{oonk} = \"Value";
433
434 sub non_dangling {
435   my $w = '';
436   local $SIG{__WARN__} = sub { $w = $_[0] };
437   *{"zap"} = \&{"oonk"};
438   is($w, '', "Should be no warning");
439 }
440
441 non_dangling();
442 is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original");
443 is (eval 'zap', "Value", "Constant has correct value");
444 is (ref $::{zap}, 'SCALAR', "Exported target is also a PCS");
445
446 sub dangling {
447   local $SIG{__WARN__} = sub { die $_[0] };
448   *{"biff"} = \&{"oonk"};
449 }
450
451 dangling();
452 is (ref \$::{oonk}, 'GLOB', "This export does affect original");
453 is (eval 'biff', "Value", "Constant has correct value");
454 is (ref \$::{biff}, 'GLOB', "Symbol table has full typeglob");
455
456 {
457     use vars qw($glook $smek $foof);
458     # Check reference assignment isn't affected by the SV type (bug #38439)
459     $glook = 3;
460     $smek = 4;
461     $foof = "halt and cool down";
462
463     my $rv = \*smek;
464     is($glook, 3);
465     *glook = $rv;
466     is($glook, 4);
467
468     my $pv = "";
469     $pv = \*smek;
470     is($foof, "halt and cool down");
471     *foof = $pv;
472     is($foof, 4);
473 }
474
475 format =
476 .
477
478 foreach my $value ([1,2,3], {1=>2}, *STDOUT{IO}, \&ok, *STDOUT{FORMAT}) {
479     # *STDOUT{IO} returns a reference to a PVIO. As it's blessed, ref returns
480     # IO::Handle, which isn't what we want.
481     my $type = $value;
482     $type =~ s/.*=//;
483     $type =~ s/\(.*//;
484     delete $::{oonk};
485     $::{oonk} = $value;
486     $proto = eval 'prototype \&oonk';
487     like ($@, qr/^Cannot convert a reference to $type to typeglob/,
488           "Cannot upgrade ref-to-$type to typeglob");
489 }
490
491 {
492     no warnings qw(once uninitialized);
493     my $g = \*clatter;
494     my $r = eval {no strict; ${*{$g}{SCALAR}}};
495     is ($@, '', "PERL_DONT_CREATE_GVSV shouldn't affect thingy syntax");
496
497     $g = \*vowm;
498     $r = eval {use strict; ${*{$g}{SCALAR}}};
499     is ($@, '',
500         "PERL_DONT_CREATE_GVSV shouldn't affect thingy syntax under strict");
501 }
502
503 {
504     # Bug reported by broquaint on IRC
505     *slosh::{HASH}->{ISA}=[];
506     slosh->import;
507     pass("gv_fetchmeth coped with the unexpected");
508
509     # An audit found these:
510     {
511         package slosh;
512         sub rip {
513             my $s = shift;
514             $s->SUPER::rip;
515         }
516     }
517     eval {slosh->rip;};
518     like ($@, qr/^Can't locate object method "rip"/, "Even with SUPER");
519
520     is(slosh->isa('swoosh'), '');
521
522     $CORE::GLOBAL::{"lock"}=[];
523     eval "no warnings; lock";
524     like($@, qr/^Not enough arguments for lock/,
525        "Can't trip up general keyword overloading");
526
527     $CORE::GLOBAL::{"readline"}=[];
528     eval "<STDOUT> if 0";
529     is($@, '', "Can't trip up readline overloading");
530
531     $CORE::GLOBAL::{"readpipe"}=[];
532     eval "`` if 0";
533     is($@, '', "Can't trip up readpipe overloading");
534 }
535
536 {
537     die if exists $::{BONK};
538     $::{BONK} = \"powie";
539     *{"BONK"} = \&{"BONK"};
540     eval 'is(BONK(), "powie",
541              "Assigment works when glob created midway (bug 45607)"); 1'
542         or die $@;
543 }
544
545 # For now these tests are here, but they would probably be better in a file for
546 # tests for croaks. (And in turn, that probably deserves to be in a different
547 # directory. Gerard Goossen has a point about the layout being unclear
548
549 sub coerce_integer {
550     no warnings 'numeric';
551     $_[0] |= 0;
552 }
553 sub coerce_number {
554     no warnings 'numeric';
555     $_[0] += 0;
556 }
557 sub coerce_string {
558     $_[0] .= '';
559 }
560
561 foreach my $type (qw(integer number string)) {
562     my $prog = "coerce_$type(*STDERR)";
563     is (scalar eval "$prog; 1", undef, "$prog failed...");
564     like ($@, qr/Can't coerce GLOB to $type in/,
565           "with the correct error message");
566 }
567
568 # RT #60954 anonymous glob should be defined, and not coredump when
569 # stringified. The behaviours are:
570 #
571 #        defined($glob)    "$glob"
572 # 5.8.8     false           "" with uninit warning
573 # 5.10.0    true            (coredump)
574 # 5.12.0    true            ""
575
576 {
577     my $io_ref = *STDOUT{IO};
578     my $glob = *$io_ref;
579     ok(defined $glob, "RT #60954 anon glob should be defined");
580
581     my $warn = '';
582     local $SIG{__WARN__} = sub { $warn = $_[0] };
583     use warnings;
584     my $str = "$glob";
585     is($warn, '', "RT #60954 anon glob stringification shouln't warn");
586     is($str,  '', "RT #60954 anon glob stringification should be empty");
587 }
588
589 # [perl #71254] - Assigning a glob to a variable that has a current
590 # match position. (We are testing that Perl_magic_setmglob respects globs'
591 # special used of SvSCREAM.)
592 {
593     $m = 2; $m=~s/./0/gems; $m= *STDERR;
594     is(
595         "$m", "*main::STDERR",
596         '[perl #71254] assignment of globs to vars with pos'
597     );
598 }
599
600 # [perl #72740] - indirect object syntax, heuristically imputed due to
601 # the non-existence of a function, should not cause a stash entry to be
602 # created for the non-existent function.
603 {
604         package RT72740a;
605         my $f = bless({}, RT72740b);
606         sub s1 { s2 $f; }
607         our $s4;
608         sub s3 { s4 $f; }
609 }
610 {
611         package RT72740b;
612         sub s2 { "RT72740b::s2" }
613         sub s4 { "RT72740b::s4" }
614 }
615 ok(exists($RT72740a::{s1}), "RT72740a::s1 exists");
616 ok(!exists($RT72740a::{s2}), "RT72740a::s2 does not exist");
617 ok(exists($RT72740a::{s3}), "RT72740a::s3 exists");
618 ok(exists($RT72740a::{s4}), "RT72740a::s4 exists");
619 is(RT72740a::s1(), "RT72740b::s2", "RT72740::s1 parsed correctly");
620 is(RT72740a::s3(), "RT72740b::s4", "RT72740::s3 parsed correctly");
621
622 # [perl #71686] Globs that are in symbol table can be un-globbed
623 $sym = undef;
624 $::{fake} = *sym;
625 is (eval 'local *::fake = \"chuck"; $fake', 'chuck',
626         "Localized glob didn't coerce into a RV");
627 is ($@, '', "Can localize FAKE glob that's present in stash");
628 is (scalar $::{fake}, "*main::sym",
629         "Localized FAKE glob's value was correctly restored");
630
631 # [perl #1804] *$x assignment when $x is a copy of another glob
632 {
633     no warnings 'once';
634     my $x = *_random::glob_that_is_not_used_elsewhere;
635     *$x = sub{};
636     is(
637       "$x", '*_random::glob_that_is_not_used_elsewhere',
638       '[perl #1804] *$x assignment when $x is FAKE',
639     );
640 }
641
642 # [perl #76540]
643 # this caused panics or 'Attempt to free unreferenced scalar'
644 # (its a compile-time issue, so the die lets us skip the prints)
645 {
646     my @warnings;
647     local $SIG{__WARN__} = sub { push @warnings, @_ };
648
649     eval <<'EOF';
650 BEGIN { $::{FOO} = \'bar' }
651 die "made it";
652 print FOO, "\n";
653 print FOO, "\n";
654 EOF
655
656     like($@, qr/made it/, "#76540 - no panic");
657     ok(!@warnings, "#76540 - no 'Attempt to free unreferenced scalar'");
658 }
659
660 # [perl #77362] various bugs related to globs as PVLVs
661 {
662  no warnings qw 'once void';
663  my %h; # We pass a key of this hash to the subroutine to get a PVLV.
664  sub { for(shift) {
665   # Set up our glob-as-PVLV
666   $_ = *hon;
667
668   # Bad symbol for array
669   ok eval{ @$_; 1 }, 'PVLV glob slots can be autovivified' or diag $@;
670
671   # This should call TIEHANDLE, not TIESCALAR
672   *thext::TIEHANDLE = sub{};
673   ok eval{ tie *$_, 'thext'; 1 }, 'PVLV globs can be tied as handles'
674    or diag $@;
675
676   # Assigning undef to the glob should not overwrite it...
677   {
678    my $w;
679    local $SIG{__WARN__} = sub { $w = shift };
680    *$_ = undef;
681    is $_, "*main::hon", 'PVLV: assigning undef to the glob does nothing';
682    like $w, qr\Undefined value assigned to typeglob\,
683     'PVLV: assigning undef to the glob warns';
684   }
685
686   # Neither should number assignment...
687   *$_ = 1;
688   is $_, "*main::1", "PVLV: integer-to-glob assignment assigns a glob";
689   *$_ = 2.0;
690   is $_, "*main::2", "PVLV: float-to-glob assignment assigns a glob";
691
692   # Nor reference assignment.
693   *$_ = \*thit;
694   is $_, "*main::thit", "PVLV: globref-to-glob assignment assigns a glob";
695   *$_ = [];
696   is $_, "*main::thit", "PVLV: arrayref assignment assigns to the AV slot";
697
698   # Concatenation should still work.
699   ok eval { $_ .= 'thlew' }, 'PVLV concatenation does not die' or diag $@;
700   is $_, '*main::thitthlew', 'PVLV concatenation works';
701
702   # And we should be able to overwrite it with a string, number, or refer-
703   # ence, too, if we omit the *.
704   $_ = *hon; $_ = 'tzor';
705   is $_, 'tzor', 'PVLV: assigning a string over a glob';
706   $_ = *hon; $_ = 23;
707   is $_, 23, 'PVLV: assigning an integer over a glob';
708   $_ = *hon; $_ = 23.23;
709   is $_, 23.23, 'PVLV: assigning a float over a glob';
710   $_ = *hon; $_ = \my $sthat;
711   is $_, \$sthat, 'PVLV: assigning a reference over a glob';
712
713   # This bug was found by code inspection. Could this ever happen in
714   # real life? :-)
715   # This duplicates a file handle, accessing it through a PVLV glob, the
716   # glob having been removed from the symbol table, so a stringified form
717   # of it does not work. This checks that sv_2io does not stringify a PVLV.
718   $_ = *quin;
719   open *quin, "test.pl"; # test.pl is as good a file as any
720   delete $::{quin};
721   ok eval { open my $zow, "<&", $_ }, 'PVLV: sv_2io stringifieth not'
722    or diag $@;
723
724   # Similar tests to make sure sv_2cv etc. do not stringify.
725   *$_ = sub { 1 };
726   ok eval { &$_ }, "PVLV glob can be called as a sub" or diag $@;
727   *flelp = sub { 2 };
728   $_ = 'flelp';
729   is eval { &$_ }, 2, 'PVLV holding a string can be called as a sub'
730    or diag $@;
731
732   # Coderef-to-glob assignment when the glob is no longer accessible
733   # under its name: These tests are to make sure the OPpASSIGN_CV_TO_GV
734   # optimisation takes PVLVs into account, which is why the RHSs have to be
735   # named subs.
736   use constant gheen => 'quare';
737   $_ = *ming;
738   delete $::{ming};
739   *$_ = \&gheen;
740   is eval { &$_ }, 'quare',
741    'PVLV: constant assignment when the glob is detached from the symtab'
742     or diag $@;
743   $_ = *bength;
744   delete $::{bength};
745   *gheck = sub { 'lon' };
746   *$_ = \&gheck;
747   is eval { &$_ }, 'lon',
748    'PVLV: coderef assignment when the glob is detached from the symtab'
749     or diag $@;
750
751   # open should accept a PVLV as its first argument
752   $_ = *hon;
753   ok eval { open $_,'<', \my $thlext }, 'PVLV can be the first arg to open'
754    or diag $@;
755
756   # -t should not stringify
757   $_ = *thlit; delete $::{thlit};
758   *$_ = *STDOUT{IO};
759   ok defined -t $_, 'PVLV: -t does not stringify';
760
761   # neither should -T
762   open my $quile, "<", 'test.pl';
763   $_ = *$quile;
764   ok -T $_, "PVLV: -T does not stringify";
765   
766   # Unopened file handle
767   {
768    my $w;
769    local $SIG{__WARN__} = sub { $w .= shift };
770    $_ = *vor;
771    close $_;
772    like $w, qr\unopened filehandle vor\,
773     'PVLV globs get their names reported in unopened error messages';
774   }
775
776  }}->($h{k});
777 }
778
779 __END__
780 Perl
781 Rules
782 perl
783 rocks