Add taint rethink to the todo list.
[p5sagit/p5-mst-13.2.git] / sv.c
diff --git a/sv.c b/sv.c
index cd3b6e3..5da249f 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -2867,7 +2867,7 @@ uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
        sign = 1;
     }
     do {
-       *--ptr = '0' + (uv % 10);
+       *--ptr = '0' + (char)(uv % 10);
     } while (uv /= 10);
     if (sign)
        *--ptr = '-';
@@ -2966,7 +2966,8 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags)
                            char ch;
                            int left = 0;
                            int right = 4;
-                           U16 reganch = (re->reganch & PMf_COMPILETIME) >> 12;
+                            char need_newline = 0;
+                           U16 reganch = (U16)((re->reganch & PMf_COMPILETIME) >> 12);
 
                            while((ch = *fptr++)) {
                                if(reganch & 1) {
@@ -2983,11 +2984,45 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags)
                            }
 
                            mg->mg_len = re->prelen + 4 + left;
+                            /*
+                             * If /x was used, we have to worry about a regex
+                             * ending with a comment later being embedded
+                             * within another regex. If so, we don't want this
+                             * regex's "commentization" to leak out to the
+                             * right part of the enclosing regex, we must cap
+                             * it with a newline.
+                             *
+                             * So, if /x was used, we scan backwards from the
+                             * end of the regex. If we find a '#' before we
+                             * find a newline, we need to add a newline
+                             * ourself. If we find a '\n' first (or if we
+                             * don't find '#' or '\n'), we don't need to add
+                             * anything.  -jfriedl
+                             */
+                            if (PMf_EXTENDED & re->reganch)
+                            {
+                                char *endptr = re->precomp + re->prelen;
+                                while (endptr >= re->precomp)
+                                {
+                                    char c = *(endptr--);
+                                    if (c == '\n')
+                                        break; /* don't need another */
+                                    if (c == '#') {
+                                        /* we end while in a comment, so we
+                                           need a newline */
+                                        mg->mg_len++; /* save space for it */
+                                        need_newline = 1; /* note to add it */
+                                    }
+                                }
+                            }
+
                            New(616, mg->mg_ptr, mg->mg_len + 1 + left, char);
                            Copy("(?", mg->mg_ptr, 2, char);
                            Copy(reflags, mg->mg_ptr+2, left, char);
                            Copy(":", mg->mg_ptr+left+2, 1, char);
                            Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char);
+                            if (need_newline)
+                                mg->mg_ptr[mg->mg_len - 2] = '\n';
                            mg->mg_ptr[mg->mg_len - 1] = ')';
                            mg->mg_ptr[mg->mg_len] = 0;
                        }
@@ -3055,7 +3090,7 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags)
            ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
        else
            ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
-       SvGROW(sv, ebuf - ptr + 1);     /* inlined from sv_setpvn */
+       SvGROW(sv, (STRLEN)(ebuf - ptr + 1));   /* inlined from sv_setpvn */
        Move(ptr,SvPVX(sv),ebuf - ptr,char);
        SvCUR_set(sv, ebuf - ptr);
        s = SvEND(sv);
@@ -3711,7 +3746,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
     default:
        if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) {
            mg_get(sstr);
-           if (SvTYPE(sstr) != stype) {
+           if ((int)SvTYPE(sstr) != stype) {
                stype = SvTYPE(sstr);
                if (stype == SVt_PVGV && dtype <= SVt_PVGV)
                    goto glob_assign;
@@ -3720,7 +3755,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
        if (stype == SVt_PVLV)
            (void)SvUPGRADE(dstr, SVt_PVNV);
        else
-           (void)SvUPGRADE(dstr, stype);
+           (void)SvUPGRADE(dstr, (U32)stype);
     }
 
     sflags = SvFLAGS(sstr);
@@ -3804,8 +3839,9 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
                                {
                                    Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
                                        CvCONST(cv)
-                                       ? "Constant subroutine %s redefined"
-                                       : "Subroutine %s redefined",
+                                       ? "Constant subroutine %s::%s redefined"
+                                       : "Subroutine %s::%s redefined",
+                                       HvNAME(GvSTASH((GV*)dstr)),
                                        GvENAME((GV*)dstr));
                                }
                            }
