t/op/tie.t

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