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;
DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) ));
SvFLAGS(sv) |= SVf_BREAK;
if (PL_comppad == (AV*)sv) {
- PL_comppad = Nullav;
+ PL_comppad = NULL;
PL_curpad = Null(SV**);
}
SvREFCNT_dec(sv);
PL_sv_root = 0;
}
-/* ---------------------------------------------------------------------
- *
- * support functions for report_uninit()
- */
+/*
+ Here are mid-level routines that manage the allocation of bodies out
+ of the various arenas. There are 5 kinds of arenas:
-/* the maxiumum size of array or hash where we will scan looking
- * for the undefined element that triggered the warning */
+ 1. SV-head arenas, which are discussed and handled above
+ 2. regular body arenas
+ 3. arenas for reduced-size bodies
+ 4. Hash-Entry arenas
+ 5. pte arenas (thread related)
-#define FUV_MAX_SEARCH_SIZE 1000
+ Arena types 2 & 3 are chained by body-type off an array of
+ arena-root pointers, which is indexed by svtype. Some of the
+ larger/less used body types are malloced singly, since a large
+ unused block of them is wasteful. Also, several svtypes dont have
+ bodies; the data fits into the sv-head itself. The arena-root
+ pointer thus has a few unused root-pointers (which may be hijacked
+ later for arena types 4,5)
-/* Look for an entry in the hash whose value has the same SV as val;
- * If so, return a mortal copy of the key. */
+ 3 differs from 2 as an optimization; some body types have several
+ unused fields in the front of the structure (which are kept in-place
+ for consistency). These bodies can be allocated in smaller chunks,
+ because the leading fields arent accessed. Pointers to such bodies
+ are decremented to point at the unused 'ghost' memory, knowing that
+ the pointers are used with offsets to the real memory.
-STATIC SV*
-S_find_hash_subscript(pTHX_ HV *hv, SV* val)
+ HE, HEK arenas are managed separately, with separate code, but may
+ be merge-able later..
+
+ PTE arenas are not sv-bodies, but they share these mid-level
+ mechanics, so are considered here. The new mid-level mechanics rely
+ on the sv_type of the body being allocated, so we just reserve one
+ of the unused body-slots for PTEs, then use it in those (2) PTE
+ contexts below (line ~10k)
+*/
+
+STATIC void *
+S_more_bodies (pTHX_ size_t size, svtype sv_type)
{
- dVAR;
- register HE **array;
- I32 i;
+ void ** const arena_root = &PL_body_arenaroots[sv_type];
+ void ** const root = &PL_body_roots[sv_type];
+ char *start;
+ const char *end;
+ const size_t count = PERL_ARENA_SIZE / size;
- if (!hv || SvMAGICAL(hv) || !HvARRAY(hv) ||
- (HvTOTALKEYS(hv) > FUV_MAX_SEARCH_SIZE))
- return Nullsv;
+ Newx(start, count*size, char);
+ *((void **) start) = *arena_root;
+ *arena_root = (void *)start;
- array = HvARRAY(hv);
+ end = start + (count-1) * size;
- for (i=HvMAX(hv); i>0; i--) {
- register HE *entry;
- for (entry = array[i]; entry; entry = HeNEXT(entry)) {
- if (HeVAL(entry) != val)
- continue;
- if ( HeVAL(entry) == &PL_sv_undef ||
- HeVAL(entry) == &PL_sv_placeholder)
- continue;
- if (!HeKEY(entry))
- return Nullsv;
- if (HeKLEN(entry) == HEf_SVKEY)
- return sv_mortalcopy(HeKEY_sv(entry));
- return sv_2mortal(newSVpvn(HeKEY(entry), HeKLEN(entry)));
- }
- }
- return Nullsv;
-}
+ /* The initial slot is used to link the arenas together, so it isn't to be
+ linked into the list of ready-to-use bodies. */
-/* Look for an entry in the array whose value has the same SV as val;
- * If so, return the index, otherwise return -1. */
+ start += size;
-STATIC I32
-S_find_array_subscript(pTHX_ AV *av, SV* val)
-{
- SV** svp;
- I32 i;
- if (!av || SvMAGICAL(av) || !AvARRAY(av) ||
- (AvFILLp(av) > FUV_MAX_SEARCH_SIZE))
- return -1;
+ *root = (void *)start;
- svp = AvARRAY(av);
- for (i=AvFILLp(av); i>=0; i--) {
- if (svp[i] == val && svp[i] != &PL_sv_undef)
- return i;
+ while (start < end) {
+ char * const next = start + size;
+ *(void**) start = (void *)next;
+ start = next;
}
- return -1;
+ *(void **)start = 0;
+
+ return *root;
}
-/* S_varname(): return the name of a variable, optionally with a subscript.
- * If gv is non-zero, use the name of that global, along with gvtype (one
- * of "$", "@", "%"); otherwise use the name of the lexical at pad offset
- * targ. Depending on the value of the subscript_type flag, return:
- */
+/* grab a new thing from the free list, allocating more if necessary */
-#define FUV_SUBSCRIPT_NONE 1 /* "@foo" */
-#define FUV_SUBSCRIPT_ARRAY 2 /* "$foo[aindex]" */
-#define FUV_SUBSCRIPT_HASH 3 /* "$foo{keyname}" */
-#define FUV_SUBSCRIPT_WITHIN 4 /* "within @foo" */
+/* 1st, the inline version */
-STATIC SV*
-S_varname(pTHX_ GV *gv, const char gvtype, PADOFFSET targ,
- SV* keyname, I32 aindex, int subscript_type)
-{
+#define new_body_inline(xpv, size, sv_type) \
+ STMT_START { \
+ void ** const r3wt = &PL_body_roots[sv_type]; \
+ LOCK_SV_MUTEX; \
+ xpv = *((void **)(r3wt)) \
+ ? *((void **)(r3wt)) : S_more_bodies(aTHX_ size, sv_type); \
+ *(r3wt) = *(void**)(xpv); \
+ UNLOCK_SV_MUTEX; \
+ } STMT_END
- SV * const name = sv_newmortal();
- if (gv) {
- char buffer[2];
- buffer[0] = gvtype;
- buffer[1] = 0;
+/* now use the inline version in the proper function */
- /* as gv_fullname4(), but add literal '^' for $^FOO names */
+#ifndef PURIFY
- gv_fullname4(name, gv, buffer, 0);
+/* This isn't being used with -DPURIFY, so don't declare it. Otherwise
+ compilers issue warnings. */
- if ((unsigned int)SvPVX(name)[1] <= 26) {
- buffer[0] = '^';
- buffer[1] = SvPVX(name)[1] + 'A' - 1;
+STATIC void *
+S_new_body(pTHX_ size_t size, svtype sv_type)
+{
+ void *xpv;
+ new_body_inline(xpv, size, sv_type);
+ return xpv;
+}
- /* Swap the 1 unprintable control character for the 2 byte pretty
- version - ie substr($name, 1, 1) = $buffer; */
- sv_insert(name, 1, 1, buffer, 2);
- }
- }
- else {
- U32 unused;
- CV * const cv = find_runcv(&unused);
- SV *sv;
- AV *av;
+#endif
- if (!cv || !CvPADLIST(cv))
- return Nullsv;
- av = (AV*)(*av_fetch(CvPADLIST(cv), 0, FALSE));
- sv = *av_fetch(av, targ, FALSE);
- /* SvLEN in a pad name is not to be trusted */
- sv_setpv(name, SvPV_nolen_const(sv));
- }
+/* return a thing to the free list */
- if (subscript_type == FUV_SUBSCRIPT_HASH) {
- SV * const sv = NEWSV(0,0);
- *SvPVX(name) = '$';
- Perl_sv_catpvf(aTHX_ name, "{%s}",
- pv_display(sv,SvPVX_const(keyname), SvCUR(keyname), 0, 32));
- SvREFCNT_dec(sv);
- }
- else if (subscript_type == FUV_SUBSCRIPT_ARRAY) {
- *SvPVX(name) = '$';
- Perl_sv_catpvf(aTHX_ name, "[%"IVdf"]", (IV)aindex);
- }
- else if (subscript_type == FUV_SUBSCRIPT_WITHIN)
- sv_insert(name, 0, 0, "within ", 7);
+#define del_body(thing, root) \
+ STMT_START { \
+ void ** const thing_copy = (void **)thing;\
+ LOCK_SV_MUTEX; \
+ *thing_copy = *root; \
+ *root = (void*)thing_copy; \
+ UNLOCK_SV_MUTEX; \
+ } STMT_END
- return name;
-}
+/*
+ Revisiting type 3 arenas, there are 4 body-types which have some
+ members that are never accessed. They are XPV, XPVIV, XPVAV,
+ XPVHV, which have corresponding types: xpv_allocated,
+ xpviv_allocated, xpvav_allocated, xpvhv_allocated,
+ For these types, the arenas are carved up into *_allocated size
+ chunks, we thus avoid wasted memory for those unaccessed members.
+ When bodies are allocated, we adjust the pointer back in memory by
+ the size of the bit not allocated, so it's as if we allocated the
+ full structure. (But things will all go boom if you write to the
+ part that is "not there", because you'll be overwriting the last
+ members of the preceding structure in memory.)
-/*
-=for apidoc find_uninit_var
+ We calculate the correction using the STRUCT_OFFSET macro. For example, if
+ xpv_allocated is the same structure as XPV then the two OFFSETs sum to zero,
+ and the pointer is unchanged. If the allocated structure is smaller (no
+ initial NV actually allocated) then the net effect is to subtract the size
+ of the NV from the pointer, to return a new pointer as if an initial NV were
+ actually allocated.
-Find the name of the undefined variable (if any) that caused the operator o
-to issue a "Use of uninitialized value" warning.
-If match is true, only return a name if it's value matches uninit_sv.
-So roughly speaking, if a unary operator (such as OP_COS) generates a
-warning, then following the direct child of the op may yield an
-OP_PADSV or OP_GV that gives the name of the undefined variable. On the
-other hand, with OP_ADD there are two branches to follow, so we only print
-the variable name if we get an exact match.
+ This is the same trick as was used for NV and IV bodies. Ironically it
+ doesn't need to be used for NV bodies any more, because NV is now at the
+ start of the structure. IV bodies don't need it either, because they are
+ no longer allocated. */
-The name is returned as a mortal SV.
+/* The following 2 arrays hide the above details in a pair of
+ lookup-tables, allowing us to be body-type agnostic.
-Assumes that PL_op is the op that originally triggered the error, and that
-PL_comppad/PL_curpad points to the currently executing pad.
+ size maps svtype to its body's allocated size.
+ offset maps svtype to the body-pointer adjustment needed
-=cut
+ NB: elements in latter are 0 or <0, and are added during
+ allocation, and subtracted during deallocation. It may be clearer
+ to invert the values, and call it shrinkage_by_svtype.
*/
-STATIC SV *
-S_find_uninit_var(pTHX_ OP* obase, SV* uninit_sv, bool match)
-{
- dVAR;
- SV *sv;
- AV *av;
- GV *gv;
- OP *o, *o2, *kid;
-
- 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;
-
- end = start + (count-1) * size;
-
- /* 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. */
-
- start += size;
-
- *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;
- while (start < end) {
- char * const next = start + size;
- *(void**) start = (void *)next;
- start = next;
+ if (new_type != SVt_PV && SvIsCOW(sv)) {
+ sv_force_normal_flags(sv, 0);
}
- *(void **)start = 0;
-
- return *root;
-}
-
-/* grab a new thing from the free list, allocating more if necessary */
-
-/* 1st, the inline version */
-
-#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
-/* now use the inline version in the proper function */
+ if (old_type == new_type)
+ return;
-#ifndef PURIFY
+ if (old_type > new_type)
+ Perl_croak(aTHX_ "sv_upgrade from type %d down to type %d",
+ (int)old_type, (int)new_type);
-/* This isn't being used with -DPURIFY, so don't declare it. Otherwise
- compilers issue warnings. */
-STATIC void *
-S_new_body(pTHX_ size_t size, svtype sv_type)
-{
- void *xpv;
- new_body_inline(xpv, size, sv_type);
- return xpv;
-}
+ old_body = SvANY(sv);
-#endif
+ /* Copying structures onto other structures that have been neatly zeroed
+ has a subtle gotcha. Consider XPVMG
-/* return a thing to the free list */
+ +------+------+------+------+------+-------+-------+
+ | NV | CUR | LEN | IV | MAGIC | STASH |
+ +------+------+------+------+------+-------+-------+
+ 0 4 8 12 16 20 24 28
-#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
+ 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:
-/*
- 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,
+ +------+------+------+------+------+-------+-------+------+
+ | NV | CUR | LEN | IV | MAGIC | STASH | ??? |
+ +------+------+------+------+------+-------+-------+------+
+ 0 4 8 12 16 20 24 28 32
- 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.)
+ so what happens if you allocate memory for this structure:
- 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.
+ +------+------+------+------+------+-------+-------+------+------+...
+ | NV | CUR | LEN | IV | MAGIC | STASH | GP | NAME |
+ +------+------+------+------+------+-------+-------+------+------+...
+ 0 4 8 12 16 20 24 28 32 36
- 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. */
+ 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.
-/* The following 2 arrays hide the above details in a pair of
- lookup-tables, allowing us to be body-type agnostic.
+ (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)
- size maps svtype to its body's allocated size.
- offset maps svtype to the body-pointer adjustment needed
-
- 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 */
-};
-
-#define HADNV FALSE
-#define NONV TRUE
-
-#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
-
-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),
- STRUCT_OFFSET(XPV, xpv_len) + sizeof (((XPV*)SvANY((SV*)0))->xpv_len)
- + STRUCT_OFFSET(xpv_allocated, xpv_cur) - STRUCT_OFFSET(XPV, xpv_cur),
- + STRUCT_OFFSET(xpv_allocated, xpv_cur) - STRUCT_OFFSET(XPV, xpv_cur)
- , FALSE, NONV, HASARENA},
- /* 12 */
- {sizeof(xpviv_allocated),
- STRUCT_OFFSET(XPVIV, xiv_u) + sizeof (((XPVIV*)SvANY((SV*)0))->xiv_u)
- + STRUCT_OFFSET(xpviv_allocated, xpv_cur) - STRUCT_OFFSET(XPVIV, xpv_cur),
- + STRUCT_OFFSET(xpviv_allocated, xpv_cur) - STRUCT_OFFSET(XPVIV, xpv_cur)
- , FALSE, NONV, HASARENA},
- /* 20 */
- {sizeof(XPVNV),
- STRUCT_OFFSET(XPVNV, xiv_u) + sizeof (((XPVNV*)SvANY((SV*)0))->xiv_u),
- 0, FALSE, HADNV, HASARENA},
- /* 28 */
- {sizeof(XPVMG),
- STRUCT_OFFSET(XPVMG, xmg_stash) + sizeof (((XPVMG*)SvANY((SV*)0))->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),
- STRUCT_OFFSET(XPVAV, xmg_stash)
- + sizeof (((XPVAV*)SvANY((SV *)0))->xmg_stash)
- + STRUCT_OFFSET(xpvav_allocated, xav_fill)
- - STRUCT_OFFSET(XPVAV, xav_fill),
- STRUCT_OFFSET(xpvav_allocated, xav_fill)
- - STRUCT_OFFSET(XPVAV, xav_fill), TRUE, HADNV, HASARENA},
- /* 20 */
- {sizeof(xpvhv_allocated),
- STRUCT_OFFSET(XPVHV, xmg_stash)
- + sizeof (((XPVHV*)SvANY((SV *)0))->xmg_stash)
- + STRUCT_OFFSET(xpvhv_allocated, xhv_fill)
- - STRUCT_OFFSET(XPVHV, xhv_fill),
- STRUCT_OFFSET(xpvhv_allocated, xhv_fill)
- - STRUCT_OFFSET(XPVHV, 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)
-
-#define del_body_allocated(p, sv_type) \
- del_body(p - bodies_by_type[sv_type].offset, &PL_body_roots[sv_type])
-
-
-#define my_safemalloc(s) (void*)safemalloc(s)
-#define my_safecalloc(s) (void*)safecalloc(s, 1)
-#define my_safefree(p) safefree((char*)p)
-
-#ifdef PURIFY
-
-#define new_XNV() my_safemalloc(sizeof(XPVNV))
-#define del_XNV(p) my_safefree(p)
-
-#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)
-
-#define new_XPVHV() my_safemalloc(sizeof(XPVHV))
-#define del_XPVHV(p) my_safefree(p)
-
-#define new_XPVMG() my_safemalloc(sizeof(XPVMG))
-#define del_XPVMG(p) my_safefree(p)
-
-#define new_XPVGV() my_safemalloc(sizeof(XPVGV))
-#define del_XPVGV(p) my_safefree(p)
-
-#else /* !PURIFY */
-
-#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)
-
-#define new_XPVAV() new_body_allocated(SVt_PVAV)
-#define del_XPVAV(p) del_body_allocated(p, SVt_PVAV)
-
-#define new_XPVHV() new_body_allocated(SVt_PVHV)
-#define del_XPVHV(p) del_body_allocated(p, SVt_PVHV)
-
-#define new_XPVMG() new_body_type(SVt_PVMG)
-#define del_XPVMG(p) del_body_type(p, SVt_PVMG)
-
-#define new_XPVGV() new_body_type(SVt_PVGV)
-#define del_XPVGV(p) del_body_type(p, SVt_PVGV)
-
-#endif /* PURIFY */
-
-/* no arena for you! */
-
-#define new_NOARENA(details) \
- my_safemalloc((details)->size - (details)->offset)
-#define new_NOARENAZ(details) \
- my_safecalloc((details)->size - (details)->offset)
-
-/*
-=for apidoc sv_upgrade
-
-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>.
-
-=cut
-*/
-
-void
-Perl_sv_upgrade(pTHX_ register SV *sv, U32 new_type)
-{
- void* old_body;
- void* new_body;
- const U32 old_type = SvTYPE(sv);
- const struct body_details *const old_type_details
- = bodies_by_type + old_type;
- const struct body_details *new_type_details = bodies_by_type + new_type;
-
- if (new_type != SVt_PV && SvIsCOW(sv)) {
- sv_force_normal_flags(sv, 0);
- }
-
- if (old_type == new_type)
- return;
-
- if (old_type > new_type)
- Perl_croak(aTHX_ "sv_upgrade from type %d down to type %d",
- (int)old_type, (int)new_type);
-
-
- old_body = SvANY(sv);
-
- /* Copying structures onto other structures that have been neatly zeroed
- has a subtle gotcha. Consider XPVMG
-
- +------+------+------+------+------+-------+-------+
- | NV | CUR | LEN | IV | MAGIC | STASH |
- +------+------+------+------+------+-------+-------+
- 0 4 8 12 16 20 24 28
-
- where NVs are aligned to 8 bytes, so that sizeof that structure is
- actually 32 bytes long, with 4 bytes of padding at the end:
-
- +------+------+------+------+------+-------+-------+------+
- | NV | CUR | LEN | IV | MAGIC | STASH | ??? |
- +------+------+------+------+------+-------+-------+------+
- 0 4 8 12 16 20 24 28 32
-
- so what happens if you allocate memory for this structure:
-
- +------+------+------+------+------+-------+-------+------+------+...
- | NV | CUR | LEN | IV | MAGIC | STASH | GP | NAME |
- +------+------+------+------+------+-------+-------+------+------+...
- 0 4 8 12 16 20 24 28 32 36
-
- zero it, then copy sizeof(XPVMG) bytes on top of it? Not quite what you
- expect, because you copy the area marked ??? onto GP. Now, ??? may have
- started out as zero once, but it's quite possible that it isn't. So now,
- rather than a nicely zeroed GP, you have it pointing somewhere random.
- Bugs ensue.
-
- (In fact, GP ends up pointing at a previous GP structure, because the
- principle cause of the padding in XPVMG getting garbage is a copy of
- sizeof(XPVMG) bytes from a XPVGV structure in sv_unglob)
-
- So we are careful and work out the size of used parts of all the
- structures. */
+ So we are careful and work out the size of used parts of all the
+ structures. */
switch (old_type) {
case SVt_NULL:
/* 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;
+ 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,
+ Copy((char *)old_body + old_type_details->offset,
+ (char *)new_body + old_type_details->offset,
old_type_details->copy, char);
}
#ifdef PURIFY
my_safefree(old_body);
#else
- del_body((void*)((char*)old_body - old_type_details->offset),
+ del_body((void*)((char*)old_body + old_type_details->offset),
&PL_body_roots[old_type]);
#endif
}
/* 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++) {
+ const char *s = SvPVX_const(sv);
+ const char * const end = s + SvCUR(sv);
+ for ( ; s < end && d < limit; s++ ) {
int ch = *s & 0xFF;
if (ch & 128 && !isPRINT_LC(ch)) {
*d++ = 'M';
}
#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 (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 (SvIsUV(sv)) {
- return (IV)(SvUVX(sv));
- }
- else {
- return SvIVX(sv);
- }
- }
+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. NWC */
+ * IV or UV at same time to avoid this. */
+ /* IV-over-UV optimisation - choose to cache IV if possible */
if (SvTYPE(sv) == SVt_NV)
sv_upgrade(sv, SVt_PVNV);
)
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
+ /* 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, we need to cache the
+ 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.
*/
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);
}
PTR2UV(sv), SvNVX(sv)));
#endif
-
#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;
- }
+ (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 slot will have been set from value returned by
+ /* 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);
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;
+ sv_2iuv_non_preserve (sv, numtype);
}
}
#endif /* NV_PRESERVES_UV */
}
- } else {
- if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED))
- report_uninit(sv);
+ }
+ 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_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)) {
+ UV value;
+ const int numtype
+ = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
+
+ if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
+ == IS_NUMBER_IN_UV) {
+ /* It's definitely an integer */
+ if (numtype & IS_NUMBER_NEG) {
+ if (value < (UV)IV_MIN)
+ return -(IV)value;
+ } else {
+ if (value < (UV)IV_MAX)
+ return (IV)value;
+ }
+ }
+ if (!numtype) {
+ if (ckWARN(WARN_NUMERIC))
+ not_a_number(sv);
+ }
+ return I_V(Atof(SvPVX_const(sv)));
+ }
+ if (SvROK(sv)) {
+ goto return_rok;
+ }
+ assert(SvTYPE(sv) >= SVt_PVMG);
+ /* This falls through to the report_uninit inside S_sv_2iuv_common. */
+ }
+ if (SvTHINKFIRST(sv)) {
+ if (SvROK(sv)) {
+ return_rok:
+ if (SvAMAGIC(sv)) {
+ SV * const tmpstr=AMG_CALLun(sv,numer);
+ if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
+ return SvIV(tmpstr);
+ }
+ }
+ return PTR2IV(SvRV(sv));
+ }
+ if (SvIsCOW(sv)) {
+ sv_force_normal_flags(sv, 0);
+ }
+ if (SvREADONLY(sv) && !SvOK(sv)) {
+ if (ckWARN(WARN_UNINITIALIZED))
+ report_uninit(sv);
+ return 0;
+ }
+ }
+ if (!SvIOKp(sv)) {
+ if (S_sv_2iuv_common(aTHX_ sv))
+ return 0;
}
DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
PTR2UV(sv),SvIVX(sv)));
return SvUVX(sv);
if (SvNOKp(sv))
return U_V(SvNVX(sv));
- if (SvPOKp(sv) && SvLEN(sv))
- return asUV(sv);
- if (!SvROK(sv)) {
- if (!(SvFLAGS(sv) & SVs_PADTMP)) {
- if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
- report_uninit(sv);
+ if (SvPOKp(sv) && SvLEN(sv)) {
+ UV value;
+ const int numtype
+ = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
+
+ if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
+ == IS_NUMBER_IN_UV) {
+ /* It's definitely an integer */
+ if (!(numtype & IS_NUMBER_NEG))
+ return value;
}
- return 0;
+ if (!numtype) {
+ if (ckWARN(WARN_NUMERIC))
+ not_a_number(sv);
+ }
+ return U_V(Atof(SvPVX_const(sv)));
+ }
+ if (SvROK(sv)) {
+ goto return_rok;
}
+ assert(SvTYPE(sv) >= SVt_PVMG);
+ /* This falls through to the report_uninit inside S_sv_2iuv_common. */
}
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));
+ return_rok:
+ if (SvAMAGIC(sv)) {
+ SV *const tmpstr = AMG_CALLun(sv,numer);
+ if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
+ return SvUV(tmpstr);
+ }
+ }
+ return PTR2UV(SvRV(sv));
}
if (SvIsCOW(sv)) {
sv_force_normal_flags(sv, 0);
return 0;
}
}
- if (SvIOKp(sv)) {
- if (SvIsUV(sv)) {
- return SvUVX(sv);
- }
- else {
- return (UV)SvIVX(sv);
- }
+ if (!SvIOKp(sv)) {
+ if (S_sv_2iuv_common(aTHX_ sv))
+ return 0;
}
- 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 (SvTYPE(sv) == SVt_NV)
- sv_upgrade(sv, SVt_PVNV);
+ DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
+ PTR2UV(sv),SvUVX(sv)));
+ return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
+}
- (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)));
+/*
+=for apidoc sv_2nv
- } 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)));
+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
+*/
+
+NV
+Perl_sv_2nv(pTHX_ register SV *sv)
+{
+ 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)) {
+ goto return_rok;
+ }
+ assert(SvTYPE(sv) >= SVt_PVMG);
+ /* This falls through to the report_uninit near the end of the
+ function. */
+ } else if (SvTHINKFIRST(sv)) {
+ if (SvROK(sv)) {
+ return_rok:
+ if (SvAMAGIC(sv)) {
+ SV *const tmpstr = AMG_CALLun(sv,numer);
+ if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
+ return SvNV(tmpstr);
+ }
}
- /* 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 */
+ return PTR2NV(SvRV(sv));
}
- 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 (SvIsCOW(sv)) {
+ sv_force_normal_flags(sv, 0);
+ }
+ if (SvREADONLY(sv) && !SvOK(sv)) {
+ if (ckWARN(WARN_UNINITIALIZED))
+ report_uninit(sv);
+ return 0.0;
}
- }
- 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.
- */
-
- /* 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 ((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);
-
-#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
-
-#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.
-
-=cut
-*/
-
-NV
-Perl_sv_2nv(pTHX_ register SV *sv)
-{
- if (!sv)
- return 0.0;
- if (SvGMAGICAL(sv)) {
- mg_get(sv);
- if (SvNOKp(sv))
- return SvNVX(sv);
- if (SvPOKp(sv) && SvLEN(sv)) {
- if (!SvIOKp(sv) && ckWARN(WARN_NUMERIC) &&
- !grok_number(SvPVX_const(sv), SvCUR(sv), NULL))
- not_a_number(sv);
- return Atof(SvPVX_const(sv));
- }
- if (SvIOKp(sv)) {
- if (SvIsUV(sv))
- return (NV)SvUVX(sv);
- else
- return (NV)SvIVX(sv);
- }
- if (!SvROK(sv)) {
- if (!(SvFLAGS(sv) & SVs_PADTMP)) {
- if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
- report_uninit(sv);
- }
- return (NV)0;
- }
- }
- if (SvTHINKFIRST(sv)) {
- if (SvROK(sv)) {
- SV* tmpstr;
- if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
- (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv))))
- return SvNV(tmpstr);
- return PTR2NV(SvRV(sv));
- }
- if (SvIsCOW(sv)) {
- sv_force_normal_flags(sv, 0);
- }
- if (SvREADONLY(sv) && !SvOK(sv)) {
- if (ckWARN(WARN_UNINITIALIZED))
- report_uninit(sv);
- return 0.0;
- }
- }
- 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)) {
- 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
+ }
+ if (SvTYPE(sv) < SVt_NV) {
+ /* The logic to use SVt_PVNV if necessary is in sv_upgrade. */
+ sv_upgrade(sv, SVt_NV);
+#ifdef USE_LONG_DOUBLE
+ DEBUG_c({
+ STORE_NUMERIC_LOCAL_SET_STANDARD();
+ PerlIO_printf(Perl_debug_log,
+ "0x%"UVxf" num(%" PERL_PRIgldbl ")\n",
+ PTR2UV(sv), SvNVX(sv));
+ RESTORE_NUMERIC_LOCAL();
+ });
+#else
+ DEBUG_c({
+ STORE_NUMERIC_LOCAL_SET_STANDARD();
+ PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%"NVgf")\n",
+ PTR2UV(sv), SvNVX(sv));
+ RESTORE_NUMERIC_LOCAL();
+ });
+#endif
+ }
+ else if (SvTYPE(sv) < SVt_PVNV)
+ sv_upgrade(sv, SVt_PVNV);
+ if (SvNOKp(sv)) {
+ 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
}
else if (SvPOKp(sv) && SvLEN(sv)) {
UV value;
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. */
}
+ SvIOK_on(sv);
} else {
/* between IV_MAX and NV(UV_MAX).
Could be slightly > UV_MAX */
if (value == nv_as_uv && SvUVX(sv) != UV_MAX) {
SvNOK_on(sv);
- SvIOK_on(sv);
- } else {
- SvIOK_on(sv);
}
+ SvIOK_on(sv);
}
}
}
else {
if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED))
report_uninit(sv);
- if (SvTYPE(sv) < SVt_NV)
- /* Typically the caller expects that sv_any is not NULL now. */
- /* XXX Ilya implies that this is a bug in callers that assume this
- and ideally should be fixed. */
- sv_upgrade(sv, SVt_NV);
+ assert (SvTYPE(sv) >= SVt_NV);
+ /* Typically the caller expects that sv_any is not NULL now. */
+ /* XXX Ilya implies that this is a bug in callers that assume this
+ and ideally should be fixed. */
return 0.0;
}
#if defined(USE_LONG_DOUBLE)
return SvNVX(sv);
}
-/* asIV(): extract an integer from the string value of an SV.
- * Caller must validate PVX */
-
-STATIC IV
-S_asIV(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) {
- 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)));
-}
-
-/* asUV(): extract an unsigned integer from the string value of an SV
- * Caller must validate PVX */
-
-STATIC UV
-S_asUV(pTHX_ SV *sv)
-{
- UV value;
- const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
-
- if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
- == IS_NUMBER_IN_UV) {
- /* It's definitely an integer */
- if (!(numtype & IS_NUMBER_NEG))
- return value;
- }
- if (!numtype) {
- if (ckWARN(WARN_NUMERIC))
- not_a_number(sv);
- }
- return U_V(Atof(SvPVX_const(sv)));
-}
-
/* uiv_2buf(): private routine for use by sv_2pv_flags(): print an IV or
* UV as a string towards the end of buf, and return pointers to start and
* end of it.
return ptr;
}
-/*
-=for apidoc sv_2pv_flags
+/* stringify_regexp(): private routine for use by sv_2pv_flags(): converts
+ * a regexp to its stringified form.
+ */
-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.
+static char *
+S_stringify_regexp(pTHX_ SV *sv, MAGIC *mg, STRLEN *lp) {
+ const regexp * const re = (regexp *)mg->mg_obj;
+
+ if (!mg->mg_ptr) {
+ const char *fptr = "msix";
+ char reflags[6];
+ char ch;
+ int left = 0;
+ int right = 4;
+ bool need_newline = 0;
+ U16 reganch = (U16)((re->reganch & PMf_COMPILETIME) >> 12);
+
+ while((ch = *fptr++)) {
+ if(reganch & 1) {
+ reflags[left++] = ch;
+ }
+ else {
+ reflags[right--] = ch;
+ }
+ reganch >>= 1;
+ }
+ if(left != 4) {
+ reflags[left] = '-';
+ left = 5;
+ }
-=cut
+ 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);
+ 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;
+}
+
+/*
+=for apidoc sv_2pv_flags
+
+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
*/
char *
{
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)
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 (SvIOKp(sv) || SvNOKp(sv)) {
+ char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */
+ STRLEN len;
+
+ if (SvIOKp(sv)) {
+ len = SvIsUV(sv) ? my_sprintf(tbuf,"%"UVuf, (UV)SvUVX(sv))
+ : my_sprintf(tbuf,"%"IVdf, (IV)SvIVX(sv));
+ } else {
+ Gconvert(SvNVX(sv), NV_DIG, 0, tbuf);
+ len = strlen(tbuf);
+ }
+ if (SvROK(sv)) { /* XXX Skip this when sv_pvn_force calls */
+ /* Sneaky stuff here */
+ SV * const tsv = newSVpvn(tbuf, len);
+
+ sv_2mortal(tsv);
+ if (lp)
+ *lp = SvCUR(tsv);
+ return SvPVX(tsv);
}
- 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;
- }
- }
- }
+ dVAR;
- 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;
+#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 (SvROK(sv)) {
+ goto return_rok;
+ }
+ assert(SvTYPE(sv) >= SVt_PVMG);
+ /* This falls through to the report_uninit near the end of the
+ function. */
+ } else if (SvTHINKFIRST(sv)) {
+ if (SvROK(sv)) {
+ return_rok:
+ if (SvAMAGIC(sv)) {
+ SV *const tmpstr = AMG_CALLun(sv,string);
+ if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
+ /* Unwrap this: */
+ /* char *pv = lp ? SvPV(tmpstr, *lp) : SvPV_nolen(tmpstr);
+ */
+
+ char *pv;
+ if ((SvFLAGS(tmpstr) & (SVf_POK)) == SVf_POK) {
+ if (flags & SV_CONST_RETURN) {
+ pv = (char *) SvPVX_const(tmpstr);
+ } else {
+ pv = (flags & SV_MUTABLE_RETURN)
+ ? SvPVX_mutable(tmpstr) : SvPVX(tmpstr);
}
- 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;
+ *lp = SvCUR(tmpstr);
+ } else {
+ pv = sv_2pv_flags(tmpstr, lp, flags);
}
- /* 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;
+ if (SvUTF8(tmpstr))
+ SvUTF8_on(sv);
+ else
+ SvUTF8_off(sv);
+ return pv;
}
- 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));
+ }
+ {
+ 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));
}
- else
- Perl_sv_setpvf(aTHX_ tsv, "%s(0x%"UVxf")", typestr, PTR2UV(sv));
- goto tokensaveref;
+ if (lp)
+ *lp = SvCUR(tsv);
+ return SvPVX(tsv);
}
- if (lp)
- *lp = strlen(typestr);
- return (char *)typestr;
}
if (SvREADONLY(sv) && !SvOK(sv)) {
if (ckWARN(WARN_UNINITIALIZED))
if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED))
report_uninit(sv);
if (lp)
- *lp = 0;
+ *lp = 0;
if (SvTYPE(sv) < SVt_PV)
/* Typically the caller expects that sv_any is not NULL now. */
sv_upgrade(sv, SVt_PV);
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);
- }
}
/*
* had a FLAG in SVs to signal if there are any hibit
* chars in the PV. Given that there isn't such a flag
* make the loop as fast as possible. */
- const U8 *s = (U8 *) SvPVX_const(sv);
+ const U8 * const s = (U8 *) SvPVX_const(sv);
const U8 * const e = (U8 *) SvEND(sv);
const U8 *t = s;
- int hibit = 0;
while (t < e) {
const U8 ch = *t++;
- if ((hibit = !NATIVE_IS_INVARIANT(ch)))
+ /* Check for hi bit */
+ if (!NATIVE_IS_INVARIANT(ch)) {
+ STRLEN len = SvCUR(sv) + 1; /* Plus the \0 */
+ U8 * const recoded = bytes_to_utf8((U8*)s, &len);
+
+ SvPV_free(sv); /* No longer using what was there before. */
+ SvPV_set(sv, (char*)recoded);
+ SvCUR_set(sv, len - 1);
+ SvLEN_set(sv, len); /* No longer know the real size. */
break;
- }
- if (hibit) {
- STRLEN len = SvCUR(sv) + 1; /* Plus the \0 */
- U8 * const recoded = bytes_to_utf8((U8*)s, &len);
-
- SvPV_free(sv); /* No longer using what was there before. */
-
- SvPV_set(sv, (char*)recoded);
- SvCUR_set(sv, len - 1);
- SvLEN_set(sv, len); /* No longer know the real size. */
+ }
}
/* Mark as UTF-8 even if no hibit - saves scanning loop */
SvUTF8_on(sv);
SvIV_set(dstr, SvIVX(sstr));
}
if (SvVOK(sstr)) {
- MAGIC *smg = mg_find(sstr,PERL_MAGIC_vstring);
+ const MAGIC * const smg = mg_find(sstr,PERL_MAGIC_vstring);
sv_magic(dstr, NULL, PERL_MAGIC_vstring,
smg->mg_ptr, smg->mg_len);
SvRMAGICAL_on(dstr);
void
Perl_sv_catsv_flags(pTHX_ SV *dsv, register SV *ssv, I32 flags)
{
- const char *spv;
- STRLEN slen;
if (ssv) {
- if ((spv = SvPV_const(ssv, slen))) {
+ STRLEN slen;
+ const char *spv = SvPV_const(ssv, slen);
+ if (spv) {
/* sutf8 and dutf8 were type bool, but under USE_ITHREADS,
gcc version 2.95.2 20000220 (Debian GNU/Linux) for
Linux xxx 2.2.17 on sparc64 with gcc -O2, we erroneously
if (dutf8 != sutf8) {
if (dutf8) {
/* Not modifying source SV, so taking a temporary copy. */
- SV* csv = sv_2mortal(newSVpvn(spv, slen));
+ SV* const csv = sv_2mortal(newSVpvn(spv, slen));
sv_utf8_upgrade(csv);
spv = SvPV_const(csv, slen);
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) {
screamer2:
if (rslen) {
- register const STDCHAR *bpe = buf + sizeof(buf);
+ register const STDCHAR * const bpe = buf + sizeof(buf);
bp = buf;
while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = (STDCHAR)i) != rslast && bp < bpe)
; /* keep reading */
gp_free((GV*)sv);
if (GvSTASH(sv)) {
sv_del_backref((SV*)GvSTASH(sv), sv);
- GvSTASH(sv) = Nullhv;
+ GvSTASH(sv) = NULL;
}
sv_unmagic(sv, PERL_MAGIC_glob);
Safefree(GvNAME(sv));
case '1': case '2': case '3':
case '4': case '5': case '6':
case '7': case '8': case '9':
- while (isDIGIT(**pattern))
- var = var * 10 + (*(*pattern)++ - '0');
+ var = *(*pattern)++ - '0';
+ while (isDIGIT(**pattern)) {
+ I32 tmp = var * 10 + (*(*pattern)++ - '0');
+ if (tmp < var)
+ Perl_croak(aTHX_ "Integer overflow in format string for %s", (PL_op ? OP_NAME(PL_op) : "sv_vcatpvfn"));
+ var = tmp;
+ }
}
return var;
}
}
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 (vectorarg) {
if (args)
vecsv = va_arg(*args, SV*);
- else
- vecsv = (evix ? evix <= svmax : svix < svmax) ?
- svargs[evix ? evix-1 : svix++] : &PL_sv_undef;
+ else if (evix) {
+ vecsv = (evix > 0 && evix <= svmax)
+ ? svargs[evix-1] : &PL_sv_undef;
+ } else {
+ vecsv = svix < svmax ? svargs[svix++] : &PL_sv_undef;
+ }
dotstr = SvPV_const(vecsv, dotstrlen);
+ /* Keep the DO_UTF8 test *after* the SvPV call, else things go
+ bad with tied or overloaded values that return UTF8. */
if (DO_UTF8(vecsv))
is_utf8 = TRUE;
+ else if (has_utf8) {
+ vecsv = sv_mortalcopy(vecsv);
+ sv_utf8_upgrade(vecsv);
+ dotstr = SvPV_const(vecsv, dotstrlen);
+ is_utf8 = TRUE;
+ }
}
if (args) {
VECTORIZE_ARGS
}
- else if (efix ? efix <= svmax : svix < svmax) {
+ else if (efix ? (efix > 0 && efix <= svmax) : svix < svmax) {
vecsv = svargs[efix ? efix-1 : svix++];
vecstr = (U8*)SvPV_const(vecsv,veclen);
vec_utf8 = DO_UTF8(vecsv);
- /* if this is a version object, we need to return the
- * stringified representation (which the SvPVX_const has
- * already done for us), but not vectorize the args
+
+ /* if this is a version object, we need to convert
+ * back into v-string notation and then let the
+ * vectorize happen normally
*/
- if ( *q == 'd' && sv_derived_from(vecsv,"version") )
- {
- q++; /* skip past the rest of the %vd format */
- eptr = (const char *) vecstr;
- elen = veclen;
- vectorize=FALSE;
- goto string;
+ if (sv_derived_from(vecsv, "version")) {
+ char *version = savesvpv(vecsv);
+ vecsv = sv_newmortal();
+ /* scan_vstring is expected to be called during
+ * tokenization, so we need to fake up the end
+ * of the buffer for it
+ */
+ PL_bufend = version + veclen;
+ scan_vstring(version, vecsv);
+ vecstr = (U8*)SvPV_const(vecsv, veclen);
+ vec_utf8 = DO_UTF8(vecsv);
+ Safefree(version);
}
}
else {
if (*q == '%') {
eptr = q++;
elen = 1;
+ if (vectorize) {
+ c = '%';
+ goto unknown;
+ }
goto string;
}
- if (vectorize)
- argsv = vecsv;
- else if (!args)
- argsv = (efix ? efix <= svmax : svix < svmax) ?
- svargs[efix ? efix-1 : svix++] : &PL_sv_undef;
+ if (!vectorize && !args) {
+ if (efix) {
+ const I32 i = efix-1;
+ argsv = (i >= 0 && i < svmax) ? svargs[i] : &PL_sv_undef;
+ } else {
+ argsv = (svix >= 0 && svix < svmax)
+ ? svargs[svix++] : &PL_sv_undef;
+ }
+ }
switch (c = *q++) {
/* STRINGS */
case 'c':
- uv = (args && !vectorize) ? va_arg(*args, int) : SvIVx(argsv);
+ if (vectorize)
+ goto unknown;
+ uv = (args) ? va_arg(*args, int) : SvIVx(argsv);
if ((uv > 255 ||
(!UNI_IS_INVARIANT(uv) && SvUTF8(sv)))
&& !IN_BYTES) {
goto string;
case 's':
- if (args && !vectorize) {
+ if (vectorize)
+ goto unknown;
+ if (args) {
eptr = va_arg(*args, char*);
if (eptr)
#ifdef MACOS_TRADITIONAL
}
string:
- vectorize = FALSE;
if (has_precis && elen > precis)
elen = precis;
break;
*--ptr = '0';
break;
case 2:
+ if (!uv)
+ alt = FALSE;
do {
dig = uv & 1;
*--ptr = '0' + dig;
case 'e': case 'E':
case 'f':
case 'g': case 'G':
+ if (vectorize)
+ goto unknown;
/* This is evil, but floating point is even more evil */
}
/* now we need (long double) if intsize == 'q', else (double) */
- nv = (args && !vectorize) ?
+ nv = (args) ?
#if LONG_DOUBLESIZE > DOUBLESIZE
intsize == 'q' ?
va_arg(*args, long double) :
: SvNVx(argsv);
need = 0;
- vectorize = FALSE;
if (c != 'e' && c != 'E') {
i = PERL_INT_MIN;
/* FIXME: if HAS_LONG_DOUBLE but not USE_LONG_DOUBLE this
/* SPECIAL */
case 'n':
+ if (vectorize)
+ goto unknown;
i = SvCUR(sv) - origlen;
- if (args && !vectorize) {
+ if (args) {
switch (intsize) {
case 'h': *(va_arg(*args, short*)) = i; break;
default: *(va_arg(*args, int*)) = i; break;
}
else
sv_setuv_mg(argsv, (UV)i);
- vectorize = FALSE;
continue; /* not "break" */
/* UNKNOWN */
/* 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') {
return tbl;
}
-#if (PTRSIZE == 8)
-# define PTR_TABLE_HASH(ptr) (PTR2UV(ptr) >> 3)
-#else
-# define PTR_TABLE_HASH(ptr) (PTR2UV(ptr) >> 2)
-#endif
+#define PTR_TABLE_HASH(ptr) \
+ ((PTR2UV(ptr) >> 3) ^ (PTR2UV(ptr) >> (3 + 7)) ^ (PTR2UV(ptr) >> (3 + 17)))
/*
we use the PTE_SVSLOT 'reservation' made above, both here (in the
/* 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 */
void
Perl_ptr_table_clear(pTHX_ PTR_TBL_t *tbl)
{
- register PTR_TBL_ENT_t **array;
- register PTR_TBL_ENT_t *entry;
- UV riter = 0;
- UV max;
+ if (tbl && tbl->tbl_items) {
+ register PTR_TBL_ENT_t **array = tbl->tbl_ary;
+ UV riter = tbl->tbl_max;
- if (!tbl || !tbl->tbl_items) {
- return;
- }
+ do {
+ PTR_TBL_ENT_t *entry = array[riter];
- array = tbl->tbl_ary;
- entry = array[0];
- max = tbl->tbl_max;
+ while (entry) {
+ PTR_TBL_ENT_t * const oentry = entry;
+ entry = entry->next;
+ del_pte(oentry);
+ }
+ } while (riter--);
- for (;;) {
- if (entry) {
- PTR_TBL_ENT_t *oentry = entry;
- entry = entry->next;
- del_pte(oentry);
- }
- if (!entry) {
- if (++riter > max) {
- break;
- }
- entry = array[riter];
- }
+ tbl->tbl_items = 0;
}
-
- tbl->tbl_items = 0;
}
/* clear and free a ptr table */
case SVt_PVNV:
case SVt_PVIV:
case SVt_PV:
- assert(sv_type_details->copy);
+ assert(sv_type_details->size);
if (sv_type_details->arena) {
- new_body_inline(new_body, sv_type_details->copy, sv_type);
+ new_body_inline(new_body, sv_type_details->size, 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)
++i;
}
if (SvOOK(sstr)) {
- struct xpvhv_aux *saux = HvAUX(sstr);
- struct xpvhv_aux *daux = HvAUX(dstr);
+ struct xpvhv_aux * const saux = HvAUX(sstr);
+ struct xpvhv_aux * const daux = HvAUX(dstr);
/* This flag isn't copied. */
/* SvOOK_on(hv) attacks the IV flags. */
SvFLAGS(dstr) |= SVf_OOK;
: cv_dup(cx->blk_sub.cv,param));
ncx->blk_sub.argarray = (cx->blk_sub.hasargs
? av_dup_inc(cx->blk_sub.argarray, param)
- : Nullav);
+ : NULL);
ncx->blk_sub.savearray = av_dup_inc(cx->blk_sub.savearray, param);
ncx->blk_sub.olddepth = cx->blk_sub.olddepth;
ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
#endif
/* swatch cache */
- PL_last_swash_hv = Nullhv; /* reinits on demand */
+ PL_last_swash_hv = NULL; /* reinits on demand */
PL_last_swash_klen = 0;
PL_last_swash_key[0]= '\0';
PL_last_swash_tmps = (U8*)NULL;
FREETMPS;
LEAVE;
}
- }
+ }
+
+ SvREFCNT_dec(param->stashes);
+
+ /* orphaned? eg threads->new inside BEGIN or use */
+ if (PL_compcv && ! SvREFCNT(PL_compcv)) {
+ (void)SvREFCNT_inc(PL_compcv);
+ SAVEFREESV(PL_compcv);
+ }
+
+ return my_perl;
+}
+
+#endif /* USE_ITHREADS */
+
+/*
+=head1 Unicode Support
+
+=for apidoc sv_recode_to_utf8
+
+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).
+
+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.
+
+=cut */
+
+char *
+Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding)
+{
+ dVAR;
+ if (SvPOK(sv) && !SvUTF8(sv) && !IN_BYTES && SvROK(encoding)) {
+ SV *uni;
+ STRLEN len;
+ const char *s;
+ dSP;
+ ENTER;
+ SAVETMPS;
+ save_re_context();
+ PUSHMARK(sp);
+ EXTEND(SP, 3);
+ XPUSHs(encoding);
+ XPUSHs(sv);
+/*
+ NI-S 2002/07/09
+ Passing sv_yes is wrong - it needs to be or'ed set of constants
+ for Encode::XS, while UTf-8 decode (currently) assumes a true value means
+ remove converted chars from source.
+
+ Both will default the value - let them.
+
+ XPUSHs(&PL_sv_yes);
+*/
+ PUTBACK;
+ call_method("decode", G_SCALAR);
+ SPAGAIN;
+ uni = POPs;
+ PUTBACK;
+ s = SvPV_const(uni, len);
+ if (s != SvPVX_const(sv)) {
+ SvGROW(sv, len + 1);
+ Move(s, SvPVX(sv), len + 1, char);
+ SvCUR_set(sv, len);
+ }
+ FREETMPS;
+ LEAVE;
+ SvUTF8_on(sv);
+ return SvPVX(sv);
+ }
+ return SvPOKp(sv) ? SvPVX(sv) : NULL;
+}
+
+/*
+=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.
+
+Returns TRUE if the terminator was found, else returns FALSE.
+
+=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;
+ }
+ else
+ Perl_croak(aTHX_ "Invalid argument to sv_cat_decode");
+ return ret;
+
+}
+
+/* ---------------------------------------------------------------------
+ *
+ * support functions for report_uninit()
+ */
+
+/* the maxiumum size of array or hash where we will scan looking
+ * for the undefined element that triggered the warning */
+
+#define FUV_MAX_SEARCH_SIZE 1000
+
+/* Look for an entry in the hash whose value has the same SV as val;
+ * If so, return a mortal copy of the key. */
+
+STATIC SV*
+S_find_hash_subscript(pTHX_ HV *hv, SV* val)
+{
+ dVAR;
+ register HE **array;
+ I32 i;
+
+ if (!hv || SvMAGICAL(hv) || !HvARRAY(hv) ||
+ (HvTOTALKEYS(hv) > FUV_MAX_SEARCH_SIZE))
+ return Nullsv;
+
+ array = HvARRAY(hv);
+
+ for (i=HvMAX(hv); i>0; i--) {
+ register HE *entry;
+ for (entry = array[i]; entry; entry = HeNEXT(entry)) {
+ if (HeVAL(entry) != val)
+ continue;
+ if ( HeVAL(entry) == &PL_sv_undef ||
+ HeVAL(entry) == &PL_sv_placeholder)
+ continue;
+ if (!HeKEY(entry))
+ return Nullsv;
+ if (HeKLEN(entry) == HEf_SVKEY)
+ return sv_mortalcopy(HeKEY_sv(entry));
+ return sv_2mortal(newSVpvn(HeKEY(entry), HeKLEN(entry)));
+ }
+ }
+ return Nullsv;
+}
+
+/* Look for an entry in the array whose value has the same SV as val;
+ * If so, return the index, otherwise return -1. */
+
+STATIC I32
+S_find_array_subscript(pTHX_ AV *av, SV* val)
+{
+ SV** svp;
+ I32 i;
+ if (!av || SvMAGICAL(av) || !AvARRAY(av) ||
+ (AvFILLp(av) > FUV_MAX_SEARCH_SIZE))
+ return -1;
+
+ svp = AvARRAY(av);
+ for (i=AvFILLp(av); i>=0; i--) {
+ if (svp[i] == val && svp[i] != &PL_sv_undef)
+ return i;
+ }
+ return -1;
+}
+
+/* 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:
+ */
+
+#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" */
+
+STATIC SV*
+S_varname(pTHX_ GV *gv, const char gvtype, PADOFFSET targ,
+ SV* keyname, I32 aindex, int subscript_type)
+{
+
+ SV * const name = sv_newmortal();
+ if (gv) {
+ char buffer[2];
+ buffer[0] = gvtype;
+ buffer[1] = 0;
+
+ /* as gv_fullname4(), but add literal '^' for $^FOO names */
+
+ gv_fullname4(name, gv, buffer, 0);
+
+ if ((unsigned int)SvPVX(name)[1] <= 26) {
+ buffer[0] = '^';
+ buffer[1] = SvPVX(name)[1] + 'A' - 1;
+
+ /* 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;
+
+ if (!cv || !CvPADLIST(cv))
+ return Nullsv;
+ av = (AV*)(*av_fetch(CvPADLIST(cv), 0, FALSE));
+ sv = *av_fetch(av, targ, FALSE);
+ /* SvLEN in a pad name is not to be trusted */
+ sv_setpv(name, SvPV_nolen_const(sv));
+ }
+
+ if (subscript_type == FUV_SUBSCRIPT_HASH) {
+ SV * const sv = NEWSV(0,0);
+ *SvPVX(name) = '$';
+ Perl_sv_catpvf(aTHX_ name, "{%s}",
+ pv_display(sv,SvPVX_const(keyname), SvCUR(keyname), 0, 32));
+ SvREFCNT_dec(sv);
+ }
+ else if (subscript_type == FUV_SUBSCRIPT_ARRAY) {
+ *SvPVX(name) = '$';
+ Perl_sv_catpvf(aTHX_ name, "[%"IVdf"]", (IV)aindex);
+ }
+ else if (subscript_type == FUV_SUBSCRIPT_WITHIN)
+ sv_insert(name, 0, 0, "within ", 7);
+
+ return name;
+}
+
+
+/*
+=for apidoc find_uninit_var
+
+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.
+
+The name is returned as a mortal SV.
+
+Assumes that PL_op is the op that originally triggered the error, and that
+PL_comppad/PL_curpad points to the currently executing pad.
+
+=cut
+*/
+
+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;
+
+ switch (obase->op_type) {
+
+ 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;
+
+ 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);
+ }
+
+ /* 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;
+ }
+
+ if (match && subscript_type == FUV_SUBSCRIPT_WITHIN)
+ break;
+
+ return varname(gv, hash ? '%' : '@', obase->op_targ,
+ keysv, index, subscript_type);
+ }
+
+ case OP_PADSV:
+ if (match && PAD_SVl(obase->op_targ) != uninit_sv)
+ break;
+ return varname(Nullgv, '$', obase->op_targ,
+ Nullsv, 0, FUV_SUBSCRIPT_NONE);
+
+ case OP_GVSV:
+ gv = cGVOPx_gv(obase);
+ if (!gv || (match && GvSV(gv) != uninit_sv))
+ break;
+ return varname(gv, '$', 0, Nullsv, 0, FUV_SUBSCRIPT_NONE);
+
+ 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;
+
+ 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);
+
+ 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);
+
+ gv = Nullgv;
+ o = cBINOPx(obase)->op_first;
+ kid = cBINOPx(obase)->op_last;
+
+ /* get the av or hv, and optionally the gv */
+ sv = Nullsv;
+ if (o->op_type == OP_PADAV || o->op_type == OP_PADHV) {
+ sv = PAD_SV(o->op_targ);
+ }
+ else if ((o->op_type == OP_RV2AV || o->op_type == OP_RV2HV)
+ && cUNOPo->op_first->op_type == OP_GV)
+ {
+ gv = cGVOPx_gv(cUNOPo->op_first);
+ if (!gv)
+ break;
+ sv = o->op_type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)GvAV(gv);
+ }
+ if (!sv)
+ break;
+
+ if (kid && kid->op_type == OP_CONST && SvOK(cSVOPx_sv(kid))) {
+ /* index is constant */
+ if (match) {
+ if (SvMAGICAL(sv))
+ break;
+ if (obase->op_type == OP_HELEM) {
+ HE* he = hv_fetch_ent((HV*)sv, cSVOPx_sv(kid), 0, 0);
+ if (!he || HeVAL(he) != uninit_sv)
+ break;
+ }
+ else {
+ SV * const * const svp = av_fetch((AV*)sv, SvIV(cSVOPx_sv(kid)), FALSE);
+ if (!svp || *svp != uninit_sv)
+ break;
+ }
+ }
+ if (obase->op_type == OP_HELEM)
+ return varname(gv, '%', o->op_targ,
+ cSVOPx_sv(kid), 0, FUV_SUBSCRIPT_HASH);
+ else
+ return varname(gv, '@', o->op_targ, Nullsv,
+ SvIV(cSVOPx_sv(kid)), FUV_SUBSCRIPT_ARRAY);
+ }
+ else {
+ /* index is an expression;
+ * attempt to find a match within the aggregate */
+ if (obase->op_type == OP_HELEM) {
+ SV * const keysv = S_find_hash_subscript(aTHX_ (HV*)sv, uninit_sv);
+ if (keysv)
+ return varname(gv, '%', o->op_targ,
+ keysv, 0, FUV_SUBSCRIPT_HASH);
+ }
+ else {
+ const I32 index = S_find_array_subscript(aTHX_ (AV*)sv, uninit_sv);
+ if (index >= 0)
+ return varname(gv, '@', o->op_targ,
+ Nullsv, index, FUV_SUBSCRIPT_ARRAY);
+ }
+ if (match)
+ break;
+ return varname(gv,
+ (o->op_type == OP_PADAV || o->op_type == OP_RV2AV)
+ ? '@' : '%',
+ o->op_targ, Nullsv, 0, FUV_SUBSCRIPT_WITHIN);
+ }
- SvREFCNT_dec(param->stashes);
+ break;
- /* orphaned? eg threads->new inside BEGIN or use */
- if (PL_compcv && ! SvREFCNT(PL_compcv)) {
- (void)SvREFCNT_inc(PL_compcv);
- SAVEFREESV(PL_compcv);
- }
+ case OP_AASSIGN:
+ /* only examine RHS */
+ return find_uninit_var(cBINOPx(obase)->op_first, uninit_sv, match);
- return my_perl;
-}
+ case OP_OPEN:
+ o = cUNOPx(obase)->op_first;
+ if (o->op_type == OP_PUSHMARK)
+ o = o->op_sibling;
-#endif /* USE_ITHREADS */
+ if (!o->op_sibling) {
+ /* one-arg version of open is highly magical */
-/*
-=head1 Unicode Support
+ if (o->op_type == OP_GV) { /* open FOO; */
+ gv = cGVOPx_gv(o);
+ if (match && GvSV(gv) != uninit_sv)
+ break;
+ return varname(gv, '$', 0,
+ Nullsv, 0, FUV_SUBSCRIPT_NONE);
+ }
+ /* other possibilities not handled are:
+ * open $x; or open my $x; should return '${*$x}'
+ * open expr; should return '$'.expr ideally
+ */
+ break;
+ }
+ goto do_op;
-=for apidoc sv_recode_to_utf8
+ /* ops where $_ may be an implicit arg */
+ case OP_TRANS:
+ case OP_SUBST:
+ case OP_MATCH:
+ if ( !(obase->op_flags & OPf_STACKED)) {
+ if (uninit_sv == ((obase->op_private & OPpTARGET_MY)
+ ? PAD_SVl(obase->op_targ)
+ : DEFSV))
+ {
+ sv = sv_newmortal();
+ sv_setpvn(sv, "$_", 2);
+ return sv;
+ }
+ }
+ goto do_op;
-The encoding is assumed to be an Encode object, on entry the PV
-of the sv is assumed to be octets in that encoding, and the sv
-will be converted into Unicode (and UTF-8).
+ case OP_PRTF:
+ case OP_PRINT:
+ /* skip filehandle as it can't produce 'undef' warning */
+ o = cUNOPx(obase)->op_first;
+ if ((obase->op_flags & OPf_STACKED) && o->op_type == OP_PUSHMARK)
+ o = o->op_sibling->op_sibling;
+ goto do_op2;
-If the sv already is UTF-8 (or if it is not POK), or if the encoding
-is not a reference, nothing is done to the sv. If the encoding is not
-an C<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,
+ "", "", "");
}
/*
projects / p5sagit/p5-mst-13.2.git / blobdiff