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