This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
RT #75468: readline ignores <> overloading when arg is tied
[perl5.git] / t / op / tie.t
CommitLineData
49d42823
PP
1#!./perl
2
d87ebaca
YST
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#
49d42823
PP
11
12chdir 't' if -d 't';
20822f61 13@INC = '../lib';
49d42823
PP
14$ENV{PERL5LIB} = "../lib";
15
16$|=1;
17
18undef $/;
d87ebaca 19@prgs = split /^########\n/m, <DATA>;
49d42823 20
d87ebaca
YST
21require './test.pl';
22plan(tests => scalar @prgs);
49d42823 23for (@prgs){
d87ebaca
YST
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 //;
49d42823
PP
31 $results =~ s/\n+$//;
32 $expected =~ s/\n+$//;
d87ebaca
YST
33
34 fresh_perl_is($prog, $expected, {}, $testname);
49d42823
PP
35}
36
37__END__
38
39# standard behaviour, without any extra references
40use Tie::Hash ;
41tie %h, Tie::StdHash;
42untie %h;
43EXPECT
44########
45
a29a5827
NIS
46# standard behaviour, without any extra references
47use Tie::Hash ;
48{package Tie::HashUntie;
49 use base 'Tie::StdHash';
50 sub UNTIE
51 {
52 warn "Untied\n";
53 }
54}
55tie %h, Tie::HashUntie;
56untie %h;
57EXPECT
58Untied
59########
60
49d42823
PP
61# standard behaviour, with 1 extra reference
62use Tie::Hash ;
63$a = tie %h, Tie::StdHash;
64untie %h;
65EXPECT
66########
67
68# standard behaviour, with 1 extra reference via tied
69use Tie::Hash ;
70tie %h, Tie::StdHash;
71$a = tied %h;
72untie %h;
73EXPECT
74########
75
76# standard behaviour, with 1 extra reference which is destroyed
77use Tie::Hash ;
78$a = tie %h, Tie::StdHash;
79$a = 0 ;
80untie %h;
81EXPECT
82########
83
84# standard behaviour, with 1 extra reference via tied which is destroyed
85use Tie::Hash ;
86tie %h, Tie::StdHash;
87$a = tied %h;
88$a = 0 ;
89untie %h;
90EXPECT
91########
92
93# strict behaviour, without any extra references
4438c4b7 94use warnings 'untie';
49d42823
PP
95use Tie::Hash ;
96tie %h, Tie::StdHash;
97untie %h;
98EXPECT
99########
100
101# strict behaviour, with 1 extra references generating an error
4438c4b7 102use warnings 'untie';
49d42823
PP
103use Tie::Hash ;
104$a = tie %h, Tie::StdHash;
105untie %h;
106EXPECT
d87ebaca 107untie attempted while 1 inner references still exist at - line 6.
49d42823
PP
108########
109
110# strict behaviour, with 1 extra references via tied generating an error
4438c4b7 111use warnings 'untie';
49d42823
PP
112use Tie::Hash ;
113tie %h, Tie::StdHash;
114$a = tied %h;
115untie %h;
116EXPECT
d87ebaca 117untie attempted while 1 inner references still exist at - line 7.
49d42823
PP
118########
119
120# strict behaviour, with 1 extra references which are destroyed
4438c4b7 121use warnings 'untie';
49d42823
PP
122use Tie::Hash ;
123$a = tie %h, Tie::StdHash;
124$a = 0 ;
125untie %h;
126EXPECT
127########
128
129# strict behaviour, with extra 1 references via tied which are destroyed
4438c4b7 130use warnings 'untie';
49d42823
PP
131use Tie::Hash ;
132tie %h, Tie::StdHash;
133$a = tied %h;
134$a = 0 ;
135untie %h;
136EXPECT
137########
138
87f0b213 139# strict error behaviour, with 2 extra references
4438c4b7 140use warnings 'untie';
49d42823
PP
141use Tie::Hash ;
142$a = tie %h, Tie::StdHash;
143$b = tied %h ;
144untie %h;
145EXPECT
d87ebaca 146untie attempted while 2 inner references still exist at - line 7.
49d42823
PP
147########
148
149# strict behaviour, check scope of strictness.
4438c4b7 150no warnings 'untie';
49d42823
PP
151use Tie::Hash ;
152$A = tie %H, Tie::StdHash;
153$C = $B = tied %H ;
154{
4438c4b7 155 use warnings 'untie';
49d42823
PP
156 use Tie::Hash ;
157 tie %h, Tie::StdHash;
158 untie %h;
159}
160untie %H;
161EXPECT
33c27489 162########
d87ebaca 163
ae21d580 164# Forbidden aggregate self-ties
33c27489 165sub Self::TIEHASH { bless $_[1], $_[0] }
ae21d580 166{
d87ebaca 167 my %c;
ae21d580
JH
168 tie %c, 'Self', \%c;
169}
170EXPECT
d87ebaca 171Self-ties of arrays and hashes are not supported at - line 6.
ae21d580 172########
d87ebaca 173
ae21d580 174# Allowed scalar self-ties
d87ebaca 175my $destroyed = 0;
ae21d580 176sub Self::TIESCALAR { bless $_[1], $_[0] }
d87ebaca 177sub Self::DESTROY { $destroyed = 1; }
33c27489 178{
ae21d580 179 my $c = 42;
ae21d580 180 tie $c, 'Self', \$c;
33c27489 181}
d87ebaca 182die "self-tied scalar not DESTROYed" unless $destroyed == 1;
7bb043c3 183EXPECT
83f527ec 184########
3ca7705e 185
b5ccf5f2 186# Allowed glob self-ties
87f0b213
JH
187my $destroyed = 0;
188my $printed = 0;
189sub Self2::TIEHANDLE { bless $_[1], $_[0] }
190sub Self2::DESTROY { $destroyed = 1; }
191sub Self2::PRINT { $printed = 1; }
192{
193 use Symbol;
194 my $c = gensym;
195 tie *$c, 'Self2', $c;
196 print $c 'Hello';
197}
198die "self-tied glob not PRINTed" unless $printed == 1;
43bb546a 199die "self-tied glob not DESTROYed" unless $destroyed == 1;
87f0b213
JH
200EXPECT
201########
202
203# Allowed IO self-ties
204my $destroyed = 0;
205sub Self3::TIEHANDLE { bless $_[1], $_[0] }
206sub Self3::DESTROY { $destroyed = 1; }
b5ccf5f2 207sub Self3::PRINT { $printed = 1; }
87f0b213
JH
208{
209 use Symbol 'geniosym';
210 my $c = geniosym;
211 tie *$c, 'Self3', $c;
b5ccf5f2 212 print $c 'Hello';
87f0b213 213}
b5ccf5f2 214die "self-tied IO not PRINTed" unless $printed == 1;
43bb546a 215die "self-tied IO not DESTROYed" unless $destroyed == 1;
87f0b213
JH
216EXPECT
217########
0b2c215a 218
b5ccf5f2
YST
219# TODO IO "self-tie" via TEMP glob
220my $destroyed = 0;
221sub Self3::TIEHANDLE { bless $_[1], $_[0] }
222sub Self3::DESTROY { $destroyed = 1; }
223sub Self3::PRINT { $printed = 1; }
224{
225 use Symbol 'geniosym';
226 my $c = geniosym;
227 tie *$c, 'Self3', \*$c;
228 print $c 'Hello';
229}
230die "IO tied to TEMP glob not PRINTed" unless $printed == 1;
231die "IO tied to TEMP glob not DESTROYed" unless $destroyed == 1;
232EXPECT
233########
234
d87ebaca
YST
235# Interaction of tie and vec
236
237my ($a, $b);
238use Tie::Scalar;
239tie $a,Tie::StdScalar or die;
240vec($b,1,1)=1;
241$a = $b;
242vec($a,1,1)=0;
243vec($b,1,1)=0;
244die unless $a eq $b;
245EXPECT
246########
247
248# correct unlocalisation of tied hashes (patch #16431)
249use Tie::Hash ;
250tie %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'};
254EXPECT
255########
256
257# An attempt at lvalueable barewords broke this
258tie FH, 'main';
259EXPECT
260Can't modify constant item in tie at - line 3, near "'main';"
261Execution of - aborted due to compilation errors.
eb85dfd3
DM
262########
263
264# localizing tied hash slices
265$ENV{FooA} = 1;
266$ENV{FooB} = 2;
267print exists $ENV{FooA} ? 1 : 0, "\n";
268print exists $ENV{FooB} ? 2 : 0, "\n";
269print 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}
276print exists $ENV{FooA} ? 7 : 0, "\n";
277print exists $ENV{FooB} ? 8 : 0, "\n";
278print exists $ENV{FooC} ? 9 : 0, "\n"; # this should not exist
279EXPECT
2801
2812
2820
2834
2845
2856
2867
2878
2880
b77f7d40
YST
289########
290#
291# FETCH freeing tie'd SV
292sub TIESCALAR { bless [] }
293sub FETCH { *a = \1; 1 }
294tie $a, 'main';
295print $a;
296EXPECT
dd28f7bb
DM
297########
298
299# [20020716.007] - nested FETCHES
300
301sub F1::TIEARRAY { bless [], 'F1' }
302sub F1::FETCH { 1 }
303my @f1;
304tie @f1, 'F1';
305
306sub F2::TIEARRAY { bless [2], 'F2' }
307sub F2::FETCH { my $self = shift; my $x = $f1[3]; $self }
308my @f2;
309tie @f2, 'F2';
310
311print $f2[4][0],"\n";
312
313sub F3::TIEHASH { bless [], 'F3' }
314sub F3::FETCH { 1 }
315my %f3;
316tie %f3, 'F3';
317
318sub F4::TIEHASH { bless [3], 'F4' }
319sub F4::FETCH { my $self = shift; my $x = $f3{3}; $self }
320my %f4;
321tie %f4, 'F4';
322
323print $f4{'foo'}[0],"\n";
324
325EXPECT
3262
3273
38193a09
AM
328########
329# test untie() from within FETCH
330package Foo;
331sub TIESCALAR { my $pkg = shift; return bless [@_], $pkg; }
332sub FETCH {
333 my $self = shift;
334 my ($obj, $field) = @$self;
335 untie $obj->{$field};
336 $obj->{$field} = "Bar";
337}
338package main;
339tie $a->{foo}, "Foo", $a, "foo";
39cf747a 340my $s = $a->{foo}; # access once
38193a09
AM
341# the hash element should not be tied anymore
342print defined tied $a->{foo} ? "not ok" : "ok";
343EXPECT
344ok
be65207d
DM
345########
346# the tmps returned by FETCH should appear to be SCALAR
347# (even though they are now implemented using PVLVs.)
348package X;
349sub TIEHASH { bless {} }
350sub TIEARRAY { bless {} }
351sub FETCH {1}
352my (%h, @a);
353tie %h, 'X';
354tie @a, 'X';
355my $r1 = \$h{1};
356my $r2 = \$a[0];
357my $s = "$r1 ". ref($r1) . " $r2 " . ref($r2);
358$s=~ s/\(0x\w+\)//g;
359print $s, "\n";
360EXPECT
361SCALAR SCALAR SCALAR SCALAR
b7056d9c
JH
362########
363# [perl #23287] segfault in untie
364sub TIESCALAR { bless $_[1], $_[0] }
365my $var;
366tie $var, 'main', \$var;
367untie $var;
368EXPECT
16e0ce55
JH
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)."
378use strict;
379use warnings;
380package MyTied;
381sub TIESCALAR {
382 my ($class,$code) = @_;
383 bless $code, $class;
384}
385sub FETCH {
386 my $self = shift;
387 print "Untie\n";
388 $self->();
389}
390package main;
391my $var;
392tie $var, 'MyTied', sub { untie $var; 4 };
393print "One\n";
394print "$var\n";
395print "Two\n";
396print "$var\n";
397print "Three\n";
398print "$var\n";
399EXPECT
400One
401Untie
4024
403Two
4044
405Three
4064
dd12389b
JH
407########
408# [perl #22297] cannot untie scalar from within tied FETCH
409my $counter = 0;
410my $x = 7;
411my $ref = \$x;
412tie $x, 'Overlay', $ref, $x;
413my $y;
414$y = $x;
415$y = $x;
416$y = $x;
417$y = $x;
418#print "WILL EXTERNAL UNTIE $ref\n";
419untie $$ref;
420$y = $x;
421$y = $x;
422$y = $x;
423$y = $x;
424#print "counter = $counter\n";
425
426print (($counter == 1) ? "ok\n" : "not ok\n");
427
428package Overlay;
429
430sub TIESCALAR
431{
432 my $pkg = shift;
433 my ($ref, $val) = @_;
434 return bless [ $ref, $val ], $pkg;
435}
436
437sub 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}
446EXPECT
447ok
6c0731c3
RC
448########
449
e23d9e2f 450# [perl #948] cannot meaningfully tie $,
6c0731c3
RC
451package TieDollarComma;
452
453sub TIESCALAR {
454 my $pkg = shift;
455 return bless \my $x, $pkg;
456}
457
458sub STORE {
459 my $self = shift;
460 $$self = shift;
461 print "STORE set '$$self'\n";
462}
463
464sub FETCH {
465 my $self = shift;
e23d9e2f 466 print "<FETCH>";
6c0731c3
RC
467 return $$self;
468}
469package main;
470
471tie $,, 'TieDollarComma';
472$, = 'BOBBINS';
473print "join", "things", "up\n";
474EXPECT
475STORE set 'BOBBINS'
e23d9e2f 476join<FETCH>BOBBINSthings<FETCH>BOBBINSup
a3bcc51e
TP
477########
478
479# test SCALAR method
480package TieScalar;
481
482sub TIEHASH {
483 my $pkg = shift;
484 bless { } => $pkg;
485}
486
487sub STORE {
488 $_[0]->{$_[1]} = $_[2];
489}
490
491sub FETCH {
492 $_[0]->{$_[1]}
493}
494
495sub CLEAR {
496 %{ $_[0] } = ();
497}
498
499sub SCALAR {
500 print "SCALAR\n";
501 return 0 if ! keys %{$_[0]};
502 sprintf "%i/%i", scalar keys %{$_[0]}, scalar keys %{$_[0]};
503}
504
505package main;
506tie my %h => "TieScalar";
507$h{key1} = "val1";
508$h{key2} = "val2";
867fa1e2
YO
509print scalar %h, "\n"
510 if %h; # this should also call SCALAR but implicitly
a3bcc51e 511%h = ();
867fa1e2
YO
512print scalar %h, "\n"
513 if !%h; # this should also call SCALAR but implicitly
a3bcc51e
TP
514EXPECT
515SCALAR
867fa1e2 516SCALAR
a3bcc51e
TP
5172/2
518SCALAR
867fa1e2 519SCALAR
a3bcc51e
TP
5200
521########
522
523# test scalar on tied hash when no SCALAR method has been given
524package TieScalar;
525
526sub TIEHASH {
527 my $pkg = shift;
528 bless { } => $pkg;
529}
530sub STORE {
531 $_[0]->{$_[1]} = $_[2];
532}
533sub FETCH {
534 $_[0]->{$_[1]}
535}
536sub CLEAR {
537 %{ $_[0] } = ();
538}
539sub FIRSTKEY {
540 my $a = keys %{ $_[0] };
541 print "FIRSTKEY\n";
542 each %{ $_[0] };
543}
544
545package main;
546tie my %h => "TieScalar";
547
548if (!%h) {
549 print "empty\n";
550} else {
551 print "not empty\n";
552}
553
554$h{key1} = "val1";
555print "not empty\n" if %h;
556print "not empty\n" if %h;
557print "-->\n";
558my ($k,$v) = each %h;
559print "<--\n";
560print "not empty\n" if %h;
561%h = ();
562print "empty\n" if ! %h;
563EXPECT
564FIRSTKEY
565empty
566FIRSTKEY
567not empty
568FIRSTKEY
569not empty
570-->
571FIRSTKEY
572<--
573not empty
574FIRSTKEY
575empty
2b77b520
YST
576########
577sub TIESCALAR { bless {} }
578sub FETCH { my $x = 3.3; 1 if 0+$x; $x }
579tie $h, "main";
580print $h,"\n";
581EXPECT
5823.3
c75ab21a
RH
583########
584sub TIESCALAR { bless {} }
585sub FETCH { shift()->{i} ++ }
586tie $h, "main";
587print $h.$h;
588EXPECT
58901
64207fde 590########
7de9d14e 591# Bug 53482 (and maybe others)
64207fde
RB
592sub TIESCALAR { my $foo = $_[1]; bless \$foo, $_[0] }
593sub FETCH { ${$_[0]} }
7de9d14e
B
594tie my $x1, "main", 2;
595tie my $y1, "main", 8;
596print $x1 | $y1;
597print $x1 | $y1;
598tie my $x2, "main", "2";
599tie my $y2, "main", "8";
600print $x2 | $y2;
601print $x2 | $y2;
602EXPECT
6031010::
1baaf5d7
NC
604########
605# Bug 36267
606sub TIEHASH { bless {}, $_[0] }
607sub STORE { $_[0]->{$_[1]} = $_[2] }
608sub FIRSTKEY { my $a = scalar keys %{$_[0]}; each %{$_[0]} }
609sub NEXTKEY { each %{$_[0]} }
610sub DELETE { delete $_[0]->{$_[1]} }
611sub CLEAR { %{$_[0]} = () }
612$h{b}=1;
613delete $h{b};
614print scalar keys %h, "\n";
615tie %h, 'main';
616$i{a}=1;
617%h = %i;
618untie %h;
619print scalar keys %h, "\n";
620EXPECT
6210
6220
ced497e2
YST
623########
624# Bug 37731
625sub foo::TIESCALAR { bless {value => $_[1]}, $_[0] }
626sub foo::FETCH { $_[0]->{value} }
627tie my $VAR, 'foo', '42';
628foreach my $var ($VAR) {
629 print +($var eq $VAR) ? "yes\n" : "no\n";
630}
631EXPECT
632yes
f4c21a45
DM
633########
634sub TIEARRAY { bless [], 'main' }
635{
636 local @a;
637 tie @a, 'main';
638}
639print "tied\n" if tied @a;
640EXPECT
641########
642sub TIEHASH { bless [], 'main' }
643{
644 local %h;
645 tie %h, 'main';
646}
647print "tied\n" if tied %h;
648EXPECT
099be4f1
DM
649########
650# RT 20727: PL_defoutgv is left as a tied element
651sub TIESCALAR { return bless {}, 'main' }
652
653sub STORE {
654 select($_[1]);
655 $_[1] = 1;
656 select(); # this used to coredump or assert fail
657}
658tie $SELECT, 'main';
659$SELECT = *STDERR;
660EXPECT
27e90453
DM
661########
662# RT 23810: eval in die in FETCH can corrupt context stack
663
664my $file = 'rt23810.pm';
665
666my $e;
667my $s;
668
669sub 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
686sub TIEHASH { bless {} }
687
688sub 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}
727my %foo;
728tie %foo, "main";
729
730for 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}
7361 while unlink $file;
737
738$foo{'exit'};
739print "overshot main\n"; # shouldn't reach here
740
741EXPECT
742eval: s0=EVAL-BD-BS-E1-S1-E2-S2-S2-S2-S2-S2-S2-S2-S2-S2-S2-R
743eval: s1=EVAL-BD-BS-E1-S1-E2-S2-S2-S2-S2-S2-S2-S2-S2-S2-S2-R
744eval: s2=EVAL-BD-BS-E1-S1-E2-S2-S2-S2-S2-S2-S2-S2-S2-S2-S2-R
745eval: s3=EVAL-BD-BS-E1-S1-E2-S2-S2-S2-S2-S2-S2-S2-S2-S2-S2-R
746require: s0=REQUIRE-0-ERQ-ENDRQ-1-ERQ-ENDRQ-2-ERQ-ENDRQ-3-ERQ-ENDRQ-R
747require: s1=REQUIRE-0-RQ
748require: s2=REQUIRE-0-ERQ-ENDRQ-1-ERQ-ENDRQ-2-ERQ-ENDRQ-3-ERQ-ENDRQ-R
749require: s3=REQUIRE-0-RQ
459defa1
DM
750########
751# RT 8857: STORE incorrectly invoked for local($_) on aliased tied array
752# element
753
754sub TIEARRAY { bless [], $_[0] }
755sub TIEHASH { bless [], $_[0] }
756sub FETCH { $_[0]->[$_[1]] }
757sub STORE { $_[0]->[$_[1]] = $_[2] }
758
759
760sub f {
761 local $_[0];
762}
763tie @a, 'main';
764tie %h, 'main';
27e90453 765
459defa1
DM
766foreach ($a[0], $h{a}) {
767 f($_);
768}
769# on failure, chucks up 'premature free' etc messages
770EXPECT
39cf747a
DM
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
777sub TIESCALAR { bless [], $_[0] }
778my $c = 0;
779sub FETCH { $c++; 0 }
780sub FETCHSIZE { 1 }
781sub STORE { $c += 100; 0 }
782
783
784my (@a, %h);
785tie $a[0], 'main';
786tie $h{foo}, 'main';
787
788my $i = 0;
789my $x = $a[0] + $h{foo} + $a[$i] + (@a)[0];
790print "x=$x c=$c\n";
791EXPECT
792x=0 c=4
6a5f8cbd
FC
793########
794# Bug 68192 - numeric ops not calling mg_get when tied scalar holds a ref
795sub TIESCALAR { bless {}, __PACKAGE__ };
796sub STORE {};
797sub FETCH {
798 print "fetching... "; # make sure FETCH is called once per op
799 123456
800};
801my $foo;
802tie $foo, __PACKAGE__;
803my $a = [1234567];
804$foo = $a;
805print "+ ", 0 + $foo, "\n";
806print "** ", $foo**1, "\n";
807print "* ", $foo*1, "\n";
808print "/ ", $foo*1, "\n";
809print "% ", $foo%123457, "\n";
810print "- ", $foo-0, "\n";
811print "neg ", - -$foo, "\n";
812print "int ", int $foo, "\n";
813print "abs ", abs $foo, "\n";
814print "== ", 123456 == $foo, "\n";
815print "< ", 123455 < $foo, "\n";
816print "> ", 123457 > $foo, "\n";
817print "<= ", 123456 <= $foo, "\n";
818print ">= ", 123456 >= $foo, "\n";
819print "!= ", 0 != $foo, "\n";
820print "<=> ", 123457 <=> $foo, "\n";
821EXPECT
822fetching... + 123456
823fetching... ** 123456
824fetching... * 123456
825fetching... / 123456
826fetching... % 123456
827fetching... - 123456
828fetching... neg 123456
829fetching... int 123456
830fetching... abs 123456
831fetching... == 1
832fetching... < 1
833fetching... > 1
834fetching... <= 1
835fetching... >= 1
836fetching... != 1
837fetching... <=> 1
838########
839# Ties returning overloaded objects
840{
841 package overloaded;
842 use overload
bb1bc619
FCR
843 '*{}' => sub { print '*{}'; \*100 },
844 '@{}' => sub { print '@{}'; \@100 },
845 '%{}' => sub { print '%{}'; \%100 },
846 '${}' => sub { print '${}'; \$100 },
6a5f8cbd
FC
847 map {
848 my $op = $_;
849 $_ => sub { print "$op"; 100 }
9e27fd70 850 } qw< 0+ "" + ** * / % - neg int abs == < > <= >= != <=> <> >
6a5f8cbd
FC
851}
852$o = bless [], overloaded;
853
854sub TIESCALAR { bless {}, "" }
855sub FETCH { print "fetching... "; $o }
856sub STORE{}
857tie $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";
9e27fd70 875$ghew=undef; <$ghew>; print "\n";
bb1bc619
FCR
876$ghew=\*shrext; *$ghew; print "\n";
877$ghew=\@spled; @$ghew; print "\n";
878$ghew=\%frit; %$ghew; print "\n";
879$ghew=\$drile; $$ghew; print "\n";
6a5f8cbd
FC
880EXPECT
881fetching... +
882fetching... **
883fetching... *
884fetching... /
885fetching... %
886fetching... -
887fetching... neg
888fetching... int
889fetching... abs
890fetching... ==
891fetching... <
892fetching... >
893fetching... <=
894fetching... >=
895fetching... !=
896fetching... <=>
9e27fd70 897fetching... <>
bb1bc619
FCR
898fetching... *{}
899fetching... @{}
900fetching... %{}
901fetching... ${}
3a19377b
DM
902########
903# RT 51636: segmentation fault with array ties
904
905tie my @a, 'T';
906@a = (1);
907print "ok\n"; # if we got here we didn't crash
908
909package T;
910
911sub TIEARRAY { bless {} }
912sub STORE { tie my @b, 'T' }
913sub CLEAR { }
914sub EXTEND { }
915
916EXPECT
917ok
7c75014e
DM
918########
919# RT 8438: Tied scalars don't call FETCH when subref is dereferenced
920
921sub TIESCALAR { bless {} }
922
923my $fetch = 0;
924my $called = 0;
925sub FETCH { $fetch++; sub { $called++ } }
926
927tie my $f, 'main';
928$f->(1) for 1,2;
929print "fetch=$fetch\ncalled=$called\n";
930
931EXPECT
932fetch=2
933called=2
086d2913
NC
934########
935# tie mustn't attempt to call methods on bareword filehandles.
936sub IO::File::TIEARRAY {
937 die "Did not want to invoke IO::File::TIEARRAY";
938}
939fileno FOO; tie @a, "FOO"
940EXPECT
941Can't locate object method "TIEARRAY" via package "FOO" at - line 5.