Back 22969 out of maint. (reinstate the "Tied variable freed while

still in use" error for the moment, as my change causes interesting
bugs under utf8 locales)

p4raw-id: //depot/maint-5.8/perl@23017

3 files changed, 12 insertions, 17 deletions

diff --git a/mg.c b/mg.c
index 71522015b7..3f2b191e00 100644
--- a/mg.c
+++ b/mg.c
@@ -124,21 +124,7 @@ 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
@@ -152,6 +138,10 @@ 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))
@@ -183,8 +173,6 @@ 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 d8e060d1c0..9530e75fa3 100644
--- a/pod/perldiag.pod
+++ b/pod/perldiag.pod
@@ -3699,6 +3699,12 @@ target of the change to
 are deprecated and one should use the new ithreads instead,
 see L<perl58delta> for more details.
 
+=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 bd5d079a60..51c4b3a5b8 100755
--- a/t/op/tie.t
+++ b/t/op/tie.t
@@ -294,6 +294,7 @@ 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