This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
$^P, eval and caller
[perl5.git] / sv.c
diff --git a/sv.c b/sv.c
index 51bd17e..5e61449 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -499,78 +499,91 @@ Perl_sv_free_arenas(pTHX)
        Safefree(arena);
     }
     PL_xiv_arenaroot = 0;
+    PL_xiv_root = 0;
 
     for (arena = PL_xnv_arenaroot; arena; arena = arenanext) {
        arenanext = (XPV*)arena->xpv_pv;
        Safefree(arena);
     }
     PL_xnv_arenaroot = 0;
+    PL_xnv_root = 0;
 
     for (arena = PL_xrv_arenaroot; arena; arena = arenanext) {
        arenanext = (XPV*)arena->xpv_pv;
        Safefree(arena);
     }
     PL_xrv_arenaroot = 0;
+    PL_xrv_root = 0;
 
     for (arena = PL_xpv_arenaroot; arena; arena = arenanext) {
        arenanext = (XPV*)arena->xpv_pv;
        Safefree(arena);
     }
     PL_xpv_arenaroot = 0;
+    PL_xpv_root = 0;
 
     for (arena = (XPV*)PL_xpviv_arenaroot; arena; arena = arenanext) {
        arenanext = (XPV*)arena->xpv_pv;
        Safefree(arena);
     }
     PL_xpviv_arenaroot = 0;
+    PL_xpviv_root = 0;
 
     for (arena = (XPV*)PL_xpvnv_arenaroot; arena; arena = arenanext) {
        arenanext = (XPV*)arena->xpv_pv;
        Safefree(arena);
     }
     PL_xpvnv_arenaroot = 0;
+    PL_xpvnv_root = 0;
 
     for (arena = (XPV*)PL_xpvcv_arenaroot; arena; arena = arenanext) {
        arenanext = (XPV*)arena->xpv_pv;
        Safefree(arena);
     }
     PL_xpvcv_arenaroot = 0;
+    PL_xpvcv_root = 0;
 
     for (arena = (XPV*)PL_xpvav_arenaroot; arena; arena = arenanext) {
        arenanext = (XPV*)arena->xpv_pv;
        Safefree(arena);
     }
     PL_xpvav_arenaroot = 0;
+    PL_xpvav_root = 0;
 
     for (arena = (XPV*)PL_xpvhv_arenaroot; arena; arena = arenanext) {
        arenanext = (XPV*)arena->xpv_pv;
        Safefree(arena);
     }
     PL_xpvhv_arenaroot = 0;
+    PL_xpvhv_root = 0;
 
     for (arena = (XPV*)PL_xpvmg_arenaroot; arena; arena = arenanext) {
        arenanext = (XPV*)arena->xpv_pv;
        Safefree(arena);
     }
     PL_xpvmg_arenaroot = 0;
+    PL_xpvmg_root = 0;
 
     for (arena = (XPV*)PL_xpvlv_arenaroot; arena; arena = arenanext) {
        arenanext = (XPV*)arena->xpv_pv;
        Safefree(arena);
     }
     PL_xpvlv_arenaroot = 0;
+    PL_xpvlv_root = 0;
 
     for (arena = (XPV*)PL_xpvbm_arenaroot; arena; arena = arenanext) {
        arenanext = (XPV*)arena->xpv_pv;
        Safefree(arena);
     }
     PL_xpvbm_arenaroot = 0;
+    PL_xpvbm_root = 0;
 
     for (arena = (XPV*)PL_he_arenaroot; arena; arena = arenanext) {
        arenanext = (XPV*)arena->xpv_pv;
        Safefree(arena);
     }
     PL_he_arenaroot = 0;
+    PL_he_root = 0;
 
     if (PL_nice_chunk)
        Safefree(PL_nice_chunk);
@@ -3971,6 +3984,10 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
         * has to be allocated and SvPVX(sstr) has to be freed.
         */
 
