Suppress deprecation warnings from test output for perl4 era libs.

[perl5.git] / sv.c

diff --git a/sv.c b/sv.c
index 380f442..9a4a082 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -3520,7 +3520,7 @@ Perl_sv_utf8_encode(pTHX_ register SV *const sv)
         sv_force_normal_flags(sv, 0);
     }
     if (SvREADONLY(sv)) {
-       Perl_croak(aTHX_ "%s", PL_no_modify);
+       Perl_croak_no_modify(aTHX);
     }
     (void) sv_utf8_upgrade(sv);
     SvUTF8_off(sv);
@@ -4593,7 +4593,7 @@ Perl_sv_force_normal_flags(pTHX_ register SV *const sv, const U32 flags)
             }
        }
        else if (IN_PERL_RUNTIME)
-           Perl_croak(aTHX_ "%s", PL_no_modify);
+           Perl_croak_no_modify(aTHX);
     }
 #else
     if (SvREADONLY(sv)) {
@@ -4610,7 +4610,7 @@ Perl_sv_force_normal_flags(pTHX_ register SV *const sv, const U32 flags)
            unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
        }
        else if (IN_PERL_RUNTIME)
-           Perl_croak(aTHX_ "%s", PL_no_modify);
+           Perl_croak_no_modify(aTHX);
     }
 #endif
     if (SvROK(sv))
