This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Revert "Revert "[perl #77496] tied gets scalars and globs confused""
[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
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 # tied() should still work on tied scalars after glob assignment
1013 sub TIESCALAR {bless[]}
1014 sub FETCH {*foo}
1015 sub f::TIEHANDLE{bless[],f}
1016 tie *foo, "f";
1017 tie $rin, "";
1018 [$rin]; # call FETCH
1019 print ref tied $rin, "\n";
1020 print ref tied *$rin, "\n";
1021 EXPECT
1022 main
1023 f