From: Nicholas Clark Date: Fri, 25 Nov 2005 15:12:02 +0000 (+0000) Subject: Move report_uninit() and its static supporting functions to the end of X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=bd81e77b1570766d67e2df1f282cfbd66a8978f3;p=p5sagit%2Fp5-mst-13.2.git Move report_uninit() and its static supporting functions to the end of sv.c, so that they are not sandwiched between the two halves of the SV allocation code. However, the diff looks far more evil than it should given that this is just moving a single albeit large hunk. p4raw-id: //depot/perl@26205 --- diff --git a/sv.c b/sv.c index 206cd2e..add0e9b 100644 --- a/sv.c +++ b/sv.c @@ -602,1280 +602,807 @@ Perl_sv_free_arenas(pTHX) PL_sv_root = 0; } -/* --------------------------------------------------------------------- - * - * support functions for report_uninit() - */ +/* + Here are mid-level routines that manage the allocation of bodies out + of the various arenas. There are 5 kinds of arenas: -/* the maxiumum size of array or hash where we will scan looking - * for the undefined element that triggered the warning */ + 1. SV-head arenas, which are discussed and handled above + 2. regular body arenas + 3. arenas for reduced-size bodies + 4. Hash-Entry arenas + 5. pte arenas (thread related) -#define FUV_MAX_SEARCH_SIZE 1000 + Arena types 2 & 3 are chained by body-type off an array of + arena-root pointers, which is indexed by svtype. Some of the + larger/less used body types are malloced singly, since a large + unused block of them is wasteful. Also, several svtypes dont have + bodies; the data fits into the sv-head itself. The arena-root + pointer thus has a few unused root-pointers (which may be hijacked + later for arena types 4,5) -/* Look for an entry in the hash whose value has the same SV as val; - * If so, return a mortal copy of the key. */ + 3 differs from 2 as an optimization; some body types have several + unused fields in the front of the structure (which are kept in-place + for consistency). These bodies can be allocated in smaller chunks, + because the leading fields arent accessed. Pointers to such bodies + are decremented to point at the unused 'ghost' memory, knowing that + the pointers are used with offsets to the real memory. -STATIC SV* -S_find_hash_subscript(pTHX_ HV *hv, SV* val) + HE, HEK arenas are managed separately, with separate code, but may + be merge-able later.. + + PTE arenas are not sv-bodies, but they share these mid-level + mechanics, so are considered here. The new mid-level mechanics rely + on the sv_type of the body being allocated, so we just reserve one + of the unused body-slots for PTEs, then use it in those (2) PTE + contexts below (line ~10k) +*/ + +STATIC void * +S_more_bodies (pTHX_ size_t size, svtype sv_type) { - dVAR; - register HE **array; - I32 i; + void **arena_root = &PL_body_arenaroots[sv_type]; + void **root = &PL_body_roots[sv_type]; + char *start; + const char *end; + const size_t count = PERL_ARENA_SIZE / size; - if (!hv || SvMAGICAL(hv) || !HvARRAY(hv) || - (HvTOTALKEYS(hv) > FUV_MAX_SEARCH_SIZE)) - return Nullsv; + Newx(start, count*size, char); + *((void **) start) = *arena_root; + *arena_root = (void *)start; - array = HvARRAY(hv); + end = start + (count-1) * size; - for (i=HvMAX(hv); i>0; i--) { - register HE *entry; - for (entry = array[i]; entry; entry = HeNEXT(entry)) { - if (HeVAL(entry) != val) - continue; - if ( HeVAL(entry) == &PL_sv_undef || - HeVAL(entry) == &PL_sv_placeholder) - continue; - if (!HeKEY(entry)) - return Nullsv; - if (HeKLEN(entry) == HEf_SVKEY) - return sv_mortalcopy(HeKEY_sv(entry)); - return sv_2mortal(newSVpvn(HeKEY(entry), HeKLEN(entry))); - } - } - return Nullsv; -} + /* The initial slot is used to link the arenas together, so it isn't to be + linked into the list of ready-to-use bodies. */ -/* Look for an entry in the array whose value has the same SV as val; - * If so, return the index, otherwise return -1. */ + start += size; -STATIC I32 -S_find_array_subscript(pTHX_ AV *av, SV* val) -{ - SV** svp; - I32 i; - if (!av || SvMAGICAL(av) || !AvARRAY(av) || - (AvFILLp(av) > FUV_MAX_SEARCH_SIZE)) - return -1; + *root = (void *)start; - svp = AvARRAY(av); - for (i=AvFILLp(av); i>=0; i--) { - if (svp[i] == val && svp[i] != &PL_sv_undef) - return i; + while (start < end) { + char * const next = start + size; + *(void**) start = (void *)next; + start = next; } - return -1; + *(void **)start = 0; + + return *root; } -/* S_varname(): return the name of a variable, optionally with a subscript. - * If gv is non-zero, use the name of that global, along with gvtype (one - * of "$", "@", "%"); otherwise use the name of the lexical at pad offset - * targ. Depending on the value of the subscript_type flag, return: - */ +/* grab a new thing from the free list, allocating more if necessary */ -#define FUV_SUBSCRIPT_NONE 1 /* "@foo" */ -#define FUV_SUBSCRIPT_ARRAY 2 /* "$foo[aindex]" */ -#define FUV_SUBSCRIPT_HASH 3 /* "$foo{keyname}" */ -#define FUV_SUBSCRIPT_WITHIN 4 /* "within @foo" */ +/* 1st, the inline version */ -STATIC SV* -S_varname(pTHX_ GV *gv, const char gvtype, PADOFFSET targ, - SV* keyname, I32 aindex, int subscript_type) -{ +#define new_body_inline(xpv, size, sv_type) \ + STMT_START { \ + void **r3wt = &PL_body_roots[sv_type]; \ + LOCK_SV_MUTEX; \ + xpv = *((void **)(r3wt)) \ + ? *((void **)(r3wt)) : S_more_bodies(aTHX_ size, sv_type); \ + *(r3wt) = *(void**)(xpv); \ + UNLOCK_SV_MUTEX; \ + } STMT_END - SV * const name = sv_newmortal(); - if (gv) { - char buffer[2]; - buffer[0] = gvtype; - buffer[1] = 0; +/* now use the inline version in the proper function */ - /* as gv_fullname4(), but add literal '^' for $^FOO names */ +#ifndef PURIFY - gv_fullname4(name, gv, buffer, 0); +/* This isn't being used with -DPURIFY, so don't declare it. Otherwise + compilers issue warnings. */ - if ((unsigned int)SvPVX(name)[1] <= 26) { - buffer[0] = '^'; - buffer[1] = SvPVX(name)[1] + 'A' - 1; +STATIC void * +S_new_body(pTHX_ size_t size, svtype sv_type) +{ + void *xpv; + new_body_inline(xpv, size, sv_type); + return xpv; +} - /* Swap the 1 unprintable control character for the 2 byte pretty - version - ie substr($name, 1, 1) = $buffer; */ - sv_insert(name, 1, 1, buffer, 2); - } - } - else { - U32 unused; - CV * const cv = find_runcv(&unused); - SV *sv; - AV *av; +#endif - if (!cv || !CvPADLIST(cv)) - return Nullsv; - av = (AV*)(*av_fetch(CvPADLIST(cv), 0, FALSE)); - sv = *av_fetch(av, targ, FALSE); - /* SvLEN in a pad name is not to be trusted */ - sv_setpv(name, SvPV_nolen_const(sv)); - } +/* return a thing to the free list */ - if (subscript_type == FUV_SUBSCRIPT_HASH) { - SV * const sv = NEWSV(0,0); - *SvPVX(name) = '$'; - Perl_sv_catpvf(aTHX_ name, "{%s}", - pv_display(sv,SvPVX_const(keyname), SvCUR(keyname), 0, 32)); - SvREFCNT_dec(sv); - } - else if (subscript_type == FUV_SUBSCRIPT_ARRAY) { - *SvPVX(name) = '$'; - Perl_sv_catpvf(aTHX_ name, "[%"IVdf"]", (IV)aindex); - } - else if (subscript_type == FUV_SUBSCRIPT_WITHIN) - sv_insert(name, 0, 0, "within ", 7); +#define del_body(thing, root) \ + STMT_START { \ + void **thing_copy = (void **)thing; \ + LOCK_SV_MUTEX; \ + *thing_copy = *root; \ + *root = (void*)thing_copy; \ + UNLOCK_SV_MUTEX; \ + } STMT_END - return name; -} +/* + Revisiting type 3 arenas, there are 4 body-types which have some + members that are never accessed. They are XPV, XPVIV, XPVAV, + XPVHV, which have corresponding types: xpv_allocated, + xpviv_allocated, xpvav_allocated, xpvhv_allocated, + For these types, the arenas are carved up into *_allocated size + chunks, we thus avoid wasted memory for those unaccessed members. + When bodies are allocated, we adjust the pointer back in memory by + the size of the bit not allocated, so it's as if we allocated the + full structure. (But things will all go boom if you write to the + part that is "not there", because you'll be overwriting the last + members of the preceding structure in memory.) -/* -=for apidoc find_uninit_var + We calculate the correction using the STRUCT_OFFSET macro. For example, if + xpv_allocated is the same structure as XPV then the two OFFSETs sum to zero, + and the pointer is unchanged. If the allocated structure is smaller (no + initial NV actually allocated) then the net effect is to subtract the size + of the NV from the pointer, to return a new pointer as if an initial NV were + actually allocated. -Find the name of the undefined variable (if any) that caused the operator o -to issue a "Use of uninitialized value" warning. -If match is true, only return a name if it's value matches uninit_sv. -So roughly speaking, if a unary operator (such as OP_COS) generates a -warning, then following the direct child of the op may yield an -OP_PADSV or OP_GV that gives the name of the undefined variable. On the -other hand, with OP_ADD there are two branches to follow, so we only print -the variable name if we get an exact match. + This is the same trick as was used for NV and IV bodies. Ironically it + doesn't need to be used for NV bodies any more, because NV is now at the + start of the structure. IV bodies don't need it either, because they are + no longer allocated. */ -The name is returned as a mortal SV. +/* The following 2 arrays hide the above details in a pair of + lookup-tables, allowing us to be body-type agnostic. -Assumes that PL_op is the op that originally triggered the error, and that -PL_comppad/PL_curpad points to the currently executing pad. + size maps svtype to its body's allocated size. + offset maps svtype to the body-pointer adjustment needed -=cut + NB: elements in latter are 0 or <0, and are added during + allocation, and subtracted during deallocation. It may be clearer + to invert the values, and call it shrinkage_by_svtype. */ -STATIC SV * -S_find_uninit_var(pTHX_ OP* obase, SV* uninit_sv, bool match) -{ - dVAR; - SV *sv; - AV *av; - GV *gv; - OP *o, *o2, *kid; - - if (!obase || (match && (!uninit_sv || uninit_sv == &PL_sv_undef || - uninit_sv == &PL_sv_placeholder))) - return Nullsv; +struct body_details { + size_t size; /* Size to allocate */ + size_t copy; /* Size of structure to copy (may be shorter) */ + size_t offset; + bool cant_upgrade; /* Can upgrade this type */ + bool zero_nv; /* zero the NV when upgrading from this */ + bool arena; /* Allocated from an arena */ +}; - switch (obase->op_type) { +#define HADNV FALSE +#define NONV TRUE - case OP_RV2AV: - case OP_RV2HV: - case OP_PADAV: - case OP_PADHV: - { - const bool pad = (obase->op_type == OP_PADAV || obase->op_type == OP_PADHV); - const bool hash = (obase->op_type == OP_PADHV || obase->op_type == OP_RV2HV); - I32 index = 0; - SV *keysv = Nullsv; - int subscript_type = FUV_SUBSCRIPT_WITHIN; +#ifdef PURIFY +/* With -DPURFIY we allocate everything directly, and don't use arenas. + This seems a rather elegant way to simplify some of the code below. */ +#define HASARENA FALSE +#else +#define HASARENA TRUE +#endif +#define NOARENA FALSE - if (pad) { /* @lex, %lex */ - sv = PAD_SVl(obase->op_targ); - gv = Nullgv; - } - else { - if (cUNOPx(obase)->op_first->op_type == OP_GV) { - /* @global, %global */ - gv = cGVOPx_gv(cUNOPx(obase)->op_first); - if (!gv) - break; - sv = hash ? (SV*)GvHV(gv): (SV*)GvAV(gv); - } - else /* @{expr}, %{expr} */ - return find_uninit_var(cUNOPx(obase)->op_first, - uninit_sv, match); - } +/* A macro to work out the offset needed to subtract from a pointer to (say) - /* attempt to find a match within the aggregate */ - if (hash) { - keysv = S_find_hash_subscript(aTHX_ (HV*)sv, uninit_sv); - if (keysv) - subscript_type = FUV_SUBSCRIPT_HASH; - } - else { - index = S_find_array_subscript(aTHX_ (AV*)sv, uninit_sv); - if (index >= 0) - subscript_type = FUV_SUBSCRIPT_ARRAY; - } +typedef struct { + STRLEN xpv_cur; + STRLEN xpv_len; +} xpv_allocated; - if (match && subscript_type == FUV_SUBSCRIPT_WITHIN) - break; +to make its members accessible via a pointer to (say) - return varname(gv, hash ? '%' : '@', obase->op_targ, - keysv, index, subscript_type); - } +struct xpv { + NV xnv_nv; + STRLEN xpv_cur; + STRLEN xpv_len; +}; - case OP_PADSV: - if (match && PAD_SVl(obase->op_targ) != uninit_sv) - break; - return varname(Nullgv, '$', obase->op_targ, - Nullsv, 0, FUV_SUBSCRIPT_NONE); +*/ - case OP_GVSV: - gv = cGVOPx_gv(obase); - if (!gv || (match && GvSV(gv) != uninit_sv)) - break; - return varname(gv, '$', 0, Nullsv, 0, FUV_SUBSCRIPT_NONE); +#define relative_STRUCT_OFFSET(longer, shorter, member) \ + (STRUCT_OFFSET(shorter, member) - STRUCT_OFFSET(longer, member)) - case OP_AELEMFAST: - if (obase->op_flags & OPf_SPECIAL) { /* lexical array */ - if (match) { - SV **svp; - av = (AV*)PAD_SV(obase->op_targ); - if (!av || SvRMAGICAL(av)) - break; - svp = av_fetch(av, (I32)obase->op_private, FALSE); - if (!svp || *svp != uninit_sv) - break; - } - return varname(Nullgv, '$', obase->op_targ, - Nullsv, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY); - } - else { - gv = cGVOPx_gv(obase); - if (!gv) - break; - if (match) { - SV **svp; - av = GvAV(gv); - if (!av || SvRMAGICAL(av)) - break; - svp = av_fetch(av, (I32)obase->op_private, FALSE); - if (!svp || *svp != uninit_sv) - break; - } - return varname(gv, '$', 0, - Nullsv, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY); - } - break; +/* Calculate the length to copy. Specifically work out the length less any + final padding the compiler needed to add. See the comment in sv_upgrade + for why copying the padding proved to be a bug. */ - case OP_EXISTS: - o = cUNOPx(obase)->op_first; - if (!o || o->op_type != OP_NULL || - ! (o->op_targ == OP_AELEM || o->op_targ == OP_HELEM)) - break; - return find_uninit_var(cBINOPo->op_last, uninit_sv, match); +#define copy_length(type, last_member) \ + STRUCT_OFFSET(type, last_member) \ + + sizeof (((type*)SvANY((SV*)0))->last_member) - case OP_AELEM: - case OP_HELEM: - if (PL_op == obase) - /* $a[uninit_expr] or $h{uninit_expr} */ - return find_uninit_var(cBINOPx(obase)->op_last, uninit_sv, match); +static const struct body_details bodies_by_type[] = { + {0, 0, 0, FALSE, NONV, NOARENA}, + /* IVs are in the head, so the allocation size is 0 */ + {0, sizeof(IV), STRUCT_OFFSET(XPVIV, xiv_iv), FALSE, NONV, NOARENA}, + /* 8 bytes on most ILP32 with IEEE doubles */ + {sizeof(NV), sizeof(NV), 0, FALSE, HADNV, HASARENA}, + /* RVs are in the head now */ + /* However, this slot is overloaded and used by the pte */ + {0, 0, 0, FALSE, NONV, NOARENA}, + /* 8 bytes on most ILP32 with IEEE doubles */ + {sizeof(xpv_allocated), + copy_length(XPV, xpv_len) + + relative_STRUCT_OFFSET(XPV, xpv_allocated, xpv_cur), + - relative_STRUCT_OFFSET(XPV, xpv_allocated, xpv_cur), + FALSE, NONV, HASARENA}, + /* 12 */ + {sizeof(xpviv_allocated), + copy_length(XPVIV, xiv_u) + + relative_STRUCT_OFFSET(XPVIV, xpviv_allocated, xpv_cur), + - relative_STRUCT_OFFSET(XPVIV, xpviv_allocated, xpv_cur), + FALSE, NONV, HASARENA}, + /* 20 */ + {sizeof(XPVNV), copy_length(XPVNV, xiv_u), 0, FALSE, HADNV, HASARENA}, + /* 28 */ + {sizeof(XPVMG), copy_length(XPVMG, xmg_stash), 0, FALSE, HADNV, HASARENA}, + /* 36 */ + {sizeof(XPVBM), sizeof(XPVBM), 0, TRUE, HADNV, HASARENA}, + /* 48 */ + {sizeof(XPVGV), sizeof(XPVGV), 0, TRUE, HADNV, HASARENA}, + /* 64 */ + {sizeof(XPVLV), sizeof(XPVLV), 0, TRUE, HADNV, HASARENA}, + /* 20 */ + {sizeof(xpvav_allocated), + copy_length(XPVAV, xmg_stash) + + relative_STRUCT_OFFSET(XPVAV, xpvav_allocated, xav_fill), + - relative_STRUCT_OFFSET(XPVAV, xpvav_allocated, xav_fill), + TRUE, HADNV, HASARENA}, + /* 20 */ + {sizeof(xpvhv_allocated), + copy_length(XPVHV, xmg_stash) + + relative_STRUCT_OFFSET(XPVHV, xpvhv_allocated, xhv_fill), + - relative_STRUCT_OFFSET(XPVHV, xpvhv_allocated, xhv_fill), + TRUE, HADNV, HASARENA}, + /* 76 */ + {sizeof(XPVCV), sizeof(XPVCV), 0, TRUE, HADNV, HASARENA}, + /* 80 */ + {sizeof(XPVFM), sizeof(XPVFM), 0, TRUE, HADNV, NOARENA}, + /* 84 */ + {sizeof(XPVIO), sizeof(XPVIO), 0, TRUE, HADNV, NOARENA} +}; - gv = Nullgv; - o = cBINOPx(obase)->op_first; - kid = cBINOPx(obase)->op_last; +#define new_body_type(sv_type) \ + (void *)((char *)S_new_body(aTHX_ bodies_by_type[sv_type].size, sv_type)\ + - bodies_by_type[sv_type].offset) - /* get the av or hv, and optionally the gv */ - sv = Nullsv; - if (o->op_type == OP_PADAV || o->op_type == OP_PADHV) { - sv = PAD_SV(o->op_targ); - } - else if ((o->op_type == OP_RV2AV || o->op_type == OP_RV2HV) - && cUNOPo->op_first->op_type == OP_GV) - { - gv = cGVOPx_gv(cUNOPo->op_first); - if (!gv) - break; - sv = o->op_type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)GvAV(gv); - } - if (!sv) - break; +#define del_body_type(p, sv_type) \ + del_body(p, &PL_body_roots[sv_type]) - if (kid && kid->op_type == OP_CONST && SvOK(cSVOPx_sv(kid))) { - /* index is constant */ - if (match) { - if (SvMAGICAL(sv)) - break; - if (obase->op_type == OP_HELEM) { - HE* he = hv_fetch_ent((HV*)sv, cSVOPx_sv(kid), 0, 0); - if (!he || HeVAL(he) != uninit_sv) - break; - } - else { - SV ** const svp = av_fetch((AV*)sv, SvIV(cSVOPx_sv(kid)), FALSE); - if (!svp || *svp != uninit_sv) - break; - } - } - if (obase->op_type == OP_HELEM) - return varname(gv, '%', o->op_targ, - cSVOPx_sv(kid), 0, FUV_SUBSCRIPT_HASH); - else - return varname(gv, '@', o->op_targ, Nullsv, - SvIV(cSVOPx_sv(kid)), FUV_SUBSCRIPT_ARRAY); - ; - } - else { - /* index is an expression; - * attempt to find a match within the aggregate */ - if (obase->op_type == OP_HELEM) { - SV * const keysv = S_find_hash_subscript(aTHX_ (HV*)sv, uninit_sv); - if (keysv) - return varname(gv, '%', o->op_targ, - keysv, 0, FUV_SUBSCRIPT_HASH); - } - else { - const I32 index = S_find_array_subscript(aTHX_ (AV*)sv, uninit_sv); - if (index >= 0) - return varname(gv, '@', o->op_targ, - Nullsv, index, FUV_SUBSCRIPT_ARRAY); - } - if (match) - break; - return varname(gv, - (o->op_type == OP_PADAV || o->op_type == OP_RV2AV) - ? '@' : '%', - o->op_targ, Nullsv, 0, FUV_SUBSCRIPT_WITHIN); - } - break; +#define new_body_allocated(sv_type) \ + (void *)((char *)S_new_body(aTHX_ bodies_by_type[sv_type].size, sv_type)\ + - bodies_by_type[sv_type].offset) - case OP_AASSIGN: - /* only examine RHS */ - return find_uninit_var(cBINOPx(obase)->op_first, uninit_sv, match); +#define del_body_allocated(p, sv_type) \ + del_body(p + bodies_by_type[sv_type].offset, &PL_body_roots[sv_type]) - case OP_OPEN: - o = cUNOPx(obase)->op_first; - if (o->op_type == OP_PUSHMARK) - o = o->op_sibling; - if (!o->op_sibling) { - /* one-arg version of open is highly magical */ +#define my_safemalloc(s) (void*)safemalloc(s) +#define my_safecalloc(s) (void*)safecalloc(s, 1) +#define my_safefree(p) safefree((char*)p) - if (o->op_type == OP_GV) { /* open FOO; */ - gv = cGVOPx_gv(o); - if (match && GvSV(gv) != uninit_sv) - break; - return varname(gv, '$', 0, - Nullsv, 0, FUV_SUBSCRIPT_NONE); - } - /* other possibilities not handled are: - * open $x; or open my $x; should return '${*$x}' - * open expr; should return '$'.expr ideally - */ - break; - } - goto do_op; +#ifdef PURIFY - /* ops where $_ may be an implicit arg */ - case OP_TRANS: - case OP_SUBST: - case OP_MATCH: - if ( !(obase->op_flags & OPf_STACKED)) { - if (uninit_sv == ((obase->op_private & OPpTARGET_MY) - ? PAD_SVl(obase->op_targ) - : DEFSV)) - { - sv = sv_newmortal(); - sv_setpvn(sv, "$_", 2); - return sv; - } - } - goto do_op; +#define new_XNV() my_safemalloc(sizeof(XPVNV)) +#define del_XNV(p) my_safefree(p) - case OP_PRTF: - case OP_PRINT: - /* skip filehandle as it can't produce 'undef' warning */ - o = cUNOPx(obase)->op_first; - if ((obase->op_flags & OPf_STACKED) && o->op_type == OP_PUSHMARK) - o = o->op_sibling->op_sibling; - goto do_op2; +#define new_XPVNV() my_safemalloc(sizeof(XPVNV)) +#define del_XPVNV(p) my_safefree(p) +#define new_XPVAV() my_safemalloc(sizeof(XPVAV)) +#define del_XPVAV(p) my_safefree(p) - case OP_RV2SV: - case OP_CUSTOM: - case OP_ENTERSUB: - match = 1; /* XS or custom code could trigger random warnings */ - goto do_op; +#define new_XPVHV() my_safemalloc(sizeof(XPVHV)) +#define del_XPVHV(p) my_safefree(p) - case OP_SCHOMP: - case OP_CHOMP: - if (SvROK(PL_rs) && uninit_sv == SvRV(PL_rs)) - return sv_2mortal(newSVpvn("${$/}", 5)); - /* FALL THROUGH */ +#define new_XPVMG() my_safemalloc(sizeof(XPVMG)) +#define del_XPVMG(p) my_safefree(p) - default: - do_op: - if (!(obase->op_flags & OPf_KIDS)) - break; - o = cUNOPx(obase)->op_first; - - do_op2: - if (!o) - break; +#define new_XPVGV() my_safemalloc(sizeof(XPVGV)) +#define del_XPVGV(p) my_safefree(p) - /* if all except one arg are constant, or have no side-effects, - * or are optimized away, then it's unambiguous */ - o2 = Nullop; - for (kid=o; kid; kid = kid->op_sibling) { - if (kid && - ( (kid->op_type == OP_CONST && SvOK(cSVOPx_sv(kid))) - || (kid->op_type == OP_NULL && ! (kid->op_flags & OPf_KIDS)) - || (kid->op_type == OP_PUSHMARK) - ) - ) - continue; - if (o2) { /* more than one found */ - o2 = Nullop; - break; - } - o2 = kid; - } - if (o2) - return find_uninit_var(o2, uninit_sv, match); +#else /* !PURIFY */ - /* scan all args */ - while (o) { - sv = find_uninit_var(o, uninit_sv, 1); - if (sv) - return sv; - o = o->op_sibling; - } - break; - } - return Nullsv; -} +#define new_XNV() new_body_type(SVt_NV) +#define del_XNV(p) del_body_type(p, SVt_NV) +#define new_XPVNV() new_body_type(SVt_PVNV) +#define del_XPVNV(p) del_body_type(p, SVt_PVNV) -/* -=for apidoc report_uninit +#define new_XPVAV() new_body_allocated(SVt_PVAV) +#define del_XPVAV(p) del_body_allocated(p, SVt_PVAV) -Print appropriate "Use of uninitialized variable" warning +#define new_XPVHV() new_body_allocated(SVt_PVHV) +#define del_XPVHV(p) del_body_allocated(p, SVt_PVHV) -=cut -*/ +#define new_XPVMG() new_body_type(SVt_PVMG) +#define del_XPVMG(p) del_body_type(p, SVt_PVMG) -void -Perl_report_uninit(pTHX_ SV* uninit_sv) -{ - if (PL_op) { - SV* varname = Nullsv; - if (uninit_sv) { - varname = find_uninit_var(PL_op, uninit_sv,0); - if (varname) - sv_insert(varname, 0, 0, " ", 1); - } - Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit, - varname ? SvPV_nolen_const(varname) : "", - " in ", OP_DESC(PL_op)); - } - else - Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit, - "", "", ""); -} +#define new_XPVGV() new_body_type(SVt_PVGV) +#define del_XPVGV(p) del_body_type(p, SVt_PVGV) -/* - Here are mid-level routines that manage the allocation of bodies out - of the various arenas. There are 5 kinds of arenas: +#endif /* PURIFY */ - 1. SV-head arenas, which are discussed and handled above - 2. regular body arenas - 3. arenas for reduced-size bodies - 4. Hash-Entry arenas - 5. pte arenas (thread related) +/* no arena for you! */ - Arena types 2 & 3 are chained by body-type off an array of - arena-root pointers, which is indexed by svtype. Some of the - larger/less used body types are malloced singly, since a large - unused block of them is wasteful. Also, several svtypes dont have - bodies; the data fits into the sv-head itself. The arena-root - pointer thus has a few unused root-pointers (which may be hijacked - later for arena types 4,5) +#define new_NOARENA(details) \ + my_safemalloc((details)->size + (details)->offset) +#define new_NOARENAZ(details) \ + my_safecalloc((details)->size + (details)->offset) - 3 differs from 2 as an optimization; some body types have several - unused fields in the front of the structure (which are kept in-place - for consistency). These bodies can be allocated in smaller chunks, - because the leading fields arent accessed. Pointers to such bodies - are decremented to point at the unused 'ghost' memory, knowing that - the pointers are used with offsets to the real memory. +/* +=for apidoc sv_upgrade - HE, HEK arenas are managed separately, with separate code, but may - be merge-able later.. +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 generally want to use the C macro wrapper. See also C. - PTE arenas are not sv-bodies, but they share these mid-level - mechanics, so are considered here. The new mid-level mechanics rely - on the sv_type of the body being allocated, so we just reserve one - of the unused body-slots for PTEs, then use it in those (2) PTE - contexts below (line ~10k) +=cut */ -STATIC void * -S_more_bodies (pTHX_ size_t size, svtype sv_type) +void +Perl_sv_upgrade(pTHX_ register SV *sv, U32 new_type) { - void **arena_root = &PL_body_arenaroots[sv_type]; - void **root = &PL_body_roots[sv_type]; - char *start; - const char *end; - const size_t count = PERL_ARENA_SIZE / size; - - Newx(start, count*size, char); - *((void **) start) = *arena_root; - *arena_root = (void *)start; + void* old_body; + void* new_body; + const U32 old_type = SvTYPE(sv); + const struct body_details *const old_type_details + = bodies_by_type + old_type; + const struct body_details *new_type_details = bodies_by_type + new_type; - end = start + (count-1) * size; + if (new_type != SVt_PV && SvIsCOW(sv)) { + sv_force_normal_flags(sv, 0); + } - /* The initial slot is used to link the arenas together, so it isn't to be - linked into the list of ready-to-use bodies. */ + if (old_type == new_type) + return; - start += size; + if (old_type > new_type) + Perl_croak(aTHX_ "sv_upgrade from type %d down to type %d", + (int)old_type, (int)new_type); - *root = (void *)start; - while (start < end) { - char * const next = start + size; - *(void**) start = (void *)next; - start = next; - } - *(void **)start = 0; + old_body = SvANY(sv); - return *root; -} + /* Copying structures onto other structures that have been neatly zeroed + has a subtle gotcha. Consider XPVMG -/* grab a new thing from the free list, allocating more if necessary */ + +------+------+------+------+------+-------+-------+ + | NV | CUR | LEN | IV | MAGIC | STASH | + +------+------+------+------+------+-------+-------+ + 0 4 8 12 16 20 24 28 -/* 1st, the inline version */ + where NVs are aligned to 8 bytes, so that sizeof that structure is + actually 32 bytes long, with 4 bytes of padding at the end: -#define new_body_inline(xpv, size, sv_type) \ - STMT_START { \ - void **r3wt = &PL_body_roots[sv_type]; \ - LOCK_SV_MUTEX; \ - xpv = *((void **)(r3wt)) \ - ? *((void **)(r3wt)) : S_more_bodies(aTHX_ size, sv_type); \ - *(r3wt) = *(void**)(xpv); \ - UNLOCK_SV_MUTEX; \ - } STMT_END + +------+------+------+------+------+-------+-------+------+ + | NV | CUR | LEN | IV | MAGIC | STASH | ??? | + +------+------+------+------+------+-------+-------+------+ + 0 4 8 12 16 20 24 28 32 -/* now use the inline version in the proper function */ + so what happens if you allocate memory for this structure: -#ifndef PURIFY + +------+------+------+------+------+-------+-------+------+------+... + | NV | CUR | LEN | IV | MAGIC | STASH | GP | NAME | + +------+------+------+------+------+-------+-------+------+------+... + 0 4 8 12 16 20 24 28 32 36 -/* This isn't being used with -DPURIFY, so don't declare it. Otherwise - compilers issue warnings. */ + zero it, then copy sizeof(XPVMG) bytes on top of it? Not quite what you + expect, because you copy the area marked ??? onto GP. Now, ??? may have + started out as zero once, but it's quite possible that it isn't. So now, + rather than a nicely zeroed GP, you have it pointing somewhere random. + Bugs ensue. -STATIC void * -S_new_body(pTHX_ size_t size, svtype sv_type) -{ - void *xpv; - new_body_inline(xpv, size, sv_type); - return xpv; -} + (In fact, GP ends up pointing at a previous GP structure, because the + principle cause of the padding in XPVMG getting garbage is a copy of + sizeof(XPVMG) bytes from a XPVGV structure in sv_unglob) -#endif + So we are careful and work out the size of used parts of all the + structures. */ -/* return a thing to the free list */ + switch (old_type) { + case SVt_NULL: + break; + case SVt_IV: + if (new_type < SVt_PVIV) { + new_type = (new_type == SVt_NV) + ? SVt_PVNV : SVt_PVIV; + new_type_details = bodies_by_type + new_type; + } + break; + case SVt_NV: + if (new_type < SVt_PVNV) { + new_type = SVt_PVNV; + new_type_details = bodies_by_type + new_type; + } + break; + case SVt_RV: + break; + case SVt_PV: + assert(new_type > SVt_PV); + assert(SVt_IV < SVt_PV); + assert(SVt_NV < SVt_PV); + break; + case SVt_PVIV: + break; + case SVt_PVNV: + break; + case SVt_PVMG: + /* Because the XPVMG of PL_mess_sv isn't allocated from the arena, + there's no way that it can be safely upgraded, because perl.c + expects to Safefree(SvANY(PL_mess_sv)) */ + assert(sv != PL_mess_sv); + /* This flag bit is used to mean other things in other scalar types. + Given that it only has meaning inside the pad, it shouldn't be set + on anything that can get upgraded. */ + assert((SvFLAGS(sv) & SVpad_TYPED) == 0); + break; + default: + if (old_type_details->cant_upgrade) + Perl_croak(aTHX_ "Can't upgrade that kind of scalar"); + } -#define del_body(thing, root) \ - STMT_START { \ - void **thing_copy = (void **)thing; \ - LOCK_SV_MUTEX; \ - *thing_copy = *root; \ - *root = (void*)thing_copy; \ - UNLOCK_SV_MUTEX; \ - } STMT_END + SvFLAGS(sv) &= ~SVTYPEMASK; + SvFLAGS(sv) |= new_type; -/* - Revisiting type 3 arenas, there are 4 body-types which have some - members that are never accessed. They are XPV, XPVIV, XPVAV, - XPVHV, which have corresponding types: xpv_allocated, - xpviv_allocated, xpvav_allocated, xpvhv_allocated, + switch (new_type) { + case SVt_NULL: + Perl_croak(aTHX_ "Can't upgrade to undef"); + case SVt_IV: + assert(old_type == SVt_NULL); + SvANY(sv) = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv)); + SvIV_set(sv, 0); + return; + case SVt_NV: + assert(old_type == SVt_NULL); + SvANY(sv) = new_XNV(); + SvNV_set(sv, 0); + return; + case SVt_RV: + assert(old_type == SVt_NULL); + SvANY(sv) = &sv->sv_u.svu_rv; + SvRV_set(sv, 0); + return; + case SVt_PVHV: + SvANY(sv) = new_XPVHV(); + HvFILL(sv) = 0; + HvMAX(sv) = 0; + HvTOTALKEYS(sv) = 0; - For these types, the arenas are carved up into *_allocated size - chunks, we thus avoid wasted memory for those unaccessed members. - When bodies are allocated, we adjust the pointer back in memory by - the size of the bit not allocated, so it's as if we allocated the - full structure. (But things will all go boom if you write to the - part that is "not there", because you'll be overwriting the last - members of the preceding structure in memory.) + goto hv_av_common; - We calculate the correction using the STRUCT_OFFSET macro. For example, if - xpv_allocated is the same structure as XPV then the two OFFSETs sum to zero, - and the pointer is unchanged. If the allocated structure is smaller (no - initial NV actually allocated) then the net effect is to subtract the size - of the NV from the pointer, to return a new pointer as if an initial NV were - actually allocated. + case SVt_PVAV: + SvANY(sv) = new_XPVAV(); + AvMAX(sv) = -1; + AvFILLp(sv) = -1; + AvALLOC(sv) = 0; + AvREAL_only(sv); - This is the same trick as was used for NV and IV bodies. Ironically it - doesn't need to be used for NV bodies any more, because NV is now at the - start of the structure. IV bodies don't need it either, because they are - no longer allocated. */ + hv_av_common: + /* SVt_NULL isn't the only thing upgraded to AV or HV. + The target created by newSVrv also is, and it can have magic. + However, it never has SvPVX set. + */ + if (old_type >= SVt_RV) { + assert(SvPVX_const(sv) == 0); + } -/* The following 2 arrays hide the above details in a pair of - lookup-tables, allowing us to be body-type agnostic. + /* Could put this in the else clause below, as PVMG must have SvPVX + 0 already (the assertion above) */ + SvPV_set(sv, (char*)0); - size maps svtype to its body's allocated size. - offset maps svtype to the body-pointer adjustment needed + if (old_type >= SVt_PVMG) { + SvMAGIC_set(sv, ((XPVMG*)old_body)->xmg_magic); + SvSTASH_set(sv, ((XPVMG*)old_body)->xmg_stash); + } else { + SvMAGIC_set(sv, 0); + SvSTASH_set(sv, 0); + } + break; - NB: elements in latter are 0 or <0, and are added during - allocation, and subtracted during deallocation. It may be clearer - to invert the values, and call it shrinkage_by_svtype. -*/ -struct body_details { - size_t size; /* Size to allocate */ - size_t copy; /* Size of structure to copy (may be shorter) */ - size_t offset; - bool cant_upgrade; /* Can upgrade this type */ - bool zero_nv; /* zero the NV when upgrading from this */ - bool arena; /* Allocated from an arena */ -}; + case SVt_PVIV: + /* XXX Is this still needed? Was it ever needed? Surely as there is + no route from NV to PVIV, NOK can never be true */ + assert(!SvNOKp(sv)); + assert(!SvNOK(sv)); + case SVt_PVIO: + case SVt_PVFM: + case SVt_PVBM: + case SVt_PVGV: + case SVt_PVCV: + case SVt_PVLV: + case SVt_PVMG: + case SVt_PVNV: + case SVt_PV: -#define HADNV FALSE -#define NONV TRUE + assert(new_type_details->size); + /* We always allocated the full length item with PURIFY. To do this + we fake things so that arena is false for all 16 types.. */ + if(new_type_details->arena) { + /* This points to the start of the allocated area. */ + new_body_inline(new_body, new_type_details->size, new_type); + Zero(new_body, new_type_details->size, char); + new_body = ((char *)new_body) - new_type_details->offset; + } else { + new_body = new_NOARENAZ(new_type_details); + } + SvANY(sv) = new_body; -#ifdef PURIFY -/* With -DPURFIY we allocate everything directly, and don't use arenas. - This seems a rather elegant way to simplify some of the code below. */ -#define HASARENA FALSE -#else -#define HASARENA TRUE + if (old_type_details->copy) { + Copy((char *)old_body + old_type_details->offset, + (char *)new_body + old_type_details->offset, + old_type_details->copy, char); + } + +#ifndef NV_ZERO_IS_ALLBITS_ZERO + /* If NV 0.0 is store as all bits 0 then Zero() already creates a correct + 0.0 for us. */ + if (old_type_details->zero_nv) + SvNV_set(sv, 0); #endif -#define NOARENA FALSE -/* A macro to work out the offset needed to subtract from a pointer to (say) + if (new_type == SVt_PVIO) + IoPAGE_LEN(sv) = 60; + if (old_type < SVt_RV) + SvPV_set(sv, 0); + break; + default: + Perl_croak(aTHX_ "panic: sv_upgrade to unknown type %lu", new_type); + } -typedef struct { - STRLEN xpv_cur; - STRLEN xpv_len; -} xpv_allocated; + if (old_type_details->size) { + /* If the old body had an allocated size, then we need to free it. */ +#ifdef PURIFY + my_safefree(old_body); +#else + del_body((void*)((char*)old_body + old_type_details->offset), + &PL_body_roots[old_type]); +#endif + } +} -to make its members accessible via a pointer to (say) +/* +=for apidoc sv_backoff -struct xpv { - NV xnv_nv; - STRLEN xpv_cur; - STRLEN xpv_len; -}; +Remove any string offset. You should normally use the C macro +wrapper instead. +=cut */ -#define relative_STRUCT_OFFSET(longer, shorter, member) \ - (STRUCT_OFFSET(shorter, member) - STRUCT_OFFSET(longer, member)) +int +Perl_sv_backoff(pTHX_ register SV *sv) +{ + assert(SvOOK(sv)); + assert(SvTYPE(sv) != SVt_PVHV); + assert(SvTYPE(sv) != SVt_PVAV); + if (SvIVX(sv)) { + const char * const s = SvPVX_const(sv); + SvLEN_set(sv, SvLEN(sv) + SvIVX(sv)); + SvPV_set(sv, SvPVX(sv) - SvIVX(sv)); + SvIV_set(sv, 0); + Move(s, SvPVX(sv), SvCUR(sv)+1, char); + } + SvFLAGS(sv) &= ~SVf_OOK; + return 0; +} -/* Calculate the length to copy. Specifically work out the length less any - final padding the compiler needed to add. See the comment in sv_upgrade - for why copying the padding proved to be a bug. */ +/* +=for apidoc sv_grow -#define copy_length(type, last_member) \ - STRUCT_OFFSET(type, last_member) \ - + sizeof (((type*)SvANY((SV*)0))->last_member) - -static const struct body_details bodies_by_type[] = { - {0, 0, 0, FALSE, NONV, NOARENA}, - /* IVs are in the head, so the allocation size is 0 */ - {0, sizeof(IV), STRUCT_OFFSET(XPVIV, xiv_iv), FALSE, NONV, NOARENA}, - /* 8 bytes on most ILP32 with IEEE doubles */ - {sizeof(NV), sizeof(NV), 0, FALSE, HADNV, HASARENA}, - /* RVs are in the head now */ - /* However, this slot is overloaded and used by the pte */ - {0, 0, 0, FALSE, NONV, NOARENA}, - /* 8 bytes on most ILP32 with IEEE doubles */ - {sizeof(xpv_allocated), - copy_length(XPV, xpv_len) - + relative_STRUCT_OFFSET(XPV, xpv_allocated, xpv_cur), - - relative_STRUCT_OFFSET(XPV, xpv_allocated, xpv_cur), - FALSE, NONV, HASARENA}, - /* 12 */ - {sizeof(xpviv_allocated), - copy_length(XPVIV, xiv_u) - + relative_STRUCT_OFFSET(XPVIV, xpviv_allocated, xpv_cur), - - relative_STRUCT_OFFSET(XPVIV, xpviv_allocated, xpv_cur), - FALSE, NONV, HASARENA}, - /* 20 */ - {sizeof(XPVNV), copy_length(XPVNV, xiv_u), 0, FALSE, HADNV, HASARENA}, - /* 28 */ - {sizeof(XPVMG), copy_length(XPVMG, xmg_stash), 0, FALSE, HADNV, HASARENA}, - /* 36 */ - {sizeof(XPVBM), sizeof(XPVBM), 0, TRUE, HADNV, HASARENA}, - /* 48 */ - {sizeof(XPVGV), sizeof(XPVGV), 0, TRUE, HADNV, HASARENA}, - /* 64 */ - {sizeof(XPVLV), sizeof(XPVLV), 0, TRUE, HADNV, HASARENA}, - /* 20 */ - {sizeof(xpvav_allocated), - copy_length(XPVAV, xmg_stash) - + relative_STRUCT_OFFSET(XPVAV, xpvav_allocated, xav_fill), - - relative_STRUCT_OFFSET(XPVAV, xpvav_allocated, xav_fill), - TRUE, HADNV, HASARENA}, - /* 20 */ - {sizeof(xpvhv_allocated), - copy_length(XPVHV, xmg_stash) - + relative_STRUCT_OFFSET(XPVHV, xpvhv_allocated, xhv_fill), - - relative_STRUCT_OFFSET(XPVHV, xpvhv_allocated, xhv_fill), - TRUE, HADNV, HASARENA}, - /* 76 */ - {sizeof(XPVCV), sizeof(XPVCV), 0, TRUE, HADNV, HASARENA}, - /* 80 */ - {sizeof(XPVFM), sizeof(XPVFM), 0, TRUE, HADNV, NOARENA}, - /* 84 */ - {sizeof(XPVIO), sizeof(XPVIO), 0, TRUE, HADNV, NOARENA} -}; - -#define new_body_type(sv_type) \ - (void *)((char *)S_new_body(aTHX_ bodies_by_type[sv_type].size, sv_type)\ - - bodies_by_type[sv_type].offset) +Expands the character buffer in the SV. If necessary, uses C and +upgrades the SV to C. Returns a pointer to the character buffer. +Use the C wrapper instead. -#define del_body_type(p, sv_type) \ - del_body(p, &PL_body_roots[sv_type]) +=cut +*/ +char * +Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen) +{ + register char *s; -#define new_body_allocated(sv_type) \ - (void *)((char *)S_new_body(aTHX_ bodies_by_type[sv_type].size, sv_type)\ - - bodies_by_type[sv_type].offset) +#ifdef HAS_64K_LIMIT + if (newlen >= 0x10000) { + PerlIO_printf(Perl_debug_log, + "Allocation too large: %"UVxf"\n", (UV)newlen); + my_exit(1); + } +#endif /* HAS_64K_LIMIT */ + if (SvROK(sv)) + sv_unref(sv); + if (SvTYPE(sv) < SVt_PV) { + sv_upgrade(sv, SVt_PV); + s = SvPVX_mutable(sv); + } + else if (SvOOK(sv)) { /* pv is offset? */ + sv_backoff(sv); + s = SvPVX_mutable(sv); + if (newlen > SvLEN(sv)) + newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */ +#ifdef HAS_64K_LIMIT + if (newlen >= 0x10000) + newlen = 0xFFFF; +#endif + } + else + s = SvPVX_mutable(sv); -#define del_body_allocated(p, sv_type) \ - del_body(p + bodies_by_type[sv_type].offset, &PL_body_roots[sv_type]) + if (newlen > SvLEN(sv)) { /* need more room? */ + newlen = PERL_STRLEN_ROUNDUP(newlen); + if (SvLEN(sv) && s) { +#ifdef MYMALLOC + const STRLEN l = malloced_size((void*)SvPVX_const(sv)); + if (newlen <= l) { + SvLEN_set(sv, l); + return s; + } else +#endif + s = saferealloc(s, newlen); + } + else { + s = safemalloc(newlen); + if (SvPVX_const(sv) && SvCUR(sv)) { + Move(SvPVX_const(sv), s, (newlen < SvCUR(sv)) ? newlen : SvCUR(sv), char); + } + } + SvPV_set(sv, s); + SvLEN_set(sv, newlen); + } + return s; +} +/* +=for apidoc sv_setiv -#define my_safemalloc(s) (void*)safemalloc(s) -#define my_safecalloc(s) (void*)safecalloc(s, 1) -#define my_safefree(p) safefree((char*)p) +Copies an integer into the given SV, upgrading first if necessary. +Does not handle 'set' magic. See also C. -#ifdef PURIFY +=cut +*/ -#define new_XNV() my_safemalloc(sizeof(XPVNV)) -#define del_XNV(p) my_safefree(p) +void +Perl_sv_setiv(pTHX_ register SV *sv, IV i) +{ + SV_CHECK_THINKFIRST_COW_DROP(sv); + switch (SvTYPE(sv)) { + case SVt_NULL: + sv_upgrade(sv, SVt_IV); + break; + case SVt_NV: + sv_upgrade(sv, SVt_PVNV); + break; + case SVt_RV: + case SVt_PV: + sv_upgrade(sv, SVt_PVIV); + break; -#define new_XPVNV() my_safemalloc(sizeof(XPVNV)) -#define del_XPVNV(p) my_safefree(p) + case SVt_PVGV: + case SVt_PVAV: + case SVt_PVHV: + case SVt_PVCV: + case SVt_PVFM: + case SVt_PVIO: + Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0), + OP_DESC(PL_op)); + } + (void)SvIOK_only(sv); /* validate number */ + SvIV_set(sv, i); + SvTAINT(sv); +} -#define new_XPVAV() my_safemalloc(sizeof(XPVAV)) -#define del_XPVAV(p) my_safefree(p) +/* +=for apidoc sv_setiv_mg -#define new_XPVHV() my_safemalloc(sizeof(XPVHV)) -#define del_XPVHV(p) my_safefree(p) +Like C, but also handles 'set' magic. -#define new_XPVMG() my_safemalloc(sizeof(XPVMG)) -#define del_XPVMG(p) my_safefree(p) +=cut +*/ -#define new_XPVGV() my_safemalloc(sizeof(XPVGV)) -#define del_XPVGV(p) my_safefree(p) +void +Perl_sv_setiv_mg(pTHX_ register SV *sv, IV i) +{ + sv_setiv(sv,i); + SvSETMAGIC(sv); +} -#else /* !PURIFY */ +/* +=for apidoc sv_setuv -#define new_XNV() new_body_type(SVt_NV) -#define del_XNV(p) del_body_type(p, SVt_NV) +Copies an unsigned integer into the given SV, upgrading first if necessary. +Does not handle 'set' magic. See also C. -#define new_XPVNV() new_body_type(SVt_PVNV) -#define del_XPVNV(p) del_body_type(p, SVt_PVNV) +=cut +*/ -#define new_XPVAV() new_body_allocated(SVt_PVAV) -#define del_XPVAV(p) del_body_allocated(p, SVt_PVAV) +void +Perl_sv_setuv(pTHX_ register SV *sv, UV u) +{ + /* With these two if statements: + u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865 -#define new_XPVHV() new_body_allocated(SVt_PVHV) -#define del_XPVHV(p) del_body_allocated(p, SVt_PVHV) + without + u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865 -#define new_XPVMG() new_body_type(SVt_PVMG) -#define del_XPVMG(p) del_body_type(p, SVt_PVMG) + If you wish to remove them, please benchmark to see what the effect is + */ + if (u <= (UV)IV_MAX) { + sv_setiv(sv, (IV)u); + return; + } + sv_setiv(sv, 0); + SvIsUV_on(sv); + SvUV_set(sv, u); +} -#define new_XPVGV() new_body_type(SVt_PVGV) -#define del_XPVGV(p) del_body_type(p, SVt_PVGV) +/* +=for apidoc sv_setuv_mg -#endif /* PURIFY */ +Like C, but also handles 'set' magic. -/* no arena for you! */ +=cut +*/ -#define new_NOARENA(details) \ - my_safemalloc((details)->size + (details)->offset) -#define new_NOARENAZ(details) \ - my_safecalloc((details)->size + (details)->offset) +void +Perl_sv_setuv_mg(pTHX_ register SV *sv, UV u) +{ + sv_setiv(sv, 0); + SvIsUV_on(sv); + sv_setuv(sv,u); + SvSETMAGIC(sv); +} /* -=for apidoc sv_upgrade +=for apidoc sv_setnv -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 generally want to use the C macro wrapper. See also C. +Copies a double into the given SV, upgrading first if necessary. +Does not handle 'set' magic. See also C. =cut */ void -Perl_sv_upgrade(pTHX_ register SV *sv, U32 new_type) +Perl_sv_setnv(pTHX_ register SV *sv, NV num) { - void* old_body; - void* new_body; - const U32 old_type = SvTYPE(sv); - const struct body_details *const old_type_details - = bodies_by_type + old_type; - const struct body_details *new_type_details = bodies_by_type + new_type; - - if (new_type != SVt_PV && SvIsCOW(sv)) { - sv_force_normal_flags(sv, 0); - } - - if (old_type == new_type) - return; - - if (old_type > new_type) - Perl_croak(aTHX_ "sv_upgrade from type %d down to type %d", - (int)old_type, (int)new_type); - - - old_body = SvANY(sv); - - /* Copying structures onto other structures that have been neatly zeroed - has a subtle gotcha. Consider XPVMG - - +------+------+------+------+------+-------+-------+ - | NV | CUR | LEN | IV | MAGIC | STASH | - +------+------+------+------+------+-------+-------+ - 0 4 8 12 16 20 24 28 - - where NVs are aligned to 8 bytes, so that sizeof that structure is - actually 32 bytes long, with 4 bytes of padding at the end: - - +------+------+------+------+------+-------+-------+------+ - | NV | CUR | LEN | IV | MAGIC | STASH | ??? | - +------+------+------+------+------+-------+-------+------+ - 0 4 8 12 16 20 24 28 32 - - so what happens if you allocate memory for this structure: - - +------+------+------+------+------+-------+-------+------+------+... - | NV | CUR | LEN | IV | MAGIC | STASH | GP | NAME | - +------+------+------+------+------+-------+-------+------+------+... - 0 4 8 12 16 20 24 28 32 36 - - zero it, then copy sizeof(XPVMG) bytes on top of it? Not quite what you - expect, because you copy the area marked ??? onto GP. Now, ??? may have - started out as zero once, but it's quite possible that it isn't. So now, - rather than a nicely zeroed GP, you have it pointing somewhere random. - Bugs ensue. - - (In fact, GP ends up pointing at a previous GP structure, because the - principle cause of the padding in XPVMG getting garbage is a copy of - sizeof(XPVMG) bytes from a XPVGV structure in sv_unglob) - - So we are careful and work out the size of used parts of all the - structures. */ - - switch (old_type) { + SV_CHECK_THINKFIRST_COW_DROP(sv); + switch (SvTYPE(sv)) { case SVt_NULL: - break; case SVt_IV: - if (new_type < SVt_PVIV) { - new_type = (new_type == SVt_NV) - ? SVt_PVNV : SVt_PVIV; - new_type_details = bodies_by_type + new_type; - } - break; - case SVt_NV: - if (new_type < SVt_PVNV) { - new_type = SVt_PVNV; - new_type_details = bodies_by_type + new_type; - } + sv_upgrade(sv, SVt_NV); break; case SVt_RV: - break; case SVt_PV: - assert(new_type > SVt_PV); - assert(SVt_IV < SVt_PV); - assert(SVt_NV < SVt_PV); - break; case SVt_PVIV: - break; - case SVt_PVNV: - break; - case SVt_PVMG: - /* Because the XPVMG of PL_mess_sv isn't allocated from the arena, - there's no way that it can be safely upgraded, because perl.c - expects to Safefree(SvANY(PL_mess_sv)) */ - assert(sv != PL_mess_sv); - /* This flag bit is used to mean other things in other scalar types. - Given that it only has meaning inside the pad, it shouldn't be set - on anything that can get upgraded. */ - assert((SvFLAGS(sv) & SVpad_TYPED) == 0); - break; - default: - if (old_type_details->cant_upgrade) - Perl_croak(aTHX_ "Can't upgrade that kind of scalar"); - } - - SvFLAGS(sv) &= ~SVTYPEMASK; - SvFLAGS(sv) |= new_type; - - switch (new_type) { - case SVt_NULL: - Perl_croak(aTHX_ "Can't upgrade to undef"); - case SVt_IV: - assert(old_type == SVt_NULL); - SvANY(sv) = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv)); - SvIV_set(sv, 0); - return; - case SVt_NV: - assert(old_type == SVt_NULL); - SvANY(sv) = new_XNV(); - SvNV_set(sv, 0); - return; - case SVt_RV: - assert(old_type == SVt_NULL); - SvANY(sv) = &sv->sv_u.svu_rv; - SvRV_set(sv, 0); - return; - case SVt_PVHV: - SvANY(sv) = new_XPVHV(); - HvFILL(sv) = 0; - HvMAX(sv) = 0; - HvTOTALKEYS(sv) = 0; - - goto hv_av_common; - - case SVt_PVAV: - SvANY(sv) = new_XPVAV(); - AvMAX(sv) = -1; - AvFILLp(sv) = -1; - AvALLOC(sv) = 0; - AvREAL_only(sv); - - hv_av_common: - /* SVt_NULL isn't the only thing upgraded to AV or HV. - The target created by newSVrv also is, and it can have magic. - However, it never has SvPVX set. - */ - if (old_type >= SVt_RV) { - assert(SvPVX_const(sv) == 0); - } - - /* Could put this in the else clause below, as PVMG must have SvPVX - 0 already (the assertion above) */ - SvPV_set(sv, (char*)0); - - if (old_type >= SVt_PVMG) { - SvMAGIC_set(sv, ((XPVMG*)old_body)->xmg_magic); - SvSTASH_set(sv, ((XPVMG*)old_body)->xmg_stash); - } else { - SvMAGIC_set(sv, 0); - SvSTASH_set(sv, 0); - } + sv_upgrade(sv, SVt_PVNV); break; - - case SVt_PVIV: - /* XXX Is this still needed? Was it ever needed? Surely as there is - no route from NV to PVIV, NOK can never be true */ - assert(!SvNOKp(sv)); - assert(!SvNOK(sv)); - case SVt_PVIO: - case SVt_PVFM: - case SVt_PVBM: case SVt_PVGV: + case SVt_PVAV: + case SVt_PVHV: case SVt_PVCV: - case SVt_PVLV: - case SVt_PVMG: - case SVt_PVNV: - case SVt_PV: - - assert(new_type_details->size); - /* We always allocated the full length item with PURIFY. To do this - we fake things so that arena is false for all 16 types.. */ - if(new_type_details->arena) { - /* This points to the start of the allocated area. */ - new_body_inline(new_body, new_type_details->size, new_type); - Zero(new_body, new_type_details->size, char); - new_body = ((char *)new_body) - new_type_details->offset; - } else { - new_body = new_NOARENAZ(new_type_details); - } - SvANY(sv) = new_body; - - if (old_type_details->copy) { - Copy((char *)old_body + old_type_details->offset, - (char *)new_body + old_type_details->offset, - old_type_details->copy, char); - } - -#ifndef NV_ZERO_IS_ALLBITS_ZERO - /* If NV 0.0 is store as all bits 0 then Zero() already creates a correct - 0.0 for us. */ - if (old_type_details->zero_nv) - SvNV_set(sv, 0); -#endif - - if (new_type == SVt_PVIO) - IoPAGE_LEN(sv) = 60; - if (old_type < SVt_RV) - SvPV_set(sv, 0); - break; - default: - Perl_croak(aTHX_ "panic: sv_upgrade to unknown type %lu", new_type); - } - - if (old_type_details->size) { - /* If the old body had an allocated size, then we need to free it. */ -#ifdef PURIFY - my_safefree(old_body); -#else - del_body((void*)((char*)old_body + old_type_details->offset), - &PL_body_roots[old_type]); -#endif + case SVt_PVFM: + case SVt_PVIO: + Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0), + OP_NAME(PL_op)); } + SvNV_set(sv, num); + (void)SvNOK_only(sv); /* validate number */ + SvTAINT(sv); } /* -=for apidoc sv_backoff +=for apidoc sv_setnv_mg -Remove any string offset. You should normally use the C macro -wrapper instead. +Like C, but also handles 'set' magic. =cut */ -int -Perl_sv_backoff(pTHX_ register SV *sv) +void +Perl_sv_setnv_mg(pTHX_ register SV *sv, NV num) { - assert(SvOOK(sv)); - assert(SvTYPE(sv) != SVt_PVHV); - assert(SvTYPE(sv) != SVt_PVAV); - if (SvIVX(sv)) { - const char * const s = SvPVX_const(sv); - SvLEN_set(sv, SvLEN(sv) + SvIVX(sv)); - SvPV_set(sv, SvPVX(sv) - SvIVX(sv)); - SvIV_set(sv, 0); - Move(s, SvPVX(sv), SvCUR(sv)+1, char); - } - SvFLAGS(sv) &= ~SVf_OOK; - return 0; + sv_setnv(sv,num); + SvSETMAGIC(sv); } -/* -=for apidoc sv_grow - -Expands the character buffer in the SV. If necessary, uses C and -upgrades the SV to C. Returns a pointer to the character buffer. -Use the C wrapper instead. - -=cut -*/ +/* Print an "isn't numeric" warning, using a cleaned-up, + * printable version of the offending string + */ -char * -Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen) +STATIC void +S_not_a_number(pTHX_ SV *sv) { - register char *s; - -#ifdef HAS_64K_LIMIT - if (newlen >= 0x10000) { - PerlIO_printf(Perl_debug_log, - "Allocation too large: %"UVxf"\n", (UV)newlen); - my_exit(1); - } -#endif /* HAS_64K_LIMIT */ - if (SvROK(sv)) - sv_unref(sv); - if (SvTYPE(sv) < SVt_PV) { - sv_upgrade(sv, SVt_PV); - s = SvPVX_mutable(sv); - } - else if (SvOOK(sv)) { /* pv is offset? */ - sv_backoff(sv); - s = SvPVX_mutable(sv); - if (newlen > SvLEN(sv)) - newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */ -#ifdef HAS_64K_LIMIT - if (newlen >= 0x10000) - newlen = 0xFFFF; -#endif - } - else - s = SvPVX_mutable(sv); - - if (newlen > SvLEN(sv)) { /* need more room? */ - newlen = PERL_STRLEN_ROUNDUP(newlen); - if (SvLEN(sv) && s) { -#ifdef MYMALLOC - const STRLEN l = malloced_size((void*)SvPVX_const(sv)); - if (newlen <= l) { - SvLEN_set(sv, l); - return s; - } else -#endif - s = saferealloc(s, newlen); - } - else { - s = safemalloc(newlen); - if (SvPVX_const(sv) && SvCUR(sv)) { - Move(SvPVX_const(sv), s, (newlen < SvCUR(sv)) ? newlen : SvCUR(sv), char); - } - } - SvPV_set(sv, s); - SvLEN_set(sv, newlen); - } - return s; -} - -/* -=for apidoc sv_setiv - -Copies an integer into the given SV, upgrading first if necessary. -Does not handle 'set' magic. See also C. - -=cut -*/ - -void -Perl_sv_setiv(pTHX_ register SV *sv, IV i) -{ - SV_CHECK_THINKFIRST_COW_DROP(sv); - switch (SvTYPE(sv)) { - case SVt_NULL: - sv_upgrade(sv, SVt_IV); - break; - case SVt_NV: - sv_upgrade(sv, SVt_PVNV); - break; - case SVt_RV: - case SVt_PV: - sv_upgrade(sv, SVt_PVIV); - break; - - case SVt_PVGV: - case SVt_PVAV: - case SVt_PVHV: - case SVt_PVCV: - case SVt_PVFM: - case SVt_PVIO: - Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0), - OP_DESC(PL_op)); - } - (void)SvIOK_only(sv); /* validate number */ - SvIV_set(sv, i); - SvTAINT(sv); -} - -/* -=for apidoc sv_setiv_mg - -Like C, but also handles 'set' magic. - -=cut -*/ - -void -Perl_sv_setiv_mg(pTHX_ register SV *sv, IV i) -{ - sv_setiv(sv,i); - SvSETMAGIC(sv); -} - -/* -=for apidoc sv_setuv - -Copies an unsigned integer into the given SV, upgrading first if necessary. -Does not handle 'set' magic. See also C. - -=cut -*/ - -void -Perl_sv_setuv(pTHX_ register SV *sv, UV u) -{ - /* With these two if statements: - u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865 - - without - u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865 - - If you wish to remove them, please benchmark to see what the effect is - */ - if (u <= (UV)IV_MAX) { - sv_setiv(sv, (IV)u); - return; - } - sv_setiv(sv, 0); - SvIsUV_on(sv); - SvUV_set(sv, u); -} - -/* -=for apidoc sv_setuv_mg - -Like C, but also handles 'set' magic. - -=cut -*/ - -void -Perl_sv_setuv_mg(pTHX_ register SV *sv, UV u) -{ - sv_setiv(sv, 0); - SvIsUV_on(sv); - sv_setuv(sv,u); - SvSETMAGIC(sv); -} - -/* -=for apidoc sv_setnv - -Copies a double into the given SV, upgrading first if necessary. -Does not handle 'set' magic. See also C. - -=cut -*/ - -void -Perl_sv_setnv(pTHX_ register SV *sv, NV num) -{ - SV_CHECK_THINKFIRST_COW_DROP(sv); - switch (SvTYPE(sv)) { - case SVt_NULL: - case SVt_IV: - sv_upgrade(sv, SVt_NV); - break; - case SVt_RV: - case SVt_PV: - case SVt_PVIV: - sv_upgrade(sv, SVt_PVNV); - break; - - case SVt_PVGV: - case SVt_PVAV: - case SVt_PVHV: - case SVt_PVCV: - case SVt_PVFM: - case SVt_PVIO: - Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0), - OP_NAME(PL_op)); - } - SvNV_set(sv, num); - (void)SvNOK_only(sv); /* validate number */ - SvTAINT(sv); -} - -/* -=for apidoc sv_setnv_mg - -Like C, but also handles 'set' magic. - -=cut -*/ - -void -Perl_sv_setnv_mg(pTHX_ register SV *sv, NV num) -{ - sv_setnv(sv,num); - SvSETMAGIC(sv); -} - -/* Print an "isn't numeric" warning, using a cleaned-up, - * printable version of the offending string - */ - -STATIC void -S_not_a_number(pTHX_ SV *sv) -{ - SV *dsv; - char tmpbuf[64]; - const char *pv; + SV *dsv; + char tmpbuf[64]; + const char *pv; if (DO_UTF8(sv)) { dsv = sv_2mortal(newSVpvn("", 0)); @@ -10676,981 +10203,1455 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) } } - return nss; -} + return nss; +} + + +/* if sv is a stash, call $class->CLONE_SKIP(), and set the SVphv_CLONEABLE + * flag to the result. This is done for each stash before cloning starts, + * so we know which stashes want their objects cloned */ + +static void +do_mark_cloneable_stash(pTHX_ SV *sv) +{ + const HEK * const hvname = HvNAME_HEK((HV*)sv); + if (hvname) { + GV* const cloner = gv_fetchmethod_autoload((HV*)sv, "CLONE_SKIP", 0); + SvFLAGS(sv) |= SVphv_CLONEABLE; /* clone objects by default */ + if (cloner && GvCV(cloner)) { + dSP; + UV status; + + ENTER; + SAVETMPS; + PUSHMARK(SP); + XPUSHs(sv_2mortal(newSVhek(hvname))); + PUTBACK; + call_sv((SV*)GvCV(cloner), G_SCALAR); + SPAGAIN; + status = POPu; + PUTBACK; + FREETMPS; + LEAVE; + if (status) + SvFLAGS(sv) &= ~SVphv_CLONEABLE; + } + } +} + + + +/* +=for apidoc perl_clone + +Create and return a new interpreter by cloning the current one. + +perl_clone takes these flags as parameters: + +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 +*/ + +/* XXX the above needs expanding by someone who actually understands it ! */ +EXTERN_C PerlInterpreter * +perl_clone_host(PerlInterpreter* proto_perl, UV flags); + +PerlInterpreter * +perl_clone(PerlInterpreter *proto_perl, UV flags) +{ + dVAR; +#ifdef PERL_IMPLICIT_SYS + + /* 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, + proto_perl->IEnv, + proto_perl->IStdIO, + proto_perl->ILIO, + proto_perl->IDir, + proto_perl->ISock, + proto_perl->IProc); +} + +PerlInterpreter * +perl_clone_using(PerlInterpreter *proto_perl, UV flags, + struct IPerlMem* ipM, struct IPerlMem* ipMS, + struct IPerlMem* ipMP, struct IPerlEnv* ipE, + struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO, + struct IPerlDir* ipD, struct IPerlSock* ipS, + struct IPerlProc* ipP) +{ + /* XXX many of the string copies here can be optimized if they're + * constants; they need to be allocated as common memory and just + * their pointers copied. */ + + IV i; + CLONE_PARAMS clone_params; + CLONE_PARAMS* param = &clone_params; + + PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter)); + /* for each stash, determine whether its objects should be cloned */ + S_visit(proto_perl, do_mark_cloneable_stash, SVt_PVHV, SVTYPEMASK); + PERL_SET_THX(my_perl); + +# ifdef DEBUGGING + Poison(my_perl, 1, PerlInterpreter); + PL_op = Nullop; + PL_curcop = (COP *)Nullop; + PL_markstack = 0; + PL_scopestack = 0; + PL_savestack = 0; + PL_savestack_ix = 0; + PL_savestack_max = -1; + PL_sig_pending = 0; + Zero(&PL_debug_pad, 1, struct perl_debug_pad); +# else /* !DEBUGGING */ + Zero(my_perl, 1, PerlInterpreter); +# endif /* DEBUGGING */ + + /* host pointers */ + PL_Mem = ipM; + PL_MemShared = ipMS; + PL_MemParse = ipMP; + PL_Env = ipE; + PL_StdIO = ipStd; + PL_LIO = ipLIO; + PL_Dir = ipD; + PL_Sock = ipS; + PL_Proc = ipP; +#else /* !PERL_IMPLICIT_SYS */ + IV i; + CLONE_PARAMS clone_params; + CLONE_PARAMS* param = &clone_params; + PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter)); + /* for each stash, determine whether its objects should be cloned */ + S_visit(proto_perl, do_mark_cloneable_stash, SVt_PVHV, SVTYPEMASK); + PERL_SET_THX(my_perl); + +# ifdef DEBUGGING + Poison(my_perl, 1, PerlInterpreter); + PL_op = Nullop; + PL_curcop = (COP *)Nullop; + PL_markstack = 0; + PL_scopestack = 0; + PL_savestack = 0; + PL_savestack_ix = 0; + PL_savestack_max = -1; + PL_sig_pending = 0; + Zero(&PL_debug_pad, 1, struct perl_debug_pad); +# else /* !DEBUGGING */ + Zero(my_perl, 1, PerlInterpreter); +# endif /* DEBUGGING */ +#endif /* PERL_IMPLICIT_SYS */ + param->flags = flags; + param->proto_perl = proto_perl; + + Zero(&PL_body_arenaroots, 1, PL_body_arenaroots); + Zero(&PL_body_roots, 1, PL_body_roots); + + PL_nice_chunk = NULL; + PL_nice_chunk_size = 0; + PL_sv_count = 0; + PL_sv_objcount = 0; + PL_sv_root = Nullsv; + PL_sv_arenaroot = Nullsv; + + PL_debug = proto_perl->Idebug; + + PL_hash_seed = proto_perl->Ihash_seed; + PL_rehash_seed = proto_perl->Irehash_seed; + +#ifdef USE_REENTRANT_API + /* XXX: things like -Dm will segfault here in perlio, but doing + * PERL_SET_CONTEXT(proto_perl); + * breaks too many other things + */ + Perl_reentrant_init(aTHX); +#endif + + /* create SV map for pointer relocation */ + PL_ptr_table = ptr_table_new(); + + /* initialize these special pointers as early as possible */ + SvANY(&PL_sv_undef) = NULL; + SvREFCNT(&PL_sv_undef) = (~(U32)0)/2; + SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL; + ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef); + + SvANY(&PL_sv_no) = new_XPVNV(); + SvREFCNT(&PL_sv_no) = (~(U32)0)/2; + SvFLAGS(&PL_sv_no) = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK + |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV; + SvPV_set(&PL_sv_no, SAVEPVN(PL_No, 0)); + SvCUR_set(&PL_sv_no, 0); + SvLEN_set(&PL_sv_no, 1); + SvIV_set(&PL_sv_no, 0); + SvNV_set(&PL_sv_no, 0); + ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no); + + SvANY(&PL_sv_yes) = new_XPVNV(); + SvREFCNT(&PL_sv_yes) = (~(U32)0)/2; + SvFLAGS(&PL_sv_yes) = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK + |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV; + SvPV_set(&PL_sv_yes, SAVEPVN(PL_Yes, 1)); + SvCUR_set(&PL_sv_yes, 1); + SvLEN_set(&PL_sv_yes, 2); + SvIV_set(&PL_sv_yes, 1); + SvNV_set(&PL_sv_yes, 1); + ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes); + + /* create (a non-shared!) shared string table */ + PL_strtab = newHV(); + HvSHAREKEYS_off(PL_strtab); + hv_ksplit(PL_strtab, HvTOTALKEYS(proto_perl->Istrtab)); + ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab); + + PL_compiling = proto_perl->Icompiling; + + /* These two PVs will be free'd special way so must set them same way op.c does */ + PL_compiling.cop_stashpv = savesharedpv(PL_compiling.cop_stashpv); + ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_stashpv, PL_compiling.cop_stashpv); + + PL_compiling.cop_file = savesharedpv(PL_compiling.cop_file); + ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_file, PL_compiling.cop_file); + + ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling); + if (!specialWARN(PL_compiling.cop_warnings)) + PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings, param); + if (!specialCopIO(PL_compiling.cop_io)) + PL_compiling.cop_io = sv_dup_inc(PL_compiling.cop_io, param); + PL_curcop = (COP*)any_dup(proto_perl->Tcurcop, proto_perl); + + /* pseudo environmental stuff */ + PL_origargc = proto_perl->Iorigargc; + PL_origargv = proto_perl->Iorigargv; + + param->stashes = newAV(); /* Setup array of objects to call clone on */ + + /* Set tainting stuff before PerlIO_debug can possibly get called */ + PL_tainting = proto_perl->Itainting; + PL_taint_warn = proto_perl->Itaint_warn; + +#ifdef PERLIO_LAYERS + /* Clone PerlIO tables as soon as we can handle general xx_dup() */ + PerlIO_clone(aTHX_ proto_perl, param); +#endif + + PL_envgv = gv_dup(proto_perl->Ienvgv, param); + PL_incgv = gv_dup(proto_perl->Iincgv, param); + PL_hintgv = gv_dup(proto_perl->Ihintgv, param); + PL_origfilename = SAVEPV(proto_perl->Iorigfilename); + PL_diehook = sv_dup_inc(proto_perl->Idiehook, param); + PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook, param); + + /* switches */ + PL_minus_c = proto_perl->Iminus_c; + PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel, param); + PL_localpatches = proto_perl->Ilocalpatches; + PL_splitstr = proto_perl->Isplitstr; + PL_preprocess = proto_perl->Ipreprocess; + PL_minus_n = proto_perl->Iminus_n; + PL_minus_p = proto_perl->Iminus_p; + PL_minus_l = proto_perl->Iminus_l; + PL_minus_a = proto_perl->Iminus_a; + PL_minus_F = proto_perl->Iminus_F; + PL_doswitches = proto_perl->Idoswitches; + PL_dowarn = proto_perl->Idowarn; + PL_doextract = proto_perl->Idoextract; + PL_sawampersand = proto_perl->Isawampersand; + PL_unsafe = proto_perl->Iunsafe; + PL_inplace = SAVEPV(proto_perl->Iinplace); + PL_e_script = sv_dup_inc(proto_perl->Ie_script, param); + PL_perldb = proto_perl->Iperldb; + PL_perl_destruct_level = proto_perl->Iperl_destruct_level; + PL_exit_flags = proto_perl->Iexit_flags; + + /* magical thingies */ + /* XXX time(&PL_basetime) when asked for? */ + PL_basetime = proto_perl->Ibasetime; + PL_formfeed = sv_dup(proto_perl->Iformfeed, param); + + PL_maxsysfd = proto_perl->Imaxsysfd; + PL_multiline = proto_perl->Imultiline; + PL_statusvalue = proto_perl->Istatusvalue; +#ifdef VMS + PL_statusvalue_vms = proto_perl->Istatusvalue_vms; +#else + PL_statusvalue_posix = proto_perl->Istatusvalue_posix; +#endif + PL_encoding = sv_dup(proto_perl->Iencoding, param); + + sv_setpvn(PERL_DEBUG_PAD(0), "", 0); /* For regex debugging. */ + sv_setpvn(PERL_DEBUG_PAD(1), "", 0); /* ext/re needs these */ + sv_setpvn(PERL_DEBUG_PAD(2), "", 0); /* even without DEBUGGING. */ + + /* Clone the regex array */ + PL_regex_padav = newAV(); + { + const I32 len = av_len((AV*)proto_perl->Iregex_padav); + SV** const regexen = AvARRAY((AV*)proto_perl->Iregex_padav); + IV i; + av_push(PL_regex_padav, + sv_dup_inc(regexen[0],param)); + for(i = 1; i <= len; i++) { + if(SvREPADTMP(regexen[i])) { + av_push(PL_regex_padav, sv_dup_inc(regexen[i], param)); + } else { + av_push(PL_regex_padav, + SvREFCNT_inc( + newSViv(PTR2IV(re_dup(INT2PTR(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); + PL_defgv = gv_dup(proto_perl->Idefgv, param); + PL_argvgv = gv_dup(proto_perl->Iargvgv, param); + PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv, param); + PL_argvout_stack = av_dup_inc(proto_perl->Iargvout_stack, param); + /* shortcuts to regexp stuff */ + PL_replgv = gv_dup(proto_perl->Ireplgv, param); -/* if sv is a stash, call $class->CLONE_SKIP(), and set the SVphv_CLONEABLE - * flag to the result. This is done for each stash before cloning starts, - * so we know which stashes want their objects cloned */ + /* shortcuts to misc objects */ + PL_errgv = gv_dup(proto_perl->Ierrgv, param); -static void -do_mark_cloneable_stash(pTHX_ SV *sv) -{ - const HEK * const hvname = HvNAME_HEK((HV*)sv); - if (hvname) { - GV* const cloner = gv_fetchmethod_autoload((HV*)sv, "CLONE_SKIP", 0); - SvFLAGS(sv) |= SVphv_CLONEABLE; /* clone objects by default */ - if (cloner && GvCV(cloner)) { - dSP; - UV status; + /* shortcuts to debugging objects */ + PL_DBgv = gv_dup(proto_perl->IDBgv, param); + PL_DBline = gv_dup(proto_perl->IDBline, param); + PL_DBsub = gv_dup(proto_perl->IDBsub, param); + 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); - ENTER; - SAVETMPS; - PUSHMARK(SP); - XPUSHs(sv_2mortal(newSVhek(hvname))); - PUTBACK; - call_sv((SV*)GvCV(cloner), G_SCALAR); - SPAGAIN; - status = POPu; - PUTBACK; - FREETMPS; - LEAVE; - if (status) - SvFLAGS(sv) &= ~SVphv_CLONEABLE; - } + /* symbol tables */ + PL_defstash = hv_dup_inc(proto_perl->Tdefstash, param); + PL_curstash = hv_dup(proto_perl->Tcurstash, 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); + + PL_sub_generation = proto_perl->Isub_generation; + + /* funky return mechanisms */ + PL_forkprocess = proto_perl->Iforkprocess; + + /* subprocess state */ + PL_fdpid = av_dup_inc(proto_perl->Ifdpid, param); + + /* internal state */ + 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); + PL_main_root = OpREFCNT_inc(proto_perl->Imain_root); + PL_main_start = proto_perl->Imain_start; + PL_eval_root = proto_perl->Ieval_root; + PL_eval_start = proto_perl->Ieval_start; + + /* runtime control stuff */ + PL_curcopdb = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl); + PL_copline = proto_perl->Icopline; + + PL_filemode = proto_perl->Ifilemode; + PL_lastfd = proto_perl->Ilastfd; + PL_oldname = proto_perl->Ioldname; /* XXX not quite right */ + PL_Argv = NULL; + PL_Cmd = Nullch; + PL_gensym = proto_perl->Igensym; + PL_preambled = proto_perl->Ipreambled; + PL_preambleav = av_dup_inc(proto_perl->Ipreambleav, param); + PL_laststatval = proto_perl->Ilaststatval; + PL_laststype = proto_perl->Ilaststype; + PL_mess_sv = Nullsv; + + PL_ors_sv = sv_dup_inc(proto_perl->Iors_sv, param); + + /* interpreter atexit processing */ + PL_exitlistlen = proto_perl->Iexitlistlen; + if (PL_exitlistlen) { + Newx(PL_exitlist, PL_exitlistlen, PerlExitListEntry); + Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry); } -} + else + PL_exitlist = (PerlExitListEntry*)NULL; + PL_modglobal = hv_dup_inc(proto_perl->Imodglobal, param); + PL_custom_op_names = hv_dup_inc(proto_perl->Icustom_op_names,param); + PL_custom_op_descs = hv_dup_inc(proto_perl->Icustom_op_descs,param); + + PL_profiledata = NULL; + PL_rsfp = fp_dup(proto_perl->Irsfp, '<', param); + /* PL_rsfp_filters entries have fake IoDIRP() */ + PL_rsfp_filters = av_dup_inc(proto_perl->Irsfp_filters, param); + PL_compcv = cv_dup(proto_perl->Icompcv, param); + PAD_CLONE_VARS(proto_perl, param); -/* -=for apidoc perl_clone +#ifdef HAVE_INTERP_INTERN + sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern); +#endif -Create and return a new interpreter by cloning the current one. + /* more statics moved here */ + PL_generation = proto_perl->Igeneration; + PL_DBcv = cv_dup(proto_perl->IDBcv, param); -perl_clone takes these flags as parameters: + PL_in_clean_objs = proto_perl->Iin_clean_objs; + PL_in_clean_all = proto_perl->Iin_clean_all; -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. + PL_uid = proto_perl->Iuid; + PL_euid = proto_perl->Ieuid; + PL_gid = proto_perl->Igid; + PL_egid = proto_perl->Iegid; + PL_nomemok = proto_perl->Inomemok; + PL_an = proto_perl->Ian; + PL_evalseq = proto_perl->Ievalseq; + PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */ + PL_origalen = proto_perl->Iorigalen; +#ifdef PERL_USES_PL_PIDSTATUS + PL_pidstatus = newHV(); /* XXX flag for cloning? */ +#endif + PL_osname = SAVEPV(proto_perl->Iosname); + PL_sighandlerp = proto_perl->Isighandlerp; -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 + PL_runops = proto_perl->Irunops; -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. + Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char); -=cut -*/ +#ifdef CSH + PL_cshlen = proto_perl->Icshlen; + PL_cshname = proto_perl->Icshname; /* XXX never deallocated */ +#endif -/* XXX the above needs expanding by someone who actually understands it ! */ -EXTERN_C PerlInterpreter * -perl_clone_host(PerlInterpreter* proto_perl, UV flags); + PL_lex_state = proto_perl->Ilex_state; + PL_lex_defer = proto_perl->Ilex_defer; + PL_lex_expect = proto_perl->Ilex_expect; + PL_lex_formbrack = proto_perl->Ilex_formbrack; + PL_lex_dojoin = proto_perl->Ilex_dojoin; + PL_lex_starts = proto_perl->Ilex_starts; + PL_lex_stuff = sv_dup_inc(proto_perl->Ilex_stuff, param); + PL_lex_repl = sv_dup_inc(proto_perl->Ilex_repl, param); + PL_lex_op = proto_perl->Ilex_op; + PL_lex_inpat = proto_perl->Ilex_inpat; + PL_lex_inwhat = proto_perl->Ilex_inwhat; + PL_lex_brackets = proto_perl->Ilex_brackets; + i = (PL_lex_brackets < 120 ? 120 : PL_lex_brackets); + PL_lex_brackstack = SAVEPVN(proto_perl->Ilex_brackstack,i); + PL_lex_casemods = proto_perl->Ilex_casemods; + i = (PL_lex_casemods < 12 ? 12 : PL_lex_casemods); + PL_lex_casestack = SAVEPVN(proto_perl->Ilex_casestack,i); -PerlInterpreter * -perl_clone(PerlInterpreter *proto_perl, UV flags) -{ - dVAR; -#ifdef PERL_IMPLICIT_SYS + Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE); + Copy(proto_perl->Inexttype, PL_nexttype, 5, I32); + PL_nexttoke = proto_perl->Inexttoke; - /* perlhost.h so we need to call into it - to clone the host, CPerlHost should have a c interface, sky */ + /* XXX This is probably masking the deeper issue of why + * SvANY(proto_perl->Ilinestr) can be NULL at this point. For test case: + * http://archive.develooper.com/perl5-porters%40perl.org/msg83298.html + * (A little debugging with a watchpoint on it may help.) + */ + if (SvANY(proto_perl->Ilinestr)) { + PL_linestr = sv_dup_inc(proto_perl->Ilinestr, param); + i = proto_perl->Ibufptr - SvPVX_const(proto_perl->Ilinestr); + PL_bufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i); + i = proto_perl->Ioldbufptr - SvPVX_const(proto_perl->Ilinestr); + PL_oldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i); + i = proto_perl->Ioldoldbufptr - SvPVX_const(proto_perl->Ilinestr); + PL_oldoldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i); + i = proto_perl->Ilinestart - SvPVX_const(proto_perl->Ilinestr); + PL_linestart = SvPVX(PL_linestr) + (i < 0 ? 0 : i); + } + else { + PL_linestr = NEWSV(65,79); + sv_upgrade(PL_linestr,SVt_PVIV); + sv_setpvn(PL_linestr,"",0); + PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr); + } + PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); + PL_pending_ident = proto_perl->Ipending_ident; + PL_sublex_info = proto_perl->Isublex_info; /* XXX not quite right */ + + PL_expect = proto_perl->Iexpect; + + PL_multi_start = proto_perl->Imulti_start; + PL_multi_end = proto_perl->Imulti_end; + PL_multi_open = proto_perl->Imulti_open; + PL_multi_close = proto_perl->Imulti_close; + + PL_error_count = proto_perl->Ierror_count; + PL_subline = proto_perl->Isubline; + PL_subname = sv_dup_inc(proto_perl->Isubname, param); - 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, - proto_perl->IEnv, - proto_perl->IStdIO, - proto_perl->ILIO, - proto_perl->IDir, - proto_perl->ISock, - proto_perl->IProc); -} + /* XXX See comment on SvANY(proto_perl->Ilinestr) above */ + if (SvANY(proto_perl->Ilinestr)) { + i = proto_perl->Ilast_uni - SvPVX_const(proto_perl->Ilinestr); + PL_last_uni = SvPVX(PL_linestr) + (i < 0 ? 0 : i); + i = proto_perl->Ilast_lop - SvPVX_const(proto_perl->Ilinestr); + PL_last_lop = SvPVX(PL_linestr) + (i < 0 ? 0 : i); + PL_last_lop_op = proto_perl->Ilast_lop_op; + } + else { + PL_last_uni = SvPVX(PL_linestr); + PL_last_lop = SvPVX(PL_linestr); + PL_last_lop_op = 0; + } + PL_in_my = proto_perl->Iin_my; + PL_in_my_stash = hv_dup(proto_perl->Iin_my_stash, param); +#ifdef FCRYPT + PL_cryptseen = proto_perl->Icryptseen; +#endif -PerlInterpreter * -perl_clone_using(PerlInterpreter *proto_perl, UV flags, - struct IPerlMem* ipM, struct IPerlMem* ipMS, - struct IPerlMem* ipMP, struct IPerlEnv* ipE, - struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO, - struct IPerlDir* ipD, struct IPerlSock* ipS, - struct IPerlProc* ipP) -{ - /* XXX many of the string copies here can be optimized if they're - * constants; they need to be allocated as common memory and just - * their pointers copied. */ + PL_hints = proto_perl->Ihints; - IV i; - CLONE_PARAMS clone_params; - CLONE_PARAMS* param = &clone_params; + PL_amagic_generation = proto_perl->Iamagic_generation; - PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter)); - /* for each stash, determine whether its objects should be cloned */ - S_visit(proto_perl, do_mark_cloneable_stash, SVt_PVHV, SVTYPEMASK); - PERL_SET_THX(my_perl); +#ifdef USE_LOCALE_COLLATE + PL_collation_ix = proto_perl->Icollation_ix; + PL_collation_name = SAVEPV(proto_perl->Icollation_name); + PL_collation_standard = proto_perl->Icollation_standard; + PL_collxfrm_base = proto_perl->Icollxfrm_base; + PL_collxfrm_mult = proto_perl->Icollxfrm_mult; +#endif /* USE_LOCALE_COLLATE */ -# ifdef DEBUGGING - Poison(my_perl, 1, PerlInterpreter); - PL_op = Nullop; - PL_curcop = (COP *)Nullop; - PL_markstack = 0; - PL_scopestack = 0; - PL_savestack = 0; - PL_savestack_ix = 0; - PL_savestack_max = -1; - PL_sig_pending = 0; - Zero(&PL_debug_pad, 1, struct perl_debug_pad); -# else /* !DEBUGGING */ - Zero(my_perl, 1, PerlInterpreter); -# endif /* DEBUGGING */ +#ifdef USE_LOCALE_NUMERIC + PL_numeric_name = SAVEPV(proto_perl->Inumeric_name); + PL_numeric_standard = proto_perl->Inumeric_standard; + PL_numeric_local = proto_perl->Inumeric_local; + PL_numeric_radix_sv = sv_dup_inc(proto_perl->Inumeric_radix_sv, param); +#endif /* !USE_LOCALE_NUMERIC */ - /* host pointers */ - PL_Mem = ipM; - PL_MemShared = ipMS; - PL_MemParse = ipMP; - PL_Env = ipE; - PL_StdIO = ipStd; - PL_LIO = ipLIO; - PL_Dir = ipD; - PL_Sock = ipS; - PL_Proc = ipP; -#else /* !PERL_IMPLICIT_SYS */ - IV i; - CLONE_PARAMS clone_params; - CLONE_PARAMS* param = &clone_params; - PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter)); - /* for each stash, determine whether its objects should be cloned */ - S_visit(proto_perl, do_mark_cloneable_stash, SVt_PVHV, SVTYPEMASK); - PERL_SET_THX(my_perl); + /* utf8 character classes */ + PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum, param); + PL_utf8_alnumc = sv_dup_inc(proto_perl->Iutf8_alnumc, param); + PL_utf8_ascii = sv_dup_inc(proto_perl->Iutf8_ascii, param); + PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha, param); + PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space, param); + PL_utf8_cntrl = sv_dup_inc(proto_perl->Iutf8_cntrl, param); + PL_utf8_graph = sv_dup_inc(proto_perl->Iutf8_graph, param); + PL_utf8_digit = sv_dup_inc(proto_perl->Iutf8_digit, param); + PL_utf8_upper = sv_dup_inc(proto_perl->Iutf8_upper, param); + PL_utf8_lower = sv_dup_inc(proto_perl->Iutf8_lower, param); + PL_utf8_print = sv_dup_inc(proto_perl->Iutf8_print, param); + PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct, param); + PL_utf8_xdigit = sv_dup_inc(proto_perl->Iutf8_xdigit, param); + PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark, param); + PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper, param); + PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle, param); + PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower, param); + PL_utf8_tofold = sv_dup_inc(proto_perl->Iutf8_tofold, param); + PL_utf8_idstart = sv_dup_inc(proto_perl->Iutf8_idstart, param); + PL_utf8_idcont = sv_dup_inc(proto_perl->Iutf8_idcont, param); -# ifdef DEBUGGING - Poison(my_perl, 1, PerlInterpreter); - PL_op = Nullop; - PL_curcop = (COP *)Nullop; - PL_markstack = 0; - PL_scopestack = 0; - PL_savestack = 0; - PL_savestack_ix = 0; - PL_savestack_max = -1; - PL_sig_pending = 0; - Zero(&PL_debug_pad, 1, struct perl_debug_pad); -# else /* !DEBUGGING */ - Zero(my_perl, 1, PerlInterpreter); -# endif /* DEBUGGING */ -#endif /* PERL_IMPLICIT_SYS */ - param->flags = flags; - param->proto_perl = proto_perl; + /* Did the locale setup indicate UTF-8? */ + PL_utf8locale = proto_perl->Iutf8locale; + /* Unicode features (see perlrun/-C) */ + PL_unicode = proto_perl->Iunicode; - Zero(&PL_body_arenaroots, 1, PL_body_arenaroots); - Zero(&PL_body_roots, 1, PL_body_roots); - - PL_nice_chunk = NULL; - PL_nice_chunk_size = 0; - PL_sv_count = 0; - PL_sv_objcount = 0; - PL_sv_root = Nullsv; - PL_sv_arenaroot = Nullsv; + /* Pre-5.8 signals control */ + PL_signals = proto_perl->Isignals; - PL_debug = proto_perl->Idebug; + /* times() ticks per second */ + PL_clocktick = proto_perl->Iclocktick; - PL_hash_seed = proto_perl->Ihash_seed; - PL_rehash_seed = proto_perl->Irehash_seed; + /* Recursion stopper for PerlIO_find_layer */ + PL_in_load_module = proto_perl->Iin_load_module; -#ifdef USE_REENTRANT_API - /* XXX: things like -Dm will segfault here in perlio, but doing - * PERL_SET_CONTEXT(proto_perl); - * breaks too many other things - */ - Perl_reentrant_init(aTHX); -#endif + /* sort() routine */ + PL_sort_RealCmp = proto_perl->Isort_RealCmp; - /* create SV map for pointer relocation */ - PL_ptr_table = ptr_table_new(); + /* Not really needed/useful since the reenrant_retint is "volatile", + * but do it for consistency's sake. */ + PL_reentrant_retint = proto_perl->Ireentrant_retint; - /* initialize these special pointers as early as possible */ - SvANY(&PL_sv_undef) = NULL; - SvREFCNT(&PL_sv_undef) = (~(U32)0)/2; - SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL; - ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef); + /* Hooks to shared SVs and locks. */ + PL_sharehook = proto_perl->Isharehook; + PL_lockhook = proto_perl->Ilockhook; + PL_unlockhook = proto_perl->Iunlockhook; + PL_threadhook = proto_perl->Ithreadhook; - SvANY(&PL_sv_no) = new_XPVNV(); - SvREFCNT(&PL_sv_no) = (~(U32)0)/2; - SvFLAGS(&PL_sv_no) = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK - |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV; - SvPV_set(&PL_sv_no, SAVEPVN(PL_No, 0)); - SvCUR_set(&PL_sv_no, 0); - SvLEN_set(&PL_sv_no, 1); - SvIV_set(&PL_sv_no, 0); - SvNV_set(&PL_sv_no, 0); - ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no); + PL_runops_std = proto_perl->Irunops_std; + PL_runops_dbg = proto_perl->Irunops_dbg; - SvANY(&PL_sv_yes) = new_XPVNV(); - SvREFCNT(&PL_sv_yes) = (~(U32)0)/2; - SvFLAGS(&PL_sv_yes) = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK - |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV; - SvPV_set(&PL_sv_yes, SAVEPVN(PL_Yes, 1)); - SvCUR_set(&PL_sv_yes, 1); - SvLEN_set(&PL_sv_yes, 2); - SvIV_set(&PL_sv_yes, 1); - SvNV_set(&PL_sv_yes, 1); - ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes); +#ifdef THREADS_HAVE_PIDS + PL_ppid = proto_perl->Ippid; +#endif - /* create (a non-shared!) shared string table */ - PL_strtab = newHV(); - HvSHAREKEYS_off(PL_strtab); - hv_ksplit(PL_strtab, HvTOTALKEYS(proto_perl->Istrtab)); - ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab); + /* swatch cache */ + PL_last_swash_hv = Nullhv; /* reinits on demand */ + PL_last_swash_klen = 0; + PL_last_swash_key[0]= '\0'; + PL_last_swash_tmps = (U8*)NULL; + PL_last_swash_slen = 0; - PL_compiling = proto_perl->Icompiling; + PL_glob_index = proto_perl->Iglob_index; + PL_srand_called = proto_perl->Isrand_called; + PL_uudmap['M'] = 0; /* reinits on demand */ + PL_bitcount = Nullch; /* reinits on demand */ - /* These two PVs will be free'd special way so must set them same way op.c does */ - PL_compiling.cop_stashpv = savesharedpv(PL_compiling.cop_stashpv); - ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_stashpv, PL_compiling.cop_stashpv); + if (proto_perl->Ipsig_pend) { + Newxz(PL_psig_pend, SIG_SIZE, int); + } + else { + PL_psig_pend = (int*)NULL; + } - PL_compiling.cop_file = savesharedpv(PL_compiling.cop_file); - ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_file, PL_compiling.cop_file); + if (proto_perl->Ipsig_ptr) { + Newxz(PL_psig_ptr, SIG_SIZE, SV*); + Newxz(PL_psig_name, SIG_SIZE, SV*); + for (i = 1; i < SIG_SIZE; i++) { + PL_psig_ptr[i] = sv_dup_inc(proto_perl->Ipsig_ptr[i], param); + PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i], param); + } + } + else { + PL_psig_ptr = (SV**)NULL; + PL_psig_name = (SV**)NULL; + } - ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling); - if (!specialWARN(PL_compiling.cop_warnings)) - PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings, param); - if (!specialCopIO(PL_compiling.cop_io)) - PL_compiling.cop_io = sv_dup_inc(PL_compiling.cop_io, param); - PL_curcop = (COP*)any_dup(proto_perl->Tcurcop, proto_perl); + /* thrdvar.h stuff */ - /* pseudo environmental stuff */ - PL_origargc = proto_perl->Iorigargc; - PL_origargv = proto_perl->Iorigargv; + if (flags & CLONEf_COPY_STACKS) { + /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */ + PL_tmps_ix = proto_perl->Ttmps_ix; + PL_tmps_max = proto_perl->Ttmps_max; + PL_tmps_floor = proto_perl->Ttmps_floor; + Newxz(PL_tmps_stack, PL_tmps_max, SV*); + i = 0; + while (i <= PL_tmps_ix) { + PL_tmps_stack[i] = sv_dup_inc(proto_perl->Ttmps_stack[i], param); + ++i; + } - param->stashes = newAV(); /* Setup array of objects to call clone on */ + /* next PUSHMARK() sets *(PL_markstack_ptr+1) */ + i = proto_perl->Tmarkstack_max - proto_perl->Tmarkstack; + Newxz(PL_markstack, i, I32); + PL_markstack_max = PL_markstack + (proto_perl->Tmarkstack_max + - proto_perl->Tmarkstack); + PL_markstack_ptr = PL_markstack + (proto_perl->Tmarkstack_ptr + - proto_perl->Tmarkstack); + Copy(proto_perl->Tmarkstack, PL_markstack, + PL_markstack_ptr - PL_markstack + 1, I32); - /* Set tainting stuff before PerlIO_debug can possibly get called */ - PL_tainting = proto_perl->Itainting; - PL_taint_warn = proto_perl->Itaint_warn; + /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix] + * NOTE: unlike the others! */ + PL_scopestack_ix = proto_perl->Tscopestack_ix; + PL_scopestack_max = proto_perl->Tscopestack_max; + Newxz(PL_scopestack, PL_scopestack_max, I32); + Copy(proto_perl->Tscopestack, PL_scopestack, PL_scopestack_ix, I32); -#ifdef PERLIO_LAYERS - /* Clone PerlIO tables as soon as we can handle general xx_dup() */ - PerlIO_clone(aTHX_ proto_perl, param); -#endif + /* NOTE: si_dup() looks at PL_markstack */ + PL_curstackinfo = si_dup(proto_perl->Tcurstackinfo, param); - PL_envgv = gv_dup(proto_perl->Ienvgv, param); - PL_incgv = gv_dup(proto_perl->Iincgv, param); - PL_hintgv = gv_dup(proto_perl->Ihintgv, param); - PL_origfilename = SAVEPV(proto_perl->Iorigfilename); - PL_diehook = sv_dup_inc(proto_perl->Idiehook, param); - PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook, param); + /* PL_curstack = PL_curstackinfo->si_stack; */ + PL_curstack = av_dup(proto_perl->Tcurstack, param); + PL_mainstack = av_dup(proto_perl->Tmainstack, param); - /* switches */ - PL_minus_c = proto_perl->Iminus_c; - PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel, param); - PL_localpatches = proto_perl->Ilocalpatches; - PL_splitstr = proto_perl->Isplitstr; - PL_preprocess = proto_perl->Ipreprocess; - PL_minus_n = proto_perl->Iminus_n; - PL_minus_p = proto_perl->Iminus_p; - PL_minus_l = proto_perl->Iminus_l; - PL_minus_a = proto_perl->Iminus_a; - PL_minus_F = proto_perl->Iminus_F; - PL_doswitches = proto_perl->Idoswitches; - PL_dowarn = proto_perl->Idowarn; - PL_doextract = proto_perl->Idoextract; - PL_sawampersand = proto_perl->Isawampersand; - PL_unsafe = proto_perl->Iunsafe; - PL_inplace = SAVEPV(proto_perl->Iinplace); - PL_e_script = sv_dup_inc(proto_perl->Ie_script, param); - PL_perldb = proto_perl->Iperldb; - PL_perl_destruct_level = proto_perl->Iperl_destruct_level; - PL_exit_flags = proto_perl->Iexit_flags; + /* next PUSHs() etc. set *(PL_stack_sp+1) */ + PL_stack_base = AvARRAY(PL_curstack); + PL_stack_sp = PL_stack_base + (proto_perl->Tstack_sp + - proto_perl->Tstack_base); + PL_stack_max = PL_stack_base + AvMAX(PL_curstack); - /* magical thingies */ - /* XXX time(&PL_basetime) when asked for? */ - PL_basetime = proto_perl->Ibasetime; - PL_formfeed = sv_dup(proto_perl->Iformfeed, param); + /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix] + * NOTE: unlike the others! */ + PL_savestack_ix = proto_perl->Tsavestack_ix; + PL_savestack_max = proto_perl->Tsavestack_max; + /*Newxz(PL_savestack, PL_savestack_max, ANY);*/ + PL_savestack = ss_dup(proto_perl, param); + } + else { + init_stacks(); + ENTER; /* perl_destruct() wants to LEAVE; */ + } - PL_maxsysfd = proto_perl->Imaxsysfd; - PL_multiline = proto_perl->Imultiline; - PL_statusvalue = proto_perl->Istatusvalue; -#ifdef VMS - PL_statusvalue_vms = proto_perl->Istatusvalue_vms; -#else - PL_statusvalue_posix = proto_perl->Istatusvalue_posix; -#endif - PL_encoding = sv_dup(proto_perl->Iencoding, param); + PL_start_env = proto_perl->Tstart_env; /* XXXXXX */ + PL_top_env = &PL_start_env; - sv_setpvn(PERL_DEBUG_PAD(0), "", 0); /* For regex debugging. */ - sv_setpvn(PERL_DEBUG_PAD(1), "", 0); /* ext/re needs these */ - sv_setpvn(PERL_DEBUG_PAD(2), "", 0); /* even without DEBUGGING. */ + PL_op = proto_perl->Top; - /* Clone the regex array */ - PL_regex_padav = newAV(); - { - const I32 len = av_len((AV*)proto_perl->Iregex_padav); - SV** const regexen = AvARRAY((AV*)proto_perl->Iregex_padav); - IV i; - av_push(PL_regex_padav, - sv_dup_inc(regexen[0],param)); - for(i = 1; i <= len; i++) { - if(SvREPADTMP(regexen[i])) { - av_push(PL_regex_padav, sv_dup_inc(regexen[i], param)); - } else { - av_push(PL_regex_padav, - SvREFCNT_inc( - newSViv(PTR2IV(re_dup(INT2PTR(REGEXP *, - SvIVX(regexen[i])), param))) - )); - } - } - } - PL_regex_pad = AvARRAY(PL_regex_padav); + PL_Sv = Nullsv; + PL_Xpv = (XPV*)NULL; + PL_na = proto_perl->Tna; - /* shortcuts to various I/O objects */ - PL_stdingv = gv_dup(proto_perl->Istdingv, param); - PL_stderrgv = gv_dup(proto_perl->Istderrgv, param); - PL_defgv = gv_dup(proto_perl->Idefgv, param); - PL_argvgv = gv_dup(proto_perl->Iargvgv, param); - PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv, param); - PL_argvout_stack = av_dup_inc(proto_perl->Iargvout_stack, param); + PL_statbuf = proto_perl->Tstatbuf; + PL_statcache = proto_perl->Tstatcache; + PL_statgv = gv_dup(proto_perl->Tstatgv, param); + PL_statname = sv_dup_inc(proto_perl->Tstatname, param); +#ifdef HAS_TIMES + PL_timesbuf = proto_perl->Ttimesbuf; +#endif - /* shortcuts to regexp stuff */ - PL_replgv = gv_dup(proto_perl->Ireplgv, param); + PL_tainted = proto_perl->Ttainted; + PL_curpm = proto_perl->Tcurpm; /* XXX No PMOP ref count */ + PL_rs = sv_dup_inc(proto_perl->Trs, param); + PL_last_in_gv = gv_dup(proto_perl->Tlast_in_gv, param); + PL_ofs_sv = sv_dup_inc(proto_perl->Tofs_sv, param); + PL_defoutgv = gv_dup_inc(proto_perl->Tdefoutgv, param); + PL_chopset = proto_perl->Tchopset; /* XXX never deallocated */ + PL_toptarget = sv_dup_inc(proto_perl->Ttoptarget, param); + PL_bodytarget = sv_dup_inc(proto_perl->Tbodytarget, param); + PL_formtarget = sv_dup(proto_perl->Tformtarget, param); - /* shortcuts to misc objects */ - PL_errgv = gv_dup(proto_perl->Ierrgv, param); + PL_restartop = proto_perl->Trestartop; + PL_in_eval = proto_perl->Tin_eval; + PL_delaymagic = proto_perl->Tdelaymagic; + PL_dirty = proto_perl->Tdirty; + PL_localizing = proto_perl->Tlocalizing; - /* shortcuts to debugging objects */ - PL_DBgv = gv_dup(proto_perl->IDBgv, param); - PL_DBline = gv_dup(proto_perl->IDBline, param); - PL_DBsub = gv_dup(proto_perl->IDBsub, param); - 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); + PL_errors = sv_dup_inc(proto_perl->Terrors, param); + PL_hv_fetch_ent_mh = Nullhe; + PL_modcount = proto_perl->Tmodcount; + PL_lastgotoprobe = Nullop; + PL_dumpindent = proto_perl->Tdumpindent; - /* symbol tables */ - PL_defstash = hv_dup_inc(proto_perl->Tdefstash, param); - PL_curstash = hv_dup(proto_perl->Tcurstash, 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_sortcop = (OP*)any_dup(proto_perl->Tsortcop, proto_perl); + PL_sortstash = hv_dup(proto_perl->Tsortstash, param); + PL_firstgv = gv_dup(proto_perl->Tfirstgv, param); + PL_secondgv = gv_dup(proto_perl->Tsecondgv, param); + PL_efloatbuf = Nullch; /* reinits on demand */ + PL_efloatsize = 0; /* reinits on demand */ - 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); + /* regex stuff */ - PL_sub_generation = proto_perl->Isub_generation; + PL_screamfirst = NULL; + PL_screamnext = NULL; + PL_maxscream = -1; /* reinits on demand */ + PL_lastscream = Nullsv; - /* funky return mechanisms */ - PL_forkprocess = proto_perl->Iforkprocess; + PL_watchaddr = NULL; + PL_watchok = Nullch; - /* subprocess state */ - PL_fdpid = av_dup_inc(proto_perl->Ifdpid, param); + PL_regdummy = proto_perl->Tregdummy; + PL_regprecomp = Nullch; + PL_regnpar = 0; + PL_regsize = 0; + PL_colorset = 0; /* reinits PL_colors[] */ + /*PL_colors[6] = {0,0,0,0,0,0};*/ + PL_reginput = Nullch; + PL_regbol = Nullch; + PL_regeol = Nullch; + PL_regstartp = (I32*)NULL; + PL_regendp = (I32*)NULL; + PL_reglastparen = (U32*)NULL; + PL_reglastcloseparen = (U32*)NULL; + PL_regtill = Nullch; + PL_reg_start_tmp = (char**)NULL; + PL_reg_start_tmpl = 0; + PL_regdata = (struct reg_data*)NULL; + PL_bostr = Nullch; + PL_reg_flags = 0; + PL_reg_eval_set = 0; + PL_regnarrate = 0; + PL_regprogram = (regnode*)NULL; + PL_regindent = 0; + PL_regcc = (CURCUR*)NULL; + PL_reg_call_cc = (struct re_cc_state*)NULL; + PL_reg_re = (regexp*)NULL; + PL_reg_ganch = Nullch; + PL_reg_sv = Nullsv; + PL_reg_match_utf8 = FALSE; + PL_reg_magic = (MAGIC*)NULL; + PL_reg_oldpos = 0; + PL_reg_oldcurpm = (PMOP*)NULL; + PL_reg_curpm = (PMOP*)NULL; + PL_reg_oldsaved = Nullch; + PL_reg_oldsavedlen = 0; +#ifdef PERL_OLD_COPY_ON_WRITE + PL_nrs = Nullsv; +#endif + PL_reg_maxiter = 0; + PL_reg_leftiter = 0; + PL_reg_poscache = Nullch; + PL_reg_poscache_size= 0; - /* internal state */ - 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; */ + /* RE engine - function pointers */ + PL_regcompp = proto_perl->Tregcompp; + PL_regexecp = proto_perl->Tregexecp; + PL_regint_start = proto_perl->Tregint_start; + PL_regint_string = proto_perl->Tregint_string; + PL_regfree = proto_perl->Tregfree; - /* current interpreter roots */ - PL_main_cv = cv_dup_inc(proto_perl->Imain_cv, param); - PL_main_root = OpREFCNT_inc(proto_perl->Imain_root); - PL_main_start = proto_perl->Imain_start; - PL_eval_root = proto_perl->Ieval_root; - PL_eval_start = proto_perl->Ieval_start; + PL_reginterp_cnt = 0; + PL_reg_starttry = 0; - /* runtime control stuff */ - PL_curcopdb = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl); - PL_copline = proto_perl->Icopline; + /* Pluggable optimizer */ + PL_peepp = proto_perl->Tpeepp; - PL_filemode = proto_perl->Ifilemode; - PL_lastfd = proto_perl->Ilastfd; - PL_oldname = proto_perl->Ioldname; /* XXX not quite right */ - PL_Argv = NULL; - PL_Cmd = Nullch; - PL_gensym = proto_perl->Igensym; - PL_preambled = proto_perl->Ipreambled; - PL_preambleav = av_dup_inc(proto_perl->Ipreambleav, param); - PL_laststatval = proto_perl->Ilaststatval; - PL_laststype = proto_perl->Ilaststype; - PL_mess_sv = Nullsv; + PL_stashcache = newHV(); - PL_ors_sv = sv_dup_inc(proto_perl->Iors_sv, param); + if (!(flags & CLONEf_KEEP_PTR_TABLE)) { + ptr_table_free(PL_ptr_table); + PL_ptr_table = NULL; + } - /* interpreter atexit processing */ - PL_exitlistlen = proto_perl->Iexitlistlen; - if (PL_exitlistlen) { - Newx(PL_exitlist, PL_exitlistlen, PerlExitListEntry); - Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry); + /* Call the ->CLONE method, if it exists, for each of the stashes + identified by sv_dup() above. + */ + while(av_len(param->stashes) != -1) { + HV* const stash = (HV*) av_shift(param->stashes); + GV* const cloner = gv_fetchmethod_autoload(stash, "CLONE", 0); + if (cloner && GvCV(cloner)) { + dSP; + ENTER; + SAVETMPS; + PUSHMARK(SP); + XPUSHs(sv_2mortal(newSVhek(HvNAME_HEK(stash)))); + PUTBACK; + call_sv((SV*)GvCV(cloner), G_DISCARD); + FREETMPS; + LEAVE; + } } - else - PL_exitlist = (PerlExitListEntry*)NULL; - PL_modglobal = hv_dup_inc(proto_perl->Imodglobal, param); - PL_custom_op_names = hv_dup_inc(proto_perl->Icustom_op_names,param); - PL_custom_op_descs = hv_dup_inc(proto_perl->Icustom_op_descs,param); - PL_profiledata = NULL; - PL_rsfp = fp_dup(proto_perl->Irsfp, '<', param); - /* PL_rsfp_filters entries have fake IoDIRP() */ - PL_rsfp_filters = av_dup_inc(proto_perl->Irsfp_filters, param); + SvREFCNT_dec(param->stashes); - PL_compcv = cv_dup(proto_perl->Icompcv, param); + /* orphaned? eg threads->new inside BEGIN or use */ + if (PL_compcv && ! SvREFCNT(PL_compcv)) { + (void)SvREFCNT_inc(PL_compcv); + SAVEFREESV(PL_compcv); + } - PAD_CLONE_VARS(proto_perl, param); + return my_perl; +} -#ifdef HAVE_INTERP_INTERN - sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern); -#endif +#endif /* USE_ITHREADS */ - /* more statics moved here */ - PL_generation = proto_perl->Igeneration; - PL_DBcv = cv_dup(proto_perl->IDBcv, param); +/* +=head1 Unicode Support - PL_in_clean_objs = proto_perl->Iin_clean_objs; - PL_in_clean_all = proto_perl->Iin_clean_all; +=for apidoc sv_recode_to_utf8 - PL_uid = proto_perl->Iuid; - PL_euid = proto_perl->Ieuid; - PL_gid = proto_perl->Igid; - PL_egid = proto_perl->Iegid; - PL_nomemok = proto_perl->Inomemok; - PL_an = proto_perl->Ian; - PL_evalseq = proto_perl->Ievalseq; - PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */ - PL_origalen = proto_perl->Iorigalen; -#ifdef PERL_USES_PL_PIDSTATUS - PL_pidstatus = newHV(); /* XXX flag for cloning? */ -#endif - PL_osname = SAVEPV(proto_perl->Iosname); - PL_sighandlerp = proto_perl->Isighandlerp; +The encoding is assumed to be an Encode object, on entry the PV +of the sv is assumed to be octets in that encoding, and the sv +will be converted into Unicode (and UTF-8). - PL_runops = proto_perl->Irunops; +If the sv already is UTF-8 (or if it is not POK), or if the encoding +is not a reference, nothing is done to the sv. If the encoding is not +an C Encoding object, bad things will happen. +(See F and L). - Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char); +The PV of the sv is returned. -#ifdef CSH - PL_cshlen = proto_perl->Icshlen; - PL_cshname = proto_perl->Icshname; /* XXX never deallocated */ -#endif +=cut */ - PL_lex_state = proto_perl->Ilex_state; - PL_lex_defer = proto_perl->Ilex_defer; - PL_lex_expect = proto_perl->Ilex_expect; - PL_lex_formbrack = proto_perl->Ilex_formbrack; - PL_lex_dojoin = proto_perl->Ilex_dojoin; - PL_lex_starts = proto_perl->Ilex_starts; - PL_lex_stuff = sv_dup_inc(proto_perl->Ilex_stuff, param); - PL_lex_repl = sv_dup_inc(proto_perl->Ilex_repl, param); - PL_lex_op = proto_perl->Ilex_op; - PL_lex_inpat = proto_perl->Ilex_inpat; - PL_lex_inwhat = proto_perl->Ilex_inwhat; - PL_lex_brackets = proto_perl->Ilex_brackets; - i = (PL_lex_brackets < 120 ? 120 : PL_lex_brackets); - PL_lex_brackstack = SAVEPVN(proto_perl->Ilex_brackstack,i); - PL_lex_casemods = proto_perl->Ilex_casemods; - i = (PL_lex_casemods < 12 ? 12 : PL_lex_casemods); - PL_lex_casestack = SAVEPVN(proto_perl->Ilex_casestack,i); +char * +Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding) +{ + dVAR; + if (SvPOK(sv) && !SvUTF8(sv) && !IN_BYTES && SvROK(encoding)) { + SV *uni; + STRLEN len; + const 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 + for Encode::XS, while UTf-8 decode (currently) assumes a true value means + remove converted chars from source. - Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE); - Copy(proto_perl->Inexttype, PL_nexttype, 5, I32); - PL_nexttoke = proto_perl->Inexttoke; + Both will default the value - let them. - /* XXX This is probably masking the deeper issue of why - * SvANY(proto_perl->Ilinestr) can be NULL at this point. For test case: - * http://archive.develooper.com/perl5-porters%40perl.org/msg83298.html - * (A little debugging with a watchpoint on it may help.) - */ - if (SvANY(proto_perl->Ilinestr)) { - PL_linestr = sv_dup_inc(proto_perl->Ilinestr, param); - i = proto_perl->Ibufptr - SvPVX_const(proto_perl->Ilinestr); - PL_bufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i); - i = proto_perl->Ioldbufptr - SvPVX_const(proto_perl->Ilinestr); - PL_oldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i); - i = proto_perl->Ioldoldbufptr - SvPVX_const(proto_perl->Ilinestr); - PL_oldoldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i); - i = proto_perl->Ilinestart - SvPVX_const(proto_perl->Ilinestr); - PL_linestart = SvPVX(PL_linestr) + (i < 0 ? 0 : i); - } - else { - PL_linestr = NEWSV(65,79); - sv_upgrade(PL_linestr,SVt_PVIV); - sv_setpvn(PL_linestr,"",0); - PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr); + XPUSHs(&PL_sv_yes); +*/ + PUTBACK; + call_method("decode", G_SCALAR); + SPAGAIN; + uni = POPs; + PUTBACK; + s = SvPV_const(uni, len); + if (s != SvPVX_const(sv)) { + SvGROW(sv, len + 1); + Move(s, SvPVX(sv), len + 1, char); + SvCUR_set(sv, len); + } + FREETMPS; + LEAVE; + SvUTF8_on(sv); + return SvPVX(sv); } - PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); - PL_pending_ident = proto_perl->Ipending_ident; - PL_sublex_info = proto_perl->Isublex_info; /* XXX not quite right */ + return SvPOKp(sv) ? SvPVX(sv) : NULL; +} - PL_expect = proto_perl->Iexpect; +/* +=for apidoc sv_cat_decode - PL_multi_start = proto_perl->Imulti_start; - PL_multi_end = proto_perl->Imulti_end; - PL_multi_open = proto_perl->Imulti_open; - PL_multi_close = proto_perl->Imulti_close; +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. - PL_error_count = proto_perl->Ierror_count; - PL_subline = proto_perl->Isubline; - PL_subname = sv_dup_inc(proto_perl->Isubname, param); +Returns TRUE if the terminator was found, else returns FALSE. - /* XXX See comment on SvANY(proto_perl->Ilinestr) above */ - if (SvANY(proto_perl->Ilinestr)) { - i = proto_perl->Ilast_uni - SvPVX_const(proto_perl->Ilinestr); - PL_last_uni = SvPVX(PL_linestr) + (i < 0 ? 0 : i); - i = proto_perl->Ilast_lop - SvPVX_const(proto_perl->Ilinestr); - PL_last_lop = SvPVX(PL_linestr) + (i < 0 ? 0 : i); - PL_last_lop_op = proto_perl->Ilast_lop_op; - } - else { - PL_last_uni = SvPVX(PL_linestr); - PL_last_lop = SvPVX(PL_linestr); - PL_last_lop_op = 0; +=cut */ + +bool +Perl_sv_cat_decode(pTHX_ SV *dsv, SV *encoding, + SV *ssv, int *offset, char *tstr, int tlen) +{ + dVAR; + 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; } - PL_in_my = proto_perl->Iin_my; - PL_in_my_stash = hv_dup(proto_perl->Iin_my_stash, param); -#ifdef FCRYPT - PL_cryptseen = proto_perl->Icryptseen; -#endif + else + Perl_croak(aTHX_ "Invalid argument to sv_cat_decode"); + return ret; - PL_hints = proto_perl->Ihints; +} - PL_amagic_generation = proto_perl->Iamagic_generation; +/* --------------------------------------------------------------------- + * + * support functions for report_uninit() + */ -#ifdef USE_LOCALE_COLLATE - PL_collation_ix = proto_perl->Icollation_ix; - PL_collation_name = SAVEPV(proto_perl->Icollation_name); - PL_collation_standard = proto_perl->Icollation_standard; - PL_collxfrm_base = proto_perl->Icollxfrm_base; - PL_collxfrm_mult = proto_perl->Icollxfrm_mult; -#endif /* USE_LOCALE_COLLATE */ +/* the maxiumum size of array or hash where we will scan looking + * for the undefined element that triggered the warning */ -#ifdef USE_LOCALE_NUMERIC - PL_numeric_name = SAVEPV(proto_perl->Inumeric_name); - PL_numeric_standard = proto_perl->Inumeric_standard; - PL_numeric_local = proto_perl->Inumeric_local; - PL_numeric_radix_sv = sv_dup_inc(proto_perl->Inumeric_radix_sv, param); -#endif /* !USE_LOCALE_NUMERIC */ +#define FUV_MAX_SEARCH_SIZE 1000 - /* utf8 character classes */ - PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum, param); - PL_utf8_alnumc = sv_dup_inc(proto_perl->Iutf8_alnumc, param); - PL_utf8_ascii = sv_dup_inc(proto_perl->Iutf8_ascii, param); - PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha, param); - PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space, param); - PL_utf8_cntrl = sv_dup_inc(proto_perl->Iutf8_cntrl, param); - PL_utf8_graph = sv_dup_inc(proto_perl->Iutf8_graph, param); - PL_utf8_digit = sv_dup_inc(proto_perl->Iutf8_digit, param); - PL_utf8_upper = sv_dup_inc(proto_perl->Iutf8_upper, param); - PL_utf8_lower = sv_dup_inc(proto_perl->Iutf8_lower, param); - PL_utf8_print = sv_dup_inc(proto_perl->Iutf8_print, param); - PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct, param); - PL_utf8_xdigit = sv_dup_inc(proto_perl->Iutf8_xdigit, param); - PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark, param); - PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper, param); - PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle, param); - PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower, param); - PL_utf8_tofold = sv_dup_inc(proto_perl->Iutf8_tofold, param); - PL_utf8_idstart = sv_dup_inc(proto_perl->Iutf8_idstart, param); - PL_utf8_idcont = sv_dup_inc(proto_perl->Iutf8_idcont, param); +/* Look for an entry in the hash whose value has the same SV as val; + * If so, return a mortal copy of the key. */ - /* Did the locale setup indicate UTF-8? */ - PL_utf8locale = proto_perl->Iutf8locale; - /* Unicode features (see perlrun/-C) */ - PL_unicode = proto_perl->Iunicode; +STATIC SV* +S_find_hash_subscript(pTHX_ HV *hv, SV* val) +{ + dVAR; + register HE **array; + I32 i; - /* Pre-5.8 signals control */ - PL_signals = proto_perl->Isignals; + if (!hv || SvMAGICAL(hv) || !HvARRAY(hv) || + (HvTOTALKEYS(hv) > FUV_MAX_SEARCH_SIZE)) + return Nullsv; - /* times() ticks per second */ - PL_clocktick = proto_perl->Iclocktick; + array = HvARRAY(hv); - /* Recursion stopper for PerlIO_find_layer */ - PL_in_load_module = proto_perl->Iin_load_module; + for (i=HvMAX(hv); i>0; i--) { + register HE *entry; + for (entry = array[i]; entry; entry = HeNEXT(entry)) { + if (HeVAL(entry) != val) + continue; + if ( HeVAL(entry) == &PL_sv_undef || + HeVAL(entry) == &PL_sv_placeholder) + continue; + if (!HeKEY(entry)) + return Nullsv; + if (HeKLEN(entry) == HEf_SVKEY) + return sv_mortalcopy(HeKEY_sv(entry)); + return sv_2mortal(newSVpvn(HeKEY(entry), HeKLEN(entry))); + } + } + return Nullsv; +} - /* sort() routine */ - PL_sort_RealCmp = proto_perl->Isort_RealCmp; +/* Look for an entry in the array whose value has the same SV as val; + * If so, return the index, otherwise return -1. */ - /* Not really needed/useful since the reenrant_retint is "volatile", - * but do it for consistency's sake. */ - PL_reentrant_retint = proto_perl->Ireentrant_retint; +STATIC I32 +S_find_array_subscript(pTHX_ AV *av, SV* val) +{ + SV** svp; + I32 i; + if (!av || SvMAGICAL(av) || !AvARRAY(av) || + (AvFILLp(av) > FUV_MAX_SEARCH_SIZE)) + return -1; - /* Hooks to shared SVs and locks. */ - PL_sharehook = proto_perl->Isharehook; - PL_lockhook = proto_perl->Ilockhook; - PL_unlockhook = proto_perl->Iunlockhook; - PL_threadhook = proto_perl->Ithreadhook; + svp = AvARRAY(av); + for (i=AvFILLp(av); i>=0; i--) { + if (svp[i] == val && svp[i] != &PL_sv_undef) + return i; + } + return -1; +} - PL_runops_std = proto_perl->Irunops_std; - PL_runops_dbg = proto_perl->Irunops_dbg; +/* S_varname(): return the name of a variable, optionally with a subscript. + * If gv is non-zero, use the name of that global, along with gvtype (one + * of "$", "@", "%"); otherwise use the name of the lexical at pad offset + * targ. Depending on the value of the subscript_type flag, return: + */ -#ifdef THREADS_HAVE_PIDS - PL_ppid = proto_perl->Ippid; -#endif +#define FUV_SUBSCRIPT_NONE 1 /* "@foo" */ +#define FUV_SUBSCRIPT_ARRAY 2 /* "$foo[aindex]" */ +#define FUV_SUBSCRIPT_HASH 3 /* "$foo{keyname}" */ +#define FUV_SUBSCRIPT_WITHIN 4 /* "within @foo" */ - /* swatch cache */ - PL_last_swash_hv = Nullhv; /* reinits on demand */ - PL_last_swash_klen = 0; - PL_last_swash_key[0]= '\0'; - PL_last_swash_tmps = (U8*)NULL; - PL_last_swash_slen = 0; +STATIC SV* +S_varname(pTHX_ GV *gv, const char gvtype, PADOFFSET targ, + SV* keyname, I32 aindex, int subscript_type) +{ - PL_glob_index = proto_perl->Iglob_index; - PL_srand_called = proto_perl->Isrand_called; - PL_uudmap['M'] = 0; /* reinits on demand */ - PL_bitcount = Nullch; /* reinits on demand */ + SV * const name = sv_newmortal(); + if (gv) { + char buffer[2]; + buffer[0] = gvtype; + buffer[1] = 0; - if (proto_perl->Ipsig_pend) { - Newxz(PL_psig_pend, SIG_SIZE, int); - } - else { - PL_psig_pend = (int*)NULL; - } + /* as gv_fullname4(), but add literal '^' for $^FOO names */ - if (proto_perl->Ipsig_ptr) { - Newxz(PL_psig_ptr, SIG_SIZE, SV*); - Newxz(PL_psig_name, SIG_SIZE, SV*); - for (i = 1; i < SIG_SIZE; i++) { - PL_psig_ptr[i] = sv_dup_inc(proto_perl->Ipsig_ptr[i], param); - PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i], param); - } - } - else { - PL_psig_ptr = (SV**)NULL; - PL_psig_name = (SV**)NULL; - } + gv_fullname4(name, gv, buffer, 0); - /* thrdvar.h stuff */ + if ((unsigned int)SvPVX(name)[1] <= 26) { + buffer[0] = '^'; + buffer[1] = SvPVX(name)[1] + 'A' - 1; - if (flags & CLONEf_COPY_STACKS) { - /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */ - PL_tmps_ix = proto_perl->Ttmps_ix; - PL_tmps_max = proto_perl->Ttmps_max; - PL_tmps_floor = proto_perl->Ttmps_floor; - Newxz(PL_tmps_stack, PL_tmps_max, SV*); - i = 0; - while (i <= PL_tmps_ix) { - PL_tmps_stack[i] = sv_dup_inc(proto_perl->Ttmps_stack[i], param); - ++i; + /* Swap the 1 unprintable control character for the 2 byte pretty + version - ie substr($name, 1, 1) = $buffer; */ + sv_insert(name, 1, 1, buffer, 2); } + } + else { + U32 unused; + CV * const cv = find_runcv(&unused); + SV *sv; + AV *av; - /* next PUSHMARK() sets *(PL_markstack_ptr+1) */ - i = proto_perl->Tmarkstack_max - proto_perl->Tmarkstack; - Newxz(PL_markstack, i, I32); - PL_markstack_max = PL_markstack + (proto_perl->Tmarkstack_max - - proto_perl->Tmarkstack); - PL_markstack_ptr = PL_markstack + (proto_perl->Tmarkstack_ptr - - proto_perl->Tmarkstack); - Copy(proto_perl->Tmarkstack, PL_markstack, - PL_markstack_ptr - PL_markstack + 1, I32); + if (!cv || !CvPADLIST(cv)) + return Nullsv; + av = (AV*)(*av_fetch(CvPADLIST(cv), 0, FALSE)); + sv = *av_fetch(av, targ, FALSE); + /* SvLEN in a pad name is not to be trusted */ + sv_setpv(name, SvPV_nolen_const(sv)); + } - /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix] - * NOTE: unlike the others! */ - PL_scopestack_ix = proto_perl->Tscopestack_ix; - PL_scopestack_max = proto_perl->Tscopestack_max; - Newxz(PL_scopestack, PL_scopestack_max, I32); - Copy(proto_perl->Tscopestack, PL_scopestack, PL_scopestack_ix, I32); + if (subscript_type == FUV_SUBSCRIPT_HASH) { + SV * const sv = NEWSV(0,0); + *SvPVX(name) = '$'; + Perl_sv_catpvf(aTHX_ name, "{%s}", + pv_display(sv,SvPVX_const(keyname), SvCUR(keyname), 0, 32)); + SvREFCNT_dec(sv); + } + else if (subscript_type == FUV_SUBSCRIPT_ARRAY) { + *SvPVX(name) = '$'; + Perl_sv_catpvf(aTHX_ name, "[%"IVdf"]", (IV)aindex); + } + else if (subscript_type == FUV_SUBSCRIPT_WITHIN) + sv_insert(name, 0, 0, "within ", 7); - /* NOTE: si_dup() looks at PL_markstack */ - PL_curstackinfo = si_dup(proto_perl->Tcurstackinfo, param); + return name; +} - /* PL_curstack = PL_curstackinfo->si_stack; */ - PL_curstack = av_dup(proto_perl->Tcurstack, param); - PL_mainstack = av_dup(proto_perl->Tmainstack, param); - /* next PUSHs() etc. set *(PL_stack_sp+1) */ - PL_stack_base = AvARRAY(PL_curstack); - PL_stack_sp = PL_stack_base + (proto_perl->Tstack_sp - - proto_perl->Tstack_base); - PL_stack_max = PL_stack_base + AvMAX(PL_curstack); +/* +=for apidoc find_uninit_var - /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix] - * NOTE: unlike the others! */ - PL_savestack_ix = proto_perl->Tsavestack_ix; - PL_savestack_max = proto_perl->Tsavestack_max; - /*Newxz(PL_savestack, PL_savestack_max, ANY);*/ - PL_savestack = ss_dup(proto_perl, param); - } - else { - init_stacks(); - ENTER; /* perl_destruct() wants to LEAVE; */ - } +Find the name of the undefined variable (if any) that caused the operator o +to issue a "Use of uninitialized value" warning. +If match is true, only return a name if it's value matches uninit_sv. +So roughly speaking, if a unary operator (such as OP_COS) generates a +warning, then following the direct child of the op may yield an +OP_PADSV or OP_GV that gives the name of the undefined variable. On the +other hand, with OP_ADD there are two branches to follow, so we only print +the variable name if we get an exact match. - PL_start_env = proto_perl->Tstart_env; /* XXXXXX */ - PL_top_env = &PL_start_env; +The name is returned as a mortal SV. - PL_op = proto_perl->Top; +Assumes that PL_op is the op that originally triggered the error, and that +PL_comppad/PL_curpad points to the currently executing pad. - PL_Sv = Nullsv; - PL_Xpv = (XPV*)NULL; - PL_na = proto_perl->Tna; +=cut +*/ - PL_statbuf = proto_perl->Tstatbuf; - PL_statcache = proto_perl->Tstatcache; - PL_statgv = gv_dup(proto_perl->Tstatgv, param); - PL_statname = sv_dup_inc(proto_perl->Tstatname, param); -#ifdef HAS_TIMES - PL_timesbuf = proto_perl->Ttimesbuf; -#endif +STATIC SV * +S_find_uninit_var(pTHX_ OP* obase, SV* uninit_sv, bool match) +{ + dVAR; + SV *sv; + AV *av; + GV *gv; + OP *o, *o2, *kid; - PL_tainted = proto_perl->Ttainted; - PL_curpm = proto_perl->Tcurpm; /* XXX No PMOP ref count */ - PL_rs = sv_dup_inc(proto_perl->Trs, param); - PL_last_in_gv = gv_dup(proto_perl->Tlast_in_gv, param); - PL_ofs_sv = sv_dup_inc(proto_perl->Tofs_sv, param); - PL_defoutgv = gv_dup_inc(proto_perl->Tdefoutgv, param); - PL_chopset = proto_perl->Tchopset; /* XXX never deallocated */ - PL_toptarget = sv_dup_inc(proto_perl->Ttoptarget, param); - PL_bodytarget = sv_dup_inc(proto_perl->Tbodytarget, param); - PL_formtarget = sv_dup(proto_perl->Tformtarget, param); + if (!obase || (match && (!uninit_sv || uninit_sv == &PL_sv_undef || + uninit_sv == &PL_sv_placeholder))) + return Nullsv; - PL_restartop = proto_perl->Trestartop; - PL_in_eval = proto_perl->Tin_eval; - PL_delaymagic = proto_perl->Tdelaymagic; - PL_dirty = proto_perl->Tdirty; - PL_localizing = proto_perl->Tlocalizing; + switch (obase->op_type) { - PL_errors = sv_dup_inc(proto_perl->Terrors, param); - PL_hv_fetch_ent_mh = Nullhe; - PL_modcount = proto_perl->Tmodcount; - PL_lastgotoprobe = Nullop; - PL_dumpindent = proto_perl->Tdumpindent; + case OP_RV2AV: + case OP_RV2HV: + case OP_PADAV: + case OP_PADHV: + { + const bool pad = (obase->op_type == OP_PADAV || obase->op_type == OP_PADHV); + const bool hash = (obase->op_type == OP_PADHV || obase->op_type == OP_RV2HV); + I32 index = 0; + SV *keysv = Nullsv; + int subscript_type = FUV_SUBSCRIPT_WITHIN; - PL_sortcop = (OP*)any_dup(proto_perl->Tsortcop, proto_perl); - PL_sortstash = hv_dup(proto_perl->Tsortstash, param); - PL_firstgv = gv_dup(proto_perl->Tfirstgv, param); - PL_secondgv = gv_dup(proto_perl->Tsecondgv, param); - PL_efloatbuf = Nullch; /* reinits on demand */ - PL_efloatsize = 0; /* reinits on demand */ + if (pad) { /* @lex, %lex */ + sv = PAD_SVl(obase->op_targ); + gv = Nullgv; + } + else { + if (cUNOPx(obase)->op_first->op_type == OP_GV) { + /* @global, %global */ + gv = cGVOPx_gv(cUNOPx(obase)->op_first); + if (!gv) + break; + sv = hash ? (SV*)GvHV(gv): (SV*)GvAV(gv); + } + else /* @{expr}, %{expr} */ + return find_uninit_var(cUNOPx(obase)->op_first, + uninit_sv, match); + } - /* regex stuff */ + /* attempt to find a match within the aggregate */ + if (hash) { + keysv = S_find_hash_subscript(aTHX_ (HV*)sv, uninit_sv); + if (keysv) + subscript_type = FUV_SUBSCRIPT_HASH; + } + else { + index = S_find_array_subscript(aTHX_ (AV*)sv, uninit_sv); + if (index >= 0) + subscript_type = FUV_SUBSCRIPT_ARRAY; + } - PL_screamfirst = NULL; - PL_screamnext = NULL; - PL_maxscream = -1; /* reinits on demand */ - PL_lastscream = Nullsv; + if (match && subscript_type == FUV_SUBSCRIPT_WITHIN) + break; - PL_watchaddr = NULL; - PL_watchok = Nullch; + return varname(gv, hash ? '%' : '@', obase->op_targ, + keysv, index, subscript_type); + } - PL_regdummy = proto_perl->Tregdummy; - PL_regprecomp = Nullch; - PL_regnpar = 0; - PL_regsize = 0; - PL_colorset = 0; /* reinits PL_colors[] */ - /*PL_colors[6] = {0,0,0,0,0,0};*/ - PL_reginput = Nullch; - PL_regbol = Nullch; - PL_regeol = Nullch; - PL_regstartp = (I32*)NULL; - PL_regendp = (I32*)NULL; - PL_reglastparen = (U32*)NULL; - PL_reglastcloseparen = (U32*)NULL; - PL_regtill = Nullch; - PL_reg_start_tmp = (char**)NULL; - PL_reg_start_tmpl = 0; - PL_regdata = (struct reg_data*)NULL; - PL_bostr = Nullch; - PL_reg_flags = 0; - PL_reg_eval_set = 0; - PL_regnarrate = 0; - PL_regprogram = (regnode*)NULL; - PL_regindent = 0; - PL_regcc = (CURCUR*)NULL; - PL_reg_call_cc = (struct re_cc_state*)NULL; - PL_reg_re = (regexp*)NULL; - PL_reg_ganch = Nullch; - PL_reg_sv = Nullsv; - PL_reg_match_utf8 = FALSE; - PL_reg_magic = (MAGIC*)NULL; - PL_reg_oldpos = 0; - PL_reg_oldcurpm = (PMOP*)NULL; - PL_reg_curpm = (PMOP*)NULL; - PL_reg_oldsaved = Nullch; - PL_reg_oldsavedlen = 0; -#ifdef PERL_OLD_COPY_ON_WRITE - PL_nrs = Nullsv; -#endif - PL_reg_maxiter = 0; - PL_reg_leftiter = 0; - PL_reg_poscache = Nullch; - PL_reg_poscache_size= 0; + case OP_PADSV: + if (match && PAD_SVl(obase->op_targ) != uninit_sv) + break; + return varname(Nullgv, '$', obase->op_targ, + Nullsv, 0, FUV_SUBSCRIPT_NONE); - /* RE engine - function pointers */ - PL_regcompp = proto_perl->Tregcompp; - PL_regexecp = proto_perl->Tregexecp; - PL_regint_start = proto_perl->Tregint_start; - PL_regint_string = proto_perl->Tregint_string; - PL_regfree = proto_perl->Tregfree; + case OP_GVSV: + gv = cGVOPx_gv(obase); + if (!gv || (match && GvSV(gv) != uninit_sv)) + break; + return varname(gv, '$', 0, Nullsv, 0, FUV_SUBSCRIPT_NONE); - PL_reginterp_cnt = 0; - PL_reg_starttry = 0; + case OP_AELEMFAST: + if (obase->op_flags & OPf_SPECIAL) { /* lexical array */ + if (match) { + SV **svp; + av = (AV*)PAD_SV(obase->op_targ); + if (!av || SvRMAGICAL(av)) + break; + svp = av_fetch(av, (I32)obase->op_private, FALSE); + if (!svp || *svp != uninit_sv) + break; + } + return varname(Nullgv, '$', obase->op_targ, + Nullsv, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY); + } + else { + gv = cGVOPx_gv(obase); + if (!gv) + break; + if (match) { + SV **svp; + av = GvAV(gv); + if (!av || SvRMAGICAL(av)) + break; + svp = av_fetch(av, (I32)obase->op_private, FALSE); + if (!svp || *svp != uninit_sv) + break; + } + return varname(gv, '$', 0, + Nullsv, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY); + } + break; - /* Pluggable optimizer */ - PL_peepp = proto_perl->Tpeepp; + case OP_EXISTS: + o = cUNOPx(obase)->op_first; + if (!o || o->op_type != OP_NULL || + ! (o->op_targ == OP_AELEM || o->op_targ == OP_HELEM)) + break; + return find_uninit_var(cBINOPo->op_last, uninit_sv, match); - PL_stashcache = newHV(); + case OP_AELEM: + case OP_HELEM: + if (PL_op == obase) + /* $a[uninit_expr] or $h{uninit_expr} */ + return find_uninit_var(cBINOPx(obase)->op_last, uninit_sv, match); - if (!(flags & CLONEf_KEEP_PTR_TABLE)) { - ptr_table_free(PL_ptr_table); - PL_ptr_table = NULL; - } + gv = Nullgv; + o = cBINOPx(obase)->op_first; + kid = cBINOPx(obase)->op_last; - /* Call the ->CLONE method, if it exists, for each of the stashes - identified by sv_dup() above. - */ - while(av_len(param->stashes) != -1) { - HV* const stash = (HV*) av_shift(param->stashes); - GV* const cloner = gv_fetchmethod_autoload(stash, "CLONE", 0); - if (cloner && GvCV(cloner)) { - dSP; - ENTER; - SAVETMPS; - PUSHMARK(SP); - XPUSHs(sv_2mortal(newSVhek(HvNAME_HEK(stash)))); - PUTBACK; - call_sv((SV*)GvCV(cloner), G_DISCARD); - FREETMPS; - LEAVE; + /* get the av or hv, and optionally the gv */ + sv = Nullsv; + if (o->op_type == OP_PADAV || o->op_type == OP_PADHV) { + sv = PAD_SV(o->op_targ); + } + else if ((o->op_type == OP_RV2AV || o->op_type == OP_RV2HV) + && cUNOPo->op_first->op_type == OP_GV) + { + gv = cGVOPx_gv(cUNOPo->op_first); + if (!gv) + break; + sv = o->op_type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)GvAV(gv); + } + if (!sv) + break; + + if (kid && kid->op_type == OP_CONST && SvOK(cSVOPx_sv(kid))) { + /* index is constant */ + if (match) { + if (SvMAGICAL(sv)) + break; + if (obase->op_type == OP_HELEM) { + HE* he = hv_fetch_ent((HV*)sv, cSVOPx_sv(kid), 0, 0); + if (!he || HeVAL(he) != uninit_sv) + break; + } + else { + SV ** const svp = av_fetch((AV*)sv, SvIV(cSVOPx_sv(kid)), FALSE); + if (!svp || *svp != uninit_sv) + break; + } + } + if (obase->op_type == OP_HELEM) + return varname(gv, '%', o->op_targ, + cSVOPx_sv(kid), 0, FUV_SUBSCRIPT_HASH); + else + return varname(gv, '@', o->op_targ, Nullsv, + SvIV(cSVOPx_sv(kid)), FUV_SUBSCRIPT_ARRAY); + ; + } + else { + /* index is an expression; + * attempt to find a match within the aggregate */ + if (obase->op_type == OP_HELEM) { + SV * const keysv = S_find_hash_subscript(aTHX_ (HV*)sv, uninit_sv); + if (keysv) + return varname(gv, '%', o->op_targ, + keysv, 0, FUV_SUBSCRIPT_HASH); + } + else { + const I32 index = S_find_array_subscript(aTHX_ (AV*)sv, uninit_sv); + if (index >= 0) + return varname(gv, '@', o->op_targ, + Nullsv, index, FUV_SUBSCRIPT_ARRAY); + } + if (match) + break; + return varname(gv, + (o->op_type == OP_PADAV || o->op_type == OP_RV2AV) + ? '@' : '%', + o->op_targ, Nullsv, 0, FUV_SUBSCRIPT_WITHIN); } - } - SvREFCNT_dec(param->stashes); + break; - /* orphaned? eg threads->new inside BEGIN or use */ - if (PL_compcv && ! SvREFCNT(PL_compcv)) { - (void)SvREFCNT_inc(PL_compcv); - SAVEFREESV(PL_compcv); - } + case OP_AASSIGN: + /* only examine RHS */ + return find_uninit_var(cBINOPx(obase)->op_first, uninit_sv, match); - return my_perl; -} + case OP_OPEN: + o = cUNOPx(obase)->op_first; + if (o->op_type == OP_PUSHMARK) + o = o->op_sibling; -#endif /* USE_ITHREADS */ + if (!o->op_sibling) { + /* one-arg version of open is highly magical */ -/* -=head1 Unicode Support + if (o->op_type == OP_GV) { /* open FOO; */ + gv = cGVOPx_gv(o); + if (match && GvSV(gv) != uninit_sv) + break; + return varname(gv, '$', 0, + Nullsv, 0, FUV_SUBSCRIPT_NONE); + } + /* other possibilities not handled are: + * open $x; or open my $x; should return '${*$x}' + * open expr; should return '$'.expr ideally + */ + break; + } + goto do_op; -=for apidoc sv_recode_to_utf8 + /* ops where $_ may be an implicit arg */ + case OP_TRANS: + case OP_SUBST: + case OP_MATCH: + if ( !(obase->op_flags & OPf_STACKED)) { + if (uninit_sv == ((obase->op_private & OPpTARGET_MY) + ? PAD_SVl(obase->op_targ) + : DEFSV)) + { + sv = sv_newmortal(); + sv_setpvn(sv, "$_", 2); + return sv; + } + } + goto do_op; -The encoding is assumed to be an Encode object, on entry the PV -of the sv is assumed to be octets in that encoding, and the sv -will be converted into Unicode (and UTF-8). + case OP_PRTF: + case OP_PRINT: + /* skip filehandle as it can't produce 'undef' warning */ + o = cUNOPx(obase)->op_first; + if ((obase->op_flags & OPf_STACKED) && o->op_type == OP_PUSHMARK) + o = o->op_sibling->op_sibling; + goto do_op2; -If the sv already is UTF-8 (or if it is not POK), or if the encoding -is not a reference, nothing is done to the sv. If the encoding is not -an C Encoding object, bad things will happen. -(See F and L). -The PV of the sv is returned. + case OP_RV2SV: + case OP_CUSTOM: + case OP_ENTERSUB: + match = 1; /* XS or custom code could trigger random warnings */ + goto do_op; -=cut */ + case OP_SCHOMP: + case OP_CHOMP: + if (SvROK(PL_rs) && uninit_sv == SvRV(PL_rs)) + return sv_2mortal(newSVpvn("${$/}", 5)); + /* FALL THROUGH */ -char * -Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding) -{ - dVAR; - if (SvPOK(sv) && !SvUTF8(sv) && !IN_BYTES && SvROK(encoding)) { - SV *uni; - STRLEN len; - const 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 - for Encode::XS, while UTf-8 decode (currently) assumes a true value means - remove converted chars from source. + default: + do_op: + if (!(obase->op_flags & OPf_KIDS)) + break; + o = cUNOPx(obase)->op_first; + + do_op2: + if (!o) + break; - Both will default the value - let them. + /* if all except one arg are constant, or have no side-effects, + * or are optimized away, then it's unambiguous */ + o2 = Nullop; + for (kid=o; kid; kid = kid->op_sibling) { + if (kid && + ( (kid->op_type == OP_CONST && SvOK(cSVOPx_sv(kid))) + || (kid->op_type == OP_NULL && ! (kid->op_flags & OPf_KIDS)) + || (kid->op_type == OP_PUSHMARK) + ) + ) + continue; + if (o2) { /* more than one found */ + o2 = Nullop; + break; + } + o2 = kid; + } + if (o2) + return find_uninit_var(o2, uninit_sv, match); - XPUSHs(&PL_sv_yes); -*/ - PUTBACK; - call_method("decode", G_SCALAR); - SPAGAIN; - uni = POPs; - PUTBACK; - s = SvPV_const(uni, len); - if (s != SvPVX_const(sv)) { - SvGROW(sv, len + 1); - Move(s, SvPVX(sv), len + 1, char); - SvCUR_set(sv, len); + /* scan all args */ + while (o) { + sv = find_uninit_var(o, uninit_sv, 1); + if (sv) + return sv; + o = o->op_sibling; } - FREETMPS; - LEAVE; - SvUTF8_on(sv); - return SvPVX(sv); + break; } - return SvPOKp(sv) ? SvPVX(sv) : NULL; + return Nullsv; } -/* -=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. +/* +=for apidoc report_uninit -Returns TRUE if the terminator was found, else returns FALSE. +Print appropriate "Use of uninitialized variable" warning -=cut */ +=cut +*/ -bool -Perl_sv_cat_decode(pTHX_ SV *dsv, SV *encoding, - SV *ssv, int *offset, char *tstr, int tlen) +void +Perl_report_uninit(pTHX_ SV* uninit_sv) { - dVAR; - 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; + if (PL_op) { + SV* varname = Nullsv; + if (uninit_sv) { + varname = find_uninit_var(PL_op, uninit_sv,0); + if (varname) + sv_insert(varname, 0, 0, " ", 1); + } + Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit, + varname ? SvPV_nolen_const(varname) : "", + " in ", OP_DESC(PL_op)); } else - Perl_croak(aTHX_ "Invalid argument to sv_cat_decode"); - return ret; + Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit, + "", "", ""); } /*