This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
5628694b8fbdaf5fd5acda4660f3ef424a93797f
[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 $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... ${}
900 ########
901 # RT 51636: segmentation fault with array ties
902
903 tie my @a, 'T';
904 @a = (1);
905 print "ok\n"; # if we got here we didn't crash
906
907 package T;
908
909 sub TIEARRAY { bless {} }
910 sub STORE    { tie my @b, 'T' }
911 sub CLEAR    { }
912 sub EXTEND   { }
913
914 EXPECT
915 ok
916 ########
917 # RT 8438: Tied scalars don't call FETCH when subref is dereferenced
918
919 sub TIESCALAR { bless {} }
920
921 my $fetch = 0;
922 my $called = 0;
923 sub FETCH { $fetch++; sub { $called++ } }
924
925 tie my $f, 'main';
926 $f->(1) for 1,2;
927 print "fetch=$fetch\ncalled=$called\n";
928
929 EXPECT
930 fetch=2
931 called=2
932 ########
933 # tie mustn't attempt to call methods on bareword filehandles.
934 sub IO::File::TIEARRAY {
935     die "Did not want to invoke IO::File::TIEARRAY";
936 }
937 fileno FOO; tie @a, "FOO"
938 EXPECT
939 Can't locate object method "TIEARRAY" via package "FOO" at - line 5.