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