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 => 239 );
  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 #65582 anonymous glob should be defined, and not coredump when
 599 # stringified. The behaviours are:
 600 #
 601 #        defined($glob)    "$glob"                   $glob .= ...
 602 # 5.8.8     false           "" with uninit warning   "" with uninit warning
 603 # 5.10.0    true            (coredump)               (coredump)
 604 # 5.1[24]   true            ""                       "" with uninit warning
 605 # 5.16      true            "*__ANON__::..."         "*__ANON__::..."
 606
 607 {
 608     my $io_ref = *STDOUT{IO};
 609     my $glob = *$io_ref;
 610     ok(defined $glob, "RT #65582 anon glob should be defined");
 611
 612     my $warn = '';
 613     local $SIG{__WARN__} = sub { $warn = $_[0] };
 614     use warnings;
 615     my $str = "$glob";
 616     is($warn, '', "RT #65582 anon glob stringification shouldn't warn");
 617     is($str,  '*__ANON__::$__ANONIO__',
 618         "RT #65582/#96326 anon glob stringification");
 619 }
 620
 621 # [perl #71254] - Assigning a glob to a variable that has a current
 622 # match position. (We are testing that Perl_magic_setmglob respects globs'
 623 # special used of SvSCREAM.)
 624 {
 625     $m = 2; $m=~s/./0/gems; $m= *STDERR;
 626     is(
 627         "$m", "*main::STDERR",
 628         '[perl #71254] assignment of globs to vars with pos'
 629     );
 630 }
 631
 632 # [perl #72740] - indirect object syntax, heuristically imputed due to
 633 # the non-existence of a function, should not cause a stash entry to be
 634 # created for the non-existent function.
 635 {
 636         package RT72740a;
 637         my $f = bless({}, RT72740b);
 638         sub s1 { s2 $f; }
 639         our $s4;
 640         sub s3 { s4 $f; }
 641 }
 642 {
 643         package RT72740b;
 644         sub s2 { "RT72740b::s2" }
 645         sub s4 { "RT72740b::s4" }
 646 }
 647 ok(exists($RT72740a::{s1}), "RT72740a::s1 exists");
 648 ok(!exists($RT72740a::{s2}), "RT72740a::s2 does not exist");
 649 ok(exists($RT72740a::{s3}), "RT72740a::s3 exists");
 650 ok(exists($RT72740a::{s4}), "RT72740a::s4 exists");
 651 is(RT72740a::s1(), "RT72740b::s2", "RT72740::s1 parsed correctly");
 652 is(RT72740a::s3(), "RT72740b::s4", "RT72740::s3 parsed correctly");
 653
 654 # [perl #71686] Globs that are in symbol table can be un-globbed
 655 $sym = undef;
 656 $::{fake} = *sym;
 657 is (eval 'local *::fake = \"chuck"; $fake', 'chuck',
 658         "Localized glob didn't coerce into a RV");
 659 is ($@, '', "Can localize FAKE glob that's present in stash");
 660 is (scalar $::{fake}, "*main::sym",
 661         "Localized FAKE glob's value was correctly restored");
 662
 663 # [perl #1804] *$x assignment when $x is a copy of another glob
 664 # And [perl #77508] (same thing with list assignment)
 665 {
 666     no warnings 'once';
 667     my $x = *_random::glob_that_is_not_used_elsewhere;
 668     *$x = sub{};
 669     is(
 670       "$x", '*_random::glob_that_is_not_used_elsewhere',
 671       '[perl #1804] *$x assignment when $x is FAKE',
 672     );
 673     $x = *_random::glob_that_is_not_used_elsewhere;
 674     (my $dummy, *$x) = (undef,[]);
 675     is(
 676       "$x", '*_random::glob_that_is_not_used_elsewhere',
 677       '[perl #77508] *$x list assignment when $x is FAKE',
 678     ) or require Devel::Peek, Devel::Peek::Dump($x);
 679 }
 680
 681 # [perl #76540]
 682 # this caused panics or 'Attempt to free unreferenced scalar'
 683 # (its a compile-time issue, so the die lets us skip the prints)
 684 {
 685     my @warnings;
 686     local $SIG{__WARN__} = sub { push @warnings, @_ };
 687
 688     eval <<'EOF';
 689 BEGIN { $::{FOO} = \'bar' }
 690 die "made it";
 691 print FOO, "\n";
 692 print FOO, "\n";
 693 EOF
 694
 695     like($@, qr/made it/, "#76540 - no panic");
 696     ok(!@warnings, "#76540 - no 'Attempt to free unreferenced scalar'");
 697 }
 698
 699 # [perl #77362] various bugs related to globs as PVLVs
 700 {
 701  no warnings qw 'once void';
 702  my %h; # We pass a key of this hash to the subroutine to get a PVLV.
 703  sub { for(shift) {
 704   # Set up our glob-as-PVLV
 705   $_ = *hon;
 706
 707   # Bad symbol for array
 708   ok eval{ @$_; 1 }, 'PVLV glob slots can be autovivified' or diag $@;
 709
 710   # This should call TIEHANDLE, not TIESCALAR
 711   *thext::TIEHANDLE = sub{};
 712   ok eval{ tie *$_, 'thext'; 1 }, 'PVLV globs can be tied as handles'
 713    or diag $@;
 714
 715   # Assigning undef to the glob should not overwrite it...
 716   {
 717    my $w;
 718    local $SIG{__WARN__} = sub { $w = shift };
 719    *$_ = undef;
 720    is $_, "*main::hon", 'PVLV: assigning undef to the glob does nothing';
 721    like $w, qr\Undefined value assigned to typeglob\,
 722     'PVLV: assigning undef to the glob warns';
 723   }
 724
 725   # Neither should reference assignment.
 726   *$_ = [];
 727   is $_, "*main::hon", "PVLV: arrayref assignment assigns to the AV slot";
 728
 729   # Concatenation should still work.
 730   ok eval { $_ .= 'thlew' }, 'PVLV concatenation does not die' or diag $@;
 731   is $_, '*main::honthlew', 'PVLV concatenation works';
 732
 733   # And we should be able to overwrite it with a string, number, or refer-
 734   # ence, too, if we omit the *.
 735   $_ = *hon; $_ = 'tzor';
 736   is $_, 'tzor', 'PVLV: assigning a string over a glob';
 737   $_ = *hon; $_ = 23;
 738   is $_, 23, 'PVLV: assigning an integer over a glob';
 739   $_ = *hon; $_ = 23.23;
 740   is $_, 23.23, 'PVLV: assigning a float over a glob';
 741   $_ = *hon; $_ = \my $sthat;
 742   is $_, \$sthat, 'PVLV: assigning a reference over a glob';
 743
 744   # This bug was found by code inspection. Could this ever happen in
 745   # real life? :-)
 746   # This duplicates a file handle, accessing it through a PVLV glob, the
 747   # glob having been removed from the symbol table, so a stringified form
 748   # of it does not work. This checks that sv_2io does not stringify a PVLV.
 749   $_ = *quin;
 750   open *quin, "test.pl"; # test.pl is as good a file as any
 751   delete $::{quin};
 752   ok eval { open my $zow, "<&", $_ }, 'PVLV: sv_2io stringifieth not'
 753    or diag $@;
 754
 755   # Similar tests to make sure sv_2cv etc. do not stringify.
 756   *$_ = sub { 1 };
 757   ok eval { &$_ }, "PVLV glob can be called as a sub" or diag $@;
 758   *flelp = sub { 2 };
 759   $_ = 'flelp';
 760   is eval { &$_ }, 2, 'PVLV holding a string can be called as a sub'
 761    or diag $@;
 762
 763   # Coderef-to-glob assignment when the glob is no longer accessible
 764   # under its name: These tests are to make sure the OPpASSIGN_CV_TO_GV
 765   # optimisation takes PVLVs into account, which is why the RHSs have to be
 766   # named subs.
 767   use constant gheen => 'quare';
 768   $_ = *ming;
 769   delete $::{ming};
 770   *$_ = \&gheen;
 771   is eval { &$_ }, 'quare',
 772    'PVLV: constant assignment when the glob is detached from the symtab'
 773     or diag $@;
 774   $_ = *bength;
 775   delete $::{bength};
 776   *gheck = sub { 'lon' };
 777   *$_ = \&gheck;
 778   is eval { &$_ }, 'lon',
 779    'PVLV: coderef assignment when the glob is detached from the symtab'
 780     or diag $@;
 781
 782 SKIP: {
 783     skip_if_miniperl("no dynamic loading on miniperl, so can't load PerlIO::scalar", 1);
 784     # open should accept a PVLV as its first argument
 785     $_ = *hon;
 786     ok eval { open $_,'<', \my $thlext }, 'PVLV can be the first arg to open'
 787         or diag $@;
 788   }
 789
 790   # -t should not stringify
 791   $_ = *thlit; delete $::{thlit};
 792   *$_ = *STDOUT{IO};
 793   ok defined -t $_, 'PVLV: -t does not stringify';
 794
 795   # neither should -T
 796   # but some systems don’t support this on file handles
 797   my $pass;
 798   ok
 799     eval {
 800      open my $quile, "<", 'test.pl';
 801      $_ = *$quile;
 802      $pass = -T $_;
 803      1
 804     } ? $pass : $@ =~ /not implemented on filehandles/,
 805    "PVLV: -T does not stringify";
 806
 807   # Unopened file handle
 808   {
 809    my $w;
 810    local $SIG{__WARN__} = sub { $w .= shift };
 811    $_ = *vor;
 812    close $_;
 813    like $w, qr\unopened filehandle vor\,
 814     'PVLV globs get their names reported in unopened error messages';
 815   }
 816
 817  }}->($h{k});
 818 }
 819
 820 *aieee = 4;
 821 pass('Can assign integers to typeglobs');
 822 *aieee = 3.14;
 823 pass('Can assign floats to typeglobs');
 824 *aieee = 'pi';
 825 pass('Can assign strings to typeglobs');
 826
 827 {
 828   package thrext;
 829   sub TIESCALAR{bless[]}
 830   sub STORE{ die "No!"}
 831   sub FETCH{ no warnings 'once'; *thrit }
 832   tie my $a, "thrext";
 833   () = "$a"; # do a fetch; now $a holds a glob
 834   eval { *$a = sub{} };
 835   untie $a;
 836   eval { $a = "bar" };
 837   ::is $a, "bar",
 838     "[perl #77812] Globs in tied scalars can be reified if STORE dies"
 839 }
 840
 841 # These two crashed prior to 5.13.6. In 5.13.6 they were fatal errors. They
 842 # were fixed in 5.13.7.
 843 ok eval {
 844   my $glob = \*heen::ISA;
 845   delete $::{"heen::"};
 846   *$glob = *bar;
 847 }, "glob-to-*ISA assignment works when *ISA has lost its stash";
 848 ok eval {
 849   my $glob = \*slare::ISA;
 850   delete $::{"slare::"};
 851   *$glob = [];
 852 }, "array-to-*ISA assignment works when *ISA has lost its stash";
 853 # These two crashed in 5.13.6. They were likewise fixed in 5.13.7.
 854 ok eval {
 855   sub greck;
 856   my $glob = do { no warnings "once"; \*phing::foo};
 857   delete $::{"phing::"};
 858   *$glob = *greck;
 859 }, "Assigning a glob-with-sub to a glob that has lost its stash works";
 860 ok eval {
 861   sub pon::foo;
 862   my $glob = \*pon::foo;
 863   delete $::{"pon::"};
 864   *$glob = *foo;
 865 }, "Assigning a glob to a glob-with-sub that has lost its stash works";
 866
 867 {
 868   package Tie::Alias;
 869   sub TIESCALAR{ bless \\pop }
 870   sub FETCH { $${$_[0]} }
 871   sub STORE { $${$_[0]} = $_[1] }
 872   package main;
 873   tie my $alias, 'Tie::Alias', my $var;
 874   no warnings 'once';
 875   $var = *galobbe;
 876   {
 877     local *$alias = [];
 878     $var = 3;
 879     is $alias, 3, "[perl #77926] Glob reification during localisation";
 880   }
 881 }
 882
 883 # This code causes gp_free to call a destructor when a glob is being
 884 # restored on scope exit. The destructor used to see SVs with a refcount of
 885 # zero inside the glob, which could result in crashes (though not in this
 886 # test case, which just panics).
 887 {
 888  no warnings 'once';
 889  my $survived;
 890  *Trit::DESTROY = sub {
 891    $thwext = 42;  # panic
 892    $survived = 1;
 893  };
 894  {
 895   local *thwext;
 896   $thwext = bless[],'Trit';
 897   ();
 898  }
 899  ok $survived,
 900   'no error when gp_free calls a destructor that assigns to the gv';
 901 }
 902
 903 # *{undef}
 904 eval { *{my $undef} = 3 };
 905 like $@, qr/^Can't use an undefined value as a symbol reference at /,
 906   '*{ $undef } assignment';
 907 eval { *{;undef} = 3 };
 908 like $@, qr/^Can't use an undefined value as a symbol reference at /,
 909   '*{ ;undef } assignment';
 910
 911 # [perl #99142] defined &{"foo"} when there is a constant stub
 912 # If I break your module, you get to have it mentioned in Perl's tests. :-)
 913 package HTTP::MobileAttribute::Plugin::Locator {
 914     use constant LOCATOR_GPS => 1;
 915     ::ok defined &{__PACKAGE__."::LOCATOR_GPS"},
 916         'defined &{"name of constant"}';
 917     ::ok Internals::SvREFCNT(${__PACKAGE__."::"}{LOCATOR_GPS}),
 918        "stash elem for slot is not freed prematurely";
 919 }
 920
 921 # Check that constants promoted to CVs point to the right GVs when the name
 922 # contains a null.
 923 package lrcg {
 924   use constant x => 3;
 925   # These two lines abuse the optimisation that copies the scalar ref from
 926   # one stash element to another, to get a constant with a null in its name
 927   *{"yz\0a"} = \&{"x"};
 928   my $ref = \&{"yz\0a"};
 929   ::ok !exists $lrcg::{yz},
 930     'constants w/nulls in their names point 2 the right GVs when promoted';
 931 }
 932
 933 __END__
 934 Perl
 935 Rules
 936 perl
 937 rocks