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