Suppress a few compilation warnings in pp_hot.c.
[p5sagit/p5-mst-13.2.git] / t / op / tie.t
1 #!./perl
2
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 #
11
12 chdir 't' if -d 't';
13 @INC = '../lib';
14 $ENV{PERL5LIB} = "../lib";
15
16 $|=1;
17
18 undef $/;
19 @prgs = split /^########\n/m, <DATA>;
20
21 require './test.pl';
22 plan(tests => scalar @prgs);
23 for (@prgs){
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 //;
31     $results =~ s/\n+$//;
32     $expected =~ s/\n+$//;
33
34     fresh_perl_is($prog, $expected, {}, $testname);
35 }
36
37 __END__
38
39 # standard behaviour, without any extra references
40 use Tie::Hash ;
41 tie %h, Tie::StdHash;
42 untie %h;
43 EXPECT
44 ########
45
46 # standard behaviour, without any extra references
47 use Tie::Hash ;
48 {package Tie::HashUntie;
49  use base 'Tie::StdHash';
50  sub UNTIE
51   {
52    warn "Untied\n";
53   }
54 }
55 tie %h, Tie::HashUntie;
56 untie %h;
57 EXPECT
58 Untied
59 ########
60
61 # standard behaviour, with 1 extra reference
62 use Tie::Hash ;
63 $a = tie %h, Tie::StdHash;
64 untie %h;
65 EXPECT
66 ########
67
68 # standard behaviour, with 1 extra reference via tied
69 use Tie::Hash ;
70 tie %h, Tie::StdHash;
71 $a = tied %h;
72 untie %h;
73 EXPECT
74 ########
75
76 # standard behaviour, with 1 extra reference which is destroyed
77 use Tie::Hash ;
78 $a = tie %h, Tie::StdHash;
79 $a = 0 ;
80 untie %h;
81 EXPECT
82 ########
83
84 # standard behaviour, with 1 extra reference via tied which is destroyed
85 use Tie::Hash ;
86 tie %h, Tie::StdHash;
87 $a = tied %h;
88 $a = 0 ;
89 untie %h;
90 EXPECT
91 ########
92
93 # strict behaviour, without any extra references
94 use warnings 'untie';
95 use Tie::Hash ;
96 tie %h, Tie::StdHash;
97 untie %h;
98 EXPECT
99 ########
100
101 # strict behaviour, with 1 extra references generating an error
102 use warnings 'untie';
103 use Tie::Hash ;
104 $a = tie %h, Tie::StdHash;
105 untie %h;
106 EXPECT
107 untie attempted while 1 inner references still exist at - line 6.
108 ########
109
110 # strict behaviour, with 1 extra references via tied generating an error
111 use warnings 'untie';
112 use Tie::Hash ;
113 tie %h, Tie::StdHash;
114 $a = tied %h;
115 untie %h;
116 EXPECT
117 untie attempted while 1 inner references still exist at - line 7.
118 ########
119
120 # strict behaviour, with 1 extra references which are destroyed
121 use warnings 'untie';
122 use Tie::Hash ;
123 $a = tie %h, Tie::StdHash;
124 $a = 0 ;
125 untie %h;
126 EXPECT
127 ########
128
129 # strict behaviour, with extra 1 references via tied which are destroyed
130 use warnings 'untie';
131 use Tie::Hash ;
132 tie %h, Tie::StdHash;
133 $a = tied %h;
134 $a = 0 ;
135 untie %h;
136 EXPECT
137 ########
138
139 # strict error behaviour, with 2 extra references
140 use warnings 'untie';
141 use Tie::Hash ;
142 $a = tie %h, Tie::StdHash;
143 $b = tied %h ;
144 untie %h;
145 EXPECT
146 untie attempted while 2 inner references still exist at - line 7.
147 ########
148
149 # strict behaviour, check scope of strictness.
150 no warnings 'untie';
151 use Tie::Hash ;
152 $A = tie %H, Tie::StdHash;
153 $C = $B = tied %H ;
154 {
155     use warnings 'untie';
156     use Tie::Hash ;
157     tie %h, Tie::StdHash;
158     untie %h;
159 }
160 untie %H;
161 EXPECT
162 ########
163
164 # Forbidden aggregate self-ties
165 sub Self::TIEHASH { bless $_[1], $_[0] }
166 {
167     my %c;
168     tie %c, 'Self', \%c;
169 }
170 EXPECT
171 Self-ties of arrays and hashes are not supported at - line 6.
172 ########
173
174 # Allowed scalar self-ties
175 my $destroyed = 0;
176 sub Self::TIESCALAR { bless $_[1], $_[0] }
177 sub Self::DESTROY   { $destroyed = 1; }
178 {
179     my $c = 42;
180     tie $c, 'Self', \$c;
181 }
182 die "self-tied scalar not DESTROYed" unless $destroyed == 1;
183 EXPECT
184 ########
185
186 # Allowed glob self-ties
187 my $destroyed = 0;
188 my $printed   = 0;
189 sub Self2::TIEHANDLE { bless $_[1], $_[0] }
190 sub Self2::DESTROY   { $destroyed = 1; }
191 sub Self2::PRINT     { $printed = 1; }
192 {
193     use Symbol;
194     my $c = gensym;
195     tie *$c, 'Self2', $c;
196     print $c 'Hello';
197 }
198 die "self-tied glob not PRINTed" unless $printed == 1;
199 die "self-tied glob not DESTROYed" unless $destroyed == 1;
200 EXPECT
201 ########
202
203 # Allowed IO self-ties
204 my $destroyed = 0;
205 sub Self3::TIEHANDLE { bless $_[1], $_[0] }
206 sub Self3::DESTROY   { $destroyed = 1; }
207 sub Self3::PRINT     { $printed = 1; }
208 {
209     use Symbol 'geniosym';
210     my $c = geniosym;
211     tie *$c, 'Self3', $c;
212     print $c 'Hello';
213 }
214 die "self-tied IO not PRINTed" unless $printed == 1;
215 die "self-tied IO not DESTROYed" unless $destroyed == 1;
216 EXPECT
217 ########
218
219 # TODO IO "self-tie" via TEMP glob
220 my $destroyed = 0;
221 sub Self3::TIEHANDLE { bless $_[1], $_[0] }
222 sub Self3::DESTROY   { $destroyed = 1; }
223 sub Self3::PRINT     { $printed = 1; }
224 {
225     use Symbol 'geniosym';
226     my $c = geniosym;
227     tie *$c, 'Self3', \*$c;
228     print $c 'Hello';
229 }
230 die "IO tied to TEMP glob not PRINTed" unless $printed == 1;
231 die "IO tied to TEMP glob not DESTROYed" unless $destroyed == 1;
232 EXPECT
233 ########
234
235 # Interaction of tie and vec
236
237 my ($a, $b);
238 use Tie::Scalar;
239 tie $a,Tie::StdScalar or die;
240 vec($b,1,1)=1;
241 $a = $b;
242 vec($a,1,1)=0;
243 vec($b,1,1)=0;
244 die unless $a eq $b;
245 EXPECT
246 ########
247
248 # correct unlocalisation of tied hashes (patch #16431)
249 use Tie::Hash ;
250 tie %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'};
254 EXPECT
255 ########
256
257 # An attempt at lvalueable barewords broke this
258 tie FH, 'main';
259 EXPECT
260 Can't modify constant item in tie at - line 3, near "'main';"
261 Execution of - aborted due to compilation errors.
262 ########
263
264 # localizing tied hash slices
265 $ENV{FooA} = 1;
266 $ENV{FooB} = 2;
267 print exists $ENV{FooA} ? 1 : 0, "\n";
268 print exists $ENV{FooB} ? 2 : 0, "\n";
269 print 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 }
276 print exists $ENV{FooA} ? 7 : 0, "\n";
277 print exists $ENV{FooB} ? 8 : 0, "\n";
278 print exists $ENV{FooC} ? 9 : 0, "\n"; # this should not exist
279 EXPECT
280 1
281 2
282 0
283 4
284 5
285 6
286 7
287 8
288 0
289 ########
290 #
291 # FETCH freeing tie'd SV
292 sub TIESCALAR { bless [] }
293 sub FETCH { *a = \1; 1 }
294 tie $a, 'main';
295 print $a;
296 EXPECT
297 Tied variable freed while still in use at - line 6.
298 ########
299
300 #  [20020716.007] - nested FETCHES
301
302 sub F1::TIEARRAY { bless [], 'F1' }
303 sub F1::FETCH { 1 }
304 my @f1;
305 tie @f1, 'F1';
306
307 sub F2::TIEARRAY { bless [2], 'F2' }
308 sub F2::FETCH { my $self = shift; my $x = $f1[3]; $self }
309 my @f2;
310 tie @f2, 'F2';
311
312 print $f2[4][0],"\n";
313
314 sub F3::TIEHASH { bless [], 'F3' }
315 sub F3::FETCH { 1 }
316 my %f3;
317 tie %f3, 'F3';
318
319 sub F4::TIEHASH { bless [3], 'F4' }
320 sub F4::FETCH { my $self = shift; my $x = $f3{3}; $self }
321 my %f4;
322 tie %f4, 'F4';
323
324 print $f4{'foo'}[0],"\n";
325
326 EXPECT
327 2
328 3