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 @INC = '../lib';
  14 require './test.pl';
  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
  31 # standard behaviour, without any extra references
  32 use Tie::Hash ;
  33 {package Tie::HashUntie;
  34  use base 'Tie::StdHash';
  35  sub UNTIE
  36   {
  37    warn "Untied\n";
  38   }
  39 }
  40 tie %h, Tie::HashUntie;
  41 untie %h;
  42 EXPECT
  43 Untied
  44 ########
  45
  46 # standard behaviour, with 1 extra reference
  47 use Tie::Hash ;
  48 $a = tie %h, Tie::StdHash;
  49 untie %h;
  50 EXPECT
  51 ########
  52
  53 # standard behaviour, with 1 extra reference via tied
  54 use Tie::Hash ;
  55 tie %h, Tie::StdHash;
  56 $a = tied %h;
  57 untie %h;
  58 EXPECT
  59 ########
  60
  61 # standard behaviour, with 1 extra reference which is destroyed
  62 use Tie::Hash ;
  63 $a = tie %h, Tie::StdHash;
  64 $a = 0 ;
  65 untie %h;
  66 EXPECT
  67 ########
  68
  69 # standard behaviour, with 1 extra reference via tied which is destroyed
  70 use Tie::Hash ;
  71 tie %h, Tie::StdHash;
  72 $a = tied %h;
  73 $a = 0 ;
  74 untie %h;
  75 EXPECT
  76 ########
  77
  78 # strict behaviour, without any extra references
  79 use warnings 'untie';
  80 use Tie::Hash ;
  81 tie %h, Tie::StdHash;
  82 untie %h;
  83 EXPECT
  84 ########
  85
  86 # strict behaviour, with 1 extra references generating an error
  87 use warnings 'untie';
  88 use Tie::Hash ;
  89 $a = tie %h, Tie::StdHash;
  90 untie %h;
  91 EXPECT
  92 untie attempted while 1 inner references still exist at - line 6.
  93 ########
  94
  95 # strict behaviour, with 1 extra references via tied generating an error
  96 use warnings 'untie';
  97 use Tie::Hash ;
  98 tie %h, Tie::StdHash;
  99 $a = tied %h;
 100 untie %h;
 101 EXPECT
 102 untie attempted while 1 inner references still exist at - line 7.
 103 ########
 104
 105 # strict behaviour, with 1 extra references which are destroyed
 106 use warnings 'untie';
 107 use Tie::Hash ;
 108 $a = tie %h, Tie::StdHash;
 109 $a = 0 ;
 110 untie %h;
 111 EXPECT
 112 ########
 113
 114 # strict behaviour, with extra 1 references via tied which are destroyed
 115 use warnings 'untie';
 116 use Tie::Hash ;
 117 tie %h, Tie::StdHash;
 118 $a = tied %h;
 119 $a = 0 ;
 120 untie %h;
 121 EXPECT
 122 ########
 123
 124 # strict error behaviour, with 2 extra references
 125 use warnings 'untie';
 126 use Tie::Hash ;
 127 $a = tie %h, Tie::StdHash;
 128 $b = tied %h ;
 129 untie %h;
 130 EXPECT
 131 untie attempted while 2 inner references still exist at - line 7.
 132 ########
 133
 134 # strict behaviour, check scope of strictness.
 135 no warnings 'untie';
 136 use Tie::Hash ;
 137 $A = tie %H, Tie::StdHash;
 138 $C = $B = tied %H ;
 139 {
 140     use warnings 'untie';
 141     use Tie::Hash ;
 142     tie %h, Tie::StdHash;
 143     untie %h;
 144 }
 145 untie %H;
 146 EXPECT
 147 ########
 148
 149 # Forbidden aggregate self-ties
 150 sub Self::TIEHASH { bless $_[1], $_[0] }
 151 {
 152     my %c;
 153     tie %c, 'Self', \%c;
 154 }
 155 EXPECT
 156 Self-ties of arrays and hashes are not supported at - line 6.
 157 ########
 158
 159 # Allowed scalar self-ties
 160 my $destroyed = 0;
 161 sub Self::TIESCALAR { bless $_[1], $_[0] }
 162 sub Self::DESTROY   { $destroyed = 1; }
 163 {
 164     my $c = 42;
 165     tie $c, 'Self', \$c;
 166 }
 167 die "self-tied scalar not DESTROYed" unless $destroyed == 1;
 168 EXPECT
 169 ########
 170
 171 # Allowed glob self-ties
 172 my $destroyed = 0;
 173 my $printed   = 0;
 174 sub Self2::TIEHANDLE { bless $_[1], $_[0] }
 175 sub Self2::DESTROY   { $destroyed = 1; }
 176 sub Self2::PRINT     { $printed = 1; }
 177 {
 178     use Symbol;
 179     my $c = gensym;
 180     tie *$c, 'Self2', $c;
 181     print $c 'Hello';
 182 }
 183 die "self-tied glob not PRINTed" unless $printed == 1;
 184 die "self-tied glob not DESTROYed" unless $destroyed == 1;
 185 EXPECT
 186 ########
 187
 188 # Allowed IO self-ties
 189 my $destroyed = 0;
 190 sub Self3::TIEHANDLE { bless $_[1], $_[0] }
 191 sub Self3::DESTROY   { $destroyed = 1; }
 192 sub Self3::PRINT     { $printed = 1; }
 193 {
 194     use Symbol 'geniosym';
 195     my $c = geniosym;
 196     tie *$c, 'Self3', $c;
 197     print $c 'Hello';
 198 }
 199 die "self-tied IO not PRINTed" unless $printed == 1;
 200 die "self-tied IO not DESTROYed" unless $destroyed == 1;
 201 EXPECT
 202 ########
 203
 204 # TODO IO "self-tie" via TEMP glob
 205 my $destroyed = 0;
 206 sub Self3::TIEHANDLE { bless $_[1], $_[0] }
 207 sub Self3::DESTROY   { $destroyed = 1; }
 208 sub Self3::PRINT     { $printed = 1; }
 209 {
 210     use Symbol 'geniosym';
 211     my $c = geniosym;
 212     tie *$c, 'Self3', \*$c;
 213     print $c 'Hello';
 214 }
 215 die "IO tied to TEMP glob not PRINTed" unless $printed == 1;
 216 die "IO tied to TEMP glob not DESTROYed" unless $destroyed == 1;
 217 EXPECT
 218 ########
 219
 220 # Interaction of tie and vec
 221
 222 my ($a, $b);
 223 use Tie::Scalar;
 224 tie $a,Tie::StdScalar or die;
 225 vec($b,1,1)=1;
 226 $a = $b;
 227 vec($a,1,1)=0;
 228 vec($b,1,1)=0;
 229 die unless $a eq $b;
 230 EXPECT
 231 ########
 232
 233 # correct unlocalisation of tied hashes (patch #16431)
 234 use Tie::Hash ;
 235 tie %tied, Tie::StdHash;
 236 { local $hash{'foo'} } warn "plain hash bad unlocalize" if exists $hash{'foo'};
 237 { local $tied{'foo'} } warn "tied hash bad unlocalize" if exists $tied{'foo'};
 238 { local $ENV{'foo'}  } warn "%ENV bad unlocalize" if exists $ENV{'foo'};
 239 EXPECT
 240 ########
 241
 242 # An attempt at lvalueable barewords broke this
 243 tie FH, 'main';
 244 EXPECT
 245 Can't modify constant item in tie at - line 3, near "'main';"
 246 Execution of - aborted due to compilation errors.
 247 ########
 248
 249 # localizing tied hash slices
 250 $ENV{FooA} = 1;
 251 $ENV{FooB} = 2;
 252 print exists $ENV{FooA} ? 1 : 0, "\n";
 253 print exists $ENV{FooB} ? 2 : 0, "\n";
 254 print exists $ENV{FooC} ? 3 : 0, "\n";
 255 {
 256     local @ENV{qw(FooA FooC)};
 257     print exists $ENV{FooA} ? 4 : 0, "\n";
 258     print exists $ENV{FooB} ? 5 : 0, "\n";
 259     print exists $ENV{FooC} ? 6 : 0, "\n";
 260 }
 261 print exists $ENV{FooA} ? 7 : 0, "\n";
 262 print exists $ENV{FooB} ? 8 : 0, "\n";
 263 print exists $ENV{FooC} ? 9 : 0, "\n"; # this should not exist
 264 EXPECT
 265 1
 266 2
 267 0
 268 4
 269 5
 270 6
 271 7
 272 8
 273 0
 274 ########
 275 #
 276 # FETCH freeing tie'd SV
 277 sub TIESCALAR { bless [] }
 278 sub FETCH { *a = \1; 1 }
 279 tie $a, 'main';
 280 print $a;
 281 EXPECT
 282 ########
 283
 284 #  [20020716.007] - nested FETCHES
 285
 286 sub F1::TIEARRAY { bless [], 'F1' }
 287 sub F1::FETCH { 1 }
 288 my @f1;
 289 tie @f1, 'F1';
 290
 291 sub F2::TIEARRAY { bless [2], 'F2' }
 292 sub F2::FETCH { my $self = shift; my $x = $f1[3]; $self }
 293 my @f2;
 294 tie @f2, 'F2';
 295
 296 print $f2[4][0],"\n";
 297
 298 sub F3::TIEHASH { bless [], 'F3' }
 299 sub F3::FETCH { 1 }
 300 my %f3;
 301 tie %f3, 'F3';
 302
 303 sub F4::TIEHASH { bless [3], 'F4' }
 304 sub F4::FETCH { my $self = shift; my $x = $f3{3}; $self }
 305 my %f4;
 306 tie %f4, 'F4';
 307
 308 print $f4{'foo'}[0],"\n";
 309
 310 EXPECT
 311 2
 312 3
 313 ########
 314 # test untie() from within FETCH
 315 package Foo;
 316 sub TIESCALAR { my $pkg = shift; return bless [@_], $pkg; }
 317 sub FETCH {
 318   my $self = shift;
 319   my ($obj, $field) = @$self;
 320   untie $obj->{$field};
 321   $obj->{$field} = "Bar";
 322 }
 323 package main;
 324 tie $a->{foo}, "Foo", $a, "foo";
 325 my $s = $a->{foo}; # access once
 326 # the hash element should not be tied anymore
 327 print defined tied $a->{foo} ? "not ok" : "ok";
 328 EXPECT
 329 ok
 330 ########
 331 # the tmps returned by FETCH should appear to be SCALAR
 332 # (even though they are now implemented using PVLVs.)
 333 package X;
 334 sub TIEHASH { bless {} }
 335 sub TIEARRAY { bless {} }
 336 sub FETCH {1}
 337 my (%h, @a);
 338 tie %h, 'X';
 339 tie @a, 'X';
 340 my $r1 = \$h{1};
 341 my $r2 = \$a[0];
 342 my $s = "$r1 ". ref($r1) . " $r2 " . ref($r2);
 343 $s=~ s/\(0x\w+\)//g;
 344 print $s, "\n";
 345 EXPECT
 346 SCALAR SCALAR SCALAR SCALAR
 347 ########
 348 # [perl #23287] segfault in untie
 349 sub TIESCALAR { bless $_[1], $_[0] }
 350 my $var;
 351 tie $var, 'main', \$var;
 352 untie $var;
 353 EXPECT
 354 ########
 355 # Test case from perlmonks by runrig
 356 # http://www.perlmonks.org/index.pl?node_id=273490
 357 # "Here is what I tried. I think its similar to what you've tried
 358 #  above. Its odd but convenient that after untie'ing you are left with
 359 #  a variable that has the same value as was last returned from
 360 #  FETCH. (At least on my perl v5.6.1). So you don't need to pass a
 361 #  reference to the variable in order to set it after the untie (here it
 362 #  is accessed through a closure)."
 363 use strict;
 364 use warnings;
 365 package MyTied;
 366 sub TIESCALAR {
 367     my ($class,$code) = @_;
 368     bless $code, $class;
 369 }
 370 sub FETCH {
 371     my $self = shift;
 372     print "Untie\n";
 373     $self->();
 374 }
 375 package main;
 376 my $var;
 377 tie $var, 'MyTied', sub { untie $var; 4 };
 378 print "One\n";
 379 print "$var\n";
 380 print "Two\n";
 381 print "$var\n";
 382 print "Three\n";
 383 print "$var\n";
 384 EXPECT
 385 One
 386 Untie
 387 4
 388 Two
 389 4
 390 Three
 391 4
 392 ########
 393 # [perl #22297] cannot untie scalar from within tied FETCH
 394 my $counter = 0;
 395 my $x = 7;
 396 my $ref = \$x;
 397 tie $x, 'Overlay', $ref, $x;
 398 my $y;
 399 $y = $x;
 400 $y = $x;
 401 $y = $x;
 402 $y = $x;
 403 #print "WILL EXTERNAL UNTIE $ref\n";
 404 untie $$ref;
 405 $y = $x;
 406 $y = $x;
 407 $y = $x;
 408 $y = $x;
 409 #print "counter = $counter\n";
 410
 411 print (($counter == 1) ? "ok\n" : "not ok\n");
 412
 413 package Overlay;
 414
 415 sub TIESCALAR
 416 {
 417         my $pkg = shift;
 418         my ($ref, $val) = @_;
 419         return bless [ $ref, $val ], $pkg;
 420 }
 421
 422 sub FETCH
 423 {
 424         my $self = shift;
 425         my ($ref, $val) = @$self;
 426         #print "WILL INTERNAL UNITE $ref\n";
 427         $counter++;
 428         untie $$ref;
 429         return $val;
 430 }
 431 EXPECT
 432 ok
 433 ########
 434
 435 # [perl #948] cannot meaningfully tie $,
 436 package TieDollarComma;
 437
 438 sub TIESCALAR {
 439      my $pkg = shift;
 440      return bless \my $x, $pkg;
 441 }
 442
 443 sub STORE {
 444     my $self = shift;
 445     $$self = shift;
 446     print "STORE set '$$self'\n";
 447 }
 448
 449 sub FETCH {
 450     my $self = shift;
 451     print "<FETCH>";
 452     return $$self;
 453 }
 454 package main;
 455
 456 tie $,, 'TieDollarComma';
 457 $, = 'BOBBINS';
 458 print "join", "things", "up\n";
 459 EXPECT
 460 STORE set 'BOBBINS'
 461 join<FETCH>BOBBINSthings<FETCH>BOBBINSup
 462 ########
 463
 464 # test SCALAR method
 465 package TieScalar;
 466
 467 sub TIEHASH {
 468     my $pkg = shift;
 469     bless { } => $pkg;
 470 }
 471
 472 sub STORE {
 473     $_[0]->{$_[1]} = $_[2];
 474 }
 475
 476 sub FETCH {
 477     $_[0]->{$_[1]}
 478 }
 479
 480 sub CLEAR {
 481     %{ $_[0] } = ();
 482 }
 483
 484 sub SCALAR {
 485     print "SCALAR\n";
 486     return 0 if ! keys %{$_[0]};
 487     sprintf "%i/%i", scalar keys %{$_[0]}, scalar keys %{$_[0]};
 488 }
 489
 490 package main;
 491 tie my %h => "TieScalar";
 492 $h{key1} = "val1";
 493 $h{key2} = "val2";
 494 print scalar %h, "\n"
 495     if %h; # this should also call SCALAR but implicitly
 496 %h = ();
 497 print scalar %h, "\n"
 498     if !%h; # this should also call SCALAR but implicitly
 499 EXPECT
 500 SCALAR
 501 SCALAR
 502 2/2
 503 SCALAR
 504 SCALAR
 505 0
 506 ########
 507
 508 # test scalar on tied hash when no SCALAR method has been given
 509 package TieScalar;
 510
 511 sub TIEHASH {
 512     my $pkg = shift;
 513     bless { } => $pkg;
 514 }
 515 sub STORE {
 516     $_[0]->{$_[1]} = $_[2];
 517 }
 518 sub FETCH {
 519     $_[0]->{$_[1]}
 520 }
 521 sub CLEAR {
 522     %{ $_[0] } = ();
 523 }
 524 sub FIRSTKEY {
 525     my $a = keys %{ $_[0] };
 526     print "FIRSTKEY\n";
 527     each %{ $_[0] };
 528 }
 529
 530 package main;
 531 tie my %h => "TieScalar";
 532
 533 if (!%h) {
 534     print "empty\n";
 535 } else {
 536     print "not empty\n";
 537 }
 538
 539 $h{key1} = "val1";
 540 print "not empty\n" if %h;
 541 print "not empty\n" if %h;
 542 print "-->\n";
 543 my ($k,$v) = each %h;
 544 print "<--\n";
 545 print "not empty\n" if %h;
 546 %h = ();
 547 print "empty\n" if ! %h;
 548 EXPECT
 549 FIRSTKEY
 550 empty
 551 FIRSTKEY
 552 not empty
 553 FIRSTKEY
 554 not empty
 555 -->
 556 FIRSTKEY
 557 <--
 558 not empty
 559 FIRSTKEY
 560 empty
 561 ########
 562 sub TIESCALAR { bless {} }
 563 sub FETCH { my $x = 3.3; 1 if 0+$x; $x }
 564 tie $h, "main";
 565 print $h,"\n";
 566 EXPECT
 567 3.3
 568 ########
 569 sub TIESCALAR { bless {} }
 570 sub FETCH { shift()->{i} ++ }
 571 tie $h, "main";
 572 print $h.$h;
 573 EXPECT
 574 01
 575 ########
 576 # Bug 53482 (and maybe others)
 577 sub TIESCALAR { my $foo = $_[1]; bless \$foo, $_[0] }
 578 sub FETCH { ${$_[0]} }
 579 tie my $x1, "main", 2;
 580 tie my $y1, "main", 8;
 581 print $x1 | $y1;
 582 print $x1 | $y1;
 583 tie my $x2, "main", "2";
 584 tie my $y2, "main", "8";
 585 print $x2 | $y2;
 586 print $x2 | $y2;
 587 EXPECT
 588 1010::
 589 ########
 590 # Bug 36267
 591 sub TIEHASH  { bless {}, $_[0] }
 592 sub STORE    { $_[0]->{$_[1]} = $_[2] }
 593 sub FIRSTKEY { my $a = scalar keys %{$_[0]}; each %{$_[0]} }
 594 sub NEXTKEY  { each %{$_[0]} }
 595 sub DELETE   { delete $_[0]->{$_[1]} }
 596 sub CLEAR    { %{$_[0]} = () }
 597 $h{b}=1;
 598 delete $h{b};
 599 print scalar keys %h, "\n";
 600 tie %h, 'main';
 601 $i{a}=1;
 602 %h = %i;
 603 untie %h;
 604 print scalar keys %h, "\n";
 605 EXPECT
 606 0
 607 0
 608 ########
 609 # Bug 37731
 610 sub foo::TIESCALAR { bless {value => $_[1]}, $_[0] }
 611 sub foo::FETCH { $_[0]->{value} }
 612 tie my $VAR, 'foo', '42';
 613 foreach my $var ($VAR) {
 614     print +($var eq $VAR) ? "yes\n" : "no\n";
 615 }
 616 EXPECT
 617 yes
 618 ########
 619 sub TIEARRAY { bless [], 'main' }
 620 {
 621     local @a;
 622     tie @a, 'main';
 623 }
 624 print "tied\n" if tied @a;
 625 EXPECT
 626 ########
 627 sub TIEHASH { bless [], 'main' }
 628 {
 629     local %h;
 630     tie %h, 'main';
 631 }
 632 print "tied\n" if tied %h;
 633 EXPECT
 634 ########
 635 # RT 20727: PL_defoutgv is left as a tied element
 636 sub TIESCALAR { return bless {}, 'main' }
 637
 638 sub STORE {
 639     select($_[1]);
 640     $_[1] = 1;
 641     select(); # this used to coredump or assert fail
 642 }
 643 tie $SELECT, 'main';
 644 $SELECT = *STDERR;
 645 EXPECT
 646 ########
 647 # RT 23810: eval in die in FETCH can corrupt context stack
 648
 649 my $file = 'rt23810.pm';
 650
 651 my $e;
 652 my $s;
 653
 654 sub do_require {
 655     my ($str, $eval) = @_;
 656     open my $fh, '>', $file or die "Can't create $file: $!\n";
 657     print $fh $str;
 658     close $fh;
 659     if ($eval) {
 660         $s .= '-ERQ';
 661         eval { require $pm; $s .= '-ENDE' }
 662     }
 663     else {
 664         $s .= '-RQ';
 665         require $pm;
 666     }
 667     $s .= '-ENDRQ';
 668     unlink $file;
 669 }
 670
 671 sub TIEHASH { bless {} }
 672
 673 sub FETCH {
 674     # 10 or more syntax errors makes yyparse croak()
 675     my $bad = q{$x+;$x+;$x+;$x+;$x+;$x+;$x+;$x+;$x+$x+;$x+;$x+;$x+;$x+;;$x+;};
 676
 677     if ($_[1] eq 'eval') {
 678         $s .= 'EVAL';
 679         eval q[BEGIN { die; $s .= '-X1' }];
 680         $s .= '-BD';
 681         eval q[BEGIN { $x+ }];
 682         $s .= '-BS';
 683         eval '$x+';
 684         $s .= '-E1';
 685         $s .= '-S1' while $@ =~ /syntax error at/g;
 686         eval $bad;
 687         $s .= '-E2';
 688         $s .= '-S2' while $@ =~ /syntax error at/g;
 689     }
 690     elsif ($_[1] eq 'require') {
 691         $s .= 'REQUIRE';
 692         my @text = (
 693             q[BEGIN { die; $s .= '-X1' }],
 694             q[BEGIN { $x+ }],
 695             '$x+',
 696             $bad
 697         );
 698         for my $i (0..$#text) {
 699             $s .= "-$i";
 700             do_require($txt[$i], 0) if $e;;
 701             do_require($txt[$i], 1);
 702         }
 703     }
 704     elsif ($_[1] eq 'exit') {
 705         eval q[exit(0); print "overshot eval\n"];
 706     }
 707     else {
 708         print "unknown key: '$_[1]'\n";
 709     }
 710     return "-R";
 711 }
 712 my %foo;
 713 tie %foo, "main";
 714
 715 for my $action(qw(eval require)) {
 716     $s = ''; $e = 0; $s .= main->FETCH($action); print "$action: s0=$s\n";
 717     $s = ''; $e = 1; eval { $s .= main->FETCH($action)}; print "$action: s1=$s\n";
 718     $s = ''; $e = 0; $s .= $foo{$action}; print "$action: s2=$s\n";
 719     $s = ''; $e = 1; eval { $s .= $foo{$action}}; print "$action: s3=$s\n";
 720 }
 721 1 while unlink $file;
 722
 723 $foo{'exit'};
 724 print "overshot main\n"; # shouldn't reach here
 725
 726 EXPECT
 727 eval: s0=EVAL-BD-BS-E1-S1-E2-S2-S2-S2-S2-S2-S2-S2-S2-S2-S2-R
 728 eval: s1=EVAL-BD-BS-E1-S1-E2-S2-S2-S2-S2-S2-S2-S2-S2-S2-S2-R
 729 eval: s2=EVAL-BD-BS-E1-S1-E2-S2-S2-S2-S2-S2-S2-S2-S2-S2-S2-R
 730 eval: s3=EVAL-BD-BS-E1-S1-E2-S2-S2-S2-S2-S2-S2-S2-S2-S2-S2-R
 731 require: s0=REQUIRE-0-ERQ-ENDRQ-1-ERQ-ENDRQ-2-ERQ-ENDRQ-3-ERQ-ENDRQ-R
 732 require: s1=REQUIRE-0-RQ
 733 require: s2=REQUIRE-0-ERQ-ENDRQ-1-ERQ-ENDRQ-2-ERQ-ENDRQ-3-ERQ-ENDRQ-R
 734 require: s3=REQUIRE-0-RQ
 735 ########
 736 # RT 8857: STORE incorrectly invoked for local($_) on aliased tied array
 737 #          element
 738
 739 sub TIEARRAY { bless [], $_[0] }
 740 sub TIEHASH  { bless [], $_[0] }
 741 sub FETCH { $_[0]->[$_[1]] }
 742 sub STORE { $_[0]->[$_[1]] = $_[2] }
 743
 744
 745 sub f {
 746     local $_[0];
 747 }
 748 tie @a, 'main';
 749 tie %h, 'main';
 750
 751 foreach ($a[0], $h{a}) {
 752     f($_);
 753 }
 754 # on failure, chucks up 'premature free' etc messages
 755 EXPECT
 756 ########
 757 # RT 5475:
 758 # the initial fix for this bug caused tied scalar FETCH to be called
 759 # multiple times when that scalar was an element in an array. Check it
 760 # only gets called once now.
 761
 762 sub TIESCALAR { bless [], $_[0] }
 763 my $c = 0;
 764 sub FETCH { $c++; 0 }
 765 sub FETCHSIZE { 1 }
 766 sub STORE { $c += 100; 0 }
 767
 768
 769 my (@a, %h);
 770 tie $a[0],   'main';
 771 tie $h{foo}, 'main';
 772
 773 my $i = 0;
 774 my $x = $a[0] + $h{foo} + $a[$i] + (@a)[0];
 775 print "x=$x c=$c\n";
 776 EXPECT
 777 x=0 c=4
 778 ########
 779 # Bug 68192 - numeric ops not calling mg_get when tied scalar holds a ref
 780 sub TIESCALAR { bless {}, __PACKAGE__ };
 781 sub STORE {};
 782 sub FETCH {
 783  print "fetching... "; # make sure FETCH is called once per op
 784  123456
 785 };
 786 my $foo;
 787 tie $foo, __PACKAGE__;
 788 my $a = [1234567];
 789 $foo = $a;
 790 print "+   ", 0 + $foo, "\n";
 791 print "**  ", $foo**1, "\n";
 792 print "*   ", $foo*1, "\n";
 793 print "/   ", $foo*1, "\n";
 794 print "%   ", $foo%123457, "\n";
 795 print "-   ", $foo-0, "\n";
 796 print "neg ", - -$foo, "\n";
 797 print "int ", int $foo, "\n";
 798 print "abs ", abs $foo, "\n";
 799 print "==  ", 123456 == $foo, "\n";
 800 print "<   ", 123455 < $foo, "\n";
 801 print ">   ", 123457 > $foo, "\n";
 802 print "<=  ", 123456 <= $foo, "\n";
 803 print ">=  ", 123456 >= $foo, "\n";
 804 print "!=  ", 0 != $foo, "\n";
 805 print "<=> ", 123457 <=> $foo, "\n";
 806 EXPECT
 807 fetching... +   123456
 808 fetching... **  123456
 809 fetching... *   123456
 810 fetching... /   123456
 811 fetching... %   123456
 812 fetching... -   123456
 813 fetching... neg 123456
 814 fetching... int 123456
 815 fetching... abs 123456
 816 fetching... ==  1
 817 fetching... <   1
 818 fetching... >   1
 819 fetching... <=  1
 820 fetching... >=  1
 821 fetching... !=  1
 822 fetching... <=> 1
 823 ########
 824 # Ties returning overloaded objects
 825 {
 826  package overloaded;
 827  use overload
 828   '*{}' => sub { print '*{}'; \*100 },
 829   '@{}' => sub { print '@{}'; \@100 },
 830   '%{}' => sub { print '%{}'; \%100 },
 831   '${}' => sub { print '${}'; \$100 },
 832   map {
 833    my $op = $_;
 834    $_ => sub { print "$op"; 100 }
 835   } qw< 0+ "" + ** * / % - neg int abs == < > <= >= != <=> <> >
 836 }
 837 $o = bless [], overloaded;
 838
 839 sub TIESCALAR { bless {}, "" }
 840 sub FETCH { print "fetching... "; $o }
 841 sub STORE{}
 842 tie $ghew, "";
 843
 844 $ghew=undef; 1+$ghew; print "\n";
 845 $ghew=undef; $ghew**1; print "\n";
 846 $ghew=undef; $ghew*1; print "\n";
 847 $ghew=undef; $ghew/1; print "\n";
 848 $ghew=undef; $ghew%1; print "\n";
 849 $ghew=undef; $ghew-1; print "\n";
 850 $ghew=undef; -$ghew; print "\n";
 851 $ghew=undef; int $ghew; print "\n";
 852 $ghew=undef; abs $ghew; print "\n";
 853 $ghew=undef; 1 == $ghew; 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 >=1; print "\n";
 858 $ghew=undef; $ghew != 1; print "\n";
 859 $ghew=undef; $ghew<=>1; print "\n";
 860 $ghew=undef; <$ghew>; print "\n";
 861 $ghew=\*shrext; *$ghew; print "\n";
 862 $ghew=\@spled; @$ghew; print "\n";
 863 $ghew=\%frit; %$ghew; print "\n";
 864 $ghew=\$drile; $$ghew; print "\n";
 865 EXPECT
 866 fetching... +
 867 fetching... **
 868 fetching... *
 869 fetching... /
 870 fetching... %
 871 fetching... -
 872 fetching... neg
 873 fetching... int
 874 fetching... abs
 875 fetching... ==
 876 fetching... <
 877 fetching... >
 878 fetching... <=
 879 fetching... >=
 880 fetching... !=
 881 fetching... <=>
 882 fetching... <>
 883 fetching... *{}
 884 fetching... @{}
 885 fetching... %{}
 886 fetching... ${}
 887 ########
 888 # RT 51636: segmentation fault with array ties
 889
 890 tie my @a, 'T';
 891 @a = (1);
 892 print "ok\n"; # if we got here we didn't crash
 893
 894 package T;
 895
 896 sub TIEARRAY { bless {} }
 897 sub STORE    { tie my @b, 'T' }
 898 sub CLEAR    { }
 899 sub EXTEND   { }
 900
 901 EXPECT
 902 ok
 903 ########
 904 # RT 8438: Tied scalars don't call FETCH when subref is dereferenced
 905
 906 sub TIESCALAR { bless {} }
 907
 908 my $fetch = 0;
 909 my $called = 0;
 910 sub FETCH { $fetch++; sub { $called++ } }
 911
 912 tie my $f, 'main';
 913 $f->(1) for 1,2;
 914 print "fetch=$fetch\ncalled=$called\n";
 915
 916 EXPECT
 917 fetch=2
 918 called=2
 919 ########
 920 # tie mustn't attempt to call methods on bareword filehandles.
 921 sub IO::File::TIEARRAY {
 922     die "Did not want to invoke IO::File::TIEARRAY";
 923 }
 924 fileno FOO; tie @a, "FOO"
 925 EXPECT
 926 Can't locate object method "TIEARRAY" via package "FOO" at - line 5.
 927 ########
 928 #
 929 # STORE freeing tie'd AV
 930 sub TIEARRAY  { bless [] }
 931 sub STORE     { *a = []; 1 }
 932 sub STORESIZE { }
 933 sub EXTEND    { }
 934 tie @a, 'main';
 935 $a[0] = 1;
 936 EXPECT
 937 ########
 938 #
 939 # CLEAR freeing tie'd AV
 940 sub TIEARRAY  { bless [] }
 941 sub CLEAR     { *a = []; 1 }
 942 sub STORESIZE { }
 943 sub EXTEND    { }
 944 sub STORE     { }
 945 tie @a, 'main';
 946 @a = (1,2,3);
 947 EXPECT
 948 ########
 949 #
 950 # FETCHSIZE freeing tie'd AV
 951 sub TIEARRAY  { bless [] }
 952 sub FETCHSIZE { *a = []; 100 }
 953 sub STORESIZE { }
 954 sub EXTEND    { }
 955 sub STORE     { }
 956 tie @a, 'main';
 957 print $#a,"\n"
 958 EXPECT
 959 99
 960 ########
 961 #
 962 # [perl #86328] Crash when freeing tie magic that can increment the refcnt
 963
 964 eval { require Scalar::Util } or print("ok\n"), exit;
 965
 966 sub TIEHASH {
 967     return $_[1];
 968 }
 969 *TIEARRAY = *TIEHASH;
 970
 971 sub DESTROY {
 972     my ($tied) = @_;
 973     my $b = $tied->[0];
 974 }
 975
 976 my $a = {};
 977 my $o = bless [];
 978 Scalar::Util::weaken($o->[0] = $a);
 979 tie %$a, "main", $o;
 980
 981 my $b = [];
 982 my $p = bless [];
 983 Scalar::Util::weaken($p->[0] = $b);
 984 tie @$b, "main", $p;
 985
 986 # Done setting up the evil data structures
 987
 988 $a = undef;
 989 $b = undef;
 990 print "ok\n";
 991
 992 EXPECT
 993 ok
 994 ########
 995 #
 996 # Localising a tied COW scalar should not make it read-only.
 997
 998 sub TIESCALAR { bless [] }
 999 sub FETCH { __PACKAGE__ }
