X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=sv.c;h=4e6d930ed215c9f0ae0852236d7329b82d250777;hb=ca9279baf07d6843f58a31f1ce3ff7dc875faf1a;hp=6eef6264cc99562fbf6304b906523593fa22d0fa;hpb=a4bfb2902c7fff0a7b1981922fca3ac7c05b580a;p=p5sagit%2Fp5-mst-13.2.git diff --git a/sv.c b/sv.c index 6eef626..4e6d930 100644 --- a/sv.c +++ b/sv.c @@ -1,6 +1,7 @@ /* sv.c * - * Copyright (c) 1991-2002, Larry Wall + * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, + * 2000, 2001, 2002, 2003, by Larry Wall and others * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -28,10 +29,6 @@ #define SV_COW_NEXT_SV_SET(current,next) SvUVX(current) = PTR2UV(next) /* This is a pessimistic view. Scalar must be purely a read-write PV to copy- on-write. */ -#define CAN_COW_MASK (SVs_OBJECT|SVs_GMG|SVs_SMG|SVs_RMG|SVf_IOK|SVf_NOK| \ - SVf_POK|SVf_ROK|SVp_IOK|SVp_NOK|SVp_POK|SVf_FAKE| \ - SVf_OOK|SVf_BREAK|SVf_READONLY|SVf_AMAGIC) -#define CAN_COW_FLAGS (SVp_POK|SVf_POK) #endif /* ============================================================================ @@ -1566,8 +1563,6 @@ Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen) { register char *s; - - #ifdef HAS_64K_LIMIT if (newlen >= 0x10000) { PerlIO_printf(Perl_debug_log, @@ -2279,7 +2274,7 @@ Perl_sv_2iv(pTHX_ register SV *sv) this NV is in the preserved range, therefore: */ if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv)) < (UV)IV_MAX)) { - Perl_croak(aTHX_ "sv_2iv assumed (U_V(fabs(SvNVX(sv))) < (UV)IV_MAX) but SvNVX(sv)=%"NVgf" U_V is 0x%"UVxf", IV_MAX is 0x%"UVxf"\n", SvNVX(sv), U_V(SvNVX(sv)), (UV)IV_MAX); + Perl_croak(aTHX_ "sv_2iv assumed (U_V(fabs((double)SvNVX(sv))) < (UV)IV_MAX) but SvNVX(sv)=%"NVgf" U_V is 0x%"UVxf", IV_MAX is 0x%"UVxf"\n", SvNVX(sv), U_V(SvNVX(sv)), (UV)IV_MAX); } } else { /* IN_UV NOT_INT @@ -2566,7 +2561,7 @@ Perl_sv_2uv(pTHX_ register SV *sv) this NV is in the preserved range, therefore: */ if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv)) < (UV)IV_MAX)) { - Perl_croak(aTHX_ "sv_2uv assumed (U_V(fabs(SvNVX(sv))) < (UV)IV_MAX) but SvNVX(sv)=%"NVgf" U_V is 0x%"UVxf", IV_MAX is 0x%"UVxf"\n", SvNVX(sv), U_V(SvNVX(sv)), (UV)IV_MAX); + Perl_croak(aTHX_ "sv_2uv assumed (U_V(fabs((double)SvNVX(sv))) < (UV)IV_MAX) but SvNVX(sv)=%"NVgf" U_V is 0x%"UVxf", IV_MAX is 0x%"UVxf"\n", SvNVX(sv), U_V(SvNVX(sv)), (UV)IV_MAX); } } else sv_2iuv_non_preserve (sv, numtype); @@ -2895,6 +2890,16 @@ 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 @@ -2972,7 +2977,7 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) case SVt_PVMG: if ( ((SvFLAGS(sv) & (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG)) - == (SVs_OBJECT|SVs_RMG)) + == (SVs_OBJECT|SVs_SMG)) && (mg = mg_find(sv, PERL_MAGIC_qr))) { regexp *re = (regexp *)mg->mg_obj; @@ -3064,7 +3069,7 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) s = "REF"; else s = "SCALAR"; break; - case SVt_PVLV: s = "LVALUE"; break; + case SVt_PVLV: s = SvROK(sv) ? "REF":"LVALUE"; break; case SVt_PVAV: s = "ARRAY"; break; case SVt_PVHV: s = "HASH"; break; case SVt_PVCV: s = "CODE"; break; @@ -3075,7 +3080,10 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) } tsv = NEWSV(0,0); if (SvOBJECT(sv)) - Perl_sv_setpvf(aTHX_ tsv, "%s=%s", HvNAME(SvSTASH(sv)), s); + if (HvNAME(SvSTASH(sv))) + Perl_sv_setpvf(aTHX_ tsv, "%s=%s", HvNAME(SvSTASH(sv)), s); + else + Perl_sv_setpvf(aTHX_ tsv, "__ANON__=%s", s); else sv_setpv(tsv, s); Perl_sv_catpvf(aTHX_ tsv, "(0x%"UVxf")", PTR2UV(sv)); @@ -3346,6 +3354,17 @@ Perl_sv_2bool(pTHX_ register SV *sv) } } +/* 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 @@ -3528,6 +3547,16 @@ Perl_sv_utf8_decode(pTHX_ register SV *sv) return TRUE; } +/* 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 @@ -3658,8 +3687,16 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) goto glob_assign; } break; - case SVt_PV: case SVt_PVFM: +#ifdef PERL_COPY_ON_WRITE + if ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS) { + if (dtype < SVt_PVIV) + sv_upgrade(dstr, SVt_PVIV); + break; + } + /* Fall through */ +#endif + case SVt_PV: if (dtype < SVt_PV) sv_upgrade(dstr, SVt_PV); break; @@ -3944,8 +3981,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) /* Either it's a shared hash key, or it's suitable for copy-on-write or we can swipe the string. */ if (DEBUG_C_TEST) { - PerlIO_printf(Perl_debug_log, - "Copy on write: sstr --> dstr\n"); + PerlIO_printf(Perl_debug_log, "Copy on write: sstr --> dstr\n"); sv_dump(sstr); sv_dump(dstr); } @@ -3982,6 +4018,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) /* making another shared SV. */ STRLEN cur = SvCUR(sstr); STRLEN len = SvLEN(sstr); + assert (SvTYPE(dstr) >= SVt_PVIV); if (len) { /* SvIsCOW_normal */ /* splice us in between source and next-after-source. */ @@ -4098,6 +4135,77 @@ Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr) SvSETMAGIC(dstr); } +#ifdef PERL_COPY_ON_WRITE +SV * +Perl_sv_setsv_cow(pTHX_ SV *dstr, SV *sstr) +{ + STRLEN cur = SvCUR(sstr); + STRLEN len = SvLEN(sstr); + register char *new_pv; + + if (DEBUG_C_TEST) { + PerlIO_printf(Perl_debug_log, "Fast copy on write: %p -> %p\n", + sstr, dstr); + sv_dump(sstr); + if (dstr) + sv_dump(dstr); + } + + if (dstr) { + if (SvTHINKFIRST(dstr)) + sv_force_normal_flags(dstr, SV_COW_DROP_PV); + else if (SvPVX(dstr)) + Safefree(SvPVX(dstr)); + } + else + new_SV(dstr); + SvUPGRADE (dstr, SVt_PVIV); + + assert (SvPOK(sstr)); + assert (SvPOKp(sstr)); + assert (!SvIOK(sstr)); + assert (!SvIOKp(sstr)); + assert (!SvNOK(sstr)); + assert (!SvNOKp(sstr)); + + if (SvIsCOW(sstr)) { + + if (SvLEN(sstr) == 0) { + /* source is a COW shared hash key. */ + UV hash = SvUVX(sstr); + DEBUG_C(PerlIO_printf(Perl_debug_log, + "Fast copy on write: Sharing hash\n")); + SvUVX(dstr) = hash; + new_pv = sharepvn(SvPVX(sstr), (SvUTF8(sstr)?-cur:cur), hash); + goto common_exit; + } + SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr)); + } else { + assert ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS); + SvUPGRADE (sstr, SVt_PVIV); + SvREADONLY_on(sstr); + SvFAKE_on(sstr); + DEBUG_C(PerlIO_printf(Perl_debug_log, + "Fast copy on write: Converting sstr to COW\n")); + SV_COW_NEXT_SV_SET(dstr, sstr); + } + SV_COW_NEXT_SV_SET(sstr, dstr); + new_pv = SvPVX(sstr); + + common_exit: + SvPV_set(dstr, new_pv); + SvFLAGS(dstr) = (SVt_PVIV|SVf_POK|SVp_POK|SVf_FAKE|SVf_READONLY); + if (SvUTF8(sstr)) + SvUTF8_on(dstr); + SvLEN(dstr) = len; + SvCUR(dstr) = cur; + if (DEBUG_C_TEST) { + sv_dump(dstr); + } + return dstr; +} +#endif + /* =for apidoc sv_setpvn @@ -4299,7 +4407,7 @@ an xpvmg; if we're a copy-on-write scalar, this is the on-write time when we do the copy, and is also used locally. If C is set then a copy-on-write scalar drops its PV buffer (if any) and becomes SvPOK_off rather than making a copy. (Used where this scalar is about to be -set to some other value. In addtion, the C parameter gets passed to +set to some other value.) In addition, the C parameter gets passed to C when unrefing. C calls this function with flags set to 0. @@ -4353,11 +4461,11 @@ Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags) char *pvx = SvPVX(sv); STRLEN len = SvCUR(sv); U32 hash = SvUVX(sv); + SvFAKE_off(sv); + SvREADONLY_off(sv); SvGROW(sv, len + 1); Move(pvx,SvPVX(sv),len,char); *SvEND(sv) = '\0'; - SvFAKE_off(sv); - SvREADONLY_off(sv); unsharepvn(pvx, SvUTF8(sv) ? -(I32)len : len, hash); } else if (PL_curcop != &PL_compiling) @@ -4393,6 +4501,8 @@ Efficient removal of characters from the beginning of the string buffer. SvPOK(sv) must be true and the C must be a pointer to somewhere inside the string buffer. The C becomes the first character of the adjusted string. Uses the "OOK hack". +Beware: after this function returns, C and SvPVX(sv) may no longer +refer to the same chunk of data. =cut */ @@ -4401,9 +4511,9 @@ void Perl_sv_chop(pTHX_ register SV *sv, register char *ptr) { register STRLEN delta; - if (!ptr || !SvPOKp(sv)) return; + delta = ptr - SvPVX(sv); SV_CHECK_THINKFIRST(sv); if (SvTYPE(sv) < SVt_PVIV) sv_upgrade(sv,SVt_PVIV); @@ -4423,13 +4533,22 @@ Perl_sv_chop(pTHX_ register SV *sv, register char *ptr) SvFLAGS(sv) |= SVf_OOK; } SvNIOK_off(sv); - delta = ptr - SvPVX(sv); SvLEN(sv) -= delta; SvCUR(sv) -= delta; SvPVX(sv) += delta; SvIVX(sv) += delta; } +/* 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 @@ -4482,6 +4601,16 @@ Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRL SvSETMAGIC(sv); } +/* 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 @@ -4964,7 +5093,19 @@ S_sv_add_backref(pTHX_ SV *tsv, SV *sv) sv_magic(tsv, (SV*)av, PERL_MAGIC_backref, NULL, 0); SvREFCNT_dec(av); /* for sv_magic */ } - av_push(av,sv); + if (AvFILLp(av) >= AvMAX(av)) { + SV **svp = AvARRAY(av); + I32 i = AvFILLp(av); + while (i >= 0) { + if (svp[i] == &PL_sv_undef) { + svp[i] = sv; /* reuse the slot */ + return; + } + i--; + } + av_extend(av, AvFILLp(av)+1); + } + AvARRAY(av)[++AvFILLp(av)] = sv; /* av_push() */ } /* delete a back-reference to ourselves from the backref magic associated @@ -5172,34 +5313,37 @@ Perl_sv_clear(pTHX_ register SV *sv) if (PL_defstash) { /* Still have a symbol table? */ dSP; CV* destructor; - SV tmpref; - Zero(&tmpref, 1, SV); - sv_upgrade(&tmpref, SVt_RV); - SvROK_on(&tmpref); - SvREADONLY_on(&tmpref); /* DESTROY() could be naughty */ - SvREFCNT(&tmpref) = 1; + do { stash = SvSTASH(sv); destructor = StashHANDLER(stash,DESTROY); if (destructor) { + SV* tmpref = newRV(sv); + SvREADONLY_on(tmpref); /* DESTROY() could be naughty */ ENTER; PUSHSTACKi(PERLSI_DESTROY); - SvRV(&tmpref) = SvREFCNT_inc(sv); EXTEND(SP, 2); PUSHMARK(SP); - PUSHs(&tmpref); + PUSHs(tmpref); PUTBACK; call_sv((SV*)destructor, G_DISCARD|G_EVAL|G_KEEPERR|G_VOID); - SvREFCNT(sv)--; + + POPSTACK; SPAGAIN; LEAVE; + if(SvREFCNT(tmpref) < 2) { + /* tmpref is not kept alive! */ + SvREFCNT(sv)--; + SvRV(tmpref) = 0; + SvROK_off(tmpref); + } + SvREFCNT_dec(tmpref); } } while (SvOBJECT(sv) && SvSTASH(sv) != stash); - del_XRV(SvANY(&tmpref)); if (SvREFCNT(sv)) { if (PL_in_clean_objs) @@ -5253,7 +5397,13 @@ Perl_sv_clear(pTHX_ register SV *sv) av_undef((AV*)sv); break; case SVt_PVLV: - SvREFCNT_dec(LvTARG(sv)); + if (LvTYPE(sv) == 'T') { /* for tie: return HE to pool */ + SvREFCNT_dec(HeKEY_sv((HE*)LvTARG(sv))); + HeNEXT((HE*)LvTARG(sv)) = PL_hv_fetch_ent_mh; + PL_hv_fetch_ent_mh = (HE*)LvTARG(sv); + } + else if (LvTYPE(sv) != 't') /* unless tie: unrefcnted fake SV** */ + SvREFCNT_dec(LvTARG(sv)); goto freescalar; case SVt_PVGV: gp_free((GV*)sv); @@ -5386,7 +5536,7 @@ SV * Perl_sv_newref(pTHX_ SV *sv) { if (sv) - ATOMIC_INC(SvREFCNT(sv)); + (SvREFCNT(sv))++; return sv; } @@ -5404,8 +5554,6 @@ Normally called via a wrapper macro C. void Perl_sv_free(pTHX_ SV *sv) { - int refcount_is_zero; - if (!sv) return; if (SvREFCNT(sv) == 0) { @@ -5424,9 +5572,14 @@ Perl_sv_free(pTHX_ SV *sv) Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "Attempt to free unreferenced scalar"); return; } - ATOMIC_DEC_AND_TEST(refcount_is_zero, SvREFCNT(sv)); - if (!refcount_is_zero) + if (--(SvREFCNT(sv)) > 0) return; + Perl_sv_free2(aTHX_ sv); +} + +void +Perl_sv_free2(pTHX_ SV *sv) +{ #ifdef DEBUGGING if (SvTEMP(sv)) { if (ckWARN_d(WARN_DEBUGGING)) @@ -5765,13 +5918,13 @@ Perl_sv_pos_b2u(pTHX_ register SV* sv, I32* offsetp) mg = mg_find(sv, PERL_MAGIC_utf8); if (mg && mg->mg_ptr) { cache = (STRLEN *) mg->mg_ptr; - if (cache[1] == *offsetp) { + if (cache[1] == (STRLEN)*offsetp) { /* An exact match. */ *offsetp = cache[0]; return; } - else if (cache[1] < *offsetp) { + else if (cache[1] < (STRLEN)*offsetp) { /* We already know part of the way. */ len = cache[0]; s += cache[1]; @@ -5794,13 +5947,15 @@ Perl_sv_pos_b2u(pTHX_ register SV* sv, I32* offsetp) while (backw--) { p--; - while (UTF8_IS_CONTINUATION(*p)) + while (UTF8_IS_CONTINUATION(*p)) { p--; + backw--; + } ubackw++; } cache[0] -= ubackw; - + *offsetp = cache[0]; return; } } @@ -6159,7 +6314,8 @@ Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append) I32 rspara = 0; I32 recsize; - SV_CHECK_THINKFIRST_COW_DROP(sv); + if (SvTHINKFIRST(sv)) + sv_force_normal_flags(sv, append ? 0 : SV_COW_DROP_PV); /* XXX. If you make this PVIV, then copy on write can copy scalars read from <>. However, perlbench says it's slower, because the existing swipe code @@ -6168,7 +6324,27 @@ Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append) (void)SvUPGRADE(sv, SVt_PV); SvSCREAM_off(sv); - SvPOK_only(sv); /* Validate pointer */ + + if (append) { + if (PerlIO_isutf8(fp)) { + if (!SvUTF8(sv)) { + sv_utf8_upgrade_nomg(sv); + sv_pos_u2b(sv,&append,0); + } + } else if (SvUTF8(sv)) { + SV *tsv = NEWSV(0,0); + sv_gets(tsv, fp, 0); + sv_utf8_upgrade_nomg(tsv); + SvCUR_set(sv,append); + sv_catsv(sv,tsv); + sv_free(tsv); + goto return_string_or_null; + } + } + + SvPOK_only(sv); + if (PerlIO_isutf8(fp)) + SvUTF8_on(sv); if (PL_curcop == &PL_compiling) { /* we always read code in line mode */ @@ -6184,7 +6360,7 @@ Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append) Stat_t st; if (!PerlLIO_fstat(PerlIO_fileno(fp), &st) && S_ISREG(st.st_mode)) { Off_t offset = PerlIO_tell(fp); - if (offset != (Off_t) -1) { + if (offset != (Off_t) -1 && st.st_size + append > offset) { (void) SvGROW(sv, (STRLEN)((st.st_size - offset) + append + 1)); } } @@ -6209,9 +6385,11 @@ Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append) #else bytesread = PerlIO_read(fp, buffer, recsize); #endif + if (bytesread < 0) + bytesread = 0; SvCUR_set(sv, bytesread += append); buffer[bytesread] = '\0'; - goto check_utf8_and_return; + goto return_string_or_null; } else if (RsPARA(PL_rs)) { rsptr = "\n\n"; @@ -6464,12 +6642,7 @@ screamer2: } } -check_utf8_and_return: - if (PerlIO_isutf8(fp)) - SvUTF8_on(sv); - else - SvUTF8_off(sv); - +return_string_or_null: return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch; } @@ -7379,6 +7552,21 @@ Perl_sv_nv(pTHX_ register SV *sv) return sv_2nv(sv); } +/* 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_pv @@ -7413,6 +7601,16 @@ Perl_sv_pvn_nomg(pTHX_ register SV *sv, STRLEN *lp) return sv_2pv_flags(sv, lp, 0); } +/* 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 @@ -7471,6 +7669,17 @@ Perl_sv_pvn_force_flags(pTHX_ SV *sv, STRLEN *lp, I32 flags) return SvPVX(sv); } +/* 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_pvbyte @@ -7509,6 +7718,17 @@ Perl_sv_pvbyten_force(pTHX_ SV *sv, STRLEN *lp) return sv_pvn_force(sv,lp); } +/* 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_pvutf8 @@ -7559,7 +7779,10 @@ char * Perl_sv_reftype(pTHX_ SV *sv, int ob) { if (ob && SvOBJECT(sv)) { - return HvNAME(SvSTASH(sv)); + if (HvNAME(SvSTASH(sv))) + return HvNAME(SvSTASH(sv)); + else + return "__ANON__"; } else { switch (SvTYPE(sv)) { @@ -7578,7 +7801,7 @@ Perl_sv_reftype(pTHX_ SV *sv, int ob) return "REF"; else return "SCALAR"; - case SVt_PVLV: return "LVALUE"; + case SVt_PVLV: return SvROK(sv) ? "REF" : "LVALUE"; case SVt_PVAV: return "ARRAY"; case SVt_PVHV: return "HASH"; case SVt_PVCV: return "CODE"; @@ -7637,6 +7860,8 @@ Perl_sv_isa(pTHX_ SV *sv, const char *name) sv = (SV*)SvRV(sv); if (!SvOBJECT(sv)) return 0; + if (!HvNAME(SvSTASH(sv))) + return 0; return strEQ(HvNAME(SvSTASH(sv)), name); } @@ -7976,6 +8201,44 @@ 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 @@ -8209,7 +8472,11 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV I32 svix = 0; static char nullstr[] = "(null)"; SV *argsv = Nullsv; - bool has_utf8 = FALSE; /* has the result utf8? */ + bool has_utf8; /* has the result utf8? */ + bool pat_utf8; /* the pattern is in utf8? */ + SV *nsv = Nullsv; + + has_utf8 = pat_utf8 = DO_UTF8(sv); /* no matter what, this is a string now */ (void)SvPV_force(sv, origlen); @@ -8260,6 +8527,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; + I32 osvix = svix; bool is_utf8 = FALSE; /* is this item utf8? */ #ifdef HAS_LDBL_SPRINTF_BUG /* This is to try to fix a bug with irix/nonstop-ux/powerux and @@ -8310,7 +8578,10 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV /* echo everything up to the next format specification */ for (q = p; q < patend && *q != '%'; ++q) ; if (q > p) { - sv_catpvn(sv, p, q - p); + if (has_utf8 && !pat_utf8) + sv_catpvn_utf8_upgrade(sv, p, q - p, nsv); + else + sv_catpvn(sv, p, q - p); p = q; } if (q++ >= patend) @@ -8321,6 +8592,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV \d+\$ explicit format parameter index [-+ 0#]+ flags v|\*(\d+\$)?v vector with optional (optionally specified) arg + 0 flag (as above): repeated to allow "v02" \d+|\*(\d+\$)? width using optional (optionally specified) arg \.(\d*|\*(\d+\$)?) precision using optional (optionally specified) arg [hlqLV] size @@ -8386,6 +8658,8 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV } if (!asterisk) + if( *q == '0' ) + fill = *q++; EXPECT_NUMBER(q, width); if (vectorize) { @@ -8813,6 +9087,9 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV intsize = 'q'; #endif break; +/* [perl #20339] - we should accept and ignore %lf rather than die */ + case 'l': + /* FALL THROUGH */ default: #if defined(USE_LONG_DOUBLE) intsize = args ? 0 : 'q'; @@ -8825,8 +9102,6 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV /* FALL THROUGH */ #endif case 'h': - /* FALL THROUGH */ - case 'l': goto unknown; } @@ -9004,7 +9279,6 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV default: unknown: - vectorize = FALSE; if (!args && ckWARN(WARN_PRINTF) && (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) { SV *msg = sv_newmortal(); @@ -9036,6 +9310,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV p += elen; *p = '\0'; SvCUR(sv) = p - SvPVX(sv); + svix = osvix; continue; /* not "break" */ } @@ -9054,6 +9329,13 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV p = SvEND(sv); *p = '\0'; } + /* Use memchr() instead of strchr(), as eptr is not guaranteed */ + /* to point to a null-terminated string. */ + if (left && ckWARN(WARN_PRINTF) && memchr(eptr, '\n', elen) && + (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) + Perl_warner(aTHX_ packWARN(WARN_PRINTF), + "Newline in left-justified string for %sprintf", + (PL_op->op_type == OP_PRTF) ? "" : "s"); have = esignlen + zeros + elen; need = (have > width ? have : width); @@ -9240,6 +9522,9 @@ Perl_re_dup(pTHX_ REGEXP *r, CLONE_PARAMS *param) ret->subbeg = SAVEPV(r->subbeg); else ret->subbeg = Nullch; +#ifdef PERL_COPY_ON_WRITE + ret->saved_copy = Nullsv; +#endif ptr_table_store(PL_ptr_table, r, ret); return ret; @@ -9608,9 +9893,20 @@ Perl_rvpv_dup(pTHX_ SV *dstr, SV *sstr, CLONE_PARAMS* param) /* Special case - not normally malloced for some reason */ if (SvREADONLY(sstr) && SvFAKE(sstr)) { /* A "shared" PV - clone it as unshared string */ - SvFAKE_off(dstr); - SvREADONLY_off(dstr); - SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvCUR(sstr)); + if(SvPADTMP(sstr)) { + /* However, some of them live in the pad + and they should not have these flags + turned off */ + + SvPVX(dstr) = sharepvn(SvPVX(sstr), SvCUR(sstr), + SvUVX(sstr)); + SvUVX(dstr) = SvUVX(sstr); + } else { + + SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvCUR(sstr)); + SvFAKE_off(dstr); + SvREADONLY_off(dstr); + } } else { /* Some other special case - random pointer */ @@ -9734,7 +10030,12 @@ Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param) Perl_rvpv_dup(aTHX_ dstr, sstr, param); LvTARGOFF(dstr) = LvTARGOFF(sstr); /* XXX sometimes holds PMOP* when DEBUGGING */ LvTARGLEN(dstr) = LvTARGLEN(sstr); - LvTARG(dstr) = sv_dup_inc(LvTARG(sstr), param); + if (LvTYPE(sstr) == 't') /* for tie: unrefcnted fake (SV**) */ + LvTARG(dstr) = dstr; + else if (LvTYPE(sstr) == 'T') /* for tie: fake HE */ + LvTARG(dstr) = (SV*)he_dup((HE*)LvTARG(sstr), 0, param); + else + LvTARG(dstr) = sv_dup_inc(LvTARG(sstr), param); LvTYPE(dstr) = LvTYPE(sstr); break; case SVt_PVGV: @@ -9789,12 +10090,21 @@ Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param) IoPAGE(dstr) = IoPAGE(sstr); IoPAGE_LEN(dstr) = IoPAGE_LEN(sstr); IoLINES_LEFT(dstr) = IoLINES_LEFT(sstr); + if(IoFLAGS(sstr) & IOf_FAKE_DIRP) { + /* I have no idea why fake dirp (rsfps) + should be treaded differently but otherwise + we end up with leaks -- sky*/ + IoTOP_GV(dstr) = gv_dup_inc(IoTOP_GV(sstr), param); + IoFMT_GV(dstr) = gv_dup_inc(IoFMT_GV(sstr), param); + IoBOTTOM_GV(dstr) = gv_dup_inc(IoBOTTOM_GV(sstr), param); + } else { + IoTOP_GV(dstr) = gv_dup(IoTOP_GV(sstr), param); + IoFMT_GV(dstr) = gv_dup(IoFMT_GV(sstr), param); + IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(sstr), param); + } IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(sstr)); - IoTOP_GV(dstr) = gv_dup(IoTOP_GV(sstr), param); IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(sstr)); - IoFMT_GV(dstr) = gv_dup(IoFMT_GV(sstr), param); IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(sstr)); - IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(sstr), param); IoSUBPROCESS(dstr) = IoSUBPROCESS(sstr); IoTYPE(dstr) = IoTYPE(sstr); IoFLAGS(dstr) = IoFLAGS(sstr); @@ -10666,6 +10976,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_DBsingle = sv_dup(proto_perl->IDBsingle, param); PL_DBtrace = sv_dup(proto_perl->IDBtrace, param); PL_DBsignal = sv_dup(proto_perl->IDBsignal, param); + PL_DBassertion = sv_dup(proto_perl->IDBassertion, param); PL_lineary = av_dup(proto_perl->Ilineary, param); PL_dbargs = av_dup(proto_perl->Idbargs, param); @@ -10693,11 +11004,13 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, /* internal state */ PL_tainting = proto_perl->Itainting; + PL_taint_warn = proto_perl->Itaint_warn; PL_maxo = proto_perl->Imaxo; if (proto_perl->Iop_mask) PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo); else PL_op_mask = Nullch; + /* PL_asserting = proto_perl->Iasserting; */ /* current interpreter roots */ PL_main_cv = cv_dup_inc(proto_perl->Imain_cv, param); @@ -10769,7 +11082,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_origalen = proto_perl->Iorigalen; PL_pidstatus = newHV(); /* XXX flag for cloning? */ PL_osname = SAVEPV(proto_perl->Iosname); - PL_sh_path = proto_perl->Ish_path; /* XXX never deallocated */ + PL_sh_path_compat = proto_perl->Ish_path_compat; /* XXX never deallocated */ PL_sighandlerp = proto_perl->Isighandlerp; @@ -10901,6 +11214,40 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_utf8_idstart = sv_dup_inc(proto_perl->Iutf8_idstart, param); PL_utf8_idcont = sv_dup_inc(proto_perl->Iutf8_idcont, param); + /* Did the locale setup indicate UTF-8? */ + PL_utf8locale = proto_perl->Iutf8locale; + /* Unicode features (see perlrun/-C) */ + PL_unicode = proto_perl->Iunicode; + + /* Pre-5.8 signals control */ + PL_signals = proto_perl->Isignals; + + /* times() ticks per second */ + PL_clocktick = proto_perl->Iclocktick; + + /* Recursion stopper for PerlIO_find_layer */ + PL_in_load_module = proto_perl->Iin_load_module; + + /* sort() routine */ + PL_sort_RealCmp = proto_perl->Isort_RealCmp; + + /* Not really needed/useful since the reenrant_retint is "volatile", + * but do it for consistency's sake. */ + PL_reentrant_retint = proto_perl->Ireentrant_retint; + + /* Hooks to shared SVs and locks. */ + PL_sharehook = proto_perl->Isharehook; + PL_lockhook = proto_perl->Ilockhook; + PL_unlockhook = proto_perl->Iunlockhook; + PL_threadhook = proto_perl->Ithreadhook; + + PL_runops_std = proto_perl->Irunops_std; + PL_runops_dbg = proto_perl->Irunops_dbg; + +#ifdef THREADS_HAVE_PIDS + PL_ppid = proto_perl->Ippid; +#endif + /* swatch cache */ PL_last_swash_hv = Nullhv; /* reinits on demand */ PL_last_swash_klen = 0; @@ -11042,9 +11389,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_protect = proto_perl->Tprotect; #endif PL_errors = sv_dup_inc(proto_perl->Terrors, param); - PL_av_fetch_sv = Nullsv; - PL_hv_fetch_sv = Nullsv; - Zero(&PL_hv_fetch_ent_mh, 1, HE); /* XXX */ + PL_hv_fetch_ent_mh = Nullhe; PL_modcount = proto_perl->Tmodcount; PL_lastgotoprobe = Nullop; PL_dumpindent = proto_perl->Tdumpindent; @@ -11101,6 +11446,9 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_reg_curpm = (PMOP*)NULL; PL_reg_oldsaved = Nullch; PL_reg_oldsavedlen = 0; +#ifdef PERL_COPY_ON_WRITE + PL_nrs = Nullsv; +#endif PL_reg_maxiter = 0; PL_reg_leftiter = 0; PL_reg_poscache = Nullch; @@ -11119,6 +11467,8 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, /* Pluggable optimizer */ PL_peepp = proto_perl->Tpeepp; + PL_stashcache = newHV(); + if (!(flags & CLONEf_KEEP_PTR_TABLE)) { ptr_table_free(PL_ptr_table); PL_ptr_table = NULL; @@ -11231,8 +11581,8 @@ bool Perl_sv_cat_decode(pTHX_ SV *dsv, SV *encoding, SV *ssv, int *offset, char *tstr, int tlen) { + bool ret = FALSE; if (SvPOK(ssv) && SvPOK(dsv) && SvROK(encoding) && offset) { - bool ret = FALSE; SV *offsv; dSP; ENTER; @@ -11253,8 +11603,9 @@ Perl_sv_cat_decode(pTHX_ SV *dsv, SV *encoding, PUTBACK; FREETMPS; LEAVE; - return ret; } - Perl_croak(aTHX_ "Invalid argument to sv_cat_decode."); + else + Perl_croak(aTHX_ "Invalid argument to sv_cat_decode"); + return ret; }