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