This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
e78fd5e6b554dab41796771d12994a0c31c73c28
[perl5.git] / 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 ########
1293
1294 # NAME Test that tying a hash does not leak a deleted iterator
1295 # This produced unbalanced string table warnings under
1296 # PERL_DESTRUCT_LEVEL=2.
1297 package l {
1298     sub TIEHASH{bless[]}
1299 }
1300 $h = {foo=>0};
1301 each %$h;
1302 delete $$h{foo};
1303 tie %$h, 'l';
1304 EXPECT
1305 ########
1306
1307 # NAME EXISTS on arrays
1308 sub TIEARRAY{bless[]};
1309 sub FETCHSIZE { 50 }
1310 sub EXISTS { print "does $_[1] exist?\n" }
1311 tie @a, "";
1312 exists $a[1];
1313 exists $a[-1];
1314 $NEGATIVE_INDICES=1;
1315 exists $a[-1];
1316 EXPECT
1317 does 1 exist?
1318 does 49 exist?
1319 does -1 exist?
1320 ########
1321
1322 # Crash when using negative index on array tied to non-object
1323 sub TIEARRAY{bless[]};
1324 ${\tie @a, ""} = undef;
1325 eval { $_ = $a[-1] }; print $@;
1326 eval { $a[-1] = '' }; print $@;
1327 eval { delete $a[-1] }; print $@;
1328 eval { exists $a[-1] }; print $@;
1329
1330 EXPECT
1331 Can't call method "FETCHSIZE" on an undefined value at - line 5.
1332 Can't call method "FETCHSIZE" on an undefined value at - line 6.
1333 Can't call method "FETCHSIZE" on an undefined value at - line 7.
1334 Can't call method "FETCHSIZE" on an undefined value at - line 8.
1335 ########
1336
1337 # Assigning vstrings to tied scalars
1338 sub TIESCALAR{bless[]};
1339 sub STORE { print ref \$_[1], "\n" }
1340 tie $x, ""; $x = v3;
1341 EXPECT
1342 VSTRING
1343 ########
1344
1345 # [perl #27010] Tying deferred elements
1346 $\="\n";
1347 sub TIESCALAR{bless[]};
1348 sub {
1349     tie $_[0], "";
1350     print ref tied $h{k};
1351     tie $h{l}, "";
1352     print ref tied $_[1];
1353     untie $h{k};
1354     print tied $_[0] // 'undef';
1355     untie $_[1];
1356     print tied $h{l} // 'undef';
1357     # check that tied and untie do not autovivify
1358     # XXX should they autovivify?
1359     tied $_[2];
1360     print exists $h{m} ? "yes" : "no";
1361     untie $_[2];
1362     print exists $h{m} ? "yes" : "no";
1363 }->($h{k}, $h{l}, $h{m});
1364 EXPECT
1365 main
1366 main
1367 undef
1368 undef
1369 no
1370 no
1371 ########
1372
1373 # [perl #78194] Passing op return values to tie constructors
1374 sub TIEARRAY{
1375     print \$_[1] == \$_[1] ? "ok\n" : "not ok\n";
1376 };
1377 tie @a, "", "$a$b";
1378 EXPECT
1379 ok