X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=sv.c;h=fe7c0d46070e8dc588b4c2b121d4156f8822c8cc;hb=02a834a9ae508dc3fab0b5a0375804172985b012;hp=40b7b877f9c11562b51b7ace22708c7a92091bac;hpb=c623ac675720b3145d48cc2ea9474a0f3e0cbbca;p=p5sagit%2Fp5-mst-13.2.git diff --git a/sv.c b/sv.c index 40b7b87..fe7c0d4 100644 --- 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 = '-'; @@ -2875,16 +2875,6 @@ uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob) return ptr; } -/* sv_2pv() is now a macro using Perl_sv_2pv_flags(); - * this function provided for binary compatibility only - */ - -char * -Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp) -{ - return sv_2pv_flags(sv, lp, SV_GMAGIC); -} - /* =for apidoc sv_2pv_flags @@ -2967,7 +2957,7 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) int left = 0; int right = 4; char need_newline = 0; - U16 reganch = (re->reganch & PMf_COMPILETIME) >> 12; + U16 reganch = (U16)((re->reganch & PMf_COMPILETIME) >> 12); while((ch = *fptr++)) { if(reganch & 1) { @@ -3090,7 +3080,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); @@ -3202,14 +3192,16 @@ would lose the UTF-8'ness of the PV. void Perl_sv_copypv(pTHX_ SV *dsv, register SV *ssv) { - SV *tmpsv = sv_newmortal(); + SV *tmpsv; - if ( SvTHINKFIRST(ssv) && SvROK(ssv) && SvAMAGIC(ssv) ) { - tmpsv = AMG_CALLun(ssv,string); + if ( SvTHINKFIRST(ssv) && SvROK(ssv) && SvAMAGIC(ssv) && + (tmpsv = AMG_CALLun(ssv,string))) { if (SvTYPE(tmpsv) != SVt_RV || (SvRV(tmpsv) != SvRV(ssv))) { SvSetSV(dsv,tmpsv); return; } + } else { + tmpsv = sv_newmortal(); } { STRLEN len; @@ -3318,7 +3310,7 @@ Perl_sv_2bool(pTHX_ register SV *sv) SV* tmpsv; if (SvAMAGIC(sv) && (tmpsv=AMG_CALLun(sv,bool_)) && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv)))) - return SvTRUE(tmpsv); + return (bool)SvTRUE(tmpsv); return SvRV(sv) != 0; } if (SvPOKp(sv)) { @@ -3354,21 +3346,6 @@ if all the bytes have hibit clear. This is not as a general purpose byte encoding to Unicode interface: use the Encode extension for that. -=cut -*/ - -/* sv_utf8_upgrade() is now a macro using sv_utf8_upgrade_flags(); - * this function provided for binary compatibility only - */ - - -STRLEN -Perl_sv_utf8_upgrade(pTHX_ register SV *sv) -{ - return sv_utf8_upgrade_flags(sv, SV_GMAGIC); -} - -/* =for apidoc sv_utf8_upgrade_flags Convert the PV of an SV to its UTF8-encoded form. @@ -3552,21 +3529,6 @@ You probably want to use one of the assortment of wrappers, such as C, C, C and C. - -=cut -*/ - -/* sv_setsv() is now a macro using Perl_sv_setsv_flags(); - * this function provided for binary compatibility only - */ - -void -Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr) -{ - sv_setsv_flags(dstr, sstr, SV_GMAGIC); -} - -/* =for apidoc sv_setsv_flags Copies the contents of the source SV C into the destination SV @@ -3746,7 +3708,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; @@ -3755,7 +3717,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); @@ -4286,20 +4248,6 @@ C 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. -=cut -*/ - -/* sv_catpvn() is now a macro using Perl_sv_catpvn_flags(); - * this function provided for binary compatibility only - */ - -void -Perl_sv_catpvn(pTHX_ SV *dsv, const char* sstr, STRLEN slen) -{ - sv_catpvn_flags(dsv, sstr, slen, SV_GMAGIC); -} - -/* =for apidoc sv_catpvn_flags Concatenates the string onto the end of the string which is in the SV. The @@ -4351,19 +4299,6 @@ Concatenates the string from SV C onto the end of the string in SV C. Modifies C but not C. Handles 'get' magic, but not 'set' magic. See C. -=cut */ - -/* sv_catsv() is now a macro using Perl_sv_catsv_flags(); - * this function provided for binary compatibility only - */ - -void -Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr) -{ - sv_catsv_flags(dstr, sstr, SV_GMAGIC); -} - -/* =for apidoc sv_catsv_flags Concatenates the string from SV C onto the end of the string in @@ -4526,7 +4461,13 @@ Perl_sv_magicext(pTHX_ SV* sv, SV* obj, int how, MGVTBL *vtable, /* 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. */ + avoid incrementing the object refcount. + + Note we cannot do this to avoid self-tie loops as intervening RV must + have its REFCNT incremented to keep it in existence - instead we could + special case them in sv_free() -- NI-S + + */ if (!obj || obj == sv || how == PERL_MAGIC_arylen || how == PERL_MAGIC_qr || @@ -5367,14 +5308,16 @@ 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; while (s < send) { - STRLEN n; - /* Call utf8n_to_uvchr() to validate the sequence */ - utf8n_to_uvchr(s, UTF8SKIP(s), &n, 0); + STRLEN n = 1; + /* Call utf8n_to_uvchr() to validate the sequence + * (unless a simple non-UTF character) */ + if (!UTF8_IS_INVARIANT(*s)) + utf8n_to_uvchr(s, UTF8SKIP(s), &n, 0); if (n > 0) { s += n; len++; @@ -5721,7 +5664,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 */ @@ -5807,15 +5750,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 @@ -5889,14 +5832,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: @@ -5932,7 +5875,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; } @@ -5941,13 +5884,18 @@ screamer2: /* Accomodate broken VAXC compiler, which applies U8 cast to * both args of ?: operator, causing EOF to change into 255 */ - if (cnt) { i = (U8)buf[cnt - 1]; } else { i = EOF; } + if (cnt > 0) + i = (U8)buf[cnt - 1]; + else + i = EOF; } + if (cnt < 0) + cnt = 0; /* we do need to re-set the sv even when cnt <= 0 */ if (append) - sv_catpvn(sv, (char *) buf, cnt); + sv_catpvn(sv, (char *) buf, cnt); else - sv_setpvn(sv, (char *) buf, cnt); + sv_setpvn(sv, (char *) buf, cnt); if (i != EOF && /* joy */ (!rslen || @@ -6661,8 +6609,14 @@ Perl_sv_reset(pTHX_ register char *s, HV *stash) if (GvHV(gv) && !HvNAME(GvHV(gv))) { hv_clear(GvHV(gv)); #ifdef USE_ENVIRON_ARRAY - if (gv == PL_envgv) + if (gv == PL_envgv +# ifdef USE_ITHREADS + && PL_curinterp == aTHX +# endif + ) + { environ[0] = Nullch; + } #endif } } @@ -6893,26 +6847,6 @@ Perl_sv_nv(pTHX_ register SV *sv) Use the C macro instead -=cut -*/ - -/* sv_pv() is now a macro using SvPV_nolen(); - * this function provided for binary compatibility only - */ - - -char * -Perl_sv_pv(pTHX_ SV *sv) -{ - STRLEN n_a; - - if (SvPOK(sv)) - return SvPVX(sv); - - return sv_2pv(sv, &n_a); -} - -/* =for apidoc sv_pvn A private implementation of the C macro for compilers which can't @@ -6949,20 +6883,6 @@ Get a sensible string out of the SV somehow. A private implementation of the C macro for compilers which can't cope with complex macro expressions. Always use the macro instead. -=cut -*/ - -/* sv_pvn_force() is now a macro using Perl_sv_pvn_force_flags(); - * this function provided for binary compatibility only - */ - -char * -Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp) -{ - return sv_pvn_force_flags(sv, lp, SV_GMAGIC); -} - -/* =for apidoc sv_pvn_force_flags Get a sensible string out of the SV somehow. @@ -7019,22 +6939,6 @@ Perl_sv_pvn_force_flags(pTHX_ SV *sv, STRLEN *lp, I32 flags) Use C instead. -=cut -*/ - -/* sv_pvbyte () is now a macro using Perl_sv_2pv_flags(); - * this function provided for binary compatibility only - */ - - -char * -Perl_sv_pvbyte(pTHX_ SV *sv) -{ - sv_utf8_downgrade(sv,0); - return sv_pv(sv); -} - -/* =for apidoc sv_pvbyten A private implementation of the C macro for compilers @@ -7073,21 +6977,6 @@ Perl_sv_pvbyten_force(pTHX_ SV *sv, STRLEN *lp) Use the C macro instead -=cut -*/ -/* sv_pvutf8 () is now a macro using Perl_sv_2pv_flags(); - * this function provided for binary compatibility only - */ - - -char * -Perl_sv_pvutf8(pTHX_ SV *sv) -{ - sv_utf8_upgrade(sv); - return sv_pv(sv); -} - -/* =for apidoc sv_pvutf8n A private implementation of the C macro for compilers @@ -7422,9 +7311,6 @@ Perl_sv_bless(pTHX_ SV *sv, HV *stash) } /* Downgrades a PVGV to a PVMG. - * - * XXX This function doesn't actually appear to be used anywhere - * DAPM 15-Jun-01 */ STATIC void @@ -7552,44 +7438,6 @@ Perl_sv_tainted(pTHX_ SV *sv) return FALSE; } -/* -=for apidoc sv_setpviv - -Copies an integer into the given SV, also updating its string value. -Does not handle 'set' magic. See C. - -=cut -*/ - -void -Perl_sv_setpviv(pTHX_ SV *sv, IV iv) -{ - char buf[TYPE_CHARS(UV)]; - char *ebuf; - char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf); - - sv_setpvn(sv, ptr, ebuf - ptr); -} - -/* -=for apidoc sv_setpviv_mg - -Like C, but also handles 'set' magic. - -=cut -*/ - -void -Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv) -{ - char buf[TYPE_CHARS(UV)]; - char *ebuf; - char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf); - - sv_setpvn(sv, ptr, ebuf - ptr); - SvSETMAGIC(sv); -} - #if defined(PERL_IMPLICIT_CONTEXT) /* pTHX_ magic can't cope with varargs, so this is a no-context @@ -7889,7 +7737,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV /* large enough for "%#.#f" --chip */ /* what about long double NVs? --jhi */ - SV *vecsv; + SV *vecsv = Nullsv; U8 *vecstr = Null(U8*); STRLEN veclen = 0; char c = 0; @@ -7897,7 +7745,14 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV unsigned base = 0; IV iv = 0; UV uv = 0; + /* we need a long double target in case HAS_LONG_DOUBLE but + not USE_LONG_DOUBLE + */ +#if defined(HAS_LONG_DOUBLE) && LONG_DOUBLESIZE > DOUBLESIZE + long double nv; +#else NV nv; +#endif STRLEN have; STRLEN need; STRLEN gap; @@ -7922,7 +7777,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV We allow format specification elements in this order: \d+\$ explicit format parameter index [-+ 0#]+ flags - \*?(\d+\$)?v vector with optional (optionally specified) arg + v|\*(\d+\$)?v vector with optional (optionally specified) arg \d+|\*(\d+\$)? width using optional (optionally specified) arg \.(\d*|\*(\d+\$)?) precision using optional (optionally specified) arg [hlqLV] size @@ -8034,7 +7889,10 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV q++; if (*q == '*') { q++; - if (EXPECT_NUMBER(q, epix) && *q++ != '$') /* epix currently unused */ + if (EXPECT_NUMBER(q, epix) && *q++ != '$') + goto unknown; + /* XXX: todo, support specified precision parameter */ + if (epix) goto unknown; if (args) i = va_arg(*args, int); @@ -8073,18 +7931,18 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV q++; break; #endif -#if defined(HAS_QUAD) || (defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)) +#if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE) case 'L': /* Ld */ /* FALL THROUGH */ -#endif #ifdef HAS_QUAD case 'q': /* qd */ +#endif intsize = 'q'; q++; break; #endif case 'l': -#if defined(HAS_QUAD) || (defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)) +#if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE) if (*(q + 1) == 'l') { /* lld, llf */ intsize = 'q'; q += 2; @@ -8107,7 +7965,9 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV goto string; } - if (!args) + if (vectorize) + argsv = vecsv; + else if (!args) argsv = (efix ? efix <= svmax : svix < svmax) ? svargs[efix ? efix-1 : svix++] : &PL_sv_undef; @@ -8116,7 +7976,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV /* STRINGS */ case 'c': - uv = args ? va_arg(*args, int) : SvIVx(argsv); + uv = (args && !vectorize) ? va_arg(*args, int) : SvIVx(argsv); if ((uv > 255 || (!UNI_IS_INVARIANT(uv) && SvUTF8(sv))) && !IN_BYTES) { @@ -8132,7 +7992,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV goto string; case 's': - if (args) { + if (args && !vectorize) { eptr = va_arg(*args, char*); if (eptr) #ifdef MACOS_TRADITIONAL @@ -8169,7 +8029,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV * if ISO or ANSI decide to use '_' for something. * So we keep it hidden from users' code. */ - if (!args) + if (!args || vectorize) goto unknown; argsv = va_arg(*args, SV*); eptr = SvPVx(argsv, elen); @@ -8185,7 +8045,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV /* INTEGERS */ case 'p': - if (alt) + if (alt || vectorize) goto unknown; uv = PTR2UV(args ? va_arg(*args, void*) : argsv); base = 16; @@ -8400,12 +8260,50 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV /* This is evil, but floating point is even more evil */ - vectorize = FALSE; - nv = args ? va_arg(*args, NV) : SvNVx(argsv); + /* for SV-style calling, we can only get NV + for C-style calling, we assume %f is double; + for simplicity we allow any of %Lf, %llf, %qf for long double + */ + switch (intsize) { + case 'V': +#if defined(USE_LONG_DOUBLE) + intsize = 'q'; +#endif + break; + default: +#if defined(USE_LONG_DOUBLE) + intsize = args ? 0 : 'q'; +#endif + break; + case 'q': +#if defined(HAS_LONG_DOUBLE) + break; +#else + /* FALL THROUGH */ +#endif + case 'h': + /* FALL THROUGH */ + case 'l': + goto unknown; + } + + /* now we need (long double) if intsize == 'q', else (double) */ + nv = (args && !vectorize) ? +#if LONG_DOUBLESIZE > DOUBLESIZE + intsize == 'q' ? + va_arg(*args, long double) : + va_arg(*args, double) +#else + va_arg(*args, double) +#endif + : SvNVx(argsv); need = 0; + vectorize = FALSE; if (c != 'e' && c != 'E') { i = PERL_INT_MIN; + /* FIXME: if HAS_LONG_DOUBLE but not USE_LONG_DOUBLE this + will cast our (long double) to (double) */ (void)Perl_frexp(nv, &i); if (i == PERL_INT_MIN) Perl_die(aTHX_ "panic: frexp"); @@ -8427,8 +8325,9 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV eptr = ebuf + sizeof ebuf; *--eptr = '\0'; *--eptr = c; -#if defined(USE_LONG_DOUBLE) && defined(PERL_PRIfldbl) - { + /* FIXME: what to do if HAS_LONG_DOUBLE but not PERL_PRIfldbl? */ +#if defined(HAS_LONG_DOUBLE) && defined(PERL_PRIfldbl) + if (intsize == 'q') { /* Copy the one or more characters in a long double * format before the 'base' ([efgEFG]) character to * the format string. */ @@ -8459,8 +8358,14 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV /* No taint. Otherwise we are in the strange situation * where printf() taints but print($float) doesn't. * --jhi */ +#if defined(HAS_LONG_DOUBLE) + if (intsize == 'q') + (void)sprintf(PL_efloatbuf, eptr, nv); + else + (void)sprintf(PL_efloatbuf, eptr, (double)nv); +#else (void)sprintf(PL_efloatbuf, eptr, nv); - +#endif eptr = PL_efloatbuf; elen = strlen(PL_efloatbuf); break; @@ -8468,9 +8373,8 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV /* SPECIAL */ case 'n': - vectorize = FALSE; i = SvCUR(sv) - origlen; - if (args) { + if (args && !vectorize) { switch (intsize) { case 'h': *(va_arg(*args, short*)) = i; break; default: *(va_arg(*args, int*)) = i; break; @@ -8483,6 +8387,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV } else sv_setuv_mg(argsv, (UV)i); + vectorize = FALSE; continue; /* not "break" */ /* UNKNOWN */ @@ -8547,7 +8452,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) { @@ -8555,7 +8460,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) { @@ -8916,7 +8821,6 @@ Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, void *oldv, void *newv) for (tblent = *otblent; tblent; i=0, tblent = tblent->next) { if (tblent->oldval == oldv) { tblent->newval = newv; - tbl->tbl_items++; return; } } @@ -9018,10 +8922,10 @@ char *PL_watch_pvx; /* attempt to make everything in the typeglob readonly */ STATIC SV * -S_gv_share(pTHX_ SV *sstr) +S_gv_share(pTHX_ SV *sstr, CLONE_PARAMS *param) { GV *gv = (GV*)sstr; - SV *sv = &PL_sv_no; /* just need SvREADONLY-ness */ + SV *sv = ¶m->proto_perl->Isv_no; /* just need SvREADONLY-ness */ if (GvIO(gv) || GvFORM(gv)) { GvUNIQUE_off(gv); /* GvIOs cannot be shared. nor can GvFORMs */ @@ -9031,7 +8935,7 @@ S_gv_share(pTHX_ SV *sstr) } else { /* CvPADLISTs cannot be shared */ - if (!CvXSUB(GvCV(gv))) { + if (!SvREADONLY(GvCV(gv)) && !CvXSUB(GvCV(gv))) { GvUNIQUE_off(gv); } } @@ -9212,9 +9116,10 @@ Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param) case SVt_PVGV: if (GvUNIQUE((GV*)sstr)) { SV *share; - if ((share = gv_share(sstr))) { + if ((share = gv_share(sstr, param))) { del_SV(dstr); dstr = share; + ptr_table_store(PL_ptr_table, sstr, dstr); #if 0 PerlIO_printf(Perl_debug_log, "sv_dup: sharing %s::%s\n", HvNAME(GvSTASH(share)), GvNAME(share)); @@ -9324,10 +9229,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; @@ -9387,7 +9294,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; } @@ -9447,7 +9354,7 @@ Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, CLONE_PARAMS* param) case CXt_EVAL: ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval; ncx->blk_eval.old_op_type = cx->blk_eval.old_op_type; - ncx->blk_eval.old_namesv = sv_dup_inc(cx->blk_eval.old_namesv, param);; + ncx->blk_eval.old_namesv = sv_dup_inc(cx->blk_eval.old_namesv, param); ncx->blk_eval.old_eval_root = cx->blk_eval.old_eval_root; ncx->blk_eval.cur_text = sv_dup(cx->blk_eval.cur_text, param); break; @@ -9872,7 +9779,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PERL_SET_THX(my_perl); # ifdef DEBUGGING - memset(my_perl, 0xab, sizeof(PerlInterpreter)); + Poison(my_perl, 1, PerlInterpreter); PL_markstack = 0; PL_scopestack = 0; PL_savestack = 0; @@ -9903,7 +9810,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, # ifdef DEBUGGING - memset(my_perl, 0xab, sizeof(PerlInterpreter)); + Poison(my_perl, 1, PerlInterpreter); PL_markstack = 0; PL_scopestack = 0; PL_savestack = 0; @@ -9915,6 +9822,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, # endif /* DEBUGGING */ #endif /* PERL_IMPLICIT_SYS */ param->flags = flags; + param->proto_perl = proto_perl; /* arena roots */ PL_xiv_arenaroot = NULL; @@ -10252,16 +10160,29 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, Copy(proto_perl->Inexttype, PL_nexttype, 5, I32); PL_nexttoke = proto_perl->Inexttoke; - PL_linestr = sv_dup_inc(proto_perl->Ilinestr, param); - i = proto_perl->Ibufptr - SvPVX(proto_perl->Ilinestr); - PL_bufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i); - i = proto_perl->Ioldbufptr - SvPVX(proto_perl->Ilinestr); - PL_oldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i); - i = proto_perl->Ioldoldbufptr - SvPVX(proto_perl->Ilinestr); - PL_oldoldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i); + /* XXX This is probably masking the deeper issue of why + * SvANY(proto_perl->Ilinestr) can be NULL at this point. For test case: + * http://archive.develooper.com/perl5-porters%40perl.org/msg83298.html + * (A little debugging with a watchpoint on it may help.) + */ + if (SvANY(proto_perl->Ilinestr)) { + PL_linestr = sv_dup_inc(proto_perl->Ilinestr, param); + i = proto_perl->Ibufptr - SvPVX(proto_perl->Ilinestr); + PL_bufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i); + i = proto_perl->Ioldbufptr - SvPVX(proto_perl->Ilinestr); + PL_oldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i); + i = proto_perl->Ioldoldbufptr - SvPVX(proto_perl->Ilinestr); + PL_oldoldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i); + i = proto_perl->Ilinestart - SvPVX(proto_perl->Ilinestr); + PL_linestart = SvPVX(PL_linestr) + (i < 0 ? 0 : i); + } + else { + PL_linestr = NEWSV(65,79); + sv_upgrade(PL_linestr,SVt_PVIV); + sv_setpvn(PL_linestr,"",0); + PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr); + } PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); - i = proto_perl->Ilinestart - SvPVX(proto_perl->Ilinestr); - PL_linestart = SvPVX(PL_linestr) + (i < 0 ? 0 : i); PL_pending_ident = proto_perl->Ipending_ident; PL_sublex_info = proto_perl->Isublex_info; /* XXX not quite right */ @@ -10282,11 +10203,19 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_padix_floor = proto_perl->Ipadix_floor; PL_pad_reset_pending = proto_perl->Ipad_reset_pending; - i = proto_perl->Ilast_uni - SvPVX(proto_perl->Ilinestr); - PL_last_uni = SvPVX(PL_linestr) + (i < 0 ? 0 : i); - i = proto_perl->Ilast_lop - SvPVX(proto_perl->Ilinestr); - PL_last_lop = SvPVX(PL_linestr) + (i < 0 ? 0 : i); - PL_last_lop_op = proto_perl->Ilast_lop_op; + /* XXX See comment on SvANY(proto_perl->Ilinestr) above */ + if (SvANY(proto_perl->Ilinestr)) { + i = proto_perl->Ilast_uni - SvPVX(proto_perl->Ilinestr); + PL_last_uni = SvPVX(PL_linestr) + (i < 0 ? 0 : i); + i = proto_perl->Ilast_lop - SvPVX(proto_perl->Ilinestr); + PL_last_lop = SvPVX(PL_linestr) + (i < 0 ? 0 : i); + PL_last_lop_op = proto_perl->Ilast_lop_op; + } + else { + PL_last_uni = SvPVX(PL_linestr); + PL_last_lop = SvPVX(PL_linestr); + PL_last_lop_op = 0; + } PL_in_my = proto_perl->Iin_my; PL_in_my_stash = hv_dup(proto_perl->Iin_my_stash, param); #ifdef FCRYPT @@ -10410,7 +10339,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); @@ -10616,7 +10545,7 @@ The PV of the sv is returned. char * Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding) { - if (SvPOK(sv) && !DO_UTF8(sv) && SvROK(encoding)) { + if (SvPOK(sv) && !DO_UTF8(sv) && SvROK(encoding)) { SV *uni; STRLEN len; char *s; @@ -10627,7 +10556,16 @@ Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding) EXTEND(SP, 3); XPUSHs(encoding); XPUSHs(sv); +/* + NI-S 2002/07/09 + Passing sv_yes is wrong - it needs to be or'ed set of constants + for Encode::XS, while UTf-8 decode (currently) assumes a true value means + remove converted chars from source. + + Both will default the value - let them. + XPUSHs(&PL_sv_yes); +*/ PUTBACK; call_method("decode", G_SCALAR); SPAGAIN; @@ -10635,15 +10573,17 @@ Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding) PUTBACK; s = SvPV(uni, len); if (s != SvPVX(sv)) { - SvGROW(sv, len); + SvGROW(sv, len + 1); Move(s, SvPVX(sv), len, char); SvCUR_set(sv, len); + SvPVX(sv)[len] = 0; } FREETMPS; LEAVE; SvUTF8_on(sv); - } - return SvPVX(sv); + } + return SvPVX(sv); } +