X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=sv.c;h=f918d5ab2722a1cf8a039135d858df3dde86a79b;hb=170c5524f26ec8d57d5b2a5413842df92809a613;hp=fdd9a65bc0422fb719071a0e3e78395aa7c0e7b0;hpb=a95c302be5eb00c1f54619017ae777b107c54275;p=p5sagit%2Fp5-mst-13.2.git diff --git a/sv.c b/sv.c index fdd9a65..f918d5a 100644 --- a/sv.c +++ b/sv.c @@ -112,8 +112,7 @@ list, and call more_xiv() etc to add a new arena if the list is empty. At the time of very final cleanup, sv_free_arenas() is called from perl_destruct() to physically free all the arenas allocated since the -start of the interpreter. Note that this also clears PL_he_arenaroot, -which is otherwise dealt with in hv.c. +start of the interpreter. Manipulation of any of the PL_*root pointers is protected by enclosing LOCK_SV_MUTEX; ... UNLOCK_SV_MUTEX calls which should Do the Right Thing @@ -358,7 +357,7 @@ and split it into a list of free SVs. void Perl_sv_add_arena(pTHX_ char *ptr, U32 size, U32 flags) { - SV* sva = (SV*)ptr; + SV* const sva = (SV*)ptr; register SV* sv; register SV* svend; @@ -521,7 +520,7 @@ do_clean_all(pTHX_ SV *sv) DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) )); SvFLAGS(sv) |= SVf_BREAK; if (PL_comppad == (AV*)sv) { - PL_comppad = Nullav; + PL_comppad = NULL; PL_curpad = Null(SV**); } SvREFCNT_dec(sv); @@ -596,8 +595,6 @@ Perl_sv_free_arenas(pTHX) PL_body_roots[i] = 0; } - free_arena(he); - Safefree(PL_nice_chunk); PL_nice_chunk = Nullch; PL_nice_chunk_size = 0; @@ -605,1560 +602,1471 @@ 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 ** const arena_root = &PL_body_arenaroots[sv_type]; + void ** const 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 ** const 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 ** const 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; +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 */ +}; - if (!obase || (match && (!uninit_sv || uninit_sv == &PL_sv_undef || - uninit_sv == &PL_sv_placeholder))) - return Nullsv; +#define HADNV FALSE +#define NONV TRUE - switch (obase->op_type) { +#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 - 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; +/* A macro to work out the offset needed to subtract from a pointer to (say) - 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); - } +typedef struct { + STRLEN xpv_cur; + STRLEN xpv_len; +} xpv_allocated; - /* 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; - } +to make its members accessible via a pointer to (say) - if (match && subscript_type == FUV_SUBSCRIPT_WITHIN) - break; +struct xpv { + NV xnv_nv; + STRLEN xpv_cur; + STRLEN xpv_len; +}; - return varname(gv, hash ? '%' : '@', obase->op_targ, - keysv, index, subscript_type); - } +*/ - case OP_PADSV: - if (match && PAD_SVl(obase->op_targ) != uninit_sv) - break; - return varname(Nullgv, '$', obase->op_targ, - Nullsv, 0, FUV_SUBSCRIPT_NONE); +#define relative_STRUCT_OFFSET(longer, shorter, member) \ + (STRUCT_OFFSET(shorter, member) - STRUCT_OFFSET(longer, member)) - case OP_GVSV: - gv = cGVOPx_gv(obase); - if (!gv || (match && GvSV(gv) != uninit_sv)) - break; - return varname(gv, '$', 0, Nullsv, 0, FUV_SUBSCRIPT_NONE); +/* 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_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; +#define copy_length(type, last_member) \ + STRUCT_OFFSET(type, last_member) \ + + sizeof (((type*)SvANY((SV*)0))->last_member) - 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); +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} +}; - 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); +#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) - gv = Nullgv; - o = cBINOPx(obase)->op_first; - kid = cBINOPx(obase)->op_last; +#define del_body_type(p, sv_type) \ + del_body(p, &PL_body_roots[sv_type]) - /* 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); - } +#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) - break; +#define del_body_allocated(p, sv_type) \ + del_body(p + bodies_by_type[sv_type].offset, &PL_body_roots[sv_type]) - case OP_AASSIGN: - /* only examine RHS */ - return find_uninit_var(cBINOPx(obase)->op_first, uninit_sv, match); - case OP_OPEN: - o = cUNOPx(obase)->op_first; - if (o->op_type == OP_PUSHMARK) - o = o->op_sibling; +#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_sibling) { - /* one-arg version of open is highly magical */ +#ifdef PURIFY - 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; +#define new_XNV() my_safemalloc(sizeof(XPVNV)) +#define del_XNV(p) my_safefree(p) - /* 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_XPVNV() my_safemalloc(sizeof(XPVNV)) +#define del_XPVNV(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_XPVAV() my_safemalloc(sizeof(XPVAV)) +#define del_XPVAV(p) my_safefree(p) +#define new_XPVHV() my_safemalloc(sizeof(XPVHV)) +#define del_XPVHV(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_XPVMG() my_safemalloc(sizeof(XPVMG)) +#define del_XPVMG(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_XPVGV() my_safemalloc(sizeof(XPVGV)) +#define del_XPVGV(p) my_safefree(p) - default: - do_op: - if (!(obase->op_flags & OPf_KIDS)) - break; - o = cUNOPx(obase)->op_first; - - do_op2: - if (!o) - break; +#else /* !PURIFY */ - /* 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); +#define new_XNV() new_body_type(SVt_NV) +#define del_XNV(p) del_body_type(p, SVt_NV) - /* 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_XPVNV() new_body_type(SVt_PVNV) +#define del_XPVNV(p) del_body_type(p, SVt_PVNV) + +#define new_XPVAV() new_body_allocated(SVt_PVAV) +#define del_XPVAV(p) del_body_allocated(p, SVt_PVAV) + +#define new_XPVHV() new_body_allocated(SVt_PVHV) +#define del_XPVHV(p) del_body_allocated(p, SVt_PVHV) + +#define new_XPVMG() new_body_type(SVt_PVMG) +#define del_XPVMG(p) del_body_type(p, SVt_PVMG) + +#define new_XPVGV() new_body_type(SVt_PVGV) +#define del_XPVGV(p) del_body_type(p, SVt_PVGV) + +#endif /* PURIFY */ + +/* no arena for you! */ +#define new_NOARENA(details) \ + my_safemalloc((details)->size + (details)->offset) +#define new_NOARENAZ(details) \ + my_safecalloc((details)->size + (details)->offset) /* -=for apidoc report_uninit +=for apidoc sv_upgrade -Print appropriate "Use of uninitialized variable" warning +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. =cut */ void -Perl_report_uninit(pTHX_ SV* uninit_sv) +Perl_sv_upgrade(pTHX_ register SV *sv, U32 new_type) { - 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)); + 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); } - else - Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit, - "", "", ""); -} -/* - Here are mid-level routines that manage the allocation of bodies out - of the various arenas. There are 5 kinds of arenas: + if (old_type == new_type) + return; - 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) + if (old_type > new_type) + Perl_croak(aTHX_ "sv_upgrade from type %d down to type %d", + (int)old_type, (int)new_type); - 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) - 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. + old_body = SvANY(sv); - HE, HEK arenas are managed separately, with separate code, but may - be merge-able later.. + /* Copying structures onto other structures that have been neatly zeroed + has a subtle gotcha. Consider XPVMG - 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) -*/ + +------+------+------+------+------+-------+-------+ + | NV | CUR | LEN | IV | MAGIC | STASH | + +------+------+------+------+------+-------+-------+ + 0 4 8 12 16 20 24 28 -STATIC void * -S_more_bodies (pTHX_ size_t size, svtype sv_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; + 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: - Newx(start, count*size, char); - *((void **) start) = *arena_root; - *arena_root = (void *)start; + +------+------+------+------+------+-------+-------+------+ + | NV | CUR | LEN | IV | MAGIC | STASH | ??? | + +------+------+------+------+------+-------+-------+------+ + 0 4 8 12 16 20 24 28 32 - end = start + (count-1) * size; + so what happens if you allocate memory for this structure: - /* 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. */ + +------+------+------+------+------+-------+-------+------+------+... + | NV | CUR | LEN | IV | MAGIC | STASH | GP | NAME | + +------+------+------+------+------+-------+-------+------+------+... + 0 4 8 12 16 20 24 28 32 36 - start += size; + 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. - *root = (void *)start; + (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) - while (start < end) { - char * const next = start + size; - *(void**) start = (void *)next; - start = next; - } - *(void **)start = 0; + So we are careful and work out the size of used parts of all the + structures. */ - return *root; -} + 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"); + } -/* grab a new thing from the free list, allocating more if necessary */ + SvFLAGS(sv) &= ~SVTYPEMASK; + SvFLAGS(sv) |= new_type; -/* 1st, the inline version */ + 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; -#define new_body_inline(xpv, root, size, sv_type) \ - STMT_START { \ - LOCK_SV_MUTEX; \ - xpv = *((void **)(root)) \ - ? *((void **)(root)) : S_more_bodies(aTHX_ size, sv_type); \ - *(root) = *(void**)(xpv); \ - UNLOCK_SV_MUTEX; \ - } STMT_END + goto hv_av_common; -/* now use the inline version in the proper function */ + case SVt_PVAV: + SvANY(sv) = new_XPVAV(); + AvMAX(sv) = -1; + AvFILLp(sv) = -1; + AvALLOC(sv) = 0; + AvREAL_only(sv); -#ifndef PURIFY + 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); + } -/* This isn't being used with -DPURIFY, so don't declare it. Otherwise - compilers issue warnings. */ + /* Could put this in the else clause below, as PVMG must have SvPVX + 0 already (the assertion above) */ + SvPV_set(sv, (char*)0); -STATIC void * -S_new_body(pTHX_ size_t size, svtype sv_type) -{ - void *xpv; - new_body_inline(xpv, &PL_body_roots[sv_type], size, sv_type); - return xpv; -} + 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; -#endif -/* return a thing to the free list */ + 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 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 + 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; -/* - 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, + 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); + } - 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.) +#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 - 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. + 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); + } - 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. */ + 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 + } +} -/* The following 2 arrays hide the above details in a pair of - lookup-tables, allowing us to be body-type agnostic. +/* +=for apidoc sv_backoff - size maps svtype to its body's allocated size. - offset maps svtype to the body-pointer adjustment needed +Remove any string offset. You should normally use the C macro +wrapper instead. - 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. +=cut */ -struct body_details { - size_t size; /* Size to allocate */ - size_t copy; /* Size of structure to copy (may be shorter) */ - int offset; - bool cant_upgrade; /* Can upgrade this type */ - bool zero_nv; /* zero the NV when upgrading from this */ -}; - -static const struct body_details bodies_by_type[] = { - {0, 0, 0, FALSE, TRUE}, - /* IVs are in the head, so the allocation size is 0 */ - {0, sizeof(IV), -STRUCT_OFFSET(XPVIV, xiv_iv), FALSE, TRUE}, - /* 8 bytes on most ILP32 with IEEE doubles */ - {sizeof(NV), sizeof(NV), 0, FALSE, FALSE}, - /* RVs are in the head now */ - {0, 0, 0, FALSE, TRUE}, - /* 8 bytes on most ILP32 with IEEE doubles */ - {sizeof(xpv_allocated), - STRUCT_OFFSET(XPV, xpv_len) + sizeof (((XPV*)SvANY((SV*)0))->xpv_len) - + STRUCT_OFFSET(xpv_allocated, xpv_cur) - STRUCT_OFFSET(XPV, xpv_cur), - + STRUCT_OFFSET(xpv_allocated, xpv_cur) - STRUCT_OFFSET(XPV, xpv_cur) - , FALSE, TRUE}, - /* 12 */ - {sizeof(xpviv_allocated), - STRUCT_OFFSET(XPVIV, xiv_u) + sizeof (((XPVIV*)SvANY((SV*)0))->xiv_u) - + STRUCT_OFFSET(xpviv_allocated, xpv_cur) - STRUCT_OFFSET(XPVIV, xpv_cur), - + STRUCT_OFFSET(xpviv_allocated, xpv_cur) - STRUCT_OFFSET(XPVIV, xpv_cur) - , FALSE, TRUE}, - /* 20 */ - {sizeof(XPVNV), - STRUCT_OFFSET(XPVNV, xiv_u) + sizeof (((XPVNV*)SvANY((SV*)0))->xiv_u), - 0, FALSE, FALSE}, - /* 28 */ - {sizeof(XPVMG), - STRUCT_OFFSET(XPVMG, xmg_stash) + sizeof (((XPVMG*)SvANY((SV*)0))->xmg_stash), - 0, FALSE, FALSE}, - /* 36 */ - {sizeof(XPVBM), 0, 0, TRUE, FALSE}, - /* 48 */ - {sizeof(XPVGV), 0, 0, TRUE, FALSE}, - /* 64 */ - {sizeof(XPVLV), 0, 0, TRUE, FALSE}, - /* 20 */ - {sizeof(xpvav_allocated), 0, - STRUCT_OFFSET(xpvav_allocated, xav_fill) - - STRUCT_OFFSET(XPVAV, xav_fill), TRUE, FALSE}, - /* 20 */ - {sizeof(xpvhv_allocated), 0, - STRUCT_OFFSET(xpvhv_allocated, xhv_fill) - - STRUCT_OFFSET(XPVHV, xhv_fill), TRUE, FALSE}, - /* 76 */ - {sizeof(XPVCV), 0, 0, TRUE, FALSE}, - /* 80 */ - {sizeof(XPVFM), 0, 0, TRUE, FALSE}, - /* 84 */ - {sizeof(XPVIO), 0, 0, TRUE, FALSE} -}; +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; +} -#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) +/* +=for apidoc sv_grow -#define del_body_type(p, sv_type) \ - del_body(p, &PL_body_roots[sv_type]) +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 +*/ -#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) +char * +Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen) +{ + register char *s; -#define del_body_allocated(p, sv_type) \ - del_body(p - bodies_by_type[sv_type].offset, &PL_body_roots[sv_type]) +#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; +} -#define my_safemalloc(s) (void*)safemalloc(s) -#define my_safefree(p) safefree((char*)p) +/* +=for apidoc sv_setiv -#ifdef PURIFY +Copies an integer into the given SV, upgrading first if necessary. +Does not handle 'set' magic. See also C. -#define new_XNV() my_safemalloc(sizeof(XPVNV)) -#define del_XNV(p) my_safefree(p) +=cut +*/ -#define new_XPV() my_safemalloc(sizeof(XPV)) -#define del_XPV(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_XPVIV() my_safemalloc(sizeof(XPVIV)) -#define del_XPVIV(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_XPVNV() my_safemalloc(sizeof(XPVNV)) -#define del_XPVNV(p) my_safefree(p) +/* +=for apidoc sv_setiv_mg -#define new_XPVCV() my_safemalloc(sizeof(XPVCV)) -#define del_XPVCV(p) my_safefree(p) +Like C, but also handles 'set' magic. -#define new_XPVAV() my_safemalloc(sizeof(XPVAV)) -#define del_XPVAV(p) my_safefree(p) +=cut +*/ -#define new_XPVHV() my_safemalloc(sizeof(XPVHV)) -#define del_XPVHV(p) my_safefree(p) +void +Perl_sv_setiv_mg(pTHX_ register SV *sv, IV i) +{ + sv_setiv(sv,i); + SvSETMAGIC(sv); +} -#define new_XPVMG() my_safemalloc(sizeof(XPVMG)) -#define del_XPVMG(p) my_safefree(p) +/* +=for apidoc sv_setuv -#define new_XPVGV() my_safemalloc(sizeof(XPVGV)) -#define del_XPVGV(p) my_safefree(p) +Copies an unsigned integer into the given SV, upgrading first if necessary. +Does not handle 'set' magic. See also C. -#define new_XPVLV() my_safemalloc(sizeof(XPVLV)) -#define del_XPVLV(p) my_safefree(p) +=cut +*/ -#define new_XPVBM() my_safemalloc(sizeof(XPVBM)) -#define del_XPVBM(p) my_safefree(p) +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 -#else /* !PURIFY */ + without + u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865 -#define new_XNV() new_body_type(SVt_NV) -#define del_XNV(p) del_body_type(p, SVt_NV) + 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_XPV() new_body_allocated(SVt_PV) -#define del_XPV(p) del_body_allocated(p, SVt_PV) +/* +=for apidoc sv_setuv_mg -#define new_XPVIV() new_body_allocated(SVt_PVIV) -#define del_XPVIV(p) del_body_allocated(p, SVt_PVIV) +Like C, but also handles 'set' magic. -#define new_XPVNV() new_body_type(SVt_PVNV) -#define del_XPVNV(p) del_body_type(p, SVt_PVNV) +=cut +*/ -#define new_XPVCV() new_body_type(SVt_PVCV) -#define del_XPVCV(p) del_body_type(p, SVt_PVCV) +void +Perl_sv_setuv_mg(pTHX_ register SV *sv, UV u) +{ + sv_setiv(sv, 0); + SvIsUV_on(sv); + sv_setuv(sv,u); + SvSETMAGIC(sv); +} -#define new_XPVAV() new_body_allocated(SVt_PVAV) -#define del_XPVAV(p) del_body_allocated(p, SVt_PVAV) +/* +=for apidoc sv_setnv -#define new_XPVHV() new_body_allocated(SVt_PVHV) -#define del_XPVHV(p) del_body_allocated(p, SVt_PVHV) +Copies a double into the given SV, upgrading first if necessary. +Does not handle 'set' magic. See also C. -#define new_XPVMG() new_body_type(SVt_PVMG) -#define del_XPVMG(p) del_body_type(p, SVt_PVMG) +=cut +*/ -#define new_XPVGV() new_body_type(SVt_PVGV) -#define del_XPVGV(p) del_body_type(p, SVt_PVGV) +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; -#define new_XPVLV() new_body_type(SVt_PVLV) -#define del_XPVLV(p) del_body_type(p, SVt_PVLV) + 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); +} -#define new_XPVBM() new_body_type(SVt_PVBM) -#define del_XPVBM(p) del_body_type(p, SVt_PVBM) +/* +=for apidoc sv_setnv_mg -#endif /* PURIFY */ +Like C, but also handles 'set' magic. -/* no arena for you! */ -#define new_XPVFM() my_safemalloc(sizeof(XPVFM)) -#define del_XPVFM(p) my_safefree(p) +=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 + */ -#define new_XPVIO() my_safemalloc(sizeof(XPVIO)) -#define del_XPVIO(p) my_safefree(p) +STATIC void +S_not_a_number(pTHX_ SV *sv) +{ + SV *dsv; + char tmpbuf[64]; + const char *pv; + if (DO_UTF8(sv)) { + dsv = sv_2mortal(newSVpvn("", 0)); + pv = sv_uni_display(dsv, sv, 10, 0); + } else { + char *d = tmpbuf; + const char * const limit = tmpbuf + sizeof(tmpbuf) - 8; + /* each *s can expand to 4 chars + "...\0", + i.e. need room for 8 chars */ + + const char *s = SvPVX_const(sv); + const char * const end = s + SvCUR(sv); + for ( ; s < end && d < limit; s++ ) { + int ch = *s & 0xFF; + if (ch & 128 && !isPRINT_LC(ch)) { + *d++ = 'M'; + *d++ = '-'; + ch &= 127; + } + if (ch == '\n') { + *d++ = '\\'; + *d++ = 'n'; + } + else if (ch == '\r') { + *d++ = '\\'; + *d++ = 'r'; + } + else if (ch == '\f') { + *d++ = '\\'; + *d++ = 'f'; + } + else if (ch == '\\') { + *d++ = '\\'; + *d++ = '\\'; + } + else if (ch == '\0') { + *d++ = '\\'; + *d++ = '0'; + } + else if (isPRINT_LC(ch)) + *d++ = ch; + else { + *d++ = '^'; + *d++ = toCTRL(ch); + } + } + if (s < end) { + *d++ = '.'; + *d++ = '.'; + *d++ = '.'; + } + *d = '\0'; + pv = tmpbuf; + } + if (PL_op) + Perl_warner(aTHX_ packWARN(WARN_NUMERIC), + "Argument \"%s\" isn't numeric in %s", pv, + OP_DESC(PL_op)); + else + Perl_warner(aTHX_ packWARN(WARN_NUMERIC), + "Argument \"%s\" isn't numeric", pv); +} /* -=for apidoc sv_upgrade +=for apidoc looks_like_number -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. +Test if the content of an SV looks like a number (or is a number). +C and C are treated as numbers (so will not issue a +non-numeric warning), even if your atof() doesn't grok them. =cut */ -void -Perl_sv_upgrade(pTHX_ register SV *sv, U32 new_type) +I32 +Perl_looks_like_number(pTHX_ SV *sv) { - void* old_body; - void* new_body; - size_t new_body_length; - size_t new_body_offset; - void** new_body_arena; - void** new_body_arenaroot; - const U32 old_type = SvTYPE(sv); - const struct body_details *const old_type_details - = bodies_by_type + old_type; + register const char *sbegin; + STRLEN len; - if (new_type != SVt_PV && SvIsCOW(sv)) { - sv_force_normal_flags(sv, 0); + if (SvPOK(sv)) { + sbegin = SvPVX_const(sv); + len = SvCUR(sv); } + else if (SvPOKp(sv)) + sbegin = SvPV_const(sv, len); + else + return SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK); + return grok_number(sbegin, len, NULL); +} - 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); +/* Actually, ISO C leaves conversion of UV to IV undefined, but + until proven guilty, assume that things are not that bad... */ +/* + NV_PRESERVES_UV: - old_body = SvANY(sv); - new_body_offset = 0; - new_body_length = ~0; + As 64 bit platforms often have an NV that doesn't preserve all bits of + an IV (an assumption perl has been based on to date) it becomes necessary + to remove the assumption that the NV always carries enough precision to + recreate the IV whenever needed, and that the NV is the canonical form. + Instead, IV/UV and NV need to be given equal rights. So as to not lose + precision as a side effect of conversion (which would lead to insanity + and the dragon(s) in t/op/numconvert.t getting very angry) the intent is + 1) to distinguish between IV/UV/NV slots that have cached a valid + conversion where precision was lost and IV/UV/NV slots that have a + valid conversion which has lost no precision + 2) to ensure that if a numeric conversion to one form is requested that + would lose precision, the precise conversion (or differently + imprecise conversion) is also performed and cached, to prevent + requests for different numeric formats on the same SV causing + lossy conversion chains. (lossless conversion chains are perfectly + acceptable (still)) - /* 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 + flags are used: + SvIOKp is true if the IV slot contains a valid value + SvIOK is true only if the IV value is accurate (UV if SvIOK_UV true) + SvNOKp is true if the NV slot contains a valid value + SvNOK is true only if the NV value is accurate - 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: + so + while converting from PV to NV, check to see if converting that NV to an + IV(or UV) would lose accuracy over a direct conversion from PV to + IV(or UV). If it would, cache both conversions, return NV, but mark + SV as IOK NOKp (ie not NOK). - +------+------+------+------+------+-------+-------+------+ - | NV | CUR | LEN | IV | MAGIC | STASH | ??? | - +------+------+------+------+------+-------+-------+------+ - 0 4 8 12 16 20 24 28 32 + While converting from PV to IV, check to see if converting that IV to an + NV would lose accuracy over a direct conversion from PV to NV. If it + would, cache both conversions, flag similarly. - 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) { - case SVt_NULL: - break; - case SVt_IV: - if (new_type < SVt_PVIV) { - new_type = (new_type == SVt_NV) - ? SVt_PVNV : SVt_PVIV; - } - break; - case SVt_NV: - if (new_type < SVt_PVNV) - new_type = SVt_PVNV; - 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); - } - break; + Before, the SV value "3.2" could become NV=3.2 IV=3 NOK, IOK quite + correctly because if IV & NV were set NV *always* overruled. + Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flag's meaning + changes - now IV and NV together means that the two are interchangeable: + SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX; - case SVt_PVIO: - new_body = new_XPVIO(); - new_body_length = sizeof(XPVIO); - goto zero; - case SVt_PVFM: - new_body = new_XPVFM(); - new_body_length = sizeof(XPVFM); - goto zero; + The benefit of this is that operations such as pp_add know that if + SvIOK is true for both left and right operands, then integer addition + can be used instead of floating point (for cases where the result won't + overflow). Before, floating point was always used, which could lead to + loss of precision compared with integer addition. - case SVt_PVBM: - case SVt_PVGV: - case SVt_PVCV: - case SVt_PVLV: - case SVt_PVMG: - case SVt_PVNV: - new_body_length = bodies_by_type[new_type].size; - new_body_arena = &PL_body_roots[new_type]; - new_body_arenaroot = &PL_body_arenaroots[new_type]; - goto new_body; + * making IV and NV equal status should make maths accurate on 64 bit + platforms + * may speed up maths somewhat if pp_add and friends start to use + integers when possible instead of fp. (Hopefully the overhead in + looking for SvIOK and checking for overflow will not outweigh the + fp to integer speedup) + * will slow down integer operations (callers of SvIV) on "inaccurate" + values, as the change from SvIOK to SvIOKp will cause a call into + sv_2iv each time rather than a macro access direct to the IV slot + * should speed up number->string conversion on integers as IV is + favoured when IV and NV are equally accurate - case SVt_PVIV: - new_body_offset = - bodies_by_type[SVt_PVIV].offset; - new_body_length = sizeof(XPVIV) - new_body_offset; - new_body_arena = &PL_body_roots[SVt_PVIV]; - new_body_arenaroot = &PL_body_arenaroots[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)); - goto new_body_no_NV; - case SVt_PV: - new_body_offset = - bodies_by_type[SVt_PV].offset; - new_body_length = sizeof(XPV) - new_body_offset; - new_body_arena = &PL_body_roots[SVt_PV]; - new_body_arenaroot = &PL_body_arenaroots[SVt_PV]; - new_body_no_NV: - /* PV and PVIV don't have an NV slot. */ - - new_body: - assert(new_body_length); -#ifndef PURIFY - /* This points to the start of the allocated area. */ - new_body_inline(new_body, new_body_arena, new_body_length, new_type); -#else - /* We always allocated the full length item with PURIFY */ - new_body_length += new_body_offset; - new_body_offset = 0; - new_body = my_safemalloc(new_body_length); + #################################################################### + You had better be using SvIOK_notUV if you want an IV for arithmetic: + SvIOK is true if (IV or UV), so you might be getting (IV)SvUV. + On the other hand, SvUOK is true iff UV. + #################################################################### -#endif - zero: - Zero(new_body, new_body_length, char); - new_body = ((char *)new_body) - new_body_offset; - SvANY(sv) = new_body; + Your mileage will vary depending your CPU's relative fp to integer + performance ratio. +*/ - 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_PRESERVES_UV +# define IS_NUMBER_UNDERFLOW_IV 1 +# define IS_NUMBER_UNDERFLOW_UV 2 +# define IS_NUMBER_IV_AND_UV 2 +# define IS_NUMBER_OVERFLOW_IV 4 +# define IS_NUMBER_OVERFLOW_UV 5 -#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 +/* sv_2iuv_non_preserve(): private routine for use by sv_2iv() and sv_2uv() */ - 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); +/* For sv_2nv these three cases are "SvNOK and don't bother casting" */ +STATIC int +S_sv_2iuv_non_preserve(pTHX_ register SV *sv, I32 numtype) +{ + DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_2iuv_non '%s', IV=0x%"UVxf" NV=%"NVgf" inttype=%"UVXf"\n", SvPVX_const(sv), SvIVX(sv), SvNVX(sv), (UV)numtype)); + if (SvNVX(sv) < (NV)IV_MIN) { + (void)SvIOKp_on(sv); + (void)SvNOK_on(sv); + SvIV_set(sv, IV_MIN); + return IS_NUMBER_UNDERFLOW_IV; } - - 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 + if (SvNVX(sv) > (NV)UV_MAX) { + (void)SvIOKp_on(sv); + (void)SvNOK_on(sv); + SvIsUV_on(sv); + SvUV_set(sv, UV_MAX); + return IS_NUMBER_OVERFLOW_UV; + } + (void)SvIOKp_on(sv); + (void)SvNOK_on(sv); + /* Can't use strtol etc to convert this string. (See truth table in + sv_2iv */ + if (SvNVX(sv) <= (UV)IV_MAX) { + SvIV_set(sv, I_V(SvNVX(sv))); + if ((NV)(SvIVX(sv)) == SvNVX(sv)) { + SvIOK_on(sv); /* Integer is precise. NOK, IOK */ + } else { + /* Integer is imprecise. NOK, IOKp */ + } + return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV; + } + SvIsUV_on(sv); + SvUV_set(sv, U_V(SvNVX(sv))); + if ((NV)(SvUVX(sv)) == SvNVX(sv)) { + if (SvUVX(sv) == UV_MAX) { + /* As we know that NVs don't preserve UVs, UV_MAX cannot + possibly be preserved by NV. Hence, it must be overflow. + NOK, IOKp */ + return IS_NUMBER_OVERFLOW_UV; + } + SvIOK_on(sv); /* Integer is precise. NOK, UOK */ + } else { + /* Integer is imprecise. NOK, IOKp */ } + return IS_NUMBER_OVERFLOW_IV; } +#endif /* !NV_PRESERVES_UV*/ -/* -=for apidoc sv_backoff - -Remove any string offset. You should normally use the C macro -wrapper instead. +STATIC bool +S_sv_2iuv_common(pTHX_ SV *sv) { + if (SvNOKp(sv)) { + /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv + * without also getting a cached IV/UV from it at the same time + * (ie PV->NV conversion should detect loss of accuracy and cache + * IV or UV at same time to avoid this. */ + /* IV-over-UV optimisation - choose to cache IV if possible */ -=cut -*/ + if (SvTYPE(sv) == SVt_NV) + sv_upgrade(sv, SVt_PVNV); -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; -} - -/* -=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 -*/ - -char * -Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen) -{ - register char *s; - -#ifdef HAS_64K_LIMIT - if (newlen >= 0x10000) { - PerlIO_printf(Perl_debug_log, - "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; + (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */ + /* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost + certainly cast into the IV range at IV_MAX, whereas the correct + answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary + cases go to UV */ + if (SvNVX(sv) < (NV)IV_MAX + 0.5) { + SvIV_set(sv, I_V(SvNVX(sv))); + if (SvNVX(sv) == (NV) SvIVX(sv) +#ifndef NV_PRESERVES_UV + && (((UV)1 << NV_PRESERVES_UV_BITS) > + (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv))) + /* Don't flag it as "accurately an integer" if the number + came from a (by definition imprecise) NV operation, and + we're outside the range of NV integer precision */ #endif - } - else - s = SvPVX_mutable(sv); + ) { + SvIOK_on(sv); /* Can this go wrong with rounding? NWC */ + DEBUG_c(PerlIO_printf(Perl_debug_log, + "0x%"UVxf" iv(%"NVgf" => %"IVdf") (precise)\n", + PTR2UV(sv), + SvNVX(sv), + SvIVX(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 { + /* IV not precise. No need to convert from PV, as NV + conversion would already have cached IV if it detected + that PV->IV would be better than PV->NV->IV + flags already correct - don't set public IOK. */ + DEBUG_c(PerlIO_printf(Perl_debug_log, + "0x%"UVxf" iv(%"NVgf" => %"IVdf") (imprecise)\n", + PTR2UV(sv), + SvNVX(sv), + SvIVX(sv))); + } + /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN, + but the cast (NV)IV_MIN rounds to a the value less (more + negative) than IV_MIN which happens to be equal to SvNVX ?? + Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and + NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and + (NV)UVX == NVX are both true, but the values differ. :-( + Hopefully for 2s complement IV_MIN is something like + 0x8000000000000000 which will be exact. NWC */ } else { - s = safemalloc(newlen); - if (SvPVX_const(sv) && SvCUR(sv)) { - Move(SvPVX_const(sv), s, (newlen < SvCUR(sv)) ? newlen : SvCUR(sv), char); - } + SvUV_set(sv, U_V(SvNVX(sv))); + if ( + (SvNVX(sv) == (NV) SvUVX(sv)) +#ifndef NV_PRESERVES_UV + /* Make sure it's not 0xFFFFFFFFFFFFFFFF */ + /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */ + && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv)) + /* Don't flag it as "accurately an integer" if the number + came from a (by definition imprecise) NV operation, and + we're outside the range of NV integer precision */ +#endif + ) + SvIOK_on(sv); + SvIsUV_on(sv); + DEBUG_c(PerlIO_printf(Perl_debug_log, + "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n", + PTR2UV(sv), + SvUVX(sv), + SvUVX(sv))); } - 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; + else if (SvPOKp(sv) && SvLEN(sv)) { + UV value; + const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value); + /* We want to avoid a possible problem when we cache an IV/ a UV which + may be later translated to an NV, and the resulting NV is not + the same as the direct translation of the initial string + (eg 123.456 can shortcut to the IV 123 with atol(), but we must + be careful to ensure that the value with the .456 is around if the + NV value is requested in the future). + + This means that if we cache such an IV/a UV, we need to cache the + NV as well. Moreover, we trade speed for space, and do not + cache the NV if we are sure it's not needed. + */ - 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); -} + /* SVt_PVNV is one higher than SVt_PVIV, hence this order */ + if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) + == IS_NUMBER_IN_UV) { + /* It's definitely an integer, only upgrade to PVIV */ + if (SvTYPE(sv) < SVt_PVIV) + sv_upgrade(sv, SVt_PVIV); + (void)SvIOK_on(sv); + } else if (SvTYPE(sv) < SVt_PVNV) + sv_upgrade(sv, SVt_PVNV); -/* -=for apidoc sv_setiv_mg + /* If NV preserves UV then we only use the UV value if we know that + we aren't going to call atof() below. If NVs don't preserve UVs + then the value returned may have more precision than atof() will + return, even though value isn't perfectly accurate. */ + if ((numtype & (IS_NUMBER_IN_UV +#ifdef NV_PRESERVES_UV + | IS_NUMBER_NOT_INT +#endif + )) == IS_NUMBER_IN_UV) { + /* This won't turn off the public IOK flag if it was set above */ + (void)SvIOKp_on(sv); -Like C, but also handles 'set' magic. + if (!(numtype & IS_NUMBER_NEG)) { + /* positive */; + if (value <= (UV)IV_MAX) { + SvIV_set(sv, (IV)value); + } else { + /* it didn't overflow, and it was positive. */ + SvUV_set(sv, value); + SvIsUV_on(sv); + } + } else { + /* 2s complement assumption */ + if (value <= (UV)IV_MIN) { + SvIV_set(sv, -(IV)value); + } else { + /* Too negative for an IV. This is a double upgrade, but + I'm assuming it will be rare. */ + if (SvTYPE(sv) < SVt_PVNV) + sv_upgrade(sv, SVt_PVNV); + SvNOK_on(sv); + SvIOK_off(sv); + SvIOKp_on(sv); + SvNV_set(sv, -(NV)value); + SvIV_set(sv, IV_MIN); + } + } + } + /* For !NV_PRESERVES_UV and IS_NUMBER_IN_UV and IS_NUMBER_NOT_INT we + will be in the previous block to set the IV slot, and the next + block to set the NV slot. So no else here. */ + + if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) + != IS_NUMBER_IN_UV) { + /* It wasn't an (integer that doesn't overflow the UV). */ + SvNV_set(sv, Atof(SvPVX_const(sv))); -=cut -*/ + if (! numtype && ckWARN(WARN_NUMERIC)) + not_a_number(sv); -void -Perl_sv_setiv_mg(pTHX_ register SV *sv, IV i) -{ - sv_setiv(sv,i); - SvSETMAGIC(sv); -} +#if defined(USE_LONG_DOUBLE) + DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" PERL_PRIgldbl ")\n", + PTR2UV(sv), SvNVX(sv))); +#else + DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"NVgf")\n", + PTR2UV(sv), SvNVX(sv))); +#endif -/* -=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; +#ifdef NV_PRESERVES_UV + (void)SvIOKp_on(sv); + (void)SvNOK_on(sv); + if (SvNVX(sv) < (NV)IV_MAX + 0.5) { + SvIV_set(sv, I_V(SvNVX(sv))); + if ((NV)(SvIVX(sv)) == SvNVX(sv)) { + SvIOK_on(sv); + } else { + /* Integer is imprecise. NOK, IOKp */ + } + /* UV will not work better than IV */ + } else { + if (SvNVX(sv) > (NV)UV_MAX) { + SvIsUV_on(sv); + /* Integer is inaccurate. NOK, IOKp, is UV */ + SvUV_set(sv, UV_MAX); + } else { + SvUV_set(sv, U_V(SvNVX(sv))); + /* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs + NV preservse UV so can do correct comparison. */ + if ((NV)(SvUVX(sv)) == SvNVX(sv)) { + SvIOK_on(sv); + } else { + /* Integer is imprecise. NOK, IOKp, is UV */ + } + } + SvIsUV_on(sv); + } +#else /* NV_PRESERVES_UV */ + if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) + == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) { + /* The IV/UV slot will have been set from value returned by + grok_number above. The NV slot has just been set using + Atof. */ + SvNOK_on(sv); + assert (SvIOKp(sv)); + } else { + if (((UV)1 << NV_PRESERVES_UV_BITS) > + U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) { + /* Small enough to preserve all bits. */ + (void)SvIOKp_on(sv); + SvNOK_on(sv); + SvIV_set(sv, I_V(SvNVX(sv))); + if ((NV)(SvIVX(sv)) == SvNVX(sv)) + SvIOK_on(sv); + /* Assumption: first non-preserved integer is < IV_MAX, + this NV is in the preserved range, therefore: */ + if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv)) + < (UV)IV_MAX)) { + Perl_croak(aTHX_ "sv_2iv assumed (U_V(fabs((double)SvNVX(sv))) < (UV)IV_MAX) but SvNVX(sv)=%"NVgf" U_V is 0x%"UVxf", IV_MAX is 0x%"UVxf"\n", SvNVX(sv), U_V(SvNVX(sv)), (UV)IV_MAX); + } + } else { + /* IN_UV NOT_INT + 0 0 already failed to read UV. + 0 1 already failed to read UV. + 1 0 you won't get here in this case. IV/UV + slot set, public IOK, Atof() unneeded. + 1 1 already read UV. + so there's no point in sv_2iuv_non_preserve() attempting + to use atol, strtol, strtoul etc. */ + sv_2iuv_non_preserve (sv, numtype); + } + } +#endif /* NV_PRESERVES_UV */ + } } - sv_setiv(sv, 0); - SvIsUV_on(sv); - SvUV_set(sv, u); + else { + if (!(SvFLAGS(sv) & SVs_PADTMP)) { + if (!PL_localizing && ckWARN(WARN_UNINITIALIZED)) + report_uninit(sv); + } + if (SvTYPE(sv) < SVt_IV) + /* Typically the caller expects that sv_any is not NULL now. */ + sv_upgrade(sv, SVt_IV); + /* Return 0 from the caller. */ + return TRUE; + } + return FALSE; } /* -=for apidoc sv_setuv_mg +=for apidoc sv_2iv_flags -Like C, but also handles 'set' magic. +Return the integer value of an SV, doing any necessary string +conversion. If flags includes SV_GMAGIC, does an mg_get() first. +Normally used via the C and C macros. =cut */ -void -Perl_sv_setuv_mg(pTHX_ register SV *sv, UV u) +IV +Perl_sv_2iv_flags(pTHX_ register SV *sv, I32 flags) { - sv_setiv(sv, 0); - SvIsUV_on(sv); - sv_setuv(sv,u); - SvSETMAGIC(sv); + if (!sv) + return 0; + if (SvGMAGICAL(sv)) { + if (flags & SV_GMAGIC) + mg_get(sv); + if (SvIOKp(sv)) + return SvIVX(sv); + if (SvNOKp(sv)) { + return I_V(SvNVX(sv)); + } + if (SvPOKp(sv) && SvLEN(sv)) { + UV value; + const int numtype + = grok_number(SvPVX_const(sv), SvCUR(sv), &value); + + if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) + == IS_NUMBER_IN_UV) { + /* It's definitely an integer */ + if (numtype & IS_NUMBER_NEG) { + if (value < (UV)IV_MIN) + return -(IV)value; + } else { + if (value < (UV)IV_MAX) + return (IV)value; + } + } + if (!numtype) { + if (ckWARN(WARN_NUMERIC)) + not_a_number(sv); + } + return I_V(Atof(SvPVX_const(sv))); + } + if (SvROK(sv)) { + goto return_rok; + } + assert(SvTYPE(sv) >= SVt_PVMG); + /* This falls through to the report_uninit inside S_sv_2iuv_common. */ + } + if (SvTHINKFIRST(sv)) { + if (SvROK(sv)) { + return_rok: + if (SvAMAGIC(sv)) { + SV * const tmpstr=AMG_CALLun(sv,numer); + if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) { + return SvIV(tmpstr); + } + } + return PTR2IV(SvRV(sv)); + } + if (SvIsCOW(sv)) { + sv_force_normal_flags(sv, 0); + } + if (SvREADONLY(sv) && !SvOK(sv)) { + if (ckWARN(WARN_UNINITIALIZED)) + report_uninit(sv); + return 0; + } + } + if (!SvIOKp(sv)) { + if (S_sv_2iuv_common(aTHX_ sv)) + return 0; + } + DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n", + PTR2UV(sv),SvIVX(sv))); + return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv); } /* -=for apidoc sv_setnv +=for apidoc sv_2uv_flags -Copies a double into the given SV, upgrading first if necessary. -Does not handle 'set' magic. See also C. +Return the unsigned integer value of an SV, doing any necessary string +conversion. If flags includes SV_GMAGIC, does an mg_get() first. +Normally used via the C and C macros. =cut */ -void -Perl_sv_setnv(pTHX_ register SV *sv, NV num) +UV +Perl_sv_2uv_flags(pTHX_ register SV *sv, I32 flags) { - 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)); + if (!sv) + return 0; + if (SvGMAGICAL(sv)) { + if (flags & SV_GMAGIC) + mg_get(sv); + if (SvIOKp(sv)) + return SvUVX(sv); + if (SvNOKp(sv)) + return U_V(SvNVX(sv)); + if (SvPOKp(sv) && SvLEN(sv)) { + UV value; + const int numtype + = grok_number(SvPVX_const(sv), SvCUR(sv), &value); + + if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) + == IS_NUMBER_IN_UV) { + /* It's definitely an integer */ + if (!(numtype & IS_NUMBER_NEG)) + return value; + } + if (!numtype) { + if (ckWARN(WARN_NUMERIC)) + not_a_number(sv); + } + return U_V(Atof(SvPVX_const(sv))); + } + if (SvROK(sv)) { + goto return_rok; + } + assert(SvTYPE(sv) >= SVt_PVMG); + /* This falls through to the report_uninit inside S_sv_2iuv_common. */ } - SvNV_set(sv, num); - (void)SvNOK_only(sv); /* validate number */ - SvTAINT(sv); + if (SvTHINKFIRST(sv)) { + if (SvROK(sv)) { + return_rok: + if (SvAMAGIC(sv)) { + SV *const tmpstr = AMG_CALLun(sv,numer); + if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) { + return SvUV(tmpstr); + } + } + return PTR2UV(SvRV(sv)); + } + if (SvIsCOW(sv)) { + sv_force_normal_flags(sv, 0); + } + if (SvREADONLY(sv) && !SvOK(sv)) { + if (ckWARN(WARN_UNINITIALIZED)) + report_uninit(sv); + return 0; + } + } + if (!SvIOKp(sv)) { + if (S_sv_2iuv_common(aTHX_ sv)) + return 0; + } + + DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n", + PTR2UV(sv),SvUVX(sv))); + return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv); } /* -=for apidoc sv_setnv_mg +=for apidoc sv_2nv -Like C, but also handles 'set' magic. +Return the num value of an SV, doing any necessary string or integer +conversion, magic etc. Normally used via the C and C +macros. =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; - - if (DO_UTF8(sv)) { - dsv = sv_2mortal(newSVpvn("", 0)); - pv = sv_uni_display(dsv, sv, 10, 0); - } else { - char *d = tmpbuf; - const char * const limit = tmpbuf + sizeof(tmpbuf) - 8; - /* each *s can expand to 4 chars + "...\0", - i.e. need room for 8 chars */ - - const char *s, *end; - for (s = SvPVX_const(sv), end = s + SvCUR(sv); s < end && d < limit; - s++) { - int ch = *s & 0xFF; - if (ch & 128 && !isPRINT_LC(ch)) { - *d++ = 'M'; - *d++ = '-'; - ch &= 127; - } - if (ch == '\n') { - *d++ = '\\'; - *d++ = 'n'; - } - else if (ch == '\r') { - *d++ = '\\'; - *d++ = 'r'; - } - else if (ch == '\f') { - *d++ = '\\'; - *d++ = 'f'; - } - else if (ch == '\\') { - *d++ = '\\'; - *d++ = '\\'; - } - else if (ch == '\0') { - *d++ = '\\'; - *d++ = '0'; - } - else if (isPRINT_LC(ch)) - *d++ = ch; - else { - *d++ = '^'; - *d++ = toCTRL(ch); - } - } - if (s < end) { - *d++ = '.'; - *d++ = '.'; - *d++ = '.'; - } - *d = '\0'; - pv = tmpbuf; - } - - if (PL_op) - Perl_warner(aTHX_ packWARN(WARN_NUMERIC), - "Argument \"%s\" isn't numeric in %s", pv, - OP_DESC(PL_op)); - else - Perl_warner(aTHX_ packWARN(WARN_NUMERIC), - "Argument \"%s\" isn't numeric", pv); -} - -/* -=for apidoc looks_like_number - -Test if the content of an SV looks like a number (or is a number). -C and C are treated as numbers (so will not issue a -non-numeric warning), even if your atof() doesn't grok them. - -=cut -*/ - -I32 -Perl_looks_like_number(pTHX_ SV *sv) -{ - register const char *sbegin; - STRLEN len; - - if (SvPOK(sv)) { - sbegin = SvPVX_const(sv); - len = SvCUR(sv); - } - else if (SvPOKp(sv)) - sbegin = SvPV_const(sv, len); - else - return SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK); - return grok_number(sbegin, len, NULL); -} - -/* Actually, ISO C leaves conversion of UV to IV undefined, but - until proven guilty, assume that things are not that bad... */ - -/* - NV_PRESERVES_UV: - - As 64 bit platforms often have an NV that doesn't preserve all bits of - an IV (an assumption perl has been based on to date) it becomes necessary - to remove the assumption that the NV always carries enough precision to - recreate the IV whenever needed, and that the NV is the canonical form. - Instead, IV/UV and NV need to be given equal rights. So as to not lose - precision as a side effect of conversion (which would lead to insanity - and the dragon(s) in t/op/numconvert.t getting very angry) the intent is - 1) to distinguish between IV/UV/NV slots that have cached a valid - conversion where precision was lost and IV/UV/NV slots that have a - valid conversion which has lost no precision - 2) to ensure that if a numeric conversion to one form is requested that - would lose precision, the precise conversion (or differently - imprecise conversion) is also performed and cached, to prevent - requests for different numeric formats on the same SV causing - lossy conversion chains. (lossless conversion chains are perfectly - acceptable (still)) - - - flags are used: - SvIOKp is true if the IV slot contains a valid value - SvIOK is true only if the IV value is accurate (UV if SvIOK_UV true) - SvNOKp is true if the NV slot contains a valid value - SvNOK is true only if the NV value is accurate - - so - while converting from PV to NV, check to see if converting that NV to an - IV(or UV) would lose accuracy over a direct conversion from PV to - IV(or UV). If it would, cache both conversions, return NV, but mark - SV as IOK NOKp (ie not NOK). - - While converting from PV to IV, check to see if converting that IV to an - NV would lose accuracy over a direct conversion from PV to NV. If it - would, cache both conversions, flag similarly. - - Before, the SV value "3.2" could become NV=3.2 IV=3 NOK, IOK quite - correctly because if IV & NV were set NV *always* overruled. - Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flag's meaning - changes - now IV and NV together means that the two are interchangeable: - SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX; - - The benefit of this is that operations such as pp_add know that if - SvIOK is true for both left and right operands, then integer addition - can be used instead of floating point (for cases where the result won't - overflow). Before, floating point was always used, which could lead to - loss of precision compared with integer addition. - - * making IV and NV equal status should make maths accurate on 64 bit - platforms - * may speed up maths somewhat if pp_add and friends start to use - integers when possible instead of fp. (Hopefully the overhead in - looking for SvIOK and checking for overflow will not outweigh the - fp to integer speedup) - * will slow down integer operations (callers of SvIV) on "inaccurate" - values, as the change from SvIOK to SvIOKp will cause a call into - sv_2iv each time rather than a macro access direct to the IV slot - * should speed up number->string conversion on integers as IV is - favoured when IV and NV are equally accurate - - #################################################################### - You had better be using SvIOK_notUV if you want an IV for arithmetic: - SvIOK is true if (IV or UV), so you might be getting (IV)SvUV. - On the other hand, SvUOK is true iff UV. - #################################################################### - - Your mileage will vary depending your CPU's relative fp to integer - performance ratio. -*/ - -#ifndef NV_PRESERVES_UV -# define IS_NUMBER_UNDERFLOW_IV 1 -# define IS_NUMBER_UNDERFLOW_UV 2 -# define IS_NUMBER_IV_AND_UV 2 -# define IS_NUMBER_OVERFLOW_IV 4 -# define IS_NUMBER_OVERFLOW_UV 5 - -/* sv_2iuv_non_preserve(): private routine for use by sv_2iv() and sv_2uv() */ - -/* For sv_2nv these three cases are "SvNOK and don't bother casting" */ -STATIC int -S_sv_2iuv_non_preserve(pTHX_ register SV *sv, I32 numtype) -{ - DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_2iuv_non '%s', IV=0x%"UVxf" NV=%"NVgf" inttype=%"UVXf"\n", SvPVX_const(sv), SvIVX(sv), SvNVX(sv), (UV)numtype)); - if (SvNVX(sv) < (NV)IV_MIN) { - (void)SvIOKp_on(sv); - (void)SvNOK_on(sv); - SvIV_set(sv, IV_MIN); - return IS_NUMBER_UNDERFLOW_IV; - } - if (SvNVX(sv) > (NV)UV_MAX) { - (void)SvIOKp_on(sv); - (void)SvNOK_on(sv); - SvIsUV_on(sv); - SvUV_set(sv, UV_MAX); - return IS_NUMBER_OVERFLOW_UV; - } - (void)SvIOKp_on(sv); - (void)SvNOK_on(sv); - /* Can't use strtol etc to convert this string. (See truth table in - sv_2iv */ - if (SvNVX(sv) <= (UV)IV_MAX) { - SvIV_set(sv, I_V(SvNVX(sv))); - if ((NV)(SvIVX(sv)) == SvNVX(sv)) { - SvIOK_on(sv); /* Integer is precise. NOK, IOK */ - } else { - /* Integer is imprecise. NOK, IOKp */ - } - return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV; - } - SvIsUV_on(sv); - SvUV_set(sv, U_V(SvNVX(sv))); - if ((NV)(SvUVX(sv)) == SvNVX(sv)) { - if (SvUVX(sv) == UV_MAX) { - /* As we know that NVs don't preserve UVs, UV_MAX cannot - possibly be preserved by NV. Hence, it must be overflow. - NOK, IOKp */ - return IS_NUMBER_OVERFLOW_UV; - } - SvIOK_on(sv); /* Integer is precise. NOK, UOK */ - } else { - /* Integer is imprecise. NOK, IOKp */ - } - return IS_NUMBER_OVERFLOW_IV; -} -#endif /* !NV_PRESERVES_UV*/ - -/* -=for apidoc sv_2iv_flags - -Return the integer value of an SV, doing any necessary string -conversion. If flags includes SV_GMAGIC, does an mg_get() first. -Normally used via the C and C macros. - -=cut -*/ - -IV -Perl_sv_2iv_flags(pTHX_ register SV *sv, I32 flags) +NV +Perl_sv_2nv(pTHX_ register SV *sv) { if (!sv) - return 0; + return 0.0; if (SvGMAGICAL(sv)) { - if (flags & SV_GMAGIC) - mg_get(sv); - if (SvIOKp(sv)) - return SvIVX(sv); - if (SvNOKp(sv)) { - return I_V(SvNVX(sv)); + mg_get(sv); + if (SvNOKp(sv)) + return SvNVX(sv); + if (SvPOKp(sv) && SvLEN(sv)) { + if (!SvIOKp(sv) && ckWARN(WARN_NUMERIC) && + !grok_number(SvPVX_const(sv), SvCUR(sv), NULL)) + not_a_number(sv); + return Atof(SvPVX_const(sv)); } - if (SvPOKp(sv) && SvLEN(sv)) - return asIV(sv); - if (!SvROK(sv)) { - if (!(SvFLAGS(sv) & SVs_PADTMP)) { - if (!PL_localizing && ckWARN(WARN_UNINITIALIZED)) - report_uninit(sv); - } - return 0; + if (SvIOKp(sv)) { + if (SvIsUV(sv)) + return (NV)SvUVX(sv); + else + return (NV)SvIVX(sv); } - } - if (SvTHINKFIRST(sv)) { + if (SvROK(sv)) { + goto return_rok; + } + assert(SvTYPE(sv) >= SVt_PVMG); + /* This falls through to the report_uninit near the end of the + function. */ + } else if (SvTHINKFIRST(sv)) { if (SvROK(sv)) { + return_rok: if (SvAMAGIC(sv)) { - SV * const tmpstr=AMG_CALLun(sv,numer); - if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) { - return SvIV(tmpstr); + SV *const tmpstr = AMG_CALLun(sv,numer); + if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) { + return SvNV(tmpstr); } } - return PTR2IV(SvRV(sv)); + return PTR2NV(SvRV(sv)); } if (SvIsCOW(sv)) { sv_force_normal_flags(sv, 0); @@ -2166,1431 +2074,760 @@ Perl_sv_2iv_flags(pTHX_ register SV *sv, I32 flags) if (SvREADONLY(sv) && !SvOK(sv)) { if (ckWARN(WARN_UNINITIALIZED)) report_uninit(sv); - return 0; + return 0.0; } } - if (SvIOKp(sv)) { - if (SvIsUV(sv)) { - return (IV)(SvUVX(sv)); - } - else { - return SvIVX(sv); - } + if (SvTYPE(sv) < SVt_NV) { + /* The logic to use SVt_PVNV if necessary is in sv_upgrade. */ + sv_upgrade(sv, SVt_NV); +#ifdef USE_LONG_DOUBLE + DEBUG_c({ + STORE_NUMERIC_LOCAL_SET_STANDARD(); + PerlIO_printf(Perl_debug_log, + "0x%"UVxf" num(%" PERL_PRIgldbl ")\n", + PTR2UV(sv), SvNVX(sv)); + RESTORE_NUMERIC_LOCAL(); + }); +#else + DEBUG_c({ + STORE_NUMERIC_LOCAL_SET_STANDARD(); + PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%"NVgf")\n", + PTR2UV(sv), SvNVX(sv)); + RESTORE_NUMERIC_LOCAL(); + }); +#endif } + else if (SvTYPE(sv) < SVt_PVNV) + sv_upgrade(sv, SVt_PVNV); if (SvNOKp(sv)) { - /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv - * without also getting a cached IV/UV from it at the same time - * (ie PV->NV conversion should detect loss of accuracy and cache - * IV or UV at same time to avoid this. NWC */ - - if (SvTYPE(sv) == SVt_NV) - sv_upgrade(sv, SVt_PVNV); - - (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */ - /* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost - certainly cast into the IV range at IV_MAX, whereas the correct - answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary - cases go to UV */ - if (SvNVX(sv) < (NV)IV_MAX + 0.5) { - SvIV_set(sv, I_V(SvNVX(sv))); - if (SvNVX(sv) == (NV) SvIVX(sv) -#ifndef NV_PRESERVES_UV - && (((UV)1 << NV_PRESERVES_UV_BITS) > - (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv))) - /* Don't flag it as "accurately an integer" if the number - came from a (by definition imprecise) NV operation, and - we're outside the range of NV integer precision */ -#endif - ) { - SvIOK_on(sv); /* Can this go wrong with rounding? NWC */ - DEBUG_c(PerlIO_printf(Perl_debug_log, - "0x%"UVxf" iv(%"NVgf" => %"IVdf") (precise)\n", - PTR2UV(sv), - SvNVX(sv), - SvIVX(sv))); - - } else { - /* IV not precise. No need to convert from PV, as NV - conversion would already have cached IV if it detected - that PV->IV would be better than PV->NV->IV - flags already correct - don't set public IOK. */ - DEBUG_c(PerlIO_printf(Perl_debug_log, - "0x%"UVxf" iv(%"NVgf" => %"IVdf") (imprecise)\n", - PTR2UV(sv), - SvNVX(sv), - SvIVX(sv))); - } - /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN, - but the cast (NV)IV_MIN rounds to a the value less (more - negative) than IV_MIN which happens to be equal to SvNVX ?? - Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and - NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and - (NV)UVX == NVX are both true, but the values differ. :-( - Hopefully for 2s complement IV_MIN is something like - 0x8000000000000000 which will be exact. NWC */ - } - else { - SvUV_set(sv, U_V(SvNVX(sv))); - if ( - (SvNVX(sv) == (NV) SvUVX(sv)) -#ifndef NV_PRESERVES_UV - /* Make sure it's not 0xFFFFFFFFFFFFFFFF */ - /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */ - && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv)) - /* Don't flag it as "accurately an integer" if the number - came from a (by definition imprecise) NV operation, and - we're outside the range of NV integer precision */ + return SvNVX(sv); + } + if (SvIOKp(sv)) { + SvNV_set(sv, SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv)); +#ifdef NV_PRESERVES_UV + SvNOK_on(sv); +#else + /* Only set the public NV OK flag if this NV preserves the IV */ + /* Check it's not 0xFFFFFFFFFFFFFFFF */ + if (SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv)))) + : (SvIVX(sv) == I_V(SvNVX(sv)))) + SvNOK_on(sv); + else + SvNOKp_on(sv); #endif - ) - SvIOK_on(sv); - SvIsUV_on(sv); - ret_iv_max: - DEBUG_c(PerlIO_printf(Perl_debug_log, - "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n", - PTR2UV(sv), - SvUVX(sv), - SvUVX(sv))); - return (IV)SvUVX(sv); - } } else if (SvPOKp(sv) && SvLEN(sv)) { UV value; const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value); - /* We want to avoid a possible problem when we cache an IV which - may be later translated to an NV, and the resulting NV is not - the same as the direct translation of the initial string - (eg 123.456 can shortcut to the IV 123 with atol(), but we must - be careful to ensure that the value with the .456 is around if the - NV value is requested in the future). - - This means that if we cache such an IV, we need to cache the - NV as well. Moreover, we trade speed for space, and do not - cache the NV if we are sure it's not needed. - */ - - /* SVt_PVNV is one higher than SVt_PVIV, hence this order */ - if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) - == IS_NUMBER_IN_UV) { - /* It's definitely an integer, only upgrade to PVIV */ - if (SvTYPE(sv) < SVt_PVIV) - sv_upgrade(sv, SVt_PVIV); - (void)SvIOK_on(sv); - } else if (SvTYPE(sv) < SVt_PVNV) - sv_upgrade(sv, SVt_PVNV); - - /* If NV preserves UV then we only use the UV value if we know that - we aren't going to call atof() below. If NVs don't preserve UVs - then the value returned may have more precision than atof() will - return, even though value isn't perfectly accurate. */ - if ((numtype & (IS_NUMBER_IN_UV + if (!SvIOKp(sv) && !numtype && ckWARN(WARN_NUMERIC)) + not_a_number(sv); #ifdef NV_PRESERVES_UV - | IS_NUMBER_NOT_INT -#endif - )) == IS_NUMBER_IN_UV) { - /* This won't turn off the public IOK flag if it was set above */ - (void)SvIOKp_on(sv); + if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) + == IS_NUMBER_IN_UV) { + /* It's definitely an integer */ + SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value); + } else + SvNV_set(sv, Atof(SvPVX_const(sv))); + SvNOK_on(sv); +#else + SvNV_set(sv, Atof(SvPVX_const(sv))); + /* Only set the public NV OK flag if this NV preserves the value in + the PV at least as well as an IV/UV would. + Not sure how to do this 100% reliably. */ + /* if that shift count is out of range then Configure's test is + wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS == + UV_BITS */ + if (((UV)1 << NV_PRESERVES_UV_BITS) > + U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) { + SvNOK_on(sv); /* Definitely small enough to preserve all bits */ + } else if (!(numtype & IS_NUMBER_IN_UV)) { + /* Can't use strtol etc to convert this string, so don't try. + sv_2iv and sv_2uv will use the NV to convert, not the PV. */ + SvNOK_on(sv); + } else { + /* value has been set. It may not be precise. */ + if ((numtype & IS_NUMBER_NEG) && (value > (UV)IV_MIN)) { + /* 2s complement assumption for (UV)IV_MIN */ + SvNOK_on(sv); /* Integer is too negative. */ + } else { + SvNOKp_on(sv); + SvIOKp_on(sv); - if (!(numtype & IS_NUMBER_NEG)) { - /* positive */; - if (value <= (UV)IV_MAX) { + if (numtype & IS_NUMBER_NEG) { + SvIV_set(sv, -(IV)value); + } else if (value <= (UV)IV_MAX) { SvIV_set(sv, (IV)value); } else { SvUV_set(sv, value); SvIsUV_on(sv); } - } else { - /* 2s complement assumption */ - if (value <= (UV)IV_MIN) { - SvIV_set(sv, -(IV)value); - } else { - /* Too negative for an IV. This is a double upgrade, but - I'm assuming it will be rare. */ - if (SvTYPE(sv) < SVt_PVNV) - sv_upgrade(sv, SVt_PVNV); - SvNOK_on(sv); - SvIOK_off(sv); - SvIOKp_on(sv); - SvNV_set(sv, -(NV)value); - SvIV_set(sv, IV_MIN); - } - } - } - /* For !NV_PRESERVES_UV and IS_NUMBER_IN_UV and IS_NUMBER_NOT_INT we - will be in the previous block to set the IV slot, and the next - block to set the NV slot. So no else here. */ - - if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) - != IS_NUMBER_IN_UV) { - /* It wasn't an (integer that doesn't overflow the UV). */ - SvNV_set(sv, Atof(SvPVX_const(sv))); - if (! numtype && ckWARN(WARN_NUMERIC)) - not_a_number(sv); + if (numtype & IS_NUMBER_NOT_INT) { + /* I believe that even if the original PV had decimals, + they are lost beyond the limit of the FP precision. + However, neither is canonical, so both only get p + flags. NWC, 2000/11/25 */ + /* Both already have p flags, so do nothing */ + } else { + const NV nv = SvNVX(sv); + if (SvNVX(sv) < (NV)IV_MAX + 0.5) { + if (SvIVX(sv) == I_V(nv)) { + SvNOK_on(sv); + } else { + /* It had no "." so it must be integer. */ + } + SvIOK_on(sv); + } else { + /* between IV_MAX and NV(UV_MAX). + Could be slightly > UV_MAX */ + + if (numtype & IS_NUMBER_NOT_INT) { + /* UV and NV both imprecise. */ + } else { + const UV nv_as_uv = U_V(nv); + if (value == nv_as_uv && SvUVX(sv) != UV_MAX) { + SvNOK_on(sv); + } + SvIOK_on(sv); + } + } + } + } + } +#endif /* NV_PRESERVES_UV */ + } + else { + if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED)) + report_uninit(sv); + assert (SvTYPE(sv) >= SVt_NV); + /* Typically the caller expects that sv_any is not NULL now. */ + /* XXX Ilya implies that this is a bug in callers that assume this + and ideally should be fixed. */ + return 0.0; + } #if defined(USE_LONG_DOUBLE) - DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" PERL_PRIgldbl ")\n", - PTR2UV(sv), SvNVX(sv))); + DEBUG_c({ + STORE_NUMERIC_LOCAL_SET_STANDARD(); + PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n", + PTR2UV(sv), SvNVX(sv)); + RESTORE_NUMERIC_LOCAL(); + }); #else - DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"NVgf")\n", - PTR2UV(sv), SvNVX(sv))); -#endif + DEBUG_c({ + STORE_NUMERIC_LOCAL_SET_STANDARD(); + PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%"NVgf")\n", + PTR2UV(sv), SvNVX(sv)); + RESTORE_NUMERIC_LOCAL(); + }); +#endif + return SvNVX(sv); +} +/* uiv_2buf(): private routine for use by sv_2pv_flags(): print an IV or + * UV as a string towards the end of buf, and return pointers to start and + * end of it. + * + * We assume that buf is at least TYPE_CHARS(UV) long. + */ -#ifdef NV_PRESERVES_UV - (void)SvIOKp_on(sv); - (void)SvNOK_on(sv); - if (SvNVX(sv) < (NV)IV_MAX + 0.5) { - SvIV_set(sv, I_V(SvNVX(sv))); - if ((NV)(SvIVX(sv)) == SvNVX(sv)) { - SvIOK_on(sv); - } else { - /* Integer is imprecise. NOK, IOKp */ - } - /* UV will not work better than IV */ - } else { - if (SvNVX(sv) > (NV)UV_MAX) { - SvIsUV_on(sv); - /* Integer is inaccurate. NOK, IOKp, is UV */ - SvUV_set(sv, UV_MAX); - SvIsUV_on(sv); - } else { - SvUV_set(sv, U_V(SvNVX(sv))); - /* 0xFFFFFFFFFFFFFFFF not an issue in here */ - if ((NV)(SvUVX(sv)) == SvNVX(sv)) { - SvIOK_on(sv); - SvIsUV_on(sv); - } else { - /* Integer is imprecise. NOK, IOKp, is UV */ - SvIsUV_on(sv); - } +static char * +S_uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob) +{ + char *ptr = buf + TYPE_CHARS(UV); + char * const ebuf = ptr; + int sign; + + if (is_uv) + sign = 0; + else if (iv >= 0) { + uv = iv; + sign = 0; + } else { + uv = -iv; + sign = 1; + } + do { + *--ptr = '0' + (char)(uv % 10); + } while (uv /= 10); + if (sign) + *--ptr = '-'; + *peob = ebuf; + return ptr; +} + +/* stringify_regexp(): private routine for use by sv_2pv_flags(): converts + * a regexp to its stringified form. + */ + +static char * +S_stringify_regexp(pTHX_ SV *sv, MAGIC *mg, STRLEN *lp) { + const regexp * const re = (regexp *)mg->mg_obj; + + if (!mg->mg_ptr) { + const char *fptr = "msix"; + char reflags[6]; + char ch; + int left = 0; + int right = 4; + bool need_newline = 0; + U16 reganch = (U16)((re->reganch & PMf_COMPILETIME) >> 12); + + while((ch = *fptr++)) { + if(reganch & 1) { + reflags[left++] = ch; + } + else { + reflags[right--] = ch; + } + reganch >>= 1; + } + if(left != 4) { + reflags[left] = '-'; + left = 5; + } + + mg->mg_len = re->prelen + 4 + left; + /* + * If /x was used, we have to worry about a regex ending with a + * comment later being embedded within another regex. If so, we don't + * want this regex's "commentization" to leak out to the right part of + * the enclosing regex, we must cap it with a newline. + * + * So, if /x was used, we scan backwards from the end of the regex. If + * we find a '#' before we find a newline, we need to add a newline + * ourself. If we find a '\n' first (or if we don't find '#' or '\n'), + * we don't need to add anything. -jfriedl + */ + if (PMf_EXTENDED & re->reganch) { + const char *endptr = re->precomp + re->prelen; + while (endptr >= re->precomp) { + const char c = *(endptr--); + if (c == '\n') + break; /* don't need another */ + if (c == '#') { + /* we end while in a comment, so we need a newline */ + mg->mg_len++; /* save space for it */ + need_newline = 1; /* note to add it */ + break; } - goto ret_iv_max; } -#else /* NV_PRESERVES_UV */ - if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) - == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) { - /* The IV slot will have been set from value returned by - grok_number above. The NV slot has just been set using - Atof. */ - SvNOK_on(sv); - assert (SvIOKp(sv)); - } else { - if (((UV)1 << NV_PRESERVES_UV_BITS) > - U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) { - /* Small enough to preserve all bits. */ - (void)SvIOKp_on(sv); - SvNOK_on(sv); - SvIV_set(sv, I_V(SvNVX(sv))); - if ((NV)(SvIVX(sv)) == SvNVX(sv)) - SvIOK_on(sv); - /* Assumption: first non-preserved integer is < IV_MAX, - this NV is in the preserved range, therefore: */ - if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv)) - < (UV)IV_MAX)) { - Perl_croak(aTHX_ "sv_2iv assumed (U_V(fabs((double)SvNVX(sv))) < (UV)IV_MAX) but SvNVX(sv)=%"NVgf" U_V is 0x%"UVxf", IV_MAX is 0x%"UVxf"\n", SvNVX(sv), U_V(SvNVX(sv)), (UV)IV_MAX); - } - } else { - /* IN_UV NOT_INT - 0 0 already failed to read UV. - 0 1 already failed to read UV. - 1 0 you won't get here in this case. IV/UV - slot set, public IOK, Atof() unneeded. - 1 1 already read UV. - so there's no point in sv_2iuv_non_preserve() attempting - to use atol, strtol, strtoul etc. */ - if (sv_2iuv_non_preserve (sv, numtype) - >= IS_NUMBER_OVERFLOW_IV) - goto ret_iv_max; - } - } -#endif /* NV_PRESERVES_UV */ } - } else { - if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED)) - report_uninit(sv); - if (SvTYPE(sv) < SVt_IV) - /* Typically the caller expects that sv_any is not NULL now. */ - sv_upgrade(sv, SVt_IV); - return 0; + + Newx(mg->mg_ptr, mg->mg_len + 1 + left, char); + mg->mg_ptr[0] = '('; + mg->mg_ptr[1] = '?'; + Copy(reflags, mg->mg_ptr+2, left, char); + *(mg->mg_ptr+left+2) = ':'; + Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char); + if (need_newline) + mg->mg_ptr[mg->mg_len - 2] = '\n'; + mg->mg_ptr[mg->mg_len - 1] = ')'; + mg->mg_ptr[mg->mg_len] = 0; } - DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n", - PTR2UV(sv),SvIVX(sv))); - return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv); + PL_reginterp_cnt += re->program[0].next_off; + + if (re->reganch & ROPT_UTF8) + SvUTF8_on(sv); + else + SvUTF8_off(sv); + if (lp) + *lp = mg->mg_len; + return mg->mg_ptr; } /* -=for apidoc sv_2uv_flags +=for apidoc sv_2pv_flags -Return the unsigned integer value of an SV, doing any necessary string -conversion. If flags includes SV_GMAGIC, does an mg_get() first. -Normally used via the C and C macros. +Returns a pointer to the string value of an SV, and sets *lp to its length. +If flags includes SV_GMAGIC, does an mg_get() first. Coerces sv to a string +if necessary. +Normally invoked via the C macro. C and C +usually end up here too. =cut */ -UV -Perl_sv_2uv_flags(pTHX_ register SV *sv, I32 flags) +char * +Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) { - if (!sv) - return 0; + register char *s; + int olderrno; + + if (!sv) { + if (lp) + *lp = 0; + return (char *)""; + } if (SvGMAGICAL(sv)) { if (flags & SV_GMAGIC) mg_get(sv); - if (SvIOKp(sv)) - return SvUVX(sv); - if (SvNOKp(sv)) - return U_V(SvNVX(sv)); - if (SvPOKp(sv) && SvLEN(sv)) - return asUV(sv); - if (!SvROK(sv)) { - if (!(SvFLAGS(sv) & SVs_PADTMP)) { - if (!PL_localizing && ckWARN(WARN_UNINITIALIZED)) - report_uninit(sv); + if (SvPOKp(sv)) { + if (lp) + *lp = SvCUR(sv); + if (flags & SV_MUTABLE_RETURN) + return SvPVX_mutable(sv); + if (flags & SV_CONST_RETURN) + return (char *)SvPVX_const(sv); + return SvPVX(sv); + } + if (SvIOKp(sv) || SvNOKp(sv)) { + char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */ + STRLEN len; + + if (SvIOKp(sv)) { + len = SvIsUV(sv) ? my_sprintf(tbuf,"%"UVuf, (UV)SvUVX(sv)) + : my_sprintf(tbuf,"%"IVdf, (IV)SvIVX(sv)); + } else { + Gconvert(SvNVX(sv), NV_DIG, 0, tbuf); + len = strlen(tbuf); + } + if (SvROK(sv)) { /* XXX Skip this when sv_pvn_force calls */ + /* Sneaky stuff here */ + SV * const tsv = newSVpvn(tbuf, len); + + sv_2mortal(tsv); + if (lp) + *lp = SvCUR(tsv); + return SvPVX(tsv); + } + else { + dVAR; + +#ifdef FIXNEGATIVEZERO + if (len == 2 && tbuf[0] == '-' && tbuf[1] == '0') { + tbuf[0] = '0'; + tbuf[1] = 0; + len = 1; + } +#endif + SvUPGRADE(sv, SVt_PV); + if (lp) + *lp = len; + s = SvGROW_mutable(sv, len + 1); + SvCUR_set(sv, len); + SvPOKp_on(sv); + return memcpy(s, tbuf, len + 1); } - return 0; } - } - if (SvTHINKFIRST(sv)) { - if (SvROK(sv)) { - SV* tmpstr; - if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) && - (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) - return SvUV(tmpstr); - return PTR2UV(SvRV(sv)); + if (SvROK(sv)) { + goto return_rok; } - if (SvIsCOW(sv)) { - sv_force_normal_flags(sv, 0); + assert(SvTYPE(sv) >= SVt_PVMG); + /* This falls through to the report_uninit near the end of the + function. */ + } else if (SvTHINKFIRST(sv)) { + if (SvROK(sv)) { + return_rok: + if (SvAMAGIC(sv)) { + SV *const tmpstr = AMG_CALLun(sv,string); + if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) { + /* Unwrap this: */ + /* char *pv = lp ? SvPV(tmpstr, *lp) : SvPV_nolen(tmpstr); + */ + + char *pv; + if ((SvFLAGS(tmpstr) & (SVf_POK)) == SVf_POK) { + if (flags & SV_CONST_RETURN) { + pv = (char *) SvPVX_const(tmpstr); + } else { + pv = (flags & SV_MUTABLE_RETURN) + ? SvPVX_mutable(tmpstr) : SvPVX(tmpstr); + } + if (lp) + *lp = SvCUR(tmpstr); + } else { + pv = sv_2pv_flags(tmpstr, lp, flags); + } + if (SvUTF8(tmpstr)) + SvUTF8_on(sv); + else + SvUTF8_off(sv); + return pv; + } + } + { + SV *tsv; + MAGIC *mg; + const SV *const referent = (SV*)SvRV(sv); + + if (!referent) { + tsv = sv_2mortal(newSVpvn("NULLREF", 7)); + } else if (SvTYPE(referent) == SVt_PVMG + && ((SvFLAGS(referent) & + (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG)) + == (SVs_OBJECT|SVs_SMG)) + && (mg = mg_find(referent, PERL_MAGIC_qr))) { + return S_stringify_regexp(aTHX_ sv, mg, lp); + } else { + const char *const typestr = sv_reftype(referent, 0); + + tsv = sv_newmortal(); + if (SvOBJECT(referent)) { + const char *const name = HvNAME_get(SvSTASH(referent)); + Perl_sv_setpvf(aTHX_ tsv, "%s=%s(0x%"UVxf")", + name ? name : "__ANON__" , typestr, + PTR2UV(referent)); + } + else + Perl_sv_setpvf(aTHX_ tsv, "%s(0x%"UVxf")", typestr, + PTR2UV(referent)); + } + if (lp) + *lp = SvCUR(tsv); + return SvPVX(tsv); + } } if (SvREADONLY(sv) && !SvOK(sv)) { if (ckWARN(WARN_UNINITIALIZED)) report_uninit(sv); - return 0; - } - } - if (SvIOKp(sv)) { - if (SvIsUV(sv)) { - return SvUVX(sv); - } - else { - return (UV)SvIVX(sv); + if (lp) + *lp = 0; + return (char *)""; } } - if (SvNOKp(sv)) { - /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv - * without also getting a cached IV/UV from it at the same time - * (ie PV->NV conversion should detect loss of accuracy and cache - * IV or UV at same time to avoid this. */ - /* IV-over-UV optimisation - choose to cache IV if possible */ + if (SvIOK(sv) || ((SvIOKp(sv) && !SvNOKp(sv)))) { + /* I'm assuming that if both IV and NV are equally valid then + converting the IV is going to be more efficient */ + const U32 isIOK = SvIOK(sv); + const U32 isUIOK = SvIsUV(sv); + char buf[TYPE_CHARS(UV)]; + char *ebuf, *ptr; - if (SvTYPE(sv) == SVt_NV) + if (SvTYPE(sv) < SVt_PVIV) + sv_upgrade(sv, SVt_PVIV); + if (isUIOK) + ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf); + else + ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf); + /* inlined from sv_setpvn */ + SvGROW_mutable(sv, (STRLEN)(ebuf - ptr + 1)); + Move(ptr,SvPVX_mutable(sv),ebuf - ptr,char); + SvCUR_set(sv, ebuf - ptr); + s = SvEND(sv); + *s = '\0'; + if (isIOK) + SvIOK_on(sv); + else + SvIOKp_on(sv); + if (isUIOK) + SvIsUV_on(sv); + } + else if (SvNOKp(sv)) { + if (SvTYPE(sv) < SVt_PVNV) sv_upgrade(sv, SVt_PVNV); - - (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */ - if (SvNVX(sv) < (NV)IV_MAX + 0.5) { - SvIV_set(sv, I_V(SvNVX(sv))); - if (SvNVX(sv) == (NV) SvIVX(sv) -#ifndef NV_PRESERVES_UV - && (((UV)1 << NV_PRESERVES_UV_BITS) > - (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv))) - /* Don't flag it as "accurately an integer" if the number - came from a (by definition imprecise) NV operation, and - we're outside the range of NV integer precision */ + /* The +20 is pure guesswork. Configure test needed. --jhi */ + s = SvGROW_mutable(sv, NV_DIG + 20); + olderrno = errno; /* some Xenix systems wipe out errno here */ +#ifdef apollo + if (SvNVX(sv) == 0.0) + (void)strcpy(s,"0"); + else +#endif /*apollo*/ + { + Gconvert(SvNVX(sv), NV_DIG, 0, s); + } + errno = olderrno; +#ifdef FIXNEGATIVEZERO + if (*s == '-' && s[1] == '0' && !s[2]) + strcpy(s,"0"); #endif - ) { - SvIOK_on(sv); /* Can this go wrong with rounding? NWC */ - DEBUG_c(PerlIO_printf(Perl_debug_log, - "0x%"UVxf" uv(%"NVgf" => %"IVdf") (precise)\n", - PTR2UV(sv), - SvNVX(sv), - SvIVX(sv))); - - } else { - /* IV not precise. No need to convert from PV, as NV - conversion would already have cached IV if it detected - that PV->IV would be better than PV->NV->IV - flags already correct - don't set public IOK. */ - DEBUG_c(PerlIO_printf(Perl_debug_log, - "0x%"UVxf" uv(%"NVgf" => %"IVdf") (imprecise)\n", - PTR2UV(sv), - SvNVX(sv), - SvIVX(sv))); - } - /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN, - but the cast (NV)IV_MIN rounds to a the value less (more - negative) than IV_MIN which happens to be equal to SvNVX ?? - Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and - NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and - (NV)UVX == NVX are both true, but the values differ. :-( - Hopefully for 2s complement IV_MIN is something like - 0x8000000000000000 which will be exact. NWC */ - } - else { - SvUV_set(sv, U_V(SvNVX(sv))); - if ( - (SvNVX(sv) == (NV) SvUVX(sv)) -#ifndef NV_PRESERVES_UV - /* Make sure it's not 0xFFFFFFFFFFFFFFFF */ - /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */ - && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv)) - /* Don't flag it as "accurately an integer" if the number - came from a (by definition imprecise) NV operation, and - we're outside the range of NV integer precision */ + while (*s) s++; +#ifdef hcx + if (s[-1] == '.') + *--s = '\0'; #endif - ) - SvIOK_on(sv); - SvIsUV_on(sv); - DEBUG_c(PerlIO_printf(Perl_debug_log, - "0x%"UVxf" 2uv(%"UVuf" => %"IVdf") (as unsigned)\n", - PTR2UV(sv), - SvUVX(sv), - SvUVX(sv))); - } } - else if (SvPOKp(sv) && SvLEN(sv)) { - UV value; - const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value); + else { + if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED)) + report_uninit(sv); + if (lp) + *lp = 0; + if (SvTYPE(sv) < SVt_PV) + /* Typically the caller expects that sv_any is not NULL now. */ + sv_upgrade(sv, SVt_PV); + return (char *)""; + } + { + const STRLEN len = s - SvPVX_const(sv); + if (lp) + *lp = len; + SvCUR_set(sv, len); + } + SvPOK_on(sv); + DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n", + PTR2UV(sv),SvPVX_const(sv))); + if (flags & SV_CONST_RETURN) + return (char *)SvPVX_const(sv); + if (flags & SV_MUTABLE_RETURN) + return SvPVX_mutable(sv); + return SvPVX(sv); +} - /* We want to avoid a possible problem when we cache a UV which - may be later translated to an NV, and the resulting NV is not - the translation of the initial data. - - This means that if we cache such a UV, we need to cache the - NV as well. Moreover, we trade speed for space, and do not - cache the NV if not needed. - */ +/* +=for apidoc sv_copypv - /* SVt_PVNV is one higher than SVt_PVIV, hence this order */ - if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) - == IS_NUMBER_IN_UV) { - /* It's definitely an integer, only upgrade to PVIV */ - if (SvTYPE(sv) < SVt_PVIV) - sv_upgrade(sv, SVt_PVIV); - (void)SvIOK_on(sv); - } else if (SvTYPE(sv) < SVt_PVNV) - sv_upgrade(sv, SVt_PVNV); +Copies a stringified representation of the source SV into the +destination SV. Automatically performs any necessary mg_get and +coercion of numeric values into strings. Guaranteed to preserve +UTF-8 flag even from overloaded objects. Similar in nature to +sv_2pv[_flags] but operates directly on an SV instead of just the +string. Mostly uses sv_2pv_flags to do its work, except when that +would lose the UTF-8'ness of the PV. - /* If NV preserves UV then we only use the UV value if we know that - we aren't going to call atof() below. If NVs don't preserve UVs - then the value returned may have more precision than atof() will - return, even though it isn't accurate. */ - if ((numtype & (IS_NUMBER_IN_UV -#ifdef NV_PRESERVES_UV - | IS_NUMBER_NOT_INT -#endif - )) == IS_NUMBER_IN_UV) { - /* This won't turn off the public IOK flag if it was set above */ - (void)SvIOKp_on(sv); +=cut +*/ - if (!(numtype & IS_NUMBER_NEG)) { - /* positive */; - if (value <= (UV)IV_MAX) { - SvIV_set(sv, (IV)value); - } else { - /* it didn't overflow, and it was positive. */ - SvUV_set(sv, value); - SvIsUV_on(sv); - } - } else { - /* 2s complement assumption */ - if (value <= (UV)IV_MIN) { - SvIV_set(sv, -(IV)value); - } else { - /* Too negative for an IV. This is a double upgrade, but - I'm assuming it will be rare. */ - if (SvTYPE(sv) < SVt_PVNV) - sv_upgrade(sv, SVt_PVNV); - SvNOK_on(sv); - SvIOK_off(sv); - SvIOKp_on(sv); - SvNV_set(sv, -(NV)value); - SvIV_set(sv, IV_MIN); - } - } - } - - if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) - != IS_NUMBER_IN_UV) { - /* It wasn't an integer, or it overflowed the UV. */ - SvNV_set(sv, Atof(SvPVX_const(sv))); +void +Perl_sv_copypv(pTHX_ SV *dsv, register SV *ssv) +{ + STRLEN len; + const char * const s = SvPV_const(ssv,len); + sv_setpvn(dsv,s,len); + if (SvUTF8(ssv)) + SvUTF8_on(dsv); + else + SvUTF8_off(dsv); +} - if (! numtype && ckWARN(WARN_NUMERIC)) - not_a_number(sv); +/* +=for apidoc sv_2pvbyte -#if defined(USE_LONG_DOUBLE) - DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%" PERL_PRIgldbl ")\n", - PTR2UV(sv), SvNVX(sv))); -#else - DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"NVgf")\n", - PTR2UV(sv), SvNVX(sv))); -#endif +Return a pointer to the byte-encoded representation of the SV, and set *lp +to its length. May cause the SV to be downgraded from UTF-8 as a +side-effect. -#ifdef NV_PRESERVES_UV - (void)SvIOKp_on(sv); - (void)SvNOK_on(sv); - if (SvNVX(sv) < (NV)IV_MAX + 0.5) { - SvIV_set(sv, I_V(SvNVX(sv))); - if ((NV)(SvIVX(sv)) == SvNVX(sv)) { - SvIOK_on(sv); - } else { - /* Integer is imprecise. NOK, IOKp */ - } - /* UV will not work better than IV */ - } else { - if (SvNVX(sv) > (NV)UV_MAX) { - SvIsUV_on(sv); - /* Integer is inaccurate. NOK, IOKp, is UV */ - SvUV_set(sv, UV_MAX); - SvIsUV_on(sv); - } else { - SvUV_set(sv, U_V(SvNVX(sv))); - /* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs - NV preservse UV so can do correct comparison. */ - if ((NV)(SvUVX(sv)) == SvNVX(sv)) { - SvIOK_on(sv); - SvIsUV_on(sv); - } else { - /* Integer is imprecise. NOK, IOKp, is UV */ - SvIsUV_on(sv); - } - } - } -#else /* NV_PRESERVES_UV */ - if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) - == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) { - /* The UV slot will have been set from value returned by - grok_number above. The NV slot has just been set using - Atof. */ - SvNOK_on(sv); - assert (SvIOKp(sv)); - } else { - if (((UV)1 << NV_PRESERVES_UV_BITS) > - U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) { - /* Small enough to preserve all bits. */ - (void)SvIOKp_on(sv); - SvNOK_on(sv); - SvIV_set(sv, I_V(SvNVX(sv))); - if ((NV)(SvIVX(sv)) == SvNVX(sv)) - SvIOK_on(sv); - /* Assumption: first non-preserved integer is < IV_MAX, - this NV is in the preserved range, therefore: */ - if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv)) - < (UV)IV_MAX)) { - Perl_croak(aTHX_ "sv_2uv assumed (U_V(fabs((double)SvNVX(sv))) < (UV)IV_MAX) but SvNVX(sv)=%"NVgf" U_V is 0x%"UVxf", IV_MAX is 0x%"UVxf"\n", SvNVX(sv), U_V(SvNVX(sv)), (UV)IV_MAX); - } - } else - sv_2iuv_non_preserve (sv, numtype); - } -#endif /* NV_PRESERVES_UV */ - } - } - else { - if (!(SvFLAGS(sv) & SVs_PADTMP)) { - if (!PL_localizing && ckWARN(WARN_UNINITIALIZED)) - report_uninit(sv); - } - if (SvTYPE(sv) < SVt_IV) - /* Typically the caller expects that sv_any is not NULL now. */ - sv_upgrade(sv, SVt_IV); - return 0; - } +Usually accessed via the C macro. - DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n", - PTR2UV(sv),SvUVX(sv))); - return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv); +=cut +*/ + +char * +Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp) +{ + sv_utf8_downgrade(sv,0); + return lp ? SvPV(sv,*lp) : SvPV_nolen(sv); } /* -=for apidoc sv_2nv +=for apidoc sv_2pvutf8 -Return the num value of an SV, doing any necessary string or integer -conversion, magic etc. Normally used via the C and C -macros. +Return a pointer to the UTF-8-encoded representation of the SV, and set *lp +to its length. May cause the SV to be upgraded to UTF-8 as a side-effect. + +Usually accessed via the C macro. =cut */ -NV -Perl_sv_2nv(pTHX_ register SV *sv) +char * +Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp) { - if (!sv) - return 0.0; - if (SvGMAGICAL(sv)) { - mg_get(sv); - if (SvNOKp(sv)) - return SvNVX(sv); - if (SvPOKp(sv) && SvLEN(sv)) { - if (!SvIOKp(sv) && ckWARN(WARN_NUMERIC) && - !grok_number(SvPVX_const(sv), SvCUR(sv), NULL)) - not_a_number(sv); - return Atof(SvPVX_const(sv)); - } - if (SvIOKp(sv)) { - if (SvIsUV(sv)) - return (NV)SvUVX(sv); - else - return (NV)SvIVX(sv); - } - if (!SvROK(sv)) { - if (!(SvFLAGS(sv) & SVs_PADTMP)) { - if (!PL_localizing && ckWARN(WARN_UNINITIALIZED)) - report_uninit(sv); - } - return (NV)0; - } - } - if (SvTHINKFIRST(sv)) { - if (SvROK(sv)) { - SV* tmpstr; - if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) && - (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) - return SvNV(tmpstr); - return PTR2NV(SvRV(sv)); - } - if (SvIsCOW(sv)) { - sv_force_normal_flags(sv, 0); - } - if (SvREADONLY(sv) && !SvOK(sv)) { - if (ckWARN(WARN_UNINITIALIZED)) - report_uninit(sv); - return 0.0; - } + sv_utf8_upgrade(sv); + return lp ? SvPV(sv,*lp) : SvPV_nolen(sv); +} + + +/* +=for apidoc sv_2bool + +This function is only called on magical items, and is only used by +sv_true() or its macro equivalent. + +=cut +*/ + +bool +Perl_sv_2bool(pTHX_ register SV *sv) +{ + SvGETMAGIC(sv); + + if (!SvOK(sv)) + return 0; + if (SvROK(sv)) { + SV* tmpsv; + if (SvAMAGIC(sv) && (tmpsv=AMG_CALLun(sv,bool_)) && + (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv)))) + return (bool)SvTRUE(tmpsv); + return SvRV(sv) != 0; } - if (SvTYPE(sv) < SVt_NV) { - if (SvTYPE(sv) == SVt_IV) - sv_upgrade(sv, SVt_PVNV); + if (SvPOKp(sv)) { + register XPV* const Xpvtmp = (XPV*)SvANY(sv); + if (Xpvtmp && + (*sv->sv_u.svu_pv > '0' || + Xpvtmp->xpv_cur > 1 || + (Xpvtmp->xpv_cur && *sv->sv_u.svu_pv != '0'))) + return 1; else - sv_upgrade(sv, SVt_NV); -#ifdef USE_LONG_DOUBLE - DEBUG_c({ - STORE_NUMERIC_LOCAL_SET_STANDARD(); - PerlIO_printf(Perl_debug_log, - "0x%"UVxf" num(%" PERL_PRIgldbl ")\n", - PTR2UV(sv), SvNVX(sv)); - RESTORE_NUMERIC_LOCAL(); - }); -#else - DEBUG_c({ - STORE_NUMERIC_LOCAL_SET_STANDARD(); - PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%"NVgf")\n", - PTR2UV(sv), SvNVX(sv)); - RESTORE_NUMERIC_LOCAL(); - }); -#endif - } - else if (SvTYPE(sv) < SVt_PVNV) - sv_upgrade(sv, SVt_PVNV); - if (SvNOKp(sv)) { - return SvNVX(sv); + return 0; } - if (SvIOKp(sv)) { - SvNV_set(sv, SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv)); -#ifdef NV_PRESERVES_UV - SvNOK_on(sv); -#else - /* Only set the public NV OK flag if this NV preserves the IV */ - /* Check it's not 0xFFFFFFFFFFFFFFFF */ - if (SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv)))) - : (SvIVX(sv) == I_V(SvNVX(sv)))) - SvNOK_on(sv); - else - SvNOKp_on(sv); -#endif + else { + if (SvIOKp(sv)) + return SvIVX(sv) != 0; + else { + if (SvNOKp(sv)) + return SvNVX(sv) != 0.0; + else + return FALSE; + } } - else if (SvPOKp(sv) && SvLEN(sv)) { - UV value; - const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value); - if (!SvIOKp(sv) && !numtype && ckWARN(WARN_NUMERIC)) - not_a_number(sv); -#ifdef NV_PRESERVES_UV - if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) - == IS_NUMBER_IN_UV) { - /* It's definitely an integer */ - SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value); - } else - SvNV_set(sv, Atof(SvPVX_const(sv))); - SvNOK_on(sv); -#else - SvNV_set(sv, Atof(SvPVX_const(sv))); - /* Only set the public NV OK flag if this NV preserves the value in - the PV at least as well as an IV/UV would. - Not sure how to do this 100% reliably. */ - /* if that shift count is out of range then Configure's test is - wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS == - UV_BITS */ - if (((UV)1 << NV_PRESERVES_UV_BITS) > - U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) { - SvNOK_on(sv); /* Definitely small enough to preserve all bits */ - } else if (!(numtype & IS_NUMBER_IN_UV)) { - /* Can't use strtol etc to convert this string, so don't try. - sv_2iv and sv_2uv will use the NV to convert, not the PV. */ - SvNOK_on(sv); - } else { - /* value has been set. It may not be precise. */ - if ((numtype & IS_NUMBER_NEG) && (value > (UV)IV_MIN)) { - /* 2s complement assumption for (UV)IV_MIN */ - SvNOK_on(sv); /* Integer is too negative. */ - } else { - SvNOKp_on(sv); - SvIOKp_on(sv); +} - if (numtype & IS_NUMBER_NEG) { - SvIV_set(sv, -(IV)value); - } else if (value <= (UV)IV_MAX) { - SvIV_set(sv, (IV)value); - } else { - SvUV_set(sv, value); - SvIsUV_on(sv); - } +/* +=for apidoc sv_utf8_upgrade - if (numtype & IS_NUMBER_NOT_INT) { - /* I believe that even if the original PV had decimals, - they are lost beyond the limit of the FP precision. - However, neither is canonical, so both only get p - flags. NWC, 2000/11/25 */ - /* Both already have p flags, so do nothing */ - } else { - const NV nv = SvNVX(sv); - if (SvNVX(sv) < (NV)IV_MAX + 0.5) { - if (SvIVX(sv) == I_V(nv)) { - SvNOK_on(sv); - SvIOK_on(sv); - } else { - SvIOK_on(sv); - /* It had no "." so it must be integer. */ - } - } else { - /* between IV_MAX and NV(UV_MAX). - Could be slightly > UV_MAX */ +Converts the PV of an SV to its UTF-8-encoded form. +Forces the SV to string form if it is not already. +Always sets the SvUTF8 flag to avoid future validity checks even +if all the bytes have hibit clear. - if (numtype & IS_NUMBER_NOT_INT) { - /* UV and NV both imprecise. */ - } else { - const UV nv_as_uv = U_V(nv); +This is not as a general purpose byte encoding to Unicode interface: +use the Encode extension for that. - if (value == nv_as_uv && SvUVX(sv) != UV_MAX) { - SvNOK_on(sv); - SvIOK_on(sv); - } else { - SvIOK_on(sv); - } - } - } - } - } - } -#endif /* NV_PRESERVES_UV */ - } - else { - if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED)) - report_uninit(sv); - if (SvTYPE(sv) < SVt_NV) - /* Typically the caller expects that sv_any is not NULL now. */ - /* XXX Ilya implies that this is a bug in callers that assume this - and ideally should be fixed. */ - sv_upgrade(sv, SVt_NV); - return 0.0; - } -#if defined(USE_LONG_DOUBLE) - DEBUG_c({ - STORE_NUMERIC_LOCAL_SET_STANDARD(); - PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n", - PTR2UV(sv), SvNVX(sv)); - RESTORE_NUMERIC_LOCAL(); - }); -#else - DEBUG_c({ - STORE_NUMERIC_LOCAL_SET_STANDARD(); - PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%"NVgf")\n", - PTR2UV(sv), SvNVX(sv)); - RESTORE_NUMERIC_LOCAL(); - }); -#endif - return SvNVX(sv); -} +=for apidoc sv_utf8_upgrade_flags -/* asIV(): extract an integer from the string value of an SV. - * Caller must validate PVX */ +Converts the PV of an SV to its UTF-8-encoded form. +Forces the SV to string form if it is not already. +Always sets the SvUTF8 flag to avoid future validity checks even +if all the bytes have hibit clear. If C has C bit set, +will C on C if appropriate, else not. C and +C are implemented in terms of this function. -STATIC IV -S_asIV(pTHX_ SV *sv) -{ - UV value; - const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value); +This is not as a general purpose byte encoding to Unicode interface: +use the Encode extension for that. + +=cut +*/ - if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) - == IS_NUMBER_IN_UV) { - /* It's definitely an integer */ - if (numtype & IS_NUMBER_NEG) { - if (value < (UV)IV_MIN) - return -(IV)value; +STRLEN +Perl_sv_utf8_upgrade_flags(pTHX_ register SV *sv, I32 flags) +{ + if (sv == &PL_sv_undef) + return 0; + if (!SvPOK(sv)) { + STRLEN len = 0; + if (SvREADONLY(sv) && (SvPOKp(sv) || SvIOKp(sv) || SvNOKp(sv))) { + (void) sv_2pv_flags(sv,&len, flags); + if (SvUTF8(sv)) + return len; } else { - if (value < (UV)IV_MAX) - return (IV)value; + (void) SvPV_force(sv,len); } } - if (!numtype) { - if (ckWARN(WARN_NUMERIC)) - not_a_number(sv); - } - return I_V(Atof(SvPVX_const(sv))); -} -/* asUV(): extract an unsigned integer from the string value of an SV - * Caller must validate PVX */ - -STATIC UV -S_asUV(pTHX_ SV *sv) -{ - UV value; - const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value); - - if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) - == IS_NUMBER_IN_UV) { - /* It's definitely an integer */ - if (!(numtype & IS_NUMBER_NEG)) - return value; - } - if (!numtype) { - if (ckWARN(WARN_NUMERIC)) - not_a_number(sv); + if (SvUTF8(sv)) { + return SvCUR(sv); } - return U_V(Atof(SvPVX_const(sv))); -} -/* uiv_2buf(): private routine for use by sv_2pv_flags(): print an IV or - * UV as a string towards the end of buf, and return pointers to start and - * end of it. - * - * We assume that buf is at least TYPE_CHARS(UV) long. - */ + if (SvIsCOW(sv)) { + sv_force_normal_flags(sv, 0); + } -static char * -S_uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob) -{ - char *ptr = buf + TYPE_CHARS(UV); - char * const ebuf = ptr; - int sign; - - if (is_uv) - sign = 0; - else if (iv >= 0) { - uv = iv; - sign = 0; - } else { - uv = -iv; - sign = 1; + if (PL_encoding && !(flags & SV_UTF8_NO_ENCODING)) + sv_recode_to_utf8(sv, PL_encoding); + else { /* Assume Latin-1/EBCDIC */ + /* This function could be much more efficient if we + * had a FLAG in SVs to signal if there are any hibit + * chars in the PV. Given that there isn't such a flag + * make the loop as fast as possible. */ + const U8 * const s = (U8 *) SvPVX_const(sv); + const U8 * const e = (U8 *) SvEND(sv); + const U8 *t = s; + + while (t < e) { + const U8 ch = *t++; + /* Check for hi bit */ + if (!NATIVE_IS_INVARIANT(ch)) { + STRLEN len = SvCUR(sv) + 1; /* Plus the \0 */ + U8 * const recoded = bytes_to_utf8((U8*)s, &len); + + SvPV_free(sv); /* No longer using what was there before. */ + SvPV_set(sv, (char*)recoded); + SvCUR_set(sv, len - 1); + SvLEN_set(sv, len); /* No longer know the real size. */ + break; + } + } + /* Mark as UTF-8 even if no hibit - saves scanning loop */ + SvUTF8_on(sv); } - do { - *--ptr = '0' + (char)(uv % 10); - } while (uv /= 10); - if (sign) - *--ptr = '-'; - *peob = ebuf; - return ptr; + return SvCUR(sv); } /* -=for apidoc sv_2pv_flags +=for apidoc sv_utf8_downgrade -Returns a pointer to the string value of an SV, and sets *lp to its length. -If flags includes SV_GMAGIC, does an mg_get() first. Coerces sv to a string -if necessary. -Normally invoked via the C macro. C and C -usually end up here too. +Attempts to convert the PV of an SV from characters to bytes. +If the PV contains a character beyond byte, this conversion will fail; +in this case, either returns false or, if C is not +true, croaks. + +This is not as a general purpose Unicode to byte encoding interface: +use the Encode extension for that. =cut */ -char * -Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) +bool +Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok) { - register char *s; - int olderrno; - SV *tsv, *origsv; - char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */ - char *tmpbuf = tbuf; - STRLEN len = 0; /* Hush gcc. len is always initialised before use. */ + if (SvPOKp(sv) && SvUTF8(sv)) { + if (SvCUR(sv)) { + U8 *s; + STRLEN len; - if (!sv) { - if (lp) - *lp = 0; - return (char *)""; - } - if (SvGMAGICAL(sv)) { - if (flags & SV_GMAGIC) - mg_get(sv); - if (SvPOKp(sv)) { - if (lp) - *lp = SvCUR(sv); - if (flags & SV_MUTABLE_RETURN) - return SvPVX_mutable(sv); - if (flags & SV_CONST_RETURN) - return (char *)SvPVX_const(sv); - return SvPVX(sv); - } - if (SvIOKp(sv)) { - len = SvIsUV(sv) ? my_sprintf(tmpbuf,"%"UVuf, (UV)SvUVX(sv)) - : my_sprintf(tmpbuf,"%"IVdf, (IV)SvIVX(sv)); - tsv = Nullsv; - goto tokensave_has_len; - } - if (SvNOKp(sv)) { - Gconvert(SvNVX(sv), NV_DIG, 0, tmpbuf); - tsv = Nullsv; - goto tokensave; - } - if (!SvROK(sv)) { - if (!(SvFLAGS(sv) & SVs_PADTMP)) { - if (!PL_localizing && ckWARN(WARN_UNINITIALIZED)) - report_uninit(sv); - } - if (lp) - *lp = 0; - return (char *)""; - } - } - if (SvTHINKFIRST(sv)) { - if (SvROK(sv)) { - SV* tmpstr; - register const char *typestr; - if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)) && - (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) { - /* Unwrap this: */ - /* char *pv = lp ? SvPV(tmpstr, *lp) : SvPV_nolen(tmpstr); */ - - char *pv; - if ((SvFLAGS(tmpstr) & (SVf_POK)) == SVf_POK) { - if (flags & SV_CONST_RETURN) { - pv = (char *) SvPVX_const(tmpstr); - } else { - pv = (flags & SV_MUTABLE_RETURN) - ? SvPVX_mutable(tmpstr) : SvPVX(tmpstr); - } - if (lp) - *lp = SvCUR(tmpstr); - } else { - pv = sv_2pv_flags(tmpstr, lp, flags); - } - if (SvUTF8(tmpstr)) - SvUTF8_on(sv); - else - SvUTF8_off(sv); - return pv; + if (SvIsCOW(sv)) { + sv_force_normal_flags(sv, 0); } - origsv = sv; - sv = (SV*)SvRV(sv); - if (!sv) - typestr = "NULLREF"; - else { - MAGIC *mg; - - switch (SvTYPE(sv)) { - case SVt_PVMG: - if ( ((SvFLAGS(sv) & - (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG)) - == (SVs_OBJECT|SVs_SMG)) - && (mg = mg_find(sv, PERL_MAGIC_qr))) { - const regexp *re = (regexp *)mg->mg_obj; - - if (!mg->mg_ptr) { - const char *fptr = "msix"; - char reflags[6]; - char ch; - int left = 0; - int right = 4; - char need_newline = 0; - U16 reganch = (U16)((re->reganch & PMf_COMPILETIME) >> 12); - - while((ch = *fptr++)) { - if(reganch & 1) { - reflags[left++] = ch; - } - else { - reflags[right--] = ch; - } - reganch >>= 1; - } - if(left != 4) { - reflags[left] = '-'; - left = 5; - } - - mg->mg_len = re->prelen + 4 + left; - /* - * If /x was used, we have to worry about a regex - * ending with a comment later being embedded - * within another regex. If so, we don't want this - * regex's "commentization" to leak out to the - * right part of the enclosing regex, we must cap - * it with a newline. - * - * So, if /x was used, we scan backwards from the - * end of the regex. If we find a '#' before we - * find a newline, we need to add a newline - * ourself. If we find a '\n' first (or if we - * don't find '#' or '\n'), we don't need to add - * anything. -jfriedl - */ - if (PMf_EXTENDED & re->reganch) - { - const char *endptr = re->precomp + re->prelen; - while (endptr >= re->precomp) - { - const char c = *(endptr--); - if (c == '\n') - break; /* don't need another */ - if (c == '#') { - /* we end while in a comment, so we - need a newline */ - mg->mg_len++; /* save space for it */ - need_newline = 1; /* note to add it */ - break; - } - } - } - - Newx(mg->mg_ptr, mg->mg_len + 1 + left, char); - Copy("(?", mg->mg_ptr, 2, char); - Copy(reflags, mg->mg_ptr+2, left, char); - Copy(":", mg->mg_ptr+left+2, 1, char); - Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char); - if (need_newline) - mg->mg_ptr[mg->mg_len - 2] = '\n'; - mg->mg_ptr[mg->mg_len - 1] = ')'; - mg->mg_ptr[mg->mg_len] = 0; - } - PL_reginterp_cnt += re->program[0].next_off; - - if (re->reganch & ROPT_UTF8) - SvUTF8_on(origsv); - else - SvUTF8_off(origsv); - if (lp) - *lp = mg->mg_len; - return mg->mg_ptr; - } - /* Fall through */ - case SVt_NULL: - case SVt_IV: - case SVt_NV: - case SVt_RV: - case SVt_PV: - case SVt_PVIV: - case SVt_PVNV: - case SVt_PVBM: typestr = SvROK(sv) ? "REF" : "SCALAR"; break; - case SVt_PVLV: typestr = SvROK(sv) ? "REF" - /* tied lvalues should appear to be - * scalars for backwards compatitbility */ - : (LvTYPE(sv) == 't' || LvTYPE(sv) == 'T') - ? "SCALAR" : "LVALUE"; break; - case SVt_PVAV: typestr = "ARRAY"; break; - case SVt_PVHV: typestr = "HASH"; break; - case SVt_PVCV: typestr = "CODE"; break; - case SVt_PVGV: typestr = "GLOB"; break; - case SVt_PVFM: typestr = "FORMAT"; break; - case SVt_PVIO: typestr = "IO"; break; - default: typestr = "UNKNOWN"; break; - } - tsv = NEWSV(0,0); - if (SvOBJECT(sv)) { - const char * const name = HvNAME_get(SvSTASH(sv)); - Perl_sv_setpvf(aTHX_ tsv, "%s=%s(0x%"UVxf")", - name ? name : "__ANON__" , typestr, PTR2UV(sv)); + s = (U8 *) SvPV(sv, len); + if (!utf8_to_bytes(s, &len)) { + if (fail_ok) + return FALSE; + else { + if (PL_op) + Perl_croak(aTHX_ "Wide character in %s", + OP_DESC(PL_op)); + else + Perl_croak(aTHX_ "Wide character"); } - else - Perl_sv_setpvf(aTHX_ tsv, "%s(0x%"UVxf")", typestr, PTR2UV(sv)); - goto tokensaveref; } - if (lp) - *lp = strlen(typestr); - return (char *)typestr; - } - if (SvREADONLY(sv) && !SvOK(sv)) { - if (ckWARN(WARN_UNINITIALIZED)) - report_uninit(sv); - if (lp) - *lp = 0; - return (char *)""; - } - } - if (SvIOK(sv) || ((SvIOKp(sv) && !SvNOKp(sv)))) { - /* I'm assuming that if both IV and NV are equally valid then - converting the IV is going to be more efficient */ - const U32 isIOK = SvIOK(sv); - const U32 isUIOK = SvIsUV(sv); - char buf[TYPE_CHARS(UV)]; - char *ebuf, *ptr; - - if (SvTYPE(sv) < SVt_PVIV) - sv_upgrade(sv, SVt_PVIV); - if (isUIOK) - ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf); - else - ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf); - /* inlined from sv_setpvn */ - SvGROW_mutable(sv, (STRLEN)(ebuf - ptr + 1)); - Move(ptr,SvPVX_mutable(sv),ebuf - ptr,char); - SvCUR_set(sv, ebuf - ptr); - s = SvEND(sv); - *s = '\0'; - if (isIOK) - SvIOK_on(sv); - else - SvIOKp_on(sv); - if (isUIOK) - SvIsUV_on(sv); - } - else if (SvNOKp(sv)) { - if (SvTYPE(sv) < SVt_PVNV) - sv_upgrade(sv, SVt_PVNV); - /* The +20 is pure guesswork. Configure test needed. --jhi */ - s = SvGROW_mutable(sv, NV_DIG + 20); - olderrno = errno; /* some Xenix systems wipe out errno here */ -#ifdef apollo - if (SvNVX(sv) == 0.0) - (void)strcpy(s,"0"); - else -#endif /*apollo*/ - { - Gconvert(SvNVX(sv), NV_DIG, 0, s); - } - errno = olderrno; -#ifdef FIXNEGATIVEZERO - if (*s == '-' && s[1] == '0' && !s[2]) - strcpy(s,"0"); -#endif - while (*s) s++; -#ifdef hcx - if (s[-1] == '.') - *--s = '\0'; -#endif - } - else { - if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED)) - report_uninit(sv); - if (lp) - *lp = 0; - if (SvTYPE(sv) < SVt_PV) - /* Typically the caller expects that sv_any is not NULL now. */ - sv_upgrade(sv, SVt_PV); - return (char *)""; - } - { - const STRLEN len = s - SvPVX_const(sv); - if (lp) - *lp = len; - SvCUR_set(sv, len); - } - SvPOK_on(sv); - DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n", - PTR2UV(sv),SvPVX_const(sv))); - if (flags & SV_CONST_RETURN) - return (char *)SvPVX_const(sv); - if (flags & SV_MUTABLE_RETURN) - return SvPVX_mutable(sv); - return SvPVX(sv); - - tokensave: - len = strlen(tmpbuf); - tokensave_has_len: - assert (!tsv); - if (SvROK(sv)) { /* XXX Skip this when sv_pvn_force calls */ - /* Sneaky stuff here */ - - tokensaveref: - if (!tsv) - tsv = newSVpvn(tmpbuf, len); - sv_2mortal(tsv); - if (lp) - *lp = SvCUR(tsv); - return SvPVX(tsv); - } - else { - dVAR; - -#ifdef FIXNEGATIVEZERO - if (len == 2 && tmpbuf[0] == '-' && tmpbuf[1] == '0') { - tmpbuf[0] = '0'; - tmpbuf[1] = 0; - len = 1; + SvCUR_set(sv, len); } -#endif - SvUPGRADE(sv, SVt_PV); - if (lp) - *lp = len; - s = SvGROW_mutable(sv, len + 1); - SvCUR_set(sv, len); - SvPOKp_on(sv); - return memcpy(s, tmpbuf, len + 1); } + SvUTF8_off(sv); + return TRUE; } /* -=for apidoc sv_copypv +=for apidoc sv_utf8_encode -Copies a stringified representation of the source SV into the -destination SV. Automatically performs any necessary mg_get and -coercion of numeric values into strings. Guaranteed to preserve -UTF-8 flag even from overloaded objects. Similar in nature to -sv_2pv[_flags] but operates directly on an SV instead of just the -string. Mostly uses sv_2pv_flags to do its work, except when that -would lose the UTF-8'ness of the PV. +Converts the PV of an SV to UTF-8, but then turns the C +flag off so that it looks like octets again. =cut */ void -Perl_sv_copypv(pTHX_ SV *dsv, register SV *ssv) +Perl_sv_utf8_encode(pTHX_ register SV *sv) { - STRLEN len; - const char * const s = SvPV_const(ssv,len); - sv_setpvn(dsv,s,len); - if (SvUTF8(ssv)) - SvUTF8_on(dsv); - else - SvUTF8_off(dsv); + (void) sv_utf8_upgrade(sv); + if (SvIsCOW(sv)) { + sv_force_normal_flags(sv, 0); + } + if (SvREADONLY(sv)) { + Perl_croak(aTHX_ PL_no_modify); + } + SvUTF8_off(sv); } /* -=for apidoc sv_2pvbyte +=for apidoc sv_utf8_decode -Return a pointer to the byte-encoded representation of the SV, and set *lp -to its length. May cause the SV to be downgraded from UTF-8 as a -side-effect. - -Usually accessed via the C macro. - -=cut -*/ - -char * -Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp) -{ - sv_utf8_downgrade(sv,0); - return lp ? SvPV(sv,*lp) : SvPV_nolen(sv); -} - -/* -=for apidoc sv_2pvutf8 - -Return a pointer to the UTF-8-encoded representation of the SV, and set *lp -to its length. May cause the SV to be upgraded to UTF-8 as a side-effect. - -Usually accessed via the C macro. - -=cut -*/ - -char * -Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp) -{ - sv_utf8_upgrade(sv); - return lp ? SvPV(sv,*lp) : SvPV_nolen(sv); -} - - -/* -=for apidoc sv_2bool - -This function is only called on magical items, and is only used by -sv_true() or its macro equivalent. - -=cut -*/ - -bool -Perl_sv_2bool(pTHX_ register SV *sv) -{ - SvGETMAGIC(sv); - - if (!SvOK(sv)) - return 0; - if (SvROK(sv)) { - SV* tmpsv; - if (SvAMAGIC(sv) && (tmpsv=AMG_CALLun(sv,bool_)) && - (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv)))) - return (bool)SvTRUE(tmpsv); - return SvRV(sv) != 0; - } - if (SvPOKp(sv)) { - register XPV* const Xpvtmp = (XPV*)SvANY(sv); - if (Xpvtmp && - (*sv->sv_u.svu_pv > '0' || - Xpvtmp->xpv_cur > 1 || - (Xpvtmp->xpv_cur && *sv->sv_u.svu_pv != '0'))) - return 1; - else - return 0; - } - else { - if (SvIOKp(sv)) - return SvIVX(sv) != 0; - else { - if (SvNOKp(sv)) - return SvNVX(sv) != 0.0; - else - return FALSE; - } - } -} - -/* -=for apidoc sv_utf8_upgrade - -Converts the PV of an SV to its UTF-8-encoded form. -Forces the SV to string form if it is not already. -Always sets the SvUTF8 flag to avoid future validity checks even -if all the bytes have hibit clear. - -This is not as a general purpose byte encoding to Unicode interface: -use the Encode extension for that. - -=for apidoc sv_utf8_upgrade_flags - -Converts the PV of an SV to its UTF-8-encoded form. -Forces the SV to string form if it is not already. -Always sets the SvUTF8 flag to avoid future validity checks even -if all the bytes have hibit clear. If C has C bit set, -will C on C if appropriate, else not. C and -C are implemented in terms of this function. - -This is not as a general purpose byte encoding to Unicode interface: -use the Encode extension for that. - -=cut -*/ - -STRLEN -Perl_sv_utf8_upgrade_flags(pTHX_ register SV *sv, I32 flags) -{ - if (sv == &PL_sv_undef) - return 0; - if (!SvPOK(sv)) { - STRLEN len = 0; - if (SvREADONLY(sv) && (SvPOKp(sv) || SvIOKp(sv) || SvNOKp(sv))) { - (void) sv_2pv_flags(sv,&len, flags); - if (SvUTF8(sv)) - return len; - } else { - (void) SvPV_force(sv,len); - } - } - - if (SvUTF8(sv)) { - return SvCUR(sv); - } - - if (SvIsCOW(sv)) { - sv_force_normal_flags(sv, 0); - } - - if (PL_encoding && !(flags & SV_UTF8_NO_ENCODING)) - sv_recode_to_utf8(sv, PL_encoding); - else { /* Assume Latin-1/EBCDIC */ - /* This function could be much more efficient if we - * had a FLAG in SVs to signal if there are any hibit - * chars in the PV. Given that there isn't such a flag - * make the loop as fast as possible. */ - const U8 *s = (U8 *) SvPVX_const(sv); - const U8 * const e = (U8 *) SvEND(sv); - const U8 *t = s; - int hibit = 0; - - while (t < e) { - const U8 ch = *t++; - if ((hibit = !NATIVE_IS_INVARIANT(ch))) - break; - } - if (hibit) { - STRLEN len = SvCUR(sv) + 1; /* Plus the \0 */ - U8 * const recoded = bytes_to_utf8((U8*)s, &len); - - SvPV_free(sv); /* No longer using what was there before. */ - - SvPV_set(sv, (char*)recoded); - SvCUR_set(sv, len - 1); - SvLEN_set(sv, len); /* No longer know the real size. */ - } - /* Mark as UTF-8 even if no hibit - saves scanning loop */ - SvUTF8_on(sv); - } - return SvCUR(sv); -} - -/* -=for apidoc sv_utf8_downgrade - -Attempts to convert the PV of an SV from characters to bytes. -If the PV contains a character beyond byte, this conversion will fail; -in this case, either returns false or, if C is not -true, croaks. - -This is not as a general purpose Unicode to byte encoding interface: -use the Encode extension for that. - -=cut -*/ - -bool -Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok) -{ - if (SvPOKp(sv) && SvUTF8(sv)) { - if (SvCUR(sv)) { - U8 *s; - STRLEN len; - - if (SvIsCOW(sv)) { - sv_force_normal_flags(sv, 0); - } - s = (U8 *) SvPV(sv, len); - if (!utf8_to_bytes(s, &len)) { - if (fail_ok) - return FALSE; - else { - if (PL_op) - Perl_croak(aTHX_ "Wide character in %s", - OP_DESC(PL_op)); - else - Perl_croak(aTHX_ "Wide character"); - } - } - SvCUR_set(sv, len); - } - } - SvUTF8_off(sv); - return TRUE; -} - -/* -=for apidoc sv_utf8_encode - -Converts the PV of an SV to UTF-8, but then turns the C -flag off so that it looks like octets again. - -=cut -*/ - -void -Perl_sv_utf8_encode(pTHX_ register SV *sv) -{ - (void) sv_utf8_upgrade(sv); - if (SvIsCOW(sv)) { - sv_force_normal_flags(sv, 0); - } - if (SvREADONLY(sv)) { - Perl_croak(aTHX_ PL_no_modify); - } - SvUTF8_off(sv); -} - -/* -=for apidoc sv_utf8_decode - -If the PV of the SV is an octet sequence in UTF-8 -and contains a multiple-byte character, the C flag is turned on -so that it looks like a character. If the PV contains only single-byte -characters, the C flag stays being off. -Scans PV for validity and returns false if the PV is invalid UTF-8. +If the PV of the SV is an octet sequence in UTF-8 +and contains a multiple-byte character, the C flag is turned on +so that it looks like a character. If the PV contains only single-byte +characters, the C flag stays being off. +Scans PV for validity and returns false if the PV is invalid UTF-8. =cut */ @@ -4141,7 +3378,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) SvIV_set(dstr, SvIVX(sstr)); } if (SvVOK(sstr)) { - MAGIC *smg = mg_find(sstr,PERL_MAGIC_vstring); + const MAGIC * const smg = mg_find(sstr,PERL_MAGIC_vstring); sv_magic(dstr, NULL, PERL_MAGIC_vstring, smg->mg_ptr, smg->mg_len); SvRMAGICAL_on(dstr); @@ -4647,10 +3884,10 @@ and C are implemented in terms of this function. void Perl_sv_catsv_flags(pTHX_ SV *dsv, register SV *ssv, I32 flags) { - const char *spv; - STRLEN slen; if (ssv) { - if ((spv = SvPV_const(ssv, slen))) { + STRLEN slen; + const char *spv = SvPV_const(ssv, slen); + if (spv) { /* sutf8 and dutf8 were type bool, but under USE_ITHREADS, gcc version 2.95.2 20000220 (Debian GNU/Linux) for Linux xxx 2.2.17 on sparc64 with gcc -O2, we erroneously @@ -4668,7 +3905,7 @@ Perl_sv_catsv_flags(pTHX_ SV *dsv, register SV *ssv, I32 flags) if (dutf8 != sutf8) { if (dutf8) { /* Not modifying source SV, so taking a temporary copy. */ - SV* csv = sv_2mortal(newSVpvn(spv, slen)); + SV* const csv = sv_2mortal(newSVpvn(spv, slen)); sv_utf8_upgrade(csv); spv = SvPV_const(csv, slen); @@ -5352,9 +4589,9 @@ void Perl_sv_clear(pTHX_ register SV *sv) { dVAR; - void** old_body_arena; - size_t old_body_offset; const U32 type = SvTYPE(sv); + const struct body_details *const sv_type_details + = bodies_by_type + type; assert(sv); assert(SvREFCNT(sv) == 0); @@ -5362,9 +4599,6 @@ Perl_sv_clear(pTHX_ register SV *sv) if (type <= SVt_IV) return; - old_body_arena = 0; - old_body_offset = 0; - if (SvOBJECT(sv)) { if (PL_defstash) { /* Still have a symbol table? */ dSP; @@ -5436,26 +4670,18 @@ Perl_sv_clear(pTHX_ register SV *sv) Safefree(IoTOP_NAME(sv)); Safefree(IoFMT_NAME(sv)); Safefree(IoBOTTOM_NAME(sv)); - /* PVIOs aren't from arenas */ goto freescalar; case SVt_PVBM: - old_body_arena = &PL_body_roots[SVt_PVBM]; goto freescalar; case SVt_PVCV: - old_body_arena = &PL_body_roots[SVt_PVCV]; case SVt_PVFM: - /* PVFMs aren't from arenas */ cv_undef((CV*)sv); goto freescalar; case SVt_PVHV: hv_undef((HV*)sv); - old_body_arena = &PL_body_roots[SVt_PVHV]; - old_body_offset = STRUCT_OFFSET(XPVHV, xhv_fill); break; case SVt_PVAV: av_undef((AV*)sv); - old_body_arena = &PL_body_roots[SVt_PVAV]; - old_body_offset = STRUCT_OFFSET(XPVAV, xav_fill); break; case SVt_PVLV: if (LvTYPE(sv) == 'T') { /* for tie: return HE to pool */ @@ -5465,7 +4691,6 @@ Perl_sv_clear(pTHX_ register SV *sv) } else if (LvTYPE(sv) != 't') /* unless tie: unrefcnted fake SV** */ SvREFCNT_dec(LvTARG(sv)); - old_body_arena = &PL_body_roots[SVt_PVLV]; goto freescalar; case SVt_PVGV: gp_free((GV*)sv); @@ -5474,29 +4699,17 @@ Perl_sv_clear(pTHX_ register SV *sv) have a back reference to us, which needs to be cleared. */ if (GvSTASH(sv)) sv_del_backref((SV*)GvSTASH(sv), sv); - old_body_arena = &PL_body_roots[SVt_PVGV]; - goto freescalar; case SVt_PVMG: - old_body_arena = &PL_body_roots[SVt_PVMG]; - goto freescalar; case SVt_PVNV: - old_body_arena = &PL_body_roots[SVt_PVNV]; - goto freescalar; case SVt_PVIV: - old_body_arena = &PL_body_roots[SVt_PVIV]; - old_body_offset = STRUCT_OFFSET(XPVIV, xpv_cur); freescalar: /* Don't bother with SvOOK_off(sv); as we're only going to free it. */ if (SvOOK(sv)) { SvPV_set(sv, SvPVX_mutable(sv) - SvIVX(sv)); /* Don't even bother with turning off the OOK flag. */ } - goto pvrv_common; case SVt_PV: - old_body_arena = &PL_body_roots[SVt_PV]; - old_body_offset = STRUCT_OFFSET(XPV, xpv_cur); case SVt_RV: - pvrv_common: if (SvROK(sv)) { SV *target = SvRV(sv); if (SvWEAKREF(sv)) @@ -5531,22 +4744,19 @@ Perl_sv_clear(pTHX_ register SV *sv) #endif break; case SVt_NV: - old_body_arena = PL_body_roots[SVt_NV]; break; } SvFLAGS(sv) &= SVf_BREAK; SvFLAGS(sv) |= SVTYPEMASK; -#ifndef PURIFY - if (old_body_arena) { - del_body(((char *)SvANY(sv) + old_body_offset), old_body_arena); + if (sv_type_details->arena) { + del_body(((char *)SvANY(sv) + sv_type_details->offset), + &PL_body_roots[type]); + } + else if (sv_type_details->size) { + my_safefree(SvANY(sv)); } - else -#endif - if (type > SVt_RV) { - my_safefree(SvANY(sv)); - } } /* @@ -6660,7 +5870,7 @@ thats_really_all_folks: screamer2: if (rslen) { - register const STDCHAR *bpe = buf + sizeof(buf); + register const STDCHAR * const bpe = buf + sizeof(buf); bp = buf; while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = (STDCHAR)i) != rslast && bp < bpe) ; /* keep reading */ @@ -8051,7 +7261,7 @@ S_sv_unglob(pTHX_ SV *sv) gp_free((GV*)sv); if (GvSTASH(sv)) { sv_del_backref((SV*)GvSTASH(sv), sv); - GvSTASH(sv) = Nullhv; + GvSTASH(sv) = NULL; } sv_unmagic(sv, PERL_MAGIC_glob); Safefree(GvNAME(sv)); @@ -8407,8 +7617,13 @@ S_expect_number(pTHX_ char** pattern) case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': - while (isDIGIT(**pattern)) - var = var * 10 + (*(*pattern)++ - '0'); + var = *(*pattern)++ - '0'; + while (isDIGIT(**pattern)) { + I32 tmp = var * 10 + (*(*pattern)++ - '0'); + if (tmp < var) + Perl_croak(aTHX_ "Integer overflow in format string for %s", (PL_op ? OP_NAME(PL_op) : "sv_vcatpvfn")); + var = tmp; + } } return var; } @@ -8497,8 +7712,6 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV } else if (svix < svmax) { sv_catsv(sv, *svargs); - if (DO_UTF8(*svargs)) - SvUTF8_on(sv); } return; } @@ -8506,8 +7719,6 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV pat[1] == '-' && pat[2] == 'p') { argsv = va_arg(*args, SV*); sv_catsv(sv, argsv); - if (DO_UTF8(argsv)) - SvUTF8_on(sv); return; } @@ -8754,31 +7965,48 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV if (vectorarg) { if (args) vecsv = va_arg(*args, SV*); - else - vecsv = (evix ? evix <= svmax : svix < svmax) ? - svargs[evix ? evix-1 : svix++] : &PL_sv_undef; + else if (evix) { + vecsv = (evix > 0 && evix <= svmax) + ? svargs[evix-1] : &PL_sv_undef; + } else { + vecsv = svix < svmax ? svargs[svix++] : &PL_sv_undef; + } dotstr = SvPV_const(vecsv, dotstrlen); + /* Keep the DO_UTF8 test *after* the SvPV call, else things go + bad with tied or overloaded values that return UTF8. */ if (DO_UTF8(vecsv)) is_utf8 = TRUE; + else if (has_utf8) { + vecsv = sv_mortalcopy(vecsv); + sv_utf8_upgrade(vecsv); + dotstr = SvPV_const(vecsv, dotstrlen); + is_utf8 = TRUE; + } } if (args) { VECTORIZE_ARGS } - else if (efix ? efix <= svmax : svix < svmax) { + else if (efix ? (efix > 0 && efix <= svmax) : svix < svmax) { vecsv = svargs[efix ? efix-1 : svix++]; vecstr = (U8*)SvPV_const(vecsv,veclen); vec_utf8 = DO_UTF8(vecsv); - /* if this is a version object, we need to return the - * stringified representation (which the SvPVX_const has - * already done for us), but not vectorize the args + + /* if this is a version object, we need to convert + * back into v-string notation and then let the + * vectorize happen normally */ - if ( *q == 'd' && sv_derived_from(vecsv,"version") ) - { - q++; /* skip past the rest of the %vd format */ - eptr = (const char *) vecstr; - elen = veclen; - vectorize=FALSE; - goto string; + if (sv_derived_from(vecsv, "version")) { + char *version = savesvpv(vecsv); + vecsv = sv_newmortal(); + /* scan_vstring is expected to be called during + * tokenization, so we need to fake up the end + * of the buffer for it + */ + PL_bufend = version + veclen; + scan_vstring(version, vecsv); + vecstr = (U8*)SvPV_const(vecsv, veclen); + vec_utf8 = DO_UTF8(vecsv); + Safefree(version); } } else { @@ -8877,21 +8105,31 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV if (*q == '%') { eptr = q++; elen = 1; + if (vectorize) { + c = '%'; + goto unknown; + } goto string; } - if (vectorize) - argsv = vecsv; - else if (!args) - argsv = (efix ? efix <= svmax : svix < svmax) ? - svargs[efix ? efix-1 : svix++] : &PL_sv_undef; + if (!vectorize && !args) { + if (efix) { + const I32 i = efix-1; + argsv = (i >= 0 && i < svmax) ? svargs[i] : &PL_sv_undef; + } else { + argsv = (svix >= 0 && svix < svmax) + ? svargs[svix++] : &PL_sv_undef; + } + } switch (c = *q++) { /* STRINGS */ case 'c': - uv = (args && !vectorize) ? va_arg(*args, int) : SvIVx(argsv); + if (vectorize) + goto unknown; + uv = (args) ? va_arg(*args, int) : SvIVx(argsv); if ((uv > 255 || (!UNI_IS_INVARIANT(uv) && SvUTF8(sv))) && !IN_BYTES) { @@ -8907,7 +8145,9 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV goto string; case 's': - if (args && !vectorize) { + if (vectorize) + goto unknown; + if (args) { eptr = va_arg(*args, char*); if (eptr) #ifdef MACOS_TRADITIONAL @@ -8938,7 +8178,6 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV } string: - vectorize = FALSE; if (has_precis && elen > precis) elen = precis; break; @@ -9116,6 +8355,8 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV *--ptr = '0'; break; case 2: + if (!uv) + alt = FALSE; do { dig = uv & 1; *--ptr = '0' + dig; @@ -9151,7 +8392,9 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV case 'e': case 'E': case 'f': case 'g': case 'G': - + if (vectorize) + goto unknown; + /* This is evil, but floating point is even more evil */ /* for SV-style calling, we can only get NV @@ -9183,7 +8426,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV } /* now we need (long double) if intsize == 'q', else (double) */ - nv = (args && !vectorize) ? + nv = (args) ? #if LONG_DOUBLESIZE > DOUBLESIZE intsize == 'q' ? va_arg(*args, long double) : @@ -9194,7 +8437,6 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV : SvNVx(argsv); need = 0; - vectorize = FALSE; if (c != 'e' && c != 'E') { i = PERL_INT_MIN; /* FIXME: if HAS_LONG_DOUBLE but not USE_LONG_DOUBLE this @@ -9352,8 +8594,10 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV /* SPECIAL */ case 'n': + if (vectorize) + goto unknown; i = SvCUR(sv) - origlen; - if (args && !vectorize) { + if (args) { switch (intsize) { case 'h': *(va_arg(*args, short*)) = i; break; default: *(va_arg(*args, int*)) = i; break; @@ -9366,7 +8610,6 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV } else sv_setuv_mg(argsv, (UV)i); - vectorize = FALSE; continue; /* not "break" */ /* UNKNOWN */ @@ -9412,6 +8655,8 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV /* calculate width before utf8_upgrade changes it */ have = esignlen + zeros + elen; + if (have < zeros) + Perl_croak_nocontext(PL_memory_wrap); if (is_utf8 != has_utf8) { if (is_utf8) { @@ -9432,6 +8677,8 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV need = (have > width ? have : width); gap = need - have; + if (need >= (((STRLEN)~0) - SvCUR(sv) - dotstrlen - 1)) + Perl_croak_nocontext(PL_memory_wrap); SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1); p = SvEND(sv); if (esignlen && fill == '0') { @@ -9791,11 +9038,8 @@ Perl_ptr_table_new(pTHX) return tbl; } -#if (PTRSIZE == 8) -# define PTR_TABLE_HASH(ptr) (PTR2UV(ptr) >> 3) -#else -# define PTR_TABLE_HASH(ptr) (PTR2UV(ptr) >> 2) -#endif +#define PTR_TABLE_HASH(ptr) \ + ((PTR2UV(ptr) >> 3) ^ (PTR2UV(ptr) >> (3 + 7)) ^ (PTR2UV(ptr) >> (3 + 17))) /* we use the PTE_SVSLOT 'reservation' made above, both here (in the @@ -9807,18 +9051,24 @@ Perl_ptr_table_new(pTHX) /* map an existing pointer using a table */ -void * -Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, const void *sv) -{ +STATIC PTR_TBL_ENT_t * +S_ptr_table_find(pTHX_ PTR_TBL_t *tbl, const void *sv) { PTR_TBL_ENT_t *tblent; const UV hash = PTR_TABLE_HASH(sv); assert(tbl); tblent = tbl->tbl_ary[hash & tbl->tbl_max]; for (; tblent; tblent = tblent->next) { if (tblent->oldval == sv) - return tblent->newval; + return tblent; } - return (void*)NULL; + return 0; +} + +void * +Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, const void *sv) +{ + PTR_TBL_ENT_t const *const tblent = S_ptr_table_find(aTHX_ tbl, sv); + return tblent ? tblent->newval : (void *) 0; } /* add a new entry to a pointer-mapping table */ @@ -9826,30 +9076,22 @@ Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, const void *sv) void Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, const void *oldsv, void *newsv) { - PTR_TBL_ENT_t *tblent, **otblent; - /* XXX this may be pessimal on platforms where pointers aren't good - * hash values e.g. if they grow faster in the most significant - * bits */ - const UV hash = PTR_TABLE_HASH(oldsv); - bool empty = 1; + PTR_TBL_ENT_t *tblent = S_ptr_table_find(aTHX_ tbl, oldsv); - assert(tbl); - otblent = &tbl->tbl_ary[hash & tbl->tbl_max]; - for (tblent = *otblent; tblent; empty=0, tblent = tblent->next) { - if (tblent->oldval == oldsv) { - tblent->newval = newsv; - return; - } + if (tblent) { + tblent->newval = newsv; + } else { + const UV entry = PTR_TABLE_HASH(oldsv) & tbl->tbl_max; + + new_body_inline(tblent, sizeof(struct ptr_tbl_ent), PTE_SVSLOT); + tblent->oldval = oldsv; + tblent->newval = newsv; + tblent->next = tbl->tbl_ary[entry]; + tbl->tbl_ary[entry] = tblent; + tbl->tbl_items++; + if (tblent->next && tbl->tbl_items > tbl->tbl_max) + ptr_table_split(tbl); } - new_body_inline(tblent, &PL_body_roots[PTE_SVSLOT], - sizeof(struct ptr_tbl_ent), PTE_SVSLOT); - tblent->oldval = oldsv; - tblent->newval = newsv; - tblent->next = *otblent; - *otblent = tblent; - tbl->tbl_items++; - if (!empty && tbl->tbl_items > tbl->tbl_max) - ptr_table_split(tbl); } /* double the hash bucket size of an existing ptr table */ @@ -9889,34 +9131,22 @@ Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl) void Perl_ptr_table_clear(pTHX_ PTR_TBL_t *tbl) { - register PTR_TBL_ENT_t **array; - register PTR_TBL_ENT_t *entry; - UV riter = 0; - UV max; + if (tbl && tbl->tbl_items) { + register PTR_TBL_ENT_t **array = tbl->tbl_ary; + UV riter = tbl->tbl_max; - if (!tbl || !tbl->tbl_items) { - return; - } + do { + PTR_TBL_ENT_t *entry = array[riter]; - array = tbl->tbl_ary; - entry = array[0]; - max = tbl->tbl_max; + while (entry) { + PTR_TBL_ENT_t * const oentry = entry; + entry = entry->next; + del_pte(oentry); + } + } while (riter--); - for (;;) { - if (entry) { - PTR_TBL_ENT_t *oentry = entry; - entry = entry->next; - del_pte(oentry); - } - if (!entry) { - if (++riter > max) { - break; - } - entry = array[riter]; - } + tbl->tbl_items = 0; } - - tbl->tbl_items = 0; } /* clear and free a ptr table */ @@ -10058,12 +9288,10 @@ Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param) default: { /* These are all the types that need complex bodies allocating. */ - size_t new_body_length; - size_t new_body_offset = 0; - void **new_body_arena; - void **new_body_arenaroot; void *new_body; - svtype sv_type = SvTYPE(sstr); + const svtype sv_type = SvTYPE(sstr); + const struct body_details *const sv_type_details + = bodies_by_type + sv_type; switch (sv_type) { default: @@ -10071,80 +9299,44 @@ Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param) (IV)SvTYPE(sstr)); break; - case SVt_PVIO: - new_body = new_XPVIO(); - new_body_length = sizeof(XPVIO); - break; - case SVt_PVFM: - new_body = new_XPVFM(); - new_body_length = sizeof(XPVFM); - break; - - case SVt_PVHV: - new_body_arena = &PL_body_roots[SVt_PVHV]; - new_body_arenaroot = &PL_body_arenaroots[SVt_PVHV]; - new_body_offset = - bodies_by_type[SVt_PVHV].offset; - - new_body_length = STRUCT_OFFSET(XPVHV, xmg_stash) - + sizeof (((XPVHV*)SvANY(sstr))->xmg_stash) - - new_body_offset; - goto new_body; - case SVt_PVAV: - new_body_arena = &PL_body_roots[SVt_PVAV]; - new_body_arenaroot = &PL_body_arenaroots[SVt_PVAV]; - new_body_offset = - bodies_by_type[SVt_PVAV].offset; - - new_body_length = STRUCT_OFFSET(XPVHV, xmg_stash) - + sizeof (((XPVHV*)SvANY(sstr))->xmg_stash) - - new_body_offset; - goto new_body; case SVt_PVGV: if (GvUNIQUE((GV*)sstr)) { /* Do sharing here, and fall through */ } + case SVt_PVIO: + case SVt_PVFM: + case SVt_PVHV: + case SVt_PVAV: case SVt_PVBM: case SVt_PVCV: case SVt_PVLV: case SVt_PVMG: case SVt_PVNV: - new_body_length = bodies_by_type[sv_type].size; - new_body_arena = &PL_body_roots[sv_type]; - new_body_arenaroot = &PL_body_arenaroots[sv_type]; - goto new_body; - case SVt_PVIV: - new_body_offset = - bodies_by_type[SVt_PVIV].offset; - new_body_length = sizeof(XPVIV) - new_body_offset; - new_body_arena = &PL_body_roots[SVt_PVIV]; - new_body_arenaroot = &PL_body_arenaroots[SVt_PVIV]; - goto new_body; case SVt_PV: - new_body_offset = - bodies_by_type[SVt_PV].offset; - new_body_length = sizeof(XPV) - new_body_offset; - new_body_arena = &PL_body_roots[SVt_PV]; - new_body_arenaroot = &PL_body_arenaroots[SVt_PV]; - new_body: - assert(new_body_length); -#ifndef PURIFY - new_body_inline(new_body, new_body_arena, - new_body_length, SvTYPE(sstr)); - - new_body = (void*)((char*)new_body - new_body_offset); -#else - /* We always allocated the full length item with PURIFY */ - new_body_length += new_body_offset; - new_body_offset = 0; - new_body = my_safemalloc(new_body_length); -#endif + assert(sv_type_details->size); + if (sv_type_details->arena) { + new_body_inline(new_body, sv_type_details->size, sv_type); + new_body + = (void*)((char*)new_body - sv_type_details->offset); + } else { + new_body = new_NOARENA(sv_type_details); + } } assert(new_body); SvANY(dstr) = new_body; - Copy(((char*)SvANY(sstr)) + new_body_offset, - ((char*)SvANY(dstr)) + new_body_offset, - new_body_length, char); +#ifndef PURIFY + Copy(((char*)SvANY(sstr)) + sv_type_details->offset, + ((char*)SvANY(dstr)) + sv_type_details->offset, + sv_type_details->copy, char); +#else + Copy(((char*)SvANY(sstr)), + ((char*)SvANY(dstr)), + sv_type_details->size + sv_type_details->offset, char); +#endif - if (SvTYPE(sstr) != SVt_PVAV && SvTYPE(sstr) != SVt_PVHV) + if (sv_type != SVt_PVAV && sv_type != SVt_PVHV) Perl_rvpv_dup(aTHX_ dstr, sstr, param); /* The Copy above means that all the source (unduplicated) pointers @@ -10152,14 +9344,15 @@ Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param) pointers in either, but it's possible that there's less cache missing by always going for the destination. FIXME - instrument and check that assumption */ - if (SvTYPE(sstr) >= SVt_PVMG) { + if (sv_type >= SVt_PVMG) { if (SvMAGIC(dstr)) SvMAGIC_set(dstr, mg_dup(SvMAGIC(dstr), param)); if (SvSTASH(dstr)) SvSTASH_set(dstr, hv_dup_inc(SvSTASH(dstr), param)); } - switch (SvTYPE(sstr)) { + /* The cast silences a GCC warning about unhandled types. */ + switch ((int)sv_type) { case SVt_PV: break; case SVt_PVIV: @@ -10261,8 +9454,8 @@ Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param) ++i; } if (SvOOK(sstr)) { - struct xpvhv_aux *saux = HvAUX(sstr); - struct xpvhv_aux *daux = HvAUX(dstr); + struct xpvhv_aux * const saux = HvAUX(sstr); + struct xpvhv_aux * const daux = HvAUX(dstr); /* This flag isn't copied. */ /* SvOOK_on(hv) attacks the IV flags. */ SvFLAGS(dstr) |= SVf_OOK; @@ -10362,7 +9555,7 @@ Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, CLONE_PARAMS* param) : cv_dup(cx->blk_sub.cv,param)); ncx->blk_sub.argarray = (cx->blk_sub.hasargs ? av_dup_inc(cx->blk_sub.argarray, param) - : Nullav); + : NULL); ncx->blk_sub.savearray = av_dup_inc(cx->blk_sub.savearray, param); ncx->blk_sub.olddepth = cx->blk_sub.olddepth; ncx->blk_sub.hasargs = cx->blk_sub.hasargs; @@ -10760,984 +9953,1454 @@ 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); -/* 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 regexp stuff */ + PL_replgv = gv_dup(proto_perl->Ireplgv, 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 misc objects */ + PL_errgv = gv_dup(proto_perl->Ierrgv, 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; - } - } -} + /* 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); + /* 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); -/* -=for apidoc perl_clone + PL_sub_generation = proto_perl->Isub_generation; -Create and return a new interpreter by cloning the current one. + /* funky return mechanisms */ + PL_forkprocess = proto_perl->Iforkprocess; -perl_clone takes these flags as parameters: + /* subprocess state */ + PL_fdpid = av_dup_inc(proto_perl->Ifdpid, param); -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. + /* 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; */ -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 + /* 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; -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. + /* runtime control stuff */ + PL_curcopdb = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl); + PL_copline = proto_perl->Icopline; -=cut -*/ + 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; -/* XXX the above needs expanding by someone who actually understands it ! */ -EXTERN_C PerlInterpreter * -perl_clone_host(PerlInterpreter* proto_perl, UV flags); + PL_ors_sv = sv_dup_inc(proto_perl->Iors_sv, param); -PerlInterpreter * -perl_clone(PerlInterpreter *proto_perl, UV flags) -{ - dVAR; -#ifdef PERL_IMPLICIT_SYS + /* 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); - /* perlhost.h so we need to call into it - to clone the host, CPerlHost should have a c interface, sky */ + 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); - 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); -} + PL_compcv = cv_dup(proto_perl->Icompcv, param); -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. */ + PAD_CLONE_VARS(proto_perl, param); - IV i; - CLONE_PARAMS clone_params; - CLONE_PARAMS* param = &clone_params; +#ifdef HAVE_INTERP_INTERN + sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern); +#endif - 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); + /* more statics moved here */ + PL_generation = proto_perl->Igeneration; + PL_DBcv = cv_dup(proto_perl->IDBcv, 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 */ + PL_in_clean_objs = proto_perl->Iin_clean_objs; + PL_in_clean_all = proto_perl->Iin_clean_all; - /* 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); + 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; -# 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; + PL_runops = proto_perl->Irunops; - Zero(&PL_body_arenaroots, 1, PL_body_arenaroots); - Zero(&PL_body_roots, 1, PL_body_roots); - - PL_he_arenaroot = NULL; - PL_he_root = NULL; + Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char); - 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; +#ifdef CSH + PL_cshlen = proto_perl->Icshlen; + PL_cshname = proto_perl->Icshname; /* XXX never deallocated */ +#endif - PL_debug = proto_perl->Idebug; + 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); - PL_hash_seed = proto_perl->Ihash_seed; - PL_rehash_seed = proto_perl->Irehash_seed; + Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE); + Copy(proto_perl->Inexttype, PL_nexttype, 5, I32); + PL_nexttoke = proto_perl->Inexttoke; -#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 + /* 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.) */ - Perl_reentrant_init(aTHX); -#endif + 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 */ - /* create SV map for pointer relocation */ - PL_ptr_table = ptr_table_new(); + PL_expect = proto_perl->Iexpect; - /* 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); + 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; - 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_error_count = proto_perl->Ierror_count; + PL_subline = proto_perl->Isubline; + PL_subname = sv_dup_inc(proto_perl->Isubname, param); - 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); + /* 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 - /* 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_hints = proto_perl->Ihints; - PL_compiling = proto_perl->Icompiling; + PL_amagic_generation = proto_perl->Iamagic_generation; - /* 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); +#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 */ - PL_compiling.cop_file = savesharedpv(PL_compiling.cop_file); - ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_file, PL_compiling.cop_file); +#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 */ - 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); + /* 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); - /* pseudo environmental stuff */ - PL_origargc = proto_perl->Iorigargc; - PL_origargv = proto_perl->Iorigargv; + /* Did the locale setup indicate UTF-8? */ + PL_utf8locale = proto_perl->Iutf8locale; + /* Unicode features (see perlrun/-C) */ + PL_unicode = proto_perl->Iunicode; - param->stashes = newAV(); /* Setup array of objects to call clone on */ + /* Pre-5.8 signals control */ + PL_signals = proto_perl->Isignals; - /* Set tainting stuff before PerlIO_debug can possibly get called */ - PL_tainting = proto_perl->Itainting; - PL_taint_warn = proto_perl->Itaint_warn; + /* times() ticks per second */ + PL_clocktick = proto_perl->Iclocktick; -#ifdef PERLIO_LAYERS - /* Clone PerlIO tables as soon as we can handle general xx_dup() */ - PerlIO_clone(aTHX_ proto_perl, param); -#endif + /* Recursion stopper for PerlIO_find_layer */ + PL_in_load_module = proto_perl->Iin_load_module; - 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); + /* sort() routine */ + PL_sort_RealCmp = proto_perl->Isort_RealCmp; - /* 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; + /* Not really needed/useful since the reenrant_retint is "volatile", + * but do it for consistency's sake. */ + PL_reentrant_retint = proto_perl->Ireentrant_retint; + + /* 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; - /* magical thingies */ - /* XXX time(&PL_basetime) when asked for? */ - PL_basetime = proto_perl->Ibasetime; - PL_formfeed = sv_dup(proto_perl->Iformfeed, param); + PL_runops_std = proto_perl->Irunops_std; + PL_runops_dbg = proto_perl->Irunops_dbg; - 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; +#ifdef THREADS_HAVE_PIDS + PL_ppid = proto_perl->Ippid; #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. */ + /* swatch cache */ + PL_last_swash_hv = NULL; /* 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; - /* 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_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 */ + + if (proto_perl->Ipsig_pend) { + Newxz(PL_psig_pend, SIG_SIZE, int); + } + else { + PL_psig_pend = (int*)NULL; + } + + 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); } } - PL_regex_pad = AvARRAY(PL_regex_padav); + else { + PL_psig_ptr = (SV**)NULL; + PL_psig_name = (SV**)NULL; + } - /* 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); + /* thrdvar.h stuff */ - /* shortcuts to regexp stuff */ - PL_replgv = gv_dup(proto_perl->Ireplgv, param); + 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; + } - /* shortcuts to misc objects */ - PL_errgv = gv_dup(proto_perl->Ierrgv, param); + /* 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); - /* 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); + /* 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); - /* 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); + /* NOTE: si_dup() looks at PL_markstack */ + PL_curstackinfo = si_dup(proto_perl->Tcurstackinfo, 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_curstack = PL_curstackinfo->si_stack; */ + PL_curstack = av_dup(proto_perl->Tcurstack, param); + PL_mainstack = av_dup(proto_perl->Tmainstack, param); - PL_sub_generation = proto_perl->Isub_generation; + /* 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); - /* funky return mechanisms */ - PL_forkprocess = proto_perl->Iforkprocess; + /* 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; */ + } - /* subprocess state */ - PL_fdpid = av_dup_inc(proto_perl->Ifdpid, param); + PL_start_env = proto_perl->Tstart_env; /* XXXXXX */ + PL_top_env = &PL_start_env; - /* 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; */ + PL_op = proto_perl->Top; - /* 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_Sv = Nullsv; + PL_Xpv = (XPV*)NULL; + PL_na = proto_perl->Tna; - /* runtime control stuff */ - PL_curcopdb = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl); - PL_copline = proto_perl->Icopline; + 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 - 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_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); - PL_ors_sv = sv_dup_inc(proto_perl->Iors_sv, 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; - /* 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_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; - 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_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_compcv = cv_dup(proto_perl->Icompcv, param); + /* regex stuff */ - PAD_CLONE_VARS(proto_perl, param); + PL_screamfirst = NULL; + PL_screamnext = NULL; + PL_maxscream = -1; /* reinits on demand */ + PL_lastscream = Nullsv; -#ifdef HAVE_INTERP_INTERN - sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern); + PL_watchaddr = NULL; + PL_watchok = Nullch; + + 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; - /* more statics moved here */ - PL_generation = proto_perl->Igeneration; - PL_DBcv = cv_dup(proto_perl->IDBcv, param); - - PL_in_clean_objs = proto_perl->Iin_clean_objs; - PL_in_clean_all = proto_perl->Iin_clean_all; + /* 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; - 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; + PL_reginterp_cnt = 0; + PL_reg_starttry = 0; - PL_runops = proto_perl->Irunops; + /* Pluggable optimizer */ + PL_peepp = proto_perl->Tpeepp; - Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char); + PL_stashcache = newHV(); -#ifdef CSH - PL_cshlen = proto_perl->Icshlen; - PL_cshname = proto_perl->Icshname; /* XXX never deallocated */ -#endif + if (!(flags & CLONEf_KEEP_PTR_TABLE)) { + ptr_table_free(PL_ptr_table); + PL_ptr_table = NULL; + } - 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); + /* 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; + } + } - Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE); - Copy(proto_perl->Inexttype, PL_nexttype, 5, I32); - PL_nexttoke = proto_perl->Inexttoke; + SvREFCNT_dec(param->stashes); - /* 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); + /* orphaned? eg threads->new inside BEGIN or use */ + if (PL_compcv && ! SvREFCNT(PL_compcv)) { + (void)SvREFCNT_inc(PL_compcv); + SAVEFREESV(PL_compcv); } - 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; + return my_perl; +} - 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; +#endif /* USE_ITHREADS */ - PL_error_count = proto_perl->Ierror_count; - PL_subline = proto_perl->Isubline; - PL_subname = sv_dup_inc(proto_perl->Isubname, param); +/* +=head1 Unicode Support - /* 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 +=for apidoc sv_recode_to_utf8 - PL_hints = proto_perl->Ihints; +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_amagic_generation = proto_perl->Iamagic_generation; +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). -#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 PV of the sv is returned. -#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 */ +=cut */ - /* 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); +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. + + Both will default the value - let them. + + 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); + } + return SvPOKp(sv) ? SvPVX(sv) : NULL; +} - /* Did the locale setup indicate UTF-8? */ - PL_utf8locale = proto_perl->Iutf8locale; - /* Unicode features (see perlrun/-C) */ - PL_unicode = proto_perl->Iunicode; +/* +=for apidoc sv_cat_decode - /* Pre-5.8 signals control */ - PL_signals = proto_perl->Isignals; +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. - /* times() ticks per second */ - PL_clocktick = proto_perl->Iclocktick; +Returns TRUE if the terminator was found, else returns FALSE. - /* Recursion stopper for PerlIO_find_layer */ - PL_in_load_module = proto_perl->Iin_load_module; +=cut */ - /* sort() routine */ - PL_sort_RealCmp = proto_perl->Isort_RealCmp; +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; + } + else + Perl_croak(aTHX_ "Invalid argument to sv_cat_decode"); + return ret; - /* Not really needed/useful since the reenrant_retint is "volatile", - * but do it for consistency's sake. */ - PL_reentrant_retint = proto_perl->Ireentrant_retint; +} - /* 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; +/* --------------------------------------------------------------------- + * + * support functions for report_uninit() + */ - PL_runops_std = proto_perl->Irunops_std; - PL_runops_dbg = proto_perl->Irunops_dbg; +/* the maxiumum size of array or hash where we will scan looking + * for the undefined element that triggered the warning */ -#ifdef THREADS_HAVE_PIDS - PL_ppid = proto_perl->Ippid; -#endif +#define FUV_MAX_SEARCH_SIZE 1000 - /* 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; +/* Look for an entry in the hash whose value has the same SV as val; + * If so, return a mortal copy of the key. */ - 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 */ +STATIC SV* +S_find_hash_subscript(pTHX_ HV *hv, SV* val) +{ + dVAR; + register HE **array; + I32 i; - if (proto_perl->Ipsig_pend) { - Newxz(PL_psig_pend, SIG_SIZE, int); - } - else { - PL_psig_pend = (int*)NULL; - } + if (!hv || SvMAGICAL(hv) || !HvARRAY(hv) || + (HvTOTALKEYS(hv) > FUV_MAX_SEARCH_SIZE)) + return Nullsv; - 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); + array = HvARRAY(hv); + + 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))); } } - else { - PL_psig_ptr = (SV**)NULL; - PL_psig_name = (SV**)NULL; + return Nullsv; +} + +/* Look for an entry in the array whose value has the same SV as val; + * If so, return the index, otherwise return -1. */ + +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; + + svp = AvARRAY(av); + for (i=AvFILLp(av); i>=0; i--) { + if (svp[i] == val && svp[i] != &PL_sv_undef) + return i; } + return -1; +} - /* thrdvar.h stuff */ +/* 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: + */ - 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; - } +#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" */ - /* 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); +STATIC SV* +S_varname(pTHX_ GV *gv, const char gvtype, PADOFFSET targ, + SV* keyname, I32 aindex, int subscript_type) +{ - /* 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); + SV * const name = sv_newmortal(); + if (gv) { + char buffer[2]; + buffer[0] = gvtype; + buffer[1] = 0; - /* NOTE: si_dup() looks at PL_markstack */ - PL_curstackinfo = si_dup(proto_perl->Tcurstackinfo, param); + /* as gv_fullname4(), but add literal '^' for $^FOO names */ - /* PL_curstack = PL_curstackinfo->si_stack; */ - PL_curstack = av_dup(proto_perl->Tcurstack, param); - PL_mainstack = av_dup(proto_perl->Tmainstack, param); + gv_fullname4(name, gv, buffer, 0); - /* 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); + if ((unsigned int)SvPVX(name)[1] <= 26) { + buffer[0] = '^'; + buffer[1] = SvPVX(name)[1] + 'A' - 1; - /* 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); + /* 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 { - init_stacks(); - ENTER; /* perl_destruct() wants to LEAVE; */ + U32 unused; + CV * const cv = find_runcv(&unused); + SV *sv; + AV *av; + + 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)); + } + + 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); + + return name; +} + + +/* +=for apidoc find_uninit_var - PL_start_env = proto_perl->Tstart_env; /* XXXXXX */ - PL_top_env = &PL_start_env; +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_op = proto_perl->Top; +The name is returned as a mortal SV. - PL_Sv = Nullsv; - PL_Xpv = (XPV*)NULL; - PL_na = proto_perl->Tna; +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_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 +=cut +*/ - 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); +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_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; + if (!obase || (match && (!uninit_sv || uninit_sv == &PL_sv_undef || + uninit_sv == &PL_sv_placeholder))) + return Nullsv; - 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; + switch (obase->op_type) { - 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 */ + 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; - /* regex stuff */ + 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); + } - PL_screamfirst = NULL; - PL_screamnext = NULL; - PL_maxscream = -1; /* reinits on demand */ - PL_lastscream = Nullsv; + /* 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_watchaddr = NULL; - PL_watchok = Nullch; + if (match && subscript_type == FUV_SUBSCRIPT_WITHIN) + break; - 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; + return varname(gv, hash ? '%' : '@', obase->op_targ, + keysv, index, subscript_type); + } - /* 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_PADSV: + if (match && PAD_SVl(obase->op_targ) != uninit_sv) + break; + return varname(Nullgv, '$', obase->op_targ, + Nullsv, 0, FUV_SUBSCRIPT_NONE); - PL_reginterp_cnt = 0; - PL_reg_starttry = 0; + case OP_GVSV: + gv = cGVOPx_gv(obase); + if (!gv || (match && GvSV(gv) != uninit_sv)) + break; + return varname(gv, '$', 0, Nullsv, 0, FUV_SUBSCRIPT_NONE); - /* Pluggable optimizer */ - PL_peepp = proto_perl->Tpeepp; + 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; - PL_stashcache = newHV(); + 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); - if (!(flags & CLONEf_KEEP_PTR_TABLE)) { - ptr_table_free(PL_ptr_table); - PL_ptr_table = NULL; - } + 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); - /* 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; + gv = Nullgv; + o = cBINOPx(obase)->op_first; + kid = cBINOPx(obase)->op_last; + + /* 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 * 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, + "", "", ""); } /*