Integrate with Sarathy.

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

diff --git a/sv.c b/sv.c
index 834dac3..8e84946 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -1,6 +1,6 @@
 /*    sv.c
  *
- *    Copyright (c) 1991-1999, Larry Wall
+ *    Copyright (c) 1991-2000, Larry Wall
  *
  *    You may distribute under the terms of either the GNU General Public
  *    License or the Artistic License, as specified in the README file.
@@ -2769,7 +2769,7 @@ Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
            *SvEND(dstr) = '\0';
            (void)SvPOK_only(dstr);
        }
-       if (SvUTF8(sstr))
+       if (DO_UTF8(sstr))
            SvUTF8_on(dstr);
        /*SUPPRESS 560*/
        if (sflags & SVp_NOK) {
@@ -3046,7 +3046,7 @@ Perl_sv_catpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN
     Move(ptr,SvPVX(sv)+tlen,len,char);
     SvCUR(sv) += len;
     *SvEND(sv) = '\0';
-    (void)SvPOK_only(sv);              /* validate pointer */
+    (void)SvPOK_only_UTF8(sv);         /* validate pointer */
     SvTAINT(sv);
 }
 
@@ -3083,6 +3083,8 @@ Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr)
        return;
     if (s = SvPV(sstr, len))
        sv_catpvn(dstr,s,len);
+    if (SvUTF8(sstr))
+       SvUTF8_on(dstr);
 }
 
 /*
@@ -3125,7 +3127,7 @@ Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr)
        ptr = SvPVX(sv);
     Move(ptr,SvPVX(sv)+tlen,len+1,char);
     SvCUR(sv) += len;
-    (void)SvPOK_only(sv);              /* validate pointer */
+    (void)SvPOK_only_UTF8(sv);         /* validate pointer */
     SvTAINT(sv);
 }
 
@@ -5638,6 +5640,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
     STRLEN origlen;
     I32 svix = 0;
     static char nullstr[] = "(null)";
+    SV *argsv;
 
     /* no matter what, this is a string now */
     (void)SvPV_force(sv, origlen);
@@ -5652,12 +5655,18 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
                char *s = va_arg(*args, char*);
                sv_catpv(sv, s ? s : nullstr);
            }
-           else if (svix < svmax)
+           else if (svix < svmax) {
                sv_catsv(sv, *svargs);
+               if (DO_UTF8(*svargs))
+                   SvUTF8_on(sv);
+           }
            return;
        case '_':
            if (args) {
-               sv_catsv(sv, va_arg(*args, SV*));
+               argsv = va_arg(*args, SV*);
+               sv_catsv(sv, argsv);
+               if (DO_UTF8(argsv))
+                   SvUTF8_on(sv);
                return;
            }
            /* See comment on '_' below */
@@ -5676,6 +5685,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;
 
        char esignbuf[4];
        U8 utf8buf[10];
@@ -5816,22 +5826,20 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
            goto string;
 
        case 'c':