1000 sub STORE {}
1001 tie $x, "";
1002 "$x";
1003 {
1004     local $x;
1005     $x = 3;
1006 }
1007 print "ok\n";
1008 EXPECT
1009 ok
1010 ########
1011 #
1012 # Nor should it be impossible to tie COW scalars that are already PVMGs.
1013
1014 sub TIESCALAR { bless [] }
1015 $x = *foo;        # PVGV
1016 undef $x;         # downgrade to PVMG
1017 $x = __PACKAGE__; # PVMG + COW
1018 tie $x, "";       # bang!
1019
1020 print STDERR "ok\n";
1021
1022 # However, one should not be able to tie read-only glob copies, which look
1023 # a bit like kine internally (FAKE + READONLY).
1024 $y = *foo;
1025 Internals::SvREADONLY($y,1);
1026 tie $y, "";
1027
1028 EXPECT
1029 ok
1030 Modification of a read-only value attempted at - line 16.
1031 ########
1032
1033 # Similarly, read-only regexps cannot be tied.
1034 sub TIESCALAR { bless [] }
1035 $y = ${qr//};
1036 Internals::SvREADONLY($y,1);
1037 tie $y, "";
1038
1039 EXPECT
1040 Modification of a read-only value attempted at - line 6.
1041 ########
1042
1043 # tied() should still work on tied scalars after glob assignment
1044 sub TIESCALAR {bless[]}
1045 sub FETCH {*foo}
1046 sub f::TIEHANDLE{bless[],f}
1047 tie *foo, "f";
1048 tie $rin, "";
1049 [$rin]; # call FETCH
1050 print ref tied $rin, "\n";
1051 print ref tied *$rin, "\n";
1052 EXPECT
1053 main
1054 f
1055 ########
1056
1057 # (un)tie $glob_copy vs (un)tie *$glob_copy
1058 sub TIESCALAR { print "TIESCALAR\n"; bless [] }
1059 sub TIEHANDLE{ print "TIEHANDLE\n"; bless [] }
1060 sub FETCH { print "never called\n" }
1061 $f = *foo;
1062 tie *$f, "";
1063 tie $f, "";
1064 untie $f;
1065 print "ok 1\n" if !tied $f;
1066 () = $f; # should not call FETCH
1067 untie *$f;
1068 print "ok 2\n" if !tied *foo;
1069 EXPECT
1070 TIEHANDLE
1071 TIESCALAR
1072 ok 1
1073 ok 2
1074 ########
1075
1076 # RT #8611 mustn't goto outside the magic stack
1077 sub TIESCALAR { warn "tiescalar\n"; bless [] }
1078 sub FETCH { warn "fetch()\n"; goto FOO; }
1079 tie $f, "";
1080 warn "before fetch\n";
1081 my $a = "$f";
1082 warn "before FOO\n";
1083 FOO:
1084 warn "after FOO\n";
1085 EXPECT
1086 tiescalar
1087 before fetch
1088 fetch()
1089 Can't find label FOO at - line 4.
1090 ########
1091
1092 # RT #8611 mustn't goto outside the magic stack
1093 sub TIEHANDLE { warn "tiehandle\n"; bless [] }
1094 sub PRINT { warn "print()\n"; goto FOO; }
1095 tie *F, "";
1096 warn "before print\n";
1097 print F "abc";
1098 warn "before FOO\n";
1099 FOO:
1100 warn "after FOO\n";
1101 EXPECT
1102 tiehandle
1103 before print
1104 print()
1105 Can't find label FOO at - line 4.
1106 ########
1107
1108 # \&$tied with $tied holding a reference before the fetch (but not after)
1109 sub ::72 { 73 };
1110 sub TIESCALAR {bless[]}
1111 sub STORE{}
1112 sub FETCH { 72 }
1113 tie my $x, "main";
1114 $x = \$y;
1115 \&$x;
1116 print "ok\n";
1117 EXPECT
1118 ok
1119 ########
1120
1121 # \&$tied with $tied holding a PVLV glob before the fetch (but not after)
1122 sub ::72 { 73 };
1123 sub TIEARRAY {bless[]}
1124 sub STORE{}
1125 sub FETCH { 72 }
1126 tie my @x, "main";
1127 my $elem = \$x[0];
1128 $$elem = *bar;
1129 print &{\&$$elem}, "\n";
1130 EXPECT
1131 73
1132 ########
1133
1134 # \&$tied with $tied holding a PVGV glob before the fetch (but not after)
1135 local *72 = sub { 73 };
1136 sub TIESCALAR {bless[]}
1137 sub STORE{}
1138 sub FETCH { 72 }
1139 tie my $x, "main";
1140 $x = *bar;
1141 print &{\&$x}, "\n";
1142 EXPECT
1143 73
1144 ########
1145
1146 # Lexicals should not be visible to magic methods on scope exit
1147 BEGIN { unless (defined &DynaLoader::boot_DynaLoader) {
1148     print "HASH\nHASH\nARRAY\nARRAY\n"; exit;
1149 }}
1150 use Scalar::Util 'weaken';
1151 { package xoufghd;
1152   sub TIEHASH { Scalar::Util::weaken($_[1]); bless \$_[1], xoufghd:: }
1153   *TIEARRAY = *TIEHASH;
1154   DESTROY {
1155      bless ${$_[0]} || return, 0;
1156 } }
1157 for my $sub (
1158     # hashes: ties before backrefs
1159     sub {
1160         my %hash;
1161         $ref = ref \%hash;
1162         tie %hash, xoufghd::, \%hash;
1163         1;
1164     },
1165     # hashes: backrefs before ties
1166     sub {
1167         my %hash;
1168         $ref = ref \%hash;
1169         weaken(my $x = \%hash);
1170         tie %hash, xoufghd::, \%hash;
1171         1;
1172     },
1173     # arrays: ties before backrefs
1174     sub {
1175         my @array;
1176         $ref = ref \@array;
1177         tie @array, xoufghd::, \@array;
1178         1;
1179     },
1180     # arrays: backrefs before ties
1181     sub {
1182         my @array;
1183         $ref = ref \@array;
1184         weaken(my $x = \@array);
1185         tie @array, xoufghd::, \@array;
1186         1;
1187     },
1188 ) {
1189     &$sub;
1190     &$sub;
1191     print $ref, "\n";
1192 }
1193 EXPECT
1194 HASH
1195 HASH
1196 ARRAY
1197 ARRAY
1198 ########
1199
1200 # Localising a tied variable with a typeglob in it should copy magic
1201 sub TIESCALAR{bless[]}
1202 sub FETCH{warn "fetching\n"; *foo}
1203 sub STORE{}
1204 tie $x, "";
1205 local $x;
1206 warn "before";
1207 "$x";
1208 warn "after";
1209 EXPECT
1210 fetching
1211 before at - line 8.
1212 fetching
1213 after at - line 10.
1214 ########
1215
1216 # tied returns same value as tie
1217 sub TIESCALAR{bless[]}
1218 $tyre = \tie $tied, "";
1219 print "ok\n" if \tied $tied == $tyre;
1220 EXPECT
1221 ok
1222 ########
1223
1224 # tied arrays should always be AvREAL
1225 $^W=1;
1226 sub TIEARRAY{bless[]}
1227 sub {
1228   tie @_, "";
1229   \@_; # used to produce: av_reify called on tied array at - line 7.
1230 }->(1);
1231 EXPECT
1232 ########
1233
1234 # [perl #67490] scalar-tying elements of magic hashes
1235 sub TIESCALAR{bless[]}
1236 sub STORE{}
1237 tie $ENV{foo}, '';
1238 $ENV{foo} = 78;
1239 delete $ENV{foo};
1240 tie $^H{foo}, '';
1241 $^H{foo} = 78;
1242 delete $^H{foo};
1243 EXPECT
1244 ########
1245
1246 # [perl #35865, #43011] autovivification should call FETCH after STORE
1247 # because perl does not know that the FETCH would have returned the same
1248 # thing that was just stored.
1249
1250 # This package never likes to take ownership of other people’s refs.  It
1251 # always makes its own copies.  (For simplicity, it only accepts hashes.)
1252 package copier {
1253     sub TIEHASH { bless {} }
1254     sub FETCH   { $_[0]{$_[1]} }
1255     sub STORE   { $_[0]{$_[1]} = { %{ $_[2] } } }
1256 }
1257 tie my %h, copier::;
1258 $h{i}{j} = 'k';
1259 print $h{i}{j}, "\n";
1260 EXPECT
1261 k
1262 ########
1263
1264 # [perl #8931] FETCH for tied $" called an odd number of times.
1265 use strict;
1266 my $i = 0;
1267 sub A::TIESCALAR {bless [] => 'A'}
1268 sub A::FETCH {print ++ $i, "\n"}
1269 my @a = ("", "", "");
1270
1271 tie $" => 'A';
1272 "@a";
1273
1274 $i = 0;
1275 tie my $a => 'A';
1276 join $a, 1..10;
1277 EXPECT
1278 1
1279 1
1280 ########
1281
1282 # [perl #9391] return value from 'tied' not discarded soon enough
1283 use warnings;
1284 tie @a, 'T';
1285 if (tied @a) {
1286 untie @a;
1287 }
1288
1289 sub T::TIEARRAY { my $s; bless \$s => "T" }
1290 EXPECT
1291