X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=sv.c;h=a7e1bda2930c0cac67318ce541528e9a54ae74d9;hb=e930465f0bda9d63d97d7bcbea42ed0d09f68de3;hp=555f82dbdae99db881026570af49f9228c5922a9;hpb=832365561240eb07aaddce15adf009487776d2f0;p=p5sagit%2Fp5-mst-13.2.git diff --git a/sv.c b/sv.c index 555f82d..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: @@ -68,12 +69,12 @@ SVs in the free list have their SvTYPE field set to all ones. Similarly, there are macros new_XIV()/del_XIV(), new_XNV()/del_XNV() etc that allocate and return individual body types. Normally these are mapped -to the arena-maniplulating functions new_xiv()/del_xiv() etc, but may be -instead mapped directly to malloc()/free() if PURIFY is in effect. The +to the arena-manipulating functions new_xiv()/del_xiv() etc, but may be +instead mapped directly to malloc()/free() if PURIFY is defined. The new/del functions remove from, or add to, the appropriate PL_foo_root list, and call more_xiv() etc to add a new arena if the list is empty. -It the time of very final cleanup, sv_free_arenas() is called from +At the time of very final cleanup, sv_free_arenas() is called from perl_destruct() to physically free all the arenas allocated since the start of the interpreter. Note that this also clears PL_he_arenaroot, which is otherwise dealt with in hv.c. @@ -271,7 +272,7 @@ S_more_sv(pTHX) return sv; } -/* visit(): call the named function for each non-free in SV the arenas. */ +/* visit(): call the named function for each non-free SV in the arenas. */ STATIC I32 S_visit(pTHX_ SVFUNC_t f) @@ -396,7 +397,7 @@ do_clean_all(pTHXo_ SV *sv) Decrement the refcnt of each remaining SV, possibly triggering a cleanup. This function may have to be called multiple times to free -SVs which are in complex self-referential heirarchies. +SVs which are in complex self-referential hierarchies. =cut */ @@ -1207,9 +1208,9 @@ S_more_xpvbm(pTHX) /* =for apidoc sv_upgrade -Upgrade an SV to a more complex form. Gnenerally adds a new body type to the +Upgrade an SV to a more complex form. Generally adds a new body type to the SV, then copies across as much information as possible from the old body. -You genrally want to use the C macro wrapper. See also C. +You generally want to use the C macro wrapper. See also C. =cut */ @@ -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)); @@ -2857,7 +2858,7 @@ Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp) /* =for apidoc sv_2pv_flags -Returns pointer to the string value of an SV, and sets *lp to its length. +Returns a pointer to the string value of an SV, and sets *lp to its length. If flags includes SV_GMAGIC, does an mg_get() first. Coerces sv to a string if necessary. Normally invoked via the C macro. C and C @@ -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 || @@ -4779,7 +4780,7 @@ Make the first argument a copy of the second, then delete the original. The target SV physically takes over ownership of the body of the source SV and inherits its flags; however, the target keeps any magic it owns, and any magic in the source is discarded. -Note that this a rather specialist SV copying operation; most of the +Note that this is a rather specialist SV copying operation; most of the time you'll want to use C or one of its many macro front-ends. =cut @@ -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; } @@ -6332,7 +6334,7 @@ Perl_newRV_noinc(pTHX_ SV *tmpRef) return sv; } -/* newRV_inc is the offical function name to use now. +/* newRV_inc is the official function name to use now. * newRV_inc is in fact #defined to newRV in sv.h */ @@ -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); @@ -8378,7 +8380,7 @@ Perl_dirp_dup(pTHX_ DIR *dp) return dp; } -/* duplictate a typeglob */ +/* duplicate a typeglob */ GP * Perl_gp_dup(pTHX_ GP *gp, clone_params* param) @@ -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 */ - - - - -