(Retracted by #10042)
[p5sagit/p5-mst-13.2.git] / sv.c
diff --git a/sv.c b/sv.c
index 4b64e13..65a3279 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -137,6 +137,7 @@ S_more_sv(pTHX)
     if (PL_nice_chunk) {
        sv_add_arena(PL_nice_chunk, PL_nice_chunk_size, 0);
        PL_nice_chunk = Nullch;
+        PL_nice_chunk_size = 0;
     }
     else {
        char *chunk;                /* must use New here to match call to */
@@ -1430,12 +1431,12 @@ S_not_a_number(pTHX_ SV *sv)
 {
     char tmpbuf[64];
     char *d = tmpbuf;
-    char *s;
     char *limit = tmpbuf + sizeof(tmpbuf) - 8;
                   /* each *s can expand to 4 chars + "...\0",
                      i.e. need room for 8 chars */
 
-    for (s = SvPVX(sv); *s && d < limit; s++) {
+    char *s, *end;
+    for (s = SvPVX(sv), end = s + SvCUR(sv); s < end && d < limit; s++) {
        int ch = *s & 0xFF;
        if (ch & 128 && !isPRINT_LC(ch)) {
            *d++ = 'M';
@@ -1458,6 +1459,10 @@ S_not_a_number(pTHX_ SV *sv)
            *d++ = '\\';
            *d++ = '\\';
        }
+       else if (ch == '\0') {
+           *d++ = '\\';
+           *d++ = '0';
+       }
        else if (isPRINT_LC(ch))
            *d++ = ch;
        else {
@@ -1465,7 +1470,7 @@ S_not_a_number(pTHX_ SV *sv)
            *d++ = toCTRL(ch);
        }
     }
-    if (*s) {
+    if (s < end) {
        *d++ = '.';
        *d++ = '.';
        *d++ = '.';
@@ -1726,7 +1731,7 @@ Perl_sv_2iv(pTHX_ register SV *sv)
        if (SvROK(sv)) {
          SV* tmpstr;
           if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
-                  (SvRV(tmpstr) != SvRV(sv)))
+                (SvTYPE(tmpstr) != SVt_RV || (SvRV(tmpstr) != SvRV(sv))))
              return SvIV(tmpstr);
          return PTR2IV(SvRV(sv));
        }
@@ -1980,7 +1985,7 @@ Perl_sv_2uv(pTHX_ register SV *sv)
        if (SvROK(sv)) {
          SV* tmpstr;
           if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
-                  (SvRV(tmpstr) != SvRV(sv)))
+                (SvTYPE(tmpstr) != SVt_RV || (SvRV(tmpstr) != SvRV(sv))))
              return SvUV(tmpstr);
          return PTR2UV(SvRV(sv));
        }
@@ -2264,7 +2269,7 @@ Perl_sv_2nv(pTHX_ register SV *sv)
        if (SvROK(sv)) {
          SV* tmpstr;
           if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
-                  (SvRV(tmpstr) != SvRV(sv)))
+                (SvTYPE(tmpstr) != SVt_RV || (SvRV(tmpstr) != SvRV(sv))))
              return SvNV(tmpstr);
          return PTR2NV(SvRV(sv));
        }
@@ -2528,7 +2533,7 @@ Perl_looks_like_number(pTHX_ SV *sv)
            ) {
 #ifdef USE_LOCALE_NUMERIC
            if (specialradix)
-               s += SvCUR(PL_numeric_radix);
+               s += SvCUR(PL_numeric_radix_sv);
            else
 #endif
                s++;
@@ -2544,7 +2549,7 @@ Perl_looks_like_number(pTHX_ SV *sv)
            ) {
 #ifdef USE_LOCALE_NUMERIC
        if (specialradix)
-           s += SvCUR(PL_numeric_radix);
+           s += SvCUR(PL_numeric_radix_sv);
        else
 #endif
            s++;
@@ -2680,7 +2685,7 @@ Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
        if (SvROK(sv)) {
            SV* tmpstr;
             if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)) &&
