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