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