For SAVEHINTS(), re-order the savestack to be (?:PTR, )? INT, PTR.

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

diff --git a/sv.c b/sv.c
index 522668e..2a4c581 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -6,7 +6,16 @@
  *    You may distribute under the terms of either the GNU General Public
  *    License or the Artistic License, as specified in the README file.
  *
- * "I wonder what the Entish is for 'yes' and 'no'," he thought.
+ */
+
+/*
+ * 'I wonder what the Entish is for "yes" and "no",' he thought.
+ *                                                      --Pippin
+ *
+ *     [p.480 of _The Lord of the Rings_, III/iv: "Treebeard"]
+ */
+
+/*
  *
  *
  * This file contains the code that creates, manipulates and destroys
@@ -371,8 +380,8 @@ and split it into a list of free SVs.
 =cut
 */
 
-void
-Perl_sv_add_arena(pTHX_ char *const ptr, const U32 size, const U32 flags)
+static void
+S_sv_add_arena(pTHX_ char *const ptr, const U32 size, const U32 flags)
 {
     dVAR;
     SV *const sva = MUTABLE_SV(ptr);
@@ -2831,13 +2840,13 @@ Perl_sv_2pv_flags(pTHX_ register SV *const sv, STRLEN *const lp, const I32 flags
                STRLEN len;
                char *retval;
                char *buffer;
-               const SV *const referent = SvRV(sv);
+               SV *const referent = SvRV(sv);
 
                if (!referent) {
                    len = 7;
                    retval = buffer = savepvn("NULLREF", len);
                } else if (SvTYPE(referent) == SVt_REGEXP) {
-                   const REGEXP * const re = (REGEXP *)referent;
+                   REGEXP * const re = (REGEXP *)MUTABLE_PTR(referent);
                    I32 seen_evals = 0;
 
                    assert(re);
@@ -3291,7 +3300,7 @@ Perl_sv_utf8_encode(pTHX_ register SV *const sv)
         sv_force_normal_flags(sv, 0);
     }
     if (SvREADONLY(sv)) {
-       Perl_croak(aTHX_ PL_no_modify);
+       Perl_croak(aTHX_ "%s", PL_no_modify);
     }
     (void) sv_utf8_upgrade(sv);
     SvUTF8_off(sv);
@@ -3409,7 +3418,7 @@ S_glob_assign_glob(pTHX_ SV *const dstr, SV *const sstr, const int dtype)
 
 #ifdef GV_UNIQUE_CHECK
     if (GvUNIQUE((const GV *)dstr)) {
-       Perl_croak(aTHX_ PL_no_modify);
+       Perl_croak(aTHX_ "%s", PL_no_modify);
     }
 #endif
 
@@ -3468,7 +3477,7 @@ S_glob_assign_ref(pTHX_ SV *const dstr, SV *const sstr)
 
 #ifdef GV_UNIQUE_CHECK
     if (GvUNIQUE((const GV *)dstr)) {
-       Perl_croak(aTHX_ PL_no_modify);
+       Perl_croak(aTHX_ "%s", PL_no_modify);
     }
 #endif
 
@@ -4375,7 +4384,7 @@ Perl_sv_force_normal_flags(pTHX_ register SV *const sv, const U32 flags)
             }
        }
        else if (IN_PERL_RUNTIME)
-           Perl_croak(aTHX_ PL_no_modify);
+           Perl_croak(aTHX_ "%s", PL_no_modify);
         /* At this point I believe that I can drop the global SV mutex.  */
     }
 #else
@@ -4393,7 +4402,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_ PL_no_modify);
+           Perl_croak(aTHX_ "%s", PL_no_modify);
     }
 #endif
     if (SvROK(sv))
