1#!./perl 2 3# 4# various typeglob tests 5# 6 7BEGIN { 8 chdir 't' if -d 't'; 9 require './test.pl'; 10 set_up_inc('../lib'); 11 skip_all_without_unicode_tables(); 12} 13 14use utf8; 15use open qw( :utf8 :std ); 16use warnings; 17 18plan( tests => 206 ); 19 20# type coersion on assignment 21$ᕘ = 'ᕘ'; 22$ᴮᛅ = *main::ᕘ; 23$ᴮᛅ = $ᕘ; 24is(ref(\$ᴮᛅ), 'SCALAR'); 25$ᕘ = *main::ᴮᛅ; 26 27# type coersion (not) on misc ops 28 29ok($ᕘ); 30is(ref(\$ᕘ), 'GLOB'); 31 32unlike ($ᕘ, qr/abcd/); 33is(ref(\$ᕘ), 'GLOB'); 34 35is($ᕘ, '*main::ᴮᛅ'); 36is(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//; 70is(ref(\$a), 'GLOB'); 71$a =~ s/^\*//; 72is($a, 'main::ᕘ'); 73is(ref(\$b), 'GLOB'); 74 75# typeglobs as lvalues 76substr($ᕘ, 0, 1) = "XXX"; 77is(ref(\$ᕘ), 'SCALAR'); 78is($ᕘ, 'XXXmain::ᴮᛅ'); 79 80# returning glob values 81sub ᕘ { 82 local($ᴮᛅ) = *main::ᕘ; 83 $ᕘ = *main::ᴮᛅ; 84 return ($ᕘ, $ᴮᛅ); 85} 86 87($ፉṶ, $ባ) = ᕘ(); 88ok(defined $ፉṶ); 89is(ref(\$ፉṶ), 'GLOB'); 90 91 92ok(defined $ባ); 93is(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; } 101ok(exists $ฝ오::{'ʉ::'}); 102is($ฝ오::{'ʉ::'}, '*ฝ오::ʉ::'); 103 104 105# test undef operator clearing out entire glob 106$ᕘ = 'stuff'; 107@ᕘ = qw(more stuff); 108%ᕘ = qw(even more random stuff); 109undef *ᕘ; 110is ($ᕘ, undef); 111is (scalar @ᕘ, 0); 112is (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 160my $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; 168sub Ẋ { "ok $test\n" } 169print ${*Ẋ{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; 173format Ẋ = 174XXX This text isn't used. Should it be? 175. 176curr_test($test); 177 178is (ref *Ẋ{FORMAT}, "FORMAT"); 179*Ẋ = *STDOUT; 180is (*{*Ẋ{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 226is($Ｊ, 1); 227is($Ｊ{a}, 1); 228is($Ｊ[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 *Ⱥ:: = \*ㄅ::; 312EOPROG 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 357delete $::{оઓnḲ}; 358$::{оઓnḲ} = \"Value"; 359 360*{"ga_ㄕƚo잎"} = \&{"оઓnḲ"}; 361 362is (ref $::{ga_ㄕƚo잎}, 'SCALAR', "Export of proxy constant as is"); 363is (ref $::{оઓnḲ}, 'SCALAR', "Export doesn't affect original"); 364is (eval 'ga_ㄕƚo잎', "Value", "Constant has correct value"); 365is (ref $::{ga_ㄕƚo잎}, 'SCALAR', 366 "Inlining of constant doesn't change representation"); 367 368delete $::{ga_ㄕƚo잎}; 369 370eval 'sub ga_ㄕƚo잎 (); 1' or die $@; 371is ($::{ga_ㄕƚo잎}, '', "Prototype is stored as an empty string"); 372 373# Check that a prototype expands. 374*{"ga_ㄕƚo잎"} = \&{"оઓnḲ"}; 375 376is (ref $::{оઓnḲ}, 'SCALAR', "Export doesn't affect original"); 377is (eval 'ga_ㄕƚo잎', "Value", "Constant has correct value"); 378is (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 391is (ref $::{оઓnḲ}, 'SCALAR', "Export doesn't affect original"); 392is (eval 'zᐓｔ', "Value", "Constant has correct value"); 393is (ref \$::{zᐓｔ}, 'GLOB', "Symbol table has full typeglob"); 394is (join ('!', @::zᐓｔ), 'Zᐓｔ!', "Existing array still in typeglob"); 395 396sub Ṩ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 409is (ref $::{оઓnḲ}, 'SCALAR', "Export doesn't affect original"); 410is (eval 'Ṩp맅싵Ş', "Value", "Constant has correct value"); 411is (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 422is (ref $::{оઓnḲ}, 'SCALAR', "Export doesn't affect original"); 423is (eval 'plუᒃ', "Value", "Constant has correct value"); 424is (ref \$::{plუᒃ}, 'GLOB', "Symbol table has full typeglob"); 425 426my $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 435is (ref $::{оઓnḲ}, 'SCALAR', "Export doesn't affect original"); 436is (eval 'plუᒃ', "Value", "Constant has correct value"); 437is (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) 441my $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 449is (ref \$result, 'GLOB', 450 "Non void assignment should still return a typeglob"); 451 452is (ref \$::{оઓnḲ}, 'GLOB', "This export does affect original"); 453is (eval 'plუᒃ', "Value", "Constant has correct value"); 454is (ref \$::{plუᒃ}, 'GLOB', "Symbol table has full typeglob"); 455 456delete $::{оઓnḲ}; 457$::{оઓnḲ} = \"Value"; 458 459sub non_dangling { 460 my $w = ''; 461 local $SIG{__WARN__} = sub { $w = $_[0] }; 462 *{"z앞"} = \&{"оઓnḲ"}; 463 is($w, '', "Should be no warning"); 464} 465 466non_dangling(); 467is (ref $::{оઓnḲ}, 'SCALAR', "Export doesn't affect original"); 468is (eval 'z앞', "Value", "Constant has correct value"); 469is (ref $::{z앞}, 'SCALAR', "Exported target is also a PCS"); 470 471sub dangling { 472 local $SIG{__WARN__} = sub { die $_[0] }; 473 *{"ビfᶠ"} = \&{"оઓnḲ"}; 474} 475 476dangling(); 477is (ref \$::{оઓnḲ}, 'GLOB', "This export does affect original"); 478is (eval 'ビfᶠ', "Value", "Constant has correct value"); 479is (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{ 501no warnings 'once'; 502format = 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Ṁ; 589is (eval 'local *::Ḟ앜ɞ = \"chuck"; $Ḟ앜ɞ', 'chuck', 590 "Localized glob didn't coerce into a RV"); 591is ($@, '', "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'; 623BEGIN { $::{FÒÒ} = \'ᴮᛅ' } 624die "made it"; 625print FÒÒ, "\n"; 626print FÒÒ, "\n"; 627EOF 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 718SKIP: { 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’t 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; 756pass('Can assign integers to typeglobs'); 757*àieee = 3.14; 758pass('Can assign floats to typeglobs'); 759*àieee = 'pi'; 760pass('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. 779ok 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"; 784ok 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. 790ok 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"; 796ok 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__ 839Perl 840Rules 841perl 842rocks 843