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'; |
5f7e0818 | 14 | require './test.pl'; |
49d42823 | 15 | |
16 | $|=1; | |
17 | ||
5f7e0818 | 18 | run_multiple_progs('', \*DATA); |
d87ebaca | 19 | |
5f7e0818 | 20 | done_testing(); |
49d42823 | 21 | |
22 | __END__ | |
23 | ||
24 | # standard behaviour, without any extra references | |
25 | use Tie::Hash ; | |
26 | tie %h, Tie::StdHash; | |
27 | untie %h; | |
28 | EXPECT | |
29 | ######## | |
fc08da98 | 30 | # SKIP ?!defined &DynaLoader::boot_DynaLoader && !eval 'require base' |
19295df3 | 31 | # (skip under miniperl if base.pm is not in lib/ yet) |
49d42823 | 32 | |
a29a5827 NIS |
33 | # standard behaviour, without any extra references |
34 | use Tie::Hash ; | |
35 | {package Tie::HashUntie; | |
36 | use base 'Tie::StdHash'; | |
37 | sub UNTIE | |
38 | { | |
39 | warn "Untied\n"; | |
40 | } | |
41 | } | |
42 | tie %h, Tie::HashUntie; | |
43 | untie %h; | |
44 | EXPECT | |
45 | Untied | |
46 | ######## | |
47 | ||
49d42823 | 48 | # standard behaviour, with 1 extra reference |
49 | use Tie::Hash ; | |
50 | $a = tie %h, Tie::StdHash; | |
51 | untie %h; | |
52 | EXPECT | |
53 | ######## | |
54 | ||
55 | # standard behaviour, with 1 extra reference via tied | |
56 | use Tie::Hash ; | |
57 | tie %h, Tie::StdHash; | |
58 | $a = tied %h; | |
59 | untie %h; | |
60 | EXPECT | |
61 | ######## | |
62 | ||
63 | # standard behaviour, with 1 extra reference which is destroyed | |
64 | use Tie::Hash ; | |
65 | $a = tie %h, Tie::StdHash; | |
66 | $a = 0 ; | |
67 | untie %h; | |
68 | EXPECT | |
69 | ######## | |
70 | ||
71 | # standard behaviour, with 1 extra reference via tied which is destroyed | |
72 | use Tie::Hash ; | |
73 | tie %h, Tie::StdHash; | |
74 | $a = tied %h; | |
75 | $a = 0 ; | |
76 | untie %h; | |
77 | EXPECT | |
78 | ######## | |
79 | ||
80 | # strict behaviour, without any extra references | |
4438c4b7 | 81 | use warnings 'untie'; |
49d42823 | 82 | use Tie::Hash ; |
83 | tie %h, Tie::StdHash; | |
84 | untie %h; | |
85 | EXPECT | |
86 | ######## | |
87 | ||
88 | # strict behaviour, with 1 extra references generating an error | |
4438c4b7 | 89 | use warnings 'untie'; |
49d42823 | 90 | use Tie::Hash ; |
91 | $a = tie %h, Tie::StdHash; | |
92 | untie %h; | |
93 | EXPECT | |
d87ebaca | 94 | untie attempted while 1 inner references still exist at - line 6. |
49d42823 | 95 | ######## |
96 | ||
97 | # strict behaviour, with 1 extra references via tied generating an error | |
4438c4b7 | 98 | use warnings 'untie'; |
49d42823 | 99 | use Tie::Hash ; |
100 | tie %h, Tie::StdHash; | |
101 | $a = tied %h; | |
102 | untie %h; | |
103 | EXPECT | |
d87ebaca | 104 | untie attempted while 1 inner references still exist at - line 7. |
49d42823 | 105 | ######## |
106 | ||
107 | # strict behaviour, with 1 extra references which are destroyed | |
4438c4b7 | 108 | use warnings 'untie'; |
49d42823 | 109 | use Tie::Hash ; |
110 | $a = tie %h, Tie::StdHash; | |
111 | $a = 0 ; | |
112 | untie %h; | |
113 | EXPECT | |
114 | ######## | |
115 | ||
116 | # strict behaviour, with extra 1 references via tied which are destroyed | |
4438c4b7 | 117 | use warnings 'untie'; |
49d42823 | 118 | use Tie::Hash ; |
119 | tie %h, Tie::StdHash; | |
120 | $a = tied %h; | |
121 | $a = 0 ; | |
122 | untie %h; | |
123 | EXPECT | |
124 | ######## | |
125 | ||
87f0b213 | 126 | # strict error behaviour, with 2 extra references |
4438c4b7 | 127 | use warnings 'untie'; |
49d42823 | 128 | use Tie::Hash ; |
129 | $a = tie %h, Tie::StdHash; | |
130 | $b = tied %h ; | |
131 | untie %h; | |
132 | EXPECT | |
d87ebaca | 133 | untie attempted while 2 inner references still exist at - line 7. |
49d42823 | 134 | ######## |
135 | ||
136 | # strict behaviour, check scope of strictness. | |
4438c4b7 | 137 | no warnings 'untie'; |
49d42823 | 138 | use Tie::Hash ; |
139 | $A = tie %H, Tie::StdHash; | |
140 | $C = $B = tied %H ; | |
141 | { | |
4438c4b7 | 142 | use warnings 'untie'; |
49d42823 | 143 | use Tie::Hash ; |
144 | tie %h, Tie::StdHash; | |
145 | untie %h; | |
146 | } | |
147 | untie %H; | |
148 | EXPECT | |
33c27489 | 149 | ######## |
d87ebaca | 150 | |
ae21d580 | 151 | # Forbidden aggregate self-ties |
33c27489 | 152 | sub Self::TIEHASH { bless $_[1], $_[0] } |
ae21d580 | 153 | { |
d87ebaca | 154 | my %c; |
ae21d580 JH |
155 | tie %c, 'Self', \%c; |
156 | } | |
157 | EXPECT | |
d87ebaca | 158 | Self-ties of arrays and hashes are not supported at - line 6. |
ae21d580 | 159 | ######## |
d87ebaca | 160 | |
ae21d580 | 161 | # Allowed scalar self-ties |
d87ebaca | 162 | my $destroyed = 0; |
ae21d580 | 163 | sub Self::TIESCALAR { bless $_[1], $_[0] } |
d87ebaca | 164 | sub Self::DESTROY { $destroyed = 1; } |
33c27489 | 165 | { |
ae21d580 | 166 | my $c = 42; |
ae21d580 | 167 | tie $c, 'Self', \$c; |
33c27489 | 168 | } |
d87ebaca | 169 | die "self-tied scalar not DESTROYed" unless $destroyed == 1; |
7bb043c3 | 170 | EXPECT |
83f527ec | 171 | ######## |
3ca7705e | 172 | |
b5ccf5f2 | 173 | # Allowed glob self-ties |
87f0b213 JH |
174 | my $destroyed = 0; |
175 | my $printed = 0; | |
176 | sub Self2::TIEHANDLE { bless $_[1], $_[0] } | |
177 | sub Self2::DESTROY { $destroyed = 1; } | |
178 | sub Self2::PRINT { $printed = 1; } | |
179 | { | |
180 | use Symbol; | |
181 | my $c = gensym; | |
182 | tie *$c, 'Self2', $c; | |
183 | print $c 'Hello'; | |
184 | } | |
185 | die "self-tied glob not PRINTed" unless $printed == 1; | |
43bb546a | 186 | die "self-tied glob not DESTROYed" unless $destroyed == 1; |
87f0b213 JH |
187 | EXPECT |
188 | ######## | |
189 | ||
190 | # Allowed IO self-ties | |
191 | my $destroyed = 0; | |
192 | sub Self3::TIEHANDLE { bless $_[1], $_[0] } | |
193 | sub Self3::DESTROY { $destroyed = 1; } | |
b5ccf5f2 | 194 | sub Self3::PRINT { $printed = 1; } |
87f0b213 JH |
195 | { |
196 | use Symbol 'geniosym'; | |
197 | my $c = geniosym; | |
198 | tie *$c, 'Self3', $c; | |
b5ccf5f2 | 199 | print $c 'Hello'; |
87f0b213 | 200 | } |
b5ccf5f2 | 201 | die "self-tied IO not PRINTed" unless $printed == 1; |
43bb546a | 202 | die "self-tied IO not DESTROYed" unless $destroyed == 1; |
87f0b213 JH |
203 | EXPECT |
204 | ######## | |
0b2c215a | 205 | |
b5ccf5f2 YST |
206 | # TODO IO "self-tie" via TEMP glob |
207 | my $destroyed = 0; | |
208 | sub Self3::TIEHANDLE { bless $_[1], $_[0] } | |
209 | sub Self3::DESTROY { $destroyed = 1; } | |
210 | sub Self3::PRINT { $printed = 1; } | |
211 | { | |
212 | use Symbol 'geniosym'; | |
213 | my $c = geniosym; | |
214 | tie *$c, 'Self3', \*$c; | |
215 | print $c 'Hello'; | |
216 | } | |
217 | die "IO tied to TEMP glob not PRINTed" unless $printed == 1; | |
218 | die "IO tied to TEMP glob not DESTROYed" unless $destroyed == 1; | |
219 | EXPECT | |
220 | ######## | |
221 | ||
d87ebaca YST |
222 | # Interaction of tie and vec |
223 | ||
224 | my ($a, $b); | |
225 | use Tie::Scalar; | |
226 | tie $a,Tie::StdScalar or die; | |
227 | vec($b,1,1)=1; | |
228 | $a = $b; | |
229 | vec($a,1,1)=0; | |
230 | vec($b,1,1)=0; | |
231 | die unless $a eq $b; | |
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'} } warn "plain hash bad unlocalize" if exists $hash{'foo'}; | |
239 | { local $tied{'foo'} } warn "tied hash bad unlocalize" if exists $tied{'foo'}; | |
240 | { local $ENV{'foo'} } warn "%ENV bad unlocalize" if exists $ENV{'foo'}; | |
241 | EXPECT | |
242 | ######## | |
243 | ||
244 | # An attempt at lvalueable barewords broke this | |
245 | tie FH, 'main'; | |
246 | EXPECT | |
247 | Can't modify constant item in tie at - line 3, near "'main';" | |
248 | Execution of - aborted due to compilation errors. | |
eb85dfd3 DM |
249 | ######## |
250 | ||
251 | # localizing tied hash slices | |
252 | $ENV{FooA} = 1; | |
253 | $ENV{FooB} = 2; | |
254 | print exists $ENV{FooA} ? 1 : 0, "\n"; | |
255 | print exists $ENV{FooB} ? 2 : 0, "\n"; | |
256 | print exists $ENV{FooC} ? 3 : 0, "\n"; | |
257 | { | |
258 | local @ENV{qw(FooA FooC)}; | |
259 | print exists $ENV{FooA} ? 4 : 0, "\n"; | |
260 | print exists $ENV{FooB} ? 5 : 0, "\n"; | |
261 | print exists $ENV{FooC} ? 6 : 0, "\n"; | |
262 | } | |
263 | print exists $ENV{FooA} ? 7 : 0, "\n"; | |
264 | print exists $ENV{FooB} ? 8 : 0, "\n"; | |
265 | print exists $ENV{FooC} ? 9 : 0, "\n"; # this should not exist | |
266 | EXPECT | |
267 | 1 | |
268 | 2 | |
269 | 0 | |
270 | 4 | |
271 | 5 | |
272 | 6 | |
273 | 7 | |
274 | 8 | |
275 | 0 | |
b77f7d40 YST |
276 | ######## |
277 | # | |
4bac9ae4 | 278 | # FETCH freeing tie'd SV still works |
b77f7d40 | 279 | sub TIESCALAR { bless [] } |
4bac9ae4 | 280 | sub FETCH { *a = \1; 2 } |
b77f7d40 YST |
281 | tie $a, 'main'; |
282 | print $a; | |
283 | EXPECT | |
4bac9ae4 | 284 | 2 |
dd28f7bb DM |
285 | ######## |
286 | ||
287 | # [20020716.007] - nested FETCHES | |
288 | ||
289 | sub F1::TIEARRAY { bless [], 'F1' } | |
290 | sub F1::FETCH { 1 } | |
291 | my @f1; | |
292 | tie @f1, 'F1'; | |
293 | ||
294 | sub F2::TIEARRAY { bless [2], 'F2' } | |
295 | sub F2::FETCH { my $self = shift; my $x = $f1[3]; $self } | |
296 | my @f2; | |
297 | tie @f2, 'F2'; | |
298 | ||
299 | print $f2[4][0],"\n"; | |
300 | ||
301 | sub F3::TIEHASH { bless [], 'F3' } | |
302 | sub F3::FETCH { 1 } | |
303 | my %f3; | |
304 | tie %f3, 'F3'; | |
305 | ||
306 | sub F4::TIEHASH { bless [3], 'F4' } | |
307 | sub F4::FETCH { my $self = shift; my $x = $f3{3}; $self } | |
308 | my %f4; | |
309 | tie %f4, 'F4'; | |
310 | ||
311 | print $f4{'foo'}[0],"\n"; | |
312 | ||
313 | EXPECT | |
314 | 2 | |
315 | 3 | |
38193a09 AM |
316 | ######## |
317 | # test untie() from within FETCH | |
318 | package Foo; | |
319 | sub TIESCALAR { my $pkg = shift; return bless [@_], $pkg; } | |
320 | sub FETCH { | |
321 | my $self = shift; | |
322 | my ($obj, $field) = @$self; | |
323 | untie $obj->{$field}; | |
324 | $obj->{$field} = "Bar"; | |
325 | } | |
326 | package main; | |
327 | tie $a->{foo}, "Foo", $a, "foo"; | |
39cf747a | 328 | my $s = $a->{foo}; # access once |
38193a09 AM |
329 | # the hash element should not be tied anymore |
330 | print defined tied $a->{foo} ? "not ok" : "ok"; | |
331 | EXPECT | |
332 | ok | |
be65207d DM |
333 | ######## |
334 | # the tmps returned by FETCH should appear to be SCALAR | |
335 | # (even though they are now implemented using PVLVs.) | |
336 | package X; | |
337 | sub TIEHASH { bless {} } | |
338 | sub TIEARRAY { bless {} } | |
339 | sub FETCH {1} | |
340 | my (%h, @a); | |
341 | tie %h, 'X'; | |
342 | tie @a, 'X'; | |
343 | my $r1 = \$h{1}; | |
344 | my $r2 = \$a[0]; | |
345 | my $s = "$r1 ". ref($r1) . " $r2 " . ref($r2); | |
346 | $s=~ s/\(0x\w+\)//g; | |
347 | print $s, "\n"; | |
348 | EXPECT | |
349 | SCALAR SCALAR SCALAR SCALAR | |
b7056d9c JH |
350 | ######## |
351 | # [perl #23287] segfault in untie | |
352 | sub TIESCALAR { bless $_[1], $_[0] } | |
353 | my $var; | |
354 | tie $var, 'main', \$var; | |
355 | untie $var; | |
356 | EXPECT | |
16e0ce55 JH |
357 | ######## |
358 | # Test case from perlmonks by runrig | |
359 | # http://www.perlmonks.org/index.pl?node_id=273490 | |
360 | # "Here is what I tried. I think its similar to what you've tried | |
93f09d7b | 361 | # above. Its odd but convenient that after untie'ing you are left with |
16e0ce55 JH |
362 | # a variable that has the same value as was last returned from |
363 | # FETCH. (At least on my perl v5.6.1). So you don't need to pass a | |
364 | # reference to the variable in order to set it after the untie (here it | |
365 | # is accessed through a closure)." | |
366 | use strict; | |
367 | use warnings; | |
368 | package MyTied; | |
369 | sub TIESCALAR { | |
370 | my ($class,$code) = @_; | |
371 | bless $code, $class; | |
372 | } | |
373 | sub FETCH { | |
374 | my $self = shift; | |
375 | print "Untie\n"; | |
376 | $self->(); | |
377 | } | |
378 | package main; | |
379 | my $var; | |
380 | tie $var, 'MyTied', sub { untie $var; 4 }; | |
381 | print "One\n"; | |
382 | print "$var\n"; | |
383 | print "Two\n"; | |
384 | print "$var\n"; | |
385 | print "Three\n"; | |
386 | print "$var\n"; | |
387 | EXPECT | |
388 | One | |
389 | Untie | |
390 | 4 | |
391 | Two | |
392 | 4 | |
393 | Three | |
394 | 4 | |
dd12389b JH |
395 | ######## |
396 | # [perl #22297] cannot untie scalar from within tied FETCH | |
397 | my $counter = 0; | |
398 | my $x = 7; | |
399 | my $ref = \$x; | |
400 | tie $x, 'Overlay', $ref, $x; | |
401 | my $y; | |
402 | $y = $x; | |
403 | $y = $x; | |
404 | $y = $x; | |
405 | $y = $x; | |
406 | #print "WILL EXTERNAL UNTIE $ref\n"; | |
407 | untie $$ref; | |
408 | $y = $x; | |
409 | $y = $x; | |
410 | $y = $x; | |
411 | $y = $x; | |
412 | #print "counter = $counter\n"; | |
413 | ||
414 | print (($counter == 1) ? "ok\n" : "not ok\n"); | |
415 | ||
416 | package Overlay; | |
417 | ||
418 | sub TIESCALAR | |
419 | { | |
420 | my $pkg = shift; | |
421 | my ($ref, $val) = @_; | |
422 | return bless [ $ref, $val ], $pkg; | |
423 | } | |
424 | ||
425 | sub FETCH | |
426 | { | |
427 | my $self = shift; | |
428 | my ($ref, $val) = @$self; | |
429 | #print "WILL INTERNAL UNITE $ref\n"; | |
430 | $counter++; | |
431 | untie $$ref; | |
432 | return $val; | |
433 | } | |
434 | EXPECT | |
435 | ok | |
6c0731c3 RC |
436 | ######## |
437 | ||
e23d9e2f | 438 | # [perl #948] cannot meaningfully tie $, |
6c0731c3 RC |
439 | package TieDollarComma; |
440 | ||
441 | sub TIESCALAR { | |
442 | my $pkg = shift; | |
443 | return bless \my $x, $pkg; | |
444 | } | |
445 | ||
446 | sub STORE { | |
447 | my $self = shift; | |
448 | $$self = shift; | |
449 | print "STORE set '$$self'\n"; | |
450 | } | |
451 | ||
452 | sub FETCH { | |
453 | my $self = shift; | |
e23d9e2f | 454 | print "<FETCH>"; |
6c0731c3 RC |
455 | return $$self; |
456 | } | |
457 | package main; | |
458 | ||
459 | tie $,, 'TieDollarComma'; | |
460 | $, = 'BOBBINS'; | |
461 | print "join", "things", "up\n"; | |
462 | EXPECT | |
463 | STORE set 'BOBBINS' | |
e23d9e2f | 464 | join<FETCH>BOBBINSthings<FETCH>BOBBINSup |
a3bcc51e TP |
465 | ######## |
466 | ||
467 | # test SCALAR method | |
468 | package TieScalar; | |
469 | ||
470 | sub TIEHASH { | |
471 | my $pkg = shift; | |
472 | bless { } => $pkg; | |
473 | } | |
474 | ||
475 | sub STORE { | |
476 | $_[0]->{$_[1]} = $_[2]; | |
477 | } | |
478 | ||
479 | sub FETCH { | |
480 | $_[0]->{$_[1]} | |
481 | } | |
482 | ||
483 | sub CLEAR { | |
484 | %{ $_[0] } = (); | |
485 | } | |
486 | ||
487 | sub SCALAR { | |
488 | print "SCALAR\n"; | |
489 | return 0 if ! keys %{$_[0]}; | |
490 | sprintf "%i/%i", scalar keys %{$_[0]}, scalar keys %{$_[0]}; | |
491 | } | |
492 | ||
493 | package main; | |
494 | tie my %h => "TieScalar"; | |
495 | $h{key1} = "val1"; | |
496 | $h{key2} = "val2"; | |
867fa1e2 YO |
497 | print scalar %h, "\n" |
498 | if %h; # this should also call SCALAR but implicitly | |
a3bcc51e | 499 | %h = (); |
867fa1e2 YO |
500 | print scalar %h, "\n" |
501 | if !%h; # this should also call SCALAR but implicitly | |
a3bcc51e TP |
502 | EXPECT |
503 | SCALAR | |
867fa1e2 | 504 | SCALAR |
a3bcc51e TP |
505 | 2/2 |
506 | SCALAR | |
867fa1e2 | 507 | SCALAR |
a3bcc51e TP |
508 | 0 |
509 | ######## | |
510 | ||
511 | # test scalar on tied hash when no SCALAR method has been given | |
512 | package TieScalar; | |
513 | ||
514 | sub TIEHASH { | |
515 | my $pkg = shift; | |
516 | bless { } => $pkg; | |
517 | } | |
518 | sub STORE { | |
519 | $_[0]->{$_[1]} = $_[2]; | |
520 | } | |
521 | sub FETCH { | |
522 | $_[0]->{$_[1]} | |
523 | } | |
524 | sub CLEAR { | |
525 | %{ $_[0] } = (); | |
526 | } | |
527 | sub FIRSTKEY { | |
528 | my $a = keys %{ $_[0] }; | |
529 | print "FIRSTKEY\n"; | |
530 | each %{ $_[0] }; | |
531 | } | |
532 | ||
533 | package main; | |
534 | tie my %h => "TieScalar"; | |
535 | ||
536 | if (!%h) { | |
537 | print "empty\n"; | |
538 | } else { | |
539 | print "not empty\n"; | |
540 | } | |
541 | ||
542 | $h{key1} = "val1"; | |
543 | print "not empty\n" if %h; | |
544 | print "not empty\n" if %h; | |
545 | print "-->\n"; | |
546 | my ($k,$v) = each %h; | |
547 | print "<--\n"; | |
548 | print "not empty\n" if %h; | |
549 | %h = (); | |
550 | print "empty\n" if ! %h; | |
551 | EXPECT | |
552 | FIRSTKEY | |
553 | empty | |
554 | FIRSTKEY | |
555 | not empty | |
556 | FIRSTKEY | |
557 | not empty | |
558 | --> | |
559 | FIRSTKEY | |
560 | <-- | |
561 | not empty | |
562 | FIRSTKEY | |
563 | empty | |
2b77b520 YST |
564 | ######## |
565 | sub TIESCALAR { bless {} } | |
566 | sub FETCH { my $x = 3.3; 1 if 0+$x; $x } | |
567 | tie $h, "main"; | |
568 | print $h,"\n"; | |
569 | EXPECT | |
570 | 3.3 | |
c75ab21a RH |
571 | ######## |
572 | sub TIESCALAR { bless {} } | |
573 | sub FETCH { shift()->{i} ++ } | |
574 | tie $h, "main"; | |
575 | print $h.$h; | |
576 | EXPECT | |
577 | 01 | |
64207fde | 578 | ######## |
d6fdb726 KW |
579 | # SKIP ? $IS_EBCDIC |
580 | # skipped on EBCDIC because "2" | "8" is 0xFA (not COLON as it is on ASCII), | |
581 | # which isn't representable in this file's UTF-8 encoding. | |
7de9d14e | 582 | # Bug 53482 (and maybe others) |
d6fdb726 | 583 | |
64207fde RB |
584 | sub TIESCALAR { my $foo = $_[1]; bless \$foo, $_[0] } |
585 | sub FETCH { ${$_[0]} } | |
7de9d14e B |
586 | tie my $x1, "main", 2; |
587 | tie my $y1, "main", 8; | |
588 | print $x1 | $y1; | |
589 | print $x1 | $y1; | |
590 | tie my $x2, "main", "2"; | |
591 | tie my $y2, "main", "8"; | |
592 | print $x2 | $y2; | |
593 | print $x2 | $y2; | |
594 | EXPECT | |
595 | 1010:: | |
1baaf5d7 NC |
596 | ######## |
597 | # Bug 36267 | |
598 | sub TIEHASH { bless {}, $_[0] } | |
599 | sub STORE { $_[0]->{$_[1]} = $_[2] } | |
600 | sub FIRSTKEY { my $a = scalar keys %{$_[0]}; each %{$_[0]} } | |
601 | sub NEXTKEY { each %{$_[0]} } | |
602 | sub DELETE { delete $_[0]->{$_[1]} } | |
603 | sub CLEAR { %{$_[0]} = () } | |
604 | $h{b}=1; | |
605 | delete $h{b}; | |
606 | print scalar keys %h, "\n"; | |
607 | tie %h, 'main'; | |
608 | $i{a}=1; | |
609 | %h = %i; | |
610 | untie %h; | |
611 | print scalar keys %h, "\n"; | |
612 | EXPECT | |
613 | 0 | |
614 | 0 | |
ced497e2 YST |
615 | ######## |
616 | # Bug 37731 | |
617 | sub foo::TIESCALAR { bless {value => $_[1]}, $_[0] } | |
618 | sub foo::FETCH { $_[0]->{value} } | |
619 | tie my $VAR, 'foo', '42'; | |
620 | foreach my $var ($VAR) { | |
621 | print +($var eq $VAR) ? "yes\n" : "no\n"; | |
622 | } | |
623 | EXPECT | |
624 | yes | |
f4c21a45 DM |
625 | ######## |
626 | sub TIEARRAY { bless [], 'main' } | |
627 | { | |
628 | local @a; | |
629 | tie @a, 'main'; | |
630 | } | |
631 | print "tied\n" if tied @a; | |
632 | EXPECT | |
633 | ######## | |
634 | sub TIEHASH { bless [], 'main' } | |
635 | { | |
636 | local %h; | |
637 | tie %h, 'main'; | |
638 | } | |
639 | print "tied\n" if tied %h; | |
640 | EXPECT | |
099be4f1 DM |
641 | ######## |
642 | # RT 20727: PL_defoutgv is left as a tied element | |
643 | sub TIESCALAR { return bless {}, 'main' } | |
644 | ||
645 | sub STORE { | |
646 | select($_[1]); | |
647 | $_[1] = 1; | |
648 | select(); # this used to coredump or assert fail | |
649 | } | |
650 | tie $SELECT, 'main'; | |
651 | $SELECT = *STDERR; | |
652 | EXPECT | |
27e90453 DM |
653 | ######## |
654 | # RT 23810: eval in die in FETCH can corrupt context stack | |
655 | ||
656 | my $file = 'rt23810.pm'; | |
657 | ||
658 | my $e; | |
659 | my $s; | |
660 | ||
661 | sub do_require { | |
662 | my ($str, $eval) = @_; | |
663 | open my $fh, '>', $file or die "Can't create $file: $!\n"; | |
664 | print $fh $str; | |
665 | close $fh; | |
666 | if ($eval) { | |
667 | $s .= '-ERQ'; | |
668 | eval { require $pm; $s .= '-ENDE' } | |
669 | } | |
670 | else { | |
671 | $s .= '-RQ'; | |
672 | require $pm; | |
673 | } | |
674 | $s .= '-ENDRQ'; | |
675 | unlink $file; | |
676 | } | |
677 | ||
678 | sub TIEHASH { bless {} } | |
679 | ||
680 | sub FETCH { | |
681 | # 10 or more syntax errors makes yyparse croak() | |
682 | my $bad = q{$x+;$x+;$x+;$x+;$x+;$x+;$x+;$x+;$x+$x+;$x+;$x+;$x+;$x+;;$x+;}; | |
683 | ||
684 | if ($_[1] eq 'eval') { | |
685 | $s .= 'EVAL'; | |
686 | eval q[BEGIN { die; $s .= '-X1' }]; | |
687 | $s .= '-BD'; | |
688 | eval q[BEGIN { $x+ }]; | |
689 | $s .= '-BS'; | |
690 | eval '$x+'; | |
691 | $s .= '-E1'; | |
692 | $s .= '-S1' while $@ =~ /syntax error at/g; | |
693 | eval $bad; | |
694 | $s .= '-E2'; | |
695 | $s .= '-S2' while $@ =~ /syntax error at/g; | |
696 | } | |
697 | elsif ($_[1] eq 'require') { | |
698 | $s .= 'REQUIRE'; | |
699 | my @text = ( | |
700 | q[BEGIN { die; $s .= '-X1' }], | |
701 | q[BEGIN { $x+ }], | |
702 | '$x+', | |
703 | $bad | |
704 | ); | |
705 | for my $i (0..$#text) { | |
706 | $s .= "-$i"; | |
707 | do_require($txt[$i], 0) if $e;; | |
708 | do_require($txt[$i], 1); | |
709 | } | |
710 | } | |
711 | elsif ($_[1] eq 'exit') { | |
712 | eval q[exit(0); print "overshot eval\n"]; | |
713 | } | |
714 | else { | |
715 | print "unknown key: '$_[1]'\n"; | |
716 | } | |
717 | return "-R"; | |
718 | } | |
719 | my %foo; | |
720 | tie %foo, "main"; | |
721 | ||
722 | for my $action(qw(eval require)) { | |
723 | $s = ''; $e = 0; $s .= main->FETCH($action); print "$action: s0=$s\n"; | |
724 | $s = ''; $e = 1; eval { $s .= main->FETCH($action)}; print "$action: s1=$s\n"; | |
725 | $s = ''; $e = 0; $s .= $foo{$action}; print "$action: s2=$s\n"; | |
726 | $s = ''; $e = 1; eval { $s .= $foo{$action}}; print "$action: s3=$s\n"; | |
727 | } | |
728 | 1 while unlink $file; | |
729 | ||
730 | $foo{'exit'}; | |
731 | print "overshot main\n"; # shouldn't reach here | |
732 | ||
733 | EXPECT | |
734 | eval: s0=EVAL-BD-BS-E1-S1-E2-S2-S2-S2-S2-S2-S2-S2-S2-S2-S2-R | |
735 | eval: s1=EVAL-BD-BS-E1-S1-E2-S2-S2-S2-S2-S2-S2-S2-S2-S2-S2-R | |
736 | eval: s2=EVAL-BD-BS-E1-S1-E2-S2-S2-S2-S2-S2-S2-S2-S2-S2-S2-R | |
737 | eval: s3=EVAL-BD-BS-E1-S1-E2-S2-S2-S2-S2-S2-S2-S2-S2-S2-S2-R | |
738 | require: s0=REQUIRE-0-ERQ-ENDRQ-1-ERQ-ENDRQ-2-ERQ-ENDRQ-3-ERQ-ENDRQ-R | |
739 | require: s1=REQUIRE-0-RQ | |
740 | require: s2=REQUIRE-0-ERQ-ENDRQ-1-ERQ-ENDRQ-2-ERQ-ENDRQ-3-ERQ-ENDRQ-R | |
741 | require: s3=REQUIRE-0-RQ | |
459defa1 DM |
742 | ######## |
743 | # RT 8857: STORE incorrectly invoked for local($_) on aliased tied array | |
744 | # element | |
745 | ||
746 | sub TIEARRAY { bless [], $_[0] } | |
747 | sub TIEHASH { bless [], $_[0] } | |
748 | sub FETCH { $_[0]->[$_[1]] } | |
749 | sub STORE { $_[0]->[$_[1]] = $_[2] } | |
750 | ||
751 | ||
752 | sub f { | |
753 | local $_[0]; | |
754 | } | |
755 | tie @a, 'main'; | |
756 | tie %h, 'main'; | |
27e90453 | 757 | |
459defa1 DM |
758 | foreach ($a[0], $h{a}) { |
759 | f($_); | |
760 | } | |
761 | # on failure, chucks up 'premature free' etc messages | |
762 | EXPECT | |
39cf747a DM |
763 | ######## |
764 | # RT 5475: | |
765 | # the initial fix for this bug caused tied scalar FETCH to be called | |
766 | # multiple times when that scalar was an element in an array. Check it | |
767 | # only gets called once now. | |
768 | ||
769 | sub TIESCALAR { bless [], $_[0] } | |
770 | my $c = 0; | |
771 | sub FETCH { $c++; 0 } | |
772 | sub FETCHSIZE { 1 } | |
773 | sub STORE { $c += 100; 0 } | |
774 | ||
775 | ||
776 | my (@a, %h); | |
777 | tie $a[0], 'main'; | |
778 | tie $h{foo}, 'main'; | |
779 | ||
780 | my $i = 0; | |
781 | my $x = $a[0] + $h{foo} + $a[$i] + (@a)[0]; | |
782 | print "x=$x c=$c\n"; | |
783 | EXPECT | |
784 | x=0 c=4 | |
6a5f8cbd FC |
785 | ######## |
786 | # Bug 68192 - numeric ops not calling mg_get when tied scalar holds a ref | |
787 | sub TIESCALAR { bless {}, __PACKAGE__ }; | |
788 | sub STORE {}; | |
789 | sub FETCH { | |
790 | print "fetching... "; # make sure FETCH is called once per op | |
791 | 123456 | |
792 | }; | |
793 | my $foo; | |
794 | tie $foo, __PACKAGE__; | |
795 | my $a = [1234567]; | |
796 | $foo = $a; | |
797 | print "+ ", 0 + $foo, "\n"; | |
798 | print "** ", $foo**1, "\n"; | |
799 | print "* ", $foo*1, "\n"; | |
800 | print "/ ", $foo*1, "\n"; | |
801 | print "% ", $foo%123457, "\n"; | |
802 | print "- ", $foo-0, "\n"; | |
803 | print "neg ", - -$foo, "\n"; | |
804 | print "int ", int $foo, "\n"; | |
805 | print "abs ", abs $foo, "\n"; | |
806 | print "== ", 123456 == $foo, "\n"; | |
807 | print "< ", 123455 < $foo, "\n"; | |
808 | print "> ", 123457 > $foo, "\n"; | |
809 | print "<= ", 123456 <= $foo, "\n"; | |
810 | print ">= ", 123456 >= $foo, "\n"; | |
811 | print "!= ", 0 != $foo, "\n"; | |
812 | print "<=> ", 123457 <=> $foo, "\n"; | |
813 | EXPECT | |
814 | fetching... + 123456 | |
815 | fetching... ** 123456 | |
816 | fetching... * 123456 | |
817 | fetching... / 123456 | |
818 | fetching... % 123456 | |
819 | fetching... - 123456 | |
820 | fetching... neg 123456 | |
821 | fetching... int 123456 | |
822 | fetching... abs 123456 | |
823 | fetching... == 1 | |
824 | fetching... < 1 | |
825 | fetching... > 1 | |
826 | fetching... <= 1 | |
827 | fetching... >= 1 | |
828 | fetching... != 1 | |
829 | fetching... <=> 1 | |
830 | ######## | |
831 | # Ties returning overloaded objects | |
832 | { | |
833 | package overloaded; | |
834 | use overload | |
bb1bc619 FC |
835 | '*{}' => sub { print '*{}'; \*100 }, |
836 | '@{}' => sub { print '@{}'; \@100 }, | |
837 | '%{}' => sub { print '%{}'; \%100 }, | |
838 | '${}' => sub { print '${}'; \$100 }, | |
6a5f8cbd FC |
839 | map { |
840 | my $op = $_; | |
841 | $_ => sub { print "$op"; 100 } | |
9e27fd70 | 842 | } qw< 0+ "" + ** * / % - neg int abs == < > <= >= != <=> <> > |
6a5f8cbd FC |
843 | } |
844 | $o = bless [], overloaded; | |
845 | ||
846 | sub TIESCALAR { bless {}, "" } | |
847 | sub FETCH { print "fetching... "; $o } | |
848 | sub STORE{} | |
849 | tie $ghew, ""; | |
850 | ||
851 | $ghew=undef; 1+$ghew; print "\n"; | |
852 | $ghew=undef; $ghew**1; print "\n"; | |
853 | $ghew=undef; $ghew*1; print "\n"; | |
854 | $ghew=undef; $ghew/1; print "\n"; | |
855 | $ghew=undef; $ghew%1; print "\n"; | |
856 | $ghew=undef; $ghew-1; print "\n"; | |
857 | $ghew=undef; -$ghew; print "\n"; | |
858 | $ghew=undef; int $ghew; print "\n"; | |
859 | $ghew=undef; abs $ghew; print "\n"; | |
860 | $ghew=undef; 1 == $ghew; print "\n"; | |
861 | $ghew=undef; $ghew<1; print "\n"; | |
862 | $ghew=undef; $ghew>1; print "\n"; | |
863 | $ghew=undef; $ghew<=1; print "\n"; | |
864 | $ghew=undef; $ghew >=1; print "\n"; | |
865 | $ghew=undef; $ghew != 1; print "\n"; | |
866 | $ghew=undef; $ghew<=>1; print "\n"; | |
9e27fd70 | 867 | $ghew=undef; <$ghew>; print "\n"; |
bb1bc619 FC |
868 | $ghew=\*shrext; *$ghew; print "\n"; |
869 | $ghew=\@spled; @$ghew; print "\n"; | |
870 | $ghew=\%frit; %$ghew; print "\n"; | |
871 | $ghew=\$drile; $$ghew; print "\n"; | |
6a5f8cbd FC |
872 | EXPECT |
873 | fetching... + | |
874 | fetching... ** | |
875 | fetching... * | |
876 | fetching... / | |
877 | fetching... % | |
878 | fetching... - | |
879 | fetching... neg | |
880 | fetching... int | |
881 | fetching... abs | |
882 | fetching... == | |
883 | fetching... < | |
884 | fetching... > | |
885 | fetching... <= | |
886 | fetching... >= | |
887 | fetching... != | |
888 | fetching... <=> | |
9e27fd70 | 889 | fetching... <> |
bb1bc619 FC |
890 | fetching... *{} |
891 | fetching... @{} | |
892 | fetching... %{} | |
893 | fetching... ${} | |
3a19377b DM |
894 | ######## |
895 | # RT 51636: segmentation fault with array ties | |
896 | ||
897 | tie my @a, 'T'; | |
898 | @a = (1); | |
899 | print "ok\n"; # if we got here we didn't crash | |
900 | ||
901 | package T; | |
902 | ||
903 | sub TIEARRAY { bless {} } | |
904 | sub STORE { tie my @b, 'T' } | |
905 | sub CLEAR { } | |
906 | sub EXTEND { } | |
907 | ||
908 | EXPECT | |
909 | ok | |
7c75014e DM |
910 | ######## |
911 | # RT 8438: Tied scalars don't call FETCH when subref is dereferenced | |
912 | ||
913 | sub TIESCALAR { bless {} } | |
914 | ||
915 | my $fetch = 0; | |
916 | my $called = 0; | |
917 | sub FETCH { $fetch++; sub { $called++ } } | |
918 | ||
919 | tie my $f, 'main'; | |
920 | $f->(1) for 1,2; | |
921 | print "fetch=$fetch\ncalled=$called\n"; | |
922 | ||
923 | EXPECT | |
924 | fetch=2 | |
925 | called=2 | |
086d2913 NC |
926 | ######## |
927 | # tie mustn't attempt to call methods on bareword filehandles. | |
928 | sub IO::File::TIEARRAY { | |
929 | die "Did not want to invoke IO::File::TIEARRAY"; | |
930 | } | |
931 | fileno FOO; tie @a, "FOO" | |
932 | EXPECT | |
933 | Can't locate object method "TIEARRAY" via package "FOO" at - line 5. | |
7c7df812 | 934 | ######## |
8985fe98 DM |
935 | # |
936 | # STORE freeing tie'd AV | |
937 | sub TIEARRAY { bless [] } | |
938 | sub STORE { *a = []; 1 } | |
939 | sub STORESIZE { } | |
940 | sub EXTEND { } | |
941 | tie @a, 'main'; | |
942 | $a[0] = 1; | |
943 | EXPECT | |
944 | ######## | |
945 | # | |
946 | # CLEAR freeing tie'd AV | |
947 | sub TIEARRAY { bless [] } | |
948 | sub CLEAR { *a = []; 1 } | |
949 | sub STORESIZE { } | |
950 | sub EXTEND { } | |
951 | sub STORE { } | |
952 | tie @a, 'main'; | |
953 | @a = (1,2,3); | |
954 | EXPECT | |
955 | ######## | |
956 | # | |
957 | # FETCHSIZE freeing tie'd AV | |
958 | sub TIEARRAY { bless [] } | |
959 | sub FETCHSIZE { *a = []; 100 } | |
960 | sub STORESIZE { } | |
961 | sub EXTEND { } | |
962 | sub STORE { } | |
963 | tie @a, 'main'; | |
964 | print $#a,"\n" | |
965 | EXPECT | |
966 | 99 | |
007f907e FC |
967 | ######## |
968 | # | |
969 | # [perl #86328] Crash when freeing tie magic that can increment the refcnt | |
970 | ||
971 | eval { require Scalar::Util } or print("ok\n"), exit; | |
972 | ||
973 | sub TIEHASH { | |
974 | return $_[1]; | |
975 | } | |
976 | *TIEARRAY = *TIEHASH; | |
977 | ||
978 | sub DESTROY { | |
979 | my ($tied) = @_; | |
980 | my $b = $tied->[0]; | |
981 | } | |
982 | ||
983 | my $a = {}; | |
984 | my $o = bless []; | |
985 | Scalar::Util::weaken($o->[0] = $a); | |
986 | tie %$a, "main", $o; | |
987 | ||
988 | my $b = []; | |
989 | my $p = bless []; | |
990 | Scalar::Util::weaken($p->[0] = $b); | |
991 | tie @$b, "main", $p; | |
992 | ||
993 | # Done setting up the evil data structures | |
994 | ||
995 | $a = undef; | |
996 | $b = undef; | |
997 | print "ok\n"; | |
998 | ||
999 | EXPECT | |
1000 | ok | |
b2b95e4c FC |
1001 | ######## |
1002 | # | |
1003 | # Localising a tied COW scalar should not make it read-only. | |
1004 | ||
1005 | sub TIESCALAR { bless [] } | |
1006 | sub FETCH { __PACKAGE__ } | |
1007 | sub STORE {} | |
1008 | tie $x, ""; | |
1009 | "$x"; | |
1010 | { | |
1011 | local $x; | |
1012 | $x = 3; | |
1013 | } | |
1014 | print "ok\n"; | |
1015 | EXPECT | |
1016 | ok | |
4be76e1f | 1017 | ######## |
e7d0a3fb FC |
1018 | # |
1019 | # Nor should it be impossible to tie COW scalars that are already PVMGs. | |
1020 | ||
1021 | sub TIESCALAR { bless [] } | |
1022 | $x = *foo; # PVGV | |
1023 | undef $x; # downgrade to PVMG | |
1024 | $x = __PACKAGE__; # PVMG + COW | |
1025 | tie $x, ""; # bang! | |
1026 | ||
1027 | print STDERR "ok\n"; | |
1028 | ||
1029 | # However, one should not be able to tie read-only glob copies, which look | |
1030 | # a bit like kine internally (FAKE + READONLY). | |
1031 | $y = *foo; | |
1032 | Internals::SvREADONLY($y,1); | |
1033 | tie $y, ""; | |
1034 | ||
1035 | EXPECT | |
1036 | ok | |
1037 | Modification of a read-only value attempted at - line 16. | |
1038 | ######## | |
5a37a95f FC |
1039 | # |
1040 | # And one should not be able to tie read-only COWs | |
1041 | for(__PACKAGE__) { tie $_, "" } | |
1042 | sub TIESCALAR {bless []} | |
1043 | EXPECT | |
1044 | Modification of a read-only value attempted at - line 3. | |
1045 | ######## | |
4be76e1f | 1046 | |
6dd7c1f1 FC |
1047 | # Similarly, read-only regexps cannot be tied. |
1048 | sub TIESCALAR { bless [] } | |
1049 | $y = ${qr//}; | |
1050 | Internals::SvREADONLY($y,1); | |
1051 | tie $y, ""; | |
1052 | ||
1053 | EXPECT | |
1054 | Modification of a read-only value attempted at - line 6. | |
1055 | ######## | |
1056 | ||
4be76e1f FC |
1057 | # tied() should still work on tied scalars after glob assignment |
1058 | sub TIESCALAR {bless[]} | |
1059 | sub FETCH {*foo} | |
1060 | sub f::TIEHANDLE{bless[],f} | |
1061 | tie *foo, "f"; | |
1062 | tie $rin, ""; | |
1063 | [$rin]; # call FETCH | |
1064 | print ref tied $rin, "\n"; | |
1065 | print ref tied *$rin, "\n"; | |
1066 | EXPECT | |
1067 | main | |
1068 | f | |
8bb5f786 FC |
1069 | ######## |
1070 | ||
ca0d4ed9 FC |
1071 | # (un)tie $glob_copy vs (un)tie *$glob_copy |
1072 | sub TIESCALAR { print "TIESCALAR\n"; bless [] } | |
1073 | sub TIEHANDLE{ print "TIEHANDLE\n"; bless [] } | |
1074 | sub FETCH { print "never called\n" } | |
8bb5f786 FC |
1075 | $f = *foo; |
1076 | tie *$f, ""; | |
1077 | tie $f, ""; | |
ca0d4ed9 FC |
1078 | untie $f; |
1079 | print "ok 1\n" if !tied $f; | |
1080 | () = $f; # should not call FETCH | |
1081 | untie *$f; | |
1082 | print "ok 2\n" if !tied *foo; | |
8bb5f786 FC |
1083 | EXPECT |
1084 | TIEHANDLE | |
1085 | TIESCALAR | |
ca0d4ed9 FC |
1086 | ok 1 |
1087 | ok 2 | |
d8ef3a16 DM |
1088 | ######## |
1089 | ||
1090 | # RT #8611 mustn't goto outside the magic stack | |
1091 | sub TIESCALAR { warn "tiescalar\n"; bless [] } | |
1092 | sub FETCH { warn "fetch()\n"; goto FOO; } | |
1093 | tie $f, ""; | |
1094 | warn "before fetch\n"; | |
1095 | my $a = "$f"; | |
1096 | warn "before FOO\n"; | |
1097 | FOO: | |
1098 | warn "after FOO\n"; | |
1099 | EXPECT | |
1100 | tiescalar | |
1101 | before fetch | |
1102 | fetch() | |
1103 | Can't find label FOO at - line 4. | |
1104 | ######## | |
1105 | ||
1106 | # RT #8611 mustn't goto outside the magic stack | |
1107 | sub TIEHANDLE { warn "tiehandle\n"; bless [] } | |
1108 | sub PRINT { warn "print()\n"; goto FOO; } | |
1109 | tie *F, ""; | |
1110 | warn "before print\n"; | |
1111 | print F "abc"; | |
1112 | warn "before FOO\n"; | |
1113 | FOO: | |
1114 | warn "after FOO\n"; | |
1115 | EXPECT | |
1116 | tiehandle | |
1117 | before print | |
1118 | print() | |
1119 | Can't find label FOO at - line 4. | |
ff55a019 FC |
1120 | ######## |
1121 | ||
1122 | # \&$tied with $tied holding a reference before the fetch (but not after) | |
1123 | sub ::72 { 73 }; | |
1124 | sub TIESCALAR {bless[]} | |
1125 | sub STORE{} | |
1126 | sub FETCH { 72 } | |
1127 | tie my $x, "main"; | |
1128 | $x = \$y; | |
1129 | \&$x; | |
1130 | print "ok\n"; | |
1131 | EXPECT | |
1132 | ok | |
1133 | ######## | |
1134 | ||
1135 | # \&$tied with $tied holding a PVLV glob before the fetch (but not after) | |
1136 | sub ::72 { 73 }; | |
1137 | sub TIEARRAY {bless[]} | |
1138 | sub STORE{} | |
1139 | sub FETCH { 72 } | |
1140 | tie my @x, "main"; | |
1141 | my $elem = \$x[0]; | |
1142 | $$elem = *bar; | |
1143 | print &{\&$$elem}, "\n"; | |
1144 | EXPECT | |
1145 | 73 | |
48e092ec FC |
1146 | ######## |
1147 | ||
1148 | # \&$tied with $tied holding a PVGV glob before the fetch (but not after) | |
1149 | local *72 = sub { 73 }; | |
1150 | sub TIESCALAR {bless[]} | |
1151 | sub STORE{} | |
1152 | sub FETCH { 72 } | |
1153 | tie my $x, "main"; | |
1154 | $x = *bar; | |
1155 | print &{\&$x}, "\n"; | |
1156 | EXPECT | |
1157 | 73 | |
9c3f0156 FC |
1158 | ######## |
1159 | ||
1160 | # Lexicals should not be visible to magic methods on scope exit | |
1161 | BEGIN { unless (defined &DynaLoader::boot_DynaLoader) { | |
1162 | print "HASH\nHASH\nARRAY\nARRAY\n"; exit; | |
1163 | }} | |
1164 | use Scalar::Util 'weaken'; | |
1165 | { package xoufghd; | |
1166 | sub TIEHASH { Scalar::Util::weaken($_[1]); bless \$_[1], xoufghd:: } | |
1167 | *TIEARRAY = *TIEHASH; | |
1168 | DESTROY { | |
1169 | bless ${$_[0]} || return, 0; | |
1170 | } } | |
1171 | for my $sub ( | |
1172 | # hashes: ties before backrefs | |
1173 | sub { | |
1174 | my %hash; | |
1175 | $ref = ref \%hash; | |
1176 | tie %hash, xoufghd::, \%hash; | |
1177 | 1; | |
1178 | }, | |
1179 | # hashes: backrefs before ties | |
1180 | sub { | |
1181 | my %hash; | |
1182 | $ref = ref \%hash; | |
1183 | weaken(my $x = \%hash); | |
1184 | tie %hash, xoufghd::, \%hash; | |
1185 | 1; | |
1186 | }, | |
8be25b25 | 1187 | # arrays: ties before backrefs |
9c3f0156 FC |
1188 | sub { |
1189 | my @array; | |
1190 | $ref = ref \@array; | |
1191 | tie @array, xoufghd::, \@array; | |
1192 | 1; | |
1193 | }, | |
8be25b25 | 1194 | # arrays: backrefs before ties |
9c3f0156 FC |
1195 | sub { |
1196 | my @array; | |
1197 | $ref = ref \@array; | |
1198 | weaken(my $x = \@array); | |
1199 | tie @array, xoufghd::, \@array; | |
1200 | 1; | |
1201 | }, | |
1202 | ) { | |
1203 | &$sub; | |
1204 | &$sub; | |
1205 | print $ref, "\n"; | |
1206 | } | |
1207 | EXPECT | |
1208 | HASH | |
1209 | HASH | |
1210 | ARRAY | |
1211 | ARRAY | |
f1f99dc1 FC |
1212 | ######## |
1213 | ||
1214 | # Localising a tied variable with a typeglob in it should copy magic | |
1215 | sub TIESCALAR{bless[]} | |
1216 | sub FETCH{warn "fetching\n"; *foo} | |
1217 | sub STORE{} | |
1218 | tie $x, ""; | |
1219 | local $x; | |
1220 | warn "before"; | |
1221 | "$x"; | |
1222 | warn "after"; | |
1223 | EXPECT | |
1224 | fetching | |
1225 | before at - line 8. | |
1226 | fetching | |
1227 | after at - line 10. | |
dc456155 FC |
1228 | ######## |
1229 | ||
1230 | # tied returns same value as tie | |
1231 | sub TIESCALAR{bless[]} | |
1232 | $tyre = \tie $tied, ""; | |
1233 | print "ok\n" if \tied $tied == $tyre; | |
1234 | EXPECT | |
1235 | ok | |
ce65bc73 FC |
1236 | ######## |
1237 | ||
1238 | # tied arrays should always be AvREAL | |
1239 | $^W=1; | |
1240 | sub TIEARRAY{bless[]} | |
1241 | sub { | |
1242 | tie @_, ""; | |
1243 | \@_; # used to produce: av_reify called on tied array at - line 7. | |
1244 | }->(1); | |
1245 | EXPECT | |
4c13be3f FC |
1246 | ######## |
1247 | ||
1248 | # [perl #67490] scalar-tying elements of magic hashes | |
1249 | sub TIESCALAR{bless[]} | |
1250 | sub STORE{} | |
1251 | tie $ENV{foo}, ''; | |
1252 | $ENV{foo} = 78; | |
1253 | delete $ENV{foo}; | |
1254 | tie $^H{foo}, ''; | |
1255 | $^H{foo} = 78; | |
1256 | delete $^H{foo}; | |
1257 | EXPECT | |
7e482323 FC |
1258 | ######## |
1259 | ||
1260 | # [perl #35865, #43011] autovivification should call FETCH after STORE | |
1261 | # because perl does not know that the FETCH would have returned the same | |
1262 | # thing that was just stored. | |
1263 | ||
1264 | # This package never likes to take ownership of other people’s refs. It | |
1265 | # always makes its own copies. (For simplicity, it only accepts hashes.) | |
1266 | package copier { | |
1267 | sub TIEHASH { bless {} } | |
1268 | sub FETCH { $_[0]{$_[1]} } | |
1269 | sub STORE { $_[0]{$_[1]} = { %{ $_[2] } } } | |
1270 | } | |
1271 | tie my %h, copier::; | |
1272 | $h{i}{j} = 'k'; | |
1273 | print $h{i}{j}, "\n"; | |
1274 | EXPECT | |
1275 | k | |
760209f8 BF |
1276 | ######## |
1277 | ||
1278 | # [perl #8931] FETCH for tied $" called an odd number of times. | |
1279 | use strict; | |
1280 | my $i = 0; | |
1281 | sub A::TIESCALAR {bless [] => 'A'} | |
1282 | sub A::FETCH {print ++ $i, "\n"} | |
1283 | my @a = ("", "", ""); | |
1284 | ||
1285 | tie $" => 'A'; | |
1286 | "@a"; | |
1287 | ||
1288 | $i = 0; | |
1289 | tie my $a => 'A'; | |
1290 | join $a, 1..10; | |
1291 | EXPECT | |
1292 | 1 | |
1293 | 1 | |
8f9dd741 BF |
1294 | ######## |
1295 | ||
1296 | # [perl #9391] return value from 'tied' not discarded soon enough | |
1297 | use warnings; | |
1298 | tie @a, 'T'; | |
1299 | if (tied @a) { | |
1300 | untie @a; | |
1301 | } | |
1302 | ||
1303 | sub T::TIEARRAY { my $s; bless \$s => "T" } | |
1304 | EXPECT | |
aec0c0cc | 1305 | ######## |
8f9dd741 | 1306 | |
aec0c0cc FC |
1307 | # NAME Test that tying a hash does not leak a deleted iterator |
1308 | # This produced unbalanced string table warnings under | |
1309 | # PERL_DESTRUCT_LEVEL=2. | |
1310 | package l { | |
1311 | sub TIEHASH{bless[]} | |
1312 | } | |
1313 | $h = {foo=>0}; | |
1314 | each %$h; | |
1315 | delete $$h{foo}; | |
1316 | tie %$h, 'l'; | |
1317 | EXPECT | |
0960ff5a FC |
1318 | ######## |
1319 | ||
1320 | # NAME EXISTS on arrays | |
1321 | sub TIEARRAY{bless[]}; | |
1322 | sub FETCHSIZE { 50 } | |
1323 | sub EXISTS { print "does $_[1] exist?\n" } | |
1324 | tie @a, ""; | |
1325 | exists $a[1]; | |
1326 | exists $a[-1]; | |
1327 | $NEGATIVE_INDICES=1; | |
1328 | exists $a[-1]; | |
1329 | EXPECT | |
1330 | does 1 exist? | |
1331 | does 49 exist? | |
1332 | does -1 exist? | |
ac9f75b5 FC |
1333 | ######## |
1334 | ||
1335 | # Crash when using negative index on array tied to non-object | |
1336 | sub TIEARRAY{bless[]}; | |
1337 | ${\tie @a, ""} = undef; | |
1338 | eval { $_ = $a[-1] }; print $@; | |
1339 | eval { $a[-1] = '' }; print $@; | |
1340 | eval { delete $a[-1] }; print $@; | |
1341 | eval { exists $a[-1] }; print $@; | |
1342 | ||
1343 | EXPECT | |
1344 | Can't call method "FETCHSIZE" on an undefined value at - line 5. | |
1345 | Can't call method "FETCHSIZE" on an undefined value at - line 6. | |
1346 | Can't call method "FETCHSIZE" on an undefined value at - line 7. | |
1347 | Can't call method "FETCHSIZE" on an undefined value at - line 8. | |
ff44333e FC |
1348 | ######## |
1349 | ||
7274b33c FC |
1350 | # Crash when reading negative index when NEGATIVE_INDICES stub exists |
1351 | sub NEGATIVE_INDICES; | |
1352 | sub TIEARRAY{bless[]}; | |
1353 | sub FETCHSIZE{} | |
1354 | tie @a, ""; | |
1355 | print "ok\n" if ! defined $a[-1]; | |
1356 | EXPECT | |
1357 | ok | |
1358 | ######## | |
1359 | ||
ff44333e FC |
1360 | # Assigning vstrings to tied scalars |
1361 | sub TIESCALAR{bless[]}; | |
1362 | sub STORE { print ref \$_[1], "\n" } | |
1363 | tie $x, ""; $x = v3; | |
1364 | EXPECT | |
1365 | VSTRING | |
13733cde FC |
1366 | ######## |
1367 | ||
1368 | # [perl #27010] Tying deferred elements | |
1369 | $\="\n"; | |
1370 | sub TIESCALAR{bless[]}; | |
1371 | sub { | |
1372 | tie $_[0], ""; | |
1373 | print ref tied $h{k}; | |
1374 | tie $h{l}, ""; | |
1375 | print ref tied $_[1]; | |
1376 | untie $h{k}; | |
1377 | print tied $_[0] // 'undef'; | |
1378 | untie $_[1]; | |
1379 | print tied $h{l} // 'undef'; | |
1380 | # check that tied and untie do not autovivify | |
1381 | # XXX should they autovivify? | |
1382 | tied $_[2]; | |
1383 | print exists $h{m} ? "yes" : "no"; | |
1384 | untie $_[2]; | |
1385 | print exists $h{m} ? "yes" : "no"; | |
1386 | }->($h{k}, $h{l}, $h{m}); | |
1387 | EXPECT | |
1388 | main | |
1389 | main | |
1390 | undef | |
1391 | undef | |
1392 | no | |
1393 | no | |
2d885586 FC |
1394 | ######## |
1395 | ||
b479c9f2 | 1396 | # [perl #78194] Passing op return values to tie constructors |
2d885586 FC |
1397 | sub TIEARRAY{ |
1398 | print \$_[1] == \$_[1] ? "ok\n" : "not ok\n"; | |
1399 | }; | |
1400 | tie @a, "", "$a$b"; | |
1401 | EXPECT | |
1402 | ok | |
3805b5fb FC |
1403 | ######## |
1404 | ||
1405 | # Scalar-tied locked hash keys and copy-on-write | |
1406 | use Tie::Scalar; | |
1407 | tie $h{foo}, Tie::StdScalar; | |
9ff3e6d8 FC |
1408 | tie $h{bar}, Tie::StdScalar; |
1409 | $h{foo} = __PACKAGE__; # COW | |
1410 | $h{bar} = 1; # not COW | |
3805b5fb FC |
1411 | # Moral equivalent of Hash::Util::lock_whatever, but miniperl-compatible |
1412 | Internals::SvREADONLY($h{foo},1); | |
9ff3e6d8 FC |
1413 | Internals::SvREADONLY($h{bar},1); |
1414 | print $h{foo}, "\n"; # should not croak | |
1415 | # Whether the value is COW should make no difference here (whether the | |
1416 | # behaviour is ultimately correct is another matter): | |
1417 | local $h{foo}; | |
1418 | local $h{bar}; | |
1419 | print "ok\n" if (eval{ $h{foo} = 1 }||$@) eq (eval{ $h{bar} = 1 }||$@); | |
3805b5fb FC |
1420 | EXPECT |
1421 | main | |
9ff3e6d8 | 1422 | ok |
ad39f3a2 | 1423 | ######## |
d6fdb726 KW |
1424 | # SKIP ? $::IS_EBCDIC |
1425 | # skipped on EBCDIC because different from ASCII and results vary depending on | |
1426 | # code page | |
ad39f3a2 FC |
1427 | |
1428 | # &xsub and goto &xsub with tied @_ | |
1429 | use Tie::Array; | |
1430 | tie @_, Tie::StdArray; | |
1431 | @_ = "\xff"; | |
1432 | &utf8::encode; | |
1433 | printf "%x\n", $_ for map ord, split //, $_[0]; | |
1434 | print "--\n"; | |
1435 | @_ = "\xff"; | |
1436 | & {sub { goto &utf8::encode }}; | |
1437 | printf "%x\n", $_ for map ord, split //, $_[0]; | |
1438 | EXPECT | |
1439 | c3 | |
1440 | bf | |
1441 | -- | |
1442 | c3 | |
1443 | bf | |
ca58dfd9 FC |
1444 | ######## |
1445 | ||
1446 | # Defelem pointing to nonexistent element of tied array | |
1447 | ||
1448 | use Tie::Array; | |
1449 | # This sub is called with a deferred element. Inside the sub, $_[0] pros- | |
1450 | # pectively points to element 10000 of @a. | |
1451 | sub { | |
1452 | tie @a, "Tie::StdArray"; # now @a is tied | |
1453 | $#a = 20000; # and FETCHSIZE/AvFILL will now return a big number | |
1454 | $a[10000] = "crumpets\n"; | |
f298f061 | 1455 | $_ = "$_[0]"; # but defelems don't expect tied arrays and try to read |
ca58dfd9 FC |
1456 | # AvARRAY[10000], which crashes |
1457 | }->($a[10000]); | |
1458 | ||
1459 | EXPECT | |
1460 | crumpets | |
6575cde0 FC |
1461 | ######## |
1462 | ||
1463 | # tied() in list assignment | |
1464 | ||
1465 | sub TIESCALAR : lvalue { | |
1466 | ${+pop} = bless [], shift; | |
1467 | } | |
1468 | tie $t, "", \$a; | |
1469 | $a = 7; | |
1470 | ($a, $b) = (3, tied $t); | |
1471 | print "a is $a\n"; | |
1472 | print "b is $b\n"; | |
1473 | EXPECT | |
1474 | a is 3 | |
1475 | b is 7 |