@@ -5331,7 +5367,7 @@ Perl_sv_pos_b2u(pTHX_ register SV *sv, I32* offsetp)
        return;
 
     s = (U8*)SvPV(sv, len);
-    if (len < *offsetp)
+    if ((I32)len < *offsetp)
        Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset");
     send = s + *offsetp;
     len = 0;
@@ -5685,7 +5721,7 @@ Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
       /* Grab the size of the record we're getting */
       recsize = SvIV(SvRV(PL_rs));
       (void)SvPOK_only(sv);    /* Validate pointer */
-      buffer = SvGROW(sv, recsize + 1);
+      buffer = SvGROW(sv, (STRLEN)(recsize + 1));
       /* Go yank in */
 #ifdef VMS
       /* VMS wants read instead of fread, because fread doesn't respect */
@@ -5771,15 +5807,15 @@ Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
 
     cnt = PerlIO_get_cnt(fp);                  /* get count into register */
     (void)SvPOK_only(sv);              /* validate pointer */
-    if (SvLEN(sv) - append <= cnt + 1) { /* make sure we have the room */
-       if (cnt > 80 && SvLEN(sv) > append) {
+    if ((I32)(SvLEN(sv) - append) <= cnt + 1) { /* make sure we have the room */
+       if (cnt > 80 && (I32)SvLEN(sv) > append) {
            shortbuffered = cnt - SvLEN(sv) + append + 1;
            cnt -= shortbuffered;
        }
        else {
            shortbuffered = 0;
            /* remember that cnt can be negative */
-           SvGROW(sv, append + (cnt <= 0 ? 2 : (cnt + 1)));
+           SvGROW(sv, (STRLEN)(append + (cnt <= 0 ? 2 : (cnt + 1))));
        }
     }
     else
@@ -5853,14 +5889,14 @@ Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
        SvGROW(sv, bpx + cnt + 2);
        bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
 
-       *bp++ = i;                      /* store character from PerlIO_getc */
+       *bp++ = (STDCHAR)i;             /* store character from PerlIO_getc */
 
        if (rslen && (STDCHAR)i == rslast)  /* all done for now? */
            goto thats_all_folks;
     }
 
 thats_all_folks:
-    if ((rslen > 1 && (bp - (STDCHAR*)SvPVX(sv) < rslen)) ||
+    if ((rslen > 1 && (STRLEN)(bp - (STDCHAR*)SvPVX(sv)) < rslen) ||
          memNE((char*)bp - rslen, rsptr, rslen))
        goto screamer;                          /* go back to the fray */
 thats_really_all_folks:
@@ -5896,7 +5932,7 @@ screamer2:
        if (rslen) {
            register STDCHAR *bpe = buf + sizeof(buf);
            bp = buf;
-           while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = i) != rslast && bp < bpe)
+           while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = (STDCHAR)i) != rslast && bp < bpe)
                ; /* keep reading */
            cnt = bp - buf;
        }
