X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=sv.c;h=076ea5c8962c1bdf794a9d7c0ea1dc12aa0174e7;hb=8c9849ff798160d7f115286b222762e1c4e65f66;hp=7e6bc2d7e4f514bda63e150dbed0f8d77b82e1cb;hpb=a6bdc2eb98f4e9bd74b51ad84203021dea610d6b;p=p5sagit%2Fp5-mst-13.2.git diff --git a/sv.c b/sv.c index 7e6bc2d..076ea5c 100644 --- a/sv.c +++ b/sv.c @@ -3192,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; @@ -4459,16 +4461,20 @@ 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 || (SvTYPE(obj) == SVt_PVGV && (GvSV(obj) == sv || GvHV(obj) == (HV*)sv || GvAV(obj) == (AV*)sv || GvCV(obj) == (CV*)sv || GvIOp(obj) == (IO*)sv || - GvFORM(obj) == (CV*)sv)) || - (how == PERL_MAGIC_tiedscalar && - SvROK(obj) && (SvRV(obj) == sv || GvIO(SvRV(obj)) == (IO*)sv))) + GvFORM(obj) == (CV*)sv))) { mg->mg_obj = obj; } @@ -5307,9 +5313,11 @@ Perl_sv_pos_b2u(pTHX_ register SV *sv, I32* offsetp) 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++; @@ -5876,13 +5884,15 @@ 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 (append) - sv_catpvn(sv, (char *) buf, cnt); - else - sv_setpvn(sv, (char *) buf, cnt); + if (cnt > 0) { + if (append) + sv_catpvn(sv, (char *) buf, cnt); + else + sv_setpvn(sv, (char *) buf, cnt); + } if (i != EOF && /* joy */ (!rslen || @@ -6336,7 +6346,7 @@ Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash) len = tmplen; } if (!hash) - PERL_HASH(hash, (U8*)src, len); + PERL_HASH(hash, src, len); new_SV(sv); sv_upgrade(sv, SVt_PVIV); SvPVX(sv) = sharepvn(src, is_utf8?-len:len, hash); @@ -7732,7 +7742,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; @@ -7908,18 +7925,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; @@ -8236,11 +8253,49 @@ 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 ? +#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; 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"); @@ -8262,8 +8317,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. */ @@ -8294,8 +8350,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; @@ -8751,7 +8813,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; } } @@ -8853,10 +8914,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 */ @@ -8866,7 +8927,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); } } @@ -9047,9 +9108,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)); @@ -9284,7 +9346,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; @@ -9709,7 +9771,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; @@ -9740,7 +9802,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; @@ -9752,6 +9814,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; @@ -10453,7 +10516,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; @@ -10464,7 +10527,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; @@ -10472,15 +10544,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); } +