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 | ######## |
7de9d14e | 579 | # Bug 53482 (and maybe others) |
64207fde RB |
580 | sub TIESCALAR { my $foo = $_[1]; bless \$foo, $_[0] } |
581 | sub FETCH { ${$_[0]} } | |
7de9d14e B |
582 | tie my $x1, "main", 2; |
583 | tie my $y1, "main", 8; | |
584 | print $x1 | $y1; | |
585 | print $x1 | $y1; | |
586 | tie my $x2, "main", "2"; | |
587 | tie my $y2, "main", "8"; | |
588 | print $x2 | $y2; | |
589 | print $x2 | $y2; | |
590 | EXPECT | |
591 | 1010:: | |
1baaf5d7 NC |
592 | ######## |
593 | # Bug 36267 | |
594 | sub TIEHASH { bless {}, $_[0] } | |
595 | sub STORE { $_[0]->{$_[1]} = $_[2] } | |
596 | sub FIRSTKEY { my $a = scalar keys %{$_[0]}; each %{$_[0]} } | |
597 | sub NEXTKEY { each %{$_[0]} } | |
598 | sub DELETE { delete $_[0]->{$_[1]} } | |
599 | sub CLEAR { %{$_[0]} = () } | |
600 | $h{b}=1; | |
601 | delete $h{b}; | |
602 | print scalar keys %h, "\n"; | |
603 | tie %h, 'main'; | |
604 | $i{a}=1; | |
605 | %h = %i; | |
606 | untie %h; | |
607 | print scalar keys %h, "\n"; | |
608 | EXPECT | |
609 | 0 | |
610 | 0 | |
ced497e2 YST |
611 | ######## |
612 | # Bug 37731 | |
613 | sub foo::TIESCALAR { bless {value => $_[1]}, $_[0] } | |
614 | sub foo::FETCH { $_[0]->{value} } | |
615 | tie my $VAR, 'foo', '42'; | |
616 | foreach my $var ($VAR) { | |
617 | print +($var eq $VAR) ? "yes\n" : "no\n"; | |
618 | } | |
619 | EXPECT | |
620 | yes | |
f4c21a45 DM |
621 | ######## |
622 | sub TIEARRAY { bless [], 'main' } | |
623 | { | |
624 | local @a; | |
625 | tie @a, 'main'; | |
626 | } | |
627 | print "tied\n" if tied @a; | |
628 | EXPECT | |
629 | ######## | |
630 | sub TIEHASH { bless [], 'main' } | |
631 | { | |
632 | local %h; | |
633 | tie %h, 'main'; | |
634 | } | |
635 | print "tied\n" if tied %h; | |
636 | EXPECT | |
099be4f1 DM |
637 | ######## |
638 | # RT 20727: PL_defoutgv is left as a tied element | |
639 | sub TIESCALAR { return bless {}, 'main' } | |
640 | ||
641 | sub STORE { | |
642 | select($_[1]); | |
643 | $_[1] = 1; | |
644 | select(); # this used to coredump or assert fail | |
645 | } | |
646 | tie $SELECT, 'main'; | |
647 | $SELECT = *STDERR; | |
648 | EXPECT | |
27e90453 DM |
649 | ######## |
650 | # RT 23810: eval in die in FETCH can corrupt context stack | |
651 | ||
652 | my $file = 'rt23810.pm'; | |
653 | ||
654 | my $e; | |
655 | my $s; | |
656 | ||
657 | sub do_require { | |
658 | my ($str, $eval) = @_; | |
659 | open my $fh, '>', $file or die "Can't create $file: $!\n"; | |
660 | print $fh $str; | |
661 | close $fh; | |
662 | if ($eval) { | |
663 | $s .= '-ERQ'; | |
664 | eval { require $pm; $s .= '-ENDE' } | |
665 | } | |
666 | else { | |
667 | $s .= '-RQ'; | |
668 | require $pm; | |
669 | } | |
670 | $s .= '-ENDRQ'; | |
671 | unlink $file; | |
672 | } | |
673 | ||
674 | sub TIEHASH { bless {} } | |
675 | ||
676 | sub FETCH { | |
677 | # 10 or more syntax errors makes yyparse croak() | |
678 | my $bad = q{$x+;$x+;$x+;$x+;$x+;$x+;$x+;$x+;$x+$x+;$x+;$x+;$x+;$x+;;$x+;}; | |
679 | ||
680 | if ($_[1] eq 'eval') { | |
681 | $s .= 'EVAL'; | |
682 | eval q[BEGIN { die; $s .= '-X1' }]; | |
683 | $s .= '-BD'; | |
684 | eval q[BEGIN { $x+ }]; | |
685 | $s .= '-BS'; | |
686 | eval '$x+'; | |
687 | $s .= '-E1'; | |
688 | $s .= '-S1' while $@ =~ /syntax error at/g; | |
689 | eval $bad; | |
690 | $s .= '-E2'; | |
691 | $s .= '-S2' while $@ =~ /syntax error at/g; | |
692 | } | |
693 | elsif ($_[1] eq 'require') { | |
694 | $s .= 'REQUIRE'; | |
695 | my @text = ( | |
696 | q[BEGIN { die; $s .= '-X1' }], | |
697 | q[BEGIN { $x+ }], | |
698 | '$x+', | |
699 | $bad | |
700 | ); | |
701 | for my $i (0..$#text) { | |
702 | $s .= "-$i"; | |
703 | do_require($txt[$i], 0) if $e;; | |
704 | do_require($txt[$i], 1); | |
705 | } | |
706 | } | |
707 | elsif ($_[1] eq 'exit') { | |
708 | eval q[exit(0); print "overshot eval\n"]; | |
709 | } | |
710 | else { | |
711 | print "unknown key: '$_[1]'\n"; | |
712 | } | |
713 | return "-R"; | |
714 | } | |
715 | my %foo; | |
716 | tie %foo, "main"; | |
717 | ||
718 | for my $action(qw(eval require)) { | |
719 | $s = ''; $e = 0; $s .= main->FETCH($action); print "$action: s0=$s\n"; | |
720 | $s = ''; $e = 1; eval { $s .= main->FETCH($action)}; print "$action: s1=$s\n"; | |
721 | $s = ''; $e = 0; $s .= $foo{$action}; print "$action: s2=$s\n"; | |
722 | $s = ''; $e = 1; eval { $s .= $foo{$action}}; print "$action: s3=$s\n"; | |
723 | } | |
724 | 1 while unlink $file; | |
725 | ||
726 | $foo{'exit'}; | |
727 | print "overshot main\n"; # shouldn't reach here | |
728 | ||
729 | EXPECT | |
730 | eval: s0=EVAL-BD-BS-E1-S1-E2-S2-S2-S2-S2-S2-S2-S2-S2-S2-S2-R | |
731 | eval: s1=EVAL-BD-BS-E1-S1-E2-S2-S2-S2-S2-S2-S2-S2-S2-S2-S2-R | |
732 | eval: s2=EVAL-BD-BS-E1-S1-E2-S2-S2-S2-S2-S2-S2-S2-S2-S2-S2-R | |
733 | eval: s3=EVAL-BD-BS-E1-S1-E2-S2-S2-S2-S2-S2-S2-S2-S2-S2-S2-R | |
734 | require: s0=REQUIRE-0-ERQ-ENDRQ-1-ERQ-ENDRQ-2-ERQ-ENDRQ-3-ERQ-ENDRQ-R | |
735 | require: s1=REQUIRE-0-RQ | |
736 | require: s2=REQUIRE-0-ERQ-ENDRQ-1-ERQ-ENDRQ-2-ERQ-ENDRQ-3-ERQ-ENDRQ-R | |
737 | require: s3=REQUIRE-0-RQ | |
459defa1 DM |
738 | ######## |
739 | # RT 8857: STORE incorrectly invoked for local($_) on aliased tied array | |
740 | # element | |
741 | ||
742 | sub TIEARRAY { bless [], $_[0] } | |
743 | sub TIEHASH { bless [], $_[0] } | |
744 | sub FETCH { $_[0]->[$_[1]] } | |
745 | sub STORE { $_[0]->[$_[1]] = $_[2] } | |
746 | ||
747 | ||
748 | sub f { | |
749 | local $_[0]; | |
750 | } | |
751 | tie @a, 'main'; | |
752 | tie %h, 'main'; | |
27e90453 | 753 | |
459defa1 DM |
754 | foreach ($a[0], $h{a}) { |
755 | f($_); | |
756 | } | |
757 | # on failure, chucks up 'premature free' etc messages | |
758 | EXPECT | |
39cf747a DM |
759 | ######## |
760 | # RT 5475: | |
761 | # the initial fix for this bug caused tied scalar FETCH to be called | |
762 | # multiple times when that scalar was an element in an array. Check it | |
763 | # only gets called once now. | |
764 | ||
765 | sub TIESCALAR { bless [], $_[0] } | |
766 | my $c = 0; | |
767 | sub FETCH { $c++; 0 } | |
768 | sub FETCHSIZE { 1 } | |
769 | sub STORE { $c += 100; 0 } | |
770 | ||
771 | ||
772 | my (@a, %h); | |
773 | tie $a[0], 'main'; | |
774 | tie $h{foo}, 'main'; | |
775 | ||
776 | my $i = 0; | |
777 | my $x = $a[0] + $h{foo} + $a[$i] + (@a)[0]; | |
778 | print "x=$x c=$c\n"; | |
779 | EXPECT | |
780 | x=0 c=4 | |
6a5f8cbd FC |
781 | ######## |
782 | # Bug 68192 - numeric ops not calling mg_get when tied scalar holds a ref | |
783 | sub TIESCALAR { bless {}, __PACKAGE__ }; | |
784 | sub STORE {}; | |
785 | sub FETCH { | |
786 | print "fetching... "; # make sure FETCH is called once per op | |
787 | 123456 | |
788 | }; | |
789 | my $foo; | |
790 | tie $foo, __PACKAGE__; | |
791 | my $a = [1234567]; | |
792 | $foo = $a; | |
793 | print "+ ", 0 + $foo, "\n"; | |
794 | print "** ", $foo**1, "\n"; | |
795 | print "* ", $foo*1, "\n"; | |
796 | print "/ ", $foo*1, "\n"; | |
797 | print "% ", $foo%123457, "\n"; | |
798 | print "- ", $foo-0, "\n"; | |
799 | print "neg ", - -$foo, "\n"; | |
800 | print "int ", int $foo, "\n"; | |
801 | print "abs ", abs $foo, "\n"; | |
802 | print "== ", 123456 == $foo, "\n"; | |
803 | print "< ", 123455 < $foo, "\n"; | |
804 | print "> ", 123457 > $foo, "\n"; | |
805 | print "<= ", 123456 <= $foo, "\n"; | |
806 | print ">= ", 123456 >= $foo, "\n"; | |
807 | print "!= ", 0 != $foo, "\n"; | |
808 | print "<=> ", 123457 <=> $foo, "\n"; | |
809 | EXPECT | |
810 | fetching... + 123456 | |
811 | fetching... ** 123456 | |
812 | fetching... * 123456 | |
813 | fetching... / 123456 | |
814 | fetching... % 123456 | |
815 | fetching... - 123456 | |
816 | fetching... neg 123456 | |
817 | fetching... int 123456 | |
818 | fetching... abs 123456 | |
819 | fetching... == 1 | |
820 | fetching... < 1 | |
821 | fetching... > 1 | |
822 | fetching... <= 1 | |
823 | fetching... >= 1 | |
824 | fetching... != 1 | |
825 | fetching... <=> 1 | |
826 | ######## | |
827 | # Ties returning overloaded objects | |
828 | { | |
829 | package overloaded; | |
830 | use overload | |
bb1bc619 FC |
831 | '*{}' => sub { print '*{}'; \*100 }, |
832 | '@{}' => sub { print '@{}'; \@100 }, | |
833 | '%{}' => sub { print '%{}'; \%100 }, | |
834 | '${}' => sub { print '${}'; \$100 }, | |
6a5f8cbd FC |
835 | map { |
836 | my $op = $_; | |
837 | $_ => sub { print "$op"; 100 } | |
9e27fd70 | 838 | } qw< 0+ "" + ** * / % - neg int abs == < > <= >= != <=> <> > |
6a5f8cbd FC |
839 | } |
840 | $o = bless [], overloaded; | |
841 | ||
842 | sub TIESCALAR { bless {}, "" } | |
843 | sub FETCH { print "fetching... "; $o } | |
844 | sub STORE{} | |
845 | tie $ghew, ""; | |
846 | ||
847 | $ghew=undef; 1+$ghew; print "\n"; | |
848 | $ghew=undef; $ghew**1; print "\n"; | |
849 | $ghew=undef; $ghew*1; print "\n"; | |
850 | $ghew=undef; $ghew/1; print "\n"; | |
851 | $ghew=undef; $ghew%1; print "\n"; | |
852 | $ghew=undef; $ghew-1; print "\n"; | |
853 | $ghew=undef; -$ghew; print "\n"; | |
854 | $ghew=undef; int $ghew; print "\n"; | |
855 | $ghew=undef; abs $ghew; print "\n"; | |
856 | $ghew=undef; 1 == $ghew; print "\n"; | |
857 | $ghew=undef; $ghew<1; print "\n"; | |
858 | $ghew=undef; $ghew>1; print "\n"; | |
859 | $ghew=undef; $ghew<=1; print "\n"; | |
860 | $ghew=undef; $ghew >=1; print "\n"; | |
861 | $ghew=undef; $ghew != 1; print "\n"; | |
862 | $ghew=undef; $ghew<=>1; print "\n"; | |
9e27fd70 | 863 | $ghew=undef; <$ghew>; print "\n"; |
bb1bc619 FC |
864 | $ghew=\*shrext; *$ghew; print "\n"; |
865 | $ghew=\@spled; @$ghew; print "\n"; | |
866 | $ghew=\%frit; %$ghew; print "\n"; | |
867 | $ghew=\$drile; $$ghew; print "\n"; | |
6a5f8cbd FC |
868 | EXPECT |
869 | fetching... + | |
870 | fetching... ** | |
871 | fetching... * | |
872 | fetching... / | |
873 | fetching... % | |
874 | fetching... - | |
875 | fetching... neg | |
876 | fetching... int | |
877 | fetching... abs | |
878 | fetching... == | |
879 | fetching... < | |
880 | fetching... > | |
881 | fetching... <= | |
882 | fetching... >= | |
883 | fetching... != | |
884 | fetching... <=> | |
9e27fd70 | 885 | fetching... <> |
bb1bc619 FC |
886 | fetching... *{} |
887 | fetching... @{} | |
888 | fetching... %{} | |
889 | fetching... ${} | |
3a19377b DM |
890 | ######## |
891 | # RT 51636: segmentation fault with array ties | |
892 | ||
893 | tie my @a, 'T'; | |
894 | @a = (1); | |
895 | print "ok\n"; # if we got here we didn't crash | |
896 | ||
897 | package T; | |
898 | ||
899 | sub TIEARRAY { bless {} } | |
900 | sub STORE { tie my @b, 'T' } | |
901 | sub CLEAR { } | |
902 | sub EXTEND { } | |
903 | ||
904 | EXPECT | |
905 | ok | |
7c75014e DM |
906 | ######## |
907 | # RT 8438: Tied scalars don't call FETCH when subref is dereferenced | |
908 | ||
909 | sub TIESCALAR { bless {} } | |
910 | ||
911 | my $fetch = 0; | |
912 | my $called = 0; | |
913 | sub FETCH { $fetch++; sub { $called++ } } | |
914 | ||
915 | tie my $f, 'main'; | |
916 | $f->(1) for 1,2; | |
917 | print "fetch=$fetch\ncalled=$called\n"; | |
918 | ||
919 | EXPECT | |
920 | fetch=2 | |
921 | called=2 | |
086d2913 NC |
922 | ######## |
923 | # tie mustn't attempt to call methods on bareword filehandles. | |
924 | sub IO::File::TIEARRAY { | |
925 | die "Did not want to invoke IO::File::TIEARRAY"; | |
926 | } | |
927 | fileno FOO; tie @a, "FOO" | |
928 | EXPECT | |
929 | Can't locate object method "TIEARRAY" via package "FOO" at - line 5. | |
7c7df812 | 930 | ######## |
8985fe98 DM |
931 | # |
932 | # STORE freeing tie'd AV | |
933 | sub TIEARRAY { bless [] } | |
934 | sub STORE { *a = []; 1 } | |
935 | sub STORESIZE { } | |
936 | sub EXTEND { } | |
937 | tie @a, 'main'; | |
938 | $a[0] = 1; | |
939 | EXPECT | |
940 | ######## | |
941 | # | |
942 | # CLEAR freeing tie'd AV | |
943 | sub TIEARRAY { bless [] } | |
944 | sub CLEAR { *a = []; 1 } | |
945 | sub STORESIZE { } | |
946 | sub EXTEND { } | |
947 | sub STORE { } | |
948 | tie @a, 'main'; | |
949 | @a = (1,2,3); | |
950 | EXPECT | |
951 | ######## | |
952 | # | |
953 | # FETCHSIZE freeing tie'd AV | |
954 | sub TIEARRAY { bless [] } | |
955 | sub FETCHSIZE { *a = []; 100 } | |
956 | sub STORESIZE { } | |
957 | sub EXTEND { } | |
958 | sub STORE { } | |
959 | tie @a, 'main'; | |
960 | print $#a,"\n" | |
961 | EXPECT | |
962 | 99 | |
007f907e FC |
963 | ######## |
964 | # | |
965 | # [perl #86328] Crash when freeing tie magic that can increment the refcnt | |
966 | ||
967 | eval { require Scalar::Util } or print("ok\n"), exit; | |
968 | ||
969 | sub TIEHASH { | |
970 | return $_[1]; | |
971 | } | |
972 | *TIEARRAY = *TIEHASH; | |
973 | ||
974 | sub DESTROY { | |
975 | my ($tied) = @_; | |
976 | my $b = $tied->[0]; | |
977 | } | |
978 | ||
979 | my $a = {}; | |
980 | my $o = bless []; | |
981 | Scalar::Util::weaken($o->[0] = $a); | |
982 | tie %$a, "main", $o; | |
983 | ||
984 | my $b = []; | |
985 | my $p = bless []; | |
986 | Scalar::Util::weaken($p->[0] = $b); | |
987 | tie @$b, "main", $p; | |
988 | ||
989 | # Done setting up the evil data structures | |
990 | ||
991 | $a = undef; | |
992 | $b = undef; | |
993 | print "ok\n"; | |
994 | ||
995 | EXPECT | |
996 | ok | |
b2b95e4c FC |
997 | ######## |
998 | # | |
999 | # Localising a tied COW scalar should not make it read-only. | |
1000 | ||
1001 | sub TIESCALAR { bless [] } | |
1002 | sub FETCH { __PACKAGE__ } | |
1003 | sub STORE {} | |
1004 | tie $x, ""; | |
1005 | "$x"; | |
1006 | { | |
1007 | local $x; | |
1008 | $x = 3; | |
1009 | } | |
1010 | print "ok\n"; | |
1011 | EXPECT | |
1012 | ok | |
4be76e1f | 1013 | ######## |
e7d0a3fb FC |
1014 | # |
1015 | # Nor should it be impossible to tie COW scalars that are already PVMGs. | |
1016 | ||
1017 | sub TIESCALAR { bless [] } | |
1018 | $x = *foo; # PVGV | |
1019 | undef $x; # downgrade to PVMG | |
1020 | $x = __PACKAGE__; # PVMG + COW | |
1021 | tie $x, ""; # bang! | |
1022 | ||
1023 | print STDERR "ok\n"; | |
1024 | ||
1025 | # However, one should not be able to tie read-only glob copies, which look | |
1026 | # a bit like kine internally (FAKE + READONLY). | |
1027 | $y = *foo; | |
1028 | Internals::SvREADONLY($y,1); | |
1029 | tie $y, ""; | |
1030 | ||
1031 | EXPECT | |
1032 | ok | |
1033 | Modification of a read-only value attempted at - line 16. | |
1034 | ######## | |
5a37a95f FC |
1035 | # |
1036 | # And one should not be able to tie read-only COWs | |
1037 | for(__PACKAGE__) { tie $_, "" } | |
1038 | sub TIESCALAR {bless []} | |
1039 | EXPECT | |
1040 | Modification of a read-only value attempted at - line 3. | |
1041 | ######## | |
4be76e1f | 1042 | |
6dd7c1f1 FC |
1043 | # Similarly, read-only regexps cannot be tied. |
1044 | sub TIESCALAR { bless [] } | |
1045 | $y = ${qr//}; | |
1046 | Internals::SvREADONLY($y,1); | |
1047 | tie $y, ""; | |
1048 | ||
1049 | EXPECT | |
1050 | Modification of a read-only value attempted at - line 6. | |
1051 | ######## | |
1052 | ||
4be76e1f FC |
1053 | # tied() should still work on tied scalars after glob assignment |
1054 | sub TIESCALAR {bless[]} | |
1055 | sub FETCH {*foo} | |
1056 | sub f::TIEHANDLE{bless[],f} | |
1057 | tie *foo, "f"; | |
1058 | tie $rin, ""; | |
1059 | [$rin]; # call FETCH | |
1060 | print ref tied $rin, "\n"; | |
1061 | print ref tied *$rin, "\n"; | |
1062 | EXPECT | |
1063 | main | |
1064 | f | |
8bb5f786 FC |
1065 | ######## |
1066 | ||
ca0d4ed9 FC |
1067 | # (un)tie $glob_copy vs (un)tie *$glob_copy |
1068 | sub TIESCALAR { print "TIESCALAR\n"; bless [] } | |
1069 | sub TIEHANDLE{ print "TIEHANDLE\n"; bless [] } | |
1070 | sub FETCH { print "never called\n" } | |
8bb5f786 FC |
1071 | $f = *foo; |
1072 | tie *$f, ""; | |
1073 | tie $f, ""; | |
ca0d4ed9 FC |
1074 | untie $f; |
1075 | print "ok 1\n" if !tied $f; | |
1076 | () = $f; # should not call FETCH | |
1077 | untie *$f; | |
1078 | print "ok 2\n" if !tied *foo; | |
8bb5f786 FC |
1079 | EXPECT |
1080 | TIEHANDLE | |
1081 | TIESCALAR | |
ca0d4ed9 FC |
1082 | ok 1 |
1083 | ok 2 | |
d8ef3a16 DM |
1084 | ######## |
1085 | ||
1086 | # RT #8611 mustn't goto outside the magic stack | |
1087 | sub TIESCALAR { warn "tiescalar\n"; bless [] } | |
1088 | sub FETCH { warn "fetch()\n"; goto FOO; } | |
1089 | tie $f, ""; | |
1090 | warn "before fetch\n"; | |
1091 | my $a = "$f"; | |
1092 | warn "before FOO\n"; | |
1093 | FOO: | |
1094 | warn "after FOO\n"; | |
1095 | EXPECT | |
1096 | tiescalar | |
1097 | before fetch | |
1098 | fetch() | |
1099 | Can't find label FOO at - line 4. | |
1100 | ######## | |
1101 | ||
1102 | # RT #8611 mustn't goto outside the magic stack | |
1103 | sub TIEHANDLE { warn "tiehandle\n"; bless [] } | |
1104 | sub PRINT { warn "print()\n"; goto FOO; } | |
1105 | tie *F, ""; | |
1106 | warn "before print\n"; | |
1107 | print F "abc"; | |
1108 | warn "before FOO\n"; | |
1109 | FOO: | |
1110 | warn "after FOO\n"; | |
1111 | EXPECT | |
1112 | tiehandle | |
1113 | before print | |
1114 | print() | |
1115 | Can't find label FOO at - line 4. | |
ff55a019 FC |
1116 | ######## |
1117 | ||
1118 | # \&$tied with $tied holding a reference before the fetch (but not after) | |
1119 | sub ::72 { 73 }; | |
1120 | sub TIESCALAR {bless[]} | |
1121 | sub STORE{} | |
1122 | sub FETCH { 72 } | |
1123 | tie my $x, "main"; | |
1124 | $x = \$y; | |
1125 | \&$x; | |
1126 | print "ok\n"; | |
1127 | EXPECT | |
1128 | ok | |
1129 | ######## | |
1130 | ||
1131 | # \&$tied with $tied holding a PVLV glob before the fetch (but not after) | |
1132 | sub ::72 { 73 }; | |
1133 | sub TIEARRAY {bless[]} | |
1134 | sub STORE{} | |
1135 | sub FETCH { 72 } | |
1136 | tie my @x, "main"; | |
1137 | my $elem = \$x[0]; | |
1138 | $$elem = *bar; | |
1139 | print &{\&$$elem}, "\n"; | |
1140 | EXPECT | |
1141 | 73 | |
48e092ec FC |
1142 | ######## |
1143 | ||
1144 | # \&$tied with $tied holding a PVGV glob before the fetch (but not after) | |
1145 | local *72 = sub { 73 }; | |
1146 | sub TIESCALAR {bless[]} | |
1147 | sub STORE{} | |
1148 | sub FETCH { 72 } | |
1149 | tie my $x, "main"; | |
1150 | $x = *bar; | |
1151 | print &{\&$x}, "\n"; | |
1152 | EXPECT | |
1153 | 73 | |
9c3f0156 FC |
1154 | ######## |
1155 | ||
1156 | # Lexicals should not be visible to magic methods on scope exit | |
1157 | BEGIN { unless (defined &DynaLoader::boot_DynaLoader) { | |
1158 | print "HASH\nHASH\nARRAY\nARRAY\n"; exit; | |
1159 | }} | |
1160 | use Scalar::Util 'weaken'; | |
1161 | { package xoufghd; | |
1162 | sub TIEHASH { Scalar::Util::weaken($_[1]); bless \$_[1], xoufghd:: } | |
1163 | *TIEARRAY = *TIEHASH; | |
1164 | DESTROY { | |
1165 | bless ${$_[0]} || return, 0; | |
1166 | } } | |
1167 | for my $sub ( | |
1168 | # hashes: ties before backrefs | |
1169 | sub { | |
1170 | my %hash; | |
1171 | $ref = ref \%hash; | |
1172 | tie %hash, xoufghd::, \%hash; | |
1173 | 1; | |
1174 | }, | |
1175 | # hashes: backrefs before ties | |
1176 | sub { | |
1177 | my %hash; | |
1178 | $ref = ref \%hash; | |
1179 | weaken(my $x = \%hash); | |
1180 | tie %hash, xoufghd::, \%hash; | |
1181 | 1; | |
1182 | }, | |
8be25b25 | 1183 | # arrays: ties before backrefs |
9c3f0156 FC |
1184 | sub { |
1185 | my @array; | |
1186 | $ref = ref \@array; | |
1187 | tie @array, xoufghd::, \@array; | |
1188 | 1; | |
1189 | }, | |
8be25b25 | 1190 | # arrays: backrefs before ties |
9c3f0156 FC |
1191 | sub { |
1192 | my @array; | |
1193 | $ref = ref \@array; | |
1194 | weaken(my $x = \@array); | |
1195 | tie @array, xoufghd::, \@array; | |
1196 | 1; | |
1197 | }, | |
1198 | ) { | |
1199 | &$sub; | |
1200 | &$sub; | |
1201 | print $ref, "\n"; | |
1202 | } | |
1203 | EXPECT | |
1204 | HASH | |
1205 | HASH | |
1206 | ARRAY | |
1207 | ARRAY | |
f1f99dc1 FC |
1208 | ######## |
1209 | ||
1210 | # Localising a tied variable with a typeglob in it should copy magic | |
1211 | sub TIESCALAR{bless[]} | |
1212 | sub FETCH{warn "fetching\n"; *foo} | |
1213 | sub STORE{} | |
1214 | tie $x, ""; | |
1215 | local $x; | |
1216 | warn "before"; | |
1217 | "$x"; | |
1218 | warn "after"; | |
1219 | EXPECT | |
1220 | fetching | |
1221 | before at - line 8. | |
1222 | fetching | |
1223 | after at - line 10. | |
dc456155 FC |
1224 | ######## |
1225 | ||
1226 | # tied returns same value as tie | |
1227 | sub TIESCALAR{bless[]} | |
1228 | $tyre = \tie $tied, ""; | |
1229 | print "ok\n" if \tied $tied == $tyre; | |
1230 | EXPECT | |
1231 | ok | |
ce65bc73 FC |
1232 | ######## |
1233 | ||
1234 | # tied arrays should always be AvREAL | |
1235 | $^W=1; | |
1236 | sub TIEARRAY{bless[]} | |
1237 | sub { | |
1238 | tie @_, ""; | |
1239 | \@_; # used to produce: av_reify called on tied array at - line 7. | |
1240 | }->(1); | |
1241 | EXPECT | |
4c13be3f FC |
1242 | ######## |
1243 | ||
1244 | # [perl #67490] scalar-tying elements of magic hashes | |
1245 | sub TIESCALAR{bless[]} | |
1246 | sub STORE{} | |
1247 | tie $ENV{foo}, ''; | |
1248 | $ENV{foo} = 78; | |
1249 | delete $ENV{foo}; | |
1250 | tie $^H{foo}, ''; | |
1251 | $^H{foo} = 78; | |
1252 | delete $^H{foo}; | |
1253 | EXPECT | |
7e482323 FC |
1254 | ######## |
1255 | ||
1256 | # [perl #35865, #43011] autovivification should call FETCH after STORE | |
1257 | # because perl does not know that the FETCH would have returned the same | |
1258 | # thing that was just stored. | |
1259 | ||
1260 | # This package never likes to take ownership of other people’s refs. It | |
1261 | # always makes its own copies. (For simplicity, it only accepts hashes.) | |
1262 | package copier { | |
1263 | sub TIEHASH { bless {} } | |
1264 | sub FETCH { $_[0]{$_[1]} } | |
1265 | sub STORE { $_[0]{$_[1]} = { %{ $_[2] } } } | |
1266 | } | |
1267 | tie my %h, copier::; | |
1268 | $h{i}{j} = 'k'; | |
1269 | print $h{i}{j}, "\n"; | |
1270 | EXPECT | |
1271 | k | |
760209f8 BF |
1272 | ######## |
1273 | ||
1274 | # [perl #8931] FETCH for tied $" called an odd number of times. | |
1275 | use strict; | |
1276 | my $i = 0; | |
1277 | sub A::TIESCALAR {bless [] => 'A'} | |
1278 | sub A::FETCH {print ++ $i, "\n"} | |
1279 | my @a = ("", "", ""); | |
1280 | ||
1281 | tie $" => 'A'; | |
1282 | "@a"; | |
1283 | ||
1284 | $i = 0; | |
1285 | tie my $a => 'A'; | |
1286 | join $a, 1..10; | |
1287 | EXPECT | |
1288 | 1 | |
1289 | 1 | |
8f9dd741 BF |
1290 | ######## |
1291 | ||
1292 | # [perl #9391] return value from 'tied' not discarded soon enough | |
1293 | use warnings; | |
1294 | tie @a, 'T'; | |
1295 | if (tied @a) { | |
1296 | untie @a; | |
1297 | } | |
1298 | ||
1299 | sub T::TIEARRAY { my $s; bless \$s => "T" } | |
1300 | EXPECT | |
aec0c0cc | 1301 | ######## |
8f9dd741 | 1302 | |
aec0c0cc FC |
1303 | # NAME Test that tying a hash does not leak a deleted iterator |
1304 | # This produced unbalanced string table warnings under | |
1305 | # PERL_DESTRUCT_LEVEL=2. | |
1306 | package l { | |
1307 | sub TIEHASH{bless[]} | |
1308 | } | |
1309 | $h = {foo=>0}; | |
1310 | each %$h; | |
1311 | delete $$h{foo}; | |
1312 | tie %$h, 'l'; | |
1313 | EXPECT | |
0960ff5a FC |
1314 | ######## |
1315 | ||
1316 | # NAME EXISTS on arrays | |
1317 | sub TIEARRAY{bless[]}; | |
1318 | sub FETCHSIZE { 50 } | |
1319 | sub EXISTS { print "does $_[1] exist?\n" } | |
1320 | tie @a, ""; | |
1321 | exists $a[1]; | |
1322 | exists $a[-1]; | |
1323 | $NEGATIVE_INDICES=1; | |
1324 | exists $a[-1]; | |
1325 | EXPECT | |
1326 | does 1 exist? | |
1327 | does 49 exist? | |
1328 | does -1 exist? | |
ac9f75b5 FC |
1329 | ######## |
1330 | ||
1331 | # Crash when using negative index on array tied to non-object | |
1332 | sub TIEARRAY{bless[]}; | |
1333 | ${\tie @a, ""} = undef; | |
1334 | eval { $_ = $a[-1] }; print $@; | |
1335 | eval { $a[-1] = '' }; print $@; | |
1336 | eval { delete $a[-1] }; print $@; | |
1337 | eval { exists $a[-1] }; print $@; | |
1338 | ||
1339 | EXPECT | |
1340 | Can't call method "FETCHSIZE" on an undefined value at - line 5. | |
1341 | Can't call method "FETCHSIZE" on an undefined value at - line 6. | |
1342 | Can't call method "FETCHSIZE" on an undefined value at - line 7. | |
1343 | Can't call method "FETCHSIZE" on an undefined value at - line 8. | |
ff44333e FC |
1344 | ######## |
1345 | ||
7274b33c FC |
1346 | # Crash when reading negative index when NEGATIVE_INDICES stub exists |
1347 | sub NEGATIVE_INDICES; | |
1348 | sub TIEARRAY{bless[]}; | |
1349 | sub FETCHSIZE{} | |
1350 | tie @a, ""; | |
1351 | print "ok\n" if ! defined $a[-1]; | |
1352 | EXPECT | |
1353 | ok | |
1354 | ######## | |
1355 | ||
ff44333e FC |
1356 | # Assigning vstrings to tied scalars |
1357 | sub TIESCALAR{bless[]}; | |
1358 | sub STORE { print ref \$_[1], "\n" } | |
1359 | tie $x, ""; $x = v3; | |
1360 | EXPECT | |
1361 | VSTRING | |
13733cde FC |
1362 | ######## |
1363 | ||
1364 | # [perl #27010] Tying deferred elements | |
1365 | $\="\n"; | |
1366 | sub TIESCALAR{bless[]}; | |
1367 | sub { | |
1368 | tie $_[0], ""; | |
1369 | print ref tied $h{k}; | |
1370 | tie $h{l}, ""; | |
1371 | print ref tied $_[1]; | |
1372 | untie $h{k}; | |
1373 | print tied $_[0] // 'undef'; | |
1374 | untie $_[1]; | |
1375 | print tied $h{l} // 'undef'; | |
1376 | # check that tied and untie do not autovivify | |
1377 | # XXX should they autovivify? | |
1378 | tied $_[2]; | |
1379 | print exists $h{m} ? "yes" : "no"; | |
1380 | untie $_[2]; | |
1381 | print exists $h{m} ? "yes" : "no"; | |
1382 | }->($h{k}, $h{l}, $h{m}); | |
1383 | EXPECT | |
1384 | main | |
1385 | main | |
1386 | undef | |
1387 | undef | |
1388 | no | |
1389 | no | |
2d885586 FC |
1390 | ######## |
1391 | ||
b479c9f2 | 1392 | # [perl #78194] Passing op return values to tie constructors |
2d885586 FC |
1393 | sub TIEARRAY{ |
1394 | print \$_[1] == \$_[1] ? "ok\n" : "not ok\n"; | |
1395 | }; | |
1396 | tie @a, "", "$a$b"; | |
1397 | EXPECT | |
1398 | ok | |
3805b5fb FC |
1399 | ######## |
1400 | ||
1401 | # Scalar-tied locked hash keys and copy-on-write | |
1402 | use Tie::Scalar; | |
1403 | tie $h{foo}, Tie::StdScalar; | |
9ff3e6d8 FC |
1404 | tie $h{bar}, Tie::StdScalar; |
1405 | $h{foo} = __PACKAGE__; # COW | |
1406 | $h{bar} = 1; # not COW | |
3805b5fb FC |
1407 | # Moral equivalent of Hash::Util::lock_whatever, but miniperl-compatible |
1408 | Internals::SvREADONLY($h{foo},1); | |
9ff3e6d8 FC |
1409 | Internals::SvREADONLY($h{bar},1); |
1410 | print $h{foo}, "\n"; # should not croak | |
1411 | # Whether the value is COW should make no difference here (whether the | |
1412 | # behaviour is ultimately correct is another matter): | |
1413 | local $h{foo}; | |
1414 | local $h{bar}; | |
1415 | print "ok\n" if (eval{ $h{foo} = 1 }||$@) eq (eval{ $h{bar} = 1 }||$@); | |
3805b5fb FC |
1416 | EXPECT |
1417 | main | |
9ff3e6d8 | 1418 | ok |
ad39f3a2 FC |
1419 | ######## |
1420 | ||
1421 | # &xsub and goto &xsub with tied @_ | |
1422 | use Tie::Array; | |
1423 | tie @_, Tie::StdArray; | |
1424 | @_ = "\xff"; | |
1425 | &utf8::encode; | |
1426 | printf "%x\n", $_ for map ord, split //, $_[0]; | |
1427 | print "--\n"; | |
1428 | @_ = "\xff"; | |
1429 | & {sub { goto &utf8::encode }}; | |
1430 | printf "%x\n", $_ for map ord, split //, $_[0]; | |
1431 | EXPECT | |
1432 | c3 | |
1433 | bf | |
1434 | -- | |
1435 | c3 | |
1436 | bf | |
ca58dfd9 FC |
1437 | ######## |
1438 | ||
1439 | # Defelem pointing to nonexistent element of tied array | |
1440 | ||
1441 | use Tie::Array; | |
1442 | # This sub is called with a deferred element. Inside the sub, $_[0] pros- | |
1443 | # pectively points to element 10000 of @a. | |
1444 | sub { | |
1445 | tie @a, "Tie::StdArray"; # now @a is tied | |
1446 | $#a = 20000; # and FETCHSIZE/AvFILL will now return a big number | |
1447 | $a[10000] = "crumpets\n"; | |
1448 | $_ = "$_[0]"; # but defelems don’t expect tied arrays and try to read | |
1449 | # AvARRAY[10000], which crashes | |
1450 | }->($a[10000]); | |
1451 | ||
1452 | EXPECT | |
1453 | crumpets | |
6575cde0 FC |
1454 | ######## |
1455 | ||
1456 | # tied() in list assignment | |
1457 | ||
1458 | sub TIESCALAR : lvalue { | |
1459 | ${+pop} = bless [], shift; | |
1460 | } | |
1461 | tie $t, "", \$a; | |
1462 | $a = 7; | |
1463 | ($a, $b) = (3, tied $t); | |
1464 | print "a is $a\n"; | |
1465 | print "b is $b\n"; | |
1466 | EXPECT | |
1467 | a is 3 | |
1468 | b is 7 |