-           if (IN_UTF8) {
-               if (args)
-                   uv = va_arg(*args, int);
-               else
-                   uv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
-
+           if (args)
+               uv = va_arg(*args, int);
+           else
+               uv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
+           if ((uv > 255 || (uv > 127 && SvUTF8(sv))) && !IN_BYTE) {
                eptr = (char*)utf8buf;
                elen = uv_to_utf8((U8*)eptr, uv) - utf8buf;
-               goto string;
+               is_utf = TRUE;
+           }
+           else {
+               c = (char)uv;
+               eptr = &c;
+               elen = 1;
            }
-           if (args)
-               c = va_arg(*args, int);
-           else
-               c = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
-           eptr = &c;
-           elen = 1;
            goto string;
 
        case 's':
@@ -5851,17 +5859,76 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
                }
            }
            else if (svix < svmax) {
-               eptr = SvPVx(svargs[svix++], elen);
-               if (IN_UTF8) {
+               argsv = svargs[svix++];
+               eptr = SvPVx(argsv, elen);
+               if (DO_UTF8(argsv)) {
                    if (has_precis && precis < elen) {
                        I32 p = precis;
-                       sv_pos_u2b(svargs[svix - 1], &p, 0); /* sticks at end */
+                       sv_pos_u2b(argsv, &p, 0); /* sticks at end */
                        precis = p;
                    }
                    if (width) { /* fudge width (can't fudge elen) */
-                       width += elen - sv_len_utf8(svargs[svix - 1]);
+                       width += elen - sv_len_utf8(argsv);
+                   }
+                   is_utf = TRUE;
+               }
+           }
+           goto string;
+
+       case 'v':
+           if (args)
+               argsv = va_arg(*args, SV*);
+           else if (svix < svmax)
+               argsv = svargs[svix++];
+           {
+               STRLEN len;
+               U8 *str = (U8*)SvPVx(argsv,len);
+               I32 vlen = len*3+1;
+               SV *vsv = NEWSV(73,vlen);
+               I32 ulen;
+               I32 vfree = vlen;
+               U8 *vptr = (U8*)SvPVX(vsv);
+               STRLEN vcur = 0;
+               bool utf = DO_UTF8(argsv);
+
+               if (utf)
+                   is_utf = TRUE;
+               while (len) {
+                   UV uv;
+
+                   if (utf)
+                       uv = utf8_to_uv(str, &ulen);
+                   else {
+                       uv = *str;
+                       ulen = 1;
                    }
+                   str += ulen;
+                   len -= ulen;
+                   eptr = ebuf + sizeof ebuf;
+                   do {
+                       *--eptr = '0' + uv % 10;
+                   } while (uv /= 10);
+                   elen = (ebuf + sizeof ebuf) - eptr;
+                   while (elen >= vfree-1) {
+                       STRLEN off = vptr - (U8*)SvPVX(vsv);
+                       vfree += vlen;
+                       vlen *= 2;
+                       SvGROW(vsv, vlen);
+                       vptr = (U8*)SvPVX(vsv) + off;
+                   }
+                   memcpy(vptr, eptr, elen);
+                   vptr += elen;
+                   *vptr++ = '.';
+                   vfree -= elen + 1;
+                   vcur += elen + 1;
+               }
+               if (vcur) {
+                   vcur--;
+                   vptr[-1] = '\0';
                }
+               SvCUR_set(vsv,vcur);
+               eptr = SvPVX(vsv);
+               elen = vcur;
            }
            goto string;
 
@@ -5873,7 +5940,10 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
             */
            if (!args)
                goto unknown;
-           eptr = SvPVx(va_arg(*args, SV*), elen);
+           argsv = va_arg(*args,SV*);
+           eptr = SvPVx(argsv, elen);
+           if (DO_UTF8(argsv))
+               is_utf = TRUE;
 
        string:
            if (has_precis && elen > precis)
@@ -6216,6 +6286,8 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
            memset(p, ' ', gap);
            p += gap;
        }
+       if (is_utf)
+           SvUTF8_on(sv);
        *p = '\0';
        SvCUR(sv) = p - SvPVX(sv);
     }
@@ -6383,7 +6455,7 @@ void *
 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, void *sv)
 {
     PTR_TBL_ENT_t *tblent;
-    UV hash = (UV)sv;
+    UV hash = PTR2UV(sv);
     assert(tbl);
     tblent = tbl->tbl_ary[hash & tbl->tbl_max];
     for (; tblent; tblent = tblent->next) {
@@ -6400,7 +6472,7 @@ Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, void *oldv, void *newv)
     /* XXX this may be pessimal on platforms where pointers aren't good
      * hash values e.g. if they grow faster in the most significant
      * bits */
-    UV hash = (UV)oldv;
+    UV hash = PTR2UV(oldv);
     bool i = 1;
 
     assert(tbl);
@@ -6440,7 +6512,7 @@ Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl)
            continue;
        curentp = ary + oldsize;
        for (entp = ary, ent = *ary; ent; ent = *entp) {
-           if ((newsize & (UV)ent->oldval) != i) {
+           if ((newsize & PTR2UV(ent->oldval)) != i) {
                *entp = ent->next;
                ent->next = *curentp;
                *curentp = ent;
@@ -7134,6 +7206,10 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl)
            i = POPINT(ss,ix);
            TOPINT(nss,ix) = i;
            break;
+       case SAVEt_COMPPAD:
+           av = (AV*)POPPTR(ss,ix);
+           TOPPTR(nss,ix) = av_dup(av);
+           break;
        default:
            Perl_croak(aTHX_ "panic: ss_dup inconsistency");
        }