@@ -4806,7 +4815,7 @@ Perl_sv_magic(pTHX_ register SV *const sv, SV *const obj, const int how,
            && how != PERL_MAGIC_backref
           )
        {
-           Perl_croak(aTHX_ PL_no_modify);
+           Perl_croak(aTHX_ "%s", PL_no_modify);
        }
     }
     if (SvMAGICAL(sv) || (how == PERL_MAGIC_taint && SvTYPE(sv) >= SVt_PVMG)) {
@@ -7024,7 +7033,7 @@ Perl_sv_inc(pTHX_ register SV *const sv)
            sv_force_normal_flags(sv, 0);
        if (SvREADONLY(sv)) {
            if (IN_PERL_RUNTIME)
-               Perl_croak(aTHX_ PL_no_modify);
+               Perl_croak(aTHX_ "%s", PL_no_modify);
        }
        if (SvROK(sv)) {
            IV i;
@@ -7187,7 +7196,7 @@ Perl_sv_dec(pTHX_ register SV *const sv)
            sv_force_normal_flags(sv, 0);
        if (SvREADONLY(sv)) {
            if (IN_PERL_RUNTIME)
-               Perl_croak(aTHX_ PL_no_modify);
+               Perl_croak(aTHX_ "%s", PL_no_modify);
        }
        if (SvROK(sv)) {
            IV i;
@@ -8473,7 +8482,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_ PL_no_modify);
+           Perl_croak(aTHX_ "%s", PL_no_modify);
        if (SvOBJECT(tmpRef)) {
            if (SvTYPE(tmpRef) != SVt_PVIO)
                --PL_sv_objcount;
@@ -9113,6 +9122,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen,
        STRLEN esignlen = 0;
 
        const char *eptr = NULL;
+       const char *fmtstart;
        STRLEN elen = 0;
        SV *vecsv = NULL;
        const U8 *vecstr = NULL;
@@ -9153,6 +9163,8 @@ Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen,
        if (q++ >= patend)
            break;
 
+       fmtstart = q;
+
 /*
     We allow format specification elements in this order:
        \d+\$              explicit format parameter index
@@ -9548,8 +9560,11 @@ Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen,
                case 'l':       iv = va_arg(*args, long); break;
                case 'V':       iv = va_arg(*args, IV); break;
                default:        iv = va_arg(*args, int); break;
+               case 'q':
 #ifdef HAS_QUAD
-               case 'q':       iv = va_arg(*args, Quad_t); break;
+                               iv = va_arg(*args, Quad_t); break;
+#else
+                               goto unknown;
 #endif
                }
            }
@@ -9560,8 +9575,11 @@ Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen,
                case 'l':       iv = (long)tiv; break;
                case 'V':
                default:        iv = tiv; break;
+               case 'q':
 #ifdef HAS_QUAD
-               case 'q':       iv = (Quad_t)tiv; break;
+                               iv = (Quad_t)tiv; break;
+#else
+                               goto unknown;
 #endif
                }
            }
@@ -9633,8 +9651,11 @@ Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen,
                case 'l':  uv = va_arg(*args, unsigned long); break;
                case 'V':  uv = va_arg(*args, UV); break;
                default:   uv = va_arg(*args, unsigned); break;
+               case 'q':
 #ifdef HAS_QUAD
-               case 'q':  uv = va_arg(*args, Uquad_t); break;
+                          uv = va_arg(*args, Uquad_t); break;
+#else
+                          goto unknown;
 #endif
                }
            }
@@ -9645,8 +9666,11 @@ Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen,
                case 'l':       uv = (unsigned long)tuv; break;
                case 'V':
                default:        uv = tuv; break;
+               case 'q':
 #ifdef HAS_QUAD
-               case 'q':       uv = (Uquad_t)tuv; break;
+                               uv = (Uquad_t)tuv; break;
+#else
+                               goto unknown;
 #endif
                }
            }
@@ -9932,8 +9956,11 @@ Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen,
                default:        *(va_arg(*args, int*)) = i; break;
                case 'l':       *(va_arg(*args, long*)) = i; break;
                case 'V':       *(va_arg(*args, IV*)) = i; break;
+               case 'q':
 #ifdef HAS_QUAD
-               case 'q':       *(va_arg(*args, Quad_t*)) = i; break;
+                               *(va_arg(*args, Quad_t*)) = i; break;
+#else
+                               goto unknown;
 #endif
                }
            }
@@ -9952,16 +9979,22 @@ Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen,
                SV * const msg = sv_newmortal();
                Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %sprintf: ",
                          (PL_op->op_type == OP_PRTF) ? "" : "s");
-               if (c) {
-                   if (isPRINT(c))
-                       Perl_sv_catpvf(aTHX_ msg,
-                                      "\"%%%c\"", c & 0xFF);
-                   else
-                       Perl_sv_catpvf(aTHX_ msg,
-                                      "\"%%\\%03"UVof"\"",
-                                      (UV)c & 0xFF);
-               } else
+               if (fmtstart < patend) {
+                   const char * const fmtend = q < patend ? q : patend;
+                   const char * f;
+                   sv_catpvs(msg, "\"%");
+                   for (f = fmtstart; f < fmtend; f++) {
+                       if (isPRINT(*f)) {
+                           sv_catpvn(msg, f, 1);
+                       } else {
+                           Perl_sv_catpvf(aTHX_ msg,
+                                          "\\%03"UVof, (UV)*f & 0xFF);
+                       }
+                   }
+                   sv_catpvs(msg, "\"");
+               } else {
                    sv_catpvs(msg, "end of string");
+               }
                Perl_warner(aTHX_ packWARN(WARN_PRINTF), "%"SVf, SVfARG(msg)); /* yes, this is reentrant */
            }
 
@@ -10003,13 +10036,13 @@ Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen,
 
        have = esignlen + zeros + elen;
        if (have < zeros)
-           Perl_croak_nocontext(PL_memory_wrap);
+           Perl_croak_nocontext("%s", PL_memory_wrap);
 
        need = (have > width ? have : width);
        gap = need - have;
 
        if (need >= (((STRLEN)~0) - SvCUR(sv) - dotstrlen - 1))
-           Perl_croak_nocontext(PL_memory_wrap);
+           Perl_croak_nocontext("%s", PL_memory_wrap);
        SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
        p = SvEND(sv);
        if (esignlen && fill == '0') {
@@ -10529,8 +10562,8 @@ Perl_rvpv_dup(pTHX_ SV *const dstr, const SV *const sstr, CLONE_PARAMS *const pa
 
     if (SvROK(sstr)) {
        SvRV_set(dstr, SvWEAKREF(sstr)
-                      ? sv_dup(SvRV(sstr), param)
-                      : sv_dup_inc(SvRV(sstr), param));
+                      ? sv_dup(SvRV_const(sstr), param)
+                      : sv_dup_inc(SvRV_const(sstr), param));
 
     }
     else if (SvPVX_const(sstr)) {
@@ -10558,7 +10591,7 @@ Perl_rvpv_dup(pTHX_ SV *const dstr, const SV *const sstr, CLONE_PARAMS *const pa
            }
            else {
                /* Some other special case - random pointer */
-               SvPV_set(dstr, SvPVX(sstr));            
+               SvPV_set(dstr, (char *) SvPVX_const(sstr));             
            }
        }
     }
@@ -11270,8 +11303,6 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param)
            TOPPTR(nss,ix) = ptr;
            break;
        case SAVEt_HINTS:
-           i = POPINT(ss,ix);
-           TOPINT(nss,ix) = i;
            ptr = POPPTR(ss,ix);
            if (ptr) {
                HINTS_REFCNT_LOCK;
@@ -11279,6 +11310,8 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param)
                HINTS_REFCNT_UNLOCK;
            }
            TOPPTR(nss,ix) = ptr;
