3 # Add new tests to the end with format:
9 # Warn or die msgs (if any) at - line 1234
18 run_multiple_progs('', \*DATA);
24 # standard behaviour, without any extra references
31 # standard behaviour, without any extra references
33 {package Tie::HashUntie;
34 use base 'Tie::StdHash';
40 tie %h, Tie::HashUntie;
46 # standard behaviour, with 1 extra reference
48 $a = tie %h, Tie::StdHash;
53 # standard behaviour, with 1 extra reference via tied
61 # standard behaviour, with 1 extra reference which is destroyed
63 $a = tie %h, Tie::StdHash;
69 # standard behaviour, with 1 extra reference via tied which is destroyed
78 # strict behaviour, without any extra references
86 # strict behaviour, with 1 extra references generating an error
89 $a = tie %h, Tie::StdHash;
92 untie attempted while 1 inner references still exist at - line 6.
95 # strict behaviour, with 1 extra references via tied generating an error
102 untie attempted while 1 inner references still exist at - line 7.
105 # strict behaviour, with 1 extra references which are destroyed
106 use warnings 'untie';
108 $a = tie %h, Tie::StdHash;
114 # strict behaviour, with extra 1 references via tied which are destroyed
115 use warnings 'untie';
117 tie %h, Tie::StdHash;
124 # strict error behaviour, with 2 extra references
125 use warnings 'untie';
127 $a = tie %h, Tie::StdHash;
131 untie attempted while 2 inner references still exist at - line 7.
134 # strict behaviour, check scope of strictness.
137 $A = tie %H, Tie::StdHash;
140 use warnings 'untie';
142 tie %h, Tie::StdHash;
149 # Forbidden aggregate self-ties
150 sub Self::TIEHASH { bless $_[1], $_[0] }
156 Self-ties of arrays and hashes are not supported at - line 6.
159 # Allowed scalar self-ties
161 sub Self::TIESCALAR { bless $_[1], $_[0] }
162 sub Self::DESTROY { $destroyed = 1; }
167 die "self-tied scalar not DESTROYed" unless $destroyed == 1;
171 # Allowed glob self-ties
174 sub Self2::TIEHANDLE { bless $_[1], $_[0] }
175 sub Self2::DESTROY { $destroyed = 1; }
176 sub Self2::PRINT { $printed = 1; }
180 tie *$c, 'Self2', $c;
183 die "self-tied glob not PRINTed" unless $printed == 1;
184 die "self-tied glob not DESTROYed" unless $destroyed == 1;
188 # Allowed IO self-ties
190 sub Self3::TIEHANDLE { bless $_[1], $_[0] }
191 sub Self3::DESTROY { $destroyed = 1; }
192 sub Self3::PRINT { $printed = 1; }
194 use Symbol 'geniosym';
196 tie *$c, 'Self3', $c;
199 die "self-tied IO not PRINTed" unless $printed == 1;
200 die "self-tied IO not DESTROYed" unless $destroyed == 1;
204 # TODO IO "self-tie" via TEMP glob
206 sub Self3::TIEHANDLE { bless $_[1], $_[0] }
207 sub Self3::DESTROY { $destroyed = 1; }
208 sub Self3::PRINT { $printed = 1; }
210 use Symbol 'geniosym';
212 tie *$c, 'Self3', \*$c;
215 die "IO tied to TEMP glob not PRINTed" unless $printed == 1;
216 die "IO tied to TEMP glob not DESTROYed" unless $destroyed == 1;
220 # Interaction of tie and vec
224 tie $a,Tie::StdScalar or die;
233 # correct unlocalisation of tied hashes (patch #16431)
235 tie %tied, Tie::StdHash;
236 { local $hash{'foo'} } warn "plain hash bad unlocalize" if exists $hash{'foo'};
237 { local $tied{'foo'} } warn "tied hash bad unlocalize" if exists $tied{'foo'};
238 { local $ENV{'foo'} } warn "%ENV bad unlocalize" if exists $ENV{'foo'};
242 # An attempt at lvalueable barewords broke this
245 Can't modify constant item in tie at - line 3, near "'main';"
246 Execution of - aborted due to compilation errors.
249 # localizing tied hash slices
252 print exists $ENV{FooA} ? 1 : 0, "\n";
253 print exists $ENV{FooB} ? 2 : 0, "\n";
254 print exists $ENV{FooC} ? 3 : 0, "\n";
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";
261 print exists $ENV{FooA} ? 7 : 0, "\n";
262 print exists $ENV{FooB} ? 8 : 0, "\n";
263 print exists $ENV{FooC} ? 9 : 0, "\n"; # this should not exist
276 # FETCH freeing tie'd SV still works
277 sub TIESCALAR { bless [] }
278 sub FETCH { *a = \1; 2 }
285 # [20020716.007] - nested FETCHES
287 sub F1::TIEARRAY { bless [], 'F1' }
292 sub F2::TIEARRAY { bless [2], 'F2' }
293 sub F2::FETCH { my $self = shift; my $x = $f1[3]; $self }
297 print $f2[4][0],"\n";
299 sub F3::TIEHASH { bless [], 'F3' }
304 sub F4::TIEHASH { bless [3], 'F4' }
305 sub F4::FETCH { my $self = shift; my $x = $f3{3}; $self }
309 print $f4{'foo'}[0],"\n";
315 # test untie() from within FETCH
317 sub TIESCALAR { my $pkg = shift; return bless [@_], $pkg; }
320 my ($obj, $field) = @$self;
321 untie $obj->{$field};
322 $obj->{$field} = "Bar";
325 tie $a->{foo}, "Foo", $a, "foo";
326 my $s = $a->{foo}; # access once
327 # the hash element should not be tied anymore
328 print defined tied $a->{foo} ? "not ok" : "ok";
332 # the tmps returned by FETCH should appear to be SCALAR
333 # (even though they are now implemented using PVLVs.)
335 sub TIEHASH { bless {} }
336 sub TIEARRAY { bless {} }
343 my $s = "$r1 ". ref($r1) . " $r2 " . ref($r2);
347 SCALAR SCALAR SCALAR SCALAR
349 # [perl #23287] segfault in untie
350 sub TIESCALAR { bless $_[1], $_[0] }
352 tie $var, 'main', \$var;
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
359 # above. Its odd but convenient that after untie'ing you are left with
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)."
368 my ($class,$code) = @_;
378 tie $var, 'MyTied', sub { untie $var; 4 };
394 # [perl #22297] cannot untie scalar from within tied FETCH
398 tie $x, 'Overlay', $ref, $x;
404 #print "WILL EXTERNAL UNTIE $ref\n";
410 #print "counter = $counter\n";
412 print (($counter == 1) ? "ok\n" : "not ok\n");
419 my ($ref, $val) = @_;
420 return bless [ $ref, $val ], $pkg;
426 my ($ref, $val) = @$self;
427 #print "WILL INTERNAL UNITE $ref\n";
436 # [perl #948] cannot meaningfully tie $,
437 package TieDollarComma;
441 return bless \my $x, $pkg;
447 print "STORE set '$$self'\n";
457 tie $,, 'TieDollarComma';
459 print "join", "things", "up\n";
462 join<FETCH>BOBBINSthings<FETCH>BOBBINSup
474 $_[0]->{$_[1]} = $_[2];
487 return 0 if ! keys %{$_[0]};
488 sprintf "%i/%i", scalar keys %{$_[0]}, scalar keys %{$_[0]};
492 tie my %h => "TieScalar";
495 print scalar %h, "\n"
496 if %h; # this should also call SCALAR but implicitly
498 print scalar %h, "\n"
499 if !%h; # this should also call SCALAR but implicitly
509 # test scalar on tied hash when no SCALAR method has been given
517 $_[0]->{$_[1]} = $_[2];
526 my $a = keys %{ $_[0] };
532 tie my %h => "TieScalar";
541 print "not empty\n" if %h;
542 print "not empty\n" if %h;
544 my ($k,$v) = each %h;
546 print "not empty\n" if %h;
548 print "empty\n" if ! %h;
563 sub TIESCALAR { bless {} }
564 sub FETCH { my $x = 3.3; 1 if 0+$x; $x }
570 sub TIESCALAR { bless {} }
571 sub FETCH { shift()->{i} ++ }
577 # Bug 53482 (and maybe others)
578 sub TIESCALAR { my $foo = $_[1]; bless \$foo, $_[0] }
579 sub FETCH { ${$_[0]} }
580 tie my $x1, "main", 2;
581 tie my $y1, "main", 8;
584 tie my $x2, "main", "2";
585 tie my $y2, "main", "8";
592 sub TIEHASH { bless {}, $_[0] }
593 sub STORE { $_[0]->{$_[1]} = $_[2] }
594 sub FIRSTKEY { my $a = scalar keys %{$_[0]}; each %{$_[0]} }
595 sub NEXTKEY { each %{$_[0]} }
596 sub DELETE { delete $_[0]->{$_[1]} }
597 sub CLEAR { %{$_[0]} = () }
600 print scalar keys %h, "\n";
605 print scalar keys %h, "\n";
611 sub foo::TIESCALAR { bless {value => $_[1]}, $_[0] }
612 sub foo::FETCH { $_[0]->{value} }
613 tie my $VAR, 'foo', '42';
614 foreach my $var ($VAR) {
615 print +($var eq $VAR) ? "yes\n" : "no\n";
620 sub TIEARRAY { bless [], 'main' }
625 print "tied\n" if tied @a;
628 sub TIEHASH { bless [], 'main' }
633 print "tied\n" if tied %h;
636 # RT 20727: PL_defoutgv is left as a tied element
637 sub TIESCALAR { return bless {}, 'main' }
642 select(); # this used to coredump or assert fail
648 # RT 23810: eval in die in FETCH can corrupt context stack
650 my $file = 'rt23810.pm';
656 my ($str, $eval) = @_;
657 open my $fh, '>', $file or die "Can't create $file: $!\n";
662 eval { require $pm; $s .= '-ENDE' }
672 sub TIEHASH { bless {} }
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+;};
678 if ($_[1] eq 'eval') {
680 eval q[BEGIN { die; $s .= '-X1' }];
682 eval q[BEGIN { $x+ }];
686 $s .= '-S1' while $@ =~ /syntax error at/g;
689 $s .= '-S2' while $@ =~ /syntax error at/g;
691 elsif ($_[1] eq 'require') {
694 q[BEGIN { die; $s .= '-X1' }],
699 for my $i (0..$#text) {
701 do_require($txt[$i], 0) if $e;;
702 do_require($txt[$i], 1);
705 elsif ($_[1] eq 'exit') {
706 eval q[exit(0); print "overshot eval\n"];
709 print "unknown key: '$_[1]'\n";
716 for my $action(qw(eval require)) {
717 $s = ''; $e = 0; $s .= main->FETCH($action); print "$action: s0=$s\n";
718 $s = ''; $e = 1; eval { $s .= main->FETCH($action)}; print "$action: s1=$s\n";
719 $s = ''; $e = 0; $s .= $foo{$action}; print "$action: s2=$s\n";
720 $s = ''; $e = 1; eval { $s .= $foo{$action}}; print "$action: s3=$s\n";
722 1 while unlink $file;
725 print "overshot main\n"; # shouldn't reach here
728 eval: s0=EVAL-BD-BS-E1-S1-E2-S2-S2-S2-S2-S2-S2-S2-S2-S2-S2-R
729 eval: s1=EVAL-BD-BS-E1-S1-E2-S2-S2-S2-S2-S2-S2-S2-S2-S2-S2-R
730 eval: s2=EVAL-BD-BS-E1-S1-E2-S2-S2-S2-S2-S2-S2-S2-S2-S2-S2-R
731 eval: s3=EVAL-BD-BS-E1-S1-E2-S2-S2-S2-S2-S2-S2-S2-S2-S2-S2-R
732 require: s0=REQUIRE-0-ERQ-ENDRQ-1-ERQ-ENDRQ-2-ERQ-ENDRQ-3-ERQ-ENDRQ-R
733 require: s1=REQUIRE-0-RQ
734 require: s2=REQUIRE-0-ERQ-ENDRQ-1-ERQ-ENDRQ-2-ERQ-ENDRQ-3-ERQ-ENDRQ-R
735 require: s3=REQUIRE-0-RQ
737 # RT 8857: STORE incorrectly invoked for local($_) on aliased tied array
740 sub TIEARRAY { bless [], $_[0] }
741 sub TIEHASH { bless [], $_[0] }
742 sub FETCH { $_[0]->[$_[1]] }
743 sub STORE { $_[0]->[$_[1]] = $_[2] }
752 foreach ($a[0], $h{a}) {
755 # on failure, chucks up 'premature free' etc messages
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.
763 sub TIESCALAR { bless [], $_[0] }
765 sub FETCH { $c++; 0 }
767 sub STORE { $c += 100; 0 }
775 my $x = $a[0] + $h{foo} + $a[$i] + (@a)[0];
780 # Bug 68192 - numeric ops not calling mg_get when tied scalar holds a ref
781 sub TIESCALAR { bless {}, __PACKAGE__ };
784 print "fetching... "; # make sure FETCH is called once per op
788 tie $foo, __PACKAGE__;
791 print "+ ", 0 + $foo, "\n";
792 print "** ", $foo**1, "\n";
793 print "* ", $foo*1, "\n";
794 print "/ ", $foo*1, "\n";
795 print "% ", $foo%123457, "\n";
796 print "- ", $foo-0, "\n";
797 print "neg ", - -$foo, "\n";
798 print "int ", int $foo, "\n";
799 print "abs ", abs $foo, "\n";
800 print "== ", 123456 == $foo, "\n";
801 print "< ", 123455 < $foo, "\n";
802 print "> ", 123457 > $foo, "\n";
803 print "<= ", 123456 <= $foo, "\n";
804 print ">= ", 123456 >= $foo, "\n";
805 print "!= ", 0 != $foo, "\n";
806 print "<=> ", 123457 <=> $foo, "\n";
809 fetching... ** 123456
814 fetching... neg 123456
815 fetching... int 123456
816 fetching... abs 123456
825 # Ties returning overloaded objects
829 '*{}' => sub { print '*{}'; \*100 },
830 '@{}' => sub { print '@{}'; \@100 },
831 '%{}' => sub { print '%{}'; \%100 },
832 '${}' => sub { print '${}'; \$100 },
835 $_ => sub { print "$op"; 100 }
836 } qw< 0+ "" + ** * / % - neg int abs == < > <= >= != <=> <> >
838 $o = bless [], overloaded;
840 sub TIESCALAR { bless {}, "" }
841 sub FETCH { print "fetching... "; $o }
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";
861 $ghew=undef; <$ghew>; print "\n";
862 $ghew=\*shrext; *$ghew; print "\n";
863 $ghew=\@spled; @$ghew; print "\n";
864 $ghew=\%frit; %$ghew; print "\n";
865 $ghew=\$drile; $$ghew; print "\n";
889 # RT 51636: segmentation fault with array ties
893 print "ok\n"; # if we got here we didn't crash
897 sub TIEARRAY { bless {} }
898 sub STORE { tie my @b, 'T' }
905 # RT 8438: Tied scalars don't call FETCH when subref is dereferenced
907 sub TIESCALAR { bless {} }
911 sub FETCH { $fetch++; sub { $called++ } }
915 print "fetch=$fetch\ncalled=$called\n";
921 # tie mustn't attempt to call methods on bareword filehandles.
922 sub IO::File::TIEARRAY {
923 die "Did not want to invoke IO::File::TIEARRAY";
925 fileno FOO; tie @a, "FOO"
927 Can't locate object method "TIEARRAY" via package "FOO" at - line 5.
930 # STORE freeing tie'd AV
931 sub TIEARRAY { bless [] }
932 sub STORE { *a = []; 1 }
940 # CLEAR freeing tie'd AV
941 sub TIEARRAY { bless [] }
942 sub CLEAR { *a = []; 1 }
951 # FETCHSIZE freeing tie'd AV
952 sub TIEARRAY { bless [] }
953 sub FETCHSIZE { *a = []; 100 }
963 # [perl #86328] Crash when freeing tie magic that can increment the refcnt
965 eval { require Scalar::Util } or print("ok\n"), exit;
970 *TIEARRAY = *TIEHASH;
979 Scalar::Util::weaken($o->[0] = $a);
984 Scalar::Util::weaken($p->[0] = $b);
987 # Done setting up the evil data structures
997 # Localising a tied COW scalar should not make it read-only.
999 sub TIESCALAR { bless [] }
1000 sub FETCH { __PACKAGE__ }
1013 # Nor should it be impossible to tie COW scalars that are already PVMGs.
1015 sub TIESCALAR { bless [] }
1017 undef $x; # downgrade to PVMG
1018 $x = __PACKAGE__; # PVMG + COW
1021 print STDERR "ok\n";
1023 # However, one should not be able to tie read-only glob copies, which look
1024 # a bit like kine internally (FAKE + READONLY).
1026 Internals::SvREADONLY($y,1);
1031 Modification of a read-only value attempted at - line 16.
1034 # Similarly, read-only regexps cannot be tied.
1035 sub TIESCALAR { bless [] }
1037 Internals::SvREADONLY($y,1);
1041 Modification of a read-only value attempted at - line 6.
1044 # tied() should still work on tied scalars after glob assignment
1045 sub TIESCALAR {bless[]}
1047 sub f::TIEHANDLE{bless[],f}
1050 [$rin]; # call FETCH
1051 print ref tied $rin, "\n";
1052 print ref tied *$rin, "\n";
1058 # (un)tie $glob_copy vs (un)tie *$glob_copy
1059 sub TIESCALAR { print "TIESCALAR\n"; bless [] }
1060 sub TIEHANDLE{ print "TIEHANDLE\n"; bless [] }
1061 sub FETCH { print "never called\n" }
1066 print "ok 1\n" if !tied $f;
1067 () = $f; # should not call FETCH
1069 print "ok 2\n" if !tied *foo;
1077 # RT #8611 mustn't goto outside the magic stack
1078 sub TIESCALAR { warn "tiescalar\n"; bless [] }
1079 sub FETCH { warn "fetch()\n"; goto FOO; }
1081 warn "before fetch\n";
1083 warn "before FOO\n";
1090 Can't find label FOO at - line 4.
1093 # RT #8611 mustn't goto outside the magic stack
1094 sub TIEHANDLE { warn "tiehandle\n"; bless [] }
1095 sub PRINT { warn "print()\n"; goto FOO; }
1097 warn "before print\n";
1099 warn "before FOO\n";
1106 Can't find label FOO at - line 4.
1109 # \&$tied with $tied holding a reference before the fetch (but not after)
1111 sub TIESCALAR {bless[]}
1122 # \&$tied with $tied holding a PVLV glob before the fetch (but not after)
1124 sub TIEARRAY {bless[]}
1130 print &{\&$$elem}, "\n";
1135 # \&$tied with $tied holding a PVGV glob before the fetch (but not after)
1136 local *72 = sub { 73 };
1137 sub TIESCALAR {bless[]}
1142 print &{\&$x}, "\n";
1147 # Lexicals should not be visible to magic methods on scope exit
1148 BEGIN { unless (defined &DynaLoader::boot_DynaLoader) {
1149 print "HASH\nHASH\nARRAY\nARRAY\n"; exit;
1151 use Scalar::Util 'weaken';
1153 sub TIEHASH { Scalar::Util::weaken($_[1]); bless \$_[1], xoufghd:: }
1154 *TIEARRAY = *TIEHASH;
1156 bless ${$_[0]} || return, 0;
1159 # hashes: ties before backrefs
1163 tie %hash, xoufghd::, \%hash;
1166 # hashes: backrefs before ties
1170 weaken(my $x = \%hash);
1171 tie %hash, xoufghd::, \%hash;
1174 # arrays: ties before backrefs
1178 tie @array, xoufghd::, \@array;
1181 # arrays: backrefs before ties
1185 weaken(my $x = \@array);
1186 tie @array, xoufghd::, \@array;
1201 # Localising a tied variable with a typeglob in it should copy magic
1202 sub TIESCALAR{bless[]}
1203 sub FETCH{warn "fetching\n"; *foo}
1217 # tied returns same value as tie
1218 sub TIESCALAR{bless[]}
1219 $tyre = \tie $tied, "";
1220 print "ok\n" if \tied $tied == $tyre;
1225 # tied arrays should always be AvREAL
1227 sub TIEARRAY{bless[]}
1230 \@_; # used to produce: av_reify called on tied array at - line 7.
1235 # [perl #67490] scalar-tying elements of magic hashes
1236 sub TIESCALAR{bless[]}
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.
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.)
1254 sub TIEHASH { bless {} }
1255 sub FETCH { $_[0]{$_[1]} }
1256 sub STORE { $_[0]{$_[1]} = { %{ $_[2] } } }
1258 tie my %h, copier::;
1260 print $h{i}{j}, "\n";
1265 # [perl #8931] FETCH for tied $" called an odd number of times.
1268 sub A::TIESCALAR {bless [] => 'A'}
1269 sub A::FETCH {print ++ $i, "\n"}
1270 my @a = ("", "", "");
1283 # [perl #9391] return value from 'tied' not discarded soon enough
1290 sub T::TIEARRAY { my $s; bless \$s => "T" }
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.
1298 sub TIEHASH{bless[]}
1307 # NAME EXISTS on arrays
1308 sub TIEARRAY{bless[]};
1309 sub FETCHSIZE { 50 }
1310 sub EXISTS { print "does $_[1] exist?\n" }
1314 $NEGATIVE_INDICES=1;
1322 # Crash when using negative index on array tied to non-object
1323 sub TIEARRAY{bless[]};
1324 ${\tie @a, ""} = undef;
1325 eval { $_ = $a[-1] }; print $@;
1326 eval { $a[-1] = '' }; print $@;
1327 eval { delete $a[-1] }; print $@;
1328 eval { exists $a[-1] }; print $@;
1331 Can't call method "FETCHSIZE" on an undefined value at - line 5.
1332 Can't call method "FETCHSIZE" on an undefined value at - line 6.
1333 Can't call method "FETCHSIZE" on an undefined value at - line 7.
1334 Can't call method "FETCHSIZE" on an undefined value at - line 8.