X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=sv.c;h=a7e1bda2930c0cac67318ce541528e9a54ae74d9;hb=e930465f0bda9d63d97d7bcbea42ed0d09f68de3;hp=3425ac12dad0e54be94e5e1bf52e26af88fb990f;hpb=ff276b08dc1c6fe6ae5887e417b21d95c3859139;p=p5sagit%2Fp5-mst-13.2.git diff --git a/sv.c b/sv.c index 3425ac1..a7e1bda 100644 --- a/sv.c +++ b/sv.c @@ -8,14 +8,12 @@ * "I wonder what the Entish is for 'yes' and 'no'," he thought. * * - * Manipulation of scalar values (SVs). This file contains the code that - * creates, manipulates and destroys SVs. (Opcode-level functions on SVs - * can be found in the various pp*.c files.) Note that the basic structure - * of an SV is also used to hold the other major Perl data types - AVs, - * HVs, GVs, IO etc. Low-level functions on these other types - such as - * memory allocation and destruction - are handled within this file, while - * higher-level stuff can be found in the individual files av.c, hv.c, - * etc. + * This file contains the code that creates, manipulates and destroys + * scalar values (SVs). The other types (AV, HV, GV, etc.) reuse the + * structure of an SV, so their creation and destruction is handled + * here; higher-level functions are in av.c, hv.c, and so on. Opcode + * level functions (eg. substr, split, join) for each of the types are + * in the pp*.c files. */ #include "EXTERN.h" @@ -30,16 +28,19 @@ =head1 Allocation and deallocation of SVs. -An SV (or AV, HV etc) is in 2 parts: the head and the body. There is only -one type of head, but around 13 body types. Head and body are each -separately allocated. Normally, this allocation is done using arenas, -which are approximately 1K chunks of memory parcelled up into N heads or -bodies. The first slot in each arena is reserved, and is used to hold a -link to the next arena. In the case of heads, the unused first slot -also contains some flags and a note of the number of slots. Snaked through -each arena chain is a linked list of free items; when this becomes empty, -an extra arena is allocated and divided up into N items which are threaded -into the free list. +An SV (or AV, HV, etc.) is allocated in two parts: the head (struct sv, +av, hv...) contains type and reference count information, as well as a +pointer to the body (struct xrv, xpv, xpviv...), which contains fields +specific to each type. + +Normally, this allocation is done using arenas, which are approximately +1K chunks of memory parcelled up into N heads or bodies. The first slot +in each arena is reserved, and is used to hold a link to the next arena. +In the case of heads, the unused first slot also contains some flags and +a note of the number of slots. Snaked through each arena chain is a +linked list of free items; when this becomes empty, an extra arena is +allocated and divided up into N items which are threaded into the free +list. The following global variables are associated with arenas: @@ -2112,7 +2113,7 @@ Perl_sv_2iv(pTHX_ register SV *sv) /* SVt_PVNV is one higher than SVt_PVIV, hence this order */ if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) == IS_NUMBER_IN_UV) { - /* It's defintately an integer, only upgrade to PVIV */ + /* It's definitely an integer, only upgrade to PVIV */ if (SvTYPE(sv) < SVt_PVIV) sv_upgrade(sv, SVt_PVIV); (void)SvIOK_on(sv); @@ -2402,7 +2403,7 @@ Perl_sv_2uv(pTHX_ register SV *sv) /* SVt_PVNV is one higher than SVt_PVIV, hence this order */ if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) == IS_NUMBER_IN_UV) { - /* It's defintately an integer, only upgrade to PVIV */ + /* It's definitely an integer, only upgrade to PVIV */ if (SvTYPE(sv) < SVt_PVIV) sv_upgrade(sv, SVt_PVIV); (void)SvIOK_on(sv); @@ -2644,7 +2645,7 @@ Perl_sv_2nv(pTHX_ register SV *sv) #ifdef NV_PRESERVES_UV if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) == IS_NUMBER_IN_UV) { - /* It's defintately an integer */ + /* It's definitely an integer */ SvNVX(sv) = (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value; } else SvNVX(sv) = Atof(SvPVX(sv)); @@ -3612,8 +3613,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 @@ -3658,8 +3659,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 @@ -4100,7 +4101,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); @@ -4414,9 +4415,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 || @@ -4945,7 +4946,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; @@ -5101,7 +5104,6 @@ coercion. See also C, which gives raw access to the xpv_cur slot. STRLEN Perl_sv_len(pTHX_ register SV *sv) { - char *junk; STRLEN len; if (!sv) @@ -5110,7 +5112,7 @@ Perl_sv_len(pTHX_ register SV *sv) if (SvGMAGICAL(sv)) len = mg_length(sv); else - junk = SvPV(sv, len); + (void)SvPV(sv, len); return len; } @@ -7781,7 +7783,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV q++; if (*q == '*') { q++; - if (EXPECT_NUMBER(q, epix) && *q++ != '$') + if (EXPECT_NUMBER(q, epix) && *q++ != '$') /* epix currently unused */ goto unknown; if (args) i = va_arg(*args, int); @@ -8439,6 +8441,18 @@ Perl_mg_dup(pTHX_ MAGIC *mg, clone_params* param) if (mg->mg_type == PERL_MAGIC_qr) { nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj); } + else if(mg->mg_type == PERL_MAGIC_backref) { + AV *av = (AV*) mg->mg_obj; + SV **svp; + I32 i; + nmg->mg_obj = (SV*)newAV(); + svp = AvARRAY(av); + i = AvFILLp(av); + while (i >= 0) { + av_push((AV*)nmg->mg_obj,sv_dup(svp[i],param)); + i--; + } + } else { nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED) ? sv_dup_inc(mg->mg_obj, param) @@ -8622,7 +8636,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; @@ -8630,11 +8644,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)); @@ -8713,7 +8727,7 @@ Perl_sv_dup(pTHX_ SV *sstr, clone_params* param) break; case SVt_RV: SvANY(dstr) = new_XRV(); - SvRV(dstr) = SvRV(sstr) && SvWEAKREF(SvRV(sstr)) + SvRV(dstr) = SvRV(sstr) && SvWEAKREF(sstr) ? sv_dup(SvRV(sstr), param) : sv_dup_inc(SvRV(sstr), param); break; @@ -8722,7 +8736,7 @@ Perl_sv_dup(pTHX_ SV *sstr, clone_params* param) SvCUR(dstr) = SvCUR(sstr); SvLEN(dstr) = SvLEN(sstr); if (SvROK(sstr)) - SvRV(dstr) = SvWEAKREF(SvRV(sstr)) + SvRV(dstr) = SvWEAKREF(sstr) ? sv_dup(SvRV(sstr), param) : sv_dup_inc(SvRV(sstr), param); else if (SvPVX(sstr) && SvLEN(sstr)) @@ -8736,7 +8750,7 @@ Perl_sv_dup(pTHX_ SV *sstr, clone_params* param) SvLEN(dstr) = SvLEN(sstr); SvIVX(dstr) = SvIVX(sstr); if (SvROK(sstr)) - SvRV(dstr) = SvWEAKREF(SvRV(sstr)) + SvRV(dstr) = SvWEAKREF(sstr) ? sv_dup(SvRV(sstr), param) : sv_dup_inc(SvRV(sstr), param); else if (SvPVX(sstr) && SvLEN(sstr)) @@ -8751,7 +8765,7 @@ Perl_sv_dup(pTHX_ SV *sstr, clone_params* param) SvIVX(dstr) = SvIVX(sstr); SvNVX(dstr) = SvNVX(sstr); if (SvROK(sstr)) - SvRV(dstr) = SvWEAKREF(SvRV(sstr)) + SvRV(dstr) = SvWEAKREF(sstr) ? sv_dup(SvRV(sstr), param) : sv_dup_inc(SvRV(sstr), param); else if (SvPVX(sstr) && SvLEN(sstr)) @@ -8768,7 +8782,7 @@ Perl_sv_dup(pTHX_ SV *sstr, clone_params* param) SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param); SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param); if (SvROK(sstr)) - SvRV(dstr) = SvWEAKREF(SvRV(sstr)) + SvRV(dstr) = SvWEAKREF(sstr) ? sv_dup(SvRV(sstr), param) : sv_dup_inc(SvRV(sstr), param); else if (SvPVX(sstr) && SvLEN(sstr)) @@ -8785,7 +8799,7 @@ Perl_sv_dup(pTHX_ SV *sstr, clone_params* param) SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param); SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param); if (SvROK(sstr)) - SvRV(dstr) = SvWEAKREF(SvRV(sstr)) + SvRV(dstr) = SvWEAKREF(sstr) ? sv_dup(SvRV(sstr), param) : sv_dup_inc(SvRV(sstr), param); else if (SvPVX(sstr) && SvLEN(sstr)) @@ -8805,7 +8819,7 @@ Perl_sv_dup(pTHX_ SV *sstr, clone_params* param) SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param); SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param); if (SvROK(sstr)) - SvRV(dstr) = SvWEAKREF(SvRV(sstr)) + SvRV(dstr) = SvWEAKREF(sstr) ? sv_dup(SvRV(sstr), param) : sv_dup_inc(SvRV(sstr), param); else if (SvPVX(sstr) && SvLEN(sstr)) @@ -8818,7 +8832,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); @@ -8838,7 +8852,7 @@ Perl_sv_dup(pTHX_ SV *sstr, clone_params* param) SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param); SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param); if (SvROK(sstr)) - SvRV(dstr) = SvWEAKREF(SvRV(sstr)) + SvRV(dstr) = SvWEAKREF(sstr) ? sv_dup(SvRV(sstr), param) : sv_dup_inc(SvRV(sstr), param); else if (SvPVX(sstr) && SvLEN(sstr)) @@ -8861,7 +8875,7 @@ Perl_sv_dup(pTHX_ SV *sstr, clone_params* param) SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param); SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param); if (SvROK(sstr)) - SvRV(dstr) = SvWEAKREF(SvRV(sstr)) + SvRV(dstr) = SvWEAKREF(sstr) ? sv_dup(SvRV(sstr), param) : sv_dup_inc(SvRV(sstr), param); else if (SvPVX(sstr) && SvLEN(sstr)) @@ -8957,7 +8971,7 @@ Perl_sv_dup(pTHX_ SV *sstr, clone_params* param) } HvPMROOT((HV*)dstr) = HvPMROOT((HV*)sstr); /* XXX */ HvNAME((HV*)dstr) = SAVEPV(HvNAME((HV*)sstr)); - /* Record stashes for possible cloning in Perl_clone_using(). */ + /* Record stashes for possible cloning in Perl_clone(). */ if(HvNAME((HV*)dstr)) av_push(param->stashes, dstr); break; @@ -9004,6 +9018,7 @@ Perl_sv_dup(pTHX_ SV *sstr, clone_params* param) else CvOUTSIDE(dstr) = cv_dup(CvOUTSIDE(sstr), param); CvFLAGS(dstr) = CvFLAGS(sstr); + CvFILE(dstr) = CvXSUB(sstr) ? CvFILE(sstr) : SAVEPV(CvFILE(sstr)); break; default: Perl_croak(aTHX_ "Bizarre SvTYPE [%d]", SvTYPE(sstr)); @@ -9451,7 +9466,14 @@ perl_clone(PerlInterpreter *proto_perl, UV flags) #endif #ifdef PERL_IMPLICIT_SYS - return perl_clone_using(proto_perl, flags, + + /* perlhost.h so we need to call into it + to clone the host, CPerlHost should have a c interface, sky */ + + if (flags & CLONEf_CLONE_HOST) { + return perl_clone_host(proto_perl,flags); + } + return perl_clone_using(proto_perl, flags, proto_perl->IMem, proto_perl->IMemShared, proto_perl->IMemParse, @@ -10176,8 +10198,3 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, #endif #endif /* USE_ITHREADS */ - - - - -