-                    (SvRV(tmpstr) != SvRV(sv)))
+                (SvTYPE(tmpstr) != SVt_RV || (SvRV(tmpstr) != SvRV(sv))))
                return SvPV(tmpstr,*lp);
            sv = (SV*)SvRV(sv);
            if (!sv)
@@ -2920,7 +2925,7 @@ Perl_sv_2bool(pTHX_ register SV *sv)
     if (SvROK(sv)) {
        SV* tmpsv;
         if (SvAMAGIC(sv) && (tmpsv=AMG_CALLun(sv,bool_)) &&
-                (SvRV(tmpsv) != SvRV(sv)))
+                (SvTYPE(tmpsv) != SVt_RV || (SvRV(tmpsv) != SvRV(sv))))
            return SvTRUE(tmpsv);
       return SvRV(sv) != 0;
     }
@@ -2966,8 +2971,12 @@ Perl_sv_utf8_upgrade(pTHX_ register SV *sv)
     if (!sv)
        return 0;
 
-    if (!SvPOK(sv))
-       (void) SvPV_nolen(sv);
+    if (!SvPOK(sv)) {
+       STRLEN len = 0;
+       (void) sv_2pv(sv,&len);
+       if (!SvPOK(sv))
+            return len;
+    }
 
     if (SvUTF8(sv))
        return SvCUR(sv);
@@ -2984,7 +2993,8 @@ Perl_sv_utf8_upgrade(pTHX_ register SV *sv)
     e = (U8 *) SvEND(sv);
     t = s;
     while (t < e) {
-       if ((hibit = !UTF8_IS_INVARIANT(*t++)))
+       U8 ch = *t++;
+       if ((hibit = !NATIVE_IS_INVARIANT(ch)))
            break;
     }
     if (hibit) {
@@ -2997,12 +3007,6 @@ Perl_sv_utf8_upgrade(pTHX_ register SV *sv)
            Safefree(s); /* No longer using what was there before. */
        SvLEN(sv) = len; /* No longer know the real size. */
     }
-#ifdef EBCDIC
-    else {
-       for (t = s; t < e; t++)
-           *t = NATIVE_TO_ASCII(*t);
-    }
-#endif
     /* Mark as UTF-8 even if no hibit - saves scanning loop */
     SvUTF8_on(sv);
     return SvCUR(sv);
