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 $ENV{PERL5LIB} = "../lib";
  15
  16 $|=1;
  17
  18 undef $/;
  19 @prgs = split /^########\n/m, <DATA>;
  20
  21 require './test.pl';
  22 plan(tests => scalar @prgs);
  23 for (@prgs){
  24     ++$i;
  25     my($prog,$expected) = split(/\nEXPECT\n/, $_, 2);
  26     print("not ok $i # bad test format\n"), next
  27         unless defined $expected;
  28     my ($testname) = $prog =~ /^# (.*)\n/m;
  29     $testname ||= '';
  30     $TODO = $testname =~ s/^TODO //;
  31     $results =~ s/\n+$//;
  32     $expected =~ s/\n+$//;
  33
  34     fresh_perl_is($prog, $expected, {}, $testname);
  35 }
  36
  37 __END__
  38
  39 # standard behaviour, without any extra references
  40 use Tie::Hash ;
  41 tie %h, Tie::StdHash;
  42 untie %h;
  43 EXPECT
  44 ########
  45
  46 # standard behaviour, without any extra references
  47 use Tie::Hash ;
  48 {package Tie::HashUntie;
  49  use base 'Tie::StdHash';
  50  sub UNTIE
  51   {
  52    warn "Untied\n";
  53   }
  54 }
  55 tie %h, Tie::HashUntie;
  56 untie %h;
  57 EXPECT
  58 Untied
  59 ########
  60
  61 # standard behaviour, with 1 extra reference
  62 use Tie::Hash ;
  63 $a = tie %h, Tie::StdHash;
  64 untie %h;
  65 EXPECT
  66 ########
  67
  68 # standard behaviour, with 1 extra reference via tied
  69 use Tie::Hash ;
  70 tie %h, Tie::StdHash;
  71 $a = tied %h;
  72 untie %h;
  73 EXPECT
  74 ########
  75
  76 # standard behaviour, with 1 extra reference which is destroyed
  77 use Tie::Hash ;
  78 $a = tie %h, Tie::StdHash;
  79 $a = 0 ;
  80 untie %h;
  81 EXPECT
  82 ########
  83
  84 # standard behaviour, with 1 extra reference via tied which is destroyed
  85 use Tie::Hash ;
  86 tie %h, Tie::StdHash;
  87 $a = tied %h;
  88 $a = 0 ;
  89 untie %h;
  90 EXPECT
  91 ########
  92
  93 # strict behaviour, without any extra references
  94 use warnings 'untie';
  95 use Tie::Hash ;
  96 tie %h, Tie::StdHash;
  97 untie %h;
  98 EXPECT
  99 ########
 100
 101 # strict behaviour, with 1 extra references generating an error
 102 use warnings 'untie';
 103 use Tie::Hash ;
 104 $a = tie %h, Tie::StdHash;
 105 untie %h;
 106 EXPECT
 107 untie attempted while 1 inner references still exist at - line 6.
 108 ########
 109
 110 # strict behaviour, with 1 extra references via tied generating an error
 111 use warnings 'untie';
 112 use Tie::Hash ;
 113 tie %h, Tie::StdHash;
 114 $a = tied %h;
 115 untie %h;
 116 EXPECT
 117 untie attempted while 1 inner references still exist at - line 7.
 118 ########
 119
 120 # strict behaviour, with 1 extra references which are destroyed
 121 use warnings 'untie';
 122 use Tie::Hash ;
 123 $a = tie %h, Tie::StdHash;
 124 $a = 0 ;
 125 untie %h;
 126 EXPECT
 127 ########
 128
 129 # strict behaviour, with extra 1 references via tied which are destroyed
 130 use warnings 'untie';
 131 use Tie::Hash ;
 132 tie %h, Tie::StdHash;
 133 $a = tied %h;
 134 $a = 0 ;
 135 untie %h;
 136 EXPECT
 137 ########
 138
 139 # strict error behaviour, with 2 extra references
 140 use warnings 'untie';
 141 use Tie::Hash ;
 142 $a = tie %h, Tie::StdHash;
 143 $b = tied %h ;
 144 untie %h;
 145 EXPECT
 146 untie attempted while 2 inner references still exist at - line 7.
 147 ########
 148
 149 # strict behaviour, check scope of strictness.
 150 no warnings 'untie';
 151 use Tie::Hash ;
 152 $A = tie %H, Tie::StdHash;
 153 $C = $B = tied %H ;
 154 {
 155     use warnings 'untie';
 156     use Tie::Hash ;
 157     tie %h, Tie::StdHash;
 158     untie %h;
 159 }
 160 untie %H;
 161 EXPECT
 162 ########
 163
 164 # Forbidden aggregate self-ties
 165 sub Self::TIEHASH { bless $_[1], $_[0] }
 166 {
 167     my %c;
 168     tie %c, 'Self', \%c;
 169 }
 170 EXPECT
 171 Self-ties of arrays and hashes are not supported at - line 6.
 172 ########
 173
 174 # Allowed scalar self-ties
 175 my $destroyed = 0;
 176 sub Self::TIESCALAR { bless $_[1], $_[0] }
 177 sub Self::DESTROY   { $destroyed = 1; }
 178 {
 179     my $c = 42;
 180     tie $c, 'Self', \$c;
 181 }
 182 die "self-tied scalar not DESTROYed" unless $destroyed == 1;
 183 EXPECT
 184 ########
 185
 186 # Allowed glob self-ties
 187 my $destroyed = 0;
 188 my $printed   = 0;
 189 sub Self2::TIEHANDLE { bless $_[1], $_[0] }
 190 sub Self2::DESTROY   { $destroyed = 1; }
 191 sub Self2::PRINT     { $printed = 1; }
 192 {
 193     use Symbol;
 194     my $c = gensym;
 195     tie *$c, 'Self2', $c;
 196     print $c 'Hello';
 197 }
 198 die "self-tied glob not PRINTed" unless $printed == 1;
 199 die "self-tied glob not DESTROYed" unless $destroyed == 1;
 200 EXPECT
 201 ########
 202
 203 # Allowed IO self-ties
 204 my $destroyed = 0;
 205 sub Self3::TIEHANDLE { bless $_[1], $_[0] }
 206 sub Self3::DESTROY   { $destroyed = 1; }
 207 sub Self3::PRINT     { $printed = 1; }
 208 {
 209     use Symbol 'geniosym';
 210     my $c = geniosym;
 211     tie *$c, 'Self3', $c;
 212     print $c 'Hello';
 213 }
 214 die "self-tied IO not PRINTed" unless $printed == 1;
 215 die "self-tied IO not DESTROYed" unless $destroyed == 1;
 216 EXPECT
 217 ########
 218
 219 # TODO IO "self-tie" via TEMP glob
 220 my $destroyed = 0;
 221 sub Self3::TIEHANDLE { bless $_[1], $_[0] }
 222 sub Self3::DESTROY   { $destroyed = 1; }
 223 sub Self3::PRINT     { $printed = 1; }
 224 {
 225     use Symbol 'geniosym';
 226     my $c = geniosym;
 227     tie *$c, 'Self3', \*$c;
 228     print $c 'Hello';
 229 }
 230 die "IO tied to TEMP glob not PRINTed" unless $printed == 1;
 231 die "IO tied to TEMP glob not DESTROYed" unless $destroyed == 1;
 232 EXPECT
 233 ########
 234
 235 # Interaction of tie and vec
 236
 237 my ($a, $b);
 238 use Tie::Scalar;
 239 tie $a,Tie::StdScalar or die;
 240 vec($b,1,1)=1;
 241 $a = $b;
 242 vec($a,1,1)=0;
 243 vec($b,1,1)=0;
 244 die unless $a eq $b;
 245 EXPECT
 246 ########
 247
 248 # correct unlocalisation of tied hashes (patch #16431)
 249 use Tie::Hash ;
 250 tie %tied, Tie::StdHash;
 251 { local $hash{'foo'} } warn "plain hash bad unlocalize" if exists $hash{'foo'};
 252 { local $tied{'foo'} } warn "tied hash bad unlocalize" if exists $tied{'foo'};
 253 { local $ENV{'foo'}  } warn "%ENV bad unlocalize" if exists $ENV{'foo'};
 254 EXPECT
 255 ########
 256
 257 # An attempt at lvalueable barewords broke this
 258 tie FH, 'main';
 259 EXPECT
 260 Can't modify constant item in tie at - line 3, near "'main';"
 261 Execution of - aborted due to compilation errors.
 262 ########
 263
 264 # localizing tied hash slices
 265 $ENV{FooA} = 1;
 266 $ENV{FooB} = 2;
 267 print exists $ENV{FooA} ? 1 : 0, "\n";
 268 print exists $ENV{FooB} ? 2 : 0, "\n";
 269 print exists $ENV{FooC} ? 3 : 0, "\n";
 270 {
 271     local @ENV{qw(FooA FooC)};
 272     print exists $ENV{FooA} ? 4 : 0, "\n";
 273     print exists $ENV{FooB} ? 5 : 0, "\n";
 274     print exists $ENV{FooC} ? 6 : 0, "\n";
 275 }
 276 print exists $ENV{FooA} ? 7 : 0, "\n";
 277 print exists $ENV{FooB} ? 8 : 0, "\n";
 278 print exists $ENV{FooC} ? 9 : 0, "\n"; # this should not exist
 279 EXPECT
 280 1
 281 2
 282 0
 283 4
 284 5
 285 6
 286 7
 287 8
 288 0
 289 ########
 290 #
 291 # FETCH freeing tie'd SV
 292 sub TIESCALAR { bless [] }
 293 sub FETCH { *a = \1; 1 }
 294 tie $a, 'main';
 295 print $a;
 296 EXPECT
 297 ########
 298
 299 #  [20020716.007] - nested FETCHES
 300
 301 sub F1::TIEARRAY { bless [], 'F1' }
 302 sub F1::FETCH { 1 }
 303 my @f1;
 304 tie @f1, 'F1';
 305
 306 sub F2::TIEARRAY { bless [2], 'F2' }
 307 sub F2::FETCH { my $self = shift; my $x = $f1[3]; $self }
 308 my @f2;
 309 tie @f2, 'F2';
 310
 311 print $f2[4][0],"\n";
 312
 313 sub F3::TIEHASH { bless [], 'F3' }
 314 sub F3::FETCH { 1 }
 315 my %f3;
 316 tie %f3, 'F3';
 317
 318 sub F4::TIEHASH { bless [3], 'F4' }
 319 sub F4::FETCH { my $self = shift; my $x = $f3{3}; $self }
 320 my %f4;
 321 tie %f4, 'F4';
 322
 323 print $f4{'foo'}[0],"\n";
 324
 325 EXPECT
 326 2
 327 3
 328 ########
 329 # test untie() from within FETCH
 330 package Foo;
 331 sub TIESCALAR { my $pkg = shift; return bless [@_], $pkg; }
 332 sub FETCH {
 333   my $self = shift;
 334   my ($obj, $field) = @$self;
 335   untie $obj->{$field};
 336   $obj->{$field} = "Bar";
 337 }
 338 package main;
 339 tie $a->{foo}, "Foo", $a, "foo";
 340 my $s = $a->{foo}; # access once
 341 # the hash element should not be tied anymore
 342 print defined tied $a->{foo} ? "not ok" : "ok";
 343 EXPECT
 344 ok
 345 ########
 346 # the tmps returned by FETCH should appear to be SCALAR
 347 # (even though they are now implemented using PVLVs.)
 348 package X;
 349 sub TIEHASH { bless {} }
 350 sub TIEARRAY { bless {} }
 351 sub FETCH {1}
 352 my (%h, @a);
 353 tie %h, 'X';
 354 tie @a, 'X';
 355 my $r1 = \$h{1};
 356 my $r2 = \$a[0];
 357 my $s = "$r1 ". ref($r1) . " $r2 " . ref($r2);
 358 $s=~ s/\(0x\w+\)//g;
 359 print $s, "\n";
 360 EXPECT
 361 SCALAR SCALAR SCALAR SCALAR
 362 ########
 363 # [perl #23287] segfault in untie
 364 sub TIESCALAR { bless $_[1], $_[0] }
 365 my $var;
 366 tie $var, 'main', \$var;
 367 untie $var;
 368 EXPECT
 369 ########
 370 # Test case from perlmonks by runrig
 371 # http://www.perlmonks.org/index.pl?node_id=273490
 372 # "Here is what I tried. I think its similar to what you've tried
 373 #  above. Its odd but convienient that after untie'ing you are left with
 374 #  a variable that has the same value as was last returned from
 375 #  FETCH. (At least on my perl v5.6.1). So you don't need to pass a
 376 #  reference to the variable in order to set it after the untie (here it
 377 #  is accessed through a closure)."
 378 use strict;
 379 use warnings;
 380 package MyTied;
 381 sub TIESCALAR {
 382     my ($class,$code) = @_;
 383     bless $code, $class;
 384 }
 385 sub FETCH {
 386     my $self = shift;
 387     print "Untie\n";
 388     $self->();
 389 }
 390 package main;
 391 my $var;
 392 tie $var, 'MyTied', sub { untie $var; 4 };
 393 print "One\n";
 394 print "$var\n";
 395 print "Two\n";
 396 print "$var\n";
 397 print "Three\n";
 398 print "$var\n";
 399 EXPECT
 400 One
 401 Untie
 402 4
 403 Two
 404 4
 405 Three
 406 4
 407 ########
 408 # [perl #22297] cannot untie scalar from within tied FETCH
 409 my $counter = 0;
 410 my $x = 7;
 411 my $ref = \$x;
 412 tie $x, 'Overlay', $ref, $x;
 413 my $y;
 414 $y = $x;
 415 $y = $x;
 416 $y = $x;
 417 $y = $x;
 418 #print "WILL EXTERNAL UNTIE $ref\n";
 419 untie $$ref;
 420 $y = $x;
 421 $y = $x;
 422 $y = $x;
 423 $y = $x;
 424 #print "counter = $counter\n";
 425
 426 print (($counter == 1) ? "ok\n" : "not ok\n");
 427
 428 package Overlay;
 429
 430 sub TIESCALAR
 431 {
 432         my $pkg = shift;
 433         my ($ref, $val) = @_;
 434         return bless [ $ref, $val ], $pkg;
 435 }
 436
 437 sub FETCH
 438 {
 439         my $self = shift;
 440         my ($ref, $val) = @$self;
 441         #print "WILL INTERNAL UNITE $ref\n";
 442         $counter++;
 443         untie $$ref;
 444         return $val;
 445 }
 446 EXPECT
 447 ok
 448 ########
 449
 450 # [perl #948] cannot meaningfully tie $,
 451 package TieDollarComma;
 452
 453 sub TIESCALAR {
 454      my $pkg = shift;
 455      return bless \my $x, $pkg;
 456 }
 457
 458 sub STORE {
 459     my $self = shift;
 460     $$self = shift;
 461     print "STORE set '$$self'\n";
 462 }
 463
 464 sub FETCH {
 465     my $self = shift;
 466     print "<FETCH>";
 467     return $$self;
 468 }
 469 package main;
 470
 471 tie $,, 'TieDollarComma';
 472 $, = 'BOBBINS';
 473 print "join", "things", "up\n";
 474 EXPECT
 475 STORE set 'BOBBINS'
 476 join<FETCH>BOBBINSthings<FETCH>BOBBINSup
 477 ########
 478
 479 # test SCALAR method
 480 package TieScalar;
 481
 482 sub TIEHASH {
 483     my $pkg = shift;
 484     bless { } => $pkg;
 485 }
 486
 487 sub STORE {
 488     $_[0]->{$_[1]} = $_[2];
 489 }
 490
 491 sub FETCH {
 492     $_[0]->{$_[1]}
 493 }
 494
 495 sub CLEAR {
 496     %{ $_[0] } = ();
 497 }
 498
 499 sub SCALAR {
 500     print "SCALAR\n";
 501     return 0 if ! keys %{$_[0]};
 502     sprintf "%i/%i", scalar keys %{$_[0]}, scalar keys %{$_[0]};
 503 }
 504
 505 package main;
 506 tie my %h => "TieScalar";
 507 $h{key1} = "val1";
 508 $h{key2} = "val2";
 509 print scalar %h, "\n"
 510     if %h; # this should also call SCALAR but implicitly
 511 %h = ();
 512 print scalar %h, "\n"
 513     if !%h; # this should also call SCALAR but implicitly
 514 EXPECT
 515 SCALAR
 516 SCALAR
 517 2/2
 518 SCALAR
 519 SCALAR
 520 0
 521 ########
 522
 523 # test scalar on tied hash when no SCALAR method has been given
 524 package TieScalar;
 525
 526 sub TIEHASH {
 527     my $pkg = shift;
 528     bless { } => $pkg;
 529 }
 530 sub STORE {
 531     $_[0]->{$_[1]} = $_[2];
 532 }
 533 sub FETCH {
 534     $_[0]->{$_[1]}
 535 }
 536 sub CLEAR {
 537     %{ $_[0] } = ();
 538 }
 539 sub FIRSTKEY {
 540     my $a = keys %{ $_[0] };
 541     print "FIRSTKEY\n";
 542     each %{ $_[0] };
 543 }
 544
 545 package main;
 546 tie my %h => "TieScalar";
 547
 548 if (!%h) {
 549     print "empty\n";
 550 } else {
 551     print "not empty\n";
 552 }
 553
 554 $h{key1} = "val1";
 555 print "not empty\n" if %h;
 556 print "not empty\n" if %h;
 557 print "-->\n";
 558 my ($k,$v) = each %h;
 559 print "<--\n";
 560 print "not empty\n" if %h;
 561 %h = ();
 562 print "empty\n" if ! %h;
 563 EXPECT
 564 FIRSTKEY
 565 empty
 566 FIRSTKEY
 567 not empty
 568 FIRSTKEY
 569 not empty
 570 -->
 571 FIRSTKEY
 572 <--
 573 not empty
 574 FIRSTKEY
 575 empty
 576 ########
 577 sub TIESCALAR { bless {} }
 578 sub FETCH { my $x = 3.3; 1 if 0+$x; $x }
 579 tie $h, "main";
 580 print $h,"\n";
 581 EXPECT
 582 3.3
 583 ########
 584 sub TIESCALAR { bless {} }
 585 sub FETCH { shift()->{i} ++ }
 586 tie $h, "main";
 587 print $h.$h;
 588 EXPECT
 589 01
 590 ########
 591 # Bug 53482 (and maybe others)
 592 sub TIESCALAR { my $foo = $_[1]; bless \$foo, $_[0] }
 593 sub FETCH { ${$_[0]} }
 594 tie my $x1, "main", 2;
 595 tie my $y1, "main", 8;
 596 print $x1 | $y1;
 597 print $x1 | $y1;
 598 tie my $x2, "main", "2";
 599 tie my $y2, "main", "8";
 600 print $x2 | $y2;
 601 print $x2 | $y2;
 602 EXPECT
 603 1010::
 604 ########
 605 # Bug 36267
 606 sub TIEHASH  { bless {}, $_[0] }
 607 sub STORE    { $_[0]->{$_[1]} = $_[2] }
 608 sub FIRSTKEY { my $a = scalar keys %{$_[0]}; each %{$_[0]} }
 609 sub NEXTKEY  { each %{$_[0]} }
 610 sub DELETE   { delete $_[0]->{$_[1]} }
 611 sub CLEAR    { %{$_[0]} = () }
 612 $h{b}=1;
 613 delete $h{b};
 614 print scalar keys %h, "\n";
 615 tie %h, 'main';
 616 $i{a}=1;
 617 %h = %i;
 618 untie %h;
 619 print scalar keys %h, "\n";
 620 EXPECT
 621 0
 622 0
 623 ########
 624 # Bug 37731
 625 sub foo::TIESCALAR { bless {value => $_[1]}, $_[0] }
 626 sub foo::FETCH { $_[0]->{value} }
 627 tie my $VAR, 'foo', '42';
 628 foreach my $var ($VAR) {
 629     print +($var eq $VAR) ? "yes\n" : "no\n";
 630 }
 631 EXPECT
 632 yes
 633 ########
 634 sub TIEARRAY { bless [], 'main' }
 635 {
 636     local @a;
 637     tie @a, 'main';
 638 }
 639 print "tied\n" if tied @a;
 640 EXPECT
 641 ########
 642 sub TIEHASH { bless [], 'main' }
 643 {
 644     local %h;
 645     tie %h, 'main';
 646 }
 647 print "tied\n" if tied %h;
 648 EXPECT
 649 ########
 650 # RT 20727: PL_defoutgv is left as a tied element
 651 sub TIESCALAR { return bless {}, 'main' }
 652
 653 sub STORE {
 654     select($_[1]);
 655     $_[1] = 1;
 656     select(); # this used to coredump or assert fail
 657 }
 658 tie $SELECT, 'main';
 659 $SELECT = *STDERR;
 660 EXPECT
 661 ########
 662 # RT 23810: eval in die in FETCH can corrupt context stack
 663
 664 my $file = 'rt23810.pm';
 665
 666 my $e;
 667 my $s;
 668
 669 sub do_require {
 670     my ($str, $eval) = @_;
 671     open my $fh, '>', $file or die "Can't create $file: $!\n";
 672     print $fh $str;
 673     close $fh;
 674     if ($eval) {
 675         $s .= '-ERQ';
 676         eval { require $pm; $s .= '-ENDE' }
 677     }
 678     else {
 679         $s .= '-RQ';
 680         require $pm;
 681     }
 682     $s .= '-ENDRQ';
 683     unlink $file;
 684 }
 685
 686 sub TIEHASH { bless {} }
 687
 688 sub FETCH {
 689     # 10 or more syntax errors makes yyparse croak()
 690     my $bad = q{$x+;$x+;$x+;$x+;$x+;$x+;$x+;$x+;$x+$x+;$x+;$x+;$x+;$x+;;$x+;};
 691
 692     if ($_[1] eq 'eval') {
 693         $s .= 'EVAL';
 694         eval q[BEGIN { die; $s .= '-X1' }];
 695         $s .= '-BD';
 696         eval q[BEGIN { $x+ }];
 697         $s .= '-BS';
 698         eval '$x+';
 699         $s .= '-E1';
 700         $s .= '-S1' while $@ =~ /syntax error at/g;
 701         eval $bad;
 702         $s .= '-E2';
 703         $s .= '-S2' while $@ =~ /syntax error at/g;
 704     }
 705     elsif ($_[1] eq 'require') {
 706         $s .= 'REQUIRE';
 707         my @text = (
 708             q[BEGIN { die; $s .= '-X1' }],
 709             q[BEGIN { $x+ }],
 710             '$x+',
 711             $bad
 712         );
 713         for my $i (0..$#text) {
 714             $s .= "-$i";
 715             do_require($txt[$i], 0) if $e;;
 716             do_require($txt[$i], 1);
 717         }
 718     }
 719     elsif ($_[1] eq 'exit') {
 720         eval q[exit(0); print "overshot eval\n"];
 721     }
 722     else {
 723         print "unknown key: '$_[1]'\n";
 724     }
 725     return "-R";
 726 }
 727 my %foo;
 728 tie %foo, "main";
 729
 730 for my $action(qw(eval require)) {
 731     $s = ''; $e = 0; $s .= main->FETCH($action); print "$action: s0=$s\n";
 732     $s = ''; $e = 1; eval { $s .= main->FETCH($action)}; print "$action: s1=$s\n";
 733     $s = ''; $e = 0; $s .= $foo{$action}; print "$action: s2=$s\n";
 734     $s = ''; $e = 1; eval { $s .= $foo{$action}}; print "$action: s3=$s\n";
 735 }
 736 1 while unlink $file;
 737
 738 $foo{'exit'};
 739 print "overshot main\n"; # shouldn't reach here
 740
 741 EXPECT
 742 eval: s0=EVAL-BD-BS-E1-S1-E2-S2-S2-S2-S2-S2-S2-S2-S2-S2-S2-R
 743 eval: s1=EVAL-BD-BS-E1-S1-E2-S2-S2-S2-S2-S2-S2-S2-S2-S2-S2-R
 744 eval: s2=EVAL-BD-BS-E1-S1-E2-S2-S2-S2-S2-S2-S2-S2-S2-S2-S2-R
 745 eval: s3=EVAL-BD-BS-E1-S1-E2-S2-S2-S2-S2-S2-S2-S2-S2-S2-S2-R
 746 require: s0=REQUIRE-0-ERQ-ENDRQ-1-ERQ-ENDRQ-2-ERQ-ENDRQ-3-ERQ-ENDRQ-R
 747 require: s1=REQUIRE-0-RQ
 748 require: s2=REQUIRE-0-ERQ-ENDRQ-1-ERQ-ENDRQ-2-ERQ-ENDRQ-3-ERQ-ENDRQ-R
 749 require: s3=REQUIRE-0-RQ
 750 ########
 751 # RT 8857: STORE incorrectly invoked for local($_) on aliased tied array
 752 #          element
 753
 754 sub TIEARRAY { bless [], $_[0] }
 755 sub TIEHASH  { bless [], $_[0] }
 756 sub FETCH { $_[0]->[$_[1]] }
 757 sub STORE { $_[0]->[$_[1]] = $_[2] }
 758
 759
 760 sub f {
 761     local $_[0];
 762 }
 763 tie @a, 'main';
 764 tie %h, 'main';
 765
 766 foreach ($a[0], $h{a}) {
 767     f($_);
 768 }
 769 # on failure, chucks up 'premature free' etc messages
 770 EXPECT
 771 ########
 772 # RT 5475:
 773 # the initial fix for this bug caused tied scalar FETCH to be called
 774 # multiple times when that scalar was an element in an array. Check it
 775 # only gets called once now.
 776
 777 sub TIESCALAR { bless [], $_[0] }
 778 my $c = 0;
 779 sub FETCH { $c++; 0 }
 780 sub FETCHSIZE { 1 }
 781 sub STORE { $c += 100; 0 }
 782
 783
 784 my (@a, %h);
 785 tie $a[0],   'main';
 786 tie $h{foo}, 'main';
 787
 788 my $i = 0;
 789 my $x = $a[0] + $h{foo} + $a[$i] + (@a)[0];
 790 print "x=$x c=$c\n";
 791 EXPECT
 792 x=0 c=4
 793 ########
 794 # Bug 68192 - numeric ops not calling mg_get when tied scalar holds a ref
 795 sub TIESCALAR { bless {}, __PACKAGE__ };
 796 sub STORE {};
 797 sub FETCH {
 798  print "fetching... "; # make sure FETCH is called once per op
 799  123456
 800 };
 801 my $foo;
 802 tie $foo, __PACKAGE__;
 803 my $a = [1234567];
 804 $foo = $a;
 805 print "+   ", 0 + $foo, "\n";
 806 print "**  ", $foo**1, "\n";
 807 print "*   ", $foo*1, "\n";
 808 print "/   ", $foo*1, "\n";
 809 print "%   ", $foo%123457, "\n";
 810 print "-   ", $foo-0, "\n";
 811 print "neg ", - -$foo, "\n";
 812 print "int ", int $foo, "\n";
 813 print "abs ", abs $foo, "\n";
 814 print "==  ", 123456 == $foo, "\n";
 815 print "<   ", 123455 < $foo, "\n";
 816 print ">   ", 123457 > $foo, "\n";
 817 print "<=  ", 123456 <= $foo, "\n";
 818 print ">=  ", 123456 >= $foo, "\n";
 819 print "!=  ", 0 != $foo, "\n";
 820 print "<=> ", 123457 <=> $foo, "\n";
 821 EXPECT
 822 fetching... +   123456
 823 fetching... **  123456
 824 fetching... *   123456
 825 fetching... /   123456
 826 fetching... %   123456
 827 fetching... -   123456
 828 fetching... neg 123456
 829 fetching... int 123456
 830 fetching... abs 123456
 831 fetching... ==  1
 832 fetching... <   1
 833 fetching... >   1
 834 fetching... <=  1
 835 fetching... >=  1
 836 fetching... !=  1
 837 fetching... <=> 1
 838 ########
 839 # Ties returning overloaded objects
 840 {
 841  package overloaded;
 842  use overload
 843   '*{}' => sub { print '*{}'; \*100 },
 844   '@{}' => sub { print '@{}'; \@100 },
 845   '%{}' => sub { print '%{}'; \%100 },
 846   '${}' => sub { print '${}'; \$100 },
 847   map {
 848    my $op = $_;
 849    $_ => sub { print "$op"; 100 }
 850   } qw< 0+ "" + ** * / % - neg int abs == < > <= >= != <=> >
 851 }
 852 $o = bless [], overloaded;
 853
 854 sub TIESCALAR { bless {}, "" }
 855 sub FETCH { print "fetching... "; $o }
 856 sub STORE{}
 857 tie $ghew, "";
 858
 859 $ghew=undef; 1+$ghew; print "\n";
 860 $ghew=undef; $ghew**1; 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; print "\n";
 866 $ghew=undef; int $ghew; print "\n";
 867 $ghew=undef; abs $ghew; print "\n";
 868 $ghew=undef; 1 == $ghew; print "\n";
 869 $ghew=undef; $ghew<1; print "\n";
 870 $ghew=undef; $ghew>1; print "\n";
 871 $ghew=undef; $ghew<=1; print "\n";
 872 $ghew=undef; $ghew >=1; print "\n";
 873 $ghew=undef; $ghew != 1; print "\n";
 874 $ghew=undef; $ghew<=>1; print "\n";
 875 $ghew=\*shrext; *$ghew; print "\n";
 876 $ghew=\@spled; @$ghew; print "\n";
 877 $ghew=\%frit; %$ghew; print "\n";
 878 $ghew=\$drile; $$ghew; print "\n";
 879 EXPECT
 880 fetching... +
 881 fetching... **
 882 fetching... *
 883 fetching... /
 884 fetching... %
 885 fetching... -
 886 fetching... neg
 887 fetching... int
 888 fetching... abs
 889 fetching... ==
 890 fetching... <
 891 fetching... >
 892 fetching... <=
 893 fetching... >=
 894 fetching... !=
 895 fetching... <=>
 896 fetching... *{}
 897 fetching... @{}
 898 fetching... %{}
 899 fetching... ${}