X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/439cb1c4bca8637a65af6ff559799d9f5b05b394..57c6e6d2d6e8e7d8865d21652c7b582d8731722b:/sv.c diff --git a/sv.c b/sv.c index c8d11db..7668155 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. @@ -25,12 +26,9 @@ #ifdef PERL_COPY_ON_WRITE #define SV_COW_NEXT_SV(sv) INT2PTR(SV *,SvUVX(sv)) -/* This is a pessamistic view. Scalar must be purely a read-write PV to copy- +#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|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 /* ============================================================================ @@ -163,7 +161,28 @@ Public API: /* new_SV(): return a new, empty SV head */ -#define new_SV(p) \ +#ifdef DEBUG_LEAKING_SCALARS +/* provide a real function for a debugger to play with */ +STATIC SV* +S_new_SV(pTHX) +{ + SV* sv; + + LOCK_SV_MUTEX; + if (PL_sv_root) + uproot_SV(sv); + else + sv = more_sv(); + UNLOCK_SV_MUTEX; + SvANY(sv) = 0; + SvREFCNT(sv) = 1; + SvFLAGS(sv) = 0; + return sv; +} +# define new_SV(p) (p)=S_new_SV(aTHX) + +#else +# define new_SV(p) \ STMT_START { \ LOCK_SV_MUTEX; \ if (PL_sv_root) \ @@ -175,6 +194,7 @@ Public API: SvREFCNT(p) = 1; \ SvFLAGS(p) = 0; \ } STMT_END +#endif /* del_SV(): return an empty SV head to the free list */ @@ -1126,13 +1146,8 @@ S_more_xpvbm(pTHX) xpvbm->xpv_pv = 0; } -#ifdef LEAKTEST -# define my_safemalloc(s) (void*)safexmalloc(717,s) -# define my_safefree(p) safexfree((char*)p) -#else -# define my_safemalloc(s) (void*)safemalloc(s) -# define my_safefree(p) safefree((char*)p) -#endif +#define my_safemalloc(s) (void*)safemalloc(s) +#define my_safefree(p) safefree((char*)p) #ifdef PURIFY @@ -1548,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, @@ -1578,7 +1591,7 @@ Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen) if (newlen > SvLEN(sv)) { /* need more room? */ if (SvLEN(sv) && s) { -#if defined(MYMALLOC) && !defined(LEAKTEST) +#ifdef MYMALLOC STRLEN l = malloced_size((void*)SvPVX(sv)); if (newlen <= l) { SvLEN_set(sv, l); @@ -2030,7 +2043,7 @@ Perl_sv_2iv(pTHX_ register SV *sv) if (SvROK(sv)) { SV* tmpstr; if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) && - (SvTYPE(tmpstr) != SVt_RV || (SvRV(tmpstr) != SvRV(sv)))) + (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) return SvIV(tmpstr); return PTR2IV(SvRV(sv)); } @@ -2261,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 @@ -2327,7 +2340,7 @@ Perl_sv_2uv(pTHX_ register SV *sv) if (SvROK(sv)) { SV* tmpstr; if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) && - (SvTYPE(tmpstr) != SVt_RV || (SvRV(tmpstr) != SvRV(sv)))) + (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) return SvUV(tmpstr); return PTR2UV(SvRV(sv)); } @@ -2548,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); @@ -2615,7 +2628,7 @@ Perl_sv_2nv(pTHX_ register SV *sv) if (SvROK(sv)) { SV* tmpstr; if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) && - (SvTYPE(tmpstr) != SVt_RV || (SvRV(tmpstr) != SvRV(sv)))) + (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) return SvNV(tmpstr); return PTR2NV(SvRV(sv)); } @@ -2877,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 @@ -2894,7 +2917,7 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) { register char *s; int olderrno; - SV *tsv; + SV *tsv, *origsv; char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */ char *tmpbuf = tbuf; @@ -2935,8 +2958,15 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) if (SvROK(sv)) { SV* tmpstr; if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)) && - (SvTYPE(tmpstr) != SVt_RV || (SvRV(tmpstr) != SvRV(sv)))) - return SvPV(tmpstr,*lp); + (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) { + char *pv = SvPV(tmpstr, *lp); + if (SvUTF8(tmpstr)) + SvUTF8_on(sv); + else + SvUTF8_off(sv); + return pv; + } + origsv = sv; sv = (SV*)SvRV(sv); if (!sv) s = "NULLREF"; @@ -2947,8 +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)) - && strEQ(s=HvNAME(SvSTASH(sv)), "Regexp") + == (SVs_OBJECT|SVs_SMG)) && (mg = mg_find(sv, PERL_MAGIC_qr))) { regexp *re = (regexp *)mg->mg_obj; @@ -3004,6 +3033,7 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) need a newline */ mg->mg_len++; /* save space for it */ need_newline = 1; /* note to add it */ + break; } } } @@ -3019,6 +3049,11 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) mg->mg_ptr[mg->mg_len] = 0; } PL_reginterp_cnt += re->program[0].next_off; + + if (re->reganch & ROPT_UTF8) + SvUTF8_on(origsv); + else + SvUTF8_off(origsv); *lp = mg->mg_len; return mg->mg_ptr; } @@ -3034,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; @@ -3044,15 +3079,8 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) default: s = "UNKNOWN"; break; } tsv = NEWSV(0,0); - if (SvOBJECT(sv)) { - HV *svs = SvSTASH(sv); - Perl_sv_setpvf( - aTHX_ tsv, "%s=%s", - /* [20011101.072] This bandaid for C - should eventually be removed. AMS 20011103 */ - (svs ? HvNAME(svs) : ""), s - ); - } + if (SvOBJECT(sv)) + Perl_sv_setpvf(aTHX_ tsv, "%s=%s", HvNAME(SvSTASH(sv)), s); else sv_setpv(tsv, s); Perl_sv_catpvf(aTHX_ tsv, "(0x%"UVxf")", PTR2UV(sv)); @@ -3194,28 +3222,14 @@ would lose the UTF-8'ness of the PV. void Perl_sv_copypv(pTHX_ SV *dsv, register SV *ssv) { - SV *tmpsv; - - 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; - char *s; - s = SvPV(ssv,len); - sv_setpvn(tmpsv,s,len); - if (SvUTF8(ssv)) - SvUTF8_on(tmpsv); - else - SvUTF8_off(tmpsv); - SvSetSV(dsv,tmpsv); - } + STRLEN len; + char *s; + s = SvPV(ssv,len); + sv_setpvn(dsv,s,len); + if (SvUTF8(ssv)) + SvUTF8_on(dsv); + else + SvUTF8_off(dsv); } /* @@ -3337,6 +3351,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 @@ -3386,7 +3411,7 @@ Perl_sv_utf8_upgrade_flags(pTHX_ register SV *sv, I32 flags) sv_force_normal_flags(sv, 0); } - if (PL_encoding) + if (PL_encoding && !(flags & SV_UTF8_NO_ENCODING)) sv_recode_to_utf8(sv, PL_encoding); else { /* Assume Latin-1/EBCDIC */ /* This function could be much more efficient if we @@ -3519,6 +3544,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 @@ -3569,6 +3604,12 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) dtype = SvTYPE(dstr); SvAMAGIC_off(dstr); + if ( SvVOK(dstr) ) + { + /* need to nuke the magic */ + mg_free(dstr); + SvRMAGICAL_off(dstr); + } /* There's a lot of redundancy below but we're going for speed here */ @@ -3643,8 +3684,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; @@ -3747,7 +3796,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) switch (SvTYPE(sref)) { case SVt_PVAV: if (intro) - SAVESPTR(GvAV(dstr)); + SAVEGENERICSV(GvAV(dstr)); else dref = (SV*)GvAV(dstr); GvAV(dstr) = (AV*)sref; @@ -3759,7 +3808,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) break; case SVt_PVHV: if (intro) - SAVESPTR(GvHV(dstr)); + SAVEGENERICSV(GvHV(dstr)); else dref = (SV*)GvHV(dstr); GvHV(dstr) = (HV*)sref; @@ -3777,7 +3826,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) GvCVGEN(dstr) = 0; /* Switch off cacheness. */ PL_sub_generation++; } - SAVESPTR(GvCV(dstr)); + SAVEGENERICSV(GvCV(dstr)); } else dref = (SV*)GvCV(dstr); @@ -3827,21 +3876,21 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) break; case SVt_PVIO: if (intro) - SAVESPTR(GvIOp(dstr)); + SAVEGENERICSV(GvIOp(dstr)); else dref = (SV*)GvIOp(dstr); GvIOp(dstr) = (IO*)sref; break; case SVt_PVFM: if (intro) - SAVESPTR(GvFORM(dstr)); + SAVEGENERICSV(GvFORM(dstr)); else dref = (SV*)GvFORM(dstr); GvFORM(dstr) = (CV*)sref; break; default: if (intro) - SAVESPTR(GvSV(dstr)); + SAVEGENERICSV(GvSV(dstr)); else dref = (SV*)GvSV(dstr); GvSV(dstr) = sref; @@ -3854,8 +3903,6 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) } if (dref) SvREFCNT_dec(dref); - if (intro) - SAVEFREESV(sref); if (SvTAINTED(sstr)) SvTAINT(dstr); return; @@ -3931,10 +3978,9 @@ 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"); - Perl_sv_dump(sstr); - Perl_sv_dump(dstr); + PerlIO_printf(Perl_debug_log, "Copy on write: sstr --> dstr\n"); + sv_dump(sstr); + sv_dump(dstr); } if (!isSwipe) { /* I believe I should acquire a global SV mutex if @@ -3949,7 +3995,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) SvFAKE_on(sstr); /* Make the source SV into a loop of 1. (about to become 2) */ - SV_COW_NEXT_SV(sstr) = sstr; + SV_COW_NEXT_SV_SET(sstr, sstr); } } #endif @@ -3969,11 +4015,12 @@ 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. */ - SV_COW_NEXT_SV(dstr) = SV_COW_NEXT_SV(sstr); - SV_COW_NEXT_SV(sstr) = dstr; + SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr)); + SV_COW_NEXT_SV_SET(sstr, dstr); SvPV_set(dstr, SvPVX(sstr)); } else { /* SvIsCOW_shared_hash */ @@ -4024,9 +4071,9 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) SvIVX(dstr) = SvIVX(sstr); } if (SvVOK(sstr)) { - MAGIC *mg = SvMAGIC(sstr); - sv_magicext(dstr, NULL, PERL_MAGIC_vstring, NULL, - mg->mg_ptr, mg->mg_len); + MAGIC *smg = mg_find(sstr,PERL_MAGIC_vstring); + sv_magic(dstr, NULL, PERL_MAGIC_vstring, + smg->mg_ptr, smg->mg_len); SvRMAGICAL_on(dstr); } } @@ -4085,6 +4132,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 @@ -4259,9 +4377,10 @@ S_sv_release_COW(pTHX_ register SV *sv, char *pvx, STRLEN cur, STRLEN len, /* don't loop forever if the structure is bust, and we have a pointer into a closed loop. */ assert (current != after); + assert (SvPVX(current) == pvx); } /* Make the SV before us point to the SV after us. */ - SV_COW_NEXT_SV(current) = after; + SV_COW_NEXT_SV_SET(current, after); } } else { unsharepvn(pvx, SvUTF8(sv) ? -(I32)cur : cur, hash); @@ -4285,7 +4404,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. @@ -4308,7 +4427,7 @@ Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags) PerlIO_printf(Perl_debug_log, "Copy on write: Force normal %ld\n", (long) flags); - Perl_sv_dump(sv); + sv_dump(sv); } SvFAKE_off(sv); SvREADONLY_off(sv); @@ -4324,9 +4443,9 @@ Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags) SvCUR(sv) = cur; *SvEND(sv) = '\0'; } - S_sv_release_COW(sv, pvx, cur, len, hash, next); + sv_release_COW(sv, pvx, cur, len, hash, next); if (DEBUG_C_TEST) { - Perl_sv_dump(sv); + sv_dump(sv); } } else if (PL_curcop != &PL_compiling) @@ -4339,11 +4458,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) @@ -4403,9 +4522,12 @@ Perl_sv_chop(pTHX_ register SV *sv, register char *ptr) *SvEND(sv) = '\0'; } SvIVX(sv) = 0; - SvFLAGS(sv) |= SVf_OOK; + /* Same SvOOK_on but SvOOK_on does a SvIOK_off + and we do that anyway inside the SvNIOK_off + */ + SvFLAGS(sv) |= SVf_OOK; } - SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVp_IOK|SVp_NOK|SVf_IVisUV); + SvNIOK_off(sv); delta = ptr - SvPVX(sv); SvLEN(sv) -= delta; SvCUR(sv) -= delta; @@ -4413,6 +4535,16 @@ Perl_sv_chop(pTHX_ register SV *sv, register char *ptr) 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 @@ -4465,6 +4597,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 @@ -4637,8 +4779,7 @@ Perl_sv_magicext(pTHX_ SV* sv, SV* obj, int how, MGVTBL *vtable, 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 + have its REFCNT incremented to keep it in existence. */ if (!obj || obj == sv || @@ -4655,6 +4796,21 @@ Perl_sv_magicext(pTHX_ SV* sv, SV* obj, int how, MGVTBL *vtable, mg->mg_obj = SvREFCNT_inc(obj); mg->mg_flags |= MGf_REFCOUNTED; } + + /* Normal self-ties simply pass a null object, and instead of + using mg_obj directly, use the SvTIED_obj macro to produce a + new RV as needed. For glob "self-ties", we are tieing the PVIO + with an RV obj pointing to the glob containing the PVIO. In + this case, to avoid a reference loop, we need to weaken the + reference. + */ + + if (how == PERL_MAGIC_tiedscalar && SvTYPE(sv) == SVt_PVIO && + obj && SvROK(obj) && GvIO(SvRV(obj)) == (IO*)sv) + { + sv_rvweaken(obj); + } + mg->mg_type = how; mg->mg_len = namlen; if (name) { @@ -4763,11 +4919,6 @@ Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 nam case PERL_MAGIC_dbline: vtable = &PL_vtbl_dbline; break; -#ifdef USE_5005THREADS - case PERL_MAGIC_mutex: - vtable = &PL_vtbl_mutex; - break; -#endif /* USE_5005THREADS */ #ifdef USE_LOCALE_COLLATE case PERL_MAGIC_collxfrm: vtable = &PL_vtbl_collxfrm; @@ -4798,6 +4949,12 @@ Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 nam case PERL_MAGIC_vec: vtable = &PL_vtbl_vec; break; + case PERL_MAGIC_vstring: + vtable = 0; + break; + case PERL_MAGIC_utf8: + vtable = &PL_vtbl_utf8; + break; case PERL_MAGIC_substr: vtable = &PL_vtbl_substr; break; @@ -4867,6 +5024,8 @@ Perl_sv_unmagic(pTHX_ SV *sv, int type) Safefree(mg->mg_ptr); else if (mg->mg_len == HEf_SVKEY) SvREFCNT_dec((SV*)mg->mg_ptr); + else if (mg->mg_type == PERL_MAGIC_utf8 && mg->mg_ptr) + Safefree(mg->mg_ptr); } if (mg->mg_flags & MGf_REFCOUNTED) SvREFCNT_dec(mg->mg_obj); @@ -4930,7 +5089,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 @@ -5086,6 +5257,28 @@ Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv) sv_clear(sv); assert(!SvREFCNT(sv)); StructCopy(nsv,sv,SV); +#ifdef PERL_COPY_ON_WRITE + if (SvIsCOW_normal(nsv)) { + /* We need to follow the pointers around the loop to make the + previous SV point to sv, rather than nsv. */ + SV *next; + SV *current = nsv; + while ((next = SV_COW_NEXT_SV(current)) != nsv) { + assert(next); + current = next; + assert(SvPVX(current) == SvPVX(nsv)); + } + /* Make the SV before us point to the SV after us. */ + if (DEBUG_C_TEST) { + PerlIO_printf(Perl_debug_log, "previous is\n"); + sv_dump(current); + PerlIO_printf(Perl_debug_log, + "move it from 0x%"UVxf" to 0x%"UVxf"\n", + (UV) SV_COW_NEXT_SV(current), (UV) sv); + } + SV_COW_NEXT_SV_SET(current, sv); + } +#endif SvREFCNT(sv) = refcnt; SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */ del_SV(nsv); @@ -5116,34 +5309,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); - SvREFCNT(sv)--; + call_sv((SV*)destructor, G_DISCARD|G_EVAL|G_KEEPERR|G_VOID); + + 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) @@ -5197,7 +5393,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); @@ -5229,9 +5431,9 @@ Perl_sv_clear(pTHX_ register SV *sv) then recheck the COW status. */ if (DEBUG_C_TEST) { PerlIO_printf(Perl_debug_log, "Copy on write: clear\n"); - Perl_sv_dump(sv); + sv_dump(sv); } - S_sv_release_COW(sv, SvPVX(sv), SvCUR(sv), SvLEN(sv), + sv_release_COW(sv, SvPVX(sv), SvCUR(sv), SvLEN(sv), SvUVX(sv), SV_COW_NEXT_SV(sv)); /* And drop it here. */ SvFAKE_off(sv); @@ -5330,7 +5532,7 @@ SV * Perl_sv_newref(pTHX_ SV *sv) { if (sv) - ATOMIC_INC(SvREFCNT(sv)); + (SvREFCNT(sv))++; return sv; } @@ -5348,8 +5550,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) { @@ -5368,9 +5568,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)) @@ -5423,6 +5628,13 @@ UTF8 bytes as a single character. Handles magic and type coercion. =cut */ +/* + * The length is cached in PERL_UTF8_magic, in the mg_len field. Also the + * mg_ptr is used, by sv_pos_u2b(), see the comments of S_utf8_mg_pos_init(). + * (Note that the mg_len is not the length of the mg_ptr field.) + * + */ + STRLEN Perl_sv_len_utf8(pTHX_ register SV *sv) { @@ -5433,14 +5645,159 @@ Perl_sv_len_utf8(pTHX_ register SV *sv) return mg_length(sv); else { - STRLEN len; + STRLEN len, ulen; U8 *s = (U8*)SvPV(sv, len); + MAGIC *mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : 0; + + if (mg && mg->mg_len != -1 && (mg->mg_len > 0 || len == 0)) + ulen = mg->mg_len; + else { + ulen = Perl_utf8_length(aTHX_ s, s + len); + if (!mg && !SvREADONLY(sv)) { + sv_magic(sv, 0, PERL_MAGIC_utf8, 0, 0); + mg = mg_find(sv, PERL_MAGIC_utf8); + assert(mg); + } + if (mg) + mg->mg_len = ulen; + } + return ulen; + } +} + +/* S_utf8_mg_pos_init() is used to initialize the mg_ptr field of + * a PERL_UTF8_magic. The mg_ptr is used to store the mapping + * between UTF-8 and byte offsets. There are two (substr offset and substr + * length, the i offset, PERL_MAGIC_UTF8_CACHESIZE) times two (UTF-8 offset + * and byte offset) cache positions. + * + * The mg_len field is used by sv_len_utf8(), see its comments. + * Note that the mg_len is not the length of the mg_ptr field. + * + */ +STATIC bool +S_utf8_mg_pos_init(pTHX_ SV *sv, MAGIC **mgp, STRLEN **cachep, I32 i, I32 *offsetp, U8 *s, U8 *start) +{ + bool found = FALSE; + + if (SvMAGICAL(sv) && !SvREADONLY(sv)) { + if (!*mgp) { + sv_magic(sv, 0, PERL_MAGIC_utf8, 0, 0); + *mgp = mg_find(sv, PERL_MAGIC_utf8); + } + assert(*mgp); - return Perl_utf8_length(aTHX_ s, s + len); + if ((*mgp)->mg_ptr) + *cachep = (STRLEN *) (*mgp)->mg_ptr; + else { + Newz(0, *cachep, PERL_MAGIC_UTF8_CACHESIZE * 2, STRLEN); + (*mgp)->mg_ptr = (char *) *cachep; + } + assert(*cachep); + + (*cachep)[i] = *offsetp; + (*cachep)[i+1] = s - start; + found = TRUE; } + + return found; } /* + * S_utf8_mg_pos() is used to query and update mg_ptr field of + * a PERL_UTF8_magic. The mg_ptr is used to store the mapping + * between UTF-8 and byte offsets. See also the comments of + * S_utf8_mg_pos_init(). + * + */ +STATIC bool +S_utf8_mg_pos(pTHX_ SV *sv, MAGIC **mgp, STRLEN **cachep, I32 i, I32 *offsetp, I32 uoff, U8 **sp, U8 *start, U8 *send) +{ + bool found = FALSE; + + if (SvMAGICAL(sv) && !SvREADONLY(sv)) { + if (!*mgp) + *mgp = mg_find(sv, PERL_MAGIC_utf8); + if (*mgp && (*mgp)->mg_ptr) { + *cachep = (STRLEN *) (*mgp)->mg_ptr; + if ((*cachep)[i] == (STRLEN)uoff) /* An exact match. */ + found = TRUE; + else { /* We will skip to the right spot. */ + STRLEN forw = 0; + STRLEN backw = 0; + U8* p = NULL; + + /* The assumption is that going backward is half + * the speed of going forward (that's where the + * 2 * backw in the below comes from). (The real + * figure of course depends on the UTF-8 data.) */ + + if ((*cachep)[i] > (STRLEN)uoff) { + forw = uoff; + backw = (*cachep)[i] - (STRLEN)uoff; + + if (forw < 2 * backw) + p = start; + else + p = start + (*cachep)[i+1]; + } + /* Try this only for the substr offset (i == 0), + * not for the substr length (i == 2). */ + else if (i == 0) { /* (*cachep)[i] < uoff */ + STRLEN ulen = sv_len_utf8(sv); + + if ((STRLEN)uoff < ulen) { + forw = (STRLEN)uoff - (*cachep)[i]; + backw = ulen - (STRLEN)uoff; + + if (forw < 2 * backw) + p = start + (*cachep)[i+1]; + else + p = send; + } + + /* If the string is not long enough for uoff, + * we could extend it, but not at this low a level. */ + } + + if (p) { + if (forw < 2 * backw) { + while (forw--) + p += UTF8SKIP(p); + } + else { + while (backw--) { + p--; + while (UTF8_IS_CONTINUATION(*p)) + p--; + } + } + + /* Update the cache. */ + (*cachep)[i] = (STRLEN)uoff; + (*cachep)[i+1] = p - start; + + found = TRUE; + } + } + if (found) { /* Setup the return values. */ + *offsetp = (*cachep)[i+1]; + *sp = start + *offsetp; + if (*sp >= send) { + *sp = send; + *offsetp = send - start; + } + else if (*sp < start) { + *sp = start; + *offsetp = 0; + } + } + } + } + return found; +} + +/* =for apidoc sv_pos_u2b Converts the value pointed to by offsetp from a count of UTF8 chars from @@ -5452,33 +5809,67 @@ type coercion. =cut */ +/* + * sv_pos_u2b() uses, like sv_pos_b2u(), the mg_ptr of the potential + * PERL_UTF8_magic of the sv to store the mapping between UTF-8 and + * byte offsets. See also the comments of S_utf8_mg_pos(). + * + */ + void Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp) { U8 *start; U8 *s; - U8 *send; - I32 uoffset = *offsetp; STRLEN len; + STRLEN *cache = 0; + STRLEN boffset = 0; if (!sv) return; start = s = (U8*)SvPV(sv, len); - send = s + len; - while (s < send && uoffset--) - s += UTF8SKIP(s); - if (s >= send) - s = send; - *offsetp = s - start; - if (lenp) { - I32 ulen = *lenp; - start = s; - while (s < send && ulen--) - s += UTF8SKIP(s); - if (s >= send) - s = send; - *lenp = s - start; + if (len) { + I32 uoffset = *offsetp; + U8 *send = s + len; + MAGIC *mg = 0; + bool found = FALSE; + + if (utf8_mg_pos(sv, &mg, &cache, 0, offsetp, *offsetp, &s, start, send)) + found = TRUE; + if (!found && uoffset > 0) { + while (s < send && uoffset--) + s += UTF8SKIP(s); + if (s >= send) + s = send; + if (utf8_mg_pos_init(sv, &mg, &cache, 0, offsetp, s, start)) + boffset = cache[1]; + *offsetp = s - start; + } + if (lenp) { + found = FALSE; + start = s; + if (utf8_mg_pos(sv, &mg, &cache, 2, lenp, *lenp + *offsetp, &s, start, send)) { + *lenp -= boffset; + found = TRUE; + } + if (!found && *lenp > 0) { + I32 ulen = *lenp; + if (ulen > 0) + while (s < send && ulen--) + s += UTF8SKIP(s); + if (s >= send) + s = send; + if (utf8_mg_pos_init(sv, &mg, &cache, 2, lenp, s, start)) + cache[2] += *offsetp; + } + *lenp = s - start; + } + } + else { + *offsetp = 0; + if (lenp) + *lenp = 0; } return; } @@ -5493,11 +5884,17 @@ Handles magic and type coercion. =cut */ +/* + * sv_pos_b2u() uses, like sv_pos_u2b(), the mg_ptr of the potential + * PERL_UTF8_magic of the sv to store the mapping between UTF-8 and + * byte offsets. See also the comments of S_utf8_mg_pos(). + * + */ + void -Perl_sv_pos_b2u(pTHX_ register SV *sv, I32* offsetp) +Perl_sv_pos_b2u(pTHX_ register SV* sv, I32* offsetp) { - U8 *s; - U8 *send; + U8* s; STRLEN len; if (!sv) @@ -5506,22 +5903,93 @@ Perl_sv_pos_b2u(pTHX_ register SV *sv, I32* offsetp) s = (U8*)SvPV(sv, len); if ((I32)len < *offsetp) Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset"); - send = s + *offsetp; - len = 0; - while (s < send) { - 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++; + else { + U8* send = s + *offsetp; + MAGIC* mg = NULL; + STRLEN *cache = NULL; + + len = 0; + + if (SvMAGICAL(sv) && !SvREADONLY(sv)) { + mg = mg_find(sv, PERL_MAGIC_utf8); + if (mg && mg->mg_ptr) { + cache = (STRLEN *) mg->mg_ptr; + if (cache[1] == *offsetp) { + /* An exact match. */ + *offsetp = cache[0]; + + return; + } + else if (cache[1] < *offsetp) { + /* We already know part of the way. */ + len = cache[0]; + s += cache[1]; + /* Let the below loop do the rest. */ + } + else { /* cache[1] > *offsetp */ + /* We already know all of the way, now we may + * be able to walk back. The same assumption + * is made as in S_utf8_mg_pos(), namely that + * walking backward is twice slower than + * walking forward. */ + STRLEN forw = *offsetp; + STRLEN backw = cache[1] - *offsetp; + + if (!(forw < 2 * backw)) { + U8 *p = s + cache[1]; + STRLEN ubackw = 0; + + cache[1] -= backw; + + while (backw--) { + p--; + while (UTF8_IS_CONTINUATION(*p)) + p--; + ubackw++; + } + + cache[0] -= ubackw; + + return; + } + } + } } - else - break; + + while (s < send) { + 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++; + } + else + break; + } + + if (!SvREADONLY(sv)) { + if (!mg) { + sv_magic(sv, 0, PERL_MAGIC_utf8, 0, 0); + mg = mg_find(sv, PERL_MAGIC_utf8); + } + assert(mg); + + if (!mg->mg_ptr) { + Newz(0, cache, PERL_MAGIC_UTF8_CACHESIZE * 2, STRLEN); + mg->mg_ptr = (char *) cache; + } + assert(cache); + + cache[0] = len; + cache[1] = *offsetp; + } + + *offsetp = len; } - *offsetp = len; return; } @@ -5838,8 +6306,10 @@ Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append) register I32 cnt; I32 i = 0; 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 @@ -5849,39 +6319,71 @@ Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append) SvSCREAM_off(sv); + 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 */ rsptr = "\n"; rslen = 1; } else if (RsSNARF(PL_rs)) { + /* If it is a regular disk file use size from stat() as estimate + of amount we are going to read - may result in malloc-ing + more memory than we realy need if layers bellow reduce + size we read (e.g. CRLF or a gzip layer) + */ + 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) { + (void) SvGROW(sv, (STRLEN)((st.st_size - offset) + append + 1)); + } + } rsptr = NULL; rslen = 0; } else if (RsRECORD(PL_rs)) { - I32 recsize, bytesread; + I32 bytesread; char *buffer; /* Grab the size of the record we're getting */ recsize = SvIV(SvRV(PL_rs)); - (void)SvPOK_only(sv); /* Validate pointer */ - buffer = SvGROW(sv, (STRLEN)(recsize + 1)); + buffer = SvGROW(sv, (STRLEN)(recsize + append + 1)) + append; /* Go yank in */ #ifdef VMS /* VMS wants read instead of fread, because fread doesn't respect */ /* RMS record boundaries. This is not necessarily a good thing to be */ - /* doing, but we've got no other real choice */ + /* doing, but we've got no other real choice - except avoid stdio + as implementation - perhaps write a :vms layer ? + */ bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize); #else bytesread = PerlIO_read(fp, buffer, recsize); #endif - SvCUR_set(sv, bytesread); + if (bytesread < 0) + bytesread = 0; + SvCUR_set(sv, bytesread += append); buffer[bytesread] = '\0'; - if (PerlIO_isutf8(fp)) - SvUTF8_on(sv); - else - SvUTF8_off(sv); - return(SvCUR(sv) ? SvPVX(sv) : Nullch); + goto return_string_or_null; } else if (RsPARA(PL_rs)) { rsptr = "\n\n"; @@ -5950,9 +6452,13 @@ Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append) /* Here is some breathtakingly efficient cheating */ cnt = PerlIO_get_cnt(fp); /* get count into register */ - (void)SvPOK_only(sv); /* validate pointer */ - if ((I32)(SvLEN(sv) - append) <= cnt + 1) { /* make sure we have the room */ - if (cnt > 80 && (I32)SvLEN(sv) > append) { + /* make sure we have the room */ + if ((I32)(SvLEN(sv) - append) <= cnt + 1) { + /* Not room for all of it + if we are looking for a separator and room for some + */ + if (rslen && cnt > 80 && (I32)SvLEN(sv) > append) { + /* just process what we have room for */ shortbuffered = cnt - SvLEN(sv) + append + 1; cnt -= shortbuffered; } @@ -5962,7 +6468,7 @@ Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append) SvGROW(sv, (STRLEN)(append + (cnt <= 0 ? 2 : (cnt + 1)))); } } - else + else shortbuffered = 0; bp = (STDCHAR*)SvPVX(sv) + append; /* move these two too to registers */ ptr = (STDCHAR*)PerlIO_get_ptr(fp); @@ -6130,11 +6636,7 @@ screamer2: } } - if (PerlIO_isutf8(fp)) - SvUTF8_on(sv); - else - SvUTF8_off(sv); - +return_string_or_null: return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch; } @@ -6863,7 +7365,7 @@ Perl_sv_2io(pTHX_ SV *sv) else io = 0; if (!io) - Perl_croak(aTHX_ "Bad filehandle: %s", SvPV(sv,n_a)); + Perl_croak(aTHX_ "Bad filehandle: %"SVf, sv); break; } return io; @@ -6944,7 +7446,8 @@ Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref) Nullop); LEAVE; if (!GvCVu(gv)) - Perl_croak(aTHX_ "Unable to create sub named \"%s\"", SvPV(sv,n_a)); + Perl_croak(aTHX_ "Unable to create sub named \"%"SVf"\"", + sv); } return GvCVu(gv); } @@ -7043,6 +7546,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 @@ -7077,6 +7595,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 @@ -7135,6 +7663,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 @@ -7173,6 +7712,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 @@ -7223,10 +7773,7 @@ char * Perl_sv_reftype(pTHX_ SV *sv, int ob) { if (ob && SvOBJECT(sv)) { - HV *svs = SvSTASH(sv); - /* [20011101.072] This bandaid for C should eventually - be removed. AMS 20011103 */ - return (svs ? HvNAME(svs) : ""); + return HvNAME(SvSTASH(sv)); } else { switch (SvTYPE(sv)) { @@ -7245,7 +7792,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"; @@ -7570,7 +8117,9 @@ Perl_sv_unref_flags(pTHX_ SV *sv, U32 flags) } SvRV(sv) = 0; SvROK_off(sv); - if (SvREFCNT(rv) != 1 || SvREADONLY(rv) || (flags & SV_IMMEDIATE_UNREF)) + /* You can't have a || SvREADONLY(rv) here, as $a = $$a, where $a was + assigned to as BEGIN {$a = \"Foo"} will fail. */ + if (SvREFCNT(rv) != 1 || (flags & SV_IMMEDIATE_UNREF)) SvREFCNT_dec(rv); else /* XXX Hack, but hard to make $a=$a->[1] work otherwise */ sv_2mortal(rv); /* Schedule for freeing later */ @@ -7641,6 +8190,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 @@ -7874,7 +8461,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); @@ -7909,7 +8500,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV } if (!args && svix < svmax && DO_UTF8(*svargs)) - has_utf8 = TRUE; + has_utf8 = TRUE; patend = (char*)pat + patlen; for (p = (char*)pat; p < patend; p = q) { @@ -7925,8 +8516,14 @@ 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 + with sfio - Allen */ + bool fix_ldbl_sprintf_bug = FALSE; +#endif + char esignbuf[4]; U8 utf8buf[UTF8_MAXLEN+1]; STRLEN esignlen = 0; @@ -7937,7 +8534,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV * NV_DIG: mantissa takes than many decimal digits. * Plus 32: Playing safe. */ char ebuf[IV_DIG * 4 + NV_DIG + 32]; - /* large enough for "%#.#f" --chip */ + /* large enough for "%#.#f" --chip */ /* what about long double NVs? --jhi */ SV *vecsv = Nullsv; @@ -7970,7 +8567,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) @@ -7981,6 +8581,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 @@ -8046,6 +8647,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) { @@ -8146,7 +8749,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV #endif case 'l': #if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE) - if (*(q + 1) == 'l') { /* lld, llf */ + if (*(q + 1) == 'l') { /* lld, llf */ intsize = 'q'; q += 2; break; @@ -8473,6 +9076,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'; @@ -8485,8 +9091,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; } @@ -8494,10 +9098,10 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV nv = (args && !vectorize) ? #if LONG_DOUBLESIZE > DOUBLESIZE intsize == 'q' ? - va_arg(*args, long double) : - va_arg(*args, double) + va_arg(*args, long double) : + va_arg(*args, double) #else - va_arg(*args, double) + va_arg(*args, double) #endif : SvNVx(argsv); @@ -8514,9 +9118,76 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV need = BIT_DIGITS(i); } need += has_precis ? precis : 6; /* known default */ + if (need < width) need = width; +#ifdef HAS_LDBL_SPRINTF_BUG + /* This is to try to fix a bug with irix/nonstop-ux/powerux and + with sfio - Allen */ + +# ifdef DBL_MAX +# define MY_DBL_MAX DBL_MAX +# else /* XXX guessing! HUGE_VAL may be defined as infinity, so not using */ +# if DOUBLESIZE >= 8 +# define MY_DBL_MAX 1.7976931348623157E+308L +# else +# define MY_DBL_MAX 3.40282347E+38L +# endif +# endif + +# ifdef HAS_LDBL_SPRINTF_BUG_LESS1 /* only between -1L & 1L - Allen */ +# define MY_DBL_MAX_BUG 1L +# else +# define MY_DBL_MAX_BUG MY_DBL_MAX +# endif + +# ifdef DBL_MIN +# define MY_DBL_MIN DBL_MIN +# else /* XXX guessing! -Allen */ +# if DOUBLESIZE >= 8 +# define MY_DBL_MIN 2.2250738585072014E-308L +# else +# define MY_DBL_MIN 1.17549435E-38L +# endif +# endif + + if ((intsize == 'q') && (c == 'f') && + ((nv < MY_DBL_MAX_BUG) && (nv > -MY_DBL_MAX_BUG)) && + (need < DBL_DIG)) { + /* it's going to be short enough that + * long double precision is not needed */ + + if ((nv <= 0L) && (nv >= -0L)) + fix_ldbl_sprintf_bug = TRUE; /* 0 is 0 - easiest */ + else { + /* would use Perl_fp_class as a double-check but not + * functional on IRIX - see perl.h comments */ + + if ((nv >= MY_DBL_MIN) || (nv <= -MY_DBL_MIN)) { + /* It's within the range that a double can represent */ +#if defined(DBL_MAX) && !defined(DBL_MIN) + if ((nv >= ((long double)1/DBL_MAX)) || + (nv <= (-(long double)1/DBL_MAX))) +#endif + fix_ldbl_sprintf_bug = TRUE; + } + } + if (fix_ldbl_sprintf_bug == TRUE) { + double temp; + + intsize = 0; + temp = (double)nv; + nv = (NV)temp; + } + } + +# undef MY_DBL_MAX +# undef MY_DBL_MAX_BUG +# undef MY_DBL_MIN + +#endif /* HAS_LDBL_SPRINTF_BUG */ + need += 20; /* fudge factor */ if (PL_efloatsize < need) { Safefree(PL_efloatbuf); @@ -8597,12 +9268,11 @@ 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(); - Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %s: ", - (PL_op->op_type == OP_PRTF) ? "printf" : "sprintf"); + Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %sprintf: ", + (PL_op->op_type == OP_PRTF) ? "" : "s"); if (c) { if (isPRINT(c)) Perl_sv_catpvf(aTHX_ msg, @@ -8629,6 +9299,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" */ } @@ -8718,10 +9389,6 @@ ptr_table_* functions. #if defined(USE_ITHREADS) -#if defined(USE_5005THREADS) -# include "error: USE_5005THREADS and USE_ITHREADS are incompatible" -#endif - #ifndef GpREFCNT_inc # define GpREFCNT_inc(gp) ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL) #endif @@ -8837,6 +9504,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; @@ -9185,7 +9855,7 @@ void Perl_rvpv_dup(pTHX_ SV *dstr, SV *sstr, CLONE_PARAMS* param) { if (SvROK(sstr)) { - SvRV(dstr) = SvWEAKREF(sstr) + SvRV(dstr) = SvWEAKREF(sstr) ? sv_dup(SvRV(sstr), param) : sv_dup_inc(SvRV(sstr), param); } @@ -9194,19 +9864,36 @@ Perl_rvpv_dup(pTHX_ SV *dstr, SV *sstr, CLONE_PARAMS* param) if (SvLEN(sstr)) { /* Normal PV - clone whole allocated space */ SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1); + if (SvREADONLY(sstr) && SvFAKE(sstr)) { + /* Not that normal - actually sstr is copy on write. + But we are a true, independant SV, so: */ + SvREADONLY_off(dstr); + SvFAKE_off(dstr); + } } else { /* 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 */ SvPVX(dstr) = SvPVX(sstr); - } + } } } else { @@ -9227,6 +9914,18 @@ Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param) if (dstr) return dstr; + if(param->flags & CLONEf_JOIN_IN) { + /** We are joining here so we don't want do clone + something that is bad **/ + + if(SvTYPE(sstr) == SVt_PVHV && + HvNAME(sstr)) { + /** don't clone stashes if they already exist **/ + HV* old_stash = gv_stashpv(HvNAME(sstr),0); + return (SV*) old_stash; + } + } + /* create anew and remember what it is */ new_SV(dstr); ptr_table_store(PL_ptr_table, sstr, dstr); @@ -9313,7 +10012,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: @@ -9368,12 +10072,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); @@ -9480,19 +10193,12 @@ Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param) } else { CvDEPTH(dstr) = 0; } - if (CvPADLIST(sstr) && !AvREAL(CvPADLIST(sstr))) { - /* XXX padlists are real, but pretend to be not */ - AvREAL_on(CvPADLIST(sstr)); - CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr), param); - AvREAL_off(CvPADLIST(sstr)); - AvREAL_off(CvPADLIST(dstr)); - } - else - CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr), param); - if (!CvANON(sstr) || CvCLONED(sstr)) - CvOUTSIDE(dstr) = cv_dup_inc(CvOUTSIDE(sstr), param); - else - CvOUTSIDE(dstr) = cv_dup(CvOUTSIDE(sstr), param); + PAD_DUP(CvPADLIST(dstr), CvPADLIST(sstr), param); + CvOUTSIDE_SEQ(dstr) = CvOUTSIDE_SEQ(sstr); + CvOUTSIDE(dstr) = + CvWEAKOUTSIDE(sstr) + ? cv_dup( CvOUTSIDE(sstr), param) + : cv_dup_inc(CvOUTSIDE(sstr), param); CvFLAGS(dstr) = CvFLAGS(sstr); CvFILE(dstr) = CvXSUB(sstr) ? CvFILE(sstr) : SAVEPV(CvFILE(sstr)); break; @@ -9570,9 +10276,9 @@ Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, CLONE_PARAMS* param) ncx->blk_loop.iterdata = (CxPADLOOP(cx) ? cx->blk_loop.iterdata : gv_dup((GV*)cx->blk_loop.iterdata, param)); - ncx->blk_loop.oldcurpad - = (SV**)ptr_table_fetch(PL_ptr_table, - cx->blk_loop.oldcurpad); + ncx->blk_loop.oldcomppad + = (PAD*)ptr_table_fetch(PL_ptr_table, + cx->blk_loop.oldcomppad); ncx->blk_loop.itersave = sv_dup_inc(cx->blk_loop.itersave, param); ncx->blk_loop.iterlval = sv_dup_inc(cx->blk_loop.iterlval, param); ncx->blk_loop.iterary = av_dup_inc(cx->blk_loop.iterary, param); @@ -9632,6 +10338,8 @@ Perl_si_dup(pTHX_ PERL_SI *si, CLONE_PARAMS* param) #define TOPLONG(ss,ix) ((ss)[ix].any_long) #define POPIV(ss,ix) ((ss)[--(ix)].any_iv) #define TOPIV(ss,ix) ((ss)[ix].any_iv) +#define POPBOOL(ss,ix) ((ss)[--(ix)].any_bool) +#define TOPBOOL(ss,ix) ((ss)[ix].any_bool) #define POPPTR(ss,ix) ((ss)[--(ix)].any_ptr) #define TOPPTR(ss,ix) ((ss)[ix].any_ptr) #define POPDPTR(ss,ix) ((ss)[--(ix)].any_dptr) @@ -9919,6 +10627,12 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) sv = (SV*)POPPTR(ss,ix); TOPPTR(nss,ix) = sv_dup(sv, param); break; + case SAVEt_BOOL: + ptr = POPPTR(ss,ix); + TOPPTR(nss,ix) = any_dup(ptr, proto_perl); + longval = (long)POPBOOL(ss,ix); + TOPBOOL(nss,ix) = (bool)longval; + break; default: Perl_croak(aTHX_ "panic: ss_dup inconsistency"); } @@ -9932,6 +10646,35 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) Create and return a new interpreter by cloning the current one. +perl_clone takes these flags as paramters: + +CLONEf_COPY_STACKS - is used to, well, copy the stacks also, +without it we only clone the data and zero the stacks, +with it we copy the stacks and the new perl interpreter is +ready to run at the exact same point as the previous one. +The pseudo-fork code uses COPY_STACKS while the +threads->new doesn't. + +CLONEf_KEEP_PTR_TABLE +perl_clone keeps a ptr_table with the pointer of the old +variable as a key and the new variable as a value, +this allows it to check if something has been cloned and not +clone it again but rather just use the value and increase the +refcount. If KEEP_PTR_TABLE is not set then perl_clone will kill +the ptr_table using the function +C, +reason to keep it around is if you want to dup some of your own +variable who are outside the graph perl scans, example of this +code is in threads.xs create + +CLONEf_CLONE_HOST +This is a win32 thing, it is ignored on unix, it tells perls +win32host code (which is c++) to clone itself, this is needed on +win32 if you want to run two threads at the same time, +if you just want to do some stuff in a separate perl interpreter +and then throw it away and return to the original one, +you don't need to do anything. + =cut */ @@ -10118,12 +10861,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, /* pseudo environmental stuff */ PL_origargc = proto_perl->Iorigargc; - i = PL_origargc; - New(0, PL_origargv, i+1, char*); - PL_origargv[i] = '\0'; - while (i-- > 0) { - PL_origargv[i] = SAVEPV(proto_perl->Iorigargv[i]); - } + PL_origargv = proto_perl->Iorigargv; param->stashes = newAV(); /* Setup array of objects to call clone on */ @@ -10220,19 +10958,20 @@ 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); /* symbol tables */ PL_defstash = hv_dup_inc(proto_perl->Tdefstash, param); PL_curstash = hv_dup(proto_perl->Tcurstash, param); - PL_nullstash = hv_dup(proto_perl->Inullstash, param); PL_debstash = hv_dup(proto_perl->Idebstash, param); PL_globalstash = hv_dup(proto_perl->Iglobalstash, param); PL_curstname = sv_dup_inc(proto_perl->Icurstname, param); PL_beginav = av_dup_inc(proto_perl->Ibeginav, param); PL_beginav_save = av_dup_inc(proto_perl->Ibeginav_save, param); + PL_checkav_save = av_dup_inc(proto_perl->Icheckav_save, param); PL_endav = av_dup_inc(proto_perl->Iendav, param); PL_checkav = av_dup_inc(proto_perl->Icheckav, param); PL_initav = av_dup_inc(proto_perl->Iinitav, param); @@ -10247,11 +10986,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); @@ -10297,12 +11038,8 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_rsfp_filters = av_dup_inc(proto_perl->Irsfp_filters, param); PL_compcv = cv_dup(proto_perl->Icompcv, param); - PL_comppad = av_dup(proto_perl->Icomppad, param); - PL_comppad_name = av_dup(proto_perl->Icomppad_name, param); - PL_comppad_name_fill = proto_perl->Icomppad_name_fill; - PL_comppad_name_floor = proto_perl->Icomppad_name_floor; - PL_curpad = (SV**)ptr_table_fetch(PL_ptr_table, - proto_perl->Tcurpad); + + PAD_CLONE_VARS(proto_perl, param); #ifdef HAVE_INTERP_INTERN sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern); @@ -10321,14 +11058,13 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_egid = proto_perl->Iegid; PL_nomemok = proto_perl->Inomemok; PL_an = proto_perl->Ian; - PL_cop_seqmax = proto_perl->Icop_seqmax; PL_op_seqmax = proto_perl->Iop_seqmax; PL_evalseq = proto_perl->Ievalseq; PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */ 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; @@ -10400,12 +11136,6 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_subline = proto_perl->Isubline; PL_subname = sv_dup_inc(proto_perl->Isubname, param); - PL_min_intro_pending = proto_perl->Imin_intro_pending; - PL_max_intro_pending = proto_perl->Imax_intro_pending; - PL_padix = proto_perl->Ipadix; - PL_padix_floor = proto_perl->Ipadix_floor; - PL_pad_reset_pending = proto_perl->Ipad_reset_pending; - /* XXX See comment on SvANY(proto_perl->Ilinestr) above */ if (SvANY(proto_perl->Ilinestr)) { i = proto_perl->Ilast_uni - SvPVX(proto_perl->Ilinestr); @@ -10466,6 +11196,27 @@ 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; + /* swatch cache */ PL_last_swash_hv = Nullhv; /* reinits on demand */ PL_last_swash_klen = 0; @@ -10607,9 +11358,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; @@ -10633,23 +11382,11 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_watchok = Nullch; PL_regdummy = proto_perl->Tregdummy; - PL_regcomp_parse = Nullch; - PL_regxend = Nullch; - PL_regcode = (regnode*)NULL; - PL_regnaughty = 0; - PL_regsawback = 0; PL_regprecomp = Nullch; PL_regnpar = 0; PL_regsize = 0; - PL_regflags = 0; - PL_regseen = 0; - PL_seen_zerolen = 0; - PL_seen_evals = 0; - PL_regcomp_rx = (regexp*)NULL; - PL_extralen = 0; PL_colorset = 0; /* reinits PL_colors[] */ /*PL_colors[6] = {0,0,0,0,0,0};*/ - PL_reg_whilem_seen = 0; PL_reginput = Nullch; PL_regbol = Nullch; PL_regeol = Nullch; @@ -10678,6 +11415,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; @@ -10696,6 +11436,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; @@ -10748,17 +11490,18 @@ 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)) { - SV *uni; - STRLEN len; - char *s; - dSP; - ENTER; - SAVETMPS; - PUSHMARK(sp); - EXTEND(SP, 3); - XPUSHs(encoding); - XPUSHs(sv); + if (SvPOK(sv) && !SvUTF8(sv) && !IN_BYTES && SvROK(encoding)) { + SV *uni; + STRLEN len; + char *s; + dSP; + ENTER; + SAVETMPS; + save_re_context(); + PUSHMARK(sp); + 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 @@ -10767,26 +11510,71 @@ Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding) Both will default the value - let them. - XPUSHs(&PL_sv_yes); + XPUSHs(&PL_sv_yes); */ - PUTBACK; - call_method("decode", G_SCALAR); - SPAGAIN; - uni = POPs; - PUTBACK; - s = SvPV(uni, len); - if (s != SvPVX(sv)) { - SvGROW(sv, len + 1); - Move(s, SvPVX(sv), len, char); - SvCUR_set(sv, len); - SvPVX(sv)[len] = 0; - } - FREETMPS; - LEAVE; - SvUTF8_on(sv); + PUTBACK; + call_method("decode", G_SCALAR); + SPAGAIN; + uni = POPs; + PUTBACK; + s = SvPV(uni, len); + if (s != SvPVX(sv)) { + 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); } +/* +=for apidoc sv_cat_decode + +The encoding is assumed to be an Encode object, the PV of the ssv is +assumed to be octets in that encoding and decoding the input starts +from the position which (PV + *offset) pointed to. The dsv will be +concatenated the decoded UTF-8 string from ssv. Decoding will terminate +when the string tstr appears in decoding output or the input ends on +the PV of the ssv. The value which the offset points will be modified +to the last input position on the ssv. + +Returns TRUE if the terminator was found, else returns FALSE. + +=cut */ +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) { + SV *offsv; + dSP; + ENTER; + SAVETMPS; + save_re_context(); + PUSHMARK(sp); + EXTEND(SP, 6); + XPUSHs(encoding); + XPUSHs(dsv); + XPUSHs(ssv); + XPUSHs(offsv = sv_2mortal(newSViv(*offset))); + XPUSHs(sv_2mortal(newSVpvn(tstr, tlen))); + PUTBACK; + call_method("cat_decode", G_SCALAR); + SPAGAIN; + ret = SvTRUE(TOPs); + *offset = SvIV(offsv); + PUTBACK; + FREETMPS; + LEAVE; + } + else + Perl_croak(aTHX_ "Invalid argument to sv_cat_decode"); + return ret; +}