This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
https://perl5.git.perl.org / perl5.git / blobdiff
? search:
summary | shortlog | log | commit | commitdiff | tree
raw | inline | side by side
Fix for
[perl5.git] / sv.c
diff --git a/sv.c b/sv.c
index b1da4a8..d5dffef 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -216,6 +216,8 @@ S_del_sv(pTHX_ SV *p)
 
 
 /*
+=head1 SV Manipulation Functions
+
 =for apidoc sv_add_arena
 
 Given a chunk of memory, link it to the head of the list of arenas,
@@ -1422,8 +1424,8 @@ Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt)
        SvPVX(sv)       = 0;
        HvFILL(sv)      = 0;
        HvMAX(sv)       = 0;
-       HvKEYS(sv)      = 0;
-       SvNVX(sv)       = 0.0;
+       HvTOTALKEYS(sv) = 0;
+       HvPLACEHOLDERS(sv) = 0;
        SvMAGIC(sv)     = magic;
        SvSTASH(sv)     = stash;
        HvRITER(sv)     = 0;
@@ -1941,7 +1943,7 @@ Perl_looks_like_number(pTHX_ SV *sv)
 STATIC int
 S_sv_2iuv_non_preserve(pTHX_ register SV *sv, I32 numtype)
 {
-    DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_2iuv_non '%s', IV=0x%"UVxf" NV=%g inttype=%"UVXf"\n", SvPVX(sv), SvIVX(sv), SvNVX(sv), (UV)numtype));
+    DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_2iuv_non '%s', IV=0x%"UVxf" NV=%"NVgf" inttype=%"UVXf"\n", SvPVX(sv), SvIVX(sv), SvNVX(sv), (UV)numtype));
     if (SvNVX(sv) < (NV)IV_MIN) {
        (void)SvIOKp_on(sv);
        (void)SvNOK_on(sv);
@@ -2195,7 +2197,7 @@ Perl_sv_2iv(pTHX_ register SV *sv)
            DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" PERL_PRIgldbl ")\n",
                                  PTR2UV(sv), SvNVX(sv)));
 #else
-           DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%g)\n",
+           DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"NVgf")\n",
                                  PTR2UV(sv), SvNVX(sv)));
 #endif
 
@@ -2251,7 +2253,7 @@ Perl_sv_2iv(pTHX_ register SV *sv)
                        this NV is in the preserved range, therefore: */
                     if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
                           < (UV)IV_MAX)) {
-                        Perl_croak(aTHX_ "sv_2iv assumed (U_V(fabs(SvNVX(sv))) < (UV)IV_MAX) but SvNVX(sv)=%g U_V is 0x%"UVxf", IV_MAX is 0x%"UVxf"\n", SvNVX(sv), U_V(SvNVX(sv)), (UV)IV_MAX);
+                        Perl_croak(aTHX_ "sv_2iv assumed (U_V(fabs(SvNVX(sv))) < (UV)IV_MAX) but SvNVX(sv)=%"NVgf" U_V is 0x%"UVxf", IV_MAX is 0x%"UVxf"\n", SvNVX(sv), U_V(SvNVX(sv)), (UV)IV_MAX);
                     }
                 } else {
                     /* IN_UV NOT_INT
@@ -2483,7 +2485,7 @@ Perl_sv_2uv(pTHX_ register SV *sv)
             DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%" PERL_PRIgldbl ")\n",
                                   PTR2UV(sv), SvNVX(sv)));
 #else
-            DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%g)\n",
+            DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"NVgf")\n",
                                   PTR2UV(sv), SvNVX(sv)));
 #endif
 
@@ -2538,7 +2540,7 @@ Perl_sv_2uv(pTHX_ register SV *sv)
                        this NV is in the preserved range, therefore: */
                     if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
                           < (UV)IV_MAX)) {
-                        Perl_croak(aTHX_ "sv_2uv assumed (U_V(fabs(SvNVX(sv))) < (UV)IV_MAX) but SvNVX(sv)=%g U_V is 0x%"UVxf", IV_MAX is 0x%"UVxf"\n", SvNVX(sv), U_V(SvNVX(sv)), (UV)IV_MAX);
+                        Perl_croak(aTHX_ "sv_2uv assumed (U_V(fabs(SvNVX(sv))) < (UV)IV_MAX) but SvNVX(sv)=%"NVgf" U_V is 0x%"UVxf", IV_MAX is 0x%"UVxf"\n", SvNVX(sv), U_V(SvNVX(sv)), (UV)IV_MAX);
                     }
                 } else
                     sv_2iuv_non_preserve (sv, numtype);
