Recover some of the #16845.

p4raw-id: //depot/perl@16858

diff --git a/sv.c b/sv.c
index 8b707f7..18fdfc1 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -4461,7 +4461,13 @@ Perl_sv_magicext(pTHX_ SV* sv, SV* obj, int how, MGVTBL *vtable,
     /* Some magic sontains a reference loop, where the sv and object refer to
        each other.  To prevent a reference loop that would prevent such
        objects being freed, we look for such loops and if we find one we
-       avoid incrementing the object refcount. */
+       avoid incrementing the object refcount.
+
+       Note we cannot do this to avoid self-tie loops as intervening RV must
+       have its REFCNT incremented to keep it in existence - instead we could
+       special case them in sv_free() -- NI-S
+
+    */
     if (!obj || obj == sv ||
        how == PERL_MAGIC_arylen ||
        how == PERL_MAGIC_qr ||

diff --git a/t/op/tie.t b/t/op/tie.t
index f8f2322..914db11 100755 (executable)
--- a/t/op/tie.t
+++ b/t/op/tie.t
@@ -3,7 +3,7 @@
 # This test harness will (eventually) test the "tie" functionality
 # without the need for a *DBM* implementation.
 
-# Currently it only tests the untie warning 
+# Currently it only tests the untie warning
 
 chdir 't' if -d 't';
 @INC = '../lib';
@@ -138,7 +138,7 @@ untie %h;
 EXPECT
 ########
 
-# strict error behaviour, with 2 extra references 
+# strict error behaviour, with 2 extra references
 use warnings 'untie';
 use Tie::Hash ;
 $a = tie %h, Tie::StdHash;
@@ -171,7 +171,7 @@ sub Self::DESTROY { $b = $_[0] + 1; }
     tie %c, 'Self', \%c;
 }
 EXPECT
-Self-ties of arrays and hashes are not supported 
+Self-ties of arrays and hashes are not supported
 ########
 # Allowed scalar self-ties
 my ($a, $b) = (0, 0);
@@ -206,8 +206,38 @@ EXPECT
 # correct unlocalisation of tied hashes (patch #16431)
 use Tie::Hash ;
 tie %tied, Tie::StdHash;
-{ local $hash{'foo'} } print "exist1\n" if exists $hash{'foo'};
-{ local $tied{'foo'} } print "exist2\n" if exists $tied{'foo'};
-{ local $ENV{'foo'}  } print "exist3\n" if exists $ENV{'foo'};
+{ local $hash{'foo'} } warn "plain hash bad unlocalize" if exists $hash{'foo'};
+{ local $tied{'foo'} } warn "tied hash bad unlocalize" if exists $tied{'foo'};
+{ local $ENV{'foo'}  } warn "%ENV bad unlocalize" if exists $ENV{'foo'};
 EXPECT
+########
+# Allowed glob self-ties
+my $destroyed = 0;
+my $printed   = 0;
+sub Self2::TIEHANDLE { bless $_[1], $_[0] }
+sub Self2::DESTROY   { $destroyed = 1; }
+sub Self2::PRINT     { $printed = 1; }
+{
+    use Symbol;
+    my $c = gensym;
+    tie *$c, 'Self2', $c;
+    print $c 'Hello';
+}
+die "self-tied glob not PRINTed" unless $printed == 1;
+die "self-tied glob not DESTROYd" unless $destroyed == 1;
+EXPECT
+########
+
+# Allowed IO self-ties
+my $destroyed = 0;
+sub Self3::TIEHANDLE { bless $_[1], $_[0] }
+sub Self3::DESTROY   { $destroyed = 1; }
+{
+    use Symbol 'geniosym';
+    my $c = geniosym;
+    tie *$c, 'Self3', $c;
+}
+die "self-tied IO not DESTROYd" unless $destroyed == 1;
+EXPECT
+########
 

diff --git a/t/run/fresh_perl.t b/t/run/fresh_perl.t
index 9ed6023..3c0a925 100644 (file)
--- a/t/run/fresh_perl.t
+++ b/t/run/fresh_perl.t
@@ -821,12 +821,6 @@ $人++; # a child is born
 print $人, "\n";
 EXPECT
 3
-########
-# TODO An attempt at lvalueable barewords broke this
-tie FH, 'main';
-EXPECT
-Can't modify constant item in tie at - line 2, near "'main';"
-Execution of - aborted due to compilation errors.
 ######## example from Camel 5, ch. 15, pp.406 (with use vars)
 # SKIP: ord "A" == 193 # EBCDIC
 use strict;