Re: [perl #23463]: compiler version on sparc/netbsd

[p5sagit/p5-mst-13.2.git] / t / op / tie.t

diff --git a/t/op/tie.t b/t/op/tie.t
index 6e73cee..d73cce1 100755 (executable)
--- a/t/op/tie.t
+++ b/t/op/tie.t
@@ -286,3 +286,84 @@ EXPECT
 7
 8
 0
+########
+#
+# FETCH freeing tie'd SV
+sub TIESCALAR { bless [] }
+sub FETCH { *a = \1; 1 }
+tie $a, 'main';
+print $a;
+EXPECT
+Tied variable freed while still in use at - line 6.
+########
+
+#  [20020716.007] - nested FETCHES
+
+sub F1::TIEARRAY { bless [], 'F1' }
+sub F1::FETCH { 1 }
+my @f1;
+tie @f1, 'F1';
+
+sub F2::TIEARRAY { bless [2], 'F2' }
+sub F2::FETCH { my $self = shift; my $x = $f1[3]; $self }
+my @f2;
+tie @f2, 'F2';
+
+print $f2[4][0],"\n";
+
+sub F3::TIEHASH { bless [], 'F3' }
+sub F3::FETCH { 1 }
+my %f3;
+tie %f3, 'F3';
+
+sub F4::TIEHASH { bless [3], 'F4' }
+sub F4::FETCH { my $self = shift; my $x = $f3{3}; $self }
+my %f4;
+tie %f4, 'F4';
+
+print $f4{'foo'}[0],"\n";
+
+EXPECT
+2
+3
+########
+# test untie() from within FETCH
+package Foo;
+sub TIESCALAR { my $pkg = shift; return bless [@_], $pkg; }
+sub FETCH {
+  my $self = shift;
+  my ($obj, $field) = @$self;
+  untie $obj->{$field};
+  $obj->{$field} = "Bar";
+}
+package main;
+tie $a->{foo}, "Foo", $a, "foo";
+$a->{foo}; # access once
+# the hash element should not be tied anymore
+print defined tied $a->{foo} ? "not ok" : "ok";
+EXPECT
+ok
+########
+# the tmps returned by FETCH should appear to be SCALAR
+# (even though they are now implemented using PVLVs.)
+package X;
+sub TIEHASH { bless {} }
+sub TIEARRAY { bless {} }
+sub FETCH {1}
+my (%h, @a);
+tie %h, 'X';
+tie @a, 'X';
+my $r1 = \$h{1};
+my $r2 = \$a[0];
+my $s = "$r1 ". ref($r1) . " $r2 " . ref($r2);
+$s=~ s/\(0x\w+\)//g;
+print $s, "\n";
+EXPECT
+SCALAR SCALAR SCALAR SCALAR
+########
+# [perl #23287] segfault in untie
+sub TIESCALAR { bless $_[1], $_[0] }
+my $var;
+tie $var, 'main', \$var;
+untie $var;
+EXPECT