t/uni/gv.t

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