+       /* Whichever path we take through the next code, we want this true,
+          and doing it now facilitates the COW check.  */
+       (void)SvPOK_only(dstr);
+
        if (
 #ifdef PERL_COPY_ON_WRITE
             (sflags & (SVf_FAKE | SVf_READONLY)) != (SVf_FAKE | SVf_READONLY)
@@ -3985,6 +4002,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
              !(PL_op && PL_op->op_type == OP_AASSIGN))
 #ifdef PERL_COPY_ON_WRITE
             && !((sflags & CAN_COW_MASK) == CAN_COW_FLAGS
+                && (SvFLAGS(dstr) & CAN_COW_MASK) == CAN_COW_FLAGS
                  && SvTYPE(sstr) >= SVt_PVIV)
 #endif
             ) {
@@ -3995,7 +4013,6 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
             Move(SvPVX(sstr),SvPVX(dstr),len,char);
             SvCUR_set(dstr, len);
             *SvEND(dstr) = '\0';
-            (void)SvPOK_only(dstr);
         } else {
             /* If PERL_COPY_ON_WRITE is not defined, then isSwipe will always
                be true in here.  */
@@ -4033,7 +4050,6 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
                else if (SvLEN(dstr))
                    Safefree(SvPVX(dstr));
            }
-           (void)SvPOK_only(dstr);
 
 #ifdef PERL_COPY_ON_WRITE
             if (!isSwipe) {
@@ -4473,7 +4489,7 @@ Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags)
                 sv_dump(sv);
             }
        }
-       else if (PL_curcop != &PL_compiling)
+       else if (IN_PERL_RUNTIME)
            Perl_croak(aTHX_ PL_no_modify);
         /* At this point I believe that I can drop the global SV mutex.  */
     }
@@ -4490,7 +4506,7 @@ Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags)
            *SvEND(sv) = '\0';
            unsharepvn(pvx, SvUTF8(sv) ? -(I32)len : len, hash);
        }
-       else if (PL_curcop != &PL_compiling)
+       else if (IN_PERL_RUNTIME)
            Perl_croak(aTHX_ PL_no_modify);
     }
 #endif
@@ -4875,7 +4891,7 @@ Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 nam
         sv_force_normal_flags(sv, 0);
 #endif
     if (SvREADONLY(sv)) {
-       if (PL_curcop != &PL_compiling
+       if (IN_PERL_RUNTIME
            && how != PERL_MAGIC_regex_global
            && how != PERL_MAGIC_bm
            && how != PERL_MAGIC_fm
@@ -5594,7 +5610,9 @@ Perl_sv_free(pTHX_ SV *sv)
            return;
        }
        if (ckWARN_d(WARN_INTERNAL))
-           Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "Attempt to free unreferenced scalar");
+           Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
+                        "Attempt to free unreferenced scalar: SV 0x%"UVxf,
+                PTR2UV(sv));
        return;
     }
     if (--(SvREFCNT(sv)) > 0)
@@ -6396,7 +6414,7 @@ Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
     if (PerlIO_isutf8(fp))
        SvUTF8_on(sv);
 