+           i = POPINT(ss,ix);
+           TOPINT(nss,ix) = i;
            if (i & HINT_LOCALIZE_HH) {
                hv = (const HV *)POPPTR(ss,ix);
                TOPPTR(nss,ix) = hv_dup_inc(hv, param);
@@ -11728,6 +11761,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
     PL_regex_pad = AvARRAY(PL_regex_padav);
 
     /* shortcuts to various I/O objects */
+    PL_ofsgv            = gv_dup(proto_perl->Iofsgv, param);
     PL_stdingv         = gv_dup(proto_perl->Istdingv, param);
     PL_stderrgv                = gv_dup(proto_perl->Istderrgv, param);
     PL_defgv           = gv_dup(proto_perl->Idefgv, param);
@@ -12074,7 +12108,6 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
     PL_curpm           = proto_perl->Icurpm;   /* XXX No PMOP ref count */
     PL_rs              = sv_dup_inc(proto_perl->Irs, param);
     PL_last_in_gv      = gv_dup(proto_perl->Ilast_in_gv, param);
-    PL_ofs_sv          = sv_dup_inc(proto_perl->Iofs_sv, param);
     PL_defoutgv                = gv_dup_inc(proto_perl->Idefoutgv, param);
     PL_chopset         = proto_perl->Ichopset; /* XXX never deallocated */
     PL_toptarget       = sv_dup_inc(proto_perl->Itoptarget, param);