This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Add non-blocking thread doneness checking
[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
PP
18undef $/;
19@prgs = split "\n########\n", <DATA>;
20print "1..", scalar @prgs, "\n";
21
22for (@prgs){
23 my($prog,$expected) = split(/\nEXPECT\n/, $_);
24 eval "$prog" ;
25 $status = $?;
26 $results = $@ ;
27 $results =~ s/\n+$//;
28 $expected =~ s/\n+$//;
c03358ae 29 if ( $status or $results and $results !~ /^(WARNING: )?$expected/){
49d42823
PP
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";
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
55497cff 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
55497cff 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
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
55497cff 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
GS
164########
165
166# verify no leak when underlying object is selfsame tied variable
167my ($a, $b);
168sub Self::TIEHASH { bless $_[1], $_[0] }
169sub Self::DESTROY { $b = $_[0] + 0; }
170{
171 my %b5;
172 $a = \%b5 + 0;
173 tie %b5, 'Self', \%b5;
174}
175die unless $a == $b;
176EXPECT
c03358ae 177Self-ties are not supported
7bb043c3
IP
178########
179# Interaction of tie and vec
180
181my ($a, $b);
182use Tie::Scalar;
183tie $a,Tie::StdScalar or die;
184vec($b,1,1)=1;
185$a = $b;
186vec($a,1,1)=0;
187vec($b,1,1)=0;
188die unless $a eq $b;
189EXPECT