Commit | Line | Data |
---|---|---|
49d42823 | 1 | #!./perl |
2 | ||
d87ebaca YST |
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 | # | |
49d42823 | 11 | |
12 | chdir 't' if -d 't'; | |
20822f61 | 13 | @INC = '../lib'; |
49d42823 | 14 | $ENV{PERL5LIB} = "../lib"; |
15 | ||
16 | $|=1; | |
17 | ||
18 | undef $/; | |
d87ebaca | 19 | @prgs = split /^########\n/m, <DATA>; |
49d42823 | 20 | |
d87ebaca YST |
21 | require './test.pl'; |
22 | plan(tests => scalar @prgs); | |
49d42823 | 23 | for (@prgs){ |
d87ebaca YST |
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 //; | |
49d42823 | 31 | $results =~ s/\n+$//; |
32 | $expected =~ s/\n+$//; | |
d87ebaca YST |
33 | |
34 | fresh_perl_is($prog, $expected, {}, $testname); | |
49d42823 | 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 | ||
a29a5827 NIS |
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 | ||
49d42823 | 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 | |
4438c4b7 | 94 | use warnings 'untie'; |
49d42823 | 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 | |
4438c4b7 | 102 | use warnings 'untie'; |
49d42823 | 103 | use Tie::Hash ; |
104 | $a = tie %h, Tie::StdHash; | |
105 | untie %h; | |
106 | EXPECT | |
d87ebaca | 107 | untie attempted while 1 inner references still exist at - line 6. |
49d42823 | 108 | ######## |
109 | ||
110 | # strict behaviour, with 1 extra references via tied generating an error | |
4438c4b7 | 111 | use warnings 'untie'; |
49d42823 | 112 | use Tie::Hash ; |
113 | tie %h, Tie::StdHash; | |
114 | $a = tied %h; | |
115 | untie %h; | |
116 | EXPECT | |
d87ebaca | 117 | untie attempted while 1 inner references still exist at - line 7. |
49d42823 | 118 | ######## |
119 | ||
120 | # strict behaviour, with 1 extra references which are destroyed | |
4438c4b7 | 121 | use warnings 'untie'; |
49d42823 | 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 | |
4438c4b7 | 130 | use warnings 'untie'; |
49d42823 | 131 | use Tie::Hash ; |
132 | tie %h, Tie::StdHash; | |
133 | $a = tied %h; | |
134 | $a = 0 ; | |
135 | untie %h; | |
136 | EXPECT | |
137 | ######## | |
138 | ||
87f0b213 | 139 | # strict error behaviour, with 2 extra references |
4438c4b7 | 140 | use warnings 'untie'; |
49d42823 | 141 | use Tie::Hash ; |
142 | $a = tie %h, Tie::StdHash; | |
143 | $b = tied %h ; | |
144 | untie %h; | |
145 | EXPECT | |
d87ebaca | 146 | untie attempted while 2 inner references still exist at - line 7. |
49d42823 | 147 | ######## |
148 | ||
149 | # strict behaviour, check scope of strictness. | |
4438c4b7 | 150 | no warnings 'untie'; |
49d42823 | 151 | use Tie::Hash ; |
152 | $A = tie %H, Tie::StdHash; | |
153 | $C = $B = tied %H ; | |
154 | { | |
4438c4b7 | 155 | use warnings 'untie'; |
49d42823 | 156 | use Tie::Hash ; |
157 | tie %h, Tie::StdHash; | |
158 | untie %h; | |
159 | } | |
160 | untie %H; | |
161 | EXPECT | |
33c27489 | 162 | ######## |
d87ebaca | 163 | |
ae21d580 | 164 | # Forbidden aggregate self-ties |
33c27489 | 165 | sub Self::TIEHASH { bless $_[1], $_[0] } |
ae21d580 | 166 | { |
d87ebaca | 167 | my %c; |
ae21d580 JH |
168 | tie %c, 'Self', \%c; |
169 | } | |
170 | EXPECT | |
d87ebaca | 171 | Self-ties of arrays and hashes are not supported at - line 6. |
ae21d580 | 172 | ######## |
d87ebaca | 173 | |
ae21d580 | 174 | # Allowed scalar self-ties |
d87ebaca | 175 | my $destroyed = 0; |
ae21d580 | 176 | sub Self::TIESCALAR { bless $_[1], $_[0] } |
d87ebaca | 177 | sub Self::DESTROY { $destroyed = 1; } |
33c27489 | 178 | { |
ae21d580 | 179 | my $c = 42; |
ae21d580 | 180 | tie $c, 'Self', \$c; |
33c27489 | 181 | } |
d87ebaca | 182 | die "self-tied scalar not DESTROYed" unless $destroyed == 1; |
7bb043c3 | 183 | EXPECT |
83f527ec | 184 | ######## |
3ca7705e | 185 | |
b5ccf5f2 | 186 | # Allowed glob self-ties |
87f0b213 JH |
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; | |
43bb546a | 199 | die "self-tied glob not DESTROYed" unless $destroyed == 1; |
87f0b213 JH |
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; } | |
b5ccf5f2 | 207 | sub Self3::PRINT { $printed = 1; } |
87f0b213 JH |
208 | { |
209 | use Symbol 'geniosym'; | |
210 | my $c = geniosym; | |
211 | tie *$c, 'Self3', $c; | |
b5ccf5f2 | 212 | print $c 'Hello'; |
87f0b213 | 213 | } |
b5ccf5f2 | 214 | die "self-tied IO not PRINTed" unless $printed == 1; |
43bb546a | 215 | die "self-tied IO not DESTROYed" unless $destroyed == 1; |
87f0b213 JH |
216 | EXPECT |
217 | ######## | |
0b2c215a | 218 | |
b5ccf5f2 YST |
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 | ||
d87ebaca YST |
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. | |
eb85dfd3 DM |
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 | |
b77f7d40 YST |
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 | |
dd28f7bb DM |
297 | ######## |
298 | ||
299 | # [20020716.007] - nested FETCHES | |
300 | ||
301 | sub F1::TIEARRAY { bless [], 'F1' } | |
302 | sub F1::FETCH { 1 } | |
303 | my @f1; | |
304 | tie @f1, 'F1'; | |
305 | ||
306 | sub F2::TIEARRAY { bless [2], 'F2' } | |
307 | sub F2::FETCH { my $self = shift; my $x = $f1[3]; $self } | |
308 | my @f2; | |
309 | tie @f2, 'F2'; | |
310 | ||
311 | print $f2[4][0],"\n"; | |
312 | ||
313 | sub F3::TIEHASH { bless [], 'F3' } | |
314 | sub F3::FETCH { 1 } | |
315 | my %f3; | |
316 | tie %f3, 'F3'; | |
317 | ||
318 | sub F4::TIEHASH { bless [3], 'F4' } | |
319 | sub F4::FETCH { my $self = shift; my $x = $f3{3}; $self } | |
320 | my %f4; | |
321 | tie %f4, 'F4'; | |
322 | ||
323 | print $f4{'foo'}[0],"\n"; | |
324 | ||
325 | EXPECT | |
326 | 2 | |
327 | 3 | |
38193a09 AM |
328 | ######## |
329 | # test untie() from within FETCH | |
330 | package Foo; | |
331 | sub TIESCALAR { my $pkg = shift; return bless [@_], $pkg; } | |
332 | sub FETCH { | |
333 | my $self = shift; | |
334 | my ($obj, $field) = @$self; | |
335 | untie $obj->{$field}; | |
336 | $obj->{$field} = "Bar"; | |
337 | } | |
338 | package main; | |
339 | tie $a->{foo}, "Foo", $a, "foo"; | |
340 | $a->{foo}; # access once | |
341 | # the hash element should not be tied anymore | |
342 | print defined tied $a->{foo} ? "not ok" : "ok"; | |
343 | EXPECT | |
344 | ok | |
be65207d DM |
345 | ######## |
346 | # the tmps returned by FETCH should appear to be SCALAR | |
347 | # (even though they are now implemented using PVLVs.) | |
348 | package X; | |
349 | sub TIEHASH { bless {} } | |
350 | sub TIEARRAY { bless {} } | |
351 | sub FETCH {1} | |
352 | my (%h, @a); | |
353 | tie %h, 'X'; | |
354 | tie @a, 'X'; | |
355 | my $r1 = \$h{1}; | |
356 | my $r2 = \$a[0]; | |
357 | my $s = "$r1 ". ref($r1) . " $r2 " . ref($r2); | |
358 | $s=~ s/\(0x\w+\)//g; | |
359 | print $s, "\n"; | |
360 | EXPECT | |
361 | SCALAR SCALAR SCALAR SCALAR | |
b7056d9c JH |
362 | ######## |
363 | # [perl #23287] segfault in untie | |
364 | sub TIESCALAR { bless $_[1], $_[0] } | |
365 | my $var; | |
366 | tie $var, 'main', \$var; | |
367 | untie $var; | |
368 | EXPECT | |
16e0ce55 JH |
369 | ######## |
370 | # Test case from perlmonks by runrig | |
371 | # http://www.perlmonks.org/index.pl?node_id=273490 | |
372 | # "Here is what I tried. I think its similar to what you've tried | |
373 | # above. Its odd but convienient that after untie'ing you are left with | |
374 | # a variable that has the same value as was last returned from | |
375 | # FETCH. (At least on my perl v5.6.1). So you don't need to pass a | |
376 | # reference to the variable in order to set it after the untie (here it | |
377 | # is accessed through a closure)." | |
378 | use strict; | |
379 | use warnings; | |
380 | package MyTied; | |
381 | sub TIESCALAR { | |
382 | my ($class,$code) = @_; | |
383 | bless $code, $class; | |
384 | } | |
385 | sub FETCH { | |
386 | my $self = shift; | |
387 | print "Untie\n"; | |
388 | $self->(); | |
389 | } | |
390 | package main; | |
391 | my $var; | |
392 | tie $var, 'MyTied', sub { untie $var; 4 }; | |
393 | print "One\n"; | |
394 | print "$var\n"; | |
395 | print "Two\n"; | |
396 | print "$var\n"; | |
397 | print "Three\n"; | |
398 | print "$var\n"; | |
399 | EXPECT | |
400 | One | |
401 | Untie | |
402 | 4 | |
403 | Two | |
404 | 4 | |
405 | Three | |
406 | 4 | |
dd12389b JH |
407 | ######## |
408 | # [perl #22297] cannot untie scalar from within tied FETCH | |
409 | my $counter = 0; | |
410 | my $x = 7; | |
411 | my $ref = \$x; | |
412 | tie $x, 'Overlay', $ref, $x; | |
413 | my $y; | |
414 | $y = $x; | |
415 | $y = $x; | |
416 | $y = $x; | |
417 | $y = $x; | |
418 | #print "WILL EXTERNAL UNTIE $ref\n"; | |
419 | untie $$ref; | |
420 | $y = $x; | |
421 | $y = $x; | |
422 | $y = $x; | |
423 | $y = $x; | |
424 | #print "counter = $counter\n"; | |
425 | ||
426 | print (($counter == 1) ? "ok\n" : "not ok\n"); | |
427 | ||
428 | package Overlay; | |
429 | ||
430 | sub TIESCALAR | |
431 | { | |
432 | my $pkg = shift; | |
433 | my ($ref, $val) = @_; | |
434 | return bless [ $ref, $val ], $pkg; | |
435 | } | |
436 | ||
437 | sub FETCH | |
438 | { | |
439 | my $self = shift; | |
440 | my ($ref, $val) = @$self; | |
441 | #print "WILL INTERNAL UNITE $ref\n"; | |
442 | $counter++; | |
443 | untie $$ref; | |
444 | return $val; | |
445 | } | |
446 | EXPECT | |
447 | ok | |
6c0731c3 RC |
448 | ######## |
449 | ||
450 | # TODO [perl #948] cannot meaningfully tie $, | |
451 | package TieDollarComma; | |
452 | ||
453 | sub TIESCALAR { | |
454 | my $pkg = shift; | |
455 | return bless \my $x, $pkg; | |
456 | } | |
457 | ||
458 | sub STORE { | |
459 | my $self = shift; | |
460 | $$self = shift; | |
461 | print "STORE set '$$self'\n"; | |
462 | } | |
463 | ||
464 | sub FETCH { | |
465 | my $self = shift; | |
466 | print "FETCH\n"; | |
467 | return $$self; | |
468 | } | |
469 | package main; | |
470 | ||
471 | tie $,, 'TieDollarComma'; | |
472 | $, = 'BOBBINS'; | |
473 | print "join", "things", "up\n"; | |
474 | EXPECT | |
475 | STORE set 'BOBBINS' | |
476 | FETCH | |
477 | FETCH | |
478 | joinBOBBINSthingsBOBBINSup | |
a3bcc51e TP |
479 | ######## |
480 | ||
481 | # test SCALAR method | |
482 | package TieScalar; | |
483 | ||
484 | sub TIEHASH { | |
485 | my $pkg = shift; | |
486 | bless { } => $pkg; | |
487 | } | |
488 | ||
489 | sub STORE { | |
490 | $_[0]->{$_[1]} = $_[2]; | |
491 | } | |
492 | ||
493 | sub FETCH { | |
494 | $_[0]->{$_[1]} | |
495 | } | |
496 | ||
497 | sub CLEAR { | |
498 | %{ $_[0] } = (); | |
499 | } | |
500 | ||
501 | sub SCALAR { | |
502 | print "SCALAR\n"; | |
503 | return 0 if ! keys %{$_[0]}; | |
504 | sprintf "%i/%i", scalar keys %{$_[0]}, scalar keys %{$_[0]}; | |
505 | } | |
506 | ||
507 | package main; | |
508 | tie my %h => "TieScalar"; | |
509 | $h{key1} = "val1"; | |
510 | $h{key2} = "val2"; | |
511 | print scalar %h, "\n"; | |
512 | %h = (); | |
513 | print scalar %h, "\n"; | |
514 | EXPECT | |
515 | SCALAR | |
516 | 2/2 | |
517 | SCALAR | |
518 | 0 | |
519 | ######## | |
520 | ||
521 | # test scalar on tied hash when no SCALAR method has been given | |
522 | package TieScalar; | |
523 | ||
524 | sub TIEHASH { | |
525 | my $pkg = shift; | |
526 | bless { } => $pkg; | |
527 | } | |
528 | sub STORE { | |
529 | $_[0]->{$_[1]} = $_[2]; | |
530 | } | |
531 | sub FETCH { | |
532 | $_[0]->{$_[1]} | |
533 | } | |
534 | sub CLEAR { | |
535 | %{ $_[0] } = (); | |
536 | } | |
537 | sub FIRSTKEY { | |
538 | my $a = keys %{ $_[0] }; | |
539 | print "FIRSTKEY\n"; | |
540 | each %{ $_[0] }; | |
541 | } | |
542 | ||
543 | package main; | |
544 | tie my %h => "TieScalar"; | |
545 | ||
546 | if (!%h) { | |
547 | print "empty\n"; | |
548 | } else { | |
549 | print "not empty\n"; | |
550 | } | |
551 | ||
552 | $h{key1} = "val1"; | |
553 | print "not empty\n" if %h; | |
554 | print "not empty\n" if %h; | |
555 | print "-->\n"; | |
556 | my ($k,$v) = each %h; | |
557 | print "<--\n"; | |
558 | print "not empty\n" if %h; | |
559 | %h = (); | |
560 | print "empty\n" if ! %h; | |
561 | EXPECT | |
562 | FIRSTKEY | |
563 | empty | |
564 | FIRSTKEY | |
565 | not empty | |
566 | FIRSTKEY | |
567 | not empty | |
568 | --> | |
569 | FIRSTKEY | |
570 | <-- | |
571 | not empty | |
572 | FIRSTKEY | |
573 | empty |