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