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   # but some systems don’t support this on file handles
 763   my $pass;
 764   ok
 765     eval {
 766      open my $quile, "<", 'test.pl';
 767      $_ = *$quile;
 768      $pass = -T $_;
 769      1
 770     } ? $pass : $@ =~ /not implemented on filehandles/,
 771    "PVLV: -T does not stringify";
 772
 773   # Unopened file handle
 774   {
 775    my $w;
 776    local $SIG{__WARN__} = sub { $w .= shift };
 777    $_ = *vor;
 778    close $_;
 779    like $w, qr\unopened filehandle vor\,
 780     'PVLV globs get their names reported in unopened error messages';
 781   }
 782
 783  }}->($h{k});
 784 }
 785
 786 __END__
 787 Perl
 788 Rules
 789 perl
 790 rocks