fix for Module/CoreList.pm 5.029009
[perl.git] / t / op / tie.t
1 #!./perl
2
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 #
11
12 chdir 't' if -d 't';
13 require './test.pl';
14 set_up_inc('../lib');
15
16 $|=1;
17
18 run_multiple_progs('', \*DATA);
19
20 done_testing();
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 # SKIP ?!defined &DynaLoader::boot_DynaLoader && !eval 'require base'
31 # (skip under miniperl if base.pm is not in lib/ yet)
32
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
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
81 use warnings 'untie';
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
89 use warnings 'untie';
90 use Tie::Hash ;
91 $a = tie %h, Tie::StdHash;
92 untie %h;
93 EXPECT
94 untie attempted while 1 inner references still exist at - line 6.
95 ########
96
97 # strict behaviour, with 1 extra references via tied generating an error
98 use warnings 'untie';
99 use Tie::Hash ;
100 tie %h, Tie::StdHash;
101 $a = tied %h;
102 untie %h;
103 EXPECT
104 untie attempted while 1 inner references still exist at - line 7.
105 ########
106
107 # strict behaviour, with 1 extra references which are destroyed
108 use warnings 'untie';
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
117 use warnings 'untie';
118 use Tie::Hash ;
119 tie %h, Tie::StdHash;
120 $a = tied %h;
121 $a = 0 ;
122 untie %h;
123 EXPECT
124 ########
125
126 # strict error behaviour, with 2 extra references
127 use warnings 'untie';
128 use Tie::Hash ;
129 $a = tie %h, Tie::StdHash;
130 $b = tied %h ;
131 untie %h;
132 EXPECT
133 untie attempted while 2 inner references still exist at - line 7.
134 ########
135
136 # strict behaviour, check scope of strictness.
137 no warnings 'untie';
138 use Tie::Hash ;
139 $A = tie %H, Tie::StdHash;
140 $C = $B = tied %H ;
141 {
142     use warnings 'untie';
143     use Tie::Hash ;
144     tie %h, Tie::StdHash;
145     untie %h;
146 }
147 untie %H;
148 EXPECT
149 ########
150
151 # Forbidden aggregate self-ties
152 sub Self::TIEHASH { bless $_[1], $_[0] }
153 {
154     my %c;
155     tie %c, 'Self', \%c;
156 }
157 EXPECT
158 Self-ties of arrays and hashes are not supported at - line 6.
159 ########
160
161 # Allowed scalar self-ties
162 my $destroyed = 0;
163 sub Self::TIESCALAR { bless $_[1], $_[0] }
164 sub Self::DESTROY   { $destroyed = 1; }
165 {
166     my $c = 42;
167     tie $c, 'Self', \$c;
168 }
169 die "self-tied scalar not DESTROYed" unless $destroyed == 1;
170 EXPECT
171 ########
172
173 # Allowed glob self-ties
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;
186 die "self-tied glob not DESTROYed" unless $destroyed == 1;
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; }
194 sub Self3::PRINT     { $printed = 1; }
195 {
196     use Symbol 'geniosym';
197     my $c = geniosym;
198     tie *$c, 'Self3', $c;
199     print $c 'Hello';
200 }
201 die "self-tied IO not PRINTed" unless $printed == 1;
202 die "self-tied IO not DESTROYed" unless $destroyed == 1;
203 EXPECT
204 ########
205
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
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.
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
276 ########
277 #
278 # FETCH freeing tie'd SV still works
279 sub TIESCALAR { bless [] }
280 sub FETCH { *a = \1; 2 }
281 tie $a, 'main';
282 print $a;
283 EXPECT
284 2
285 ########
286
287 #  [20020716.007 (#10080)] - 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
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";
328 my $s = $a->{foo}; # access once
329 # the hash element should not be tied anymore
330 print defined tied $a->{foo} ? "not ok" : "ok";
331 EXPECT
332 ok
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
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
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
361 #  above. Its odd but convenient that after untie'ing you are left with
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
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
436 ########
437
438 # [perl #948] cannot meaningfully tie $,
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;
454     print "<FETCH>";
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'
464 join<FETCH>BOBBINSthings<FETCH>BOBBINSup
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";
497 print scalar %h, "\n"
498     if %h; # this should also call SCALAR but implicitly
499 %h = ();
500 print scalar %h, "\n"
501     if !%h; # this should also call SCALAR but implicitly
502 EXPECT
503 SCALAR
504 SCALAR
505 2/2
506 SCALAR
507 SCALAR
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
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
571 ########
572 sub TIESCALAR { bless {} }
573 sub FETCH { shift()->{i} ++ }
574 tie $h, "main";
575 print $h.$h;
576 EXPECT
577 01
578 ########
579 # SKIP ? $IS_EBCDIC
580 # skipped on EBCDIC because "2" | "8" is 0xFA (not COLON as it is on ASCII),
581 # which isn't representable in this file's UTF-8 encoding.
582 # Bug 53482 (and maybe others)
583
584 sub TIESCALAR { my $foo = $_[1]; bless \$foo, $_[0] }
585 sub FETCH { ${$_[0]} }
586 tie my $x1, "main", 2;
587 tie my $y1, "main", 8;
588 print $x1 | $y1;
589 print $x1 | $y1;
590 tie my $x2, "main", "2";
591 tie my $y2, "main", "8";
592 print $x2 | $y2;
593 print $x2 | $y2;
594 EXPECT
595 1010::
596 ########
597 # Bug 36267
598 sub TIEHASH  { bless {}, $_[0] }
599 sub STORE    { $_[0]->{$_[1]} = $_[2] }
600 sub FIRSTKEY { my $a = scalar keys %{$_[0]}; each %{$_[0]} }
601 sub NEXTKEY  { each %{$_[0]} }
602 sub DELETE   { delete $_[0]->{$_[1]} }
603 sub CLEAR    { %{$_[0]} = () }
604 $h{b}=1;
605 delete $h{b};
606 print scalar keys %h, "\n";
607 tie %h, 'main';
608 $i{a}=1;
609 %h = %i;
610 untie %h;
611 print scalar keys %h, "\n";
612 EXPECT
613 0
614 0
615 ########
616 # Bug 37731
617 sub foo::TIESCALAR { bless {value => $_[1]}, $_[0] }
618 sub foo::FETCH { $_[0]->{value} }
619 tie my $VAR, 'foo', '42';
620 foreach my $var ($VAR) {
621     print +($var eq $VAR) ? "yes\n" : "no\n";
622 }
623 EXPECT
624 yes
625 ########
626 sub TIEARRAY { bless [], 'main' }
627 {
628     local @a;
629     tie @a, 'main';
630 }
631 print "tied\n" if tied @a;
632 EXPECT
633 ########
634 sub TIEHASH { bless [], 'main' }
635 {
636     local %h;
637     tie %h, 'main';
638 }
639 print "tied\n" if tied %h;
640 EXPECT
641 ########
642 # RT 20727: PL_defoutgv is left as a tied element
643 sub TIESCALAR { return bless {}, 'main' }
644
645 sub STORE {
646     select($_[1]);
647     $_[1] = 1;
648     select(); # this used to coredump or assert fail
649 }
650 tie $SELECT, 'main';
651 $SELECT = *STDERR;
652 EXPECT
653 ########
654 # RT 23810: eval in die in FETCH can corrupt context stack
655
656 my $file = 'rt23810.pm';
657
658 my $e;
659 my $s;
660
661 sub do_require {
662     my ($str, $eval) = @_;
663     open my $fh, '>', $file or die "Can't create $file: $!\n";
664     print $fh $str;
665     close $fh;
666     if ($eval) {
667         $s .= '-ERQ';
668         eval { require $pm; $s .= '-ENDE' }
669     }
670     else {
671         $s .= '-RQ';
672         require $pm;
673     }
674     $s .= '-ENDRQ';
675     unlink $file;
676 }
677
678 sub TIEHASH { bless {} }
679
680 sub FETCH {
681     # 10 or more syntax errors makes yyparse croak()
682     my $bad = q{$x+;$x+;$x+;$x+;$x+;$x+;$x+;$x+;$x+$x+;$x+;$x+;$x+;$x+;;$x+;};
683
684     if ($_[1] eq 'eval') {
685         $s .= 'EVAL';
686         eval q[BEGIN { die; $s .= '-X1' }];
687         $s .= '-BD';
688         eval q[BEGIN { $x+ }];
689         $s .= '-BS';
690         eval '$x+';
691         $s .= '-E1';
692         $s .= '-S1' while $@ =~ /syntax error at/g;
693         eval $bad;
694         $s .= '-E2';
695         $s .= '-S2' while $@ =~ /syntax error at/g;
696     }
697     elsif ($_[1] eq 'require') {
698         $s .= 'REQUIRE';
699         my @text = (
700             q[BEGIN { die; $s .= '-X1' }],
701             q[BEGIN { $x+ }],
702             '$x+',
703             $bad
704         );
705         for my $i (0..$#text) {
706             $s .= "-$i";
707             do_require($txt[$i], 0) if $e;;
708             do_require($txt[$i], 1);
709         }
710     }
711     elsif ($_[1] eq 'exit') {
712         eval q[exit(0); print "overshot eval\n"];
713     }
714     else {
715         print "unknown key: '$_[1]'\n";
716     }
717     return "-R";
718 }
719 my %foo;
720 tie %foo, "main";
721
722 for my $action(qw(eval require)) {
723     $s = ''; $e = 0; $s .= main->FETCH($action); print "$action: s0=$s\n";
724     $s = ''; $e = 1; eval { $s .= main->FETCH($action)}; print "$action: s1=$s\n";
725     $s = ''; $e = 0; $s .= $foo{$action}; print "$action: s2=$s\n";
726     $s = ''; $e = 1; eval { $s .= $foo{$action}}; print "$action: s3=$s\n";
727 }
728 1 while unlink $file;
729
730 $foo{'exit'};
731 print "overshot main\n"; # shouldn't reach here
732
733 EXPECT
734 eval: s0=EVAL-BD-BS-E1-S1-E2-S2-S2-S2-S2-S2-S2-S2-S2-S2-S2-R
735 eval: s1=EVAL-BD-BS-E1-S1-E2-S2-S2-S2-S2-S2-S2-S2-S2-S2-S2-R
736 eval: s2=EVAL-BD-BS-E1-S1-E2-S2-S2-S2-S2-S2-S2-S2-S2-S2-S2-R
737 eval: s3=EVAL-BD-BS-E1-S1-E2-S2-S2-S2-S2-S2-S2-S2-S2-S2-S2-R
738 require: s0=REQUIRE-0-ERQ-ENDRQ-1-ERQ-ENDRQ-2-ERQ-ENDRQ-3-ERQ-ENDRQ-R
739 require: s1=REQUIRE-0-RQ
740 require: s2=REQUIRE-0-ERQ-ENDRQ-1-ERQ-ENDRQ-2-ERQ-ENDRQ-3-ERQ-ENDRQ-R
741 require: s3=REQUIRE-0-RQ
742 ########
743 # RT 8857: STORE incorrectly invoked for local($_) on aliased tied array
744 #          element
745
746 sub TIEARRAY { bless [], $_[0] }
747 sub TIEHASH  { bless [], $_[0] }
748 sub FETCH { $_[0]->[$_[1]] }
749 sub STORE { $_[0]->[$_[1]] = $_[2] }
750
751
752 sub f {
753     local $_[0];
754 }
755 tie @a, 'main';
756 tie %h, 'main';
757
758 foreach ($a[0], $h{a}) {
759     f($_);
760 }
761 # on failure, chucks up 'premature free' etc messages
762 EXPECT
763 ########
764 # RT 5475:
765 # the initial fix for this bug caused tied scalar FETCH to be called
766 # multiple times when that scalar was an element in an array. Check it
767 # only gets called once now.
768
769 sub TIESCALAR { bless [], $_[0] }
770 my $c = 0;
771 sub FETCH { $c++; 0 }
772 sub FETCHSIZE { 1 }
773 sub STORE { $c += 100; 0 }
774
775
776 my (@a, %h);
777 tie $a[0],   'main';
778 tie $h{foo}, 'main';
779
780 my $i = 0;
781 my $x = $a[0] + $h{foo} + $a[$i] + (@a)[0];
782 print "x=$x c=$c\n";
783 EXPECT
784 x=0 c=4
785 ########
786 # Bug 68192 - numeric ops not calling mg_get when tied scalar holds a ref
787 sub TIESCALAR { bless {}, __PACKAGE__ };
788 sub STORE {};
789 sub FETCH {
790  print "fetching... "; # make sure FETCH is called once per op
791  123456
792 };
793 my $foo;
794 tie $foo, __PACKAGE__;
795 my $a = [1234567];
796 $foo = $a;
797 print "+   ", 0 + $foo, "\n";
798 print "**  ", $foo**1, "\n";
799 print "*   ", $foo*1, "\n";
800 print "/   ", $foo*1, "\n";
801 print "%   ", $foo%123457, "\n";
802 print "-   ", $foo-0, "\n";
803 print "neg ", - -$foo, "\n";
804 print "int ", int $foo, "\n";
805 print "abs ", abs $foo, "\n";
806 print "==  ", 123456 == $foo, "\n";
807 print "<   ", 123455 < $foo, "\n";
808 print ">   ", 123457 > $foo, "\n";
809 print "<=  ", 123456 <= $foo, "\n";
810 print ">=  ", 123456 >= $foo, "\n";
811 print "!=  ", 0 != $foo, "\n";
812 print "<=> ", 123457 <=> $foo, "\n";
813 EXPECT
814 fetching... +   123456
815 fetching... **  123456
816 fetching... *   123456
817 fetching... /   123456
818 fetching... %   123456
819 fetching... -   123456
820 fetching... neg 123456
821 fetching... int 123456
822 fetching... abs 123456
823 fetching... ==  1
824 fetching... <   1
825 fetching... >   1
826 fetching... <=  1
827 fetching... >=  1
828 fetching... !=  1
829 fetching... <=> 1
830 ########
831 # Ties returning overloaded objects
832 {
833  package overloaded;
834  use overload
835   '*{}' => sub { print '*{}'; \*100 },
836   '@{}' => sub { print '@{}'; \@100 },
837   '%{}' => sub { print '%{}'; \%100 },
838   '${}' => sub { print '${}'; \$100 },
839   map {
840    my $op = $_;
841    $_ => sub { print "$op"; 100 }
842   } qw< 0+ "" + ** * / % - neg int abs == < > <= >= != <=> <> >
843 }
844 $o = bless [], overloaded;
845
846 sub TIESCALAR { bless {}, "" }
847 sub FETCH { print "fetching... "; $o }
848 sub STORE{}
849 tie $ghew, "";
850
851 $ghew=undef; 1+$ghew; print "\n";
852 $ghew=undef; $ghew**1; print "\n";
853 $ghew=undef; $ghew*1; print "\n";
854 $ghew=undef; $ghew/1; print "\n";
855 $ghew=undef; $ghew%1; print "\n";
856 $ghew=undef; $ghew-1; print "\n";
857 $ghew=undef; -$ghew; print "\n";
858 $ghew=undef; int $ghew; print "\n";
859 $ghew=undef; abs $ghew; print "\n";
860 $ghew=undef; 1 == $ghew; print "\n";
861 $ghew=undef; $ghew<1; print "\n";
862 $ghew=undef; $ghew>1; print "\n";
863 $ghew=undef; $ghew<=1; print "\n";
864 $ghew=undef; $ghew >=1; print "\n";
865 $ghew=undef; $ghew != 1; print "\n";
866 $ghew=undef; $ghew<=>1; print "\n";
867 $ghew=undef; <$ghew>; print "\n";
868 $ghew=\*shrext; *$ghew; print "\n";
869 $ghew=\@spled; @$ghew; print "\n";
870 $ghew=\%frit; %$ghew; print "\n";
871 $ghew=\$drile; $$ghew; print "\n";
872 EXPECT
873 fetching... +
874 fetching... **
875 fetching... *
876 fetching... /
877 fetching... %
878 fetching... -
879 fetching... neg
880 fetching... int
881 fetching... abs
882 fetching... ==
883 fetching... <
884 fetching... >
885 fetching... <=
886 fetching... >=
887 fetching... !=
888 fetching... <=>
889 fetching... <>
890 fetching... *{}
891 fetching... @{}
892 fetching... %{}
893 fetching... ${}
894 ########
895 # RT 51636: segmentation fault with array ties
896
897 tie my @a, 'T';
898 @a = (1);
899 print "ok\n"; # if we got here we didn't crash
900
901 package T;
902
903 sub TIEARRAY { bless {} }
904 sub STORE    { tie my @b, 'T' }
905 sub CLEAR    { }
906 sub EXTEND   { }
907
908 EXPECT
909 ok
910 ########
911 # RT 8438: Tied scalars don't call FETCH when subref is dereferenced
912
913 sub TIESCALAR { bless {} }
914
915 my $fetch = 0;
916 my $called = 0;
917 sub FETCH { $fetch++; sub { $called++ } }
918
919 tie my $f, 'main';
920 $f->(1) for 1,2;
921 print "fetch=$fetch\ncalled=$called\n";
922
923 EXPECT
924 fetch=2
925 called=2
926 ########
927 # tie mustn't attempt to call methods on bareword filehandles.
928 sub IO::File::TIEARRAY {
929     die "Did not want to invoke IO::File::TIEARRAY";
930 }
931 fileno FOO; tie @a, "FOO"
932 EXPECT
933 Can't locate object method "TIEARRAY" via package "FOO" (perhaps you forgot to load "FOO"?) at - line 5.
934 ########
935 # tie into empty package name
936 tie $foo, "";
937 EXPECT
938 Can't locate object method "TIESCALAR" via package "main" at - line 2.
939 ########
940 # tie into undef package name
941 tie $foo, undef;
942 EXPECT
943 Can't locate object method "TIESCALAR" via package "main" at - line 2.
944 ########
945 # tie into nonexistent glob [RT#130623 assertion failure]
946 tie $foo, *FOO;
947 EXPECT
948 Can't locate object method "TIESCALAR" via package "FOO" at - line 2.
949 ########
950 # tie into glob when package exists but not method: no "*", no "main::"
951 { package PackageWithoutTIESCALAR }
952 tie $foo, *PackageWithoutTIESCALAR;
953 EXPECT
954 Can't locate object method "TIESCALAR" via package "PackageWithoutTIESCALAR" at - line 3.
955 ########
956 # tie into reference [RT#130623 assertion failure]
957 eval { tie $foo, \"nope" };
958 my $exn = $@ // "";
959 print $exn =~ s/0x\w+/0xNNN/rg;
960 EXPECT
961 Can't locate object method "TIESCALAR" via package "SCALAR(0xNNN)" at - line 2.
962 ########
963 #
964 # STORE freeing tie'd AV
965 sub TIEARRAY  { bless [] }
966 sub STORE     { *a = []; 1 }
967 sub STORESIZE { }
968 sub EXTEND    { }
969 tie @a, 'main';
970 $a[0] = 1;
971 EXPECT
972 ########
973 #
974 # CLEAR freeing tie'd AV
975 sub TIEARRAY  { bless [] }
976 sub CLEAR     { *a = []; 1 }
977 sub STORESIZE { }
978 sub EXTEND    { }
979 sub STORE     { }
980 tie @a, 'main';
981 @a = (1,2,3);
982 EXPECT
983 ########
984 #
985 # FETCHSIZE freeing tie'd AV
986 sub TIEARRAY  { bless [] }
987 sub FETCHSIZE { *a = []; 100 }
988 sub STORESIZE { }
989 sub EXTEND    { }
990 sub STORE     { }
991 tie @a, 'main';
992 print $#a,"\n"
993 EXPECT
994 99
995 ########
996 #
997 # [perl #86328] Crash when freeing tie magic that can increment the refcnt
998
999 eval { require Scalar::Util } or print("ok\n"), exit;
1000
1001 sub TIEHASH {
1002     return $_[1];
1003 }
1004 *TIEARRAY = *TIEHASH;
1005
1006 sub DESTROY {
1007     my ($tied) = @_;
1008     my $b = $tied->[0];
1009 }
1010
1011 my $a = {};
1012 my $o = bless [];
1013 Scalar::Util::weaken($o->[0] = $a);
1014 tie %$a, "main", $o;
1015
1016 my $b = [];
1017 my $p = bless [];
1018 Scalar::Util::weaken($p->[0] = $b);
1019 tie @$b, "main", $p;
1020
1021 # Done setting up the evil data structures
1022
1023 $a = undef;
1024 $b = undef;
1025 print "ok\n";
1026
1027 EXPECT
1028 ok
1029 ########
1030 #
1031 # Localising a tied COW scalar should not make it read-only.
1032
1033 sub TIESCALAR { bless [] }
1034 sub FETCH { __PACKAGE__ }
1035 sub STORE {}
1036 tie $x, "";
1037 "$x";
1038 {
1039     local $x;
1040     $x = 3;
1041 }
1042 print "ok\n";
1043 EXPECT
1044 ok
1045 ########
1046 #
1047 # Nor should it be impossible to tie COW scalars that are already PVMGs.
1048
1049 sub TIESCALAR { bless [] }
1050 $x = *foo;        # PVGV
1051 undef $x;         # downgrade to PVMG
1052 $x = __PACKAGE__; # PVMG + COW
1053 tie $x, "";       # bang!
1054
1055 print STDERR "ok\n";
1056
1057 # However, one should not be able to tie read-only glob copies, which look
1058 # a bit like kine internally (FAKE + READONLY).
1059 $y = *foo;
1060 Internals::SvREADONLY($y,1);
1061 tie $y, "";
1062
1063 EXPECT
1064 ok
1065 Modification of a read-only value attempted at - line 16.
1066 ########
1067 #
1068 # And one should not be able to tie read-only COWs
1069 for(__PACKAGE__) { tie $_, "" }
1070 sub TIESCALAR {bless []}
1071 EXPECT
1072 Modification of a read-only value attempted at - line 3.
1073 ########
1074
1075 # Similarly, read-only regexps cannot be tied.
1076 sub TIESCALAR { bless [] }
1077 $y = ${qr//};
1078 Internals::SvREADONLY($y,1);
1079 tie $y, "";
1080
1081 EXPECT
1082 Modification of a read-only value attempted at - line 6.
1083 ########
1084
1085 # tied() should still work on tied scalars after glob assignment
1086 sub TIESCALAR {bless[]}
1087 sub FETCH {*foo}
1088 sub f::TIEHANDLE{bless[],f}
1089 tie *foo, "f";
1090 tie $rin, "";
1091 [$rin]; # call FETCH
1092 print ref tied $rin, "\n";
1093 print ref tied *$rin, "\n";
1094 EXPECT
1095 main
1096 f
1097 ########
1098
1099 # (un)tie $glob_copy vs (un)tie *$glob_copy
1100 sub TIESCALAR { print "TIESCALAR\n"; bless [] }
1101 sub TIEHANDLE{ print "TIEHANDLE\n"; bless [] }
1102 sub FETCH { print "never called\n" }
1103 $f = *foo;
1104 tie *$f, "";
1105 tie $f, "";
1106 untie $f;
1107 print "ok 1\n" if !tied $f;
1108 () = $f; # should not call FETCH
1109 untie *$f;
1110 print "ok 2\n" if !tied *foo;
1111 EXPECT
1112 TIEHANDLE
1113 TIESCALAR
1114 ok 1
1115 ok 2
1116 ########
1117
1118 # RT #8611 mustn't goto outside the magic stack
1119 sub TIESCALAR { warn "tiescalar\n"; bless [] }
1120 sub FETCH { warn "fetch()\n"; goto FOO; }
1121 tie $f, "";
1122 warn "before fetch\n";
1123 my $a = "$f";
1124 warn "before FOO\n";
1125 FOO:
1126 warn "after FOO\n";
1127 EXPECT
1128 tiescalar
1129 before fetch
1130 fetch()
1131 Can't find label FOO at - line 4.
1132 ########
1133
1134 # RT #8611 mustn't goto outside the magic stack
1135 sub TIEHANDLE { warn "tiehandle\n"; bless [] }
1136 sub PRINT { warn "print()\n"; goto FOO; }
1137 tie *F, "";
1138 warn "before print\n";
1139 print F "abc";
1140 warn "before FOO\n";
1141 FOO:
1142 warn "after FOO\n";
1143 EXPECT
1144 tiehandle
1145 before print
1146 print()
1147 Can't find label FOO at - line 4.
1148 ########
1149
1150 # \&$tied with $tied holding a reference before the fetch (but not after)
1151 sub ::72 { 73 };
1152 sub TIESCALAR {bless[]}
1153 sub STORE{}
1154 sub FETCH { 72 }
1155 tie my $x, "main";
1156 $x = \$y;
1157 \&$x;
1158 print "ok\n";
1159 EXPECT
1160 ok
1161 ########
1162
1163 # \&$tied with $tied holding a PVLV glob before the fetch (but not after)
1164 sub ::72 { 73 };
1165 sub TIEARRAY {bless[]}
1166 sub STORE{}
1167 sub FETCH { 72 }
1168 tie my @x, "main";
1169 my $elem = \$x[0];
1170 $$elem = *bar;
1171 print &{\&$$elem}, "\n";
1172 EXPECT
1173 73
1174 ########
1175
1176 # \&$tied with $tied holding a PVGV glob before the fetch (but not after)
1177 local *72 = sub { 73 };
1178 sub TIESCALAR {bless[]}
1179 sub STORE{}
1180 sub FETCH { 72 }
1181 tie my $x, "main";
1182 $x = *bar;
1183 print &{\&$x}, "\n";
1184 EXPECT
1185 73
1186 ########
1187
1188 # Lexicals should not be visible to magic methods on scope exit
1189 BEGIN { unless (defined &DynaLoader::boot_DynaLoader) {
1190     print "HASH\nHASH\nARRAY\nARRAY\n"; exit;
1191 }}
1192 use Scalar::Util 'weaken';
1193 { package xoufghd;
1194   sub TIEHASH { Scalar::Util::weaken($_[1]); bless \$_[1], xoufghd:: }
1195   *TIEARRAY = *TIEHASH;
1196   DESTROY {
1197      bless ${$_[0]} || return, 0;
1198 } }
1199 for my $sub (
1200     # hashes: ties before backrefs
1201     sub {
1202         my %hash;
1203         $ref = ref \%hash;
1204         tie %hash, xoufghd::, \%hash;
1205         1;
1206     },
1207     # hashes: backrefs before ties
1208     sub {
1209         my %hash;
1210         $ref = ref \%hash;
1211         weaken(my $x = \%hash);
1212         tie %hash, xoufghd::, \%hash;
1213         1;
1214     },
1215     # arrays: ties before backrefs
1216     sub {
1217         my @array;
1218         $ref = ref \@array;
1219         tie @array, xoufghd::, \@array;
1220         1;
1221     },
1222     # arrays: backrefs before ties
1223     sub {
1224         my @array;
1225         $ref = ref \@array;
1226         weaken(my $x = \@array);
1227         tie @array, xoufghd::, \@array;
1228         1;
1229     },
1230 ) {
1231     &$sub;
1232     &$sub;
1233     print $ref, "\n";
1234 }
1235 EXPECT
1236 HASH
1237 HASH
1238 ARRAY
1239 ARRAY
1240 ########
1241
1242 # Localising a tied variable with a typeglob in it should copy magic
1243 sub TIESCALAR{bless[]}
1244 sub FETCH{warn "fetching\n"; *foo}
1245 sub STORE{}
1246 tie $x, "";
1247 local $x;
1248 warn "before";
1249 "$x";
1250 warn "after";
1251 EXPECT
1252 fetching
1253 before at - line 8.
1254 fetching
1255 after at - line 10.
1256 ########
1257
1258 # tied returns same value as tie
1259 sub TIESCALAR{bless[]}
1260 $tyre = \tie $tied, "";
1261 print "ok\n" if \tied $tied == $tyre;
1262 EXPECT
1263 ok
1264 ########
1265
1266 # tied arrays should always be AvREAL
1267 $^W=1;
1268 sub TIEARRAY{bless[]}
1269 sub {
1270   tie @_, "";
1271   \@_; # used to produce: av_reify called on tied array at - line 7.
1272 }->(1);
1273 EXPECT
1274 ########
1275
1276 # [perl #67490] scalar-tying elements of magic hashes
1277 sub TIESCALAR{bless[]}
1278 sub STORE{}
1279 tie $ENV{foo}, '';
1280 $ENV{foo} = 78;
1281 delete $ENV{foo};
1282 tie $^H{foo}, '';
1283 $^H{foo} = 78;
1284 delete $^H{foo};
1285 EXPECT
1286 ########
1287
1288 # [perl #35865, #43011] autovivification should call FETCH after STORE
1289 # because perl does not know that the FETCH would have returned the same
1290 # thing that was just stored.
1291
1292 # This package never likes to take ownership of other people‚Äôs refs.  It
1293 # always makes its own copies.  (For simplicity, it only accepts hashes.)
1294 package copier {
1295     sub TIEHASH { bless {} }
1296     sub FETCH   { $_[0]{$_[1]} }
1297     sub STORE   { $_[0]{$_[1]} = { %{ $_[2] } } }
1298 }
1299 tie my %h, copier::;
1300 $h{i}{j} = 'k';
1301 print $h{i}{j}, "\n";
1302 EXPECT
1303 k
1304 ########
1305
1306 # [perl #8931] FETCH for tied $" called an odd number of times.
1307 use strict;
1308 my $i = 0;
1309 sub A::TIESCALAR {bless [] => 'A'}
1310 sub A::FETCH {print ++ $i, "\n"}
1311 my @a = ("", "", "");
1312
1313 tie $" => 'A';
1314 "@a";
1315
1316 $i = 0;
1317 tie my $a => 'A';
1318 join $a, 1..10;
1319 EXPECT
1320 1
1321 1
1322 ########
1323
1324 # [perl #9391] return value from 'tied' not discarded soon enough
1325 use warnings;
1326 tie @a, 'T';
1327 if (tied @a) {
1328 untie @a;
1329 }
1330
1331 sub T::TIEARRAY { my $s; bless \$s => "T" }
1332 EXPECT
1333 ########
1334
1335 # NAME Test that tying a hash does not leak a deleted iterator
1336 # This produced unbalanced string table warnings under
1337 # PERL_DESTRUCT_LEVEL=2.
1338 package l {
1339     sub TIEHASH{bless[]}
1340 }
1341 $h = {foo=>0};
1342 each %$h;
1343 delete $$h{foo};
1344 tie %$h, 'l';
1345 EXPECT
1346 ########
1347
1348 # NAME EXISTS on arrays
1349 sub TIEARRAY{bless[]};
1350 sub FETCHSIZE { 50 }
1351 sub EXISTS { print "does $_[1] exist?\n" }
1352 tie @a, "";
1353 exists $a[1];
1354 exists $a[-1];
1355 $NEGATIVE_INDICES=1;
1356 exists $a[-1];
1357 EXPECT
1358 does 1 exist?
1359 does 49 exist?
1360 does -1 exist?
1361 ########
1362
1363 # Crash when using negative index on array tied to non-object
1364 sub TIEARRAY{bless[]};
1365 ${\tie @a, ""} = undef;
1366 eval { $_ = $a[-1] }; print $@;
1367 eval { $a[-1] = '' }; print $@;
1368 eval { delete $a[-1] }; print $@;
1369 eval { exists $a[-1] }; print $@;
1370
1371 EXPECT
1372 Can't call method "FETCHSIZE" on an undefined value at - line 5.
1373 Can't call method "FETCHSIZE" on an undefined value at - line 6.
1374 Can't call method "FETCHSIZE" on an undefined value at - line 7.
1375 Can't call method "FETCHSIZE" on an undefined value at - line 8.
1376 ########
1377
1378 # Crash when reading negative index when NEGATIVE_INDICES stub exists
1379 sub NEGATIVE_INDICES;
1380 sub TIEARRAY{bless[]};
1381 sub FETCHSIZE{}
1382 tie @a, "";
1383 print "ok\n" if ! defined $a[-1];
1384 EXPECT
1385 ok
1386 ########
1387
1388 # Assigning vstrings to tied scalars
1389 sub TIESCALAR{bless[]};
1390 sub STORE { print ref \$_[1], "\n" }
1391 tie $x, ""; $x = v3;
1392 EXPECT
1393 VSTRING
1394 ########
1395
1396 # [perl #27010] Tying deferred elements
1397 $\="\n";
1398 sub TIESCALAR{bless[]};
1399 sub {
1400     tie $_[0], "";
1401     print ref tied $h{k};
1402     tie $h{l}, "";
1403     print ref tied $_[1];
1404     untie $h{k};
1405     print tied $_[0] // 'undef';
1406     untie $_[1];
1407     print tied $h{l} // 'undef';
1408     # check that tied and untie do not autovivify
1409     # XXX should they autovivify?
1410     tied $_[2];
1411     print exists $h{m} ? "yes" : "no";
1412     untie $_[2];
1413     print exists $h{m} ? "yes" : "no";
1414 }->($h{k}, $h{l}, $h{m});
1415 EXPECT
1416 main
1417 main
1418 undef
1419 undef
1420 no
1421 no
1422 ########
1423
1424 # [perl #78194] Passing op return values to tie constructors
1425 sub TIEARRAY{
1426     print \$_[1] == \$_[1] ? "ok\n" : "not ok\n";
1427 };
1428 tie @a, "", "$a$b";
1429 EXPECT
1430 ok
1431 ########
1432
1433 # Scalar-tied locked hash keys and copy-on-write
1434 use Tie::Scalar;
1435 tie $h{foo}, Tie::StdScalar;
1436 tie $h{bar}, Tie::StdScalar;
1437 $h{foo} = __PACKAGE__; # COW
1438 $h{bar} = 1;       # not COW
1439 # Moral equivalent of Hash::Util::lock_whatever, but miniperl-compatible
1440 Internals::SvREADONLY($h{foo},1);
1441 Internals::SvREADONLY($h{bar},1);
1442 print $h{foo}, "\n"; # should not croak
1443 # Whether the value is COW should make no difference here (whether the
1444 # behaviour is ultimately correct is another matter):
1445 local $h{foo};
1446 local $h{bar};
1447 print "ok\n" if (eval{ $h{foo} = 1 }||$@) eq (eval{ $h{bar} = 1 }||$@);
1448 EXPECT
1449 main
1450 ok
1451 ########
1452 # SKIP ? $::IS_EBCDIC
1453 # skipped on EBCDIC because different from ASCII and results vary depending on
1454 # code page
1455
1456 # &xsub and goto &xsub with tied @_
1457 use Tie::Array;
1458 tie @_, Tie::StdArray;
1459 @_ = "\xff";
1460 &utf8::encode;
1461 printf "%x\n", $_ for map ord, split //, $_[0];
1462 print "--\n";
1463 @_ = "\xff";
1464 & {sub { goto &utf8::encode }};
1465 printf "%x\n", $_ for map ord, split //, $_[0];
1466 EXPECT
1467 c3
1468 bf
1469 --
1470 c3
1471 bf
1472 ########
1473
1474 # Defelem pointing to nonexistent element of tied array
1475
1476 use Tie::Array;
1477 # This sub is called with a deferred element.  Inside the sub, $_[0] pros-
1478 # pectively points to element 10000 of @a.
1479 sub {
1480   tie @a, "Tie::StdArray";  # now @a is tied
1481   $#a = 20000;  # and FETCHSIZE/AvFILL will now return a big number
1482   $a[10000] = "crumpets\n";
1483   $_ = "$_[0]"; # but defelems don't expect tied arrays and try to read
1484                 # AvARRAY[10000], which crashes
1485 }->($a[10000]);
1486 print
1487 EXPECT
1488 crumpets
1489 ########
1490
1491 # tied() in list assignment
1492
1493 sub TIESCALAR : lvalue {
1494     ${+pop} = bless [], shift;
1495 }
1496 tie $t, "", \$a;
1497 $a = 7;
1498 ($a, $b) = (3, tied $t);
1499 print "a is $a\n";
1500 print "b is $b\n";
1501 EXPECT
1502 a is 3
1503 b is 7
1504 ########
1505 # when assigning to array/hash, ensure get magic is processed first
1506 use Tie::Hash;
1507 my %tied;
1508 tie %tied, "Tie::StdHash";
1509 %tied = qw(a foo);
1510 my @a = values %tied;
1511 %tied = qw(b bar); # overwrites @a's contents unless magic was called
1512 print "$a[0]\n";
1513 my %h = ("x", values %tied);
1514 %tied = qw(c baz); # overwrites @a's contents unless magic was called
1515 print "$h{x}\n";
1516
1517 EXPECT
1518 foo
1519 bar
1520 ########
1521 # keys(%tied) in bool context without SCALAR present
1522 my ($f,$n) = (0,0);
1523 my %inner = (a =>1, b => 2, c => 3);
1524 sub TIEHASH  { bless \%inner, $_[0] }
1525 sub FIRSTKEY { $f++; my $a = scalar keys %{$_[0]}; each %{$_[0]} }
1526 sub NEXTKEY  { $n++; each %{$_[0]} }
1527 tie %h, 'main';
1528 my $x = !keys %h;
1529 print "[$x][$f][$n]\n";
1530 %inner = ();
1531 $x = !keys %h;
1532 print "[$x][$f][$n]\n";
1533 EXPECT
1534 [][1][0]
1535 [1][2][0]
1536 ########
1537 # keys(%tied) in bool context with SCALAR present
1538 my ($f,$n, $s) = (0,0,0);
1539 my %inner = (a =>1, b => 2, c => 3);
1540 sub TIEHASH  { bless \%inner, $_[0] }
1541 sub FIRSTKEY { $f++; my $a = scalar keys %{$_[0]}; each %{$_[0]} }
1542 sub NEXTKEY  { $n++; each %{$_[0]} }
1543 sub SCALAR   { $s++; scalar %{$_[0]} }
1544 tie %h, 'main';
1545 my $x = !keys %h;
1546 print "[$x][$f][$n][$s]\n";
1547 %inner = ();
1548 $x = !keys %h;
1549 print "[$x][$f][$n][$s]\n";
1550 EXPECT
1551 [][0][0][1]
1552 [1][0][0][2]
1553 ########
1554 # keys(%tied) in scalar context without SCALAR present
1555 my ($f,$n) = (0,0);
1556 my %inner = (a =>1, b => 2, c => 3);
1557 sub TIEHASH  { bless \%inner, $_[0] }
1558 sub FIRSTKEY { $f++; my $a = scalar keys %{$_[0]}; each %{$_[0]} }
1559 sub NEXTKEY  { $n++; each %{$_[0]} }
1560 tie %h, 'main';
1561 my $x = keys %h;
1562 print "[$x][$f][$n]\n";
1563 %inner = ();
1564 $x = keys %h;
1565 print "[$x][$f][$n]\n";
1566 EXPECT
1567 [3][1][3]
1568 [0][2][3]
1569 ########
1570 # keys(%tied) in scalar context with SCALAR present
1571 # XXX the behaviour of scalar(keys(%tied)) may change - it currently
1572 # doesn't make use of SCALAR() if present
1573 my ($f,$n, $s) = (0,0,0);
1574 my %inner = (a =>1, b => 2, c => 3);
1575 sub TIEHASH  { bless \%inner, $_[0] }
1576 sub FIRSTKEY { $f++; my $a = scalar keys %{$_[0]}; each %{$_[0]} }
1577 sub NEXTKEY  { $n++; each %{$_[0]} }
1578 sub SCALAR   { $s++; scalar %{$_[0]} }
1579 tie %h, 'main';
1580 my $x = keys %h;
1581 print "[$x][$f][$n][$s]\n";
1582 %inner = ();
1583 $x = keys %h;
1584 print "[$x][$f][$n][$s]\n";
1585 EXPECT
1586 [3][1][3][0]
1587 [0][2][3][0]