Abolish the "Tied variable freed while still in use" error - I have

a way to cleanly avoid the coredump.

p4raw-id: //depot/perl@22969

3 files changed, 17 insertions, 12 deletions

diff --git a/mg.c b/mg.c
index d162cd31ff..48213dc789 100644
--- a/mg.c
+++ b/mg.c
@@ -129,7 +129,21 @@ Perl_mg_get(pTHX_ SV *sv)
     int new = 0;
     MAGIC *newmg, *head, *cur, *mg;
     I32 mgs_ix = SSNEW(sizeof(MGS));
-
+    /* guard against sv having being freed midway by holding a private
+       reference. It's not possible to make this sv mortal without failing
+       several tests -
+       looks like it's important that it can get DESTROYed before the next
+       FREETMPS
+       Also it's not possible to wrap this function in a SAVETMPS/FREETMPS
+       pair. We need drop our reference if croak() is called, but we also
+       can't simply make it mortal and wait for the next FREETMPS, because
+       other tests rely on the sv being freed earlier. Hence this hack.
+       We create an extra reference on the caller's sv, owned by the rv,
+       which is mortal. If croak is called the RV cleans up for us.
+       If we reach the end of the function we change it to point at
+       PL_sv_undef, and clean up manually.  */
+    SV *temp_rv = sv_2mortal(newRV_inc(sv));
+       
     save_magic(mgs_ix, sv);
 
     /* We must call svt_get(sv, mg) for each valid entry in the linked
@@ -143,10 +157,6 @@ Perl_mg_get(pTHX_ SV *sv)
 	if (!(mg->mg_flags & MGf_GSKIP) && vtbl && vtbl->svt_get) {
 	    CALL_FPTR(vtbl->svt_get)(aTHX_ sv, mg);
 
-	    /* guard against sv having been freed */
-	    if (SvTYPE(sv) == SVTYPEMASK) {
-		Perl_croak(aTHX_ "Tied variable freed while still in use");
-	    }
 	    /* guard against magic having been deleted - eg FETCH calling
 	     * untie */
 	    if (!SvMAGIC(sv))
@@ -178,6 +188,8 @@ Perl_mg_get(pTHX_ SV *sv)
     }
 
     restore_magic(aTHX_ INT2PTR(void *, (IV)mgs_ix));
+    SvRV(temp_rv) = &PL_sv_undef;
+    SvREFCNT_dec(sv);
     return 0;
 }
 
diff --git a/pod/perldiag.pod b/pod/perldiag.pod
index 67ef45a8d2..747dc054f9 100644
--- a/pod/perldiag.pod
+++ b/pod/perldiag.pod
@@ -3736,12 +3736,6 @@ target of the change to
 
 (F) The entry point function of threads->create() failed for some reason.
 
-=item Tied variable freed while still in use
-
-(F) An access method for a tied variable (e.g. FETCH) did something to
-free the variable.  Since continuing the current operation is likely
-to result in a coredump, Perl is bailing out instead.
-
 =item times not implemented
 
 (F) Your version of the C library apparently doesn't do times().  I
diff --git a/t/op/tie.t b/t/op/tie.t
index bd1e980bc0..2ea128512c 100755
--- a/t/op/tie.t
+++ b/t/op/tie.t
@@ -294,7 +294,6 @@ 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