@@ -5063,7 +5063,7 @@ Perl_sv_magic(pTHX_ register SV *const sv, SV *const obj, const int how,
            && how != PERL_MAGIC_backref
           )
        {
-           Perl_croak(aTHX_ "%s", PL_no_modify);
+           Perl_croak_no_modify(aTHX);
        }
     }
     if (SvMAGICAL(sv) || (how == PERL_MAGIC_taint && SvTYPE(sv) >= SVt_PVMG)) {
@@ -7353,7 +7353,7 @@ Perl_sv_inc_nomg(pTHX_ register SV *const sv)
            sv_force_normal_flags(sv, 0);
        if (SvREADONLY(sv)) {
            if (IN_PERL_RUNTIME)
-               Perl_croak(aTHX_ "%s", PL_no_modify);
+               Perl_croak_no_modify(aTHX);
        }
        if (SvROK(sv)) {
            IV i;
@@ -7534,7 +7534,7 @@ Perl_sv_dec_nomg(pTHX_ register SV *const sv)
            sv_force_normal_flags(sv, 0);
        if (SvREADONLY(sv)) {
            if (IN_PERL_RUNTIME)
-               Perl_croak(aTHX_ "%s", PL_no_modify);
+               Perl_croak_no_modify(aTHX);
        }
        if (SvROK(sv)) {
            IV i;
@@ -8841,7 +8841,7 @@ Perl_sv_bless(pTHX_ SV *const sv, HV *const stash)
        if (SvIsCOW(tmpRef))
            sv_force_normal_flags(tmpRef, 0);
        if (SvREADONLY(tmpRef))
-           Perl_croak(aTHX_ "%s", PL_no_modify);
+           Perl_croak_no_modify(aTHX);
        if (SvOBJECT(tmpRef)) {
            if (SvTYPE(tmpRef) != SVt_PVIO)
                --PL_sv_objcount;
@@ -10875,20 +10875,22 @@ Perl_ptr_table_split(pTHX_ PTR_TBL_t *const tbl)
     tbl->tbl_max = --newsize;
     tbl->tbl_ary = ary;
     for (i=0; i < oldsize; i++, ary++) {
-       PTR_TBL_ENT_t **curentp, **entp, *ent;
-       if (!*ary)
+       PTR_TBL_ENT_t **entp = ary;
+       PTR_TBL_ENT_t *ent = *ary;
+       PTR_TBL_ENT_t **curentp;
+       if (!ent)
            continue;
        curentp = ary + oldsize;
-       for (entp = ary, ent = *ary; ent; ent = *entp) {
+       do {
            if ((newsize & PTR_TABLE_HASH(ent->oldval)) != i) {
                *entp = ent->next;
                ent->next = *curentp;
                *curentp = ent;
-               continue;
            }
            else
                entp = &ent->next;
-       }
+           ent = *entp;
+       } while (ent);
     }
 }
 
@@ -11326,7 +11328,7 @@ S_sv_dup_common(pTHX_ const SV *const sstr, CLONE_PARAMS *const param)
                 * duped GV may never be freed. A bit of a hack! DAPM */
                CvGV(dstr)      = (param->flags & CLONEf_JOIN_IN) ?
                    NULL : gv_dup(CvGV(dstr), param) ;
-               PAD_DUP(CvPADLIST(dstr), CvPADLIST(sstr), param);
+               CvPADLIST(dstr) = padlist_dup(CvPADLIST(sstr), param);
                CvOUTSIDE(dstr) =
                    CvWEAKOUTSIDE(sstr)
                    ? cv_dup(    CvOUTSIDE(dstr), param)
@@ -11357,10 +11359,23 @@ Perl_sv_dup(pTHX_ const SV *const sstr, CLONE_PARAMS *const param)
     SV *dstr = sstr ? sv_dup_common(sstr, param) : NULL;
     PERL_ARGS_ASSERT_SV_DUP;
 
-    /* Track every SV that (at least initially) had a reference count of 0.  */
+    /* Track every SV that (at least initially) had a reference count of 0.
+       We need to do this by holding an actual reference to it in this array.
+       If we attempt to cheat, turn AvREAL_off(), and store only pointers
+       (akin to the stashes hash, and the perl stack), we come unstuck if
+       a weak reference (or other SV legitimately SvREFCNT() == 0 for this
+       thread) is manipulated in a CLONE method, because CLONE runs before the
+       unreferenced array is walked to find SVs still with SvREFCNT() == 0
+       (and fix things up by giving each a reference via the temps stack).
+       Instead, during CLONE, if the 0-referenced SV has SvREFCNT_inc() and
+       then SvREFCNT_dec(), it will be cleaned up (and added to the free list)
+       before the walk of unreferenced happens and a reference to that is SV
+       added to the temps stack. At which point we have the same SV considered
+       to be in use, and free to be re-used. Not good.
+    */
     if (dstr && !(param->flags & CLONEf_COPY_STACKS) && !SvREFCNT(dstr)) {
        assert(param->unreferenced);
-       av_push(param->unreferenced, dstr);
+       av_push(param->unreferenced, SvREFCNT_inc(dstr));
     }
 
     return dstr;
@@ -12130,7 +12145,6 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
 
     if (!(flags & CLONEf_COPY_STACKS)) {
        param->unreferenced = newAV();
-       AvREAL_off(param->unreferenced);
     }
 
     /* Set tainting stuff before PerlIO_debug can possibly get called */
@@ -12439,6 +12453,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
     PL_unlockhook      = proto_perl->Iunlockhook;
     PL_threadhook      = proto_perl->Ithreadhook;
     PL_destroyhook     = proto_perl->Idestroyhook;
+    PL_signalhook      = proto_perl->Isignalhook;
 
 #ifdef THREADS_HAVE_PIDS
     PL_ppid            = proto_perl->Ippid;
@@ -12659,7 +12674,7 @@ S_unreferenced_to_tmp_stack(pTHX_ AV *const unreferenced)
        SSize_t count = 0;
 
        do {
-           if (!SvREFCNT(*svp))
+           if (SvREFCNT(*svp) == 1)
                ++count;
        } while (++svp <= last);
 
@@ -12667,9 +12682,27 @@ S_unreferenced_to_tmp_stack(pTHX_ AV *const unreferenced)
        svp = AvARRAY(unreferenced);
 
        do {
-           if (!SvREFCNT(*svp))
-               PL_tmps_stack[++PL_tmps_ix] = SvREFCNT_inc_simple_NN(*svp);
+           if (SvREFCNT(*svp) == 1) {
+               /* Our reference is the only one to this SV. This means that
+                  in this thread, the scalar effectively has a 0 reference.
+                  That doesn't work (cleanup never happens), so donate our
+                  reference to it onto the save stack. */
+               PL_tmps_stack[++PL_tmps_ix] = *svp;
+           } else {
+               /* As an optimisation, because we are already walking the
+                  entire array, instead of above doing either
+                  SvREFCNT_inc(*svp) or *svp = &PL_sv_undef, we can instead
+                  release our reference to the scalar, so that at the end of
+                  the array owns zero references to the scalars it happens to
+                  point to. We are effectively converting the array from
+                  AvREAL() on to AvREAL() off. This saves the av_clear()
+                  (triggered by the SvREFCNT_dec(unreferenced) below) from
+                  walking the array a second time.  */
+               SvREFCNT_dec(*svp);
+           }
+
        } while (++svp <= last);
+       AvREAL_off(unreferenced);
     }
     SvREFCNT_dec(unreferenced);
 }
@@ -12723,7 +12756,6 @@ Perl_clone_params_new(PerlInterpreter *const from, PerlInterpreter *const to)
     param->stashes = (AV *)Perl_newSV_type(to, SVt_PVAV);
     AvREAL_off(param->stashes);
     param->unreferenced = (AV *)Perl_newSV_type(to, SVt_PVAV);
-    AvREAL_off(param->unreferenced);
 
     if (was != to) {
        PERL_SET_THX(was);