This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
=head2 ALL CAPS
[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
297Tied variable freed while still in use at - line 6.
dd28f7bb
DM
298########
299
300# [20020716.007] - nested FETCHES
301
302sub F1::TIEARRAY { bless [], 'F1' }
303sub F1::FETCH { 1 }
304my @f1;
305tie @f1, 'F1';
306
307sub F2::TIEARRAY { bless [2], 'F2' }
308sub F2::FETCH { my $self = shift; my $x = $f1[3]; $self }
309my @f2;
310tie @f2, 'F2';
311
312print $f2[4][0],"\n";
313
314sub F3::TIEHASH { bless [], 'F3' }
315sub F3::FETCH { 1 }
316my %f3;
317tie %f3, 'F3';
318
319sub F4::TIEHASH { bless [3], 'F4' }
320sub F4::FETCH { my $self = shift; my $x = $f3{3}; $self }
321my %f4;
322tie %f4, 'F4';
323
324print $f4{'foo'}[0],"\n";
325
326EXPECT
3272
3283
38193a09
AM
329########
330# test untie() from within FETCH
331package Foo;
332sub TIESCALAR { my $pkg = shift; return bless [@_], $pkg; }
333sub FETCH {
334 my $self = shift;
335 my ($obj, $field) = @$self;
336 untie $obj->{$field};
337 $obj->{$field} = "Bar";
338}
339package main;
340tie $a->{foo}, "Foo", $a, "foo";
341$a->{foo}; # access once
342# the hash element should not be tied anymore
343print defined tied $a->{foo} ? "not ok" : "ok";
344EXPECT
345ok
be65207d
DM
346########
347# the tmps returned by FETCH should appear to be SCALAR
348# (even though they are now implemented using PVLVs.)
349package X;
350sub TIEHASH { bless {} }
351sub TIEARRAY { bless {} }
352sub FETCH {1}
353my (%h, @a);
354tie %h, 'X';
355tie @a, 'X';
356my $r1 = \$h{1};
357my $r2 = \$a[0];
358my $s = "$r1 ". ref($r1) . " $r2 " . ref($r2);
359$s=~ s/\(0x\w+\)//g;
360print $s, "\n";
361EXPECT
362SCALAR SCALAR SCALAR SCALAR