X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=t%2Fop%2Ftie.t;h=8daa8b06f11b7b2bbfac5819ef9994b0fc19905d;hb=ae533554a9c124f574bc4e6f57c895308d938681;hp=6e73ceec85f907bceed32c814d039916d8787633;hpb=b5ccf5f2cdb7415d32c161b40f11284c4f37fb57;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/t/op/tie.t b/t/op/tie.t
old mode 100755
new mode 100644
index 6e73cee..8daa8b0
--- a/t/op/tie.t
+++ b/t/op/tie.t
@@ -286,3 +286,363 @@ EXPECT
 7
 8
 0
+########
+#
+# FETCH freeing tie'd SV
+sub TIESCALAR { bless [] }
+sub FETCH { *a = \1; 1 }
+tie $a, 'main';
+print $a;
+EXPECT
+########
+
+#  [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
+########
+# Test case from perlmonks by runrig
+# http://www.perlmonks.org/index.pl?node_id=273490
+# "Here is what I tried. I think its similar to what you've tried
+#  above. Its odd but convienient that after untie'ing you are left with
+#  a variable that has the same value as was last returned from
+#  FETCH. (At least on my perl v5.6.1). So you don't need to pass a
+#  reference to the variable in order to set it after the untie (here it
+#  is accessed through a closure)."
+use strict;
+use warnings;
+package MyTied;
+sub TIESCALAR {
+    my ($class,$code) = @_;
+    bless $code, $class;
+}
+sub FETCH {
+    my $self = shift;
+    print "Untie\n";
+    $self->();
+}
+package main;
+my $var;
+tie $var, 'MyTied', sub { untie $var; 4 };
+print "One\n";
+print "$var\n";
+print "Two\n";
+print "$var\n";
+print "Three\n";
+print "$var\n";
+EXPECT
+One
+Untie
+4
+Two
+4
+Three
+4
+########
+# [perl #22297] cannot untie scalar from within tied FETCH
+my $counter = 0;
+my $x = 7;
+my $ref = \$x;
+tie $x, 'Overlay', $ref, $x;
+my $y;
+$y = $x;
+$y = $x;
+$y = $x;
+$y = $x;
+#print "WILL EXTERNAL UNTIE $ref\n";
+untie $$ref;
+$y = $x;
+$y = $x;
+$y = $x;
+$y = $x;
+#print "counter = $counter\n";
+
+print (($counter == 1) ? "ok\n" : "not ok\n");
+
+package Overlay;
+
+sub TIESCALAR
+{
+        my $pkg = shift;
+        my ($ref, $val) = @_;
+        return bless [ $ref, $val ], $pkg;
+}
+
+sub FETCH
+{
+        my $self = shift;
+        my ($ref, $val) = @$self;
+        #print "WILL INTERNAL UNITE $ref\n";
+        $counter++;
+        untie $$ref;
+        return $val;
+}
+EXPECT
+ok
+########
+
+# [perl #948] cannot meaningfully tie $,
+package TieDollarComma;
+
+sub TIESCALAR {
+     my $pkg = shift;
+     return bless \my $x, $pkg;
+}
+
+sub STORE {
+    my $self = shift;
+    $$self = shift;
+    print "STORE set '$$self'\n";
+}
+
+sub FETCH {
+    my $self = shift;
+    print "<FETCH>";
+    return $$self;
+}
+package main;
+
+tie $,, 'TieDollarComma';
+$, = 'BOBBINS';
+print "join", "things", "up\n";
+EXPECT
+STORE set 'BOBBINS'
+join<FETCH>BOBBINSthings<FETCH>BOBBINSup
+########
+
+# test SCALAR method
+package TieScalar;
+
+sub TIEHASH {
+    my $pkg = shift;
+    bless { } => $pkg;
+}
+
+sub STORE {
+    $_[0]->{$_[1]} = $_[2];
+}
+
+sub FETCH {
+    $_[0]->{$_[1]}
+}
+
+sub CLEAR {
+    %{ $_[0] } = ();
+}
+
+sub SCALAR {
+    print "SCALAR\n";
+    return 0 if ! keys %{$_[0]};
+    sprintf "%i/%i", scalar keys %{$_[0]}, scalar keys %{$_[0]};
+}
+
+package main;
+tie my %h => "TieScalar";
+$h{key1} = "val1";
+$h{key2} = "val2";
+print scalar %h, "\n"
+    if %h; # this should also call SCALAR but implicitly
+%h = ();
+print scalar %h, "\n"
+    if !%h; # this should also call SCALAR but implicitly
+EXPECT
+SCALAR
+SCALAR
+2/2
+SCALAR
+SCALAR
+0
+########
+
+# test scalar on tied hash when no SCALAR method has been given
+package TieScalar;
+
+sub TIEHASH {
+    my $pkg = shift;
+    bless { } => $pkg;
+}
+sub STORE {
+    $_[0]->{$_[1]} = $_[2];
+}
+sub FETCH {
+    $_[0]->{$_[1]}
+}
+sub CLEAR {
+    %{ $_[0] } = ();
+}
+sub FIRSTKEY {
+    my $a = keys %{ $_[0] };
+    print "FIRSTKEY\n";
+    each %{ $_[0] };
+}
+
+package main;
+tie my %h => "TieScalar";
+
+if (!%h) {
+    print "empty\n";
+} else {
+    print "not empty\n";
+}
+
+$h{key1} = "val1";
+print "not empty\n" if %h;
+print "not empty\n" if %h;
+print "-->\n";
+my ($k,$v) = each %h;
+print "<--\n";
+print "not empty\n" if %h;
+%h = ();
+print "empty\n" if ! %h;
+EXPECT
+FIRSTKEY
+empty
+FIRSTKEY
+not empty
+FIRSTKEY
+not empty
+-->
+FIRSTKEY
+<--
+not empty
+FIRSTKEY
+empty
+########
+sub TIESCALAR { bless {} }
+sub FETCH { my $x = 3.3; 1 if 0+$x; $x }
+tie $h, "main";
+print $h,"\n";
+EXPECT
+3.3
+########
+sub TIESCALAR { bless {} }
+sub FETCH { shift()->{i} ++ }
+tie $h, "main";
+print $h.$h;
+EXPECT
+01
+########
+# Bug 53482 (and maybe others)
+sub TIESCALAR { my $foo = $_[1]; bless \$foo, $_[0] }
+sub FETCH { ${$_[0]} }
+tie my $x1, "main", 2;
+tie my $y1, "main", 8;
+print $x1 | $y1;
+print $x1 | $y1;
+tie my $x2, "main", "2";
+tie my $y2, "main", "8";
+print $x2 | $y2;
+print $x2 | $y2;
+EXPECT
+1010::
+########
+# Bug 36267
+sub TIEHASH  { bless {}, $_[0] }
+sub STORE    { $_[0]->{$_[1]} = $_[2] }
+sub FIRSTKEY { my $a = scalar keys %{$_[0]}; each %{$_[0]} }
+sub NEXTKEY  { each %{$_[0]} }
+sub DELETE   { delete $_[0]->{$_[1]} }
+sub CLEAR    { %{$_[0]} = () }
+$h{b}=1;
+delete $h{b};
+print scalar keys %h, "\n";
+tie %h, 'main';
+$i{a}=1;
+%h = %i;
+untie %h;
+print scalar keys %h, "\n";
+EXPECT
+0
+0
+########
+# Bug 37731
+sub foo::TIESCALAR { bless {value => $_[1]}, $_[0] }
+sub foo::FETCH { $_[0]->{value} }
+tie my $VAR, 'foo', '42';
+foreach my $var ($VAR) {
+    print +($var eq $VAR) ? "yes\n" : "no\n";
+}
+EXPECT
+yes
+########
+sub TIEARRAY { bless [], 'main' }
+{
+    local @a;
+    tie @a, 'main';
+}
+print "tied\n" if tied @a;
+EXPECT
+########
+sub TIEHASH { bless [], 'main' }
+{
+    local %h;
+    tie %h, 'main';
+}
+print "tied\n" if tied %h;
+EXPECT