This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Weak refs to pad hvs should go stale
[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';
5f7e0818 14require './test.pl';
49d42823
PP
15
16$|=1;
17
5f7e0818 18run_multiple_progs('', \*DATA);
d87ebaca 19
5f7e0818 20done_testing();
49d42823
PP
21
22__END__
23
24# standard behaviour, without any extra references
25use Tie::Hash ;
26tie %h, Tie::StdHash;
27untie %h;
28EXPECT
29########
30
a29a5827
NIS
31# standard behaviour, without any extra references
32use Tie::Hash ;
33{package Tie::HashUntie;
34 use base 'Tie::StdHash';
35 sub UNTIE
36 {
37 warn "Untied\n";
38 }
39}
40tie %h, Tie::HashUntie;
41untie %h;
42EXPECT
43Untied
44########
45
49d42823
PP
46# standard behaviour, with 1 extra reference
47use Tie::Hash ;
48$a = tie %h, Tie::StdHash;
49untie %h;
50EXPECT
51########
52
53# standard behaviour, with 1 extra reference via tied
54use Tie::Hash ;
55tie %h, Tie::StdHash;
56$a = tied %h;
57untie %h;
58EXPECT
59########
60
61# standard behaviour, with 1 extra reference which is destroyed
62use Tie::Hash ;
63$a = tie %h, Tie::StdHash;
64$a = 0 ;
65untie %h;
66EXPECT
67########
68
69# standard behaviour, with 1 extra reference via tied which is destroyed
70use Tie::Hash ;
71tie %h, Tie::StdHash;
72$a = tied %h;
73$a = 0 ;
74untie %h;
75EXPECT
76########
77
78# strict behaviour, without any extra references
4438c4b7 79use warnings 'untie';
49d42823
PP
80use Tie::Hash ;
81tie %h, Tie::StdHash;
82untie %h;
83EXPECT
84########
85
86# strict behaviour, with 1 extra references generating an error
4438c4b7 87use warnings 'untie';
49d42823
PP
88use Tie::Hash ;
89$a = tie %h, Tie::StdHash;
90untie %h;
91EXPECT
d87ebaca 92untie attempted while 1 inner references still exist at - line 6.
49d42823
PP
93########
94
95# strict behaviour, with 1 extra references via tied generating an error
4438c4b7 96use warnings 'untie';
49d42823
PP
97use Tie::Hash ;
98tie %h, Tie::StdHash;
99$a = tied %h;
100untie %h;
101EXPECT
d87ebaca 102untie attempted while 1 inner references still exist at - line 7.
49d42823
PP
103########
104
105# strict behaviour, with 1 extra references which are destroyed
4438c4b7 106use warnings 'untie';
49d42823
PP
107use Tie::Hash ;
108$a = tie %h, Tie::StdHash;
109$a = 0 ;
110untie %h;
111EXPECT
112########
113
114# strict behaviour, with extra 1 references via tied which are destroyed
4438c4b7 115use warnings 'untie';
49d42823
PP
116use Tie::Hash ;
117tie %h, Tie::StdHash;
118$a = tied %h;
119$a = 0 ;
120untie %h;
121EXPECT
122########
123
87f0b213 124# strict error behaviour, with 2 extra references
4438c4b7 125use warnings 'untie';
49d42823
PP
126use Tie::Hash ;
127$a = tie %h, Tie::StdHash;
128$b = tied %h ;
129untie %h;
130EXPECT
d87ebaca 131untie attempted while 2 inner references still exist at - line 7.
49d42823
PP
132########
133
134# strict behaviour, check scope of strictness.
4438c4b7 135no warnings 'untie';
49d42823
PP
136use Tie::Hash ;
137$A = tie %H, Tie::StdHash;
138$C = $B = tied %H ;
139{
4438c4b7 140 use warnings 'untie';
49d42823
PP
141 use Tie::Hash ;
142 tie %h, Tie::StdHash;
143 untie %h;
144}
145untie %H;
146EXPECT
33c27489 147########
d87ebaca 148
ae21d580 149# Forbidden aggregate self-ties
33c27489 150sub Self::TIEHASH { bless $_[1], $_[0] }
ae21d580 151{
d87ebaca 152 my %c;
ae21d580
JH
153 tie %c, 'Self', \%c;
154}
155EXPECT
d87ebaca 156Self-ties of arrays and hashes are not supported at - line 6.
ae21d580 157########
d87ebaca 158
ae21d580 159# Allowed scalar self-ties
d87ebaca 160my $destroyed = 0;
ae21d580 161sub Self::TIESCALAR { bless $_[1], $_[0] }
d87ebaca 162sub Self::DESTROY { $destroyed = 1; }
33c27489 163{
ae21d580 164 my $c = 42;
ae21d580 165 tie $c, 'Self', \$c;
33c27489 166}
d87ebaca 167die "self-tied scalar not DESTROYed" unless $destroyed == 1;
7bb043c3 168EXPECT
83f527ec 169########
3ca7705e 170
b5ccf5f2 171# Allowed glob self-ties
87f0b213
JH
172my $destroyed = 0;
173my $printed = 0;
174sub Self2::TIEHANDLE { bless $_[1], $_[0] }
175sub Self2::DESTROY { $destroyed = 1; }
176sub Self2::PRINT { $printed = 1; }
177{
178 use Symbol;
179 my $c = gensym;
180 tie *$c, 'Self2', $c;
181 print $c 'Hello';
182}
183die "self-tied glob not PRINTed" unless $printed == 1;
43bb546a 184die "self-tied glob not DESTROYed" unless $destroyed == 1;
87f0b213
JH
185EXPECT
186########
187
188# Allowed IO self-ties
189my $destroyed = 0;
190sub Self3::TIEHANDLE { bless $_[1], $_[0] }
191sub Self3::DESTROY { $destroyed = 1; }
b5ccf5f2 192sub Self3::PRINT { $printed = 1; }
87f0b213
JH
193{
194 use Symbol 'geniosym';
195 my $c = geniosym;
196 tie *$c, 'Self3', $c;
b5ccf5f2 197 print $c 'Hello';
87f0b213 198}
b5ccf5f2 199die "self-tied IO not PRINTed" unless $printed == 1;
43bb546a 200die "self-tied IO not DESTROYed" unless $destroyed == 1;
87f0b213
JH
201EXPECT
202########
0b2c215a 203
b5ccf5f2
YST
204# TODO IO "self-tie" via TEMP glob
205my $destroyed = 0;
206sub Self3::TIEHANDLE { bless $_[1], $_[0] }
207sub Self3::DESTROY { $destroyed = 1; }
208sub Self3::PRINT { $printed = 1; }
209{
210 use Symbol 'geniosym';
211 my $c = geniosym;
212 tie *$c, 'Self3', \*$c;
213 print $c 'Hello';
214}
215die "IO tied to TEMP glob not PRINTed" unless $printed == 1;
216die "IO tied to TEMP glob not DESTROYed" unless $destroyed == 1;
217EXPECT
218########
219
d87ebaca
YST
220# Interaction of tie and vec
221
222my ($a, $b);
223use Tie::Scalar;
224tie $a,Tie::StdScalar or die;
225vec($b,1,1)=1;
226$a = $b;
227vec($a,1,1)=0;
228vec($b,1,1)=0;
229die unless $a eq $b;
230EXPECT
231########
232
233# correct unlocalisation of tied hashes (patch #16431)
234use Tie::Hash ;
235tie %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'};
239EXPECT
240########
241
242# An attempt at lvalueable barewords broke this
243tie FH, 'main';
244EXPECT
245Can't modify constant item in tie at - line 3, near "'main';"
246Execution of - aborted due to compilation errors.
eb85dfd3
DM
247########
248
249# localizing tied hash slices
250$ENV{FooA} = 1;
251$ENV{FooB} = 2;
252print exists $ENV{FooA} ? 1 : 0, "\n";
253print exists $ENV{FooB} ? 2 : 0, "\n";
254print 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}
261print exists $ENV{FooA} ? 7 : 0, "\n";
262print exists $ENV{FooB} ? 8 : 0, "\n";
263print exists $ENV{FooC} ? 9 : 0, "\n"; # this should not exist
264EXPECT
2651
2662
2670
2684
2695
2706
2717
2728
2730
b77f7d40
YST
274########
275#
276# FETCH freeing tie'd SV
277sub TIESCALAR { bless [] }
278sub FETCH { *a = \1; 1 }
279tie $a, 'main';
280print $a;
281EXPECT
dd28f7bb
DM
282########
283
284# [20020716.007] - nested FETCHES
285
286sub F1::TIEARRAY { bless [], 'F1' }
287sub F1::FETCH { 1 }
288my @f1;
289tie @f1, 'F1';
290
291sub F2::TIEARRAY { bless [2], 'F2' }
292sub F2::FETCH { my $self = shift; my $x = $f1[3]; $self }
293my @f2;
294tie @f2, 'F2';
295
296print $f2[4][0],"\n";
297
298sub F3::TIEHASH { bless [], 'F3' }
299sub F3::FETCH { 1 }
300my %f3;
301tie %f3, 'F3';
302
303sub F4::TIEHASH { bless [3], 'F4' }
304sub F4::FETCH { my $self = shift; my $x = $f3{3}; $self }
305my %f4;
306tie %f4, 'F4';
307
308print $f4{'foo'}[0],"\n";
309
310EXPECT
3112
3123
38193a09
AM
313########
314# test untie() from within FETCH
315package Foo;
316sub TIESCALAR { my $pkg = shift; return bless [@_], $pkg; }
317sub FETCH {
318 my $self = shift;
319 my ($obj, $field) = @$self;
320 untie $obj->{$field};
321 $obj->{$field} = "Bar";
322}
323package main;
324tie $a->{foo}, "Foo", $a, "foo";
39cf747a 325my $s = $a->{foo}; # access once
38193a09
AM
326# the hash element should not be tied anymore
327print defined tied $a->{foo} ? "not ok" : "ok";
328EXPECT
329ok
be65207d
DM
330########
331# the tmps returned by FETCH should appear to be SCALAR
332# (even though they are now implemented using PVLVs.)
333package X;
334sub TIEHASH { bless {} }
335sub TIEARRAY { bless {} }
336sub FETCH {1}
337my (%h, @a);
338tie %h, 'X';
339tie @a, 'X';
340my $r1 = \$h{1};
341my $r2 = \$a[0];
342my $s = "$r1 ". ref($r1) . " $r2 " . ref($r2);
343$s=~ s/\(0x\w+\)//g;
344print $s, "\n";
345EXPECT
346SCALAR SCALAR SCALAR SCALAR
b7056d9c
JH
347########
348# [perl #23287] segfault in untie
349sub TIESCALAR { bless $_[1], $_[0] }
350my $var;
351tie $var, 'main', \$var;
352untie $var;
353EXPECT
16e0ce55
JH
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
93f09d7b 358# above. Its odd but convenient that after untie'ing you are left with
16e0ce55
JH
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)."
363use strict;
364use warnings;
365package MyTied;
366sub TIESCALAR {
367 my ($class,$code) = @_;
368 bless $code, $class;
369}
370sub FETCH {
371 my $self = shift;
372 print "Untie\n";
373 $self->();
374}
375package main;
376my $var;
377tie $var, 'MyTied', sub { untie $var; 4 };
378print "One\n";
379print "$var\n";
380print "Two\n";
381print "$var\n";
382print "Three\n";
383print "$var\n";
384EXPECT
385One
386Untie
3874
388Two
3894
390Three
3914
dd12389b
JH
392########
393# [perl #22297] cannot untie scalar from within tied FETCH
394my $counter = 0;
395my $x = 7;
396my $ref = \$x;
397tie $x, 'Overlay', $ref, $x;
398my $y;
399$y = $x;
400$y = $x;
401$y = $x;
402$y = $x;
403#print "WILL EXTERNAL UNTIE $ref\n";
404untie $$ref;
405$y = $x;
406$y = $x;
407$y = $x;
408$y = $x;
409#print "counter = $counter\n";
410
411print (($counter == 1) ? "ok\n" : "not ok\n");
412
413package Overlay;
414
415sub TIESCALAR
416{
417 my $pkg = shift;
418 my ($ref, $val) = @_;
419 return bless [ $ref, $val ], $pkg;
420}
421
422sub 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}
431EXPECT
432ok
6c0731c3
RC
433########
434
e23d9e2f 435# [perl #948] cannot meaningfully tie $,
6c0731c3
RC
436package TieDollarComma;
437
438sub TIESCALAR {
439 my $pkg = shift;
440 return bless \my $x, $pkg;
441}
442
443sub STORE {
444 my $self = shift;
445 $$self = shift;
446 print "STORE set '$$self'\n";
447}
448
449sub FETCH {
450 my $self = shift;
e23d9e2f 451 print "<FETCH>";
6c0731c3
RC
452 return $$self;
453}
454package main;
455
456tie $,, 'TieDollarComma';
457$, = 'BOBBINS';
458print "join", "things", "up\n";
459EXPECT
460STORE set 'BOBBINS'
e23d9e2f 461join<FETCH>BOBBINSthings<FETCH>BOBBINSup
a3bcc51e
TP
462########
463
464# test SCALAR method
465package TieScalar;
466
467sub TIEHASH {
468 my $pkg = shift;
469 bless { } => $pkg;
470}
471
472sub STORE {
473 $_[0]->{$_[1]} = $_[2];
474}
475
476sub FETCH {
477 $_[0]->{$_[1]}
478}
479
480sub CLEAR {
481 %{ $_[0] } = ();
482}
483
484sub SCALAR {
485 print "SCALAR\n";
486 return 0 if ! keys %{$_[0]};
487 sprintf "%i/%i", scalar keys %{$_[0]}, scalar keys %{$_[0]};
488}
489
490package main;
491tie my %h => "TieScalar";
492$h{key1} = "val1";
493$h{key2} = "val2";
867fa1e2
YO
494print scalar %h, "\n"
495 if %h; # this should also call SCALAR but implicitly
a3bcc51e 496%h = ();
867fa1e2
YO
497print scalar %h, "\n"
498 if !%h; # this should also call SCALAR but implicitly
a3bcc51e
TP
499EXPECT
500SCALAR
867fa1e2 501SCALAR
a3bcc51e
TP
5022/2
503SCALAR
867fa1e2 504SCALAR
a3bcc51e
TP
5050
506########
507
508# test scalar on tied hash when no SCALAR method has been given
509package TieScalar;
510
511sub TIEHASH {
512 my $pkg = shift;
513 bless { } => $pkg;
514}
515sub STORE {
516 $_[0]->{$_[1]} = $_[2];
517}
518sub FETCH {
519 $_[0]->{$_[1]}
520}
521sub CLEAR {
522 %{ $_[0] } = ();
523}
524sub FIRSTKEY {
525 my $a = keys %{ $_[0] };
526 print "FIRSTKEY\n";
527 each %{ $_[0] };
528}
529
530package main;
531tie my %h => "TieScalar";
532
533if (!%h) {
534 print "empty\n";
535} else {
536 print "not empty\n";
537}
538
539$h{key1} = "val1";
540print "not empty\n" if %h;
541print "not empty\n" if %h;
542print "-->\n";
543my ($k,$v) = each %h;
544print "<--\n";
545print "not empty\n" if %h;
546%h = ();
547print "empty\n" if ! %h;
548EXPECT
549FIRSTKEY
550empty
551FIRSTKEY
552not empty
553FIRSTKEY
554not empty
555-->
556FIRSTKEY
557<--
558not empty
559FIRSTKEY
560empty
2b77b520
YST
561########
562sub TIESCALAR { bless {} }
563sub FETCH { my $x = 3.3; 1 if 0+$x; $x }
564tie $h, "main";
565print $h,"\n";
566EXPECT
5673.3
c75ab21a
RH
568########
569sub TIESCALAR { bless {} }
570sub FETCH { shift()->{i} ++ }
571tie $h, "main";
572print $h.$h;
573EXPECT
57401
64207fde 575########
7de9d14e 576# Bug 53482 (and maybe others)
64207fde
RB
577sub TIESCALAR { my $foo = $_[1]; bless \$foo, $_[0] }
578sub FETCH { ${$_[0]} }
7de9d14e
B
579tie my $x1, "main", 2;
580tie my $y1, "main", 8;
581print $x1 | $y1;
582print $x1 | $y1;
583tie my $x2, "main", "2";
584tie my $y2, "main", "8";
585print $x2 | $y2;
586print $x2 | $y2;
587EXPECT
5881010::
1baaf5d7
NC
589########
590# Bug 36267
591sub TIEHASH { bless {}, $_[0] }
592sub STORE { $_[0]->{$_[1]} = $_[2] }
593sub FIRSTKEY { my $a = scalar keys %{$_[0]}; each %{$_[0]} }
594sub NEXTKEY { each %{$_[0]} }
595sub DELETE { delete $_[0]->{$_[1]} }
596sub CLEAR { %{$_[0]} = () }
597$h{b}=1;
598delete $h{b};
599print scalar keys %h, "\n";
600tie %h, 'main';
601$i{a}=1;
602%h = %i;
603untie %h;
604print scalar keys %h, "\n";
605EXPECT
6060
6070
ced497e2
YST
608########
609# Bug 37731
610sub foo::TIESCALAR { bless {value => $_[1]}, $_[0] }
611sub foo::FETCH { $_[0]->{value} }
612tie my $VAR, 'foo', '42';
613foreach my $var ($VAR) {
614 print +($var eq $VAR) ? "yes\n" : "no\n";
615}
616EXPECT
617yes
f4c21a45
DM
618########
619sub TIEARRAY { bless [], 'main' }
620{
621 local @a;
622 tie @a, 'main';
623}
624print "tied\n" if tied @a;
625EXPECT
626########
627sub TIEHASH { bless [], 'main' }
628{
629 local %h;
630 tie %h, 'main';
631}
632print "tied\n" if tied %h;
633EXPECT
099be4f1
DM
634########
635# RT 20727: PL_defoutgv is left as a tied element
636sub TIESCALAR { return bless {}, 'main' }
637
638sub STORE {
639 select($_[1]);
640 $_[1] = 1;
641 select(); # this used to coredump or assert fail
642}
643tie $SELECT, 'main';
644$SELECT = *STDERR;
645EXPECT
27e90453
DM
646########
647# RT 23810: eval in die in FETCH can corrupt context stack
648
649my $file = 'rt23810.pm';
650
651my $e;
652my $s;
653
654sub 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
671sub TIEHASH { bless {} }
672
673sub 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}
712my %foo;
713tie %foo, "main";
714
715for 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}
7211 while unlink $file;
722
723$foo{'exit'};
724print "overshot main\n"; # shouldn't reach here
725
726EXPECT
727eval: s0=EVAL-BD-BS-E1-S1-E2-S2-S2-S2-S2-S2-S2-S2-S2-S2-S2-R
728eval: s1=EVAL-BD-BS-E1-S1-E2-S2-S2-S2-S2-S2-S2-S2-S2-S2-S2-R
729eval: s2=EVAL-BD-BS-E1-S1-E2-S2-S2-S2-S2-S2-S2-S2-S2-S2-S2-R
730eval: s3=EVAL-BD-BS-E1-S1-E2-S2-S2-S2-S2-S2-S2-S2-S2-S2-S2-R
731require: s0=REQUIRE-0-ERQ-ENDRQ-1-ERQ-ENDRQ-2-ERQ-ENDRQ-3-ERQ-ENDRQ-R
732require: s1=REQUIRE-0-RQ
733require: s2=REQUIRE-0-ERQ-ENDRQ-1-ERQ-ENDRQ-2-ERQ-ENDRQ-3-ERQ-ENDRQ-R
734require: s3=REQUIRE-0-RQ
459defa1
DM
735########
736# RT 8857: STORE incorrectly invoked for local($_) on aliased tied array
737# element
738
739sub TIEARRAY { bless [], $_[0] }
740sub TIEHASH { bless [], $_[0] }
741sub FETCH { $_[0]->[$_[1]] }
742sub STORE { $_[0]->[$_[1]] = $_[2] }
743
744
745sub f {
746 local $_[0];
747}
748tie @a, 'main';
749tie %h, 'main';
27e90453 750
459defa1
DM
751foreach ($a[0], $h{a}) {
752 f($_);
753}
754# on failure, chucks up 'premature free' etc messages
755EXPECT
39cf747a
DM
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
762sub TIESCALAR { bless [], $_[0] }
763my $c = 0;
764sub FETCH { $c++; 0 }
765sub FETCHSIZE { 1 }
766sub STORE { $c += 100; 0 }
767
768
769my (@a, %h);
770tie $a[0], 'main';
771tie $h{foo}, 'main';
772
773my $i = 0;
774my $x = $a[0] + $h{foo} + $a[$i] + (@a)[0];
775print "x=$x c=$c\n";
776EXPECT
777x=0 c=4
6a5f8cbd
FC
778########
779# Bug 68192 - numeric ops not calling mg_get when tied scalar holds a ref
780sub TIESCALAR { bless {}, __PACKAGE__ };
781sub STORE {};
782sub FETCH {
783 print "fetching... "; # make sure FETCH is called once per op
784 123456
785};
786my $foo;
787tie $foo, __PACKAGE__;
788my $a = [1234567];
789$foo = $a;
790print "+ ", 0 + $foo, "\n";
791print "** ", $foo**1, "\n";
792print "* ", $foo*1, "\n";
793print "/ ", $foo*1, "\n";
794print "% ", $foo%123457, "\n";
795print "- ", $foo-0, "\n";
796print "neg ", - -$foo, "\n";
797print "int ", int $foo, "\n";
798print "abs ", abs $foo, "\n";
799print "== ", 123456 == $foo, "\n";
800print "< ", 123455 < $foo, "\n";
801print "> ", 123457 > $foo, "\n";
802print "<= ", 123456 <= $foo, "\n";
803print ">= ", 123456 >= $foo, "\n";
804print "!= ", 0 != $foo, "\n";
805print "<=> ", 123457 <=> $foo, "\n";
806EXPECT
807fetching... + 123456
808fetching... ** 123456
809fetching... * 123456
810fetching... / 123456
811fetching... % 123456
812fetching... - 123456
813fetching... neg 123456
814fetching... int 123456
815fetching... abs 123456
816fetching... == 1
817fetching... < 1
818fetching... > 1
819fetching... <= 1
820fetching... >= 1
821fetching... != 1
822fetching... <=> 1
823########
824# Ties returning overloaded objects
825{
826 package overloaded;
827 use overload
bb1bc619
FCR
828 '*{}' => sub { print '*{}'; \*100 },
829 '@{}' => sub { print '@{}'; \@100 },
830 '%{}' => sub { print '%{}'; \%100 },
831 '${}' => sub { print '${}'; \$100 },
6a5f8cbd
FC
832 map {
833 my $op = $_;
834 $_ => sub { print "$op"; 100 }
9e27fd70 835 } qw< 0+ "" + ** * / % - neg int abs == < > <= >= != <=> <> >
6a5f8cbd
FC
836}
837$o = bless [], overloaded;
838
839sub TIESCALAR { bless {}, "" }
840sub FETCH { print "fetching... "; $o }
841sub STORE{}
842tie $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";
9e27fd70 860$ghew=undef; <$ghew>; print "\n";
bb1bc619
FCR
861$ghew=\*shrext; *$ghew; print "\n";
862$ghew=\@spled; @$ghew; print "\n";
863$ghew=\%frit; %$ghew; print "\n";
864$ghew=\$drile; $$ghew; print "\n";
6a5f8cbd
FC
865EXPECT
866fetching... +
867fetching... **
868fetching... *
869fetching... /
870fetching... %
871fetching... -
872fetching... neg
873fetching... int
874fetching... abs
875fetching... ==
876fetching... <
877fetching... >
878fetching... <=
879fetching... >=
880fetching... !=
881fetching... <=>
9e27fd70 882fetching... <>
bb1bc619
FCR
883fetching... *{}
884fetching... @{}
885fetching... %{}
886fetching... ${}
3a19377b
DM
887########
888# RT 51636: segmentation fault with array ties
889
890tie my @a, 'T';
891@a = (1);
892print "ok\n"; # if we got here we didn't crash
893
894package T;
895
896sub TIEARRAY { bless {} }
897sub STORE { tie my @b, 'T' }
898sub CLEAR { }
899sub EXTEND { }
900
901EXPECT
902ok
7c75014e
DM
903########
904# RT 8438: Tied scalars don't call FETCH when subref is dereferenced
905
906sub TIESCALAR { bless {} }
907
908my $fetch = 0;
909my $called = 0;
910sub FETCH { $fetch++; sub { $called++ } }
911
912tie my $f, 'main';
913$f->(1) for 1,2;
914print "fetch=$fetch\ncalled=$called\n";
915
916EXPECT
917fetch=2
918called=2
086d2913
NC
919########
920# tie mustn't attempt to call methods on bareword filehandles.
921sub IO::File::TIEARRAY {
922 die "Did not want to invoke IO::File::TIEARRAY";
923}
924fileno FOO; tie @a, "FOO"
925EXPECT
926Can't locate object method "TIEARRAY" via package "FOO" at - line 5.
7c7df812 927########
8985fe98
DM
928#
929# STORE freeing tie'd AV
930sub TIEARRAY { bless [] }
931sub STORE { *a = []; 1 }
932sub STORESIZE { }
933sub EXTEND { }
934tie @a, 'main';
935$a[0] = 1;
936EXPECT
937########
938#
939# CLEAR freeing tie'd AV
940sub TIEARRAY { bless [] }
941sub CLEAR { *a = []; 1 }
942sub STORESIZE { }
943sub EXTEND { }
944sub STORE { }
945tie @a, 'main';
946@a = (1,2,3);
947EXPECT
948########
949#
950# FETCHSIZE freeing tie'd AV
951sub TIEARRAY { bless [] }
952sub FETCHSIZE { *a = []; 100 }
953sub STORESIZE { }
954sub EXTEND { }
955sub STORE { }
956tie @a, 'main';
957print $#a,"\n"
958EXPECT
95999
007f907e
FC
960########
961#
962# [perl #86328] Crash when freeing tie magic that can increment the refcnt
963
964eval { require Scalar::Util } or print("ok\n"), exit;
965
966sub TIEHASH {
967 return $_[1];
968}
969*TIEARRAY = *TIEHASH;
970
971sub DESTROY {
972 my ($tied) = @_;
973 my $b = $tied->[0];
974}
975
976my $a = {};
977my $o = bless [];
978Scalar::Util::weaken($o->[0] = $a);
979tie %$a, "main", $o;
980
981my $b = [];
982my $p = bless [];
983Scalar::Util::weaken($p->[0] = $b);
984tie @$b, "main", $p;
985
986# Done setting up the evil data structures
987
988$a = undef;
989$b = undef;
990print "ok\n";
991
992EXPECT
993ok
b2b95e4c
FC
994########
995#
996# Localising a tied COW scalar should not make it read-only.
997
998sub TIESCALAR { bless [] }
999sub FETCH { __PACKAGE__ }
1000sub STORE {}
1001tie $x, "";
1002"$x";
1003{
1004 local $x;
1005 $x = 3;
1006}
1007print "ok\n";
1008EXPECT
1009ok
4be76e1f
FC
1010########
1011
1012# tied() should still work on tied scalars after glob assignment
1013sub TIESCALAR {bless[]}
1014sub FETCH {*foo}
1015sub f::TIEHANDLE{bless[],f}
1016tie *foo, "f";
1017tie $rin, "";
1018[$rin]; # call FETCH
1019print ref tied $rin, "\n";
1020print ref tied *$rin, "\n";
1021EXPECT
1022main
1023f
8bb5f786
FC
1024########
1025
ca0d4ed9
FC
1026# (un)tie $glob_copy vs (un)tie *$glob_copy
1027sub TIESCALAR { print "TIESCALAR\n"; bless [] }
1028sub TIEHANDLE{ print "TIEHANDLE\n"; bless [] }
1029sub FETCH { print "never called\n" }
8bb5f786
FC
1030$f = *foo;
1031tie *$f, "";
1032tie $f, "";
ca0d4ed9
FC
1033untie $f;
1034print "ok 1\n" if !tied $f;
1035() = $f; # should not call FETCH
1036untie *$f;
1037print "ok 2\n" if !tied *foo;
8bb5f786
FC
1038EXPECT
1039TIEHANDLE
1040TIESCALAR
ca0d4ed9
FC
1041ok 1
1042ok 2
d8ef3a16
DM
1043########
1044
1045# RT #8611 mustn't goto outside the magic stack
1046sub TIESCALAR { warn "tiescalar\n"; bless [] }
1047sub FETCH { warn "fetch()\n"; goto FOO; }
1048tie $f, "";
1049warn "before fetch\n";
1050my $a = "$f";
1051warn "before FOO\n";
1052FOO:
1053warn "after FOO\n";
1054EXPECT
1055tiescalar
1056before fetch
1057fetch()
1058Can't find label FOO at - line 4.
1059########
1060
1061# RT #8611 mustn't goto outside the magic stack
1062sub TIEHANDLE { warn "tiehandle\n"; bless [] }
1063sub PRINT { warn "print()\n"; goto FOO; }
1064tie *F, "";
1065warn "before print\n";
1066print F "abc";
1067warn "before FOO\n";
1068FOO:
1069warn "after FOO\n";
1070EXPECT
1071tiehandle
1072before print
1073print()
1074Can't find label FOO at - line 4.
ff55a019
FC
1075########
1076
1077# \&$tied with $tied holding a reference before the fetch (but not after)
1078sub ::72 { 73 };
1079sub TIESCALAR {bless[]}
1080sub STORE{}
1081sub FETCH { 72 }
1082tie my $x, "main";
1083$x = \$y;
1084\&$x;
1085print "ok\n";
1086EXPECT
1087ok
1088########
1089
1090# \&$tied with $tied holding a PVLV glob before the fetch (but not after)
1091sub ::72 { 73 };
1092sub TIEARRAY {bless[]}
1093sub STORE{}
1094sub FETCH { 72 }
1095tie my @x, "main";
1096my $elem = \$x[0];
1097$$elem = *bar;
1098print &{\&$$elem}, "\n";
1099EXPECT
110073
48e092ec
FC
1101########
1102
1103# \&$tied with $tied holding a PVGV glob before the fetch (but not after)
1104local *72 = sub { 73 };
1105sub TIESCALAR {bless[]}
1106sub STORE{}
1107sub FETCH { 72 }
1108tie my $x, "main";
1109$x = *bar;
1110print &{\&$x}, "\n";
1111EXPECT
111273