-    if (PL_curcop == &PL_compiling) {
+    if (IN_PERL_COMPILETIME) {
        /* we always read code in line mode */
        rsptr = "\n";
        rslen = 1;
@@ -6731,7 +6749,7 @@ Perl_sv_inc(pTHX_ register SV *sv)
        if (SvIsCOW(sv))
            sv_force_normal_flags(sv, 0);
        if (SvREADONLY(sv)) {
-           if (PL_curcop != &PL_compiling)
+           if (IN_PERL_RUNTIME)
                Perl_croak(aTHX_ PL_no_modify);
        }
        if (SvROK(sv)) {
@@ -6887,7 +6905,7 @@ Perl_sv_dec(pTHX_ register SV *sv)
        if (SvIsCOW(sv))
            sv_force_normal_flags(sv, 0);
        if (SvREADONLY(sv)) {
-           if (PL_curcop != &PL_compiling)
+           if (IN_PERL_RUNTIME)
                Perl_croak(aTHX_ PL_no_modify);
        }
        if (SvROK(sv)) {
@@ -8517,6 +8535,33 @@ S_expect_number(pTHX_ char** pattern)
 }
 #define EXPECT_NUMBER(pattern, var) (var = S_expect_number(aTHX_ &pattern))
 
+static char *
+F0convert(NV nv, char *endbuf, STRLEN *len)
+{
+    int neg = nv < 0;
+    UV uv;
+    char *p = endbuf;
+
+    if (neg)
+       nv = -nv;
+    if (nv < UV_MAX) {
+       nv += 0.5;
+       uv = nv;
+       if (uv & 1 && uv == nv)
+           uv--;                       /* Round to even */
+       do {
+           unsigned dig = uv % 10;
+           *--p = '0' + dig;
+       } while (uv /= 10);
+       if (neg)
+           *--p = '-';
+       *len = endbuf - p;
+       return p;
+    }
+    return Nullch;
+}
+
+
 /*
 =for apidoc sv_vcatpvfn
 
@@ -8544,6 +8589,12 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
     bool has_utf8; /* has the result utf8? */
     bool pat_utf8; /* the pattern is in utf8? */
     SV *nsv = Nullsv;
+    /* Times 4: a decimal digit takes more than 3 binary digits.
+     * NV_DIG: mantissa takes than many decimal digits.
+     * Plus 32: Playing safe. */
+    char ebuf[IV_DIG * 4 + NV_DIG + 32];
+    /* large enough for "%#.#f" --chip */
+    /* what about long double NVs? --jhi */
 
     has_utf8 = pat_utf8 = DO_UTF8(sv);
 
@@ -8579,6 +8630,44 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
        }
     }
 
+#ifndef USE_LONG_DOUBLE
+    /* special-case "%.<number>[gf]" */
+    if ( patlen <= 5 && pat[0] == '%' && pat[1] == '.'
+        && (pat[patlen-1] == 'g' || pat[patlen-1] == 'f') ) {
+       unsigned digits = 0;
+       const char *pp;
+
+       pp = pat + 2;
+       while (*pp >= '0' && *pp <= '9')
+           digits = 10 * digits + (*pp++ - '0');
+       if (pp - pat == patlen - 1) {
+           NV nv;
+
+           if (args)
+               nv = (NV)va_arg(*args, double);
+           else if (svix < svmax)
+               nv = SvNV(*svargs);
+           else
+               return;
+           if (*pp == 'g') {
+               if (digits < sizeof(ebuf) - NV_DIG - 10) { /* 0, point, slack */
+                   Gconvert(nv, (int)digits, 0, ebuf);
+                   sv_catpv(sv, ebuf);
+                   if (*ebuf)  /* May return an empty string for digits==0 */
+                       return;
+               }
+           } else if (!digits) {
+               STRLEN l;
+
+               if ((p = F0convert(nv, ebuf + sizeof ebuf, &l))) {
+                   sv_catpvn(sv, p, l);
+                   return;
+               }
+           }
+       }
+    }
+#endif /* !USE_LONG_DOUBLE */
+
     if (!args && svix < svmax && DO_UTF8(*svargs))
        has_utf8 = TRUE;
 
@@ -8610,13 +8699,6 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
 
        char *eptr = Nullch;
        STRLEN elen = 0;
-       /* Times 4: a decimal digit takes more than 3 binary digits.
-        * NV_DIG: mantissa takes than many decimal digits.
-        * Plus 32: Playing safe. */
-       char ebuf[IV_DIG * 4 + NV_DIG + 32];
-       /* large enough for "%#.#f" --chip */
-       /* what about long double NVs? --jhi */
-
        SV *vecsv = Nullsv;
        U8 *vecstr = Null(U8*);
        STRLEN veclen = 0;
@@ -9276,6 +9358,17 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
                PL_efloatbuf[0] = '\0';
            }
 
+           if ( !(width || left || plus || alt) && fill != '0'
+                && has_precis && intsize != 'q' ) {    /* Shortcuts */
+               if ( c == 'g') {
+                   Gconvert((NV)nv, (int)precis, 0, PL_efloatbuf);
+                   if (*PL_efloatbuf)  /* May return an empty string for digits==0 */
+                       goto float_converted;
+               } else if ( c == 'f' && !precis) {
+                   if ((eptr = F0convert(nv, ebuf + sizeof ebuf, &elen)))
+                       break;
+               }
+           }
            eptr = ebuf + sizeof ebuf;
            *--eptr = '\0';
            *--eptr = c;
@@ -9320,6 +9413,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
 #else
            (void)sprintf(PL_efloatbuf, eptr, nv);
 #endif
+       float_converted:
            eptr = PL_efloatbuf;
            elen = strlen(PL_efloatbuf);
            break;
@@ -10906,6 +11000,10 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
     PL_debug           = proto_perl->Idebug;
 
 #ifdef USE_REENTRANT_API
+    /* XXX: things like -Dm will segfault here in perlio, but doing
+     *  PERL_SET_CONTEXT(proto_perl);
+     * breaks too many other things
+     */
     Perl_reentrant_init(aTHX);
 #endif
 
@@ -11347,6 +11445,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
     PL_glob_index      = proto_perl->Iglob_index;
     PL_srand_called    = proto_perl->Isrand_called;
     PL_hash_seed       = proto_perl->Ihash_seed;
+    PL_rehash_seed     = proto_perl->Irehash_seed;
     PL_uudmap['M']     = 0;            /* reinits on demand */
     PL_bitcount                = Nullch;       /* reinits on demand */