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