Upgrade to Cwd 2.17_03

[p5sagit/p5-mst-13.2.git] / mg.c

diff --git a/mg.c b/mg.c
index 7955e52..48213dc 100644 (file)
--- a/mg.c
+++ b/mg.c
@@ -1,7 +1,7 @@
 /*    mg.c
  *
  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
- *    2000, 2001, 2002, 2003, by Larry Wall and others
+ *    2000, 2001, 2002, 2003, 2004, by Larry Wall and others
  *
  *    You may distribute under the terms of either the GNU General Public
  *    License or the Artistic License, as specified in the README file.
@@ -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;
 }
 
@@ -384,7 +396,7 @@ Perl_mg_free(pTHX_ SV *sv)
        if (vtbl && vtbl->svt_free)
            CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
        if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
-           if (mg->mg_len > 0)
+           if (mg->mg_len > 0 || mg->mg_type == PERL_MAGIC_utf8)
                Safefree(mg->mg_ptr);
            else if (mg->mg_len == HEf_SVKEY)
                SvREFCNT_dec((SV*)mg->mg_ptr);
@@ -397,10 +409,7 @@ Perl_mg_free(pTHX_ SV *sv)
     return 0;
 }
 
-
-#if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX)
 #include <signal.h>
-#endif
 
 U32
 Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg)
@@ -494,12 +503,12 @@ Perl_magic_len(pTHX_ SV *sv, MAGIC *mg)
            }
            else {
                if (ckWARN(WARN_UNINITIALIZED))
-                   report_uninit();
+                   report_uninit(sv);
            }
        }
        else {
            if (ckWARN(WARN_UNINITIALIZED))
-               report_uninit();
+               report_uninit(sv);
        }
        return 0;
     case '+':
@@ -569,9 +578,6 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
 
     case '\004':               /* ^D */
        sv_setiv(sv, (IV)(PL_debug & DEBUG_MASK));
-#if defined(YYDEBUG) && defined(DEBUGGING)
-       PL_yydebug = DEBUG_p_TEST;
-#endif
        break;
     case '\005':  /* ^E */
         if (*(mg->mg_ptr+1) == '\0') {
@@ -651,8 +657,10 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
            sv_setsv(sv, &PL_sv_undef);
        break;
     case '\017':               /* ^O & ^OPEN */
-       if (*(mg->mg_ptr+1) == '\0')
+       if (*(mg->mg_ptr+1) == '\0') {
            sv_setpv(sv, PL_osname);
+           SvTAINTED_off(sv);
+       }
        else if (strEQ(mg->mg_ptr, "\017PEN")) {
            if (!PL_compiling.cop_io)
                sv_setsv(sv, &PL_sv_undef);
@@ -1784,16 +1792,21 @@ Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
        sv_utf8_upgrade(lsv);
        sv_pos_u2b(lsv, &lvoff, &lvlen);
        sv_insert(lsv, lvoff, lvlen, tmps, len);
+       LvTARGLEN(sv) = sv_len_utf8(sv);
        SvUTF8_on(lsv);
     }
     else if (lsv && SvUTF8(lsv)) {
        sv_pos_u2b(lsv, &lvoff, &lvlen);
+       LvTARGLEN(sv) = len;
        tmps = (char*)bytes_to_utf8((U8*)tmps, &len);
        sv_insert(lsv, lvoff, lvlen, tmps, len);
        Safefree(tmps);
     }
-    else
-        sv_insert(lsv, lvoff, lvlen, tmps, len);
+    else {
+       sv_insert(lsv, lvoff, lvlen, tmps, len);
+       LvTARGLEN(sv) = len;
+    }
+
 
     return 0;
 }
@@ -1930,14 +1943,14 @@ Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
     SV **svp = AvARRAY(av);
     I32 i = AvFILLp(av);
     while (i >= 0) {
-       if (svp[i] && svp[i] != &PL_sv_undef) {
+       if (svp[i]) {
            if (!SvWEAKREF(svp[i]))
                Perl_croak(aTHX_ "panic: magic_killbackrefs");
            /* XXX Should we check that it hasn't changed? */
            SvRV(svp[i]) = 0;
            (void)SvOK_off(svp[i]);
            SvWEAKREF_off(svp[i]);
-           svp[i] = &PL_sv_undef;
+           svp[i] = Nullsv;
        }
        i--;
     }
@@ -2092,12 +2105,14 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
        break;
     case '\017':       /* ^O */
        if (*(mg->mg_ptr+1) == '\0') {
-           if (PL_osname)
+           if (PL_osname) {
                Safefree(PL_osname);
-           if (SvOK(sv))
-               PL_osname = savepv(SvPV(sv,len));
-           else
                PL_osname = Nullch;
+           }
+           if (SvOK(sv)) {
+               TAINT_PROPER("assigning to $^O");
+               PL_osname = savepv(SvPV(sv,len));
+           }
        }
        else if (strEQ(mg->mg_ptr, "\017PEN")) {
            if (!PL_compiling.cop_io)