@@ -2634,7 +2636,7 @@ Perl_sv_2nv(pTHX_ register SV *sv)
 #else
        DEBUG_c({
            STORE_NUMERIC_LOCAL_SET_STANDARD();
-           PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%g)\n",
+           PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%"NVgf")\n",
                          PTR2UV(sv), SvNVX(sv));
            RESTORE_NUMERIC_LOCAL();
        });
@@ -2763,7 +2765,7 @@ Perl_sv_2nv(pTHX_ register SV *sv)
 #else
     DEBUG_c({
        STORE_NUMERIC_LOCAL_SET_STANDARD();
-       PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%g)\n",
+       PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%"NVgf")\n",
                      PTR2UV(sv), SvNVX(sv));
        RESTORE_NUMERIC_LOCAL();
     });
@@ -3235,7 +3237,7 @@ Perl_sv_2bool(pTHX_ register SV *sv)
     if (SvROK(sv)) {
        SV* tmpsv;
         if (SvAMAGIC(sv) && (tmpsv=AMG_CALLun(sv,bool_)) &&
-                (SvTYPE(tmpsv) != SVt_RV || (SvRV(tmpsv) != SvRV(sv))))
+                (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
            return SvTRUE(tmpsv);
       return SvRV(sv) != 0;
     }
@@ -4455,10 +4457,10 @@ Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 nam
     mg->mg_moremagic = SvMAGIC(sv);
     SvMAGIC(sv) = mg;
 
-    /* Some magic contains a reference loop, where the sv and object refer to
-       each other.  To avoid a reference loop that would prevent such objects
-       being freed, we look for such loops and if we find one we avoid
-       incrementing the object refcount. */
+    /* Some magic sontains a reference loop, where the sv and object refer to
+       each other.  To prevent a reference loop that would prevent such
+       objects being freed, we look for such loops and if we find one we
+       avoid incrementing the object refcount. */
     if (!obj || obj == sv ||
        how == PERL_MAGIC_arylen ||
        how == PERL_MAGIC_qr ||
@@ -5666,7 +5668,7 @@ Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
     DEBUG_P(PerlIO_printf(Perl_debug_log,
        "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
     DEBUG_P(PerlIO_printf(Perl_debug_log,
-       "Screamer: entering: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
+       "Screamer: entering: PerlIO * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
               PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
               PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
     for (;;) {
@@ -5700,19 +5702,23 @@ Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
        DEBUG_P(PerlIO_printf(Perl_debug_log,
                              "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
                              PTR2UV(ptr),(long)cnt));
-       PerlIO_set_ptrcnt(fp, ptr, cnt); /* deregisterize cnt and ptr */
+       PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* deregisterize cnt and ptr */
+#if 0
        DEBUG_P(PerlIO_printf(Perl_debug_log,
            "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
            PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
            PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
+#endif
        /* This used to call 'filbuf' in stdio form, but as that behaves like
           getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
           another abstraction.  */
        i   = PerlIO_getc(fp);          /* get more characters */
+#if 0
        DEBUG_P(PerlIO_printf(Perl_debug_log,
            "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
            PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
            PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
+#endif
        cnt = PerlIO_get_cnt(fp);
        ptr = (STDCHAR*)PerlIO_get_ptr(fp);     /* reregisterize cnt and ptr */
        DEBUG_P(PerlIO_printf(Perl_debug_log,
@@ -5741,7 +5747,7 @@ thats_really_all_folks:
        cnt += shortbuffered;
        DEBUG_P(PerlIO_printf(Perl_debug_log,
            "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
-    PerlIO_set_ptrcnt(fp, ptr, cnt);   /* put these back or we're in trouble */
+    PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* put these back or we're in trouble */
     DEBUG_P(PerlIO_printf(Perl_debug_log,
        "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
        PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
@@ -5846,6 +5852,8 @@ Perl_sv_inc(pTHX_ register SV *sv)
     if (SvGMAGICAL(sv))
        mg_get(sv);
     if (SvTHINKFIRST(sv)) {
+       if (SvREADONLY(sv) && SvFAKE(sv))
+           sv_force_normal(sv);
        if (SvREADONLY(sv)) {
            if (PL_curcop != &PL_compiling)
                Perl_croak(aTHX_ PL_no_modify);
@@ -5934,7 +5942,7 @@ Perl_sv_inc(pTHX_ register SV *sv)
            DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"PERL_PRIgldbl"\n",
                                  SvPVX(sv), SvIVX(sv), SvNVX(sv)));
 #else
-           DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%g\n",
+           DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
                                  SvPVX(sv), SvIVX(sv), SvNVX(sv)));
 #endif
        }
@@ -6000,6 +6008,8 @@ Perl_sv_dec(pTHX_ register SV *sv)
     if (SvGMAGICAL(sv))
        mg_get(sv);
     if (SvTHINKFIRST(sv)) {
+       if (SvREADONLY(sv) && SvFAKE(sv))
+           sv_force_normal(sv);
        if (SvREADONLY(sv)) {
            if (PL_curcop != &PL_compiling)
                Perl_croak(aTHX_ PL_no_modify);
@@ -6080,7 +6090,7 @@ Perl_sv_dec(pTHX_ register SV *sv)
            DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"PERL_PRIgldbl"\n",
                                  SvPVX(sv), SvIVX(sv), SvNVX(sv)));
 #else
-           DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%g\n",
+           DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
                                  SvPVX(sv), SvIVX(sv), SvNVX(sv)));
 #endif
        }
@@ -7645,6 +7655,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
     I32 svix = 0;
     static char nullstr[] = "(null)";
     SV *argsv = Nullsv;
+    bool has_utf8 = FALSE; /* has the result utf8? */
 
     /* no matter what, this is a string now */
     (void)SvPV_force(sv, origlen);
@@ -7678,13 +7689,16 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
        }
     }
 
+    if (!args && svix < svmax && DO_UTF8(*svargs))
+        has_utf8 = TRUE;
+
     patend = (char*)pat + patlen;
     for (p = (char*)pat; p < patend; p = q) {
        bool alt = FALSE;
        bool left = FALSE;
        bool vectorize = FALSE;
        bool vectorarg = FALSE;
-       bool vec_utf = FALSE;
+       bool vec_utf8 = FALSE;
        char fill = ' ';
        char plus = 0;
        char intsize = 0;
@@ -7692,7 +7706,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
        STRLEN zeros = 0;
        bool has_precis = FALSE;
        STRLEN precis = 0;
-       bool is_utf = FALSE;
+       bool is_utf8 = FALSE;  /* is this item utf8?   */
        
        char esignbuf[4];
        U8 utf8buf[UTF8_MAXLEN+1];
@@ -7817,17 +7831,17 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
                        svargs[ewix ? ewix-1 : svix++] : &PL_sv_undef;
                dotstr = SvPVx(vecsv, dotstrlen);
                if (DO_UTF8(vecsv))
-                   is_utf = TRUE;
+                   is_utf8 = TRUE;
            }
            if (args) {
                vecsv = va_arg(*args, SV*);
                vecstr = (U8*)SvPVx(vecsv,veclen);
-               vec_utf = DO_UTF8(vecsv);
+               vec_utf8 = DO_UTF8(vecsv);
            }
            else if (efix ? efix <= svmax : svix < svmax) {
                vecsv = svargs[efix ? efix-1 : svix++];
                vecstr = (U8*)SvPVx(vecsv,veclen);
-               vec_utf = DO_UTF8(vecsv);
+               vec_utf8 = DO_UTF8(vecsv);
            }
            else {
                vecstr = (U8*)"";
@@ -7921,7 +7935,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
                && !IN_BYTES) {
                eptr = (char*)utf8buf;
                elen = uvchr_to_utf8((U8*)eptr, uv) - utf8buf;
-               is_utf = TRUE;
+               is_utf8 = TRUE;
            }
            else {
                c = (char)uv;
@@ -7957,7 +7971,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
                    if (width) { /* fudge width (can't fudge elen) */
                        width += elen - sv_len_utf8(argsv);
                    }
-                   is_utf = TRUE;
+                   is_utf8 = TRUE;
                }
            }
            goto string;
@@ -7973,7 +7987,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
            argsv = va_arg(*args, SV*);
            eptr = SvPVx(argsv, elen);
            if (DO_UTF8(argsv))
-               is_utf = TRUE;
+               is_utf8 = TRUE;
 
        string:
            vectorize = FALSE;
@@ -8003,8 +8017,9 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
                STRLEN ulen;
                if (!veclen)
                    continue;
-               if (vec_utf)
-                   uv = utf8n_to_uvchr(vecstr, veclen, &ulen, UTF8_ALLOW_ANYUV);
+               if (vec_utf8)
+                   uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
+                                       UTF8_ALLOW_ANYUV);
                else {
                    uv = *vecstr;
                    ulen = 1;
@@ -8088,8 +8103,9 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
        vector:
                if (!veclen)
                    continue;
-               if (vec_utf)
-                   uv = utf8n_to_uvchr(vecstr, veclen, &ulen, UTF8_ALLOW_ANYUV);
+               if (vec_utf8)
+                   uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
+                                       UTF8_ALLOW_ANYUV);
                else {
                    uv = *vecstr;
                    ulen = 1;
@@ -8344,6 +8360,20 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
                *p++ = '0';
        }
        if (elen) {
+           if (is_utf8 != has_utf8) {
+               if (is_utf8) {
+                   if (SvCUR(sv)) {
+                       sv_utf8_upgrade(sv);
+                       p = SvEND(sv);
+                   }
+               }
+               else {
+                   SV *nsv = sv_2mortal(newSVpvn(eptr, elen));
+                   sv_utf8_upgrade(nsv);
+                   eptr = SvPVX(nsv);
+                   elen = SvCUR(nsv);
+               }
+           }
            Copy(eptr, p, elen, char);
            p += elen;
        }
@@ -8359,7 +8389,9 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
            else
                vectorize = FALSE;              /* done iterating over vecstr */
        }
-       if (is_utf)
+       if (is_utf8)
+           has_utf8 = TRUE;
+       if (has_utf8)
            SvUTF8_on(sv);
        *p = '\0';
        SvCUR(sv) = p - SvPVX(sv);
@@ -9660,7 +9692,8 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
      * their pointers copied. */
 
     IV i;
-    CLONE_PARAMS* param = (CLONE_PARAMS*) malloc(sizeof(CLONE_PARAMS));
+    CLONE_PARAMS clone_params;
+    CLONE_PARAMS* param = &clone_params;
 
     PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
     PERL_SET_THX(my_perl);
@@ -9672,6 +9705,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
     PL_savestack = 0;
     PL_retstack = 0;
     PL_sig_pending = 0;
+    Zero(&PL_debug_pad, 1, struct perl_debug_pad);
 #  else        /* !DEBUGGING */
     Zero(my_perl, 1, PerlInterpreter);
 #  endif       /* DEBUGGING */
@@ -9688,7 +9722,8 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
     PL_Proc            = ipP;
 #else          /* !PERL_IMPLICIT_SYS */
     IV i;
-    CLONE_PARAMS* param = (CLONE_PARAMS*) malloc(sizeof(CLONE_PARAMS));
+    CLONE_PARAMS clone_params;
+    CLONE_PARAMS* param = &clone_params;
     PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
     PERL_SET_THX(my_perl);
 
@@ -9701,6 +9736,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
     PL_savestack = 0;
     PL_retstack = 0;
     PL_sig_pending = 0;
+    Zero(&PL_debug_pad, 1, struct perl_debug_pad);
 #    else      /* !DEBUGGING */
     Zero(my_perl, 1, PerlInterpreter);
 #    endif     /* DEBUGGING */
@@ -10369,7 +10405,6 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
     }
 
     SvREFCNT_dec(param->stashes);
-    Safefree(param);
 
     return my_perl;
 }
@@ -10377,6 +10412,8 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
 #endif /* USE_ITHREADS */
 
 /*
+=head1 Unicode Support
+
 =for apidoc sv_recode_to_utf8
 
 The encoding is assumed to be an Encode object, on entry the PV
Unnamed repository; edit this file 'description' to name the repository.