@@ -8018,6 +8054,25 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
        /* SIZE */
 
        switch (*q) {
+#ifdef WIN32
+       case 'I':                       /* Ix, I32x, and I64x */
+#  ifdef WIN64
+           if (q[1] == '6' && q[2] == '4') {
+               q += 3;
+               intsize = 'q';
+               break;
+           }
+#  endif
+           if (q[1] == '3' && q[2] == '2') {
+               q += 3;
+               break;
+           }
+#  ifdef WIN64
+           intsize = 'q';
+#  endif
+           q++;
+           break;
+#endif
 #if defined(HAS_QUAD) || (defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE))
        case 'L':                       /* Ld */
            /* FALL THROUGH */
@@ -8492,7 +8547,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
        SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
        p = SvEND(sv);
        if (esignlen && fill == '0') {
-           for (i = 0; i < esignlen; i++)
+           for (i = 0; i < (int)esignlen; i++)
                *p++ = esignbuf[i];
        }
        if (gap && !left) {
@@ -8500,7 +8555,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
            p += gap;
        }
        if (esignlen && fill != '0') {
-           for (i = 0; i < esignlen; i++)
+           for (i = 0; i < (int)esignlen; i++)
                *p++ = esignbuf[i];
        }
        if (zeros) {
@@ -9269,10 +9324,12 @@ Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param)
                 PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1), char);
            while (i <= sxhv->xhv_max) {
                ((HE**)dxhv->xhv_array)[i] = he_dup(((HE**)sxhv->xhv_array)[i],
-                                                   !!HvSHAREKEYS(sstr), param);
+                                                   (bool)!!HvSHAREKEYS(sstr),
+                                                   param);
                ++i;
            }
-           dxhv->xhv_eiter = he_dup(sxhv->xhv_eiter, !!HvSHAREKEYS(sstr), param);
+           dxhv->xhv_eiter = he_dup(sxhv->xhv_eiter,
+                                    (bool)!!HvSHAREKEYS(sstr), param);
        }
        else {
            SvPVX(dstr)         = Nullch;
@@ -9332,7 +9389,7 @@ Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param)
        CvFILE(dstr) = CvXSUB(sstr) ? CvFILE(sstr) : SAVEPV(CvFILE(sstr));
        break;
     default:
-       Perl_croak(aTHX_ "Bizarre SvTYPE [%d]", SvTYPE(sstr));
+       Perl_croak(aTHX_ "Bizarre SvTYPE [%" IVdf "]", (IV)SvTYPE(sstr));
        break;
     }
 
@@ -10008,11 +10065,9 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
 #endif
     PL_encoding                = sv_dup(proto_perl->Iencoding, param);
 
-#ifdef DEBUGGING
     sv_setpvn(PERL_DEBUG_PAD(0), "", 0);       /* For regex debugging. */
-    sv_setpvn(PERL_DEBUG_PAD(1), "", 0);
-    sv_setpvn(PERL_DEBUG_PAD(2), "", 0);
-#endif
+    sv_setpvn(PERL_DEBUG_PAD(1), "", 0);       /* ext/re needs these */
+    sv_setpvn(PERL_DEBUG_PAD(2), "", 0);       /* even without DEBUGGING. */
 
     /* Clone the regex array */
     PL_regex_padav = newAV();
@@ -10278,6 +10333,8 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
     PL_utf8_totitle    = sv_dup_inc(proto_perl->Iutf8_totitle, param);
     PL_utf8_tolower    = sv_dup_inc(proto_perl->Iutf8_tolower, param);
     PL_utf8_tofold     = sv_dup_inc(proto_perl->Iutf8_tofold, param);
+    PL_utf8_idstart    = sv_dup_inc(proto_perl->Iutf8_idstart, param);
+    PL_utf8_idcont     = sv_dup_inc(proto_perl->Iutf8_idcont, param);
 
     /* swatch cache */
     PL_last_swash_hv   = Nullhv;       /* reinits on demand */
@@ -10355,7 +10412,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
        PL_retstack_ix          = proto_perl->Tretstack_ix;
        PL_retstack_max         = proto_perl->Tretstack_max;
        Newz(54, PL_retstack, PL_retstack_max, OP*);
-       Copy(proto_perl->Tretstack, PL_retstack, PL_retstack_ix, I32);
+       Copy(proto_perl->Tretstack, PL_retstack, PL_retstack_ix, OP*);
 
        /* NOTE: si_dup() looks at PL_markstack */
        PL_curstackinfo         = si_dup(proto_perl->Tcurstackinfo, param);