This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[PATCH] Re: perl@16433
[perl5.git] / t / op / tie.t
CommitLineData
49d42823
PP
1#!./perl
2
3# This test harness will (eventually) test the "tie" functionality
4# without the need for a *DBM* implementation.
5
55497cff 6# Currently it only tests the untie warning
49d42823
PP
7
8chdir 't' if -d 't';
20822f61 9@INC = '../lib';
49d42823
PP
10$ENV{PERL5LIB} = "../lib";
11
12$|=1;
13
55497cff
PP
14# catch warnings into fatal errors
15$SIG{__WARN__} = sub { die "WARNING: @_" } ;
c03358ae 16$SIG{__DIE__} = sub { die @_ };
55497cff 17
49d42823 18undef $/;
f0faabb7 19@prgs = split /^########\n/m, <DATA>;
49d42823
PP
20print "1..", scalar @prgs, "\n";
21
22for (@prgs){
f0faabb7
YST
23 ++$i;
24 my($prog,$expected) = split(/\nEXPECT\n/, $_, 2);
25 print("not ok $i # bad test format\n"), next
26 unless defined $expected;
27 my ($testname) = $prog =~ /^(# .*)\n/;
28 $testname ||= '';
49d42823
PP
29 eval "$prog" ;
30 $status = $?;
31 $results = $@ ;
32 $results =~ s/\n+$//;
33 $expected =~ s/\n+$//;
f0faabb7
YST
34 if ( $status || ($expected eq '') != ($results eq '') ||
35 $results !~ /^(WARNING: )?$expected/){
49d42823
PP
36 print STDERR "STATUS: $status\n";
37 print STDERR "PROG: $prog\n";
38 print STDERR "EXPECTED:\n$expected\n";
39 print STDERR "GOT:\n$results\n";
f0faabb7
YST
40 print "not ok $i $testname\n";
41 }
42 else {
43 print "ok $i $testname\n";
49d42823 44 }
49d42823
PP
45}
46
47__END__
48
49# standard behaviour, without any extra references
50use Tie::Hash ;
51tie %h, Tie::StdHash;
52untie %h;
53EXPECT
54########
55
a29a5827
NIS
56# standard behaviour, without any extra references
57use Tie::Hash ;
58{package Tie::HashUntie;
59 use base 'Tie::StdHash';
60 sub UNTIE
61 {
62 warn "Untied\n";
63 }
64}
65tie %h, Tie::HashUntie;
66untie %h;
67EXPECT
68Untied
69########
70
49d42823
PP
71# standard behaviour, with 1 extra reference
72use Tie::Hash ;
73$a = tie %h, Tie::StdHash;
74untie %h;
75EXPECT
76########
77
78# standard behaviour, with 1 extra reference via tied
79use Tie::Hash ;
80tie %h, Tie::StdHash;
81$a = tied %h;
82untie %h;
83EXPECT
84########
85
86# standard behaviour, with 1 extra reference which is destroyed
87use Tie::Hash ;
88$a = tie %h, Tie::StdHash;
89$a = 0 ;
90untie %h;
91EXPECT
92########
93
94# standard behaviour, with 1 extra reference via tied which is destroyed
95use Tie::Hash ;
96tie %h, Tie::StdHash;
97$a = tied %h;
98$a = 0 ;
99untie %h;
100EXPECT
101########
102
103# strict behaviour, without any extra references
4438c4b7 104use warnings 'untie';
49d42823
PP
105use Tie::Hash ;
106tie %h, Tie::StdHash;
107untie %h;
108EXPECT
109########
110
111# strict behaviour, with 1 extra references generating an error
4438c4b7 112use warnings 'untie';
49d42823
PP
113use Tie::Hash ;
114$a = tie %h, Tie::StdHash;
115untie %h;
116EXPECT
55497cff 117untie attempted while 1 inner references still exist
49d42823
PP
118########
119
120# strict behaviour, with 1 extra references via tied generating an error
4438c4b7 121use warnings 'untie';
49d42823
PP
122use Tie::Hash ;
123tie %h, Tie::StdHash;
124$a = tied %h;
125untie %h;
126EXPECT
55497cff 127untie attempted while 1 inner references still exist
49d42823
PP
128########
129
130# strict behaviour, with 1 extra references which are destroyed
4438c4b7 131use warnings 'untie';
49d42823
PP
132use Tie::Hash ;
133$a = tie %h, Tie::StdHash;
134$a = 0 ;
135untie %h;
136EXPECT
137########
138
139# strict behaviour, with extra 1 references via tied which are destroyed
4438c4b7 140use warnings 'untie';
49d42823
PP
141use Tie::Hash ;
142tie %h, Tie::StdHash;
143$a = tied %h;
144$a = 0 ;
145untie %h;
146EXPECT
147########
148
149# strict error behaviour, with 2 extra references
4438c4b7 150use warnings 'untie';
49d42823
PP
151use Tie::Hash ;
152$a = tie %h, Tie::StdHash;
153$b = tied %h ;
154untie %h;
155EXPECT
55497cff 156untie attempted while 2 inner references still exist
49d42823
PP
157########
158
159# strict behaviour, check scope of strictness.
4438c4b7 160no warnings 'untie';
49d42823
PP
161use Tie::Hash ;
162$A = tie %H, Tie::StdHash;
163$C = $B = tied %H ;
164{
4438c4b7 165 use warnings 'untie';
49d42823
PP
166 use Tie::Hash ;
167 tie %h, Tie::StdHash;
168 untie %h;
169}
170untie %H;
171EXPECT
33c27489 172########
ae21d580 173# Forbidden aggregate self-ties
33c27489 174sub Self::TIEHASH { bless $_[1], $_[0] }
ae21d580 175{
f0faabb7 176 my %c;
ae21d580
JH
177 tie %c, 'Self', \%c;
178}
179EXPECT
180Self-ties of arrays and hashes are not supported
181########
182# Allowed scalar self-ties
f0faabb7 183my $destroyed = 0;
ae21d580 184sub Self::TIESCALAR { bless $_[1], $_[0] }
f0faabb7 185sub Self::DESTROY { $destroyed = 1; }
33c27489 186{
ae21d580 187 my $c = 42;
ae21d580 188 tie $c, 'Self', \$c;
33c27489 189}
f0faabb7
YST
190die "self-tied scalar not DESTROYd" unless $destroyed == 1;
191EXPECT
192########
193# Allowed glob self-ties
194my $destroyed = 0;
195sub Self2::TIEHANDLE { bless $_[1], $_[0] }
196sub Self2::DESTROY { $destroyed = 1; }
197{
198 use Symbol;
199 my $c = gensym;
200 tie *$c, 'Self2', $c;
201}
202die "self-tied glob not DESTROYd" unless $destroyed == 1;
203EXPECT
204########
205# Allowed IO self-ties
206my $destroyed = 0;
207sub Self3::TIEHANDLE { bless $_[1], $_[0] }
208sub Self3::DESTROY { $destroyed = 1; }
209{
210 use Symbol 'geniosym';
211 my $c = geniosym;
212 tie *$c, 'Self3', $c;
213}
214die "self-tied IO not DESTROYd" unless $destroyed == 1;
33c27489 215EXPECT
7bb043c3
IP
216########
217# Interaction of tie and vec
218
219my ($a, $b);
220use Tie::Scalar;
221tie $a,Tie::StdScalar or die;
222vec($b,1,1)=1;
223$a = $b;
224vec($a,1,1)=0;
225vec($b,1,1)=0;
226die unless $a eq $b;
227EXPECT
83f527ec 228########
f0faabb7 229# TODO An attempt at lvalueable barewords broke this
83f527ec
JH
230
231tie FH, 'main';
232EXPECT
233
0b2c215a
JH
234########
235# correct unlocalisation of tied hashes (patch #16431)
236use Tie::Hash ;
237tie %tied, Tie::StdHash;
238{ local $hash{'foo'} } print "exist1\n" if exists $hash{'foo'};
239{ local $tied{'foo'} } print "exist2\n" if exists $tied{'foo'};
240{ local $ENV{'foo'} } print "exist3\n" if exists $ENV{'foo'};
241EXPECT
242