1#!./perl 2 3# Add new tests to the end with format: 4# ######## 5# 6# # test description 7# Test code 8# EXPECT 9# Warn or die msgs (if any) at - line 1234 10# 11 12chdir 't' if -d 't'; 13require './test.pl'; 14set_up_inc('../lib'); 15 16$|=1; 17 18run_multiple_progs('', \*DATA); 19 20done_testing(); 21 22__END__ 23 24# standard behaviour, without any extra references 25use Tie::Hash ; 26tie %h, Tie::StdHash; 27untie %h; 28EXPECT 29######## 30# SKIP ?!defined &DynaLoader::boot_DynaLoader && !eval 'require base' 31# (skip under miniperl if base.pm is not in lib/ yet) 32 33# standard behaviour, without any extra references 34use Tie::Hash ; 35{package Tie::HashUntie; 36 use base 'Tie::StdHash'; 37 sub UNTIE 38 { 39 warn "Untied\n"; 40 } 41} 42tie %h, Tie::HashUntie; 43untie %h; 44EXPECT 45Untied 46######## 47 48# standard behaviour, with 1 extra reference 49use Tie::Hash ; 50$a = tie %h, Tie::StdHash; 51untie %h; 52EXPECT 53######## 54 55# standard behaviour, with 1 extra reference via tied 56use Tie::Hash ; 57tie %h, Tie::StdHash; 58$a = tied %h; 59untie %h; 60EXPECT 61######## 62 63# standard behaviour, with 1 extra reference which is destroyed 64use Tie::Hash ; 65$a = tie %h, Tie::StdHash; 66$a = 0 ; 67untie %h; 68EXPECT 69######## 70 71# standard behaviour, with 1 extra reference via tied which is destroyed 72use Tie::Hash ; 73tie %h, Tie::StdHash; 74$a = tied %h; 75$a = 0 ; 76untie %h; 77EXPECT 78######## 79 80# strict behaviour, without any extra references 81use warnings 'untie'; 82use Tie::Hash ; 83tie %h, Tie::StdHash; 84untie %h; 85EXPECT 86######## 87 88# strict behaviour, with 1 extra references generating an error 89use warnings 'untie'; 90use Tie::Hash ; 91$a = tie %h, Tie::StdHash; 92untie %h; 93EXPECT 94untie attempted while 1 inner references still exist at - line 6. 95######## 96 97# strict behaviour, with 1 extra references via tied generating an error 98use warnings 'untie'; 99use Tie::Hash ; 100tie %h, Tie::StdHash; 101$a = tied %h; 102untie %h; 103EXPECT 104untie attempted while 1 inner references still exist at - line 7. 105######## 106 107# strict behaviour, with 1 extra references which are destroyed 108use warnings 'untie'; 109use Tie::Hash ; 110$a = tie %h, Tie::StdHash; 111$a = 0 ; 112untie %h; 113EXPECT 114######## 115 116# strict behaviour, with extra 1 references via tied which are destroyed 117use warnings 'untie'; 118use Tie::Hash ; 119tie %h, Tie::StdHash; 120$a = tied %h; 121$a = 0 ; 122untie %h; 123EXPECT 124######## 125 126# strict error behaviour, with 2 extra references 127use warnings 'untie'; 128use Tie::Hash ; 129$a = tie %h, Tie::StdHash; 130$b = tied %h ; 131untie %h; 132EXPECT 133untie attempted while 2 inner references still exist at - line 7. 134######## 135 136# strict behaviour, check scope of strictness. 137no warnings 'untie'; 138use Tie::Hash ; 139$A = tie %H, Tie::StdHash; 140$C = $B = tied %H ; 141{ 142 use warnings 'untie'; 143 use Tie::Hash ; 144 tie %h, Tie::StdHash; 145 untie %h; 146} 147untie %H; 148EXPECT 149######## 150 151# Forbidden aggregate self-ties 152sub Self::TIEHASH { bless $_[1], $_[0] } 153{ 154 my %c; 155 tie %c, 'Self', \%c; 156} 157EXPECT 158Self-ties of arrays and hashes are not supported at - line 6. 159######## 160 161# Allowed scalar self-ties 162my $destroyed = 0; 163sub Self::TIESCALAR { bless $_[1], $_[0] } 164sub Self::DESTROY { $destroyed = 1; } 165{ 166 my $c = 42; 167 tie $c, 'Self', \$c; 168} 169die "self-tied scalar not DESTROYed" unless $destroyed == 1; 170EXPECT 171######## 172 173# Allowed glob self-ties 174my $destroyed = 0; 175my $printed = 0; 176sub Self2::TIEHANDLE { bless $_[1], $_[0] } 177sub Self2::DESTROY { $destroyed = 1; } 178sub Self2::PRINT { $printed = 1; } 179{ 180 use Symbol; 181 my $c = gensym; 182 tie *$c, 'Self2', $c; 183 print $c 'Hello'; 184} 185die "self-tied glob not PRINTed" unless $printed == 1; 186die "self-tied glob not DESTROYed" unless $destroyed == 1; 187EXPECT 188######## 189 190# Allowed IO self-ties 191my $destroyed = 0; 192sub Self3::TIEHANDLE { bless $_[1], $_[0] } 193sub Self3::DESTROY { $destroyed = 1; } 194sub Self3::PRINT { $printed = 1; } 195{ 196 use Symbol 'geniosym'; 197 my $c = geniosym; 198 tie *$c, 'Self3', $c; 199 print $c 'Hello'; 200} 201die "self-tied IO not PRINTed" unless $printed == 1; 202die "self-tied IO not DESTROYed" unless $destroyed == 1; 203EXPECT 204######## 205 206# TODO IO "self-tie" via TEMP glob 207my $destroyed = 0; 208sub Self3::TIEHANDLE { bless $_[1], $_[0] } 209sub Self3::DESTROY { $destroyed = 1; } 210sub Self3::PRINT { $printed = 1; } 211{ 212 use Symbol 'geniosym'; 213 my $c = geniosym; 214 tie *$c, 'Self3', \*$c; 215 print $c 'Hello'; 216} 217die "IO tied to TEMP glob not PRINTed" unless $printed == 1; 218die "IO tied to TEMP glob not DESTROYed" unless $destroyed == 1; 219EXPECT 220######## 221 222# Interaction of tie and vec 223 224my ($a, $b); 225use Tie::Scalar; 226tie $a,Tie::StdScalar or die; 227vec($b,1,1)=1; 228$a = $b; 229vec($a,1,1)=0; 230vec($b,1,1)=0; 231die unless $a eq $b; 232EXPECT 233######## 234 235# correct unlocalisation of tied hashes (patch #16431) 236use Tie::Hash ; 237tie %tied, Tie::StdHash; 238{ local $hash{'foo'} } warn "plain hash bad unlocalize" if exists $hash{'foo'}; 239{ local $tied{'foo'} } warn "tied hash bad unlocalize" if exists $tied{'foo'}; 240{ local $ENV{'foo'} } warn "%ENV bad unlocalize" if exists $ENV{'foo'}; 241EXPECT 242######## 243 244# An attempt at lvalueable barewords broke this 245tie FH, 'main'; 246EXPECT 247Can't modify constant item in tie at - line 3, near "'main';" 248Execution of - aborted due to compilation errors. 249######## 250 251# localizing tied hash slices 252$ENV{FooA} = 1; 253$ENV{FooB} = 2; 254print exists $ENV{FooA} ? 1 : 0, "\n"; 255print exists $ENV{FooB} ? 2 : 0, "\n"; 256print exists $ENV{FooC} ? 3 : 0, "\n"; 257{ 258 local @ENV{qw(FooA FooC)}; 259 print exists $ENV{FooA} ? 4 : 0, "\n"; 260 print exists $ENV{FooB} ? 5 : 0, "\n"; 261 print exists $ENV{FooC} ? 6 : 0, "\n"; 262} 263print exists $ENV{FooA} ? 7 : 0, "\n"; 264print exists $ENV{FooB} ? 8 : 0, "\n"; 265print exists $ENV{FooC} ? 9 : 0, "\n"; # this should not exist 266EXPECT 2671 2682 2690 2704 2715 2726 2737 2748 2750 276######## 277# 278# FETCH freeing tie'd SV still works 279sub TIESCALAR { bless [] } 280sub FETCH { *a = \1; 2 } 281tie $a, 'main'; 282print $a; 283EXPECT 2842 285######## 286 287# [20020716.007 (#10080)] - nested FETCHES 288 289sub F1::TIEARRAY { bless [], 'F1' } 290sub F1::FETCH { 1 } 291my @f1; 292tie @f1, 'F1'; 293 294sub F2::TIEARRAY { bless [2], 'F2' } 295sub F2::FETCH { my $self = shift; my $x = $f1[3]; $self } 296my @f2; 297tie @f2, 'F2'; 298 299print $f2[4][0],"\n"; 300 301sub F3::TIEHASH { bless [], 'F3' } 302sub F3::FETCH { 1 } 303my %f3; 304tie %f3, 'F3'; 305 306sub F4::TIEHASH { bless [3], 'F4' } 307sub F4::FETCH { my $self = shift; my $x = $f3{3}; $self } 308my %f4; 309tie %f4, 'F4'; 310 311print $f4{'foo'}[0],"\n"; 312 313EXPECT 3142 3153 316######## 317# test untie() from within FETCH 318package Foo; 319sub TIESCALAR { my $pkg = shift; return bless [@_], $pkg; } 320sub FETCH { 321 my $self = shift; 322 my ($obj, $field) = @$self; 323 untie $obj->{$field}; 324 $obj->{$field} = "Bar"; 325} 326package main; 327tie $a->{foo}, "Foo", $a, "foo"; 328my $s = $a->{foo}; # access once 329# the hash element should not be tied anymore 330print defined tied $a->{foo} ? "not ok" : "ok"; 331EXPECT 332ok 333######## 334# the tmps returned by FETCH should appear to be SCALAR 335# (even though they are now implemented using PVLVs.) 336package X; 337sub TIEHASH { bless {} } 338sub TIEARRAY { bless {} } 339sub FETCH {1} 340my (%h, @a); 341tie %h, 'X'; 342tie @a, 'X'; 343my $r1 = \$h{1}; 344my $r2 = \$a[0]; 345my $s = "$r1 ". ref($r1) . " $r2 " . ref($r2); 346$s=~ s/\(0x\w+\)//g; 347print $s, "\n"; 348EXPECT 349SCALAR SCALAR SCALAR SCALAR 350######## 351# [perl #23287] segfault in untie 352sub TIESCALAR { bless $_[1], $_[0] } 353my $var; 354tie $var, 'main', \$var; 355untie $var; 356EXPECT 357######## 358# Test case from perlmonks by runrig 359# http://www.perlmonks.org/index.pl?node_id=273490 360# "Here is what I tried. I think its similar to what you've tried 361# above. Its odd but convenient that after untie'ing you are left with 362# a variable that has the same value as was last returned from 363# FETCH. (At least on my perl v5.6.1). So you don't need to pass a 364# reference to the variable in order to set it after the untie (here it 365# is accessed through a closure)." 366use strict; 367use warnings; 368package MyTied; 369sub TIESCALAR { 370 my ($class,$code) = @_; 371 bless $code, $class; 372} 373sub FETCH { 374 my $self = shift; 375 print "Untie\n"; 376 $self->(); 377} 378package main; 379my $var; 380tie $var, 'MyTied', sub { untie $var; 4 }; 381print "One\n"; 382print "$var\n"; 383print "Two\n"; 384print "$var\n"; 385print "Three\n"; 386print "$var\n"; 387EXPECT 388One 389Untie 3904 391Two 3924 393Three 3944 395######## 396# [perl #22297] cannot untie scalar from within tied FETCH 397my $counter = 0; 398my $x = 7; 399my $ref = \$x; 400tie $x, 'Overlay', $ref, $x; 401my $y; 402$y = $x; 403$y = $x; 404$y = $x; 405$y = $x; 406#print "WILL EXTERNAL UNTIE $ref\n"; 407untie $$ref; 408$y = $x; 409$y = $x; 410$y = $x; 411$y = $x; 412#print "counter = $counter\n"; 413 414print (($counter == 1) ? "ok\n" : "not ok\n"); 415 416package Overlay; 417 418sub TIESCALAR 419{ 420 my $pkg = shift; 421 my ($ref, $val) = @_; 422 return bless [ $ref, $val ], $pkg; 423} 424 425sub FETCH 426{ 427 my $self = shift; 428 my ($ref, $val) = @$self; 429 #print "WILL INTERNAL UNITE $ref\n"; 430 $counter++; 431 untie $$ref; 432 return $val; 433} 434EXPECT 435ok 436######## 437 438# [perl #948] cannot meaningfully tie $, 439package TieDollarComma; 440 441sub TIESCALAR { 442 my $pkg = shift; 443 return bless \my $x, $pkg; 444} 445 446sub STORE { 447 my $self = shift; 448 $$self = shift; 449 print "STORE set '$$self'\n"; 450} 451 452sub FETCH { 453 my $self = shift; 454 print "<FETCH>"; 455 return $$self; 456} 457package main; 458 459tie $,, 'TieDollarComma'; 460$, = 'BOBBINS'; 461print "join", "things", "up\n"; 462EXPECT 463STORE set 'BOBBINS' 464join<FETCH>BOBBINSthings<FETCH>BOBBINSup 465######## 466 467# test SCALAR method 468package TieScalar; 469 470sub TIEHASH { 471 my $pkg = shift; 472 bless { } => $pkg; 473} 474 475sub STORE { 476 $_[0]->{$_[1]} = $_[2]; 477} 478 479sub FETCH { 480 $_[0]->{$_[1]} 481} 482 483sub CLEAR { 484 %{ $_[0] } = (); 485} 486 487sub SCALAR { 488 print "SCALAR\n"; 489 return 0 if ! keys %{$_[0]}; 490 sprintf "%i/%i", scalar keys %{$_[0]}, scalar keys %{$_[0]}; 491} 492 493package main; 494tie my %h => "TieScalar"; 495$h{key1} = "val1"; 496$h{key2} = "val2"; 497print scalar %h, "\n" 498 if %h; # this should also call SCALAR but implicitly 499%h = (); 500print scalar %h, "\n" 501 if !%h; # this should also call SCALAR but implicitly 502EXPECT 503SCALAR 504SCALAR 5052/2 506SCALAR 507SCALAR 5080 509######## 510 511# test scalar on tied hash when no SCALAR method has been given 512package TieScalar; 513 514sub TIEHASH { 515 my $pkg = shift; 516 bless { } => $pkg; 517} 518sub STORE { 519 $_[0]->{$_[1]} = $_[2]; 520} 521sub FETCH { 522 $_[0]->{$_[1]} 523} 524sub CLEAR { 525 %{ $_[0] } = (); 526} 527sub FIRSTKEY { 528 my $a = keys %{ $_[0] }; 529 print "FIRSTKEY\n"; 530 each %{ $_[0] }; 531} 532 533package main; 534tie my %h => "TieScalar"; 535 536if (!%h) { 537 print "empty\n"; 538} else { 539 print "not empty\n"; 540} 541 542$h{key1} = "val1"; 543print "not empty\n" if %h; 544print "not empty\n" if %h; 545print "-->\n"; 546my ($k,$v) = each %h; 547print "<--\n"; 548print "not empty\n" if %h; 549%h = (); 550print "empty\n" if ! %h; 551EXPECT 552FIRSTKEY 553empty 554FIRSTKEY 555not empty 556FIRSTKEY 557not empty 558--> 559FIRSTKEY 560<-- 561not empty 562FIRSTKEY 563empty 564######## 565sub TIESCALAR { bless {} } 566sub FETCH { my $x = 3.3; 1 if 0+$x; $x } 567tie $h, "main"; 568print $h,"\n"; 569EXPECT 5703.3 571######## 572sub TIESCALAR { bless {} } 573sub FETCH { shift()->{i} ++ } 574tie $h, "main"; 575print $h.$h; 576EXPECT 57701 578######## 579# SKIP ? $IS_EBCDIC 580# skipped on EBCDIC because "2" | "8" is 0xFA (not COLON as it is on ASCII), 581# which isn't representable in this file's UTF-8 encoding. 582# Bug 53482 (and maybe others) 583 584sub TIESCALAR { my $foo = $_[1]; bless \$foo, $_[0] } 585sub FETCH { ${$_[0]} } 586tie my $x1, "main", 2; 587tie my $y1, "main", 8; 588print $x1 | $y1; 589print $x1 | $y1; 590tie my $x2, "main", "2"; 591tie my $y2, "main", "8"; 592print $x2 | $y2; 593print $x2 | $y2; 594EXPECT 5951010:: 596######## 597# Bug 36267 598sub TIEHASH { bless {}, $_[0] } 599sub STORE { $_[0]->{$_[1]} = $_[2] } 600sub FIRSTKEY { my $a = scalar keys %{$_[0]}; each %{$_[0]} } 601sub NEXTKEY { each %{$_[0]} } 602sub DELETE { delete $_[0]->{$_[1]} } 603sub CLEAR { %{$_[0]} = () } 604$h{b}=1; 605delete $h{b}; 606print scalar keys %h, "\n"; 607tie %h, 'main'; 608$i{a}=1; 609%h = %i; 610untie %h; 611print scalar keys %h, "\n"; 612EXPECT 6130 6140 615######## 616# Bug 37731 617sub foo::TIESCALAR { bless {value => $_[1]}, $_[0] } 618sub foo::FETCH { $_[0]->{value} } 619tie my $VAR, 'foo', '42'; 620foreach my $var ($VAR) { 621 print +($var eq $VAR) ? "yes\n" : "no\n"; 622} 623EXPECT 624yes 625######## 626sub TIEARRAY { bless [], 'main' } 627{ 628 local @a; 629 tie @a, 'main'; 630} 631print "tied\n" if tied @a; 632EXPECT 633######## 634sub TIEHASH { bless [], 'main' } 635{ 636 local %h; 637 tie %h, 'main'; 638} 639print "tied\n" if tied %h; 640EXPECT 641######## 642# RT 20727: PL_defoutgv is left as a tied element 643sub TIESCALAR { return bless {}, 'main' } 644 645sub STORE { 646 select($_[1]); 647 $_[1] = 1; 648 select(); # this used to coredump or assert fail 649} 650tie $SELECT, 'main'; 651$SELECT = *STDERR; 652EXPECT 653######## 654# RT 23810: eval in die in FETCH can corrupt context stack 655 656my $file = 'rt23810.pm'; 657 658my $e; 659my $s; 660 661sub do_require { 662 my ($str, $eval) = @_; 663 open my $fh, '>', $file or die "Can't create $file: $!\n"; 664 print $fh $str; 665 close $fh; 666 if ($eval) { 667 $s .= '-ERQ'; 668 eval { require $pm; $s .= '-ENDE' } 669 } 670 else { 671 $s .= '-RQ'; 672 require $pm; 673 } 674 $s .= '-ENDRQ'; 675 unlink $file; 676} 677 678sub TIEHASH { bless {} } 679 680sub FETCH { 681 # 10 or more syntax errors makes yyparse croak() 682 my $bad = q{$x+;$x+;$x+;$x+;$x+;$x+;$x+;$x+;$x+$x+;$x+;$x+;$x+;$x+;;$x+;}; 683 684 if ($_[1] eq 'eval') { 685 $s .= 'EVAL'; 686 eval q[BEGIN { die; $s .= '-X1' }]; 687 $s .= '-BD'; 688 eval q[BEGIN { $x+ }]; 689 $s .= '-BS'; 690 eval '$x+'; 691 $s .= '-E1'; 692 $s .= '-S1' while $@ =~ /syntax error at/g; 693 eval $bad; 694 $s .= '-E2'; 695 $s .= '-S2' while $@ =~ /syntax error at/g; 696 } 697 elsif ($_[1] eq 'require') { 698 $s .= 'REQUIRE'; 699 my @text = ( 700 q[BEGIN { die; $s .= '-X1' }], 701 q[BEGIN { $x+ }], 702 '$x+', 703 $bad 704 ); 705 for my $i (0..$#text) { 706 $s .= "-$i"; 707 do_require($txt[$i], 0) if $e;; 708 do_require($txt[$i], 1); 709 } 710 } 711 elsif ($_[1] eq 'exit') { 712 eval q[exit(0); print "overshot eval\n"]; 713 } 714 else { 715 print "unknown key: '$_[1]'\n"; 716 } 717 return "-R"; 718} 719my %foo; 720tie %foo, "main"; 721 722for my $action(qw(eval require)) { 723 $s = ''; $e = 0; $s .= main->FETCH($action); print "$action: s0=$s\n"; 724 $s = ''; $e = 1; eval { $s .= main->FETCH($action)}; print "$action: s1=$s\n"; 725 $s = ''; $e = 0; $s .= $foo{$action}; print "$action: s2=$s\n"; 726 $s = ''; $e = 1; eval { $s .= $foo{$action}}; print "$action: s3=$s\n"; 727} 7281 while unlink $file; 729 730$foo{'exit'}; 731print "overshot main\n"; # shouldn't reach here 732 733EXPECT 734eval: s0=EVAL-BD-BS-E1-S1-E2-S2-S2-S2-S2-S2-S2-S2-S2-S2-S2-R 735eval: s1=EVAL-BD-BS-E1-S1-E2-S2-S2-S2-S2-S2-S2-S2-S2-S2-S2-R 736eval: s2=EVAL-BD-BS-E1-S1-E2-S2-S2-S2-S2-S2-S2-S2-S2-S2-S2-R 737eval: s3=EVAL-BD-BS-E1-S1-E2-S2-S2-S2-S2-S2-S2-S2-S2-S2-S2-R 738require: s0=REQUIRE-0-ERQ-ENDRQ-1-ERQ-ENDRQ-2-ERQ-ENDRQ-3-ERQ-ENDRQ-R 739require: s1=REQUIRE-0-RQ 740require: s2=REQUIRE-0-ERQ-ENDRQ-1-ERQ-ENDRQ-2-ERQ-ENDRQ-3-ERQ-ENDRQ-R 741require: s3=REQUIRE-0-RQ 742######## 743# RT 8857: STORE incorrectly invoked for local($_) on aliased tied array 744# element 745 746sub TIEARRAY { bless [], $_[0] } 747sub TIEHASH { bless [], $_[0] } 748sub FETCH { $_[0]->[$_[1]] } 749sub STORE { $_[0]->[$_[1]] = $_[2] } 750 751 752sub f { 753 local $_[0]; 754} 755tie @a, 'main'; 756tie %h, 'main'; 757 758foreach ($a[0], $h{a}) { 759 f($_); 760} 761# on failure, chucks up 'premature free' etc messages 762EXPECT 763######## 764# RT 5475: 765# the initial fix for this bug caused tied scalar FETCH to be called 766# multiple times when that scalar was an element in an array. Check it 767# only gets called once now. 768 769sub TIESCALAR { bless [], $_[0] } 770my $c = 0; 771sub FETCH { $c++; 0 } 772sub FETCHSIZE { 1 } 773sub STORE { $c += 100; 0 } 774 775 776my (@a, %h); 777tie $a[0], 'main'; 778tie $h{foo}, 'main'; 779 780my $i = 0; 781my $x = $a[0] + $h{foo} + $a[$i] + (@a)[0]; 782print "x=$x c=$c\n"; 783EXPECT 784x=0 c=4 785######## 786# Bug 68192 - numeric ops not calling mg_get when tied scalar holds a ref 787sub TIESCALAR { bless {}, __PACKAGE__ }; 788sub STORE {}; 789sub FETCH { 790 print "fetching... "; # make sure FETCH is called once per op 791 123456 792}; 793my $foo; 794tie $foo, __PACKAGE__; 795my $a = [1234567]; 796$foo = $a; 797print "+ ", 0 + $foo, "\n"; 798print "** ", $foo**1, "\n"; 799print "* ", $foo*1, "\n"; 800print "/ ", $foo*1, "\n"; 801print "% ", $foo%123457, "\n"; 802print "- ", $foo-0, "\n"; 803print "neg ", - -$foo, "\n"; 804print "int ", int $foo, "\n"; 805print "abs ", abs $foo, "\n"; 806print "== ", 123456 == $foo, "\n"; 807print "< ", 123455 < $foo, "\n"; 808print "> ", 123457 > $foo, "\n"; 809print "<= ", 123456 <= $foo, "\n"; 810print ">= ", 123456 >= $foo, "\n"; 811print "!= ", 0 != $foo, "\n"; 812print "<=> ", 123457 <=> $foo, "\n"; 813EXPECT 814fetching... + 123456 815fetching... ** 123456 816fetching... * 123456 817fetching... / 123456 818fetching... % 123456 819fetching... - 123456 820fetching... neg 123456 821fetching... int 123456 822fetching... abs 123456 823fetching... == 1 824fetching... < 1 825fetching... > 1 826fetching... <= 1 827fetching... >= 1 828fetching... != 1 829fetching... <=> 1 830######## 831# Ties returning overloaded objects 832{ 833 package overloaded; 834 use overload 835 '*{}' => sub { print '*{}'; \*100 }, 836 '@{}' => sub { print '@{}'; \@100 }, 837 '%{}' => sub { print '%{}'; \%100 }, 838 '${}' => sub { print '${}'; \$100 }, 839 map { 840 my $op = $_; 841 $_ => sub { print "$op"; 100 } 842 } qw< 0+ "" + ** * / % - neg int abs == < > <= >= != <=> <> > 843} 844$o = bless [], overloaded; 845 846sub TIESCALAR { bless {}, "" } 847sub FETCH { print "fetching... "; $o } 848sub STORE{} 849tie $ghew, ""; 850 851$ghew=undef; 1+$ghew; print "\n"; 852$ghew=undef; $ghew**1; print "\n"; 853$ghew=undef; $ghew*1; print "\n"; 854$ghew=undef; $ghew/1; print "\n"; 855$ghew=undef; $ghew%1; print "\n"; 856$ghew=undef; $ghew-1; print "\n"; 857$ghew=undef; -$ghew; print "\n"; 858$ghew=undef; int $ghew; print "\n"; 859$ghew=undef; abs $ghew; print "\n"; 860$ghew=undef; 1 == $ghew; print "\n"; 861$ghew=undef; $ghew<1; print "\n"; 862$ghew=undef; $ghew>1; print "\n"; 863$ghew=undef; $ghew<=1; print "\n"; 864$ghew=undef; $ghew >=1; print "\n"; 865$ghew=undef; $ghew != 1; print "\n"; 866$ghew=undef; $ghew<=>1; print "\n"; 867$ghew=undef; <$ghew>; print "\n"; 868$ghew=\*shrext; *$ghew; print "\n"; 869$ghew=\@spled; @$ghew; print "\n"; 870$ghew=\%frit; %$ghew; print "\n"; 871$ghew=\$drile; $$ghew; print "\n"; 872EXPECT 873fetching... + 874fetching... ** 875fetching... * 876fetching... / 877fetching... % 878fetching... - 879fetching... neg 880fetching... int 881fetching... abs 882fetching... == 883fetching... < 884fetching... > 885fetching... <= 886fetching... >= 887fetching... != 888fetching... <=> 889fetching... <> 890fetching... *{} 891fetching... @{} 892fetching... %{} 893fetching... ${} 894######## 895# RT 51636: segmentation fault with array ties 896 897tie my @a, 'T'; 898@a = (1); 899print "ok\n"; # if we got here we didn't crash 900 901package T; 902 903sub TIEARRAY { bless {} } 904sub STORE { tie my @b, 'T' } 905sub CLEAR { } 906sub EXTEND { } 907 908EXPECT 909ok 910######## 911# RT 8438: Tied scalars don't call FETCH when subref is dereferenced 912 913sub TIESCALAR { bless {} } 914 915my $fetch = 0; 916my $called = 0; 917sub FETCH { $fetch++; sub { $called++ } } 918 919tie my $f, 'main'; 920$f->(1) for 1,2; 921print "fetch=$fetch\ncalled=$called\n"; 922 923EXPECT 924fetch=2 925called=2 926######## 927# tie mustn't attempt to call methods on bareword filehandles. 928sub IO::File::TIEARRAY { 929 die "Did not want to invoke IO::File::TIEARRAY"; 930} 931fileno FOO; tie @a, "FOO" 932EXPECT 933Can't locate object method "TIEARRAY" via package "FOO" (perhaps you forgot to load "FOO"?) at - line 5. 934######## 935# tie into empty package name 936tie $foo, ""; 937EXPECT 938Can't locate object method "TIESCALAR" via package "main" at - line 2. 939######## 940# tie into undef package name 941tie $foo, undef; 942EXPECT 943Can't locate object method "TIESCALAR" via package "main" at - line 2. 944######## 945# tie into nonexistent glob [RT#130623 assertion failure] 946tie $foo, *FOO; 947EXPECT 948Can't locate object method "TIESCALAR" via package "FOO" at - line 2. 949######## 950# tie into glob when package exists but not method: no "*", no "main::" 951{ package PackageWithoutTIESCALAR } 952tie $foo, *PackageWithoutTIESCALAR; 953EXPECT 954Can't locate object method "TIESCALAR" via package "PackageWithoutTIESCALAR" at - line 3. 955######## 956# tie into reference [RT#130623 assertion failure] 957eval { tie $foo, \"nope" }; 958my $exn = $@ // ""; 959print $exn =~ s/0x\w+/0xNNN/rg; 960EXPECT 961Can't locate object method "TIESCALAR" via package "SCALAR(0xNNN)" at - line 2. 962######## 963# 964# STORE freeing tie'd AV 965sub TIEARRAY { bless [] } 966sub STORE { *a = []; 1 } 967sub STORESIZE { } 968sub EXTEND { } 969tie @a, 'main'; 970$a[0] = 1; 971EXPECT 972######## 973# 974# CLEAR freeing tie'd AV 975sub TIEARRAY { bless [] } 976sub CLEAR { *a = []; 1 } 977sub STORESIZE { } 978sub EXTEND { } 979sub STORE { } 980tie @a, 'main'; 981@a = (1,2,3); 982EXPECT 983######## 984# 985# FETCHSIZE freeing tie'd AV 986sub TIEARRAY { bless [] } 987sub FETCHSIZE { *a = []; 100 } 988sub STORESIZE { } 989sub EXTEND { } 990sub STORE { } 991tie @a, 'main'; 992print $#a,"\n" 993EXPECT 99499 995######## 996# 997# [perl #86328] Crash when freeing tie magic that can increment the refcnt 998 999eval { require Scalar::Util } or print("ok\n"), exit; 1000 1001sub TIEHASH { 1002 return $_[1]; 1003} 1004*TIEARRAY = *TIEHASH; 1005 1006sub DESTROY { 1007 my ($tied) = @_; 1008 my $b = $tied->[0]; 1009} 1010 1011my $a = {}; 1012my $o = bless []; 1013Scalar::Util::weaken($o->[0] = $a); 1014tie %$a, "main", $o; 1015 1016my $b = []; 1017my $p = bless []; 1018Scalar::Util::weaken($p->[0] = $b); 1019tie @$b, "main", $p; 1020 1021# Done setting up the evil data structures 1022 1023$a = undef; 1024$b = undef; 1025print "ok\n"; 1026 1027EXPECT 1028ok 1029######## 1030# 1031# Localising a tied COW scalar should not make it read-only. 1032 1033sub TIESCALAR { bless [] } 1034sub FETCH { __PACKAGE__ } 1035sub STORE {} 1036tie $x, ""; 1037"$x"; 1038{ 1039 local $x; 1040 $x = 3; 1041} 1042print "ok\n"; 1043EXPECT 1044ok 1045######## 1046# 1047# Nor should it be impossible to tie COW scalars that are already PVMGs. 1048 1049sub TIESCALAR { bless [] } 1050$x = *foo; # PVGV 1051undef $x; # downgrade to PVMG 1052$x = __PACKAGE__; # PVMG + COW 1053tie $x, ""; # bang! 1054 1055print STDERR "ok\n"; 1056 1057# However, one should not be able to tie read-only glob copies, which look 1058# a bit like kine internally (FAKE + READONLY). 1059$y = *foo; 1060Internals::SvREADONLY($y,1); 1061tie $y, ""; 1062 1063EXPECT 1064ok 1065Modification of a read-only value attempted at - line 16. 1066######## 1067# 1068# And one should not be able to tie read-only COWs 1069for(__PACKAGE__) { tie $_, "" } 1070sub TIESCALAR {bless []} 1071EXPECT 1072Modification of a read-only value attempted at - line 3. 1073######## 1074 1075# Similarly, read-only regexps cannot be tied. 1076sub TIESCALAR { bless [] } 1077$y = ${qr//}; 1078Internals::SvREADONLY($y,1); 1079tie $y, ""; 1080 1081EXPECT 1082Modification of a read-only value attempted at - line 6. 1083######## 1084 1085# tied() should still work on tied scalars after glob assignment 1086sub TIESCALAR {bless[]} 1087sub FETCH {*foo} 1088sub f::TIEHANDLE{bless[],f} 1089tie *foo, "f"; 1090tie $rin, ""; 1091[$rin]; # call FETCH 1092print ref tied $rin, "\n"; 1093print ref tied *$rin, "\n"; 1094EXPECT 1095main 1096f 1097######## 1098 1099# (un)tie $glob_copy vs (un)tie *$glob_copy 1100sub TIESCALAR { print "TIESCALAR\n"; bless [] } 1101sub TIEHANDLE{ print "TIEHANDLE\n"; bless [] } 1102sub FETCH { print "never called\n" } 1103$f = *foo; 1104tie *$f, ""; 1105tie $f, ""; 1106untie $f; 1107print "ok 1\n" if !tied $f; 1108() = $f; # should not call FETCH 1109untie *$f; 1110print "ok 2\n" if !tied *foo; 1111EXPECT 1112TIEHANDLE 1113TIESCALAR 1114ok 1 1115ok 2 1116######## 1117 1118# RT #8611 mustn't goto outside the magic stack 1119sub TIESCALAR { warn "tiescalar\n"; bless [] } 1120sub FETCH { warn "fetch()\n"; goto FOO; } 1121tie $f, ""; 1122warn "before fetch\n"; 1123my $a = "$f"; 1124warn "before FOO\n"; 1125FOO: 1126warn "after FOO\n"; 1127EXPECT 1128tiescalar 1129before fetch 1130fetch() 1131Can't find label FOO at - line 4. 1132######## 1133 1134# RT #8611 mustn't goto outside the magic stack 1135sub TIEHANDLE { warn "tiehandle\n"; bless [] } 1136sub PRINT { warn "print()\n"; goto FOO; } 1137tie *F, ""; 1138warn "before print\n"; 1139print F "abc"; 1140warn "before FOO\n"; 1141FOO: 1142warn "after FOO\n"; 1143EXPECT 1144tiehandle 1145before print 1146print() 1147Can't find label FOO at - line 4. 1148######## 1149 1150# \&$tied with $tied holding a reference before the fetch (but not after) 1151sub ::72 { 73 }; 1152sub TIESCALAR {bless[]} 1153sub STORE{} 1154sub FETCH { 72 } 1155tie my $x, "main"; 1156$x = \$y; 1157\&$x; 1158print "ok\n"; 1159EXPECT 1160ok 1161######## 1162 1163# \&$tied with $tied holding a PVLV glob before the fetch (but not after) 1164sub ::72 { 73 }; 1165sub TIEARRAY {bless[]} 1166sub STORE{} 1167sub FETCH { 72 } 1168tie my @x, "main"; 1169my $elem = \$x[0]; 1170$$elem = *bar; 1171print &{\&$$elem}, "\n"; 1172EXPECT 117373 1174######## 1175 1176# \&$tied with $tied holding a PVGV glob before the fetch (but not after) 1177local *72 = sub { 73 }; 1178sub TIESCALAR {bless[]} 1179sub STORE{} 1180sub FETCH { 72 } 1181tie my $x, "main"; 1182$x = *bar; 1183print &{\&$x}, "\n"; 1184EXPECT 118573 1186######## 1187 1188# Lexicals should not be visible to magic methods on scope exit 1189BEGIN { unless (defined &DynaLoader::boot_DynaLoader) { 1190 print "HASH\nHASH\nARRAY\nARRAY\n"; exit; 1191}} 1192use Scalar::Util 'weaken'; 1193{ package xoufghd; 1194 sub TIEHASH { Scalar::Util::weaken($_[1]); bless \$_[1], xoufghd:: } 1195 *TIEARRAY = *TIEHASH; 1196 DESTROY { 1197 bless ${$_[0]} || return, 0; 1198} } 1199for my $sub ( 1200 # hashes: ties before backrefs 1201 sub { 1202 my %hash; 1203 $ref = ref \%hash; 1204 tie %hash, xoufghd::, \%hash; 1205 1; 1206 }, 1207 # hashes: backrefs before ties 1208 sub { 1209 my %hash; 1210 $ref = ref \%hash; 1211 weaken(my $x = \%hash); 1212 tie %hash, xoufghd::, \%hash; 1213 1; 1214 }, 1215 # arrays: ties before backrefs 1216 sub { 1217 my @array; 1218 $ref = ref \@array; 1219 tie @array, xoufghd::, \@array; 1220 1; 1221 }, 1222 # arrays: backrefs before ties 1223 sub { 1224 my @array; 1225 $ref = ref \@array; 1226 weaken(my $x = \@array); 1227 tie @array, xoufghd::, \@array; 1228 1; 1229 }, 1230) { 1231 &$sub; 1232 &$sub; 1233 print $ref, "\n"; 1234} 1235EXPECT 1236HASH 1237HASH 1238ARRAY 1239ARRAY 1240######## 1241 1242# Localising a tied variable with a typeglob in it should copy magic 1243sub TIESCALAR{bless[]} 1244sub FETCH{warn "fetching\n"; *foo} 1245sub STORE{} 1246tie $x, ""; 1247local $x; 1248warn "before"; 1249"$x"; 1250warn "after"; 1251EXPECT 1252fetching 1253before at - line 8. 1254fetching 1255after at - line 10. 1256######## 1257 1258# tied returns same value as tie 1259sub TIESCALAR{bless[]} 1260$tyre = \tie $tied, ""; 1261print "ok\n" if \tied $tied == $tyre; 1262EXPECT 1263ok 1264######## 1265 1266# tied arrays should always be AvREAL 1267$^W=1; 1268sub TIEARRAY{bless[]} 1269sub { 1270 tie @_, ""; 1271 \@_; # used to produce: av_reify called on tied array at - line 7. 1272}->(1); 1273EXPECT 1274######## 1275 1276# [perl #67490] scalar-tying elements of magic hashes 1277sub TIESCALAR{bless[]} 1278sub STORE{} 1279tie $ENV{foo}, ''; 1280$ENV{foo} = 78; 1281delete $ENV{foo}; 1282tie $^H{foo}, ''; 1283$^H{foo} = 78; 1284delete $^H{foo}; 1285EXPECT 1286######## 1287 1288# [perl #35865, #43011] autovivification should call FETCH after STORE 1289# because perl does not know that the FETCH would have returned the same 1290# thing that was just stored. 1291 1292# This package never likes to take ownership of other people’s refs. It 1293# always makes its own copies. (For simplicity, it only accepts hashes.) 1294package copier { 1295 sub TIEHASH { bless {} } 1296 sub FETCH { $_[0]{$_[1]} } 1297 sub STORE { $_[0]{$_[1]} = { %{ $_[2] } } } 1298} 1299tie my %h, copier::; 1300$h{i}{j} = 'k'; 1301print $h{i}{j}, "\n"; 1302EXPECT 1303k 1304######## 1305 1306# [perl #8931] FETCH for tied $" called an odd number of times. 1307use strict; 1308my $i = 0; 1309sub A::TIESCALAR {bless [] => 'A'} 1310sub A::FETCH {print ++ $i, "\n"} 1311my @a = ("", "", ""); 1312 1313tie $" => 'A'; 1314"@a"; 1315 1316$i = 0; 1317tie my $a => 'A'; 1318join $a, 1..10; 1319EXPECT 13201 13211 1322######## 1323 1324# [perl #9391] return value from 'tied' not discarded soon enough 1325use warnings; 1326tie @a, 'T'; 1327if (tied @a) { 1328untie @a; 1329} 1330 1331sub T::TIEARRAY { my $s; bless \$s => "T" } 1332EXPECT 1333######## 1334 1335# NAME Test that tying a hash does not leak a deleted iterator 1336# This produced unbalanced string table warnings under 1337# PERL_DESTRUCT_LEVEL=2. 1338package l { 1339 sub TIEHASH{bless[]} 1340} 1341$h = {foo=>0}; 1342each %$h; 1343delete $$h{foo}; 1344tie %$h, 'l'; 1345EXPECT 1346######## 1347 1348# NAME EXISTS on arrays 1349sub TIEARRAY{bless[]}; 1350sub FETCHSIZE { 50 } 1351sub EXISTS { print "does $_[1] exist?\n" } 1352tie @a, ""; 1353exists $a[1]; 1354exists $a[-1]; 1355$NEGATIVE_INDICES=1; 1356exists $a[-1]; 1357EXPECT 1358does 1 exist? 1359does 49 exist? 1360does -1 exist? 1361######## 1362 1363# Crash when using negative index on array tied to non-object 1364sub TIEARRAY{bless[]}; 1365${\tie @a, ""} = undef; 1366eval { $_ = $a[-1] }; print $@; 1367eval { $a[-1] = '' }; print $@; 1368eval { delete $a[-1] }; print $@; 1369eval { exists $a[-1] }; print $@; 1370 1371EXPECT 1372Can't call method "FETCHSIZE" on an undefined value at - line 5. 1373Can't call method "FETCHSIZE" on an undefined value at - line 6. 1374Can't call method "FETCHSIZE" on an undefined value at - line 7. 1375Can't call method "FETCHSIZE" on an undefined value at - line 8. 1376######## 1377 1378# Crash when reading negative index when NEGATIVE_INDICES stub exists 1379sub NEGATIVE_INDICES; 1380sub TIEARRAY{bless[]}; 1381sub FETCHSIZE{} 1382tie @a, ""; 1383print "ok\n" if ! defined $a[-1]; 1384EXPECT 1385ok 1386######## 1387 1388# Assigning vstrings to tied scalars 1389sub TIESCALAR{bless[]}; 1390sub STORE { print ref \$_[1], "\n" } 1391tie $x, ""; $x = v3; 1392EXPECT 1393VSTRING 1394######## 1395 1396# [perl #27010] Tying deferred elements 1397$\="\n"; 1398sub TIESCALAR{bless[]}; 1399sub { 1400 tie $_[0], ""; 1401 print ref tied $h{k}; 1402 tie $h{l}, ""; 1403 print ref tied $_[1]; 1404 untie $h{k}; 1405 print tied $_[0] // 'undef'; 1406 untie $_[1]; 1407 print tied $h{l} // 'undef'; 1408 # check that tied and untie do not autovivify 1409 # XXX should they autovivify? 1410 tied $_[2]; 1411 print exists $h{m} ? "yes" : "no"; 1412 untie $_[2]; 1413 print exists $h{m} ? "yes" : "no"; 1414}->($h{k}, $h{l}, $h{m}); 1415EXPECT 1416main 1417main 1418undef 1419undef 1420no 1421no 1422######## 1423 1424# [perl #78194] Passing op return values to tie constructors 1425sub TIEARRAY{ 1426 print \$_[1] == \$_[1] ? "ok\n" : "not ok\n"; 1427}; 1428tie @a, "", "$a$b"; 1429EXPECT 1430ok 1431######## 1432 1433# Scalar-tied locked hash keys and copy-on-write 1434use Tie::Scalar; 1435tie $h{foo}, Tie::StdScalar; 1436tie $h{bar}, Tie::StdScalar; 1437$h{foo} = __PACKAGE__; # COW 1438$h{bar} = 1; # not COW 1439# Moral equivalent of Hash::Util::lock_whatever, but miniperl-compatible 1440Internals::SvREADONLY($h{foo},1); 1441Internals::SvREADONLY($h{bar},1); 1442print $h{foo}, "\n"; # should not croak 1443# Whether the value is COW should make no difference here (whether the 1444# behaviour is ultimately correct is another matter): 1445local $h{foo}; 1446local $h{bar}; 1447print "ok\n" if (eval{ $h{foo} = 1 }||$@) eq (eval{ $h{bar} = 1 }||$@); 1448EXPECT 1449main 1450ok 1451######## 1452# SKIP ? $::IS_EBCDIC 1453# skipped on EBCDIC because different from ASCII and results vary depending on 1454# code page 1455 1456# &xsub and goto &xsub with tied @_ 1457use Tie::Array; 1458tie @_, Tie::StdArray; 1459@_ = "\xff"; 1460&utf8::encode; 1461printf "%x\n", $_ for map ord, split //, $_[0]; 1462print "--\n"; 1463@_ = "\xff"; 1464& {sub { goto &utf8::encode }}; 1465printf "%x\n", $_ for map ord, split //, $_[0]; 1466EXPECT 1467c3 1468bf 1469-- 1470c3 1471bf 1472######## 1473 1474# Defelem pointing to nonexistent element of tied array 1475 1476use Tie::Array; 1477# This sub is called with a deferred element. Inside the sub, $_[0] pros- 1478# pectively points to element 10000 of @a. 1479sub { 1480 tie @a, "Tie::StdArray"; # now @a is tied 1481 $#a = 20000; # and FETCHSIZE/AvFILL will now return a big number 1482 $a[10000] = "crumpets\n"; 1483 $_ = "$_[0]"; # but defelems don't expect tied arrays and try to read 1484 # AvARRAY[10000], which crashes 1485}->($a[10000]); 1486print 1487EXPECT 1488crumpets 1489######## 1490 1491# tied() in list assignment 1492 1493sub TIESCALAR : lvalue { 1494 ${+pop} = bless [], shift; 1495} 1496tie $t, "", \$a; 1497$a = 7; 1498($a, $b) = (3, tied $t); 1499print "a is $a\n"; 1500print "b is $b\n"; 1501EXPECT 1502a is 3 1503b is 7 1504######## 1505# when assigning to array/hash, ensure get magic is processed first 1506use Tie::Hash; 1507my %tied; 1508tie %tied, "Tie::StdHash"; 1509%tied = qw(a foo); 1510my @a = values %tied; 1511%tied = qw(b bar); # overwrites @a's contents unless magic was called 1512print "$a[0]\n"; 1513my %h = ("x", values %tied); 1514%tied = qw(c baz); # overwrites @a's contents unless magic was called 1515print "$h{x}\n"; 1516 1517EXPECT 1518foo 1519bar 1520######## 1521# keys(%tied) in bool context without SCALAR present 1522my ($f,$n) = (0,0); 1523my %inner = (a =>1, b => 2, c => 3); 1524sub TIEHASH { bless \%inner, $_[0] } 1525sub FIRSTKEY { $f++; my $a = scalar keys %{$_[0]}; each %{$_[0]} } 1526sub NEXTKEY { $n++; each %{$_[0]} } 1527tie %h, 'main'; 1528my $x = !keys %h; 1529print "[$x][$f][$n]\n"; 1530%inner = (); 1531$x = !keys %h; 1532print "[$x][$f][$n]\n"; 1533EXPECT 1534[][1][0] 1535[1][2][0] 1536######## 1537# keys(%tied) in bool context with SCALAR present 1538my ($f,$n, $s) = (0,0,0); 1539my %inner = (a =>1, b => 2, c => 3); 1540sub TIEHASH { bless \%inner, $_[0] } 1541sub FIRSTKEY { $f++; my $a = scalar keys %{$_[0]}; each %{$_[0]} } 1542sub NEXTKEY { $n++; each %{$_[0]} } 1543sub SCALAR { $s++; scalar %{$_[0]} } 1544tie %h, 'main'; 1545my $x = !keys %h; 1546print "[$x][$f][$n][$s]\n"; 1547%inner = (); 1548$x = !keys %h; 1549print "[$x][$f][$n][$s]\n"; 1550EXPECT 1551[][0][0][1] 1552[1][0][0][2] 1553######## 1554# keys(%tied) in scalar context without SCALAR present 1555my ($f,$n) = (0,0); 1556my %inner = (a =>1, b => 2, c => 3); 1557sub TIEHASH { bless \%inner, $_[0] } 1558sub FIRSTKEY { $f++; my $a = scalar keys %{$_[0]}; each %{$_[0]} } 1559sub NEXTKEY { $n++; each %{$_[0]} } 1560tie %h, 'main'; 1561my $x = keys %h; 1562print "[$x][$f][$n]\n"; 1563%inner = (); 1564$x = keys %h; 1565print "[$x][$f][$n]\n"; 1566EXPECT 1567[3][1][3] 1568[0][2][3] 1569######## 1570# keys(%tied) in scalar context with SCALAR present 1571# XXX the behaviour of scalar(keys(%tied)) may change - it currently 1572# doesn't make use of SCALAR() if present 1573my ($f,$n, $s) = (0,0,0); 1574my %inner = (a =>1, b => 2, c => 3); 1575sub TIEHASH { bless \%inner, $_[0] } 1576sub FIRSTKEY { $f++; my $a = scalar keys %{$_[0]}; each %{$_[0]} } 1577sub NEXTKEY { $n++; each %{$_[0]} } 1578sub SCALAR { $s++; scalar %{$_[0]} } 1579tie %h, 'main'; 1580my $x = keys %h; 1581print "[$x][$f][$n][$s]\n"; 1582%inner = (); 1583$x = keys %h; 1584print "[$x][$f][$n][$s]\n"; 1585EXPECT 1586[3][1][3][0] 1587[0][2][3][0] 1588######## 1589# dying while doing a SAVEt_DELETE dureing scope exit leaked a copy of the 1590# key. Give ASan something to play with 1591sub TIEHASH { bless({}, $_[0]) } 1592sub EXISTS { 0 } 1593sub DELETE { die; } 1594sub DESTROY { print "destroy\n"; } 1595 1596eval { 1597 my %h; 1598 tie %h, "main"; 1599 local $h{foo}; 1600 print "leaving\n"; 1601}; 1602print "left\n"; 1603EXPECT 1604leaving 1605destroy 1606left 1607######## 1608# ditto for SAVEt_DELETE with an array 1609sub TIEARRAY { bless({}, $_[0]) } 1610sub EXISTS { 0 } 1611sub DELETE { die; } 1612sub DESTROY { print "destroy\n"; } 1613 1614eval { 1615 my @a; 1616 tie @a, "main"; 1617 delete local $a[0]; 1618 print "leaving\n"; 1619}; 1620print "left\n"; 1621EXPECT 1622leaving 1623destroy 1624left 1625