X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=sv.c;h=9a287af96b5b651319465e3518a8862830e8c0f8;hb=484fdf61e8653b10160ba1e8011888f52ab6825a;hp=225ee068385a810b046ac4b2c84015038fe08ff4;hpb=f0faabb7a112c0469c217fed92a3d55cbe5f1735;p=p5sagit%2Fp5-mst-13.2.git diff --git a/sv.c b/sv.c index 225ee06..9a287af 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 || @@ -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; @@ -10089,16 +10152,24 @@ 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); + 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 */ @@ -10119,11 +10190,18 @@ 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; + 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 @@ -10453,7 +10531,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 +10542,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 +10559,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); } +