X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=sv.c;h=2d38d05416eb8a0d6fe02f8090936ecb4eaa0fe1;hb=f3faeb53b75c95d2773d14d859d4fa9ca1594daa;hp=6ed638c742ce3d3aa2cc097a6ffe4f74fcba25d2;hpb=497b47a829dd93323de2c7f4f6815ab9f23d6ada;p=p5sagit%2Fp5-mst-13.2.git diff --git a/sv.c b/sv.c index 6ed638c..2d38d05 100644 --- a/sv.c +++ b/sv.c @@ -19,6 +19,7 @@ #include "EXTERN.h" #define PERL_IN_SV_C #include "perl.h" +#include "regcomp.h" #define FCALL *f #define SV_CHECK_THINKFIRST(sv) if (SvTHINKFIRST(sv)) sv_force_normal(sv) @@ -1568,8 +1569,15 @@ Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen) #endif Renew(s,newlen,char); } - else - New(703,s,newlen,char); + else { + /* sv_force_normal_flags() must not try to unshare the new + PVX we allocate below. AMS 20010713 */ + if (SvREADONLY(sv) && SvFAKE(sv)) { + SvFAKE_off(sv); + SvREADONLY_off(sv); + } + New(703, s, newlen, char); + } SvPV_set(sv, s); SvLEN_set(sv, newlen); } @@ -2046,7 +2054,7 @@ Perl_sv_2iv(pTHX_ register SV *sv) ) { SvIOK_on(sv); /* Can this go wrong with rounding? NWC */ DEBUG_c(PerlIO_printf(Perl_debug_log, - "0x%"UVxf" iv(%g => %"IVdf") (precise)\n", + "0x%"UVxf" iv(%"NVgf" => %"IVdf") (precise)\n", PTR2UV(sv), SvNVX(sv), SvIVX(sv))); @@ -2057,7 +2065,7 @@ Perl_sv_2iv(pTHX_ register SV *sv) that PV->IV would be better than PV->NV->IV flags already correct - don't set public IOK. */ DEBUG_c(PerlIO_printf(Perl_debug_log, - "0x%"UVxf" iv(%g => %"IVdf") (imprecise)\n", + "0x%"UVxf" iv(%"NVgf" => %"IVdf") (imprecise)\n", PTR2UV(sv), SvNVX(sv), SvIVX(sv))); @@ -2340,7 +2348,7 @@ Perl_sv_2uv(pTHX_ register SV *sv) ) { SvIOK_on(sv); /* Can this go wrong with rounding? NWC */ DEBUG_c(PerlIO_printf(Perl_debug_log, - "0x%"UVxf" uv(%g => %"IVdf") (precise)\n", + "0x%"UVxf" uv(%"NVgf" => %"IVdf") (precise)\n", PTR2UV(sv), SvNVX(sv), SvIVX(sv))); @@ -2351,7 +2359,7 @@ Perl_sv_2uv(pTHX_ register SV *sv) that PV->IV would be better than PV->NV->IV flags already correct - don't set public IOK. */ DEBUG_c(PerlIO_printf(Perl_debug_log, - "0x%"UVxf" uv(%g => %"IVdf") (imprecise)\n", + "0x%"UVxf" uv(%"NVgf" => %"IVdf") (imprecise)\n", PTR2UV(sv), SvNVX(sv), SvIVX(sv))); @@ -3613,8 +3621,8 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", GvNAME(dstr)); -#ifdef GV_SHARED_CHECK - if (GvSHARED((GV*)dstr)) { +#ifdef GV_UNIQUE_CHECK + if (GvUNIQUE((GV*)dstr)) { Perl_croak(aTHX_ PL_no_modify); } #endif @@ -3659,8 +3667,8 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) SV *dref = 0; int intro = GvINTRO(dstr); -#ifdef GV_SHARED_CHECK - if (GvSHARED((GV*)dstr)) { +#ifdef GV_UNIQUE_CHECK + if (GvUNIQUE((GV*)dstr)) { Perl_croak(aTHX_ PL_no_modify); } #endif @@ -4101,7 +4109,7 @@ Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags) *SvEND(sv) = '\0'; SvFAKE_off(sv); SvREADONLY_off(sv); - unsharepvn(pvx,SvUTF8(sv)?-len:len,hash); + unsharepvn(pvx, SvUTF8(sv) ? -(I32)len : len, hash); } else if (PL_curcop != &PL_compiling) Perl_croak(aTHX_ PL_no_modify); @@ -4415,9 +4423,9 @@ Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 nam mg->mg_moremagic = SvMAGIC(sv); SvMAGIC(sv) = mg; - /* Some magic sontains a reference loop, where the sv and object refer to - each other. To prevent a avoid a reference loop that would prevent such - objects being freed, we look for such loops and if we find one we avoid + /* Some magic contains a reference loop, where the sv and object refer to + each other. To avoid 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. */ if (!obj || obj == sv || how == PERL_MAGIC_arylen || @@ -4946,7 +4954,9 @@ Perl_sv_clear(pTHX_ register SV *sv) else if (SvPVX(sv) && SvLEN(sv)) Safefree(SvPVX(sv)); else if (SvPVX(sv) && SvREADONLY(sv) && SvFAKE(sv)) { - unsharepvn(SvPVX(sv),SvUTF8(sv)?-SvCUR(sv):SvCUR(sv),SvUVX(sv)); + unsharepvn(SvPVX(sv), + SvUTF8(sv) ? -(I32)SvCUR(sv) : SvCUR(sv), + SvUVX(sv)); SvFAKE_off(sv); } break; @@ -5261,8 +5271,6 @@ Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2) if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) { bool is_utf8 = TRUE; /* UTF-8ness differs */ - if (PL_hints & HINT_UTF8_DISTINCT) - return FALSE; if (SvUTF8(sv1)) { /* sv1 is the UTF-8 one , If is equal it must be downgrade-able */ @@ -5327,9 +5335,6 @@ Perl_sv_cmp(pTHX_ register SV *sv1, register SV *sv2) /* do not utf8ize the comparands as a side-effect */ if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) { - if (PL_hints & HINT_UTF8_DISTINCT) - return SvUTF8(sv1) ? 1 : -1; - if (SvUTF8(sv1)) { pv2 = (char*)bytes_to_utf8((U8*)pv2, &cur2); pv2tmp = TRUE; @@ -6045,8 +6050,9 @@ Perl_sv_dec(pTHX_ register SV *sv) =for apidoc sv_mortalcopy Creates a new SV which is a copy of the original SV (using C). -The new SV is marked as mortal. It will be destroyed when the current -context ends. See also C and C. +The new SV is marked as mortal. It will be destroyed "soon", either by an +explicit call to FREETMPS, or by an implicit call at places such as +statement boundaries. See also C and C. =cut */ @@ -6073,8 +6079,9 @@ Perl_sv_mortalcopy(pTHX_ SV *oldstr) =for apidoc sv_newmortal Creates a new null SV which is mortal. The reference count of the SV is -set to 1. It will be destroyed when the current context ends. See -also C and C. +set to 1. It will be destroyed "soon", either by an explicit call to +FREETMPS, or by an implicit call at places such as statement boundaries. +See also C and C. =cut */ @@ -6094,8 +6101,9 @@ Perl_sv_newmortal(pTHX) /* =for apidoc sv_2mortal -Marks an existing SV as mortal. The SV will be destroyed when the current -context ends. See also C and C. +Marks an existing SV as mortal. The SV will be destroyed "soon", either +by an explicit call to FREETMPS, or by an implicit call at places such as +statement boundaries. See also C and C. =cut */ @@ -6176,11 +6184,8 @@ Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash) register SV *sv; bool is_utf8 = FALSE; if (len < 0) { - len = -len; + STRLEN tmplen = -len; is_utf8 = TRUE; - } - if (is_utf8 && !(PL_hints & HINT_UTF8_DISTINCT)) { - STRLEN tmplen = len; /* See the note in hv.c:hv_fetch() --jhi */ src = (char*)bytes_from_utf8((U8*)src, &tmplen, &is_utf8); len = tmplen; @@ -8337,14 +8342,103 @@ ptr_table_* functions. #define SAVEPVN(p,n) (p ? savepvn(p,n) : Nullch) - -/* duplicate a regexp */ +/* Duplicate a regexp. Required reading: pregcomp() and pregfree() in + regcomp.c. AMS 20010712 */ REGEXP * -Perl_re_dup(pTHX_ REGEXP *r) +Perl_re_dup(pTHX_ REGEXP *r, clone_params *param) { - /* XXX fix when pmop->op_pmregexp becomes shared */ - return ReREFCNT_inc(r); + REGEXP *ret; + int i, len, npar; + struct reg_substr_datum *s; + + if (!r) + return (REGEXP *)NULL; + + if ((ret = (REGEXP *)ptr_table_fetch(PL_ptr_table, r))) + return ret; + + len = r->offsets[0]; + npar = r->nparens+1; + + Newc(0, ret, sizeof(regexp) + (len+1)*sizeof(regnode), char, regexp); + Copy(r->program, ret->program, len+1, regnode); + + New(0, ret->startp, npar, I32); + Copy(r->startp, ret->startp, npar, I32); + New(0, ret->endp, npar, I32); + Copy(r->startp, ret->startp, npar, I32); + + New(0, ret->substrs, 1, struct reg_substr_data); + for (s = ret->substrs->data, i = 0; i < 3; i++, s++) { + s->min_offset = r->substrs->data[i].min_offset; + s->max_offset = r->substrs->data[i].max_offset; + s->substr = sv_dup_inc(r->substrs->data[i].substr, param); + } + + ret->regstclass = NULL; + if (r->data) { + struct reg_data *d; + int count = r->data->count; + + Newc(0, d, sizeof(struct reg_data) + count*sizeof(void *), + char, struct reg_data); + New(0, d->what, count, U8); + + d->count = count; + for (i = 0; i < count; i++) { + d->what[i] = r->data->what[i]; + switch (d->what[i]) { + case 's': + d->data[i] = sv_dup_inc((SV *)r->data->data[i], param); + break; + case 'p': + d->data[i] = av_dup_inc((AV *)r->data->data[i], param); + break; + case 'f': + /* This is cheating. */ + New(0, d->data[i], 1, struct regnode_charclass_class); + StructCopy(r->data->data[i], d->data[i], + struct regnode_charclass_class); + ret->regstclass = (regnode*)d->data[i]; + break; + case 'o': + /* Compiled op trees are readonly, and can thus be + shared without duplication. */ + d->data[i] = (void*)OpREFCNT_inc((OP*)r->data->data[i]); + break; + case 'n': + d->data[i] = r->data->data[i]; + break; + } + } + + ret->data = d; + } + else + ret->data = NULL; + + New(0, ret->offsets, 2*len+1, U32); + Copy(r->offsets, ret->offsets, 2*len+1, U32); + + ret->precomp = SAVEPV(r->precomp); + ret->refcnt = r->refcnt; + ret->minlen = r->minlen; + ret->prelen = r->prelen; + ret->nparens = r->nparens; + ret->lastparen = r->lastparen; + ret->lastcloseparen = r->lastcloseparen; + ret->reganch = r->reganch; + + ret->sublen = r->sublen; + + if (RX_MATCH_COPIED(ret)) + ret->subbeg = SAVEPV(r->subbeg); + else + ret->subbeg = Nullch; + + ptr_table_store(PL_ptr_table, r, ret); + return ret; } /* duplicate a file handle */ @@ -8437,7 +8531,7 @@ Perl_mg_dup(pTHX_ MAGIC *mg, clone_params* param) nmg->mg_type = mg->mg_type; nmg->mg_flags = mg->mg_flags; if (mg->mg_type == PERL_MAGIC_qr) { - nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj); + nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj, param); } else if(mg->mg_type == PERL_MAGIC_backref) { AV *av = (AV*) mg->mg_obj; @@ -8634,7 +8728,7 @@ S_gv_share(pTHX_ SV *sstr) SV *sv = &PL_sv_no; /* just need SvREADONLY-ness */ if (GvIO(gv) || GvFORM(gv)) { - GvSHARED_off(gv); /* GvIOs cannot be shared. nor can GvFORMs */ + GvUNIQUE_off(gv); /* GvIOs cannot be shared. nor can GvFORMs */ } else if (!GvCV(gv)) { GvCV(gv) = (CV*)sv; @@ -8642,11 +8736,11 @@ S_gv_share(pTHX_ SV *sstr) else { /* CvPADLISTs cannot be shared */ if (!CvXSUB(GvCV(gv))) { - GvSHARED_off(gv); + GvUNIQUE_off(gv); } } - if (!GvSHARED(gv)) { + if (!GvUNIQUE(gv)) { #if 0 PerlIO_printf(Perl_debug_log, "gv_share: unable to share %s::%s\n", HvNAME(GvSTASH(gv)), GvNAME(gv)); @@ -8830,7 +8924,7 @@ Perl_sv_dup(pTHX_ SV *sstr, clone_params* param) LvTYPE(dstr) = LvTYPE(sstr); break; case SVt_PVGV: - if (GvSHARED((GV*)sstr)) { + if (GvUNIQUE((GV*)sstr)) { SV *share; if ((share = gv_share(sstr))) { del_SV(dstr); @@ -8996,6 +9090,11 @@ Perl_sv_dup(pTHX_ SV *sstr, clone_params* param) CvROOT(dstr) = OpREFCNT_inc(CvROOT(sstr)); CvXSUB(dstr) = CvXSUB(sstr); CvXSUBANY(dstr) = CvXSUBANY(sstr); + if (CvCONST(sstr)) { + CvXSUBANY(dstr).any_ptr = GvUNIQUE(CvGV(sstr)) ? + SvREFCNT_inc(CvXSUBANY(sstr).any_ptr) : + sv_dup_inc(CvXSUBANY(sstr).any_ptr, param); + } CvGV(dstr) = gv_dup(CvGV(sstr), param); if (param->flags & CLONEf_COPY_STACKS) { CvDEPTH(dstr) = CvDEPTH(sstr); @@ -9211,7 +9310,7 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, clone_params* param) GP *gp; IV iv; I32 i; - char *c; + char *c = NULL; void (*dptr) (void*); void (*dxptr) (pTHXo_ void*); OP *o; @@ -9587,6 +9686,11 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_debug = proto_perl->Idebug; +#ifdef USE_REENTRANT_API + New(31337, PL_reentrant_buffer,1, REBUF); + New(31337, PL_reentrant_buffer->tmbuff,1, struct tm); +#endif + /* create SV map for pointer relocation */ PL_ptr_table = ptr_table_new(); @@ -9691,6 +9795,21 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_statusvalue_vms = proto_perl->Istatusvalue_vms; #endif + /* Clone the regex array */ + PL_regex_padav = newAV(); + { + I32 len = av_len((AV*)proto_perl->Iregex_padav); + SV** regexen = AvARRAY((AV*)proto_perl->Iregex_padav); + for(i = 0; i <= len; i++) { + av_push(PL_regex_padav, + SvREFCNT_inc( + newSViv((IV)re_dup((REGEXP *) + SvIVX(regexen[i]), param)) + )); + } + } + PL_regex_pad = AvARRAY(PL_regex_padav); + /* shortcuts to various I/O objects */ PL_stdingv = gv_dup(proto_perl->Istdingv, param); PL_stderrgv = gv_dup(proto_perl->Istderrgv, param); @@ -9817,7 +9936,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 = SAVEPV(proto_perl->Ish_path); + PL_sh_path = proto_perl->Ish_path; /* XXX never deallocated */ PL_sighandlerp = proto_perl->Isighandlerp; @@ -9827,7 +9946,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, #ifdef CSH PL_cshlen = proto_perl->Icshlen; - PL_cshname = SAVEPVN(proto_perl->Icshname, PL_cshlen); + PL_cshname = proto_perl->Icshname; /* XXX never deallocated */ #endif PL_lex_state = proto_perl->Ilex_state; @@ -10158,6 +10277,9 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_reginterp_cnt = 0; PL_reg_starttry = 0; + /* Pluggable optimizer */ + PL_peepp = proto_perl->Tpeepp; + if (!(flags & CLONEf_KEEP_PTR_TABLE)) { ptr_table_free(PL_ptr_table); PL_ptr_table = NULL; @@ -10174,7 +10296,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, ENTER; SAVETMPS; PUSHMARK(SP); - XPUSHs(newSVpv(HvNAME(stash), 0)); + XPUSHs(sv_2mortal(newSVpv(HvNAME(stash), 0))); PUTBACK; call_sv((SV*)GvCV(cloner), G_DISCARD); FREETMPS; @@ -10182,6 +10304,9 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, } } + SvREFCNT_dec(param->stashes); + Safefree(param); + #ifdef PERL_OBJECT return (PerlInterpreter*)pPerl; #else