Re: [perl #18038] DESTROY change in 5.8.0?

Message-ID: <CXbx9gzkgS8W092yn@efn.org>

p4raw-id: //depot/perl@18121

diff --git a/sv.c b/sv.c
index 48efa2e..a674986 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -26,7 +26,7 @@
 #ifdef PERL_COPY_ON_WRITE
 #define SV_COW_NEXT_SV(sv)     INT2PTR(SV *,SvUVX(sv))
 #define SV_COW_NEXT_SV_SET(current,next)       SvUVX(current) = PTR2UV(next)
-/* This is a pessamistic view. Scalar must be purely a read-write PV to copy-
+/* This is a pessimistic view. Scalar must be purely a read-write PV to copy-
    on-write.  */
 #define CAN_COW_MASK   (SVs_OBJECT|SVs_GMG|SVs_SMG|SVs_RMG|SVf_IOK|SVf_NOK| \
                         SVf_POK|SVf_ROK|SVp_IOK|SVp_NOK|SVp_POK|SVf_FAKE| \
@@ -4631,8 +4631,7 @@ Perl_sv_magicext(pTHX_ SV* sv, SV* obj, int how, MGVTBL *vtable,
        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
+       have its REFCNT incremented to keep it in existence.
 
     */
     if (!obj || obj == sv ||
@@ -4649,6 +4648,21 @@ Perl_sv_magicext(pTHX_ SV* sv, SV* obj, int how, MGVTBL *vtable,
        mg->mg_obj = SvREFCNT_inc(obj);
        mg->mg_flags |= MGf_REFCOUNTED;
     }
+
+    /* Normal self-ties simply pass a null object, and instead of
+       using mg_obj directly, use the SvTIED_obj macro to produce a
+       new RV as needed.  For glob "self-ties", we are tieing the PVIO
+       with an RV obj pointing to the glob containing the PVIO.  In
+       this case, to avoid a reference loop, we need to weaken the
+       reference.
+    */
+
+    if (how == PERL_MAGIC_tiedscalar && SvTYPE(sv) == SVt_PVIO &&
+        obj && SvROK(obj) && GvIO(SvRV(obj)) == (IO*)sv)
+    {
+      sv_rvweaken(obj);
+    }
+
     mg->mg_type = how;
     mg->mg_len = namlen;
     if (name) {

diff --git a/t/op/tie.t b/t/op/tie.t
index d3bd452..6e73cee 100755 (executable)
--- a/t/op/tie.t
+++ b/t/op/tie.t
@@ -183,7 +183,7 @@ die "self-tied scalar not DESTROYed" unless $destroyed == 1;
 EXPECT
 ########
 
-# TODO Allowed glob self-ties
+# Allowed glob self-ties
 my $destroyed = 0;
 my $printed   = 0;
 sub Self2::TIEHANDLE { bless $_[1], $_[0] }
@@ -204,15 +204,34 @@ EXPECT
 my $destroyed = 0;
 sub Self3::TIEHANDLE { bless $_[1], $_[0] }
 sub Self3::DESTROY   { $destroyed = 1; }
+sub Self3::PRINT     { $printed = 1; }
 {
     use Symbol 'geniosym';
     my $c = geniosym;
     tie *$c, 'Self3', $c;
+    print $c 'Hello';
 }
+die "self-tied IO not PRINTed" unless $printed == 1;
 die "self-tied IO not DESTROYed" unless $destroyed == 1;
 EXPECT
 ########
 
+# TODO IO "self-tie" via TEMP glob
+my $destroyed = 0;
+sub Self3::TIEHANDLE { bless $_[1], $_[0] }
+sub Self3::DESTROY   { $destroyed = 1; }
+sub Self3::PRINT     { $printed = 1; }
+{
+    use Symbol 'geniosym';
+    my $c = geniosym;
+    tie *$c, 'Self3', \*$c;
+    print $c 'Hello';
+}
+die "IO tied to TEMP glob not PRINTed" unless $printed == 1;
+die "IO tied to TEMP glob not DESTROYed" unless $destroyed == 1;
+EXPECT
+########
+
 # Interaction of tie and vec
 
 my ($a, $b);