@@ -3118,7 +3122,8 @@ Perl_sv_utf8_decode(pTHX_ register SV *sv)
            return FALSE;
         e = (U8 *) SvEND(sv);
         while (c < e) {
-            if (!UTF8_IS_INVARIANT(*c++)) {
+           U8 ch = *c++;
+            if (!UTF8_IS_INVARIANT(ch)) {
                SvUTF8_on(sv);
                break;
            }
@@ -3821,8 +3826,9 @@ Perl_sv_chop(pTHX_ register SV *sv, register char *ptr)   /* like set but assuming
 =for apidoc sv_catpvn
 
 Concatenates the string onto the end of the string which is in the SV.  The
-C<len> indicates number of bytes to copy.  Handles 'get' magic, but not
-'set' magic.  See C<sv_catpvn_mg>.
+C<len> indicates number of bytes to copy.  If the SV has the UTF8
+status set, then the bytes appended should be valid UTF8.
+Handles 'get' magic, but not 'set' magic.  See C<sv_catpvn_mg>.
 
 =cut
 */
@@ -3920,10 +3926,10 @@ Perl_sv_catsv_mg(pTHX_ SV *dsv, register SV *ssv)
 =for apidoc sv_catpv
 
 Concatenates the string onto the end of the string which is in the SV.
-Handles 'get' magic, but not 'set' magic.  See C<sv_catpv_mg>.
+If the SV has the UTF8 status set, then the bytes appended should be
+valid UTF8.  Handles 'get' magic, but not 'set' magic.  See C<sv_catpv_mg>.
 
-=cut
-*/
+=cut */
 
 void
 Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr)
@@ -4737,8 +4743,9 @@ Perl_sv_pos_b2u(pTHX_ register SV *sv, I32* offsetp)
     len = 0;
     while (s < send) {
        STRLEN n;
-        /* We can use low level directly here as we are not looking at the values */
-       if (utf8n_to_uvuni(s, UTF8SKIP(s), &n, 0)) {
+       /* Call utf8n_to_uvchr() to validate the sequence */
+       utf8n_to_uvchr(s, UTF8SKIP(s), &n, 0);
+       if (n > 0) {
            s += n;
            len++;
        }
@@ -6763,12 +6770,15 @@ Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...)
 /*
 =for apidoc sv_catpvf
 
-Processes its arguments like C<sprintf> and appends the formatted output
-to an SV.  Handles 'get' magic, but not 'set' magic.  C<SvSETMAGIC()> must
-typically be called after calling this function to handle 'set' magic.
+Processes its arguments like C<sprintf> and appends the formatted
+output to an SV.  If the appended data contains "wide" characters
+(including, but not limited to, SVs with a UTF-8 PV formatted with %s,
+and characters >255 formatted with %c), the original SV might get
+upgraded to UTF-8.  Handles 'get' magic, but not 'set' magic.
+C<SvSETMAGIC()> must typically be called after calling this function
+to handle 'set' magic.
 
-=cut
-*/
+=cut */
 
 void
 Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...)
@@ -7133,7 +7143,9 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
 
        case 'c':
            uv = args ? va_arg(*args, int) : SvIVx(argsv);
-           if ((uv > 255 || (!UTF8_IS_INVARIANT(uv) && SvUTF8(sv))) && !IN_BYTE) {
+           if ((uv > 255 ||
+                (!UNI_IS_INVARIANT(uv) && SvUTF8(sv)))
+               && !IN_BYTE) {
                eptr = (char*)utf8buf;
                elen = uvchr_to_utf8((U8*)eptr, uv) - utf8buf;
                is_utf = TRUE;
@@ -7673,8 +7685,8 @@ Perl_gp_dup(pTHX_ GP *gp)
 MAGIC *
 Perl_mg_dup(pTHX_ MAGIC *mg)
 {
-    MAGIC *mgret = (MAGIC*)NULL;
-    MAGIC *mgprev;
+    MAGIC *mgprev = (MAGIC*)NULL;
+    MAGIC *mgret;
     if (!mg)
        return (MAGIC*)NULL;
     /* look for it in the table first */
@@ -7685,10 +7697,10 @@ Perl_mg_dup(pTHX_ MAGIC *mg)
     for (; mg; mg = mg->mg_moremagic) {
        MAGIC *nmg;
        Newz(0, nmg, 1, MAGIC);
-       if (!mgret)
-           mgret = nmg;
-       else
+       if (mgprev)
            mgprev->mg_moremagic = nmg;
+       else
+           mgret = nmg;
        nmg->mg_virtual = mg->mg_virtual;       /* XXX copy dynamic vtable? */
        nmg->mg_private = mg->mg_private;
        nmg->mg_type    = mg->mg_type;
@@ -8524,6 +8536,7 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl)
            TOPIV(nss,ix) = iv;
             break;
        case SAVEt_FREESV:
+       case SAVEt_MORTALIZESV:
            sv = (SV*)POPPTR(ss,ix);
            TOPPTR(nss,ix) = sv_dup_inc(sv);
            break;
@@ -9068,7 +9081,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
     PL_numeric_name    = SAVEPV(proto_perl->Inumeric_name);
     PL_numeric_standard        = proto_perl->Inumeric_standard;
     PL_numeric_local   = proto_perl->Inumeric_local;
-    PL_numeric_radix   = sv_dup_inc(proto_perl->Inumeric_radix);
+    PL_numeric_radix_sv        = sv_dup_inc(proto_perl->Inumeric_radix_sv);
 #endif /* !USE_LOCALE_NUMERIC */
 
     /* utf8 character classes */
@@ -9282,7 +9295,6 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
     PL_regendp         = (I32*)NULL;
     PL_reglastparen    = (U32*)NULL;
     PL_regtill         = Nullch;
-    PL_regprev         = '\n';
     PL_reg_start_tmp   = (char**)NULL;
     PL_reg_start_tmpl  = 0;
     PL_regdata         = (struct reg_data*)NULL;