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