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 | # | |
276 | # FETCH freeing tie'd SV | |
277 | sub TIESCALAR { bless [] } | |
278 | sub FETCH { *a = \1; 1 } | |
279 | tie $a, 'main'; | |
280 | print $a; | |
281 | EXPECT | |
dd28f7bb DM |
282 | ######## |
283 | ||
284 | # [20020716.007] - nested FETCHES | |
285 | ||
286 | sub F1::TIEARRAY { bless [], 'F1' } | |
287 | sub F1::FETCH { 1 } | |
288 | my @f1; | |
289 | tie @f1, 'F1'; | |
290 | ||
291 | sub F2::TIEARRAY { bless [2], 'F2' } | |
292 | sub F2::FETCH { my $self = shift; my $x = $f1[3]; $self } | |
293 | my @f2; | |
294 | tie @f2, 'F2'; | |
295 | ||
296 | print $f2[4][0],"\n"; | |
297 | ||
298 | sub F3::TIEHASH { bless [], 'F3' } | |
299 | sub F3::FETCH { 1 } | |
300 | my %f3; | |
301 | tie %f3, 'F3'; | |
302 | ||
303 | sub F4::TIEHASH { bless [3], 'F4' } | |
304 | sub F4::FETCH { my $self = shift; my $x = $f3{3}; $self } | |
305 | my %f4; | |
306 | tie %f4, 'F4'; | |
307 | ||
308 | print $f4{'foo'}[0],"\n"; | |
309 | ||
310 | EXPECT | |
311 | 2 | |
312 | 3 | |
38193a09 AM |
313 | ######## |
314 | # test untie() from within FETCH | |
315 | package Foo; | |
316 | sub TIESCALAR { my $pkg = shift; return bless [@_], $pkg; } | |
317 | sub FETCH { | |
318 | my $self = shift; | |
319 | my ($obj, $field) = @$self; | |
320 | untie $obj->{$field}; | |
321 | $obj->{$field} = "Bar"; | |
322 | } | |
323 | package main; | |
324 | tie $a->{foo}, "Foo", $a, "foo"; | |
39cf747a | 325 | my $s = $a->{foo}; # access once |
38193a09 AM |
326 | # the hash element should not be tied anymore |
327 | print defined tied $a->{foo} ? "not ok" : "ok"; | |
328 | EXPECT | |
329 | ok | |
be65207d DM |
330 | ######## |
331 | # the tmps returned by FETCH should appear to be SCALAR | |
332 | # (even though they are now implemented using PVLVs.) | |
333 | package X; | |
334 | sub TIEHASH { bless {} } | |
335 | sub TIEARRAY { bless {} } | |
336 | sub FETCH {1} | |
337 | my (%h, @a); | |
338 | tie %h, 'X'; | |
339 | tie @a, 'X'; | |
340 | my $r1 = \$h{1}; | |
341 | my $r2 = \$a[0]; | |
342 | my $s = "$r1 ". ref($r1) . " $r2 " . ref($r2); | |
343 | $s=~ s/\(0x\w+\)//g; | |
344 | print $s, "\n"; | |
345 | EXPECT | |
346 | SCALAR SCALAR SCALAR SCALAR | |
b7056d9c JH |
347 | ######## |
348 | # [perl #23287] segfault in untie | |
349 | sub TIESCALAR { bless $_[1], $_[0] } | |
350 | my $var; | |
351 | tie $var, 'main', \$var; | |
352 | untie $var; | |
353 | EXPECT | |
16e0ce55 JH |
354 | ######## |
355 | # Test case from perlmonks by runrig | |
356 | # http://www.perlmonks.org/index.pl?node_id=273490 | |
357 | # "Here is what I tried. I think its similar to what you've tried | |
93f09d7b | 358 | # above. Its odd but convenient that after untie'ing you are left with |
16e0ce55 JH |
359 | # a variable that has the same value as was last returned from |
360 | # FETCH. (At least on my perl v5.6.1). So you don't need to pass a | |
361 | # reference to the variable in order to set it after the untie (here it | |
362 | # is accessed through a closure)." | |
363 | use strict; | |
364 | use warnings; | |
365 | package MyTied; | |
366 | sub TIESCALAR { | |
367 | my ($class,$code) = @_; | |
368 | bless $code, $class; | |
369 | } | |
370 | sub FETCH { | |
371 | my $self = shift; | |
372 | print "Untie\n"; | |
373 | $self->(); | |
374 | } | |
375 | package main; | |
376 | my $var; | |
377 | tie $var, 'MyTied', sub { untie $var; 4 }; | |
378 | print "One\n"; | |
379 | print "$var\n"; | |
380 | print "Two\n"; | |
381 | print "$var\n"; | |
382 | print "Three\n"; | |
383 | print "$var\n"; | |
384 | EXPECT | |
385 | One | |
386 | Untie | |
387 | 4 | |
388 | Two | |
389 | 4 | |
390 | Three | |
391 | 4 | |
dd12389b JH |
392 | ######## |
393 | # [perl #22297] cannot untie scalar from within tied FETCH | |
394 | my $counter = 0; | |
395 | my $x = 7; | |
396 | my $ref = \$x; | |
397 | tie $x, 'Overlay', $ref, $x; | |
398 | my $y; | |
399 | $y = $x; | |
400 | $y = $x; | |
401 | $y = $x; | |
402 | $y = $x; | |
403 | #print "WILL EXTERNAL UNTIE $ref\n"; | |
404 | untie $$ref; | |
405 | $y = $x; | |
406 | $y = $x; | |
407 | $y = $x; | |
408 | $y = $x; | |
409 | #print "counter = $counter\n"; | |
410 | ||
411 | print (($counter == 1) ? "ok\n" : "not ok\n"); | |
412 | ||
413 | package Overlay; | |
414 | ||
415 | sub TIESCALAR | |
416 | { | |
417 | my $pkg = shift; | |
418 | my ($ref, $val) = @_; | |
419 | return bless [ $ref, $val ], $pkg; | |
420 | } | |
421 | ||
422 | sub FETCH | |
423 | { | |
424 | my $self = shift; | |
425 | my ($ref, $val) = @$self; | |
426 | #print "WILL INTERNAL UNITE $ref\n"; | |
427 | $counter++; | |
428 | untie $$ref; | |
429 | return $val; | |
430 | } | |
431 | EXPECT | |
432 | ok | |
6c0731c3 RC |
433 | ######## |
434 | ||
e23d9e2f | 435 | # [perl #948] cannot meaningfully tie $, |
6c0731c3 RC |
436 | package TieDollarComma; |
437 | ||
438 | sub TIESCALAR { | |
439 | my $pkg = shift; | |
440 | return bless \my $x, $pkg; | |
441 | } | |
442 | ||
443 | sub STORE { | |
444 | my $self = shift; | |
445 | $$self = shift; | |
446 | print "STORE set '$$self'\n"; | |
447 | } | |
448 | ||
449 | sub FETCH { | |
450 | my $self = shift; | |
e23d9e2f | 451 | print "<FETCH>"; |
6c0731c3 RC |
452 | return $$self; |
453 | } | |
454 | package main; | |
455 | ||
456 | tie $,, 'TieDollarComma'; | |
457 | $, = 'BOBBINS'; | |
458 | print "join", "things", "up\n"; | |
459 | EXPECT | |
460 | STORE set 'BOBBINS' | |
e23d9e2f | 461 | join<FETCH>BOBBINSthings<FETCH>BOBBINSup |
a3bcc51e TP |
462 | ######## |
463 | ||
464 | # test SCALAR method | |
465 | package TieScalar; | |
466 | ||
467 | sub TIEHASH { | |
468 | my $pkg = shift; | |
469 | bless { } => $pkg; | |
470 | } | |
471 | ||
472 | sub STORE { | |
473 | $_[0]->{$_[1]} = $_[2]; | |
474 | } | |
475 | ||
476 | sub FETCH { | |
477 | $_[0]->{$_[1]} | |
478 | } | |
479 | ||
480 | sub CLEAR { | |
481 | %{ $_[0] } = (); | |
482 | } | |
483 | ||
484 | sub SCALAR { | |
485 | print "SCALAR\n"; | |
486 | return 0 if ! keys %{$_[0]}; | |
487 | sprintf "%i/%i", scalar keys %{$_[0]}, scalar keys %{$_[0]}; | |
488 | } | |
489 | ||
490 | package main; | |
491 | tie my %h => "TieScalar"; | |
492 | $h{key1} = "val1"; | |
493 | $h{key2} = "val2"; | |
867fa1e2 YO |
494 | print scalar %h, "\n" |
495 | if %h; # this should also call SCALAR but implicitly | |
a3bcc51e | 496 | %h = (); |
867fa1e2 YO |
497 | print scalar %h, "\n" |
498 | if !%h; # this should also call SCALAR but implicitly | |
a3bcc51e TP |
499 | EXPECT |
500 | SCALAR | |
867fa1e2 | 501 | SCALAR |
a3bcc51e TP |
502 | 2/2 |
503 | SCALAR | |
867fa1e2 | 504 | SCALAR |
a3bcc51e TP |
505 | 0 |
506 | ######## | |
507 | ||
508 | # test scalar on tied hash when no SCALAR method has been given | |
509 | package TieScalar; | |
510 | ||
511 | sub TIEHASH { | |
512 | my $pkg = shift; | |
513 | bless { } => $pkg; | |
514 | } | |
515 | sub STORE { | |
516 | $_[0]->{$_[1]} = $_[2]; | |
517 | } | |
518 | sub FETCH { | |
519 | $_[0]->{$_[1]} | |
520 | } | |
521 | sub CLEAR { | |
522 | %{ $_[0] } = (); | |
523 | } | |
524 | sub FIRSTKEY { | |
525 | my $a = keys %{ $_[0] }; | |
526 | print "FIRSTKEY\n"; | |
527 | each %{ $_[0] }; | |
528 | } | |
529 | ||
530 | package main; | |
531 | tie my %h => "TieScalar"; | |
532 | ||
533 | if (!%h) { | |
534 | print "empty\n"; | |
535 | } else { | |
536 | print "not empty\n"; | |
537 | } | |
538 | ||
539 | $h{key1} = "val1"; | |
540 | print "not empty\n" if %h; | |
541 | print "not empty\n" if %h; | |
542 | print "-->\n"; | |
543 | my ($k,$v) = each %h; | |
544 | print "<--\n"; | |
545 | print "not empty\n" if %h; | |
546 | %h = (); | |
547 | print "empty\n" if ! %h; | |
548 | EXPECT | |
549 | FIRSTKEY | |
550 | empty | |
551 | FIRSTKEY | |
552 | not empty | |
553 | FIRSTKEY | |
554 | not empty | |
555 | --> | |
556 | FIRSTKEY | |
557 | <-- | |
558 | not empty | |
559 | FIRSTKEY | |
560 | empty | |
2b77b520 YST |
561 | ######## |
562 | sub TIESCALAR { bless {} } | |
563 | sub FETCH { my $x = 3.3; 1 if 0+$x; $x } | |
564 | tie $h, "main"; | |
565 | print $h,"\n"; | |
566 | EXPECT | |
567 | 3.3 | |
c75ab21a RH |
568 | ######## |
569 | sub TIESCALAR { bless {} } | |
570 | sub FETCH { shift()->{i} ++ } | |
571 | tie $h, "main"; | |
572 | print $h.$h; | |
573 | EXPECT | |
574 | 01 | |
64207fde | 575 | ######## |
7de9d14e | 576 | # Bug 53482 (and maybe others) |
64207fde RB |
577 | sub TIESCALAR { my $foo = $_[1]; bless \$foo, $_[0] } |
578 | sub FETCH { ${$_[0]} } | |
7de9d14e B |
579 | tie my $x1, "main", 2; |
580 | tie my $y1, "main", 8; | |
581 | print $x1 | $y1; | |
582 | print $x1 | $y1; | |
583 | tie my $x2, "main", "2"; | |
584 | tie my $y2, "main", "8"; | |
585 | print $x2 | $y2; | |
586 | print $x2 | $y2; | |
587 | EXPECT | |
588 | 1010:: | |
1baaf5d7 NC |
589 | ######## |
590 | # Bug 36267 | |
591 | sub TIEHASH { bless {}, $_[0] } | |
592 | sub STORE { $_[0]->{$_[1]} = $_[2] } | |
593 | sub FIRSTKEY { my $a = scalar keys %{$_[0]}; each %{$_[0]} } | |
594 | sub NEXTKEY { each %{$_[0]} } | |
595 | sub DELETE { delete $_[0]->{$_[1]} } | |
596 | sub CLEAR { %{$_[0]} = () } | |
597 | $h{b}=1; | |
598 | delete $h{b}; | |
599 | print scalar keys %h, "\n"; | |
600 | tie %h, 'main'; | |
601 | $i{a}=1; | |
602 | %h = %i; | |
603 | untie %h; | |
604 | print scalar keys %h, "\n"; | |
605 | EXPECT | |
606 | 0 | |
607 | 0 | |
ced497e2 YST |
608 | ######## |
609 | # Bug 37731 | |
610 | sub foo::TIESCALAR { bless {value => $_[1]}, $_[0] } | |
611 | sub foo::FETCH { $_[0]->{value} } | |
612 | tie my $VAR, 'foo', '42'; | |
613 | foreach my $var ($VAR) { | |
614 | print +($var eq $VAR) ? "yes\n" : "no\n"; | |
615 | } | |
616 | EXPECT | |
617 | yes | |
f4c21a45 DM |
618 | ######## |
619 | sub TIEARRAY { bless [], 'main' } | |
620 | { | |
621 | local @a; | |
622 | tie @a, 'main'; | |
623 | } | |
624 | print "tied\n" if tied @a; | |
625 | EXPECT | |
626 | ######## | |
627 | sub TIEHASH { bless [], 'main' } | |
628 | { | |
629 | local %h; | |
630 | tie %h, 'main'; | |
631 | } | |
632 | print "tied\n" if tied %h; | |
633 | EXPECT | |
099be4f1 DM |
634 | ######## |
635 | # RT 20727: PL_defoutgv is left as a tied element | |
636 | sub TIESCALAR { return bless {}, 'main' } | |
637 | ||
638 | sub STORE { | |
639 | select($_[1]); | |
640 | $_[1] = 1; | |
641 | select(); # this used to coredump or assert fail | |
642 | } | |
643 | tie $SELECT, 'main'; | |
644 | $SELECT = *STDERR; | |
645 | EXPECT | |
27e90453 DM |
646 | ######## |
647 | # RT 23810: eval in die in FETCH can corrupt context stack | |
648 | ||
649 | my $file = 'rt23810.pm'; | |
650 | ||
651 | my $e; | |
652 | my $s; | |
653 | ||
654 | sub do_require { | |
655 | my ($str, $eval) = @_; | |
656 | open my $fh, '>', $file or die "Can't create $file: $!\n"; | |
657 | print $fh $str; | |
658 | close $fh; | |
659 | if ($eval) { | |
660 | $s .= '-ERQ'; | |
661 | eval { require $pm; $s .= '-ENDE' } | |
662 | } | |
663 | else { | |
664 | $s .= '-RQ'; | |
665 | require $pm; | |
666 | } | |
667 | $s .= '-ENDRQ'; | |
668 | unlink $file; | |
669 | } | |
670 | ||
671 | sub TIEHASH { bless {} } | |
672 | ||
673 | sub FETCH { | |
674 | # 10 or more syntax errors makes yyparse croak() | |
675 | my $bad = q{$x+;$x+;$x+;$x+;$x+;$x+;$x+;$x+;$x+$x+;$x+;$x+;$x+;$x+;;$x+;}; | |
676 | ||
677 | if ($_[1] eq 'eval') { | |
678 | $s .= 'EVAL'; | |
679 | eval q[BEGIN { die; $s .= '-X1' }]; | |
680 | $s .= '-BD'; | |
681 | eval q[BEGIN { $x+ }]; | |
682 | $s .= '-BS'; | |
683 | eval '$x+'; | |
684 | $s .= '-E1'; | |
685 | $s .= '-S1' while $@ =~ /syntax error at/g; | |
686 | eval $bad; | |
687 | $s .= '-E2'; | |
688 | $s .= '-S2' while $@ =~ /syntax error at/g; | |
689 | } | |
690 | elsif ($_[1] eq 'require') { | |
691 | $s .= 'REQUIRE'; | |
692 | my @text = ( | |
693 | q[BEGIN { die; $s .= '-X1' }], | |
694 | q[BEGIN { $x+ }], | |
695 | '$x+', | |
696 | $bad | |
697 | ); | |
698 | for my $i (0..$#text) { | |
699 | $s .= "-$i"; | |
700 | do_require($txt[$i], 0) if $e;; | |
701 | do_require($txt[$i], 1); | |
702 | } | |
703 | } | |
704 | elsif ($_[1] eq 'exit') { | |
705 | eval q[exit(0); print "overshot eval\n"]; | |
706 | } | |
707 | else { | |
708 | print "unknown key: '$_[1]'\n"; | |
709 | } | |
710 | return "-R"; | |
711 | } | |
712 | my %foo; | |
713 | tie %foo, "main"; | |
714 | ||
715 | for my $action(qw(eval require)) { | |
716 | $s = ''; $e = 0; $s .= main->FETCH($action); print "$action: s0=$s\n"; | |
717 | $s = ''; $e = 1; eval { $s .= main->FETCH($action)}; print "$action: s1=$s\n"; | |
718 | $s = ''; $e = 0; $s .= $foo{$action}; print "$action: s2=$s\n"; | |
719 | $s = ''; $e = 1; eval { $s .= $foo{$action}}; print "$action: s3=$s\n"; | |
720 | } | |
721 | 1 while unlink $file; | |
722 | ||
723 | $foo{'exit'}; | |
724 | print "overshot main\n"; # shouldn't reach here | |
725 | ||
726 | EXPECT | |
727 | eval: s0=EVAL-BD-BS-E1-S1-E2-S2-S2-S2-S2-S2-S2-S2-S2-S2-S2-R | |
728 | eval: s1=EVAL-BD-BS-E1-S1-E2-S2-S2-S2-S2-S2-S2-S2-S2-S2-S2-R | |
729 | eval: s2=EVAL-BD-BS-E1-S1-E2-S2-S2-S2-S2-S2-S2-S2-S2-S2-S2-R | |
730 | eval: s3=EVAL-BD-BS-E1-S1-E2-S2-S2-S2-S2-S2-S2-S2-S2-S2-S2-R | |
731 | require: s0=REQUIRE-0-ERQ-ENDRQ-1-ERQ-ENDRQ-2-ERQ-ENDRQ-3-ERQ-ENDRQ-R | |
732 | require: s1=REQUIRE-0-RQ | |
733 | require: s2=REQUIRE-0-ERQ-ENDRQ-1-ERQ-ENDRQ-2-ERQ-ENDRQ-3-ERQ-ENDRQ-R | |
734 | require: s3=REQUIRE-0-RQ | |
459defa1 DM |
735 | ######## |
736 | # RT 8857: STORE incorrectly invoked for local($_) on aliased tied array | |
737 | # element | |
738 | ||
739 | sub TIEARRAY { bless [], $_[0] } | |
740 | sub TIEHASH { bless [], $_[0] } | |
741 | sub FETCH { $_[0]->[$_[1]] } | |
742 | sub STORE { $_[0]->[$_[1]] = $_[2] } | |
743 | ||
744 | ||
745 | sub f { | |
746 | local $_[0]; | |
747 | } | |
748 | tie @a, 'main'; | |
749 | tie %h, 'main'; | |
27e90453 | 750 | |
459defa1 DM |
751 | foreach ($a[0], $h{a}) { |
752 | f($_); | |
753 | } | |
754 | # on failure, chucks up 'premature free' etc messages | |
755 | EXPECT | |
39cf747a DM |
756 | ######## |
757 | # RT 5475: | |
758 | # the initial fix for this bug caused tied scalar FETCH to be called | |
759 | # multiple times when that scalar was an element in an array. Check it | |
760 | # only gets called once now. | |
761 | ||
762 | sub TIESCALAR { bless [], $_[0] } | |
763 | my $c = 0; | |
764 | sub FETCH { $c++; 0 } | |
765 | sub FETCHSIZE { 1 } | |
766 | sub STORE { $c += 100; 0 } | |
767 | ||
768 | ||
769 | my (@a, %h); | |
770 | tie $a[0], 'main'; | |
771 | tie $h{foo}, 'main'; | |
772 | ||
773 | my $i = 0; | |
774 | my $x = $a[0] + $h{foo} + $a[$i] + (@a)[0]; | |
775 | print "x=$x c=$c\n"; | |
776 | EXPECT | |
777 | x=0 c=4 | |
6a5f8cbd FC |
778 | ######## |
779 | # Bug 68192 - numeric ops not calling mg_get when tied scalar holds a ref | |
780 | sub TIESCALAR { bless {}, __PACKAGE__ }; | |
781 | sub STORE {}; | |
782 | sub FETCH { | |
783 | print "fetching... "; # make sure FETCH is called once per op | |
784 | 123456 | |
785 | }; | |
786 | my $foo; | |
787 | tie $foo, __PACKAGE__; | |
788 | my $a = [1234567]; | |
789 | $foo = $a; | |
790 | print "+ ", 0 + $foo, "\n"; | |
791 | print "** ", $foo**1, "\n"; | |
792 | print "* ", $foo*1, "\n"; | |
793 | print "/ ", $foo*1, "\n"; | |
794 | print "% ", $foo%123457, "\n"; | |
795 | print "- ", $foo-0, "\n"; | |
796 | print "neg ", - -$foo, "\n"; | |
797 | print "int ", int $foo, "\n"; | |
798 | print "abs ", abs $foo, "\n"; | |
799 | print "== ", 123456 == $foo, "\n"; | |
800 | print "< ", 123455 < $foo, "\n"; | |
801 | print "> ", 123457 > $foo, "\n"; | |
802 | print "<= ", 123456 <= $foo, "\n"; | |
803 | print ">= ", 123456 >= $foo, "\n"; | |
804 | print "!= ", 0 != $foo, "\n"; | |
805 | print "<=> ", 123457 <=> $foo, "\n"; | |
806 | EXPECT | |
807 | fetching... + 123456 | |
808 | fetching... ** 123456 | |
809 | fetching... * 123456 | |
810 | fetching... / 123456 | |
811 | fetching... % 123456 | |
812 | fetching... - 123456 | |
813 | fetching... neg 123456 | |
814 | fetching... int 123456 | |
815 | fetching... abs 123456 | |
816 | fetching... == 1 | |
817 | fetching... < 1 | |
818 | fetching... > 1 | |
819 | fetching... <= 1 | |
820 | fetching... >= 1 | |
821 | fetching... != 1 | |
822 | fetching... <=> 1 | |
823 | ######## | |
824 | # Ties returning overloaded objects | |
825 | { | |
826 | package overloaded; | |
827 | use overload | |
bb1bc619 FC |
828 | '*{}' => sub { print '*{}'; \*100 }, |
829 | '@{}' => sub { print '@{}'; \@100 }, | |
830 | '%{}' => sub { print '%{}'; \%100 }, | |
831 | '${}' => sub { print '${}'; \$100 }, | |
6a5f8cbd FC |
832 | map { |
833 | my $op = $_; | |
834 | $_ => sub { print "$op"; 100 } | |
9e27fd70 | 835 | } qw< 0+ "" + ** * / % - neg int abs == < > <= >= != <=> <> > |
6a5f8cbd FC |
836 | } |
837 | $o = bless [], overloaded; | |
838 | ||
839 | sub TIESCALAR { bless {}, "" } | |
840 | sub FETCH { print "fetching... "; $o } | |
841 | sub STORE{} | |
842 | tie $ghew, ""; | |
843 | ||
844 | $ghew=undef; 1+$ghew; print "\n"; | |
845 | $ghew=undef; $ghew**1; 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; print "\n"; | |
851 | $ghew=undef; int $ghew; print "\n"; | |
852 | $ghew=undef; abs $ghew; print "\n"; | |
853 | $ghew=undef; 1 == $ghew; 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 >=1; print "\n"; | |
858 | $ghew=undef; $ghew != 1; print "\n"; | |
859 | $ghew=undef; $ghew<=>1; print "\n"; | |
9e27fd70 | 860 | $ghew=undef; <$ghew>; print "\n"; |
bb1bc619 FC |
861 | $ghew=\*shrext; *$ghew; print "\n"; |
862 | $ghew=\@spled; @$ghew; print "\n"; | |
863 | $ghew=\%frit; %$ghew; print "\n"; | |
864 | $ghew=\$drile; $$ghew; print "\n"; | |
6a5f8cbd FC |
865 | EXPECT |
866 | fetching... + | |
867 | fetching... ** | |
868 | fetching... * | |
869 | fetching... / | |
870 | fetching... % | |
871 | fetching... - | |
872 | fetching... neg | |
873 | fetching... int | |
874 | fetching... abs | |
875 | fetching... == | |
876 | fetching... < | |
877 | fetching... > | |
878 | fetching... <= | |
879 | fetching... >= | |
880 | fetching... != | |
881 | fetching... <=> | |
9e27fd70 | 882 | fetching... <> |
bb1bc619 FC |
883 | fetching... *{} |
884 | fetching... @{} | |
885 | fetching... %{} | |
886 | fetching... ${} | |
3a19377b DM |
887 | ######## |
888 | # RT 51636: segmentation fault with array ties | |
889 | ||
890 | tie my @a, 'T'; | |
891 | @a = (1); | |
892 | print "ok\n"; # if we got here we didn't crash | |
893 | ||
894 | package T; | |
895 | ||
896 | sub TIEARRAY { bless {} } | |
897 | sub STORE { tie my @b, 'T' } | |
898 | sub CLEAR { } | |
899 | sub EXTEND { } | |
900 | ||
901 | EXPECT | |
902 | ok | |
7c75014e DM |
903 | ######## |
904 | # RT 8438: Tied scalars don't call FETCH when subref is dereferenced | |
905 | ||
906 | sub TIESCALAR { bless {} } | |
907 | ||
908 | my $fetch = 0; | |
909 | my $called = 0; | |
910 | sub FETCH { $fetch++; sub { $called++ } } | |
911 | ||
912 | tie my $f, 'main'; | |
913 | $f->(1) for 1,2; | |
914 | print "fetch=$fetch\ncalled=$called\n"; | |
915 | ||
916 | EXPECT | |
917 | fetch=2 | |
918 | called=2 | |
086d2913 NC |
919 | ######## |
920 | # tie mustn't attempt to call methods on bareword filehandles. | |
921 | sub IO::File::TIEARRAY { | |
922 | die "Did not want to invoke IO::File::TIEARRAY"; | |
923 | } | |
924 | fileno FOO; tie @a, "FOO" | |
925 | EXPECT | |
926 | Can't locate object method "TIEARRAY" via package "FOO" at - line 5. | |
7c7df812 | 927 | ######## |
8985fe98 DM |
928 | # |
929 | # STORE freeing tie'd AV | |
930 | sub TIEARRAY { bless [] } | |
931 | sub STORE { *a = []; 1 } | |
932 | sub STORESIZE { } | |
933 | sub EXTEND { } | |
934 | tie @a, 'main'; | |
935 | $a[0] = 1; | |
936 | EXPECT | |
937 | ######## | |
938 | # | |
939 | # CLEAR freeing tie'd AV | |
940 | sub TIEARRAY { bless [] } | |
941 | sub CLEAR { *a = []; 1 } | |
942 | sub STORESIZE { } | |
943 | sub EXTEND { } | |
944 | sub STORE { } | |
945 | tie @a, 'main'; | |
946 | @a = (1,2,3); | |
947 | EXPECT | |
948 | ######## | |
949 | # | |
950 | # FETCHSIZE freeing tie'd AV | |
951 | sub TIEARRAY { bless [] } | |
952 | sub FETCHSIZE { *a = []; 100 } | |
953 | sub STORESIZE { } | |
954 | sub EXTEND { } | |
955 | sub STORE { } | |
956 | tie @a, 'main'; | |
957 | print $#a,"\n" | |
958 | EXPECT | |
959 | 99 | |
007f907e FC |
960 | ######## |
961 | # | |
962 | # [perl #86328] Crash when freeing tie magic that can increment the refcnt | |
963 | ||
964 | eval { require Scalar::Util } or print("ok\n"), exit; | |
965 | ||
966 | sub TIEHASH { | |
967 | return $_[1]; | |
968 | } | |
969 | *TIEARRAY = *TIEHASH; | |
970 | ||
971 | sub DESTROY { | |
972 | my ($tied) = @_; | |
973 | my $b = $tied->[0]; | |
974 | } | |
975 | ||
976 | my $a = {}; | |
977 | my $o = bless []; | |
978 | Scalar::Util::weaken($o->[0] = $a); | |
979 | tie %$a, "main", $o; | |
980 | ||
981 | my $b = []; | |
982 | my $p = bless []; | |
983 | Scalar::Util::weaken($p->[0] = $b); | |
984 | tie @$b, "main", $p; | |
985 | ||
986 | # Done setting up the evil data structures | |
987 | ||
988 | $a = undef; | |
989 | $b = undef; | |
990 | print "ok\n"; | |
991 | ||
992 | EXPECT | |
993 | ok | |
b2b95e4c FC |
994 | ######## |
995 | # | |
996 | # Localising a tied COW scalar should not make it read-only. | |
997 | ||
998 | sub TIESCALAR { bless [] } | |
999 | sub FETCH { __PACKAGE__ } | |
1000 | sub STORE {} | |
1001 | tie $x, ""; | |
1002 | "$x"; | |
1003 | { | |
1004 | local $x; | |
1005 | $x = 3; | |
1006 | } | |
1007 | print "ok\n"; | |
1008 | EXPECT | |
1009 | ok | |
4be76e1f | 1010 | ######## |
e7d0a3fb FC |
1011 | # |
1012 | # Nor should it be impossible to tie COW scalars that are already PVMGs. | |
1013 | ||
1014 | sub TIESCALAR { bless [] } | |
1015 | $x = *foo; # PVGV | |
1016 | undef $x; # downgrade to PVMG | |
1017 | $x = __PACKAGE__; # PVMG + COW | |
1018 | tie $x, ""; # bang! | |
1019 | ||
1020 | print STDERR "ok\n"; | |
1021 | ||
1022 | # However, one should not be able to tie read-only glob copies, which look | |
1023 | # a bit like kine internally (FAKE + READONLY). | |
1024 | $y = *foo; | |
1025 | Internals::SvREADONLY($y,1); | |
1026 | tie $y, ""; | |
1027 | ||
1028 | EXPECT | |
1029 | ok | |
1030 | Modification of a read-only value attempted at - line 16. | |
1031 | ######## | |
4be76e1f FC |
1032 | |
1033 | # tied() should still work on tied scalars after glob assignment | |
1034 | sub TIESCALAR {bless[]} | |
1035 | sub FETCH {*foo} | |
1036 | sub f::TIEHANDLE{bless[],f} | |
1037 | tie *foo, "f"; | |
1038 | tie $rin, ""; | |
1039 | [$rin]; # call FETCH | |
1040 | print ref tied $rin, "\n"; | |
1041 | print ref tied *$rin, "\n"; | |
1042 | EXPECT | |
1043 | main | |
1044 | f | |
8bb5f786 FC |
1045 | ######## |
1046 | ||
ca0d4ed9 FC |
1047 | # (un)tie $glob_copy vs (un)tie *$glob_copy |
1048 | sub TIESCALAR { print "TIESCALAR\n"; bless [] } | |
1049 | sub TIEHANDLE{ print "TIEHANDLE\n"; bless [] } | |
1050 | sub FETCH { print "never called\n" } | |
8bb5f786 FC |
1051 | $f = *foo; |
1052 | tie *$f, ""; | |
1053 | tie $f, ""; | |
ca0d4ed9 FC |
1054 | untie $f; |
1055 | print "ok 1\n" if !tied $f; | |
1056 | () = $f; # should not call FETCH | |
1057 | untie *$f; | |
1058 | print "ok 2\n" if !tied *foo; | |
8bb5f786 FC |
1059 | EXPECT |
1060 | TIEHANDLE | |
1061 | TIESCALAR | |
ca0d4ed9 FC |
1062 | ok 1 |
1063 | ok 2 | |
d8ef3a16 DM |
1064 | ######## |
1065 | ||
1066 | # RT #8611 mustn't goto outside the magic stack | |
1067 | sub TIESCALAR { warn "tiescalar\n"; bless [] } | |
1068 | sub FETCH { warn "fetch()\n"; goto FOO; } | |
1069 | tie $f, ""; | |
1070 | warn "before fetch\n"; | |
1071 | my $a = "$f"; | |
1072 | warn "before FOO\n"; | |
1073 | FOO: | |
1074 | warn "after FOO\n"; | |
1075 | EXPECT | |
1076 | tiescalar | |
1077 | before fetch | |
1078 | fetch() | |
1079 | Can't find label FOO at - line 4. | |
1080 | ######## | |
1081 | ||
1082 | # RT #8611 mustn't goto outside the magic stack | |
1083 | sub TIEHANDLE { warn "tiehandle\n"; bless [] } | |
1084 | sub PRINT { warn "print()\n"; goto FOO; } | |
1085 | tie *F, ""; | |
1086 | warn "before print\n"; | |
1087 | print F "abc"; | |
1088 | warn "before FOO\n"; | |
1089 | FOO: | |
1090 | warn "after FOO\n"; | |
1091 | EXPECT | |
1092 | tiehandle | |
1093 | before print | |
1094 | print() | |
1095 | Can't find label FOO at - line 4. | |
ff55a019 FC |
1096 | ######## |
1097 | ||
1098 | # \&$tied with $tied holding a reference before the fetch (but not after) | |
1099 | sub ::72 { 73 }; | |
1100 | sub TIESCALAR {bless[]} | |
1101 | sub STORE{} | |
1102 | sub FETCH { 72 } | |
1103 | tie my $x, "main"; | |
1104 | $x = \$y; | |
1105 | \&$x; | |
1106 | print "ok\n"; | |
1107 | EXPECT | |
1108 | ok | |
1109 | ######## | |
1110 | ||
1111 | # \&$tied with $tied holding a PVLV glob before the fetch (but not after) | |
1112 | sub ::72 { 73 }; | |
1113 | sub TIEARRAY {bless[]} | |
1114 | sub STORE{} | |
1115 | sub FETCH { 72 } | |
1116 | tie my @x, "main"; | |
1117 | my $elem = \$x[0]; | |
1118 | $$elem = *bar; | |
1119 | print &{\&$$elem}, "\n"; | |
1120 | EXPECT | |
1121 | 73 | |
48e092ec FC |
1122 | ######## |
1123 | ||
1124 | # \&$tied with $tied holding a PVGV glob before the fetch (but not after) | |
1125 | local *72 = sub { 73 }; | |
1126 | sub TIESCALAR {bless[]} | |
1127 | sub STORE{} | |
1128 | sub FETCH { 72 } | |
1129 | tie my $x, "main"; | |
1130 | $x = *bar; | |
1131 | print &{\&$x}, "\n"; | |
1132 | EXPECT | |
1133 | 73 | |
9c3f0156 FC |
1134 | ######## |
1135 | ||
1136 | # Lexicals should not be visible to magic methods on scope exit | |
1137 | BEGIN { unless (defined &DynaLoader::boot_DynaLoader) { | |
1138 | print "HASH\nHASH\nARRAY\nARRAY\n"; exit; | |
1139 | }} | |
1140 | use Scalar::Util 'weaken'; | |
1141 | { package xoufghd; | |
1142 | sub TIEHASH { Scalar::Util::weaken($_[1]); bless \$_[1], xoufghd:: } | |
1143 | *TIEARRAY = *TIEHASH; | |
1144 | DESTROY { | |
1145 | bless ${$_[0]} || return, 0; | |
1146 | } } | |
1147 | for my $sub ( | |
1148 | # hashes: ties before backrefs | |
1149 | sub { | |
1150 | my %hash; | |
1151 | $ref = ref \%hash; | |
1152 | tie %hash, xoufghd::, \%hash; | |
1153 | 1; | |
1154 | }, | |
1155 | # hashes: backrefs before ties | |
1156 | sub { | |
1157 | my %hash; | |
1158 | $ref = ref \%hash; | |
1159 | weaken(my $x = \%hash); | |
1160 | tie %hash, xoufghd::, \%hash; | |
1161 | 1; | |
1162 | }, | |
8be25b25 | 1163 | # arrays: ties before backrefs |
9c3f0156 FC |
1164 | sub { |
1165 | my @array; | |
1166 | $ref = ref \@array; | |
1167 | tie @array, xoufghd::, \@array; | |
1168 | 1; | |
1169 | }, | |
8be25b25 | 1170 | # arrays: backrefs before ties |
9c3f0156 FC |
1171 | sub { |
1172 | my @array; | |
1173 | $ref = ref \@array; | |
1174 | weaken(my $x = \@array); | |
1175 | tie @array, xoufghd::, \@array; | |
1176 | 1; | |
1177 | }, | |
1178 | ) { | |
1179 | &$sub; | |
1180 | &$sub; | |
1181 | print $ref, "\n"; | |
1182 | } | |
1183 | EXPECT | |
1184 | HASH | |
1185 | HASH | |
1186 | ARRAY | |
1187 | ARRAY | |
f1f99dc1 FC |
1188 | ######## |
1189 | ||
1190 | # Localising a tied variable with a typeglob in it should copy magic | |
1191 | sub TIESCALAR{bless[]} | |
1192 | sub FETCH{warn "fetching\n"; *foo} | |
1193 | sub STORE{} | |
1194 | tie $x, ""; | |
1195 | local $x; | |
1196 | warn "before"; | |
1197 | "$x"; | |
1198 | warn "after"; | |
1199 | EXPECT | |
1200 | fetching | |
1201 | before at - line 8. | |
1202 | fetching | |
1203 | after at - line 10. | |
dc456155 FC |
1204 | ######## |
1205 | ||
1206 | # tied returns same value as tie | |
1207 | sub TIESCALAR{bless[]} | |
1208 | $tyre = \tie $tied, ""; | |
1209 | print "ok\n" if \tied $tied == $tyre; | |
1210 | EXPECT | |
1211 | ok |