pointer to the body (struct xrv, xpv, xpviv...), which contains fields
specific to each type.
-Normally, this allocation is done using arenas, which by default are
-approximately 4K chunks of memory parcelled up into N heads or bodies. The
-first slot in each arena is reserved, and is used to hold a link to the next
-arena. In the case of heads, the unused first slot also contains some flags
-and a note of the number of slots. Snaked through each arena chain is a
-linked list of free items; when this becomes empty, an extra arena is
-allocated and divided up into N items which are threaded into the free list.
+In all but the most memory-paranoid configuations (ex: PURIFY), this
+allocation is done using arenas, which by default are approximately 4K
+chunks of memory parcelled up into N heads or bodies (of same size).
+Sv-bodies are allocated by their sv-type, guaranteeing size
+consistency needed to allocate safely from arrays.
+
+The first slot in each arena is reserved, and is used to hold a link
+to the next arena. In the case of heads, the unused first slot also
+contains some flags and a note of the number of slots. Snaked through
+each arena chain is a linked list of free items; when this becomes
+empty, an extra arena is allocated and divided up into N items which
+are threaded into the free list.
The following global variables are associated with arenas:
PL_sv_arenaroot pointer to list of SV arenas
PL_sv_root pointer to list of free SV structures
- PL_foo_arenaroot pointer to list of foo arenas,
- PL_foo_root pointer to list of free foo bodies
- ... for foo in xiv, xnv, xrv, xpv etc.
+ PL_body_arenaroots[] array of pointers to list of arenas, 1 per svtype
+ PL_body_roots[] array of pointers to list of free bodies of svtype
+ arrays are indexed by the svtype needed
-Note that some of the larger and more rarely used body types (eg xpvio)
-are not allocated using arenas, but are instead just malloc()/free()ed as
-required. Also, if PURIFY is defined, arenas are abandoned altogether,
-with all items individually malloc()ed. In addition, a few SV heads are
-not allocated from an arena, but are instead directly created as static
-or auto variables, eg PL_sv_undef. The size of arenas can be changed from
-the default by setting PERL_ARENA_SIZE appropriately at compile time.
+Note that some of the larger and more rarely used body types (eg
+xpvio) are not allocated using arenas, but are instead just
+malloc()/free()ed as required.
+
+In addition, a few SV heads are not allocated from an arena, but are
+instead directly created as static or auto variables, eg PL_sv_undef.
+The size of arenas can be changed from the default by setting
+PERL_ARENA_SIZE appropriately at compile time.
The SV arena serves the secondary purpose of allowing still-live SVs
to be located and destroyed during final cleanup.
At the time of very final cleanup, sv_free_arenas() is called from
perl_destruct() to physically free all the arenas allocated since the
-start of the interpreter. Note that this also clears PL_he_arenaroot,
-which is otherwise dealt with in hv.c.
+start of the interpreter.
Manipulation of any of the PL_*root pointers is protected by enclosing
LOCK_SV_MUTEX; ... UNLOCK_SV_MUTEX calls which should Do the Right Thing
of zero. called repeatedly from perl_destruct()
until there are no SVs left.
-=head2 Summary
+=head2 Arena allocator API Summary
Private API to rest of sv.c
* "A time to plant, and a time to uproot what was planted..."
*/
+/*
+ * nice_chunk and nice_chunk size need to be set
+ * and queried under the protection of sv_mutex
+ */
+void
+Perl_offer_nice_chunk(pTHX_ void *chunk, U32 chunk_size)
+{
+ void *new_chunk;
+ U32 new_chunk_size;
+ LOCK_SV_MUTEX;
+ new_chunk = (void *)(chunk);
+ new_chunk_size = (chunk_size);
+ if (new_chunk_size > PL_nice_chunk_size) {
+ Safefree(PL_nice_chunk);
+ PL_nice_chunk = (char *) new_chunk;
+ PL_nice_chunk_size = new_chunk_size;
+ } else {
+ Safefree(chunk);
+ }
+ UNLOCK_SV_MUTEX;
+}
#ifdef DEBUG_LEAKING_SCALARS
-# ifdef NETWARE
-# define FREE_SV_DEBUG_FILE(sv) PerlMemfree((sv)->sv_debug_file)
-# else
-# define FREE_SV_DEBUG_FILE(sv) PerlMemShared_free((sv)->sv_debug_file)
-# endif
+# define FREE_SV_DEBUG_FILE(sv) Safefree((sv)->sv_debug_file)
#else
# define FREE_SV_DEBUG_FILE(sv)
#endif
+#ifdef PERL_POISON
+# define SvARENA_CHAIN(sv) ((sv)->sv_u.svu_rv)
+/* Whilst I'd love to do this, it seems that things like to check on
+ unreferenced scalars
+# define POSION_SV_HEAD(sv) Poison(sv, 1, struct STRUCT_SV)
+*/
+# define POSION_SV_HEAD(sv) Poison(&SvANY(sv), 1, void *), \
+ Poison(&SvREFCNT(sv), 1, U32)
+#else
+# define SvARENA_CHAIN(sv) SvANY(sv)
+# define POSION_SV_HEAD(sv)
+#endif
+
#define plant_SV(p) \
STMT_START { \
FREE_SV_DEBUG_FILE(p); \
- SvANY(p) = (void *)PL_sv_root; \
+ POSION_SV_HEAD(p); \
+ SvARENA_CHAIN(p) = (void *)PL_sv_root; \
SvFLAGS(p) = SVTYPEMASK; \
PL_sv_root = (p); \
--PL_sv_count; \
#define uproot_SV(p) \
STMT_START { \
(p) = PL_sv_root; \
- PL_sv_root = (SV*)SvANY(p); \
+ PL_sv_root = (SV*)SvARENA_CHAIN(p); \
++PL_sv_count; \
} STMT_END
}
else {
char *chunk; /* must use New here to match call to */
- New(704,chunk,PERL_ARENA_SIZE,char); /* Safefree() in sv_free_arenas() */
+ Newx(chunk,PERL_ARENA_SIZE,char); /* Safefree() in sv_free_arenas() */
sv_add_arena(chunk, PERL_ARENA_SIZE, 0);
}
uproot_SV(sv);
(PL_curcop ? CopLINE(PL_curcop) : 0) : PL_copline);
sv->sv_debug_inpad = 0;
sv->sv_debug_cloned = 0;
-# ifdef NETWARE
sv->sv_debug_file = PL_curcop ? savepv(CopFILE(PL_curcop)): NULL;
-# else
- sv->sv_debug_file = PL_curcop ? savesharedpv(CopFILE(PL_curcop)): NULL;
-# endif
return sv;
}
SV* sva;
bool ok = 0;
for (sva = PL_sv_arenaroot; sva; sva = (SV *) SvANY(sva)) {
- SV *sv = sva + 1;
- SV *svend = &sva[SvREFCNT(sva)];
+ const SV * const sv = sva + 1;
+ const SV * const svend = &sva[SvREFCNT(sva)];
if (p >= sv && p < svend) {
ok = 1;
break;
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;
svend = &sva[SvREFCNT(sva) - 1];
sv = sva + 1;
while (sv < svend) {
- SvANY(sv) = (void *)(SV*)(sv + 1);
+ SvARENA_CHAIN(sv) = (void *)(SV*)(sv + 1);
#ifdef DEBUGGING
SvREFCNT(sv) = 0;
#endif
SvFLAGS(sv) = SVTYPEMASK;
sv++;
}
- SvANY(sv) = 0;
+ SvARENA_CHAIN(sv) = 0;
#ifdef DEBUGGING
SvREFCNT(sv) = 0;
#endif
I32 visited = 0;
for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
- register SV * const svend = &sva[SvREFCNT(sva)];
+ register const SV * const svend = &sva[SvREFCNT(sva)];
register SV* sv;
for (sv = sva + 1; sv < svend; ++sv) {
if (SvTYPE(sv) != SVTYPEMASK
/* called by sv_clean_objs() for each live SV */
static void
-do_clean_objs(pTHX_ SV *sv)
-{
- SV* rv;
-
- if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) {
- DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv)));
- if (SvWEAKREF(sv)) {
- sv_del_backref(sv);
- SvWEAKREF_off(sv);
- SvRV_set(sv, NULL);
- } else {
- SvROK_off(sv);
- SvRV_set(sv, NULL);
- SvREFCNT_dec(rv);
+do_clean_objs(pTHX_ SV *ref)
+{
+ if (SvROK(ref)) {
+ SV * const target = SvRV(ref);
+ if (SvOBJECT(target)) {
+ DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(ref)));
+ if (SvWEAKREF(ref)) {
+ sv_del_backref(target, ref);
+ SvWEAKREF_off(ref);
+ SvRV_set(ref, NULL);
+ } else {
+ SvROK_off(ref);
+ SvRV_set(ref, NULL);
+ SvREFCNT_dec(target);
+ }
}
}
do_clean_named_objs(pTHX_ SV *sv)
{
if (SvTYPE(sv) == SVt_PVGV && GvGP(sv)) {
- if ( SvOBJECT(GvSV(sv)) ||
+ if ((
+#ifdef PERL_DONT_CREATE_GVSV
+ GvSV(sv) &&
+#endif
+ SvOBJECT(GvSV(sv))) ||
(GvAV(sv) && SvOBJECT(GvAV(sv))) ||
(GvHV(sv) && SvOBJECT(GvHV(sv))) ||
(GvIO(sv) && SvOBJECT(GvIO(sv))) ||
DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) ));
SvFLAGS(sv) |= SVf_BREAK;
if (PL_comppad == (AV*)sv) {
- PL_comppad = Nullav;
+ PL_comppad = NULL;
PL_curpad = Null(SV**);
}
SvREFCNT_dec(sv);
return cleaned;
}
+static void
+S_free_arena(pTHX_ void **root) {
+ while (root) {
+ void ** const next = *(void **)root;
+ Safefree(root);
+ root = next;
+ }
+}
+
/*
=for apidoc sv_free_arenas
=cut
*/
+#define free_arena(name) \
+ STMT_START { \
+ S_free_arena(aTHX_ (void**) PL_ ## name ## _arenaroot); \
+ PL_ ## name ## _arenaroot = 0; \
+ PL_ ## name ## _root = 0; \
+ } STMT_END
void
Perl_sv_free_arenas(pTHX)
{
SV* sva;
SV* svanext;
- void *arena, *arenanext;
+ int i;
/* Free arenas here, but be careful about fake ones. (We assume
contiguity of the fake ones with the corresponding real ones.) */
Safefree(sva);
}
- for (arena = PL_xnv_arenaroot; arena; arena = arenanext) {
- arenanext = *(void **)arena;
- Safefree(arena);
+ for (i=0; i<SVt_LAST; i++) {
+ S_free_arena(aTHX_ (void**) PL_body_arenaroots[i]);
+ PL_body_arenaroots[i] = 0;
+ PL_body_roots[i] = 0;
}
- PL_xnv_arenaroot = 0;
- PL_xnv_root = 0;
- for (arena = PL_xpv_arenaroot; arena; arena = arenanext) {
- arenanext = *(void **)arena;
- Safefree(arena);
- }
- PL_xpv_arenaroot = 0;
- PL_xpv_root = 0;
+ Safefree(PL_nice_chunk);
+ PL_nice_chunk = Nullch;
+ PL_nice_chunk_size = 0;
+ PL_sv_arenaroot = 0;
+ PL_sv_root = 0;
+}
- for (arena = PL_xpviv_arenaroot; arena; arena = arenanext) {
- arenanext = *(void **)arena;
- Safefree(arena);
- }
- PL_xpviv_arenaroot = 0;
- PL_xpviv_root = 0;
+/*
+ Here are mid-level routines that manage the allocation of bodies out
+ of the various arenas. There are 5 kinds of arenas:
- for (arena = PL_xpvnv_arenaroot; arena; arena = arenanext) {
- arenanext = *(void **)arena;
- Safefree(arena);
- }
- PL_xpvnv_arenaroot = 0;
- PL_xpvnv_root = 0;
+ 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)
- for (arena = PL_xpvcv_arenaroot; arena; arena = arenanext) {
- arenanext = *(void **)arena;
- Safefree(arena);
- }
- PL_xpvcv_arenaroot = 0;
- PL_xpvcv_root = 0;
+ 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)
- for (arena = PL_xpvav_arenaroot; arena; arena = arenanext) {
- arenanext = *(void **)arena;
- Safefree(arena);
- }
- PL_xpvav_arenaroot = 0;
- PL_xpvav_root = 0;
+ 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 (arena = PL_xpvhv_arenaroot; arena; arena = arenanext) {
- arenanext = *(void **)arena;
- Safefree(arena);
- }
- PL_xpvhv_arenaroot = 0;
- PL_xpvhv_root = 0;
+ HE, HEK arenas are managed separately, with separate code, but may
+ be merge-able later..
- for (arena = PL_xpvmg_arenaroot; arena; arena = arenanext) {
- arenanext = *(void **)arena;
- Safefree(arena);
- }
- PL_xpvmg_arenaroot = 0;
- PL_xpvmg_root = 0;
+ 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)
+*/
- for (arena = PL_xpvgv_arenaroot; arena; arena = arenanext) {
- arenanext = *(void **)arena;
- Safefree(arena);
- }
- PL_xpvgv_arenaroot = 0;
- PL_xpvgv_root = 0;
+STATIC void *
+S_more_bodies (pTHX_ size_t size, svtype sv_type)
+{
+ 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;
- for (arena = PL_xpvlv_arenaroot; arena; arena = arenanext) {
- arenanext = *(void **)arena;
- Safefree(arena);
- }
- PL_xpvlv_arenaroot = 0;
- PL_xpvlv_root = 0;
+ Newx(start, count*size, char);
+ *((void **) start) = *arena_root;
+ *arena_root = (void *)start;
- for (arena = PL_xpvbm_arenaroot; arena; arena = arenanext) {
- arenanext = *(void **)arena;
- Safefree(arena);
- }
- PL_xpvbm_arenaroot = 0;
- PL_xpvbm_root = 0;
+ end = start + (count-1) * size;
- {
- HE *he;
- HE *he_next;
- for (he = PL_he_arenaroot; he; he = he_next) {
- he_next = HeNEXT(he);
- Safefree(he);
- }
- }
- PL_he_arenaroot = 0;
- PL_he_root = 0;
+ /* The initial slot is used to link the arenas together, so it isn't to be
+ linked into the list of ready-to-use bodies. */
-#if defined(USE_ITHREADS)
- {
- struct ptr_tbl_ent *pte;
- struct ptr_tbl_ent *pte_next;
- for (pte = PL_pte_arenaroot; pte; pte = pte_next) {
- pte_next = pte->next;
- Safefree(pte);
- }
+ start += size;
+
+ *root = (void *)start;
+
+ while (start < end) {
+ char * const next = start + size;
+ *(void**) start = (void *)next;
+ start = next;
}
- PL_pte_arenaroot = 0;
- PL_pte_root = 0;
-#endif
+ *(void **)start = 0;
- if (PL_nice_chunk)
- Safefree(PL_nice_chunk);
- PL_nice_chunk = Nullch;
- PL_nice_chunk_size = 0;
- PL_sv_arenaroot = 0;
- PL_sv_root = 0;
+ return *root;
}
-/* ---------------------------------------------------------------------
- *
- * support functions for report_uninit()
- */
+/* grab a new thing from the free list, allocating more if necessary */
-/* the maxiumum size of array or hash where we will scan looking
- * for the undefined element that triggered the warning */
+/* 1st, the inline version */
-#define FUV_MAX_SEARCH_SIZE 1000
+#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
-/* Look for an entry in the hash whose value has the same SV as val;
- * If so, return a mortal copy of the key. */
+/* now use the inline version in the proper function */
-STATIC SV*
-S_find_hash_subscript(pTHX_ HV *hv, SV* val)
+#ifndef PURIFY
+
+/* 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)
{
- dVAR;
- register HE **array;
- I32 i;
+ void *xpv;
+ new_body_inline(xpv, size, sv_type);
+ return xpv;
+}
- if (!hv || SvMAGICAL(hv) || !HvARRAY(hv) ||
- (HvTOTALKEYS(hv) > FUV_MAX_SEARCH_SIZE))
- return Nullsv;
+#endif
- array = HvARRAY(hv);
+/* return a thing to the free list */
- 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;
-}
+#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
-/* Look for an entry in the array whose value has the same SV as val;
- * If so, return the index, otherwise return -1. */
+/*
+ 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.)
+
+ 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.
+
+ 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 following 2 arrays hide the above details in a pair of
+ lookup-tables, allowing us to be body-type agnostic.
+
+ 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.
+*/
-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;
+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 */
+};
- svp = AvARRAY(av);
- for (i=AvFILLp(av); i>=0; i--) {
- if (svp[i] == val && svp[i] != &PL_sv_undef)
- return i;
- }
- return -1;
-}
+#define HADNV FALSE
+#define NONV TRUE
-/* S_varname(): return the name of a variable, optionally with a subscript.
- * If gv is non-zero, use the name of that global, along with gvtype (one
- * of "$", "@", "%"); otherwise use the name of the lexical at pad offset
- * targ. Depending on the value of the subscript_type flag, return:
- */
+#ifdef 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
-#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" */
+/* A macro to work out the offset needed to subtract from a pointer to (say)
-STATIC SV*
-S_varname(pTHX_ GV *gv, const char *gvtype, PADOFFSET targ,
- SV* keyname, I32 aindex, int subscript_type)
-{
- AV *av;
- SV *sv;
+typedef struct {
+ STRLEN xpv_cur;
+ STRLEN xpv_len;
+} xpv_allocated;
- SV * const name = sv_newmortal();
- if (gv) {
+to make its members accessible via a pointer to (say)
- /* simulate gv_fullname4(), but add literal '^' for $^FOO names
- * XXX get rid of all this if gv_fullnameX() ever supports this
- * directly */
-
- const char *p;
- HV *hv = GvSTASH(gv);
- sv_setpv(name, gvtype);
- if (!hv)
- p = "???";
- else if (!(p=HvNAME_get(hv)))
- p = "__ANON__";
- if (strNE(p, "main")) {
- sv_catpv(name,p);
- sv_catpvn(name,"::", 2);
- }
- if (GvNAMELEN(gv)>= 1 &&
- ((unsigned int)*GvNAME(gv)) <= 26)
- { /* handle $^FOO */
- Perl_sv_catpvf(aTHX_ name,"^%c", *GvNAME(gv) + 'A' - 1);
- sv_catpvn(name,GvNAME(gv)+1,GvNAMELEN(gv)-1);
- }
- else
- sv_catpvn(name,GvNAME(gv),GvNAMELEN(gv));
- }
- else {
- U32 u;
- CV *cv = find_runcv(&u);
- STRLEN len;
- const char *str;
- 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 */
- str = SvPV_const(sv,len);
- sv_setpvn(name, str, len);
- }
+struct xpv {
+ NV xnv_nv;
+ STRLEN xpv_cur;
+ STRLEN xpv_len;
+};
- if (subscript_type == FUV_SUBSCRIPT_HASH) {
- *SvPVX(name) = '$';
- sv = NEWSV(0,0);
- 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;
-}
+#define relative_STRUCT_OFFSET(longer, shorter, member) \
+ (STRUCT_OFFSET(shorter, member) - STRUCT_OFFSET(longer, member))
+
+/* 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. */
+
+#define copy_length(type, last_member) \
+ STRUCT_OFFSET(type, last_member) \
+ + sizeof (((type*)SvANY((SV*)0))->last_member)
+
+static const struct body_details bodies_by_type[] = {
+ {0, 0, 0, FALSE, NONV, NOARENA},
+ /* IVs are in the head, so the allocation size is 0 */
+ {0, sizeof(IV), STRUCT_OFFSET(XPVIV, xiv_iv), FALSE, NONV, NOARENA},
+ /* 8 bytes on most ILP32 with IEEE doubles */
+ {sizeof(NV), sizeof(NV), 0, FALSE, HADNV, HASARENA},
+ /* RVs are in the head now */
+ /* However, this slot is overloaded and used by the pte */
+ {0, 0, 0, FALSE, NONV, NOARENA},
+ /* 8 bytes on most ILP32 with IEEE doubles */
+ {sizeof(xpv_allocated),
+ copy_length(XPV, xpv_len)
+ - relative_STRUCT_OFFSET(xpv_allocated, XPV, xpv_cur),
+ + relative_STRUCT_OFFSET(xpv_allocated, XPV, xpv_cur),
+ FALSE, NONV, HASARENA},
+ /* 12 */
+ {sizeof(xpviv_allocated),
+ copy_length(XPVIV, xiv_u)
+ - relative_STRUCT_OFFSET(xpviv_allocated, XPVIV, xpv_cur),
+ + relative_STRUCT_OFFSET(xpviv_allocated, XPVIV, 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_allocated, XPVAV, xav_fill),
+ + relative_STRUCT_OFFSET(xpvav_allocated, XPVAV, xav_fill),
+ TRUE, HADNV, HASARENA},
+ /* 20 */
+ {sizeof(xpvhv_allocated),
+ copy_length(XPVHV, xmg_stash)
+ - relative_STRUCT_OFFSET(xpvhv_allocated, XPVHV, xhv_fill),
+ + relative_STRUCT_OFFSET(xpvhv_allocated, 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])
-/*
-=for apidoc find_uninit_var
+#define my_safemalloc(s) (void*)safemalloc(s)
+#define my_safecalloc(s) (void*)safecalloc(s, 1)
+#define my_safefree(p) safefree((char*)p)
-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.
+#ifdef PURIFY
-The name is returned as a mortal SV.
+#define new_XNV() my_safemalloc(sizeof(XPVNV))
+#define del_XNV(p) my_safefree(p)
-Assumes that PL_op is the op that originally triggered the error, and that
-PL_comppad/PL_curpad points to the currently executing pad.
+#define new_XPVNV() my_safemalloc(sizeof(XPVNV))
+#define del_XPVNV(p) my_safefree(p)
-=cut
-*/
+#define new_XPVAV() my_safemalloc(sizeof(XPVAV))
+#define del_XPVAV(p) my_safefree(p)
-STATIC SV *
-S_find_uninit_var(pTHX_ OP* obase, SV* uninit_sv, bool match)
-{
- dVAR;
- SV *sv;
- AV *av;
- SV **svp;
- GV *gv;
- OP *o, *o2, *kid;
+#define new_XPVHV() my_safemalloc(sizeof(XPVHV))
+#define del_XPVHV(p) my_safefree(p)
- if (!obase || (match && (!uninit_sv || uninit_sv == &PL_sv_undef ||
- uninit_sv == &PL_sv_placeholder)))
- return Nullsv;
+#define new_XPVMG() my_safemalloc(sizeof(XPVMG))
+#define del_XPVMG(p) my_safefree(p)
- switch (obase->op_type) {
+#define new_XPVGV() my_safemalloc(sizeof(XPVGV))
+#define del_XPVGV(p) my_safefree(p)
- 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;
+#else /* !PURIFY */
- 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);
- }
+#define new_XNV() new_body_type(SVt_NV)
+#define del_XNV(p) del_body_type(p, SVt_NV)
- /* 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;
- }
+#define new_XPVNV() new_body_type(SVt_PVNV)
+#define del_XPVNV(p) del_body_type(p, SVt_PVNV)
- if (match && subscript_type == FUV_SUBSCRIPT_WITHIN)
- break;
+#define new_XPVAV() new_body_allocated(SVt_PVAV)
+#define del_XPVAV(p) del_body_allocated(p, SVt_PVAV)
- return S_varname(aTHX_ gv, hash ? "%" : "@", obase->op_targ,
- keysv, index, subscript_type);
- }
+#define new_XPVHV() new_body_allocated(SVt_PVHV)
+#define del_XPVHV(p) del_body_allocated(p, SVt_PVHV)
- case OP_PADSV:
- if (match && PAD_SVl(obase->op_targ) != uninit_sv)
- break;
- return S_varname(aTHX_ Nullgv, "$", obase->op_targ,
- Nullsv, 0, FUV_SUBSCRIPT_NONE);
+#define new_XPVMG() new_body_type(SVt_PVMG)
+#define del_XPVMG(p) del_body_type(p, SVt_PVMG)
- case OP_GVSV:
- gv = cGVOPx_gv(obase);
- if (!gv || (match && GvSV(gv) != uninit_sv))
- break;
- return S_varname(aTHX_ gv, "$", 0, Nullsv, 0, FUV_SUBSCRIPT_NONE);
-
- case OP_AELEMFAST:
- if (obase->op_flags & OPf_SPECIAL) { /* lexical array */
- if (match) {
- 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 S_varname(aTHX_ Nullgv, "$", obase->op_targ,
- Nullsv, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY);
- }
- else {
- gv = cGVOPx_gv(obase);
- if (!gv)
- break;
- if (match) {
- av = GvAV(gv);
- if (!av || SvRMAGICAL(av))
- break;
- svp = av_fetch(av, (I32)obase->op_private, FALSE);
- if (!svp || *svp != uninit_sv)
- break;
- }
- return S_varname(aTHX_ 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 {
- svp = av_fetch((AV*)sv, SvIV(cSVOPx_sv(kid)), FALSE);
- if (!svp || *svp != uninit_sv)
- break;
- }
- }
- if (obase->op_type == OP_HELEM)
- return S_varname(aTHX_ gv, "%", o->op_targ,
- cSVOPx_sv(kid), 0, FUV_SUBSCRIPT_HASH);
- else
- return S_varname(aTHX_ 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 *keysv = S_find_hash_subscript(aTHX_ (HV*)sv, uninit_sv);
- if (keysv)
- return S_varname(aTHX_ 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 S_varname(aTHX_ gv, "@", o->op_targ,
- Nullsv, index, FUV_SUBSCRIPT_ARRAY);
- }
- if (match)
- break;
- return S_varname(aTHX_ gv,
- (o->op_type == OP_PADAV || o->op_type == OP_RV2AV)
- ? "@" : "%",
- o->op_targ, Nullsv, 0, FUV_SUBSCRIPT_WITHIN);
- }
-
- break;
-
- case OP_AASSIGN:
- /* only examine RHS */
- return find_uninit_var(cBINOPx(obase)->op_first, uninit_sv, match);
-
- case OP_OPEN:
- o = cUNOPx(obase)->op_first;
- if (o->op_type == OP_PUSHMARK)
- o = o->op_sibling;
-
- if (!o->op_sibling) {
- /* one-arg version of open is highly magical */
-
- if (o->op_type == OP_GV) { /* open FOO; */
- gv = cGVOPx_gv(o);
- if (match && GvSV(gv) != uninit_sv)
- break;
- return S_varname(aTHX_ 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;
-
- /* 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;
-
- 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;
-
-
- case OP_RV2SV:
- case OP_CUSTOM:
- case OP_ENTERSUB:
- match = 1; /* XS or custom code could trigger random warnings */
- goto do_op;
-
- case OP_SCHOMP:
- case OP_CHOMP:
- if (SvROK(PL_rs) && uninit_sv == SvRV(PL_rs))
- return sv_2mortal(newSVpv("${$/}", 0));
- /* FALL THROUGH */
-
- default:
- do_op:
- if (!(obase->op_flags & OPf_KIDS))
- break;
- o = cUNOPx(obase)->op_first;
-
- do_op2:
- if (!o)
- break;
+#define new_XPVGV() new_body_type(SVt_PVGV)
+#define del_XPVGV(p) del_body_type(p, SVt_PVGV)
- /* 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);
+#endif /* 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;
-}
+/* no arena for you! */
+#define new_NOARENA(details) \
+ my_safemalloc((details)->size + (details)->offset)
+#define new_NOARENAZ(details) \
+ my_safecalloc((details)->size + (details)->offset)
/*
-=for apidoc report_uninit
+=for apidoc sv_upgrade
-Print appropriate "Use of uninitialized variable" warning
+Upgrade an SV to a more complex form. Generally adds a new body type to the
+SV, then copies across as much information as possible from the old body.
+You generally want to use the C<SvUPGRADE> macro wrapper. See also C<svtype>.
=cut
*/
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,
- "", "", "");
-}
-
-/* allocate another arena's worth of NV bodies */
-
-STATIC void
-S_more_xnv(pTHX)
+Perl_sv_upgrade(pTHX_ register SV *sv, U32 new_type)
{
- NV* xnv;
- NV* xnvend;
- void *ptr;
- New(711, ptr, PERL_ARENA_SIZE/sizeof(NV), NV);
- *((void **) ptr) = (void *)PL_xnv_arenaroot;
- PL_xnv_arenaroot = ptr;
+ 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;
- xnv = (NV*) ptr;
- xnvend = &xnv[PERL_ARENA_SIZE / sizeof(NV) - 1];
- xnv += (sizeof(XPVIV) - 1) / sizeof(NV) + 1; /* fudge by sizeof XPVIV */
- PL_xnv_root = xnv;
- while (xnv < xnvend) {
- *(NV**)xnv = (NV*)(xnv + 1);
- xnv++;
+ if (new_type != SVt_PV && SvIsCOW(sv)) {
+ sv_force_normal_flags(sv, 0);
}
- *(NV**)xnv = 0;
-}
-/* allocate another arena's worth of struct xpv */
-
-STATIC void
-S_more_xpv(pTHX)
-{
- xpv_allocated* xpv;
- xpv_allocated* xpvend;
- New(713, xpv, PERL_ARENA_SIZE/sizeof(xpv_allocated), xpv_allocated);
- *((xpv_allocated**)xpv) = PL_xpv_arenaroot;
- PL_xpv_arenaroot = xpv;
+ if (old_type == new_type)
+ return;
- xpvend = &xpv[PERL_ARENA_SIZE / sizeof(xpv_allocated) - 1];
- PL_xpv_root = ++xpv;
- while (xpv < xpvend) {
- *((xpv_allocated**)xpv) = xpv + 1;
- xpv++;
- }
- *((xpv_allocated**)xpv) = 0;
-}
+ if (old_type > new_type)
+ Perl_croak(aTHX_ "sv_upgrade from type %d down to type %d",
+ (int)old_type, (int)new_type);
-/* allocate another arena's worth of struct xpviv */
-STATIC void
-S_more_xpviv(pTHX)
-{
- xpviv_allocated* xpviv;
- xpviv_allocated* xpvivend;
- New(713, xpviv, PERL_ARENA_SIZE/sizeof(xpviv_allocated), xpviv_allocated);
- *((xpviv_allocated**)xpviv) = PL_xpviv_arenaroot;
- PL_xpviv_arenaroot = xpviv;
+ old_body = SvANY(sv);
- xpvivend = &xpviv[PERL_ARENA_SIZE / sizeof(xpviv_allocated) - 1];
- PL_xpviv_root = ++xpviv;
- while (xpviv < xpvivend) {
- *((xpviv_allocated**)xpviv) = xpviv + 1;
- xpviv++;
- }
- *((xpviv_allocated**)xpviv) = 0;
-}
+ /* Copying structures onto other structures that have been neatly zeroed
+ has a subtle gotcha. Consider XPVMG
-/* allocate another arena's worth of struct xpvnv */
+ +------+------+------+------+------+-------+-------+
+ | NV | CUR | LEN | IV | MAGIC | STASH |
+ +------+------+------+------+------+-------+-------+
+ 0 4 8 12 16 20 24 28
-STATIC void
-S_more_xpvnv(pTHX)
-{
- XPVNV* xpvnv;
- XPVNV* xpvnvend;
- New(715, xpvnv, PERL_ARENA_SIZE/sizeof(XPVNV), XPVNV);
- *((XPVNV**)xpvnv) = PL_xpvnv_arenaroot;
- PL_xpvnv_arenaroot = xpvnv;
+ 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:
- xpvnvend = &xpvnv[PERL_ARENA_SIZE / sizeof(XPVNV) - 1];
- PL_xpvnv_root = ++xpvnv;
- while (xpvnv < xpvnvend) {
- *((XPVNV**)xpvnv) = xpvnv + 1;
- xpvnv++;
- }
- *((XPVNV**)xpvnv) = 0;
-}
+ +------+------+------+------+------+-------+-------+------+
+ | NV | CUR | LEN | IV | MAGIC | STASH | ??? |
+ +------+------+------+------+------+-------+-------+------+
+ 0 4 8 12 16 20 24 28 32
-/* allocate another arena's worth of struct xpvcv */
+ so what happens if you allocate memory for this structure:
-STATIC void
-S_more_xpvcv(pTHX)
-{
- XPVCV* xpvcv;
- XPVCV* xpvcvend;
- New(716, xpvcv, PERL_ARENA_SIZE/sizeof(XPVCV), XPVCV);
- *((XPVCV**)xpvcv) = PL_xpvcv_arenaroot;
- PL_xpvcv_arenaroot = xpvcv;
+ +------+------+------+------+------+-------+-------+------+------+...
+ | NV | CUR | LEN | IV | MAGIC | STASH | GP | NAME |
+ +------+------+------+------+------+-------+-------+------+------+...
+ 0 4 8 12 16 20 24 28 32 36
- xpvcvend = &xpvcv[PERL_ARENA_SIZE / sizeof(XPVCV) - 1];
- PL_xpvcv_root = ++xpvcv;
- while (xpvcv < xpvcvend) {
- *((XPVCV**)xpvcv) = xpvcv + 1;
- xpvcv++;
- }
- *((XPVCV**)xpvcv) = 0;
-}
+ 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.
-/* allocate another arena's worth of struct xpvav */
+ (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)
-STATIC void
-S_more_xpvav(pTHX)
-{
- xpvav_allocated* xpvav;
- xpvav_allocated* xpvavend;
- New(717, xpvav, PERL_ARENA_SIZE/sizeof(xpvav_allocated),
- xpvav_allocated);
- *((xpvav_allocated**)xpvav) = PL_xpvav_arenaroot;
- PL_xpvav_arenaroot = xpvav;
+ So we are careful and work out the size of used parts of all the
+ structures. */
- xpvavend = &xpvav[PERL_ARENA_SIZE / sizeof(xpvav_allocated) - 1];
- PL_xpvav_root = ++xpvav;
- while (xpvav < xpvavend) {
- *((xpvav_allocated**)xpvav) = xpvav + 1;
- xpvav++;
+ switch (old_type) {
+ case SVt_NULL:
+ break;
+ case SVt_IV:
+ if (new_type < SVt_PVIV) {
+ new_type = (new_type == SVt_NV)
+ ? SVt_PVNV : SVt_PVIV;
+ new_type_details = bodies_by_type + new_type;
+ }
+ break;
+ case SVt_NV:
+ if (new_type < SVt_PVNV) {
+ new_type = SVt_PVNV;
+ new_type_details = bodies_by_type + new_type;
+ }
+ break;
+ case SVt_RV:
+ break;
+ case SVt_PV:
+ assert(new_type > SVt_PV);
+ assert(SVt_IV < SVt_PV);
+ assert(SVt_NV < SVt_PV);
+ break;
+ case SVt_PVIV:
+ break;
+ case SVt_PVNV:
+ break;
+ case SVt_PVMG:
+ /* Because the XPVMG of PL_mess_sv isn't allocated from the arena,
+ there's no way that it can be safely upgraded, because perl.c
+ expects to Safefree(SvANY(PL_mess_sv)) */
+ assert(sv != PL_mess_sv);
+ /* This flag bit is used to mean other things in other scalar types.
+ Given that it only has meaning inside the pad, it shouldn't be set
+ on anything that can get upgraded. */
+ assert((SvFLAGS(sv) & SVpad_TYPED) == 0);
+ break;
+ default:
+ if (old_type_details->cant_upgrade)
+ Perl_croak(aTHX_ "Can't upgrade that kind of scalar");
}
- *((xpvav_allocated**)xpvav) = 0;
-}
-/* allocate another arena's worth of struct xpvhv */
+ SvFLAGS(sv) &= ~SVTYPEMASK;
+ SvFLAGS(sv) |= new_type;
-STATIC void
-S_more_xpvhv(pTHX)
-{
- xpvhv_allocated* xpvhv;
- xpvhv_allocated* xpvhvend;
- New(718, xpvhv, PERL_ARENA_SIZE/sizeof(xpvhv_allocated),
- xpvhv_allocated);
- *((xpvhv_allocated**)xpvhv) = PL_xpvhv_arenaroot;
- PL_xpvhv_arenaroot = xpvhv;
+ switch (new_type) {
+ case SVt_NULL:
+ Perl_croak(aTHX_ "Can't upgrade to undef");
+ case SVt_IV:
+ assert(old_type == SVt_NULL);
+ SvANY(sv) = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
+ SvIV_set(sv, 0);
+ return;
+ case SVt_NV:
+ assert(old_type == SVt_NULL);
+ SvANY(sv) = new_XNV();
+ SvNV_set(sv, 0);
+ return;
+ case SVt_RV:
+ assert(old_type == SVt_NULL);
+ SvANY(sv) = &sv->sv_u.svu_rv;
+ SvRV_set(sv, 0);
+ return;
+ case SVt_PVHV:
+ SvANY(sv) = new_XPVHV();
+ HvFILL(sv) = 0;
+ HvMAX(sv) = 0;
+ HvTOTALKEYS(sv) = 0;
- xpvhvend = &xpvhv[PERL_ARENA_SIZE / sizeof(xpvhv_allocated) - 1];
- PL_xpvhv_root = ++xpvhv;
- while (xpvhv < xpvhvend) {
- *((xpvhv_allocated**)xpvhv) = xpvhv + 1;
- xpvhv++;
- }
- *((xpvhv_allocated**)xpvhv) = 0;
-}
+ goto hv_av_common;
-/* allocate another arena's worth of struct xpvmg */
+ case SVt_PVAV:
+ SvANY(sv) = new_XPVAV();
+ AvMAX(sv) = -1;
+ AvFILLp(sv) = -1;
+ AvALLOC(sv) = 0;
+ AvREAL_only(sv);
+
+ hv_av_common:
+ /* SVt_NULL isn't the only thing upgraded to AV or HV.
+ The target created by newSVrv also is, and it can have magic.
+ However, it never has SvPVX set.
+ */
+ if (old_type >= SVt_RV) {
+ assert(SvPVX_const(sv) == 0);
+ }
-STATIC void
-S_more_xpvmg(pTHX)
-{
- XPVMG* xpvmg;
- XPVMG* xpvmgend;
- New(719, xpvmg, PERL_ARENA_SIZE/sizeof(XPVMG), XPVMG);
- *((XPVMG**)xpvmg) = PL_xpvmg_arenaroot;
- PL_xpvmg_arenaroot = xpvmg;
+ /* Could put this in the else clause below, as PVMG must have SvPVX
+ 0 already (the assertion above) */
+ SvPV_set(sv, (char*)0);
- xpvmgend = &xpvmg[PERL_ARENA_SIZE / sizeof(XPVMG) - 1];
- PL_xpvmg_root = ++xpvmg;
- while (xpvmg < xpvmgend) {
- *((XPVMG**)xpvmg) = xpvmg + 1;
- xpvmg++;
- }
- *((XPVMG**)xpvmg) = 0;
-}
+ if (old_type >= SVt_PVMG) {
+ SvMAGIC_set(sv, ((XPVMG*)old_body)->xmg_magic);
+ SvSTASH_set(sv, ((XPVMG*)old_body)->xmg_stash);
+ } else {
+ SvMAGIC_set(sv, 0);
+ SvSTASH_set(sv, 0);
+ }
+ break;
-/* allocate another arena's worth of struct xpvgv */
-STATIC void
-S_more_xpvgv(pTHX)
-{
- XPVGV* xpvgv;
- XPVGV* xpvgvend;
- New(720, xpvgv, PERL_ARENA_SIZE/sizeof(XPVGV), XPVGV);
- *((XPVGV**)xpvgv) = PL_xpvgv_arenaroot;
- PL_xpvgv_arenaroot = xpvgv;
+ case SVt_PVIV:
+ /* XXX Is this still needed? Was it ever needed? Surely as there is
+ no route from NV to PVIV, NOK can never be true */
+ assert(!SvNOKp(sv));
+ assert(!SvNOK(sv));
+ case SVt_PVIO:
+ case SVt_PVFM:
+ case SVt_PVBM:
+ case SVt_PVGV:
+ case SVt_PVCV:
+ case SVt_PVLV:
+ case SVt_PVMG:
+ case SVt_PVNV:
+ case SVt_PV:
- xpvgvend = &xpvgv[PERL_ARENA_SIZE / sizeof(XPVGV) - 1];
- PL_xpvgv_root = ++xpvgv;
- while (xpvgv < xpvgvend) {
- *((XPVGV**)xpvgv) = xpvgv + 1;
- xpvgv++;
- }
- *((XPVGV**)xpvgv) = 0;
-}
+ assert(new_type_details->size);
+ /* We always allocated the full length item with PURIFY. To do this
+ we fake things so that arena is false for all 16 types.. */
+ if(new_type_details->arena) {
+ /* This points to the start of the allocated area. */
+ new_body_inline(new_body, new_type_details->size, new_type);
+ Zero(new_body, new_type_details->size, char);
+ new_body = ((char *)new_body) - new_type_details->offset;
+ } else {
+ new_body = new_NOARENAZ(new_type_details);
+ }
+ SvANY(sv) = new_body;
-/* allocate another arena's worth of struct xpvlv */
+ if (old_type_details->copy) {
+ Copy((char *)old_body + old_type_details->offset,
+ (char *)new_body + old_type_details->offset,
+ old_type_details->copy, char);
+ }
-STATIC void
-S_more_xpvlv(pTHX)
-{
- XPVLV* xpvlv;
- XPVLV* xpvlvend;
- New(720, xpvlv, PERL_ARENA_SIZE/sizeof(XPVLV), XPVLV);
- *((XPVLV**)xpvlv) = PL_xpvlv_arenaroot;
- PL_xpvlv_arenaroot = xpvlv;
+#ifndef NV_ZERO_IS_ALLBITS_ZERO
+ /* If NV 0.0 is store as all bits 0 then Zero() already creates a correct
+ 0.0 for us. */
+ if (old_type_details->zero_nv)
+ SvNV_set(sv, 0);
+#endif
- xpvlvend = &xpvlv[PERL_ARENA_SIZE / sizeof(XPVLV) - 1];
- PL_xpvlv_root = ++xpvlv;
- while (xpvlv < xpvlvend) {
- *((XPVLV**)xpvlv) = xpvlv + 1;
- xpvlv++;
+ if (new_type == SVt_PVIO)
+ IoPAGE_LEN(sv) = 60;
+ if (old_type < SVt_RV)
+ SvPV_set(sv, 0);
+ break;
+ default:
+ Perl_croak(aTHX_ "panic: sv_upgrade to unknown type %lu", new_type);
}
- *((XPVLV**)xpvlv) = 0;
-}
-
-/* allocate another arena's worth of struct xpvbm */
-
-STATIC void
-S_more_xpvbm(pTHX)
-{
- XPVBM* xpvbm;
- XPVBM* xpvbmend;
- New(721, xpvbm, PERL_ARENA_SIZE/sizeof(XPVBM), XPVBM);
- *((XPVBM**)xpvbm) = PL_xpvbm_arenaroot;
- PL_xpvbm_arenaroot = xpvbm;
- xpvbmend = &xpvbm[PERL_ARENA_SIZE / sizeof(XPVBM) - 1];
- PL_xpvbm_root = ++xpvbm;
- while (xpvbm < xpvbmend) {
- *((XPVBM**)xpvbm) = xpvbm + 1;
- xpvbm++;
+ if (old_type_details->size) {
+ /* If the old body had an allocated size, then we need to free it. */
+#ifdef PURIFY
+ my_safefree(old_body);
+#else
+ del_body((void*)((char*)old_body + old_type_details->offset),
+ &PL_body_roots[old_type]);
+#endif
}
- *((XPVBM**)xpvbm) = 0;
}
-/* grab a new NV body from the free list, allocating more if necessary */
+/*
+=for apidoc sv_backoff
-STATIC XPVNV*
-S_new_xnv(pTHX)
-{
- NV* xnv;
- LOCK_SV_MUTEX;
- if (!PL_xnv_root)
- S_more_xnv(aTHX);
- xnv = PL_xnv_root;
- PL_xnv_root = *(NV**)xnv;
- UNLOCK_SV_MUTEX;
- return (XPVNV*)((char*)xnv - STRUCT_OFFSET(XPVNV, xnv_nv));
-}
+Remove any string offset. You should normally use the C<SvOOK_off> macro
+wrapper instead.
-/* return an NV body to the free list */
+=cut
+*/
-STATIC void
-S_del_xnv(pTHX_ XPVNV *p)
+int
+Perl_sv_backoff(pTHX_ register SV *sv)
{
- NV* xnv = (NV*)((char*)(p) + STRUCT_OFFSET(XPVNV, xnv_nv));
- LOCK_SV_MUTEX;
- *(NV**)xnv = PL_xnv_root;
- PL_xnv_root = xnv;
- UNLOCK_SV_MUTEX;
+ assert(SvOOK(sv));
+ assert(SvTYPE(sv) != SVt_PVHV);
+ assert(SvTYPE(sv) != SVt_PVAV);
+ if (SvIVX(sv)) {
+ const char * const s = SvPVX_const(sv);
+ SvLEN_set(sv, SvLEN(sv) + SvIVX(sv));
+ SvPV_set(sv, SvPVX(sv) - SvIVX(sv));
+ SvIV_set(sv, 0);
+ Move(s, SvPVX(sv), SvCUR(sv)+1, char);
+ }
+ SvFLAGS(sv) &= ~SVf_OOK;
+ return 0;
}
-/* grab a new struct xpv from the free list, allocating more if necessary */
+/*
+=for apidoc sv_grow
-STATIC XPV*
-S_new_xpv(pTHX)
-{
- xpv_allocated* xpv;
- LOCK_SV_MUTEX;
- if (!PL_xpv_root)
- S_more_xpv(aTHX);
- xpv = PL_xpv_root;
- PL_xpv_root = *(xpv_allocated**)xpv;
- UNLOCK_SV_MUTEX;
- /* 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 IV actually allocated) then the net effect is
- to subtract the size of the IV from the pointer, to return a new pointer
- as if an initial IV were actually allocated. */
- return (XPV*)((char*)xpv - STRUCT_OFFSET(XPV, xpv_cur)
- + STRUCT_OFFSET(xpv_allocated, xpv_cur));
-}
+Expands the character buffer in the SV. If necessary, uses C<sv_unref> and
+upgrades the SV to C<SVt_PV>. Returns a pointer to the character buffer.
+Use the C<SvGROW> wrapper instead.
-/* return a struct xpv to the free list */
+=cut
+*/
-STATIC void
-S_del_xpv(pTHX_ XPV *p)
+char *
+Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen)
{
- xpv_allocated* xpv
- = (xpv_allocated*)((char*)(p) + STRUCT_OFFSET(XPV, xpv_cur)
- - STRUCT_OFFSET(xpv_allocated, xpv_cur));
- LOCK_SV_MUTEX;
- *(xpv_allocated**)xpv = PL_xpv_root;
- PL_xpv_root = xpv;
- UNLOCK_SV_MUTEX;
-}
+ register char *s;
-/* grab a new struct xpviv from the free list, allocating more if necessary */
+#ifdef HAS_64K_LIMIT
+ if (newlen >= 0x10000) {
+ PerlIO_printf(Perl_debug_log,
+ "Allocation too large: %"UVxf"\n", (UV)newlen);
+ my_exit(1);
+ }
+#endif /* HAS_64K_LIMIT */
+ if (SvROK(sv))
+ sv_unref(sv);
+ if (SvTYPE(sv) < SVt_PV) {
+ sv_upgrade(sv, SVt_PV);
+ s = SvPVX_mutable(sv);
+ }
+ else if (SvOOK(sv)) { /* pv is offset? */
+ sv_backoff(sv);
+ s = SvPVX_mutable(sv);
+ if (newlen > SvLEN(sv))
+ newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
+#ifdef HAS_64K_LIMIT
+ if (newlen >= 0x10000)
+ newlen = 0xFFFF;
+#endif
+ }
+ else
+ s = SvPVX_mutable(sv);
-STATIC XPVIV*
-S_new_xpviv(pTHX)
-{
- xpviv_allocated* xpviv;
- LOCK_SV_MUTEX;
- if (!PL_xpviv_root)
- S_more_xpviv(aTHX);
- xpviv = PL_xpviv_root;
- PL_xpviv_root = *(xpviv_allocated**)xpviv;
- UNLOCK_SV_MUTEX;
- /* If xpviv_allocated is the same structure as XPVIV then the two OFFSETs
- sum to zero, and the pointer is unchanged. If the allocated structure
- is smaller (no initial IV actually allocated) then the net effect is
- to subtract the size of the IV from the pointer, to return a new pointer
- as if an initial IV were actually allocated. */
- return (XPVIV*)((char*)xpviv - STRUCT_OFFSET(XPVIV, xpv_cur)
- + STRUCT_OFFSET(xpviv_allocated, xpv_cur));
+ if (newlen > SvLEN(sv)) { /* need more room? */
+ newlen = PERL_STRLEN_ROUNDUP(newlen);
+ if (SvLEN(sv) && s) {
+#ifdef MYMALLOC
+ const STRLEN l = malloced_size((void*)SvPVX_const(sv));
+ if (newlen <= l) {
+ SvLEN_set(sv, l);
+ return s;
+ } else
+#endif
+ s = saferealloc(s, newlen);
+ }
+ else {
+ s = safemalloc(newlen);
+ if (SvPVX_const(sv) && SvCUR(sv)) {
+ Move(SvPVX_const(sv), s, (newlen < SvCUR(sv)) ? newlen : SvCUR(sv), char);
+ }
+ }
+ SvPV_set(sv, s);
+ SvLEN_set(sv, newlen);
+ }
+ return s;
}
-/* return a struct xpviv to the free list */
+/*
+=for apidoc sv_setiv
-STATIC void
-S_del_xpviv(pTHX_ XPVIV *p)
-{
- xpviv_allocated* xpviv
- = (xpviv_allocated*)((char*)(p) + STRUCT_OFFSET(XPVIV, xpv_cur)
- - STRUCT_OFFSET(xpviv_allocated, xpv_cur));
- LOCK_SV_MUTEX;
- *(xpviv_allocated**)xpviv = PL_xpviv_root;
- PL_xpviv_root = xpviv;
- UNLOCK_SV_MUTEX;
-}
+Copies an integer into the given SV, upgrading first if necessary.
+Does not handle 'set' magic. See also C<sv_setiv_mg>.
-/* grab a new struct xpvnv from the free list, allocating more if necessary */
+=cut
+*/
-STATIC XPVNV*
-S_new_xpvnv(pTHX)
+void
+Perl_sv_setiv(pTHX_ register SV *sv, IV i)
{
- XPVNV* xpvnv;
- LOCK_SV_MUTEX;
- if (!PL_xpvnv_root)
- S_more_xpvnv(aTHX);
- xpvnv = PL_xpvnv_root;
- PL_xpvnv_root = *(XPVNV**)xpvnv;
- UNLOCK_SV_MUTEX;
- return xpvnv;
-}
-
-/* return a struct xpvnv to the free list */
+ SV_CHECK_THINKFIRST_COW_DROP(sv);
+ switch (SvTYPE(sv)) {
+ case SVt_NULL:
+ sv_upgrade(sv, SVt_IV);
+ break;
+ case SVt_NV:
+ sv_upgrade(sv, SVt_PVNV);
+ break;
+ case SVt_RV:
+ case SVt_PV:
+ sv_upgrade(sv, SVt_PVIV);
+ break;
-STATIC void
-S_del_xpvnv(pTHX_ XPVNV *p)
-{
- LOCK_SV_MUTEX;
- *(XPVNV**)p = PL_xpvnv_root;
- PL_xpvnv_root = p;
- UNLOCK_SV_MUTEX;
+ case SVt_PVGV:
+ case SVt_PVAV:
+ case SVt_PVHV:
+ case SVt_PVCV:
+ case SVt_PVFM:
+ case SVt_PVIO:
+ Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
+ OP_DESC(PL_op));
+ }
+ (void)SvIOK_only(sv); /* validate number */
+ SvIV_set(sv, i);
+ SvTAINT(sv);
}
-/* grab a new struct xpvcv from the free list, allocating more if necessary */
+/*
+=for apidoc sv_setiv_mg
-STATIC XPVCV*
-S_new_xpvcv(pTHX)
-{
- XPVCV* xpvcv;
- LOCK_SV_MUTEX;
- if (!PL_xpvcv_root)
- S_more_xpvcv(aTHX);
- xpvcv = PL_xpvcv_root;
- PL_xpvcv_root = *(XPVCV**)xpvcv;
- UNLOCK_SV_MUTEX;
- return xpvcv;
-}
+Like C<sv_setiv>, but also handles 'set' magic.
-/* return a struct xpvcv to the free list */
+=cut
+*/
-STATIC void
-S_del_xpvcv(pTHX_ XPVCV *p)
+void
+Perl_sv_setiv_mg(pTHX_ register SV *sv, IV i)
{
- LOCK_SV_MUTEX;
- *(XPVCV**)p = PL_xpvcv_root;
- PL_xpvcv_root = p;
- UNLOCK_SV_MUTEX;
+ sv_setiv(sv,i);
+ SvSETMAGIC(sv);
}
-/* grab a new struct xpvav from the free list, allocating more if necessary */
+/*
+=for apidoc sv_setuv
-STATIC XPVAV*
-S_new_xpvav(pTHX)
-{
- xpvav_allocated* xpvav;
- LOCK_SV_MUTEX;
- if (!PL_xpvav_root)
- S_more_xpvav(aTHX);
- xpvav = PL_xpvav_root;
- PL_xpvav_root = *(xpvav_allocated**)xpvav;
- UNLOCK_SV_MUTEX;
- return (XPVAV*)((char*)xpvav - STRUCT_OFFSET(XPVAV, xav_fill)
- + STRUCT_OFFSET(xpvav_allocated, xav_fill));
-}
+Copies an unsigned integer into the given SV, upgrading first if necessary.
+Does not handle 'set' magic. See also C<sv_setuv_mg>.
-/* return a struct xpvav to the free list */
+=cut
+*/
-STATIC void
-S_del_xpvav(pTHX_ XPVAV *p)
-{
- xpvav_allocated* xpvav
- = (xpvav_allocated*)((char*)(p) + STRUCT_OFFSET(XPVAV, xav_fill)
- - STRUCT_OFFSET(xpvav_allocated, xav_fill));
- LOCK_SV_MUTEX;
- *(xpvav_allocated**)xpvav = PL_xpvav_root;
- PL_xpvav_root = xpvav;
- UNLOCK_SV_MUTEX;
-}
-
-/* grab a new struct xpvhv from the free list, allocating more if necessary */
-
-STATIC XPVHV*
-S_new_xpvhv(pTHX)
-{
- xpvhv_allocated* xpvhv;
- LOCK_SV_MUTEX;
- if (!PL_xpvhv_root)
- S_more_xpvhv(aTHX);
- xpvhv = PL_xpvhv_root;
- PL_xpvhv_root = *(xpvhv_allocated**)xpvhv;
- UNLOCK_SV_MUTEX;
- return (XPVHV*)((char*)xpvhv - STRUCT_OFFSET(XPVHV, xhv_fill)
- + STRUCT_OFFSET(xpvhv_allocated, xhv_fill));
-}
-
-/* return a struct xpvhv to the free list */
-
-STATIC void
-S_del_xpvhv(pTHX_ XPVHV *p)
-{
- xpvhv_allocated* xpvhv
- = (xpvhv_allocated*)((char*)(p) + STRUCT_OFFSET(XPVHV, xhv_fill)
- - STRUCT_OFFSET(xpvhv_allocated, xhv_fill));
- LOCK_SV_MUTEX;
- *(xpvhv_allocated**)xpvhv = PL_xpvhv_root;
- PL_xpvhv_root = xpvhv;
- UNLOCK_SV_MUTEX;
-}
-
-/* grab a new struct xpvmg from the free list, allocating more if necessary */
-
-STATIC XPVMG*
-S_new_xpvmg(pTHX)
-{
- XPVMG* xpvmg;
- LOCK_SV_MUTEX;
- if (!PL_xpvmg_root)
- S_more_xpvmg(aTHX);
- xpvmg = PL_xpvmg_root;
- PL_xpvmg_root = *(XPVMG**)xpvmg;
- UNLOCK_SV_MUTEX;
- return xpvmg;
-}
-
-/* return a struct xpvmg to the free list */
-
-STATIC void
-S_del_xpvmg(pTHX_ XPVMG *p)
-{
- LOCK_SV_MUTEX;
- *(XPVMG**)p = PL_xpvmg_root;
- PL_xpvmg_root = p;
- UNLOCK_SV_MUTEX;
-}
-
-/* grab a new struct xpvgv from the free list, allocating more if necessary */
-
-STATIC XPVGV*
-S_new_xpvgv(pTHX)
-{
- XPVGV* xpvgv;
- LOCK_SV_MUTEX;
- if (!PL_xpvgv_root)
- S_more_xpvgv(aTHX);
- xpvgv = PL_xpvgv_root;
- PL_xpvgv_root = *(XPVGV**)xpvgv;
- UNLOCK_SV_MUTEX;
- return xpvgv;
-}
-
-/* return a struct xpvgv to the free list */
-
-STATIC void
-S_del_xpvgv(pTHX_ XPVGV *p)
-{
- LOCK_SV_MUTEX;
- *(XPVGV**)p = PL_xpvgv_root;
- PL_xpvgv_root = p;
- UNLOCK_SV_MUTEX;
-}
-
-/* grab a new struct xpvlv from the free list, allocating more if necessary */
-
-STATIC XPVLV*
-S_new_xpvlv(pTHX)
+void
+Perl_sv_setuv(pTHX_ register SV *sv, UV u)
{
- XPVLV* xpvlv;
- LOCK_SV_MUTEX;
- if (!PL_xpvlv_root)
- S_more_xpvlv(aTHX);
- xpvlv = PL_xpvlv_root;
- PL_xpvlv_root = *(XPVLV**)xpvlv;
- UNLOCK_SV_MUTEX;
- return xpvlv;
-}
+ /* With these two if statements:
+ u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865
-/* return a struct xpvlv to the free list */
+ without
+ u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865
-STATIC void
-S_del_xpvlv(pTHX_ XPVLV *p)
-{
- LOCK_SV_MUTEX;
- *(XPVLV**)p = PL_xpvlv_root;
- PL_xpvlv_root = p;
- UNLOCK_SV_MUTEX;
+ If you wish to remove them, please benchmark to see what the effect is
+ */
+ if (u <= (UV)IV_MAX) {
+ sv_setiv(sv, (IV)u);
+ return;
+ }
+ sv_setiv(sv, 0);
+ SvIsUV_on(sv);
+ SvUV_set(sv, u);
}
-/* grab a new struct xpvbm from the free list, allocating more if necessary */
+/*
+=for apidoc sv_setuv_mg
-STATIC XPVBM*
-S_new_xpvbm(pTHX)
-{
- XPVBM* xpvbm;
- LOCK_SV_MUTEX;
- if (!PL_xpvbm_root)
- S_more_xpvbm(aTHX);
- xpvbm = PL_xpvbm_root;
- PL_xpvbm_root = *(XPVBM**)xpvbm;
- UNLOCK_SV_MUTEX;
- return xpvbm;
-}
+Like C<sv_setuv>, but also handles 'set' magic.
-/* return a struct xpvbm to the free list */
+=cut
+*/
-STATIC void
-S_del_xpvbm(pTHX_ XPVBM *p)
+void
+Perl_sv_setuv_mg(pTHX_ register SV *sv, UV u)
{
- LOCK_SV_MUTEX;
- *(XPVBM**)p = PL_xpvbm_root;
- PL_xpvbm_root = p;
- UNLOCK_SV_MUTEX;
+ sv_setiv(sv, 0);
+ SvIsUV_on(sv);
+ sv_setuv(sv,u);
+ SvSETMAGIC(sv);
}
-#define my_safemalloc(s) (void*)safemalloc(s)
-#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_XPV() my_safemalloc(sizeof(XPV))
-#define del_XPV(p) my_safefree(p)
-
-#define new_XPVIV() my_safemalloc(sizeof(XPVIV))
-#define del_XPVIV(p) my_safefree(p)
-
-#define new_XPVNV() my_safemalloc(sizeof(XPVNV))
-#define del_XPVNV(p) my_safefree(p)
-
-#define new_XPVCV() my_safemalloc(sizeof(XPVCV))
-#define del_XPVCV(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)
-
-#define new_XPVLV() my_safemalloc(sizeof(XPVLV))
-#define del_XPVLV(p) my_safefree(p)
-
-#define new_XPVBM() my_safemalloc(sizeof(XPVBM))
-#define del_XPVBM(p) my_safefree(p)
-
-#else /* !PURIFY */
-
-#define new_XNV() (void*)new_xnv()
-#define del_XNV(p) del_xnv((XPVNV*) p)
-
-#define new_XPV() (void*)new_xpv()
-#define del_XPV(p) del_xpv((XPV *)p)
-
-#define new_XPVIV() (void*)new_xpviv()
-#define del_XPVIV(p) del_xpviv((XPVIV *)p)
-
-#define new_XPVNV() (void*)new_xpvnv()
-#define del_XPVNV(p) del_xpvnv((XPVNV *)p)
-
-#define new_XPVCV() (void*)new_xpvcv()
-#define del_XPVCV(p) del_xpvcv((XPVCV *)p)
-
-#define new_XPVAV() (void*)new_xpvav()
-#define del_XPVAV(p) del_xpvav((XPVAV *)p)
-
-#define new_XPVHV() (void*)new_xpvhv()
-#define del_XPVHV(p) del_xpvhv((XPVHV *)p)
-
-#define new_XPVMG() (void*)new_xpvmg()
-#define del_XPVMG(p) del_xpvmg((XPVMG *)p)
-
-#define new_XPVGV() (void*)new_xpvgv()
-#define del_XPVGV(p) del_xpvgv((XPVGV *)p)
-
-#define new_XPVLV() (void*)new_xpvlv()
-#define del_XPVLV(p) del_xpvlv((XPVLV *)p)
-
-#define new_XPVBM() (void*)new_xpvbm()
-#define del_XPVBM(p) del_xpvbm((XPVBM *)p)
-
-#endif /* PURIFY */
-
-#define new_XPVFM() my_safemalloc(sizeof(XPVFM))
-#define del_XPVFM(p) my_safefree(p)
-
-#define new_XPVIO() my_safemalloc(sizeof(XPVIO))
-#define del_XPVIO(p) my_safefree(p)
-
/*
-=for apidoc sv_upgrade
+=for apidoc sv_setnv
-Upgrade an SV to a more complex form. Generally adds a new body type to the
-SV, then copies across as much information as possible from the old body.
-You generally want to use the C<SvUPGRADE> macro wrapper. See also C<svtype>.
+Copies a double into the given SV, upgrading first if necessary.
+Does not handle 'set' magic. See also C<sv_setnv_mg>.
=cut
*/
-bool
-Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt)
+void
+Perl_sv_setnv(pTHX_ register SV *sv, NV num)
{
-
- char* pv;
- U32 cur;
- U32 len;
- IV iv;
- NV nv;
- MAGIC* magic;
- HV* stash;
-
- if (mt != SVt_PV && SvIsCOW(sv)) {
- sv_force_normal_flags(sv, 0);
- }
-
- if (SvTYPE(sv) == mt)
- return TRUE;
-
- pv = NULL;
- cur = 0;
- len = 0;
- iv = 0;
- nv = 0.0;
- magic = NULL;
- stash = Nullhv;
-
+ SV_CHECK_THINKFIRST_COW_DROP(sv);
switch (SvTYPE(sv)) {
case SVt_NULL:
- break;
case SVt_IV:
- iv = SvIVX(sv);
- if (mt == SVt_NV)
- mt = SVt_PVNV;
- else if (mt < SVt_PVIV)
- mt = SVt_PVIV;
- break;
- case SVt_NV:
- nv = SvNVX(sv);
- del_XNV(SvANY(sv));
- if (mt < SVt_PVNV)
- mt = SVt_PVNV;
+ sv_upgrade(sv, SVt_NV);
break;
case SVt_RV:
- pv = (char*)SvRV(sv);
- break;
case SVt_PV:
- pv = SvPVX_mutable(sv);
- cur = SvCUR(sv);
- len = SvLEN(sv);
- del_XPV(SvANY(sv));
- if (mt <= SVt_IV)
- mt = SVt_PVIV;
- else if (mt == SVt_NV)
- mt = SVt_PVNV;
- break;
case SVt_PVIV:
- pv = SvPVX_mutable(sv);
- cur = SvCUR(sv);
- len = SvLEN(sv);
- iv = SvIVX(sv);
- del_XPVIV(SvANY(sv));
- break;
- case SVt_PVNV:
- pv = SvPVX_mutable(sv);
- cur = SvCUR(sv);
- len = SvLEN(sv);
- iv = SvIVX(sv);
- nv = SvNVX(sv);
- del_XPVNV(SvANY(sv));
- break;
- case SVt_PVMG:
- /* Because the XPVMG of PL_mess_sv isn't allocated from the arena,
- there's no way that it can be safely upgraded, because perl.c
- expects to Safefree(SvANY(PL_mess_sv)) */
- assert(sv != PL_mess_sv);
- /* This flag bit is used to mean other things in other scalar types.
- Given that it only has meaning inside the pad, it shouldn't be set
- on anything that can get upgraded. */
- assert((SvFLAGS(sv) & SVpad_TYPED) == 0);
- pv = SvPVX_mutable(sv);
- cur = SvCUR(sv);
- len = SvLEN(sv);
- iv = SvIVX(sv);
- nv = SvNVX(sv);
- magic = SvMAGIC(sv);
- stash = SvSTASH(sv);
- del_XPVMG(SvANY(sv));
- break;
- default:
- Perl_croak(aTHX_ "Can't upgrade that kind of scalar");
- }
-
- SvFLAGS(sv) &= ~SVTYPEMASK;
- SvFLAGS(sv) |= mt;
-
- switch (mt) {
- case SVt_NULL:
- Perl_croak(aTHX_ "Can't upgrade to undef");
- case SVt_IV:
- SvANY(sv) = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
- SvIV_set(sv, iv);
- break;
- case SVt_NV:
- SvANY(sv) = new_XNV();
- SvNV_set(sv, nv);
- break;
- case SVt_RV:
- SvANY(sv) = &sv->sv_u.svu_rv;
- SvRV_set(sv, (SV*)pv);
- break;
- case SVt_PVHV:
- SvANY(sv) = new_XPVHV();
- HvFILL(sv) = 0;
- HvMAX(sv) = 0;
- HvTOTALKEYS(sv) = 0;
-
- /* Fall through... */
- if (0) {
- case SVt_PVAV:
- SvANY(sv) = new_XPVAV();
- AvMAX(sv) = -1;
- AvFILLp(sv) = -1;
- AvALLOC(sv) = 0;
- AvREAL_only(sv);
- }
- /* to here. */
- /* XXX? Only SVt_NULL is ever upgraded to AV or HV? */
- assert(!pv);
- /* FIXME. Should be able to remove all this if()... if the above
- assertion is genuinely always true. */
- if(SvOOK(sv)) {
- pv -= iv;
- SvFLAGS(sv) &= ~SVf_OOK;
- }
- Safefree(pv);
- SvPV_set(sv, (char*)0);
- SvMAGIC_set(sv, magic);
- SvSTASH_set(sv, stash);
+ sv_upgrade(sv, SVt_PVNV);
break;
- case SVt_PVIO:
- SvANY(sv) = new_XPVIO();
- Zero(SvANY(sv), 1, XPVIO);
- IoPAGE_LEN(sv) = 60;
- goto set_magic_common;
- case SVt_PVFM:
- SvANY(sv) = new_XPVFM();
- Zero(SvANY(sv), 1, XPVFM);
- goto set_magic_common;
- case SVt_PVBM:
- SvANY(sv) = new_XPVBM();
- BmRARE(sv) = 0;
- BmUSEFUL(sv) = 0;
- BmPREVIOUS(sv) = 0;
- goto set_magic_common;
case SVt_PVGV:
- SvANY(sv) = new_XPVGV();
- GvGP(sv) = 0;
- GvNAME(sv) = 0;
- GvNAMELEN(sv) = 0;
- GvSTASH(sv) = 0;
- GvFLAGS(sv) = 0;
- goto set_magic_common;
+ case SVt_PVAV:
+ case SVt_PVHV:
case SVt_PVCV:
- SvANY(sv) = new_XPVCV();
- Zero(SvANY(sv), 1, XPVCV);
- goto set_magic_common;
- case SVt_PVLV:
- SvANY(sv) = new_XPVLV();
- LvTARGOFF(sv) = 0;
- LvTARGLEN(sv) = 0;
- LvTARG(sv) = 0;
- LvTYPE(sv) = 0;
- GvGP(sv) = 0;
- GvNAME(sv) = 0;
- GvNAMELEN(sv) = 0;
- GvSTASH(sv) = 0;
- GvFLAGS(sv) = 0;
- /* Fall through. */
- if (0) {
- case SVt_PVMG:
- SvANY(sv) = new_XPVMG();
- }
- set_magic_common:
- SvMAGIC_set(sv, magic);
- SvSTASH_set(sv, stash);
- /* Fall through. */
- if (0) {
- case SVt_PVNV:
- SvANY(sv) = new_XPVNV();
- }
- SvNV_set(sv, nv);
- /* Fall through. */
- if (0) {
- case SVt_PVIV:
- SvANY(sv) = new_XPVIV();
- if (SvNIOK(sv))
- (void)SvIOK_on(sv);
- SvNOK_off(sv);
- }
- SvIV_set(sv, iv);
- /* Fall through. */
- if (0) {
- case SVt_PV:
- SvANY(sv) = new_XPV();
- }
- SvPV_set(sv, pv);
- SvCUR_set(sv, cur);
- SvLEN_set(sv, len);
- break;
+ case SVt_PVFM:
+ case SVt_PVIO:
+ Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
+ OP_NAME(PL_op));
}
- return TRUE;
+ SvNV_set(sv, num);
+ (void)SvNOK_only(sv); /* validate number */
+ SvTAINT(sv);
}
/*
-=for apidoc sv_backoff
+=for apidoc sv_setnv_mg
-Remove any string offset. You should normally use the C<SvOOK_off> macro
-wrapper instead.
+Like C<sv_setnv>, but also handles 'set' magic.
=cut
*/
-int
-Perl_sv_backoff(pTHX_ register SV *sv)
+void
+Perl_sv_setnv_mg(pTHX_ register SV *sv, NV num)
{
- assert(SvOOK(sv));
- assert(SvTYPE(sv) != SVt_PVHV);
- assert(SvTYPE(sv) != SVt_PVAV);
- if (SvIVX(sv)) {
- const char *s = SvPVX_const(sv);
- SvLEN_set(sv, SvLEN(sv) + SvIVX(sv));
- SvPV_set(sv, SvPVX(sv) - SvIVX(sv));
- SvIV_set(sv, 0);
- Move(s, SvPVX(sv), SvCUR(sv)+1, char);
- }
- SvFLAGS(sv) &= ~SVf_OOK;
- return 0;
+ sv_setnv(sv,num);
+ SvSETMAGIC(sv);
}
-/*
-=for apidoc sv_grow
-
-Expands the character buffer in the SV. If necessary, uses C<sv_unref> and
-upgrades the SV to C<SVt_PV>. Returns a pointer to the character buffer.
-Use the C<SvGROW> wrapper instead.
-
-=cut
-*/
+/* Print an "isn't numeric" warning, using a cleaned-up,
+ * printable version of the offending string
+ */
-char *
-Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen)
+STATIC void
+S_not_a_number(pTHX_ SV *sv)
{
- register char *s;
-
-#ifdef HAS_64K_LIMIT
- if (newlen >= 0x10000) {
- PerlIO_printf(Perl_debug_log,
- "Allocation too large: %"UVxf"\n", (UV)newlen);
- my_exit(1);
- }
-#endif /* HAS_64K_LIMIT */
- if (SvROK(sv))
- sv_unref(sv);
- if (SvTYPE(sv) < SVt_PV) {
- sv_upgrade(sv, SVt_PV);
- s = SvPVX_mutable(sv);
- }
- else if (SvOOK(sv)) { /* pv is offset? */
- sv_backoff(sv);
- s = SvPVX_mutable(sv);
- if (newlen > SvLEN(sv))
- newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
-#ifdef HAS_64K_LIMIT
- if (newlen >= 0x10000)
- newlen = 0xFFFF;
-#endif
- }
- else
- s = SvPVX_mutable(sv);
-
- if (newlen > SvLEN(sv)) { /* need more room? */
- newlen = PERL_STRLEN_ROUNDUP(newlen);
- if (SvLEN(sv) && s) {
-#ifdef MYMALLOC
- const STRLEN l = malloced_size((void*)SvPVX_const(sv));
- if (newlen <= l) {
- SvLEN_set(sv, l);
- return s;
- } else
-#endif
- s = saferealloc(s, newlen);
- }
- else {
- s = safemalloc(newlen);
- if (SvPVX_const(sv) && SvCUR(sv)) {
- Move(SvPVX_const(sv), s, (newlen < SvCUR(sv)) ? newlen : SvCUR(sv), char);
- }
- }
- SvPV_set(sv, s);
- SvLEN_set(sv, newlen);
- }
- return s;
-}
-
-/*
-=for apidoc sv_setiv
-
-Copies an integer into the given SV, upgrading first if necessary.
-Does not handle 'set' magic. See also C<sv_setiv_mg>.
-
-=cut
-*/
-
-void
-Perl_sv_setiv(pTHX_ register SV *sv, IV i)
-{
- SV_CHECK_THINKFIRST_COW_DROP(sv);
- switch (SvTYPE(sv)) {
- case SVt_NULL:
- sv_upgrade(sv, SVt_IV);
- break;
- case SVt_NV:
- sv_upgrade(sv, SVt_PVNV);
- break;
- case SVt_RV:
- case SVt_PV:
- sv_upgrade(sv, SVt_PVIV);
- break;
-
- case SVt_PVGV:
- case SVt_PVAV:
- case SVt_PVHV:
- case SVt_PVCV:
- case SVt_PVFM:
- case SVt_PVIO:
- Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
- OP_DESC(PL_op));
- }
- (void)SvIOK_only(sv); /* validate number */
- SvIV_set(sv, i);
- SvTAINT(sv);
-}
-
-/*
-=for apidoc sv_setiv_mg
-
-Like C<sv_setiv>, but also handles 'set' magic.
-
-=cut
-*/
-
-void
-Perl_sv_setiv_mg(pTHX_ register SV *sv, IV i)
-{
- sv_setiv(sv,i);
- SvSETMAGIC(sv);
-}
-
-/*
-=for apidoc sv_setuv
-
-Copies an unsigned integer into the given SV, upgrading first if necessary.
-Does not handle 'set' magic. See also C<sv_setuv_mg>.
-
-=cut
-*/
-
-void
-Perl_sv_setuv(pTHX_ register SV *sv, UV u)
-{
- /* With these two if statements:
- u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865
-
- without
- u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865
-
- If you wish to remove them, please benchmark to see what the effect is
- */
- if (u <= (UV)IV_MAX) {
- sv_setiv(sv, (IV)u);
- return;
- }
- sv_setiv(sv, 0);
- SvIsUV_on(sv);
- SvUV_set(sv, u);
-}
-
-/*
-=for apidoc sv_setuv_mg
-
-Like C<sv_setuv>, but also handles 'set' magic.
-
-=cut
-*/
-
-void
-Perl_sv_setuv_mg(pTHX_ register SV *sv, UV u)
-{
- /* With these two if statements:
- u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865
-
- without
- u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865
-
- If you wish to remove them, please benchmark to see what the effect is
- */
- if (u <= (UV)IV_MAX) {
- sv_setiv(sv, (IV)u);
- } else {
- sv_setiv(sv, 0);
- SvIsUV_on(sv);
- sv_setuv(sv,u);
- }
- SvSETMAGIC(sv);
-}
-
-/*
-=for apidoc sv_setnv
-
-Copies a double into the given SV, upgrading first if necessary.
-Does not handle 'set' magic. See also C<sv_setnv_mg>.
-
-=cut
-*/
-
-void
-Perl_sv_setnv(pTHX_ register SV *sv, NV num)
-{
- SV_CHECK_THINKFIRST_COW_DROP(sv);
- switch (SvTYPE(sv)) {
- case SVt_NULL:
- case SVt_IV:
- sv_upgrade(sv, SVt_NV);
- break;
- case SVt_RV:
- case SVt_PV:
- case SVt_PVIV:
- sv_upgrade(sv, SVt_PVNV);
- break;
-
- case SVt_PVGV:
- case SVt_PVAV:
- case SVt_PVHV:
- case SVt_PVCV:
- case SVt_PVFM:
- case SVt_PVIO:
- Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
- OP_NAME(PL_op));
- }
- SvNV_set(sv, num);
- (void)SvNOK_only(sv); /* validate number */
- SvTAINT(sv);
-}
-
-/*
-=for apidoc sv_setnv_mg
-
-Like C<sv_setnv>, but also handles 'set' magic.
-
-=cut
-*/
-
-void
-Perl_sv_setnv_mg(pTHX_ register SV *sv, NV num)
-{
- sv_setnv(sv,num);
- SvSETMAGIC(sv);
-}
-
-/* Print an "isn't numeric" warning, using a cleaned-up,
- * printable version of the offending string
- */
-
-STATIC void
-S_not_a_number(pTHX_ SV *sv)
-{
- SV *dsv;
- char tmpbuf[64];
- char *pv;
+ SV *dsv;
+ char tmpbuf[64];
+ const char *pv;
if (DO_UTF8(sv)) {
- dsv = sv_2mortal(newSVpv("", 0));
+ dsv = sv_2mortal(newSVpvn("", 0));
pv = sv_uni_display(dsv, sv, 10, 0);
} else {
char *d = tmpbuf;
- char *limit = tmpbuf + sizeof(tmpbuf) - 8;
+ const char * const limit = tmpbuf + sizeof(tmpbuf) - 8;
/* each *s can expand to 4 chars + "...\0",
i.e. need room for 8 chars */
- const char *s, *end;
- for (s = SvPVX_const(sv), end = s + SvCUR(sv); s < end && d < limit;
- s++) {
+ 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*/
-/* sv_2iv() is now a macro using Perl_sv_2iv_flags();
- * this function provided for binary compatibility only
- */
-
-IV
-Perl_sv_2iv(pTHX_ register SV *sv)
-{
- return sv_2iv_flags(sv, SV_GMAGIC);
-}
-
-/*
-=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.
+STATIC bool
+S_sv_2iuv_common(pTHX_ SV *sv) {
+ if (SvNOKp(sv)) {
+ /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
+ * without also getting a cached IV/UV from it at the same time
+ * (ie PV->NV conversion should detect loss of accuracy and cache
+ * IV or UV at same time to avoid this. */
+ /* IV-over-UV optimisation - choose to cache IV if possible */
-=cut
-*/
-
-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 (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
- report_uninit(sv);
- }
- return 0;
- }
- }
- if (SvTHINKFIRST(sv)) {
- if (SvROK(sv)) {
- SV* tmpstr;
- if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
- (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv))))
- return 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);
- }
- }
- if (SvNOKp(sv)) {
- /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
- * without also getting a cached IV/UV from it at the same time
- * (ie PV->NV conversion should detect loss of accuracy and cache
- * IV or UV at same time to avoid this. NWC */
-
- if (SvTYPE(sv) == SVt_NV)
- sv_upgrade(sv, SVt_PVNV);
+ if (SvTYPE(sv) == SVt_NV)
+ sv_upgrade(sv, SVt_PVNV);
(void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
/* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost
)
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 (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
- 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;
+ /* Return 0 from the caller. */
+ return TRUE;
}
- DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
- PTR2UV(sv),SvIVX(sv)));
- return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
+ return FALSE;
}
-/* sv_2uv() is now a macro using Perl_sv_2uv_flags();
- * this function provided for binary compatibility only
- */
+/*
+=for apidoc sv_2iv_flags
-UV
-Perl_sv_2uv(pTHX_ register SV *sv)
+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)
{
- return sv_2uv_flags(sv, SV_GMAGIC);
+ 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. */
+ } else if (SvTHINKFIRST(sv)) {
+ if (SvROK(sv)) {
+ return_rok:
+ if (SvAMAGIC(sv)) {
+ SV * const tmpstr=AMG_CALLun(sv,numer);
+ if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
+ return SvIV(tmpstr);
+ }
+ }
+ return PTR2IV(SvRV(sv));
+ }
+ if (SvIsCOW(sv)) {
+ sv_force_normal_flags(sv, 0);
+ }
+ if (SvREADONLY(sv) && !SvOK(sv)) {
+ if (ckWARN(WARN_UNINITIALIZED))
+ report_uninit(sv);
+ return 0;
+ }
+ }
+ if (!SvIOKp(sv)) {
+ if (S_sv_2iuv_common(aTHX_ sv))
+ return 0;
+ }
+ DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
+ PTR2UV(sv),SvIVX(sv)));
+ return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
}
/*
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 (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
- 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 (SvTHINKFIRST(sv)) {
+ if (SvROK(sv)) {
+ goto return_rok;
+ }
+ assert(SvTYPE(sv) >= SVt_PVMG);
+ /* This falls through to the report_uninit inside S_sv_2iuv_common. */
+ } else 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)));
- }
- }
- 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 (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
- 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 (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) &&
- !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 (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
- 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 (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);
+ /* 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();
else if (SvPOKp(sv) && SvLEN(sv)) {
UV value;
const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
- if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !numtype)
+ if (!SvIOKp(sv) && !numtype && ckWARN(WARN_NUMERIC))
not_a_number(sv);
#ifdef NV_PRESERVES_UV
if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
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);
}
}
}
#endif /* NV_PRESERVES_UV */
}
else {
- if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
+ 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)));
-}
-
-/*
-=for apidoc sv_2pv_nolen
-
-Like C<sv_2pv()>, but doesn't return the length too. You should usually
-use the macro wrapper C<SvPV_nolen(sv)> instead.
-=cut
-*/
-
-char *
-Perl_sv_2pv_nolen(pTHX_ register SV *sv)
-{
- return sv_2pv(sv, 0);
-}
-
/* 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.
*/
static char *
-uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
+S_uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
{
char *ptr = buf + TYPE_CHARS(UV);
- char *ebuf = ptr;
+ char * const ebuf = ptr;
int sign;
if (is_uv)
return ptr;
}
-/* sv_2pv() is now a macro using Perl_sv_2pv_flags();
- * this function provided for binary compatibility only
+/* stringify_regexp(): private routine for use by sv_2pv_flags(): converts
+ * a regexp to its stringified form.
*/
-char *
-Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
-{
- return sv_2pv_flags(sv, lp, SV_GMAGIC);
+static char *
+S_stringify_regexp(pTHX_ SV *sv, MAGIC *mg, STRLEN *lp) {
+ const regexp * const re = (regexp *)mg->mg_obj;
+
+ if (!mg->mg_ptr) {
+ const char *fptr = "msix";
+ char reflags[6];
+ char ch;
+ int left = 0;
+ int right = 4;
+ bool need_newline = 0;
+ U16 reganch = (U16)((re->reganch & PMf_COMPILETIME) >> 12);
+
+ while((ch = *fptr++)) {
+ if(reganch & 1) {
+ reflags[left++] = ch;
+ }
+ else {
+ reflags[right--] = ch;
+ }
+ reganch >>= 1;
+ }
+ if(left != 4) {
+ reflags[left] = '-';
+ left = 5;
+ }
+
+ mg->mg_len = re->prelen + 4 + left;
+ /*
+ * If /x was used, we have to worry about a regex ending with a
+ * comment later being embedded within another regex. If so, we don't
+ * want this regex's "commentization" to leak out to the right part of
+ * the enclosing regex, we must cap it with a newline.
+ *
+ * So, if /x was used, we scan backwards from the end of the regex. If
+ * we find a '#' before we find a newline, we need to add a newline
+ * ourself. If we find a '\n' first (or if we don't find '#' or '\n'),
+ * we don't need to add anything. -jfriedl
+ */
+ if (PMf_EXTENDED & re->reganch) {
+ const char *endptr = re->precomp + re->prelen;
+ while (endptr >= re->precomp) {
+ const char c = *(endptr--);
+ if (c == '\n')
+ break; /* don't need another */
+ if (c == '#') {
+ /* we end while in a comment, so we need a newline */
+ mg->mg_len++; /* save space for it */
+ need_newline = 1; /* note to add it */
+ break;
+ }
+ }
+ }
+
+ 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;
}
/*
Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags)
{
register char *s;
- int olderrno;
- SV *tsv, *origsv;
- char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */
- char *tmpbuf = tbuf;
if (!sv) {
if (lp)
return (char *)SvPVX_const(sv);
return SvPVX(sv);
}
- if (SvIOKp(sv)) {
- if (SvIsUV(sv))
- (void)sprintf(tmpbuf,"%"UVuf, (UV)SvUVX(sv));
- else
- (void)sprintf(tmpbuf,"%"IVdf, (IV)SvIVX(sv));
- tsv = Nullsv;
- goto tokensave;
- }
- if (SvNOKp(sv)) {
- Gconvert(SvNVX(sv), NV_DIG, 0, tmpbuf);
- tsv = Nullsv;
- goto tokensave;
- }
- if (!SvROK(sv)) {
- if (!(SvFLAGS(sv) & SVs_PADTMP)) {
- if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
- 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 (lp)
- *lp = 0;
- return (char *)"";
- }
- }
- if (SvTHINKFIRST(sv)) {
+ if (SvROK(sv)) { /* XXX Skip this when sv_pvn_force calls */
+ /* Sneaky stuff here */
+ SV * const tsv = newSVpvn(tbuf, len);
+
+ sv_2mortal(tsv);
+ if (lp)
+ *lp = SvCUR(tsv);
+ return SvPVX(tsv);
+ }
+ else {
+ dVAR;
+
+#ifdef FIXNEGATIVEZERO
+ if (len == 2 && tbuf[0] == '-' && tbuf[1] == '0') {
+ tbuf[0] = '0';
+ tbuf[1] = 0;
+ len = 1;
+ }
+#endif
+ SvUPGRADE(sv, SVt_PV);
+ if (lp)
+ *lp = len;
+ s = SvGROW_mutable(sv, len + 1);
+ SvCUR_set(sv, len);
+ SvPOKp_on(sv);
+ return memcpy(s, tbuf, len + 1);
+ }
+ }
+ 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)) {
- 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);
+ return_rok:
+ if (SvAMAGIC(sv)) {
+ SV *const tmpstr = AMG_CALLun(sv,string);
+ if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
+ /* Unwrap this: */
+ /* char *pv = lp ? SvPV(tmpstr, *lp) : SvPV_nolen(tmpstr);
+ */
+
+ char *pv;
+ if ((SvFLAGS(tmpstr) & (SVf_POK)) == SVf_POK) {
+ if (flags & SV_CONST_RETURN) {
+ pv = (char *) SvPVX_const(tmpstr);
+ } else {
+ pv = (flags & SV_MUTABLE_RETURN)
+ ? SvPVX_mutable(tmpstr) : SvPVX(tmpstr);
+ }
+ if (lp)
+ *lp = SvCUR(tmpstr);
} else {
- pv = (flags & SV_MUTABLE_RETURN)
- ? SvPVX_mutable(tmpstr) : SvPVX(tmpstr);
+ pv = sv_2pv_flags(tmpstr, lp, flags);
}
- if (lp)
- *lp = SvCUR(tmpstr);
- } else {
- pv = sv_2pv_flags(tmpstr, lp, flags);
+ if (SvUTF8(tmpstr))
+ SvUTF8_on(sv);
+ else
+ SvUTF8_off(sv);
+ return pv;
}
- if (SvUTF8(tmpstr))
- SvUTF8_on(sv);
- else
- SvUTF8_off(sv);
- return pv;
- }
- origsv = sv;
- sv = (SV*)SvRV(sv);
- if (!sv)
- typestr = "NULLREF";
- else {
+ }
+ {
+ SV *tsv;
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;
- }
- }
- }
-
- New(616, mg->mg_ptr, mg->mg_len + 1 + left, char);
- Copy("(?", mg->mg_ptr, 2, char);
- Copy(reflags, mg->mg_ptr+2, left, char);
- Copy(":", mg->mg_ptr+left+2, 1, char);
- Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char);
- if (need_newline)
- mg->mg_ptr[mg->mg_len - 2] = '\n';
- mg->mg_ptr[mg->mg_len - 1] = ')';
- mg->mg_ptr[mg->mg_len] = 0;
- }
- PL_reginterp_cnt += re->program[0].next_off;
-
- if (re->reganch & ROPT_UTF8)
- SvUTF8_on(origsv);
- else
- SvUTF8_off(origsv);
- if (lp)
- *lp = mg->mg_len;
- return mg->mg_ptr;
+ 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));
}
- /* Fall through */
- case SVt_NULL:
- case SVt_IV:
- case SVt_NV:
- case SVt_RV:
- case SVt_PV:
- case SVt_PVIV:
- case SVt_PVNV:
- case SVt_PVBM: typestr = SvROK(sv) ? "REF" : "SCALAR"; break;
- case SVt_PVLV: typestr = SvROK(sv) ? "REF"
- /* tied lvalues should appear to be
- * scalars for backwards compatitbility */
- : (LvTYPE(sv) == 't' || LvTYPE(sv) == 'T')
- ? "SCALAR" : "LVALUE"; break;
- case SVt_PVAV: typestr = "ARRAY"; break;
- case SVt_PVHV: typestr = "HASH"; break;
- case SVt_PVCV: typestr = "CODE"; break;
- case SVt_PVGV: typestr = "GLOB"; break;
- case SVt_PVFM: typestr = "FORMAT"; break;
- case SVt_PVIO: typestr = "IO"; break;
- default: typestr = "UNKNOWN"; break;
- }
- tsv = NEWSV(0,0);
- if (SvOBJECT(sv)) {
- const char *name = HvNAME_get(SvSTASH(sv));
- Perl_sv_setpvf(aTHX_ tsv, "%s=%s(0x%"UVxf")",
- name ? name : "__ANON__" , typestr, PTR2UV(sv));
+ else
+ Perl_sv_setpvf(aTHX_ tsv, "%s(0x%"UVxf")", typestr,
+ PTR2UV(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 (SvTYPE(sv) < SVt_PVIV)
sv_upgrade(sv, SVt_PVIV);
- if (isUIOK)
- ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
- else
- ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
+ ptr = uiv_2buf(buf, SvIVX(sv), SvUVX(sv), isUIOK, &ebuf);
/* inlined from sv_setpvn */
SvGROW_mutable(sv, (STRLEN)(ebuf - ptr + 1));
Move(ptr,SvPVX_mutable(sv),ebuf - ptr,char);
SvIsUV_on(sv);
}
else if (SvNOKp(sv)) {
+ const int olderrno = errno;
if (SvTYPE(sv) < SVt_PVNV)
sv_upgrade(sv, SVt_PVNV);
/* The +20 is pure guesswork. Configure test needed. --jhi */
s = SvGROW_mutable(sv, NV_DIG + 20);
- olderrno = errno; /* some Xenix systems wipe out errno here */
+ /* some Xenix systems wipe out errno here */
#ifdef apollo
if (SvNVX(sv) == 0.0)
(void)strcpy(s,"0");
#endif
}
else {
- if (ckWARN(WARN_UNINITIALIZED)
- && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
+ 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);
return (char *)"";
}
{
- STRLEN len = s - SvPVX_const(sv);
+ const STRLEN len = s - SvPVX_const(sv);
if (lp)
*lp = len;
SvCUR_set(sv, len);
if (flags & SV_MUTABLE_RETURN)
return SvPVX_mutable(sv);
return SvPVX(sv);
-
- tokensave:
- if (SvROK(sv)) { /* XXX Skip this when sv_pvn_force calls */
- /* Sneaky stuff here */
-
- tokensaveref:
- if (!tsv)
- tsv = newSVpv(tmpbuf, 0);
- sv_2mortal(tsv);
- if (lp)
- *lp = SvCUR(tsv);
- return SvPVX(tsv);
- }
- else {
- dVAR;
- STRLEN len;
- const char *t;
-
- if (tsv) {
- sv_2mortal(tsv);
- t = SvPVX_const(tsv);
- len = SvCUR(tsv);
- }
- else {
- t = tmpbuf;
- len = strlen(tmpbuf);
- }
-#ifdef FIXNEGATIVEZERO
- if (len == 2 && t[0] == '-' && t[1] == '0') {
- t = "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 strcpy(s, t);
- }
}
/*
Perl_sv_copypv(pTHX_ SV *dsv, register SV *ssv)
{
STRLEN len;
- const char *s;
- s = SvPV_const(ssv,len);
+ const char * const s = SvPV_const(ssv,len);
sv_setpvn(dsv,s,len);
if (SvUTF8(ssv))
SvUTF8_on(dsv);
}
/*
-=for apidoc sv_2pvbyte_nolen
-
-Return a pointer to the byte-encoded representation of the SV.
-May cause the SV to be downgraded from UTF-8 as a side-effect.
-
-Usually accessed via the C<SvPVbyte_nolen> macro.
-
-=cut
-*/
-
-char *
-Perl_sv_2pvbyte_nolen(pTHX_ register SV *sv)
-{
- return sv_2pvbyte(sv, 0);
-}
-
-/*
=for apidoc sv_2pvbyte
Return a pointer to the byte-encoded representation of the SV, and set *lp
Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp)
{
sv_utf8_downgrade(sv,0);
- return SvPV(sv,*lp);
-}
-
-/*
-=for apidoc sv_2pvutf8_nolen
-
-Return a pointer to the UTF-8-encoded representation of the SV.
-May cause the SV to be upgraded to UTF-8 as a side-effect.
-
-Usually accessed via the C<SvPVutf8_nolen> macro.
-
-=cut
-*/
-
-char *
-Perl_sv_2pvutf8_nolen(pTHX_ register SV *sv)
-{
- return sv_2pvutf8(sv, 0);
+ return lp ? SvPV(sv,*lp) : SvPV_nolen(sv);
}
/*
Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp)
{
sv_utf8_upgrade(sv);
- return SvPV(sv,*lp);
+ return lp ? SvPV(sv,*lp) : SvPV_nolen(sv);
}
+
/*
=for apidoc sv_2bool
bool
Perl_sv_2bool(pTHX_ register SV *sv)
{
- if (SvGMAGICAL(sv))
- mg_get(sv);
+ SvGETMAGIC(sv);
if (!SvOK(sv))
return 0;
return SvRV(sv) != 0;
}
if (SvPOKp(sv)) {
- register XPV* Xpvtmp;
- if ((Xpvtmp = (XPV*)SvANY(sv)) &&
+ register XPV* const Xpvtmp = (XPV*)SvANY(sv);
+ if (Xpvtmp &&
(*sv->sv_u.svu_pv > '0' ||
Xpvtmp->xpv_cur > 1 ||
(Xpvtmp->xpv_cur && *sv->sv_u.svu_pv != '0')))
}
}
-/* sv_utf8_upgrade() is now a macro using sv_utf8_upgrade_flags();
- * this function provided for binary compatibility only
- */
-
-
-STRLEN
-Perl_sv_utf8_upgrade(pTHX_ register SV *sv)
-{
- return sv_utf8_upgrade_flags(sv, SV_GMAGIC);
-}
-
/*
=for apidoc sv_utf8_upgrade
* 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 *e = (U8 *) SvEND(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) {
- U8 ch = *t++;
- if ((hibit = !NATIVE_IS_INVARIANT(ch)))
+ const U8 ch = *t++;
+ /* Check for hi bit */
+ if (!NATIVE_IS_INVARIANT(ch)) {
+ STRLEN len = SvCUR(sv) + 1; /* Plus the \0 */
+ U8 * const recoded = bytes_to_utf8((U8*)s, &len);
+
+ SvPV_free(sv); /* No longer using what was there before. */
+ SvPV_set(sv, (char*)recoded);
+ SvCUR_set(sv, len - 1);
+ SvLEN_set(sv, len); /* No longer know the real size. */
break;
- }
- if (hibit) {
- STRLEN len = SvCUR(sv) + 1; /* Plus the \0 */
- char *recoded = bytes_to_utf8((U8*)s, &len);
-
- SvPV_free(sv); /* No longer using what was there before. */
-
- SvPV_set(sv, recoded);
- SvCUR_set(sv, len - 1);
- SvLEN_set(sv, len); /* No longer know the real size. */
+ }
}
/* Mark as UTF-8 even if no hibit - saves scanning loop */
SvUTF8_on(sv);
return FALSE;
e = (const U8 *) SvEND(sv);
while (c < e) {
- U8 ch = *c++;
+ const U8 ch = *c++;
if (!UTF8_IS_INVARIANT(ch)) {
SvUTF8_on(sv);
break;
return TRUE;
}
-/* sv_setsv() is now a macro using Perl_sv_setsv_flags();
- * this function provided for binary compatibility only
- */
-
-void
-Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
-{
- sv_setsv_flags(dstr, sstr, SV_GMAGIC);
-}
-
/*
=for apidoc sv_setsv
if (dtype != SVt_PVLV)
sv_upgrade(dstr, SVt_PVGV);
sv_magic(dstr, dstr, PERL_MAGIC_glob, Nullch, 0);
- GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr));
+ GvSTASH(dstr) = GvSTASH(sstr);
+ if (GvSTASH(dstr))
+ Perl_sv_add_backref(aTHX_ (SV*)GvSTASH(dstr), dstr);
GvNAME(dstr) = savepvn(name, len);
GvNAMELEN(dstr) = len;
SvFAKE_on(dstr); /* can coerce to non-glob */
}
- /* ahem, death to those who redefine active sort subs */
- else if (PL_curstackinfo->si_type == PERLSI_SORT
- && GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr)))
- Perl_croak(aTHX_ "Can't redefine active sort subroutine %s",
- GvNAME(dstr));
#ifdef GV_UNIQUE_CHECK
if (GvUNIQUE((GV*)dstr)) {
if (sflags & SVf_ROK) {
if (dtype >= SVt_PV) {
if (dtype == SVt_PVGV) {
- SV *sref = SvREFCNT_inc(SvRV(sstr));
+ SV * const sref = SvREFCNT_inc(SvRV(sstr));
SV *dref = 0;
const int intro = GvINTRO(dstr);
else
dref = (SV*)GvCV(dstr);
if (GvCV(dstr) != (CV*)sref) {
- CV* cv = GvCV(dstr);
+ CV* const cv = GvCV(dstr);
if (cv) {
if (!GvCVGEN((GV*)dstr) &&
(CvROOT(cv) || CvXSUB(cv)))
{
- /* ahem, death to those who redefine
- * active sort subs */
- if (PL_curstackinfo->si_type == PERLSI_SORT &&
- PL_sortcop == CvSTART(cv))
- Perl_croak(aTHX_
- "Can't redefine active sort subroutine %s",
- GvENAME((GV*)dstr));
/* Redefining a sub - warning is mandatory if
it was a const and its value changed. */
if (ckWARN(WARN_REDEFINE)
}
#endif
/* Initial code is common. */
- if (SvPVX_const(dstr)) { /* we know that dtype >= SVt_PV */
- if (SvOOK(dstr)) {
- SvFLAGS(dstr) &= ~SVf_OOK;
- Safefree(SvPVX_const(dstr) - SvIVX(dstr));
- }
- else if (SvLEN(dstr))
- Safefree(SvPVX_const(dstr));
+ if (SvPVX_const(dstr)) { /* we know that dtype >= SVt_PV */
+ SvPV_free(dstr);
}
if (!isSwipe) {
#endif
{
/* SvIsCOW_shared_hash */
- UV hash = SvSHARED_HASH(sstr);
DEBUG_C(PerlIO_printf(Perl_debug_log,
"Copy on write: Sharing hash\n"));
assert (SvTYPE(dstr) >= SVt_PV);
- /* FIXME - would benefit from share_hek_hek */
SvPV_set(dstr,
- sharepvn(SvPVX_const(sstr),
- (sflags & SVf_UTF8?-cur:cur), hash));
+ HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)))));
}
SvLEN_set(dstr, len);
SvCUR_set(dstr, cur);
}
if (sflags & SVf_UTF8)
SvUTF8_on(dstr);
- /*SUPPRESS 560*/
if (sflags & SVp_NOK) {
SvNOKp_on(dstr);
if (sflags & SVf_NOK)
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);
if (SvLEN(sstr) == 0) {
/* source is a COW shared hash key. */
- UV hash = SvSHARED_HASH(sstr);
DEBUG_C(PerlIO_printf(Perl_debug_log,
"Fast copy on write: Sharing hash\n"));
- /* FIXME - would benefit from share_hek_hek */
- new_pv = sharepvn(SvPVX_const(sstr), (SvUTF8(sstr)?-cur:cur), hash);
+ new_pv = HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr))));
goto common_exit;
}
SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
{
if (len) { /* this SV was SvIsCOW_normal(sv) */
/* we need to find the SV pointing to us. */
- SV *current = SV_COW_NEXT_SV(after);
+ SV * const current = SV_COW_NEXT_SV(after);
if (current == sv) {
/* The SV we point to points back to us (there were only two of us
if (SvREADONLY(sv)) {
/* At this point I believe I should acquire a global SV mutex. */
if (SvFAKE(sv)) {
- const char *pvx = SvPVX_const(sv);
+ const char * const pvx = SvPVX_const(sv);
const STRLEN len = SvLEN(sv);
const STRLEN cur = SvCUR(sv);
SV * const next = SV_COW_NEXT_SV(sv); /* next COW sv in the loop. */
}
SvFAKE_off(sv);
SvREADONLY_off(sv);
- /* This SV doesn't own the buffer, so need to New() a new one: */
+ /* This SV doesn't own the buffer, so need to Newx() a new one: */
SvPV_set(sv, (char*)0);
SvLEN_set(sv, 0);
if (flags & SV_COW_DROP_PV) {
#else
if (SvREADONLY(sv)) {
if (SvFAKE(sv)) {
- const char *pvx = SvPVX_const(sv);
+ const char * const pvx = SvPVX_const(sv);
const STRLEN len = SvCUR(sv);
SvFAKE_off(sv);
SvREADONLY_off(sv);
SvPV_set(sv, Nullch);
SvLEN_set(sv, 0);
SvGROW(sv, len + 1);
- Move(pvx,SvPVX_const(sv),len,char);
+ Move(pvx,SvPVX(sv),len,char);
*SvEND(sv) = '\0';
unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
}
}
/*
-=for apidoc sv_force_normal
-
-Undo various types of fakery on an SV: if the PV is a shared string, make
-a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
-an xpvmg. See also C<sv_force_normal_flags>.
-
-=cut
-*/
-
-void
-Perl_sv_force_normal(pTHX_ register SV *sv)
-{
- sv_force_normal_flags(sv, 0);
-}
-
-/*
=for apidoc sv_chop
Efficient removal of characters from the beginning of the string buffer.
const char *pvx = SvPVX_const(sv);
const STRLEN len = SvCUR(sv);
SvGROW(sv, len + 1);
- Move(pvx,SvPVX_const(sv),len,char);
+ Move(pvx,SvPVX(sv),len,char);
*SvEND(sv) = '\0';
}
SvIV_set(sv, 0);
SvIV_set(sv, SvIVX(sv) + delta);
}
-/* sv_catpvn() is now a macro using Perl_sv_catpvn_flags();
- * this function provided for binary compatibility only
- */
-
-void
-Perl_sv_catpvn(pTHX_ SV *dsv, const char* sstr, STRLEN slen)
-{
- sv_catpvn_flags(dsv, sstr, slen, SV_GMAGIC);
-}
-
/*
=for apidoc sv_catpvn
*SvEND(dsv) = '\0';
(void)SvPOK_only_UTF8(dsv); /* validate pointer */
SvTAINT(dsv);
-}
-
-/*
-=for apidoc sv_catpvn_mg
-
-Like C<sv_catpvn>, but also handles 'set' magic.
-
-=cut
-*/
-
-void
-Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
-{
- sv_catpvn(sv,ptr,len);
- SvSETMAGIC(sv);
-}
-
-/* sv_catsv() is now a macro using Perl_sv_catsv_flags();
- * this function provided for binary compatibility only
- */
-
-void
-Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr)
-{
- sv_catsv_flags(dstr, sstr, SV_GMAGIC);
+ if (flags & SV_SMAGIC)
+ SvSETMAGIC(dsv);
}
/*
void
Perl_sv_catsv_flags(pTHX_ SV *dsv, register SV *ssv, I32 flags)
{
- const char *spv;
- STRLEN slen;
- if (!ssv)
- return;
- if ((spv = SvPV_const(ssv, slen))) {
- /* 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
- get dutf8 = 0x20000000, (i.e. SVf_UTF8) even though
- dsv->sv_flags doesn't have that bit set.
+ if (ssv) {
+ 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
+ get dutf8 = 0x20000000, (i.e. SVf_UTF8) even though
+ dsv->sv_flags doesn't have that bit set.
Andy Dougherty 12 Oct 2001
- */
- const I32 sutf8 = DO_UTF8(ssv);
- I32 dutf8;
+ */
+ const I32 sutf8 = DO_UTF8(ssv);
+ I32 dutf8;
- if (SvGMAGICAL(dsv) && (flags & SV_GMAGIC))
- mg_get(dsv);
- dutf8 = DO_UTF8(dsv);
+ if (SvGMAGICAL(dsv) && (flags & SV_GMAGIC))
+ mg_get(dsv);
+ dutf8 = DO_UTF8(dsv);
- if (dutf8 != sutf8) {
- if (dutf8) {
- /* Not modifying source SV, so taking a temporary copy. */
- SV* csv = sv_2mortal(newSVpvn(spv, slen));
+ if (dutf8 != sutf8) {
+ if (dutf8) {
+ /* Not modifying source SV, so taking a temporary copy. */
+ SV* const csv = sv_2mortal(newSVpvn(spv, slen));
- sv_utf8_upgrade(csv);
- spv = SvPV_const(csv, slen);
+ sv_utf8_upgrade(csv);
+ spv = SvPV_const(csv, slen);
+ }
+ else
+ sv_utf8_upgrade_nomg(dsv);
}
- else
- sv_utf8_upgrade_nomg(dsv);
+ sv_catpvn_nomg(dsv, spv, slen);
}
- sv_catpvn_nomg(dsv, spv, slen);
}
-}
-
-/*
-=for apidoc sv_catsv_mg
-
-Like C<sv_catsv>, but also handles 'set' magic.
-
-=cut
-*/
-
-void
-Perl_sv_catsv_mg(pTHX_ SV *dsv, register SV *ssv)
-{
- sv_catsv(dsv,ssv);
- SvSETMAGIC(dsv);
+ if (flags & SV_SMAGIC)
+ SvSETMAGIC(dsv);
}
/*
if (SvTYPE(sv) < SVt_PVMG) {
SvUPGRADE(sv, SVt_PVMG);
}
- Newz(702,mg, 1, MAGIC);
+ Newxz(mg, 1, MAGIC);
mg->mg_moremagic = SvMAGIC(sv);
SvMAGIC_set(sv, mg);
void
Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
{
- const MGVTBL *vtable = 0;
+ const MGVTBL *vtable;
MAGIC* mg;
#ifdef PERL_OLD_COPY_ON_WRITE
sv_force_normal_flags(sv, 0);
#endif
if (SvREADONLY(sv)) {
- if (IN_PERL_RUNTIME
+ if (
+ /* its okay to attach magic to shared strings; the subsequent
+ * upgrade to PVMG will unshare the string */
+ !(SvFAKE(sv) && SvTYPE(sv) < SVt_PVMG)
+
+ && IN_PERL_RUNTIME
&& how != PERL_MAGIC_regex_global
&& how != PERL_MAGIC_bm
&& how != PERL_MAGIC_fm
vtable = &PL_vtbl_nkeys;
break;
case PERL_MAGIC_dbfile:
- vtable = 0;
+ vtable = NULL;
break;
case PERL_MAGIC_dbline:
vtable = &PL_vtbl_dbline;
case PERL_MAGIC_rhash:
case PERL_MAGIC_symtab:
case PERL_MAGIC_vstring:
- vtable = 0;
+ vtable = NULL;
break;
case PERL_MAGIC_utf8:
vtable = &PL_vtbl_utf8;
/* Useful for attaching extension internal data to perl vars. */
/* Note that multiple extensions may clash if magical scalars */
/* etc holding private data from one are passed to another. */
+ vtable = NULL;
break;
default:
Perl_croak(aTHX_ "Don't know how to handle magic of type \\%o", how);
}
/* Rest of work is done else where */
- mg = sv_magicext(sv,obj,how,(MGVTBL*)vtable,name,namlen);
+ mg = sv_magicext(sv,obj,how,vtable,name,namlen);
switch (how) {
case PERL_MAGIC_taint:
return sv;
}
tsv = SvRV(sv);
- sv_add_backref(tsv, sv);
+ Perl_sv_add_backref(aTHX_ tsv, sv);
SvWEAKREF_on(sv);
SvREFCNT_dec(tsv);
return sv;
* back-reference to sv onto the array associated with the backref magic.
*/
-STATIC void
-S_sv_add_backref(pTHX_ SV *tsv, SV *sv)
+void
+Perl_sv_add_backref(pTHX_ SV *tsv, SV *sv)
{
AV *av;
MAGIC *mg;
* by magic_killbackrefs() when tsv is being freed */
}
if (AvFILLp(av) >= AvMAX(av)) {
- I32 i;
- SV **svp = AvARRAY(av);
- for (i = AvFILLp(av); i >= 0; i--)
- if (!svp[i]) {
- svp[i] = sv; /* reuse the slot */
- return;
- }
av_extend(av, AvFILLp(av)+1);
}
AvARRAY(av)[++AvFILLp(av)] = sv; /* av_push() */
*/
STATIC void
-S_sv_del_backref(pTHX_ SV *sv)
+S_sv_del_backref(pTHX_ SV *tsv, SV *sv)
{
AV *av;
SV **svp;
I32 i;
- SV *tsv = SvRV(sv);
MAGIC *mg = NULL;
+ if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, PERL_MAGIC_backref))) {
+ if (PL_in_clean_all)
+ return;
+ }
if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, PERL_MAGIC_backref)))
Perl_croak(aTHX_ "panic: del_backref");
av = (AV *)mg->mg_obj;
svp = AvARRAY(av);
- for (i = AvFILLp(av); i >= 0; i--)
- if (svp[i] == sv) svp[i] = Nullsv;
+ /* We shouldn't be in here more than once, but for paranoia reasons lets
+ not assume this. */
+ for (i = AvFILLp(av); i >= 0; i--) {
+ if (svp[i] == sv) {
+ const SSize_t fill = AvFILLp(av);
+ if (i != fill) {
+ /* We weren't the last entry.
+ An unordered list has this property that you can take the
+ last element off the end to fill the hole, and it's still
+ an unordered list :-)
+ */
+ svp[i] = svp[fill];
+ }
+ svp[fill] = Nullsv;
+ AvFILLp(av) = fill - 1;
+ }
+ }
}
/*
*mid = '\0';
SvCUR_set(bigstr, mid - big);
}
- /*SUPPRESS 560*/
else if ((i = mid - big)) { /* faster from front */
midend -= littlelen;
mid = midend;
{
const U32 refcnt = SvREFCNT(sv);
SV_CHECK_THINKFIRST_COW_DROP(sv);
- if (SvREFCNT(nsv) != 1 && ckWARN_d(WARN_INTERNAL))
- Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "Reference miscount in sv_replace()");
+ if (SvREFCNT(nsv) != 1) {
+ Perl_croak(aTHX_ "panic: reference miscount on nsv in sv_replace() (%"
+ UVuf " != 1)", (UV) SvREFCNT(nsv));
+ }
if (SvMAGICAL(sv)) {
if (SvMAGICAL(nsv))
mg_free(nsv);
Perl_sv_clear(pTHX_ register SV *sv)
{
dVAR;
- HV* stash;
+ const U32 type = SvTYPE(sv);
+ const struct body_details *const sv_type_details
+ = bodies_by_type + type;
+
assert(sv);
assert(SvREFCNT(sv) == 0);
+ if (type <= SVt_IV)
+ return;
+
if (SvOBJECT(sv)) {
if (PL_defstash) { /* Still have a symbol table? */
dSP;
+ HV* stash;
do {
CV* destructor;
stash = SvSTASH(sv);
destructor = StashHANDLER(stash,DESTROY);
if (destructor) {
- SV* tmpref = newRV(sv);
+ SV* const tmpref = newRV(sv);
SvREADONLY_on(tmpref); /* DESTROY() could be naughty */
ENTER;
PUSHSTACKi(PERLSI_DESTROY);
if (SvOBJECT(sv)) {
SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
SvOBJECT_off(sv); /* Curse the object. */
- if (SvTYPE(sv) != SVt_PVIO)
+ if (type != SVt_PVIO)
--PL_sv_objcount; /* XXX Might want something more general */
}
}
- if (SvTYPE(sv) >= SVt_PVMG) {
+ if (type >= SVt_PVMG) {
if (SvMAGIC(sv))
mg_free(sv);
- if (SvTYPE(sv) == SVt_PVMG && SvFLAGS(sv) & SVpad_TYPED)
+ if (type == SVt_PVMG && SvFLAGS(sv) & SVpad_TYPED)
SvREFCNT_dec(SvSTASH(sv));
}
- stash = NULL;
- switch (SvTYPE(sv)) {
+ switch (type) {
case SVt_PVIO:
if (IoIFP(sv) &&
IoIFP(sv) != PerlIO_stdin() &&
Safefree(IoTOP_NAME(sv));
Safefree(IoFMT_NAME(sv));
Safefree(IoBOTTOM_NAME(sv));
- /* FALL THROUGH */
+ goto freescalar;
case SVt_PVBM:
goto freescalar;
case SVt_PVCV:
case SVt_PVGV:
gp_free((GV*)sv);
Safefree(GvNAME(sv));
- /* cannot decrease stash refcount yet, as we might recursively delete
- ourselves when the refcnt drops to zero. Delay SvREFCNT_dec
- of stash until current sv is completely gone.
- -- JohnPC, 27 Mar 1998 */
- stash = GvSTASH(sv);
- /* FALL THROUGH */
+ /* If we're in a stash, we don't own a reference to it. However it does
+ have a back reference to us, which needs to be cleared. */
+ if (GvSTASH(sv))
+ sv_del_backref((SV*)GvSTASH(sv), sv);
case SVt_PVMG:
case SVt_PVNV:
case SVt_PVIV:
SvPV_set(sv, SvPVX_mutable(sv) - SvIVX(sv));
/* Don't even bother with turning off the OOK flag. */
}
- /* FALL THROUGH */
case SVt_PV:
case SVt_RV:
if (SvROK(sv)) {
+ SV *target = SvRV(sv);
if (SvWEAKREF(sv))
- sv_del_backref(sv);
+ sv_del_backref(target, sv);
else
- SvREFCNT_dec(SvRV(sv));
+ SvREFCNT_dec(target);
}
#ifdef PERL_OLD_COPY_ON_WRITE
else if (SvPVX_const(sv)) {
}
#else
else if (SvPVX_const(sv) && SvLEN(sv))
- Safefree(SvPVX_const(sv));
+ Safefree(SvPVX_mutable(sv));
else if (SvPVX_const(sv) && SvREADONLY(sv) && SvFAKE(sv)) {
unshare_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sv)));
SvFAKE_off(sv);
}
#endif
break;
-/*
case SVt_NV:
- case SVt_IV:
- case SVt_NULL:
break;
-*/
}
- switch (SvTYPE(sv)) {
- case SVt_NULL:
- break;
- case SVt_IV:
- break;
- case SVt_NV:
- del_XNV(SvANY(sv));
- break;
- case SVt_RV:
- break;
- case SVt_PV:
- del_XPV(SvANY(sv));
- break;
- case SVt_PVIV:
- del_XPVIV(SvANY(sv));
- break;
- case SVt_PVNV:
- del_XPVNV(SvANY(sv));
- break;
- case SVt_PVMG:
- del_XPVMG(SvANY(sv));
- break;
- case SVt_PVLV:
- del_XPVLV(SvANY(sv));
- break;
- case SVt_PVAV:
- del_XPVAV(SvANY(sv));
- break;
- case SVt_PVHV:
- del_XPVHV(SvANY(sv));
- break;
- case SVt_PVCV:
- del_XPVCV(SvANY(sv));
- break;
- case SVt_PVGV:
- del_XPVGV(SvANY(sv));
- /* code duplication for increased performance. */
- SvFLAGS(sv) &= SVf_BREAK;
- SvFLAGS(sv) |= SVTYPEMASK;
- /* decrease refcount of the stash that owns this GV, if any */
- if (stash)
- SvREFCNT_dec(stash);
- return; /* not break, SvFLAGS reset already happened */
- case SVt_PVBM:
- del_XPVBM(SvANY(sv));
- break;
- case SVt_PVFM:
- del_XPVFM(SvANY(sv));
- break;
- case SVt_PVIO:
- del_XPVIO(SvANY(sv));
- break;
- }
SvFLAGS(sv) &= SVf_BREAK;
SvFLAGS(sv) |= SVTYPEMASK;
+
+ if (sv_type_details->arena) {
+ del_body(((char *)SvANY(sv) + sv_type_details->offset),
+ &PL_body_roots[type]);
+ }
+ else if (sv_type_details->size) {
+ my_safefree(SvANY(sv));
+ }
}
/*
SvREFCNT(sv) = (~(U32)0)/2;
return;
}
- if (ckWARN_d(WARN_INTERNAL))
+ if (ckWARN_d(WARN_INTERNAL)) {
Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
"Attempt to free unreferenced scalar: SV 0x%"UVxf
pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
+#ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
+ Perl_dump_sv_child(aTHX_ sv);
+#endif
+ }
return;
}
if (--(SvREFCNT(sv)) > 0)
if ((*mgp)->mg_ptr)
*cachep = (STRLEN *) (*mgp)->mg_ptr;
else {
- Newz(0, *cachep, PERL_MAGIC_UTF8_CACHESIZE * 2, STRLEN);
+ Newxz(*cachep, PERL_MAGIC_UTF8_CACHESIZE * 2, STRLEN);
(*mgp)->mg_ptr = (char *) *cachep;
}
assert(*cachep);
STRLEN *cache = 0;
const U8 *s = start;
I32 uoffset = *offsetp;
- const U8 *send = s + len;
+ const U8 * const send = s + len;
MAGIC *mg = 0;
bool found = FALSE;
* is made as in S_utf8_mg_pos(), namely that
* walking backward is twice slower than
* walking forward. */
- STRLEN forw = *offsetp;
+ const STRLEN forw = *offsetp;
STRLEN backw = cache[1] - *offsetp;
if (!(forw < 2 * backw)) {
assert(mg);
if (!mg->mg_ptr) {
- Newz(0, cache, PERL_MAGIC_UTF8_CACHESIZE * 2, STRLEN);
+ Newxz(cache, PERL_MAGIC_UTF8_CACHESIZE * 2, STRLEN);
mg->mg_ptr = (char *) cache;
}
assert(cache);
if (SvUTF8(sv1)) {
/* sv1 is the UTF-8 one,
* if is equal it must be downgrade-able */
- char *pv = (char*)bytes_from_utf8((const U8*)pv1,
+ char * const pv = (char*)bytes_from_utf8((const U8*)pv1,
&cur1, &is_utf8);
if (pv != pv1)
pv1 = tpv = pv;
else {
/* sv2 is the UTF-8 one,
* if is equal it must be downgrade-able */
- char *pv = (char *)bytes_from_utf8((const U8*)pv2,
+ char * const pv = (char *)bytes_from_utf8((const U8*)pv2,
&cur2, &is_utf8);
if (pv != pv2)
pv2 = tpv = pv;
sv_pos_u2b(sv,&append,0);
}
} else if (SvUTF8(sv)) {
- SV *tsv = NEWSV(0,0);
+ SV * const tsv = NEWSV(0,0);
sv_gets(tsv, fp, 0);
sv_utf8_upgrade_nomg(tsv);
SvCUR_set(sv,append);
/*The big, slow, and stupid way. */
#ifdef USE_HEAP_INSTEAD_OF_STACK /* Even slower way. */
STDCHAR *buf = 0;
- New(0, buf, 8192, STDCHAR);
+ Newx(buf, 8192, STDCHAR);
assert(buf);
#else
STDCHAR buf[8192];
screamer2:
if (rslen) {
- const register 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 */
if (!sv)
return;
- if (SvGMAGICAL(sv))
- mg_get(sv);
+ SvGETMAGIC(sv);
if (SvTHINKFIRST(sv)) {
if (SvIsCOW(sv))
sv_force_normal_flags(sv, 0);
if (!(flags & SVp_POK) || !*SvPVX_const(sv)) {
if ((flags & SVTYPEMASK) < SVt_PVIV)
- sv_upgrade(sv, SVt_IV);
+ sv_upgrade(sv, ((flags & SVTYPEMASK) > SVt_IV ? SVt_PVIV : SVt_IV));
(void)SvIOK_only(sv);
SvIV_set(sv, 1);
return;
if (!sv)
return;
- if (SvGMAGICAL(sv))
- mg_get(sv);
+ SvGETMAGIC(sv);
if (SvTHINKFIRST(sv)) {
if (SvIsCOW(sv))
sv_force_normal_flags(sv, 0);
}
else {
(void)SvIOK_only_UV(sv);
- SvUV_set(sv, SvUVX(sv) + 1);
+ SvUV_set(sv, SvUVX(sv) - 1);
}
} else {
if (SvIVX(sv) == IV_MIN)
return;
}
if (!(flags & SVp_POK)) {
- if ((flags & SVTYPEMASK) < SVt_PVNV)
- sv_upgrade(sv, SVt_NV);
- SvNV_set(sv, 1.0);
- (void)SvNOK_only(sv);
+ if ((flags & SVTYPEMASK) < SVt_PVIV)
+ sv_upgrade(sv, ((flags & SVTYPEMASK) > SVt_IV) ? SVt_PVIV : SVt_IV);
+ SvIV_set(sv, -1);
+ (void)SvIOK_only(sv);
return;
}
#ifdef PERL_PRESERVE_IVUV
Andreas would like keys he put in as utf8 to come back as utf8
*/
STRLEN utf8_len = HEK_LEN(hek);
- U8 *as_utf8 = bytes_to_utf8 ((U8*)HEK_KEY(hek), &utf8_len);
- SV *sv = newSVpvn ((char*)as_utf8, utf8_len);
+ const U8 *as_utf8 = bytes_to_utf8 ((U8*)HEK_KEY(hek), &utf8_len);
+ SV * const sv = newSVpvn ((const char*)as_utf8, utf8_len);
SvUTF8_on (sv);
Safefree (as_utf8); /* bytes_to_utf8() allocates a new string */
that would contain the (wrong) hash value, and might get passed
into an hv routine with a regular hash */
- SV *sv = newSVpvn (HEK_KEY(hek), HEK_LEN(hek));
+ SV * const sv = newSVpvn (HEK_KEY(hek), HEK_LEN(hek));
if (HEK_UTF8(hek))
SvUTF8_on (sv);
return sv;
return;
if (!*s) { /* reset ?? searches */
- MAGIC *mg = mg_find((SV *)stash, PERL_MAGIC_symtab);
+ MAGIC * const mg = mg_find((SV *)stash, PERL_MAGIC_symtab);
if (mg) {
PMOP *pm = (PMOP *) mg->mg_obj;
while (pm) {
continue;
gv = (GV*)HeVAL(entry);
sv = GvSV(gv);
- if (SvTHINKFIRST(sv)) {
- if (!SvREADONLY(sv) && SvROK(sv))
- sv_unref(sv);
- continue;
- }
- SvOK_off(sv);
- if (SvTYPE(sv) >= SVt_PV) {
- SvCUR_set(sv, 0);
- if (SvPVX_const(sv) != Nullch)
- *SvPVX(sv) = '\0';
- SvTAINT(sv);
+ if (sv) {
+ if (SvTHINKFIRST(sv)) {
+ if (!SvREADONLY(sv) && SvROK(sv))
+ sv_unref(sv);
+ /* XXX Is this continue a bug? Why should THINKFIRST
+ exempt us from resetting arrays and hashes? */
+ continue;
+ }
+ SvOK_off(sv);
+ if (SvTYPE(sv) >= SVt_PV) {
+ SvCUR_set(sv, 0);
+ if (SvPVX_const(sv) != Nullch)
+ *SvPVX(sv) = '\0';
+ SvTAINT(sv);
+ }
}
if (GvAV(gv)) {
av_clear(GvAV(gv));
}
if (GvHV(gv) && !HvNAME_get(GvHV(gv))) {
+#if defined(VMS)
+ Perl_die(aTHX_ "Can't reset %%ENV on this system");
+#else /* ! VMS */
hv_clear(GvHV(gv));
-#ifndef PERL_MICRO
-#ifdef USE_ENVIRON_ARRAY
- if (gv == PL_envgv
-# ifdef USE_ITHREADS
- && PL_curinterp == aTHX
-# endif
- )
- {
- environ[0] = Nullch;
- }
-#endif
-#endif /* !PERL_MICRO */
+# if defined(USE_ENVIRON_ARRAY)
+ if (gv == PL_envgv)
+ my_clearenv();
+# endif /* USE_ENVIRON_ARRAY */
+#endif /* VMS */
}
}
}
Perl_croak(aTHX_ PL_no_usym, "filehandle");
if (SvROK(sv))
return sv_2io(SvRV(sv));
- gv = gv_fetchsv(sv, FALSE, SVt_PVIO);
+ gv = gv_fetchsv(sv, 0, SVt_PVIO);
if (gv)
io = GvIO(gv);
else
Using various gambits, try to get a CV from an SV; in addition, try if
possible to set C<*st> and C<*gvp> to the stash and GV associated with it.
+The flags in C<lref> are passed to sv_fetchsv.
=cut
*/
CV *cv = Nullcv;
if (!sv)
- return *gvp = Nullgv, Nullcv;
+ return *st = NULL, *gvp = Nullgv, Nullcv;
switch (SvTYPE(sv)) {
case SVt_PVCV:
*st = CvSTASH(sv);
return (CV*)sv;
case SVt_PVHV:
case SVt_PVAV:
+ *st = NULL;
*gvp = Nullgv;
return Nullcv;
case SVt_PVGV:
goto fix_gv;
default:
- if (SvGMAGICAL(sv))
- mg_get(sv);
+ SvGETMAGIC(sv);
if (SvROK(sv)) {
- SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
+ SV * const *sp = &sv; /* Used in tryAMAGICunDEREF macro. */
tryAMAGICunDEREF(to_cv);
sv = SvRV(sv);
else
gv = gv_fetchsv(sv, lref, SVt_PVCV);
*gvp = gv;
- if (!gv)
+ if (!gv) {
+ *st = NULL;
return Nullcv;
+ }
*st = GvESTASH(gv);
fix_gv:
if (lref && !GvCVu(gv)) {
if (!sv)
return 0;
if (SvPOK(sv)) {
- const register XPV* tXpv;
- if ((tXpv = (XPV*)SvANY(sv)) &&
+ register const XPV* const tXpv = (XPV*)SvANY(sv);
+ if (tXpv &&
(tXpv->xpv_cur > 1 ||
(tXpv->xpv_cur && *sv->sv_u.svu_pv != '0')))
return 1;
}
/*
-=for apidoc sv_iv
-
-A private implementation of the C<SvIVx> macro for compilers which can't
-cope with complex macro expressions. Always use the macro instead.
-
-=cut
-*/
+=for apidoc sv_pvn_force
-IV
-Perl_sv_iv(pTHX_ register SV *sv)
-{
- if (SvIOK(sv)) {
- if (SvIsUV(sv))
- return (IV)SvUVX(sv);
- return SvIVX(sv);
- }
- return sv_2iv(sv);
-}
+Get a sensible string out of the SV somehow.
+A private implementation of the C<SvPV_force> macro for compilers which
+can't cope with complex macro expressions. Always use the macro instead.
-/*
-=for apidoc sv_uv
+=for apidoc sv_pvn_force_flags
-A private implementation of the C<SvUVx> macro for compilers which can't
-cope with complex macro expressions. Always use the macro instead.
+Get a sensible string out of the SV somehow.
+If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<sv> if
+appropriate, else not. C<sv_pvn_force> and C<sv_pvn_force_nomg> are
+implemented in terms of this function.
+You normally want to use the various wrapper macros instead: see
+C<SvPV_force> and C<SvPV_force_nomg>
=cut
*/
-UV
-Perl_sv_uv(pTHX_ register SV *sv)
+char *
+Perl_sv_pvn_force_flags(pTHX_ SV *sv, STRLEN *lp, I32 flags)
{
- if (SvIOK(sv)) {
- if (SvIsUV(sv))
- return SvUVX(sv);
- return (UV)SvIVX(sv);
- }
- return sv_2uv(sv);
-}
-
-/*
-=for apidoc sv_nv
-
-A private implementation of the C<SvNVx> macro for compilers which can't
-cope with complex macro expressions. Always use the macro instead.
-=cut
-*/
-
-NV
-Perl_sv_nv(pTHX_ register SV *sv)
-{
- if (SvNOK(sv))
- return SvNVX(sv);
- return sv_2nv(sv);
-}
-
-/* sv_pv() is now a macro using SvPV_nolen();
- * this function provided for binary compatibility only
- */
-
-char *
-Perl_sv_pv(pTHX_ SV *sv)
-{
- if (SvPOK(sv))
- return SvPVX(sv);
-
- return sv_2pv(sv, 0);
-}
-
-/*
-=for apidoc sv_pv
-
-Use the C<SvPV_nolen> macro instead
-
-=for apidoc sv_pvn
-
-A private implementation of the C<SvPV> macro for compilers which can't
-cope with complex macro expressions. Always use the macro instead.
-
-=cut
-*/
-
-char *
-Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp)
-{
- if (SvPOK(sv)) {
- *lp = SvCUR(sv);
- return SvPVX(sv);
- }
- return sv_2pv(sv, lp);
-}
-
-
-char *
-Perl_sv_pvn_nomg(pTHX_ register SV *sv, STRLEN *lp)
-{
- if (SvPOK(sv)) {
- *lp = SvCUR(sv);
- return SvPVX(sv);
- }
- return sv_2pv_flags(sv, lp, 0);
-}
-
-/* sv_pvn_force() is now a macro using Perl_sv_pvn_force_flags();
- * this function provided for binary compatibility only
- */
-
-char *
-Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
-{
- return sv_pvn_force_flags(sv, lp, SV_GMAGIC);
-}
-
-/*
-=for apidoc sv_pvn_force
-
-Get a sensible string out of the SV somehow.
-A private implementation of the C<SvPV_force> macro for compilers which
-can't cope with complex macro expressions. Always use the macro instead.
-
-=for apidoc sv_pvn_force_flags
-
-Get a sensible string out of the SV somehow.
-If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<sv> if
-appropriate, else not. C<sv_pvn_force> and C<sv_pvn_force_nomg> are
-implemented in terms of this function.
-You normally want to use the various wrapper macros instead: see
-C<SvPV_force> and C<SvPV_force_nomg>
-
-=cut
-*/
-
-char *
-Perl_sv_pvn_force_flags(pTHX_ SV *sv, STRLEN *lp, I32 flags)
-{
-
- if (SvTHINKFIRST(sv) && !SvROK(sv))
- sv_force_normal_flags(sv, 0);
+ if (SvTHINKFIRST(sv) && !SvROK(sv))
+ sv_force_normal_flags(sv, 0);
if (SvPOK(sv)) {
if (lp)
STRLEN len;
if (SvREADONLY(sv) && !(flags & SV_MUTABLE_RETURN)) {
+ const char * const ref = sv_reftype(sv,0);
if (PL_op)
Perl_croak(aTHX_ "Can't coerce readonly %s to string in %s",
- sv_reftype(sv,0), OP_NAME(PL_op));
+ ref, OP_NAME(PL_op));
else
- Perl_croak(aTHX_ "Can't coerce readonly %s to string",
- sv_reftype(sv,0));
+ Perl_croak(aTHX_ "Can't coerce readonly %s to string", ref);
}
- if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) {
+ if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM)
Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
OP_NAME(PL_op));
- }
- else
- s = sv_2pv_flags(sv, &len, flags);
+ s = sv_2pv_flags(sv, &len, flags);
if (lp)
*lp = len;
sv_unref(sv);
SvUPGRADE(sv, SVt_PV); /* Never FALSE */
SvGROW(sv, len + 1);
- Move(s,SvPVX_const(sv),len,char);
+ Move(s,SvPVX(sv),len,char);
SvCUR_set(sv, len);
*SvEND(sv) = '\0';
}
return SvPVX_mutable(sv);
}
-/* sv_pvbyte () is now a macro using Perl_sv_2pv_flags();
- * this function provided for binary compatibility only
- */
-
-char *
-Perl_sv_pvbyte(pTHX_ SV *sv)
-{
- sv_utf8_downgrade(sv,0);
- return sv_pv(sv);
-}
-
-/*
-=for apidoc sv_pvbyte
-
-Use C<SvPVbyte_nolen> instead.
-
-=for apidoc sv_pvbyten
-
-A private implementation of the C<SvPVbyte> macro for compilers
-which can't cope with complex macro expressions. Always use the macro
-instead.
-
-=cut
-*/
-
-char *
-Perl_sv_pvbyten(pTHX_ SV *sv, STRLEN *lp)
-{
- sv_utf8_downgrade(sv,0);
- return sv_pvn(sv,lp);
-}
-
/*
=for apidoc sv_pvbyten_force
-A private implementation of the C<SvPVbytex_force> macro for compilers
-which can't cope with complex macro expressions. Always use the macro
-instead.
+The backend for the C<SvPVbytex_force> macro. Always use the macro instead.
=cut
*/
return SvPVX(sv);
}
-/* sv_pvutf8 () is now a macro using Perl_sv_2pv_flags();
- * this function provided for binary compatibility only
- */
-
-char *
-Perl_sv_pvutf8(pTHX_ SV *sv)
-{
- sv_utf8_upgrade(sv);
- return sv_pv(sv);
-}
-
-/*
-=for apidoc sv_pvutf8
-
-Use the C<SvPVutf8_nolen> macro instead
-
-=for apidoc sv_pvutf8n
-
-A private implementation of the C<SvPVutf8> macro for compilers
-which can't cope with complex macro expressions. Always use the macro
-instead.
-
-=cut
-*/
-
-char *
-Perl_sv_pvutf8n(pTHX_ SV *sv, STRLEN *lp)
-{
- sv_utf8_upgrade(sv);
- return sv_pvn(sv,lp);
-}
-
/*
=for apidoc sv_pvutf8n_force
-A private implementation of the C<SvPVutf8_force> macro for compilers
-which can't cope with complex macro expressions. Always use the macro
-instead.
+The backend for the C<SvPVutf8x_force> macro. Always use the macro instead.
=cut
*/
/* The fact that I don't need to downcast to char * everywhere, only in ?:
inside return suggests a const propagation bug in g++. */
if (ob && SvOBJECT(sv)) {
- char *name = HvNAME_get(SvSTASH(sv));
+ char * const name = HvNAME_get(SvSTASH(sv));
return name ? name : (char *) "__ANON__";
}
else {
{
if (!sv)
return 0;
- if (SvGMAGICAL(sv))
- mg_get(sv);
+ SvGETMAGIC(sv);
if (!SvROK(sv))
return 0;
sv = (SV*)SvRV(sv);
const char *hvname;
if (!sv)
return 0;
- if (SvGMAGICAL(sv))
- mg_get(sv);
+ SvGETMAGIC(sv);
if (!SvROK(sv))
return 0;
sv = (SV*)SvRV(sv);
SvROK_on(rv);
if (classname) {
- HV* stash = gv_stashpv(classname, TRUE);
+ HV* const stash = gv_stashpv(classname, TRUE);
(void)sv_bless(rv, stash);
}
return sv;
*/
SV*
-Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, char *pv, STRLEN n)
+Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, const char *pv, STRLEN n)
{
sv_setpvn(newSVrv(rv,classname), pv, n);
return rv;
if (GvGP(sv))
gp_free((GV*)sv);
if (GvSTASH(sv)) {
- SvREFCNT_dec(GvSTASH(sv));
- GvSTASH(sv) = Nullhv;
+ sv_del_backref((SV*)GvSTASH(sv), sv);
+ GvSTASH(sv) = NULL;
}
sv_unmagic(sv, PERL_MAGIC_glob);
Safefree(GvNAME(sv));
*/
void
-Perl_sv_unref_flags(pTHX_ SV *sv, U32 flags)
+Perl_sv_unref_flags(pTHX_ SV *ref, U32 flags)
{
- SV* rv = SvRV(sv);
+ SV* const target = SvRV(ref);
- if (SvWEAKREF(sv)) {
- sv_del_backref(sv);
- SvWEAKREF_off(sv);
- SvRV_set(sv, NULL);
+ if (SvWEAKREF(ref)) {
+ sv_del_backref(target, ref);
+ SvWEAKREF_off(ref);
+ SvRV_set(ref, NULL);
return;
}
- SvRV_set(sv, NULL);
- SvROK_off(sv);
- /* You can't have a || SvREADONLY(rv) here, as $a = $$a, where $a was
+ SvRV_set(ref, NULL);
+ SvROK_off(ref);
+ /* You can't have a || SvREADONLY(target) here, as $a = $$a, where $a was
assigned to as BEGIN {$a = \"Foo"} will fail. */
- if (SvREFCNT(rv) != 1 || (flags & SV_IMMEDIATE_UNREF))
- SvREFCNT_dec(rv);
+ if (SvREFCNT(target) != 1 || (flags & SV_IMMEDIATE_UNREF))
+ SvREFCNT_dec(target);
else /* XXX Hack, but hard to make $a=$a->[1] work otherwise */
- sv_2mortal(rv); /* Schedule for freeing later */
-}
-
-/*
-=for apidoc sv_unref
-
-Unsets the RV status of the SV, and decrements the reference count of
-whatever was being referenced by the RV. This can almost be thought of
-as a reversal of C<newSVrv>. This is C<sv_unref_flags> with the C<flag>
-being zero. See C<SvROK_off>.
-
-=cut
-*/
-
-void
-Perl_sv_unref(pTHX_ SV *sv)
-{
- sv_unref_flags(sv, 0);
-}
-
-/*
-=for apidoc sv_taint
-
-Taint an SV. Use C<SvTAINTED_on> instead.
-=cut
-*/
-
-void
-Perl_sv_taint(pTHX_ SV *sv)
-{
- sv_magic((sv), Nullsv, PERL_MAGIC_taint, Nullch, 0);
+ sv_2mortal(target); /* Schedule for freeing later */
}
/*
Perl_sv_untaint(pTHX_ SV *sv)
{
if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
- MAGIC *mg = mg_find(sv, PERL_MAGIC_taint);
+ MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint);
if (mg)
mg->mg_len &= ~1;
}
Perl_sv_tainted(pTHX_ SV *sv)
{
if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
- MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint);
- if (mg && ((mg->mg_len & 1) || ((mg->mg_len & 2) && mg->mg_obj == sv)))
+ const MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint);
+ if (mg && (mg->mg_len & 1) )
return TRUE;
}
return FALSE;
{
char buf[TYPE_CHARS(UV)];
char *ebuf;
- char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
+ char * const ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
sv_setpvn(sv, ptr, ebuf - ptr);
}
void
Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv)
{
- char buf[TYPE_CHARS(UV)];
- char *ebuf;
- char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
-
- sv_setpvn(sv, ptr, ebuf - ptr);
+ sv_setpviv(sv, iv);
SvSETMAGIC(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;
}
=cut
*/
+
+#define VECTORIZE_ARGS vecsv = va_arg(*args, SV*);\
+ vecstr = (U8*)SvPV_const(vecsv,veclen);\
+ vec_utf8 = DO_UTF8(vecsv);
+
/* XXX maybe_tainted is never assigned to, so the doc above is lying. */
void
/* large enough for "%#.#f" --chip */
/* what about long double NVs? --jhi */
+ PERL_UNUSED_ARG(maybe_tainted);
+
/* no matter what, this is a string now */
(void)SvPV_force(sv, origlen);
- /* special-case "", "%s", and "%-p" (SVf) */
+ /* special-case "", "%s", and "%-p" (SVf - see below) */
if (patlen == 0)
return;
if (patlen == 2 && pat[0] == '%' && pat[1] == 's') {
- if (args) {
- const char *s = va_arg(*args, char*);
- sv_catpv(sv, s ? s : nullstr);
- }
- else if (svix < svmax) {
- sv_catsv(sv, *svargs);
- if (DO_UTF8(*svargs))
- SvUTF8_on(sv);
- }
- return;
+ if (args) {
+ const char * const s = va_arg(*args, char*);
+ sv_catpv(sv, s ? s : nullstr);
+ }
+ else if (svix < svmax) {
+ sv_catsv(sv, *svargs);
+ }
+ return;
}
- if (patlen == 3 && pat[0] == '%' &&
- pat[1] == '-' && pat[2] == 'p') {
- if (args) {
- argsv = va_arg(*args, SV*);
- sv_catsv(sv, argsv);
- if (DO_UTF8(argsv))
- SvUTF8_on(sv);
- return;
- }
+ if (args && patlen == 3 && pat[0] == '%' &&
+ pat[1] == '-' && pat[2] == 'p') {
+ argsv = va_arg(*args, SV*);
+ sv_catsv(sv, argsv);
+ return;
}
#ifndef USE_LONG_DOUBLE
/* special-case "%.<number>[gf]" */
- if ( patlen <= 5 && pat[0] == '%' && pat[1] == '.'
+ if ( !args && patlen <= 5 && pat[0] == '%' && pat[1] == '.'
&& (pat[patlen-1] == 'g' || pat[patlen-1] == 'f') ) {
unsigned digits = 0;
const char *pp;
if (pp - pat == (int)patlen - 1) {
NV nv;
- if (args)
- nv = (NV)va_arg(*args, double);
- else if (svix < svmax)
+ if (svix < svmax)
nv = SvNV(*svargs);
else
return;
STRLEN have;
STRLEN need;
STRLEN gap;
- const char *dotstr = ".";
+ const char *dotstr = ".";
STRLEN dotstrlen = 1;
I32 efix = 0; /* explicit format parameter index */
I32 ewix = 0; /* explicit width index */
\d+|\*(\d+\$)? width using optional (optionally specified) arg
\.(\d*|\*(\d+\$)?) precision using optional (optionally specified) arg
[hlqLV] size
- [%bcdefginopsux_DFOUX] format (mandatory)
+ [%bcdefginopsuxDFOUX] format (mandatory)
*/
+
+ if (args) {
+/*
+ As of perl5.9.3, printf format checking is on by default.
+ Internally, perl uses %p formats to provide an escape to
+ some extended formatting. This block deals with those
+ extensions: if it does not match, (char*)q is reset and
+ the normal format processing code is used.
+
+ Currently defined extensions are:
+ %p include pointer address (standard)
+ %-p (SVf) include an SV (previously %_)
+ %-<num>p include an SV with precision <num>
+ %1p (VDf) include a v-string (as %vd)
+ %<num>p reserved for future extensions
+
+ Robin Barker 2005-07-14
+*/
+ char* r = q;
+ bool sv = FALSE;
+ STRLEN n = 0;
+ if (*q == '-')
+ sv = *q++;
+ EXPECT_NUMBER(q, n);
+ if (*q++ == 'p') {
+ if (sv) { /* SVf */
+ if (n) {
+ precis = n;
+ has_precis = TRUE;
+ }
+ argsv = va_arg(*args, SV*);
+ eptr = SvPVx_const(argsv, elen);
+ if (DO_UTF8(argsv))
+ is_utf8 = TRUE;
+ goto string;
+ }
+#if vdNUMBER
+ else if (n == vdNUMBER) { /* VDf */
+ vectorize = TRUE;
+ VECTORIZE_ARGS
+ goto format_vd;
+ }
+#endif
+ else if (n) {
+ if (ckWARN_d(WARN_INTERNAL))
+ Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
+ "internal %%<num>p might conflict with future printf extensions");
+ }
+ }
+ q = r;
+ }
+
if (EXPECT_NUMBER(q, width)) {
if (*q == '$') {
++q;
}
if (!asterisk)
+ {
if( *q == '0' )
fill = *q++;
EXPECT_NUMBER(q, width);
+ }
if (vectorize) {
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) {
- vecsv = va_arg(*args, SV*);
- vecstr = (U8*)SvPV_const(vecsv,veclen);
- vec_utf8 = DO_UTF8(vecsv);
+ 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 = strlen(eptr);
- 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;
/* INTEGERS */
case 'p':
- if (left && args) { /* SVf */
- left = FALSE;
- if (width) {
- precis = width;
- has_precis = TRUE;
- width = 0;
- }
- if (vectorize)
- goto unknown;
- argsv = va_arg(*args, SV*);
- eptr = SvPVx_const(argsv, elen);
- if (DO_UTF8(argsv))
- is_utf8 = TRUE;
- goto string;
- }
if (alt || vectorize)
goto unknown;
uv = PTR2UV(args ? va_arg(*args, void*) : argsv);
/* FALL THROUGH */
case 'd':
case 'i':
+#if vdNUMBER
+ format_vd:
+#endif
if (vectorize) {
STRLEN ulen;
if (!veclen)
*--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
if (PL_efloatsize < need) {
Safefree(PL_efloatbuf);
PL_efloatsize = need + 20; /* more fudge */
- New(906, PL_efloatbuf, PL_efloatsize, char);
+ Newx(PL_efloatbuf, PL_efloatsize, char);
PL_efloatbuf[0] = '\0';
}
aka precis is 0 */
if ( c == 'g' && precis) {
Gconvert((NV)nv, (int)precis, 0, PL_efloatbuf);
- if (*PL_efloatbuf) /* May return an empty string for digits==0 */
+ /* May return an empty string for digits==0 */
+ if (*PL_efloatbuf) {
+ elen = strlen(PL_efloatbuf);
goto float_converted;
+ }
} else if ( c == 'f' && !precis) {
if ((eptr = F0convert(nv, ebuf + sizeof ebuf, &elen)))
break;
* where printf() taints but print($float) doesn't.
* --jhi */
#if defined(HAS_LONG_DOUBLE)
- if (intsize == 'q')
- (void)sprintf(PL_efloatbuf, ptr, nv);
- else
- (void)sprintf(PL_efloatbuf, ptr, (double)nv);
+ elen = ((intsize == 'q')
+ ? my_sprintf(PL_efloatbuf, ptr, nv)
+ : my_sprintf(PL_efloatbuf, ptr, (double)nv));
#else
- (void)sprintf(PL_efloatbuf, ptr, nv);
+ elen = my_sprintf(PL_efloatbuf, ptr, nv);
#endif
}
float_converted:
eptr = PL_efloatbuf;
- elen = strlen(PL_efloatbuf);
break;
/* 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 */
default:
unknown:
- if (!args && ckWARN(WARN_PRINTF) &&
- (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
- SV *msg = sv_newmortal();
+ if (!args
+ && (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)
+ && ckWARN(WARN_PRINTF))
+ {
+ SV * const msg = sv_newmortal();
Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %sprintf: ",
(PL_op->op_type == OP_PRTF) ? "" : "s");
if (c) {
/* 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) {
sv_utf8_upgrade(sv);
}
else {
- SV *nsv = sv_2mortal(newSVpvn(eptr, elen));
+ SV * const nsv = sv_2mortal(newSVpvn(eptr, elen));
sv_utf8_upgrade(nsv);
eptr = SvPVX_const(nsv);
elen = SvCUR(nsv);
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') {
+ int i;
for (i = 0; i < (int)esignlen; i++)
*p++ = esignbuf[i];
}
p += gap;
}
if (esignlen && fill != '0') {
+ int i;
for (i = 0; i < (int)esignlen; i++)
*p++ = esignbuf[i];
}
if (zeros) {
+ int i;
for (i = zeros; i; i--)
*p++ = '0';
}
regcomp.c. AMS 20010712 */
REGEXP *
-Perl_re_dup(pTHX_ REGEXP *r, CLONE_PARAMS *param)
+Perl_re_dup(pTHX_ const REGEXP *r, CLONE_PARAMS *param)
{
dVAR;
REGEXP *ret;
len = r->offsets[0];
npar = r->nparens+1;
- Newc(0, ret, sizeof(regexp) + (len+1)*sizeof(regnode), char, regexp);
+ Newxc(ret, sizeof(regexp) + (len+1)*sizeof(regnode), char, regexp);
Copy(r->program, ret->program, len+1, regnode);
- New(0, ret->startp, npar, I32);
+ Newx(ret->startp, npar, I32);
Copy(r->startp, ret->startp, npar, I32);
- New(0, ret->endp, npar, I32);
+ Newx(ret->endp, npar, I32);
Copy(r->startp, ret->startp, npar, I32);
- New(0, ret->substrs, 1, struct reg_substr_data);
+ Newx(ret->substrs, 1, struct reg_substr_data);
for (s = ret->substrs->data, i = 0; i < 3; i++, s++) {
s->min_offset = r->substrs->data[i].min_offset;
s->max_offset = r->substrs->data[i].max_offset;
if (r->data) {
struct reg_data *d;
const int count = r->data->count;
+ int i;
- Newc(0, d, sizeof(struct reg_data) + count*sizeof(void *),
+ Newxc(d, sizeof(struct reg_data) + count*sizeof(void *),
char, struct reg_data);
- New(0, d->what, count, U8);
+ Newx(d->what, count, U8);
d->count = count;
for (i = 0; i < count; i++) {
break;
case 'f':
/* This is cheating. */
- New(0, d->data[i], 1, struct regnode_charclass_class);
+ Newx(d->data[i], 1, struct regnode_charclass_class);
StructCopy(r->data->data[i], d->data[i],
struct regnode_charclass_class);
ret->regstclass = (regnode*)d->data[i];
else
ret->data = NULL;
- New(0, ret->offsets, 2*len+1, U32);
+ Newx(ret->offsets, 2*len+1, U32);
Copy(r->offsets, ret->offsets, 2*len+1, U32);
ret->precomp = SAVEPVN(r->precomp, r->prelen);
Perl_fp_dup(pTHX_ PerlIO *fp, char type, CLONE_PARAMS *param)
{
PerlIO *ret;
- (void)type;
+
+ PERL_UNUSED_ARG(type);
if (!fp)
return (PerlIO*)NULL;
return ret;
/* create anew and remember what it is */
- Newz(0, ret, 1, GP);
+ Newxz(ret, 1, GP);
ptr_table_store(PL_ptr_table, gp, ret);
/* clone */
ret->gp_egv = gv_dup(gp->gp_egv, param);/* GvEGV is not refcounted */
ret->gp_cv = cv_dup_inc(gp->gp_cv, param);
ret->gp_cvgen = gp->gp_cvgen;
- ret->gp_flags = gp->gp_flags;
ret->gp_line = gp->gp_line;
ret->gp_file = gp->gp_file; /* points to COP.cop_file */
return ret;
for (; mg; mg = mg->mg_moremagic) {
MAGIC *nmg;
- Newz(0, nmg, 1, MAGIC);
+ Newxz(nmg, 1, MAGIC);
if (mgprev)
mgprev->mg_moremagic = nmg;
else
if (mg->mg_type == PERL_MAGIC_overload_table &&
AMT_AMAGIC((AMT*)mg->mg_ptr))
{
- AMT *amtp = (AMT*)mg->mg_ptr;
- AMT *namtp = (AMT*)nmg->mg_ptr;
+ AMT * const amtp = (AMT*)mg->mg_ptr;
+ AMT * const namtp = (AMT*)nmg->mg_ptr;
I32 i;
for (i = 1; i < NofAMmeth; i++) {
namtp->table[i] = cv_dup_inc(amtp->table[i], param);
Perl_ptr_table_new(pTHX)
{
PTR_TBL_t *tbl;
- Newz(0, tbl, 1, PTR_TBL_t);
+ Newxz(tbl, 1, PTR_TBL_t);
tbl->tbl_max = 511;
tbl->tbl_items = 0;
- Newz(0, tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
+ Newxz(tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
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
+ following define) and at call to new_body_inline made below in
+ Perl_ptr_table_store()
+ */
-STATIC void
-S_more_pte(pTHX)
-{
- struct ptr_tbl_ent* pte;
- struct ptr_tbl_ent* pteend;
- New(0, pte, PERL_ARENA_SIZE/sizeof(struct ptr_tbl_ent), struct ptr_tbl_ent);
- pte->next = PL_pte_arenaroot;
- PL_pte_arenaroot = pte;
-
- pteend = &pte[PERL_ARENA_SIZE / sizeof(struct ptr_tbl_ent) - 1];
- PL_pte_root = ++pte;
- while (pte < pteend) {
- pte->next = pte + 1;
- pte++;
- }
- pte->next = 0;
-}
-
-STATIC struct ptr_tbl_ent*
-S_new_pte(pTHX)
-{
- struct ptr_tbl_ent* pte;
- if (!PL_pte_root)
- S_more_pte(aTHX);
- pte = PL_pte_root;
- PL_pte_root = pte->next;
- return pte;
-}
-
-STATIC void
-S_del_pte(pTHX_ struct ptr_tbl_ent*p)
-{
- p->next = PL_pte_root;
- PL_pte_root = p;
-}
+#define del_pte(p) del_body_type(p, PTE_SVSLOT)
/* map an existing pointer using a table */
-void *
-Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, 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, void *oldv, void *newv)
+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(oldv);
- 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 == oldv) {
- tblent->newval = newv;
- 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);
}
- tblent = S_new_pte(aTHX);
- tblent->oldval = oldv;
- tblent->newval = newv;
- 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;
- S_del_pte(aTHX_ oentry);
- }
- if (!entry) {
- if (++riter > max) {
- break;
- }
- entry = array[riter];
- }
+ tbl->tbl_items = 0;
}
-
- tbl->tbl_items = 0;
}
/* clear and free a ptr table */
Safefree(tbl);
}
-/* attempt to make everything in the typeglob readonly */
-STATIC SV *
-S_gv_share(pTHX_ SV *sstr, CLONE_PARAMS *param)
+void
+Perl_rvpv_dup(pTHX_ SV *dstr, SV *sstr, CLONE_PARAMS* param)
{
- GV *gv = (GV*)sstr;
- SV *sv = ¶m->proto_perl->Isv_no; /* just need SvREADONLY-ness */
-
- if (GvIO(gv) || GvFORM(gv)) {
- GvUNIQUE_off(gv); /* GvIOs cannot be shared. nor can GvFORMs */
- }
- else if (!GvCV(gv)) {
- GvCV(gv) = (CV*)sv;
- }
- else {
- /* CvPADLISTs cannot be shared */
- if (!SvREADONLY(GvCV(gv)) && !CvXSUB(GvCV(gv))) {
- GvUNIQUE_off(gv);
- }
- }
-
- if (!GvUNIQUE(gv)) {
-#if 0
- PerlIO_printf(Perl_debug_log, "gv_share: unable to share %s::%s\n",
- HvNAME_get(GvSTASH(gv)), GvNAME(gv));
-#endif
- return Nullsv;
- }
-
- /*
- * write attempts will die with
- * "Modification of a read-only value attempted"
- */
- if (!GvSV(gv)) {
- GvSV(gv) = sv;
- }
- else {
- SvREADONLY_on(GvSV(gv));
- }
-
- if (!GvAV(gv)) {
- GvAV(gv) = (AV*)sv;
- }
- else {
- SvREADONLY_on(GvAV(gv));
- }
-
- if (!GvHV(gv)) {
- GvHV(gv) = (HV*)sv;
- }
- else {
- SvREADONLY_on(GvHV(gv));
- }
-
- return sstr; /* he_dup() will SvREFCNT_inc() */
-}
-
-/* duplicate an SV of any type (including AV, HV etc) */
-
-void
-Perl_rvpv_dup(pTHX_ SV *dstr, SV *sstr, CLONE_PARAMS* param)
-{
- if (SvROK(sstr)) {
- SvRV_set(dstr, SvWEAKREF(sstr)
- ? sv_dup(SvRV(sstr), param)
- : sv_dup_inc(SvRV(sstr), param));
+ if (SvROK(sstr)) {
+ SvRV_set(dstr, SvWEAKREF(sstr)
+ ? sv_dup(SvRV(sstr), param)
+ : sv_dup_inc(SvRV(sstr), param));
}
else if (SvPVX_const(sstr)) {
}
else {
/* Special case - not normally malloced for some reason */
- if (SvREADONLY(sstr) && SvFAKE(sstr)) {
- /* A "shared" PV - clone it as unshared string */
- if(SvPADTMP(sstr)) {
- /* However, some of them live in the pad
- and they should not have these flags
- turned off */
-
- /* FIXME - would benefit from share_hek_hek */
- SvPV_set(dstr, sharepvn(SvPVX_const(sstr), SvCUR(sstr),
- SvUVX(sstr)));
- } else {
-
- SvPV_set(dstr, SAVEPVN(SvPVX_const(sstr), SvCUR(sstr)));
- SvFAKE_off(dstr);
- SvREADONLY_off(dstr);
- }
+ if ((SvREADONLY(sstr) && SvFAKE(sstr))) {
+ /* A "shared" PV - clone it as "shared" PV */
+ SvPV_set(dstr,
+ HEK_KEY(hek_dup(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)),
+ param)));
}
else {
/* Some other special case - random pointer */
}
}
+/* duplicate an SV of any type (including AV, HV etc) */
+
SV *
Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param)
{
if(SvTYPE(sstr) == SVt_PVHV &&
(hvname = HvNAME_get(sstr))) {
/** don't clone stashes if they already exist **/
- HV* old_stash = gv_stashpv(hvname,0);
- return (SV*) old_stash;
+ return (SV*)gv_stashpv(hvname,0);
}
}
SvANY(dstr) = &(dstr->sv_u.svu_rv);
Perl_rvpv_dup(aTHX_ dstr, sstr, param);
break;
- case SVt_PV:
- SvANY(dstr) = new_XPV();
- SvCUR_set(dstr, SvCUR(sstr));
- SvLEN_set(dstr, SvLEN(sstr));
- Perl_rvpv_dup(aTHX_ dstr, sstr, param);
- break;
- case SVt_PVIV:
- SvANY(dstr) = new_XPVIV();
- SvCUR_set(dstr, SvCUR(sstr));
- SvLEN_set(dstr, SvLEN(sstr));
- SvIV_set(dstr, SvIVX(sstr));
- Perl_rvpv_dup(aTHX_ dstr, sstr, param);
- break;
- case SVt_PVNV:
- SvANY(dstr) = new_XPVNV();
- SvCUR_set(dstr, SvCUR(sstr));
- SvLEN_set(dstr, SvLEN(sstr));
- SvIV_set(dstr, SvIVX(sstr));
- SvNV_set(dstr, SvNVX(sstr));
- Perl_rvpv_dup(aTHX_ dstr, sstr, param);
- break;
- case SVt_PVMG:
- SvANY(dstr) = new_XPVMG();
- SvCUR_set(dstr, SvCUR(sstr));
- SvLEN_set(dstr, SvLEN(sstr));
- SvIV_set(dstr, SvIVX(sstr));
- SvNV_set(dstr, SvNVX(sstr));
- SvMAGIC_set(dstr, mg_dup(SvMAGIC(sstr), param));
- SvSTASH_set(dstr, hv_dup_inc(SvSTASH(sstr), param));
- Perl_rvpv_dup(aTHX_ dstr, sstr, param);
- break;
- case SVt_PVBM:
- SvANY(dstr) = new_XPVBM();
- SvCUR_set(dstr, SvCUR(sstr));
- SvLEN_set(dstr, SvLEN(sstr));
- SvIV_set(dstr, SvIVX(sstr));
- SvNV_set(dstr, SvNVX(sstr));
- SvMAGIC_set(dstr, mg_dup(SvMAGIC(sstr), param));
- SvSTASH_set(dstr, hv_dup_inc(SvSTASH(sstr), param));
- Perl_rvpv_dup(aTHX_ dstr, sstr, param);
- BmRARE(dstr) = BmRARE(sstr);
- BmUSEFUL(dstr) = BmUSEFUL(sstr);
- BmPREVIOUS(dstr)= BmPREVIOUS(sstr);
- break;
- case SVt_PVLV:
- SvANY(dstr) = new_XPVLV();
- SvCUR_set(dstr, SvCUR(sstr));
- SvLEN_set(dstr, SvLEN(sstr));
- SvIV_set(dstr, SvIVX(sstr));
- SvNV_set(dstr, SvNVX(sstr));
- SvMAGIC_set(dstr, mg_dup(SvMAGIC(sstr), param));
- SvSTASH_set(dstr, hv_dup_inc(SvSTASH(sstr), param));
- Perl_rvpv_dup(aTHX_ dstr, sstr, param);
- LvTARGOFF(dstr) = LvTARGOFF(sstr); /* XXX sometimes holds PMOP* when DEBUGGING */
- LvTARGLEN(dstr) = LvTARGLEN(sstr);
- if (LvTYPE(sstr) == 't') /* for tie: unrefcnted fake (SV**) */
- LvTARG(dstr) = dstr;
- else if (LvTYPE(sstr) == 'T') /* for tie: fake HE */
- LvTARG(dstr) = (SV*)he_dup((HE*)LvTARG(sstr), 0, param);
- else
- LvTARG(dstr) = sv_dup_inc(LvTARG(sstr), param);
- LvTYPE(dstr) = LvTYPE(sstr);
- break;
- case SVt_PVGV:
- if (GvUNIQUE((GV*)sstr)) {
- SV *share;
- if ((share = gv_share(sstr, param))) {
- del_SV(dstr);
- dstr = share;
- ptr_table_store(PL_ptr_table, sstr, dstr);
-#if 0
- PerlIO_printf(Perl_debug_log, "sv_dup: sharing %s::%s\n",
- HvNAME_get(GvSTASH(share)), GvNAME(share));
-#endif
- break;
- }
- }
- SvANY(dstr) = new_XPVGV();
- SvCUR_set(dstr, SvCUR(sstr));
- SvLEN_set(dstr, SvLEN(sstr));
- SvIV_set(dstr, SvIVX(sstr));
- SvNV_set(dstr, SvNVX(sstr));
- SvMAGIC_set(dstr, mg_dup(SvMAGIC(sstr), param));
- SvSTASH_set(dstr, hv_dup_inc(SvSTASH(sstr), param));
- Perl_rvpv_dup(aTHX_ dstr, sstr, param);
- GvNAMELEN(dstr) = GvNAMELEN(sstr);
- GvNAME(dstr) = SAVEPVN(GvNAME(sstr), GvNAMELEN(sstr));
- GvSTASH(dstr) = hv_dup_inc(GvSTASH(sstr), param);
- GvFLAGS(dstr) = GvFLAGS(sstr);
- GvGP(dstr) = gp_dup(GvGP(sstr), param);
- (void)GpREFCNT_inc(GvGP(dstr));
- break;
- case SVt_PVIO:
- SvANY(dstr) = new_XPVIO();
- SvCUR_set(dstr, SvCUR(sstr));
- SvLEN_set(dstr, SvLEN(sstr));
- SvIV_set(dstr, SvIVX(sstr));
- SvNV_set(dstr, SvNVX(sstr));
- SvMAGIC_set(dstr, mg_dup(SvMAGIC(sstr), param));
- SvSTASH_set(dstr, hv_dup_inc(SvSTASH(sstr), param));
- Perl_rvpv_dup(aTHX_ dstr, sstr, param);
- IoIFP(dstr) = fp_dup(IoIFP(sstr), IoTYPE(sstr), param);
- if (IoOFP(sstr) == IoIFP(sstr))
- IoOFP(dstr) = IoIFP(dstr);
- else
- IoOFP(dstr) = fp_dup(IoOFP(sstr), IoTYPE(sstr), param);
- /* PL_rsfp_filters entries have fake IoDIRP() */
- if (IoDIRP(sstr) && !(IoFLAGS(sstr) & IOf_FAKE_DIRP))
- IoDIRP(dstr) = dirp_dup(IoDIRP(sstr));
- else
- IoDIRP(dstr) = IoDIRP(sstr);
- IoLINES(dstr) = IoLINES(sstr);
- IoPAGE(dstr) = IoPAGE(sstr);
- IoPAGE_LEN(dstr) = IoPAGE_LEN(sstr);
- IoLINES_LEFT(dstr) = IoLINES_LEFT(sstr);
- if(IoFLAGS(sstr) & IOf_FAKE_DIRP) {
- /* I have no idea why fake dirp (rsfps)
- should be treaded differently but otherwise
- we end up with leaks -- sky*/
- IoTOP_GV(dstr) = gv_dup_inc(IoTOP_GV(sstr), param);
- IoFMT_GV(dstr) = gv_dup_inc(IoFMT_GV(sstr), param);
- IoBOTTOM_GV(dstr) = gv_dup_inc(IoBOTTOM_GV(sstr), param);
- } else {
- IoTOP_GV(dstr) = gv_dup(IoTOP_GV(sstr), param);
- IoFMT_GV(dstr) = gv_dup(IoFMT_GV(sstr), param);
- IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(sstr), param);
- }
- IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(sstr));
- IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(sstr));
- IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(sstr));
- IoSUBPROCESS(dstr) = IoSUBPROCESS(sstr);
- IoTYPE(dstr) = IoTYPE(sstr);
- IoFLAGS(dstr) = IoFLAGS(sstr);
- break;
- case SVt_PVAV:
- SvANY(dstr) = new_XPVAV();
- SvCUR_set(dstr, SvCUR(sstr));
- SvLEN_set(dstr, SvLEN(sstr));
- SvMAGIC_set(dstr, mg_dup(SvMAGIC(sstr), param));
- SvSTASH_set(dstr, hv_dup_inc(SvSTASH(sstr), param));
- if (AvARRAY((AV*)sstr)) {
- SV **dst_ary, **src_ary;
- SSize_t items = AvFILLp((AV*)sstr) + 1;
-
- src_ary = AvARRAY((AV*)sstr);
- Newz(0, dst_ary, AvMAX((AV*)sstr)+1, SV*);
- ptr_table_store(PL_ptr_table, src_ary, dst_ary);
- SvPV_set(dstr, (char*)dst_ary);
- AvALLOC((AV*)dstr) = dst_ary;
- if (AvREAL((AV*)sstr)) {
- while (items-- > 0)
- *dst_ary++ = sv_dup_inc(*src_ary++, param);
- }
- else {
- while (items-- > 0)
- *dst_ary++ = sv_dup(*src_ary++, param);
- }
- items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr);
- while (items-- > 0) {
- *dst_ary++ = &PL_sv_undef;
- }
- }
- else {
- SvPV_set(dstr, Nullch);
- AvALLOC((AV*)dstr) = (SV**)NULL;
- }
- break;
- case SVt_PVHV:
- SvANY(dstr) = new_XPVHV();
- SvCUR_set(dstr, SvCUR(sstr));
- SvLEN_set(dstr, SvLEN(sstr));
- HvTOTALKEYS(dstr) = HvTOTALKEYS(sstr);
- SvMAGIC_set(dstr, mg_dup(SvMAGIC(sstr), param));
- SvSTASH_set(dstr, hv_dup_inc(SvSTASH(sstr), param));
+ default:
{
- HEK *hvname = 0;
-
- if (HvARRAY((HV*)sstr)) {
- STRLEN i = 0;
- const bool sharekeys = !!HvSHAREKEYS(sstr);
- XPVHV * const dxhv = (XPVHV*)SvANY(dstr);
- XPVHV * const sxhv = (XPVHV*)SvANY(sstr);
- char *darray;
- New(0, darray,
- PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1)
- + (SvOOK(sstr) ? sizeof(struct xpvhv_aux) : 0), char);
- HvARRAY(dstr) = (HE**)darray;
- while (i <= sxhv->xhv_max) {
- HE *source = HvARRAY(sstr)[i];
- HvARRAY(dstr)[i]
- = source ? he_dup(source, sharekeys, param) : 0;
- ++i;
+ /* These are all the types that need complex bodies allocating. */
+ void *new_body;
+ const svtype sv_type = SvTYPE(sstr);
+ const struct body_details *const sv_type_details
+ = bodies_by_type + sv_type;
+
+ switch (sv_type) {
+ default:
+ Perl_croak(aTHX_ "Bizarre SvTYPE [%" IVdf "]",
+ (IV)SvTYPE(sstr));
+ break;
+
+ case SVt_PVGV:
+ if (GvUNIQUE((GV*)sstr)) {
+ /* Do sharing here, and fall through */
}
- if (SvOOK(sstr)) {
- struct xpvhv_aux *saux = HvAUX(sstr);
- struct xpvhv_aux *daux = HvAUX(dstr);
- /* This flag isn't copied. */
- /* SvOOK_on(hv) attacks the IV flags. */
- SvFLAGS(dstr) |= SVf_OOK;
-
- hvname = saux->xhv_name;
- daux->xhv_name = hvname ? hek_dup(hvname, param) : hvname;
-
- daux->xhv_riter = saux->xhv_riter;
- daux->xhv_eiter = saux->xhv_eiter
- ? he_dup(saux->xhv_eiter, (bool)!!HvSHAREKEYS(sstr),
- param) : 0;
+ case SVt_PVIO:
+ case SVt_PVFM:
+ case SVt_PVHV:
+ case SVt_PVAV:
+ case SVt_PVBM:
+ case SVt_PVCV:
+ case SVt_PVLV:
+ case SVt_PVMG:
+ case SVt_PVNV:
+ case SVt_PVIV:
+ case SVt_PV:
+ assert(sv_type_details->size);
+ if (sv_type_details->arena) {
+ new_body_inline(new_body, sv_type_details->size, sv_type);
+ new_body
+ = (void*)((char*)new_body - sv_type_details->offset);
+ } else {
+ new_body = new_NOARENA(sv_type_details);
}
}
- else {
- SvPV_set(dstr, Nullch);
+ assert(new_body);
+ SvANY(dstr) = new_body;
+
+#ifndef PURIFY
+ Copy(((char*)SvANY(sstr)) + sv_type_details->offset,
+ ((char*)SvANY(dstr)) + sv_type_details->offset,
+ sv_type_details->copy, char);
+#else
+ Copy(((char*)SvANY(sstr)),
+ ((char*)SvANY(dstr)),
+ sv_type_details->size + sv_type_details->offset, char);
+#endif
+
+ if (sv_type != SVt_PVAV && sv_type != SVt_PVHV)
+ Perl_rvpv_dup(aTHX_ dstr, sstr, param);
+
+ /* The Copy above means that all the source (unduplicated) pointers
+ are now in the destination. We can check the flags and the
+ pointers in either, but it's possible that there's less cache
+ missing by always going for the destination.
+ FIXME - instrument and check that assumption */
+ if (sv_type >= SVt_PVMG) {
+ if (SvMAGIC(dstr))
+ SvMAGIC_set(dstr, mg_dup(SvMAGIC(dstr), param));
+ if (SvSTASH(dstr))
+ SvSTASH_set(dstr, hv_dup_inc(SvSTASH(dstr), param));
+ }
+
+ /* The cast silences a GCC warning about unhandled types. */
+ switch ((int)sv_type) {
+ case SVt_PV:
+ break;
+ case SVt_PVIV:
+ break;
+ case SVt_PVNV:
+ break;
+ case SVt_PVMG:
+ break;
+ case SVt_PVBM:
+ break;
+ case SVt_PVLV:
+ /* XXX LvTARGOFF sometimes holds PMOP* when DEBUGGING */
+ if (LvTYPE(dstr) == 't') /* for tie: unrefcnted fake (SV**) */
+ LvTARG(dstr) = dstr;
+ else if (LvTYPE(dstr) == 'T') /* for tie: fake HE */
+ LvTARG(dstr) = (SV*)he_dup((HE*)LvTARG(dstr), 0, param);
+ else
+ LvTARG(dstr) = sv_dup_inc(LvTARG(dstr), param);
+ break;
+ case SVt_PVGV:
+ GvNAME(dstr) = SAVEPVN(GvNAME(dstr), GvNAMELEN(dstr));
+ GvSTASH(dstr) = hv_dup(GvSTASH(dstr), param);
+ /* Don't call sv_add_backref here as it's going to be created
+ as part of the magic cloning of the symbol table. */
+ GvGP(dstr) = gp_dup(GvGP(dstr), param);
+ (void)GpREFCNT_inc(GvGP(dstr));
+ break;
+ case SVt_PVIO:
+ IoIFP(dstr) = fp_dup(IoIFP(dstr), IoTYPE(dstr), param);
+ if (IoOFP(dstr) == IoIFP(sstr))
+ IoOFP(dstr) = IoIFP(dstr);
+ else
+ IoOFP(dstr) = fp_dup(IoOFP(dstr), IoTYPE(dstr), param);
+ /* PL_rsfp_filters entries have fake IoDIRP() */
+ if (IoDIRP(dstr) && !(IoFLAGS(dstr) & IOf_FAKE_DIRP))
+ IoDIRP(dstr) = dirp_dup(IoDIRP(dstr));
+ if(IoFLAGS(dstr) & IOf_FAKE_DIRP) {
+ /* I have no idea why fake dirp (rsfps)
+ should be treated differently but otherwise
+ we end up with leaks -- sky*/
+ IoTOP_GV(dstr) = gv_dup_inc(IoTOP_GV(dstr), param);
+ IoFMT_GV(dstr) = gv_dup_inc(IoFMT_GV(dstr), param);
+ IoBOTTOM_GV(dstr) = gv_dup_inc(IoBOTTOM_GV(dstr), param);
+ } else {
+ IoTOP_GV(dstr) = gv_dup(IoTOP_GV(dstr), param);
+ IoFMT_GV(dstr) = gv_dup(IoFMT_GV(dstr), param);
+ IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(dstr), param);
+ }
+ IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(dstr));
+ IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(dstr));
+ IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(dstr));
+ break;
+ case SVt_PVAV:
+ if (AvARRAY((AV*)sstr)) {
+ SV **dst_ary, **src_ary;
+ SSize_t items = AvFILLp((AV*)sstr) + 1;
+
+ src_ary = AvARRAY((AV*)sstr);
+ Newxz(dst_ary, AvMAX((AV*)sstr)+1, SV*);
+ ptr_table_store(PL_ptr_table, src_ary, dst_ary);
+ SvPV_set(dstr, (char*)dst_ary);
+ AvALLOC((AV*)dstr) = dst_ary;
+ if (AvREAL((AV*)sstr)) {
+ while (items-- > 0)
+ *dst_ary++ = sv_dup_inc(*src_ary++, param);
+ }
+ else {
+ while (items-- > 0)
+ *dst_ary++ = sv_dup(*src_ary++, param);
+ }
+ items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr);
+ while (items-- > 0) {
+ *dst_ary++ = &PL_sv_undef;
+ }
+ }
+ else {
+ SvPV_set(dstr, Nullch);
+ AvALLOC((AV*)dstr) = (SV**)NULL;
+ }
+ break;
+ case SVt_PVHV:
+ {
+ HEK *hvname = 0;
+
+ if (HvARRAY((HV*)sstr)) {
+ STRLEN i = 0;
+ const bool sharekeys = !!HvSHAREKEYS(sstr);
+ XPVHV * const dxhv = (XPVHV*)SvANY(dstr);
+ XPVHV * const sxhv = (XPVHV*)SvANY(sstr);
+ char *darray;
+ Newx(darray, PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1)
+ + (SvOOK(sstr) ? sizeof(struct xpvhv_aux) : 0),
+ char);
+ HvARRAY(dstr) = (HE**)darray;
+ while (i <= sxhv->xhv_max) {
+ const HE *source = HvARRAY(sstr)[i];
+ HvARRAY(dstr)[i] = source
+ ? he_dup(source, sharekeys, param) : 0;
+ ++i;
+ }
+ if (SvOOK(sstr)) {
+ 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;
+
+ hvname = saux->xhv_name;
+ daux->xhv_name
+ = hvname ? hek_dup(hvname, param) : hvname;
+
+ daux->xhv_riter = saux->xhv_riter;
+ daux->xhv_eiter = saux->xhv_eiter
+ ? he_dup(saux->xhv_eiter,
+ (bool)!!HvSHAREKEYS(sstr), param) : 0;
+ }
+ }
+ else {
+ SvPV_set(dstr, Nullch);
+ }
+ /* Record stashes for possible cloning in Perl_clone(). */
+ if(hvname)
+ av_push(param->stashes, dstr);
+ }
+ break;
+ case SVt_PVFM:
+ case SVt_PVCV:
+ /* NOTE: not refcounted */
+ CvSTASH(dstr) = hv_dup(CvSTASH(dstr), param);
+ OP_REFCNT_LOCK;
+ CvROOT(dstr) = OpREFCNT_inc(CvROOT(dstr));
+ OP_REFCNT_UNLOCK;
+ if (CvCONST(dstr)) {
+ CvXSUBANY(dstr).any_ptr = GvUNIQUE(CvGV(dstr)) ?
+ SvREFCNT_inc(CvXSUBANY(dstr).any_ptr) :
+ sv_dup_inc((SV *)CvXSUBANY(dstr).any_ptr, param);
+ }
+ /* don't dup if copying back - CvGV isn't refcounted, so the
+ * duped GV may never be freed. A bit of a hack! DAPM */
+ CvGV(dstr) = (param->flags & CLONEf_JOIN_IN) ?
+ Nullgv : gv_dup(CvGV(dstr), param) ;
+ if (!(param->flags & CLONEf_COPY_STACKS)) {
+ CvDEPTH(dstr) = 0;
+ }
+ PAD_DUP(CvPADLIST(dstr), CvPADLIST(sstr), param);
+ CvOUTSIDE(dstr) =
+ CvWEAKOUTSIDE(sstr)
+ ? cv_dup( CvOUTSIDE(dstr), param)
+ : cv_dup_inc(CvOUTSIDE(dstr), param);
+ if (!CvXSUB(dstr))
+ CvFILE(dstr) = SAVEPV(CvFILE(dstr));
+ break;
}
- /* Record stashes for possible cloning in Perl_clone(). */
- if(hvname)
- av_push(param->stashes, dstr);
}
- break;
- case SVt_PVFM:
- SvANY(dstr) = new_XPVFM();
- FmLINES(dstr) = FmLINES(sstr);
- goto dup_pvcv;
- /* NOTREACHED */
- case SVt_PVCV:
- SvANY(dstr) = new_XPVCV();
- dup_pvcv:
- SvCUR_set(dstr, SvCUR(sstr));
- SvLEN_set(dstr, SvLEN(sstr));
- SvIV_set(dstr, SvIVX(sstr));
- SvNV_set(dstr, SvNVX(sstr));
- SvMAGIC_set(dstr, mg_dup(SvMAGIC(sstr), param));
- SvSTASH_set(dstr, hv_dup_inc(SvSTASH(sstr), param));
- Perl_rvpv_dup(aTHX_ dstr, sstr, param);
- CvSTASH(dstr) = hv_dup(CvSTASH(sstr), param); /* NOTE: not refcounted */
- CvSTART(dstr) = CvSTART(sstr);
- OP_REFCNT_LOCK;
- CvROOT(dstr) = OpREFCNT_inc(CvROOT(sstr));
- OP_REFCNT_UNLOCK;
- CvXSUB(dstr) = CvXSUB(sstr);
- CvXSUBANY(dstr) = CvXSUBANY(sstr);
- if (CvCONST(sstr)) {
- CvXSUBANY(dstr).any_ptr = GvUNIQUE(CvGV(sstr)) ?
- SvREFCNT_inc(CvXSUBANY(sstr).any_ptr) :
- sv_dup_inc((SV *)CvXSUBANY(sstr).any_ptr, param);
- }
- /* don't dup if copying back - CvGV isn't refcounted, so the
- * duped GV may never be freed. A bit of a hack! DAPM */
- CvGV(dstr) = (param->flags & CLONEf_JOIN_IN) ?
- Nullgv : gv_dup(CvGV(sstr), param) ;
- if (param->flags & CLONEf_COPY_STACKS) {
- CvDEPTH(dstr) = CvDEPTH(sstr);
- } else {
- CvDEPTH(dstr) = 0;
- }
- PAD_DUP(CvPADLIST(dstr), CvPADLIST(sstr), param);
- CvOUTSIDE_SEQ(dstr) = CvOUTSIDE_SEQ(sstr);
- CvOUTSIDE(dstr) =
- CvWEAKOUTSIDE(sstr)
- ? cv_dup( CvOUTSIDE(sstr), param)
- : cv_dup_inc(CvOUTSIDE(sstr), param);
- CvFLAGS(dstr) = CvFLAGS(sstr);
- CvFILE(dstr) = CvXSUB(sstr) ? CvFILE(sstr) : SAVEPV(CvFILE(sstr));
- break;
- default:
- Perl_croak(aTHX_ "Bizarre SvTYPE [%" IVdf "]", (IV)SvTYPE(sstr));
- break;
}
if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
return ncxs;
/* create anew and remember what it is */
- Newz(56, ncxs, max + 1, PERL_CONTEXT);
+ Newxz(ncxs, max + 1, PERL_CONTEXT);
ptr_table_store(PL_ptr_table, cxs, ncxs);
while (ix >= 0) {
: 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;
return nsi;
/* create anew and remember what it is */
- Newz(56, nsi, 1, PERL_SI);
+ Newxz(nsi, 1, PERL_SI);
ptr_table_store(PL_ptr_table, si, nsi);
nsi->si_stack = av_dup_inc(si->si_stack, param);
*/
void *
-Perl_any_dup(pTHX_ void *v, PerlInterpreter *proto_perl)
+Perl_any_dup(pTHX_ void *v, const PerlInterpreter *proto_perl)
{
void *ret;
ANY *
Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param)
{
- ANY *ss = proto_perl->Tsavestack;
- I32 ix = proto_perl->Tsavestack_ix;
- I32 max = proto_perl->Tsavestack_max;
+ ANY * const ss = proto_perl->Tsavestack;
+ const I32 max = proto_perl->Tsavestack_max;
+ I32 ix = proto_perl->Tsavestack_ix;
ANY *nss;
SV *sv;
GV *gv;
char *c = NULL;
void (*dptr) (void*);
void (*dxptr) (pTHX_ void*);
- OP *o;
- Newz(54, nss, max, ANY);
+ Newxz(nss, max, ANY);
while (ix > 0) {
I32 i = POPINT(ss,ix);
ptr = POPPTR(ss,ix);
if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
/* these are assumed to be refcounted properly */
+ OP *o;
switch (((OP*)ptr)->op_type) {
case OP_LEAVESUB:
case OP_LEAVESUBLV:
static void
do_mark_cloneable_stash(pTHX_ SV *sv)
{
- const HEK *hvname = HvNAME_HEK((HV*)sv);
+ const HEK * const hvname = HvNAME_HEK((HV*)sv);
if (hvname) {
- GV* cloner = gv_fetchmethod_autoload((HV*)sv, "CLONE_SKIP", 0);
+ GV* const cloner = gv_fetchmethod_autoload((HV*)sv, "CLONE_SKIP", 0);
SvFLAGS(sv) |= SVphv_CLONEABLE; /* clone objects by default */
if (cloner && GvCV(cloner)) {
dSP;
param->flags = flags;
param->proto_perl = proto_perl;
- /* arena roots */
- PL_xnv_arenaroot = NULL;
- PL_xnv_root = NULL;
- PL_xpv_arenaroot = NULL;
- PL_xpv_root = NULL;
- PL_xpviv_arenaroot = NULL;
- PL_xpviv_root = NULL;
- PL_xpvnv_arenaroot = NULL;
- PL_xpvnv_root = NULL;
- PL_xpvcv_arenaroot = NULL;
- PL_xpvcv_root = NULL;
- PL_xpvav_arenaroot = NULL;
- PL_xpvav_root = NULL;
- PL_xpvhv_arenaroot = NULL;
- PL_xpvhv_root = NULL;
- PL_xpvmg_arenaroot = NULL;
- PL_xpvmg_root = NULL;
- PL_xpvgv_arenaroot = NULL;
- PL_xpvgv_root = NULL;
- PL_xpvlv_arenaroot = NULL;
- PL_xpvlv_root = NULL;
- PL_xpvbm_arenaroot = NULL;
- PL_xpvbm_root = NULL;
- PL_he_arenaroot = NULL;
- PL_he_root = NULL;
-#if defined(USE_ITHREADS)
- PL_pte_arenaroot = NULL;
- PL_pte_root = NULL;
-#endif
+ Zero(&PL_body_arenaroots, 1, PL_body_arenaroots);
+ Zero(&PL_body_roots, 1, PL_body_roots);
+
PL_nice_chunk = NULL;
PL_nice_chunk_size = 0;
PL_sv_count = 0;
/* create SV map for pointer relocation */
PL_ptr_table = ptr_table_new();
- /* and one for finding shared hash keys quickly */
- PL_shared_hek_table = ptr_table_new();
/* initialize these special pointers as early as possible */
SvANY(&PL_sv_undef) = NULL;
param->stashes = newAV(); /* Setup array of objects to call clone on */
+ /* Set tainting stuff before PerlIO_debug can possibly get called */
+ PL_tainting = proto_perl->Itainting;
+ PL_taint_warn = proto_perl->Itaint_warn;
+
#ifdef PERLIO_LAYERS
/* Clone PerlIO tables as soon as we can handle general xx_dup() */
PerlIO_clone(aTHX_ proto_perl, param);
PL_minus_p = proto_perl->Iminus_p;
PL_minus_l = proto_perl->Iminus_l;
PL_minus_a = proto_perl->Iminus_a;
+ PL_minus_E = proto_perl->Iminus_E;
PL_minus_F = proto_perl->Iminus_F;
PL_doswitches = proto_perl->Idoswitches;
PL_dowarn = proto_perl->Idowarn;
PL_statusvalue = proto_perl->Istatusvalue;
#ifdef VMS
PL_statusvalue_vms = proto_perl->Istatusvalue_vms;
+#else
+ PL_statusvalue_posix = proto_perl->Istatusvalue_posix;
#endif
PL_encoding = sv_dup(proto_perl->Iencoding, param);
PL_regex_padav = newAV();
{
const I32 len = av_len((AV*)proto_perl->Iregex_padav);
- SV** regexen = AvARRAY((AV*)proto_perl->Iregex_padav);
+ SV** const regexen = AvARRAY((AV*)proto_perl->Iregex_padav);
IV i;
av_push(PL_regex_padav,
sv_dup_inc(regexen[0],param));
PL_fdpid = av_dup_inc(proto_perl->Ifdpid, param);
/* internal state */
- PL_tainting = proto_perl->Itainting;
- PL_taint_warn = proto_perl->Itaint_warn;
PL_maxo = proto_perl->Imaxo;
if (proto_perl->Iop_mask)
PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
PL_mess_sv = Nullsv;
PL_ors_sv = sv_dup_inc(proto_perl->Iors_sv, param);
- PL_ofmt = SAVEPV(proto_perl->Iofmt);
/* interpreter atexit processing */
PL_exitlistlen = proto_perl->Iexitlistlen;
if (PL_exitlistlen) {
- New(0, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
+ Newx(PL_exitlist, PL_exitlistlen, PerlExitListEntry);
Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
}
else
PL_evalseq = proto_perl->Ievalseq;
PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */
PL_origalen = proto_perl->Iorigalen;
+#ifdef PERL_USES_PL_PIDSTATUS
PL_pidstatus = newHV(); /* XXX flag for cloning? */
+#endif
PL_osname = SAVEPV(proto_perl->Iosname);
- PL_sh_path_compat = proto_perl->Ish_path_compat; /* XXX never deallocated */
PL_sighandlerp = proto_perl->Isighandlerp;
-
PL_runops = proto_perl->Irunops;
Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char);
#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;
PL_bitcount = Nullch; /* reinits on demand */
if (proto_perl->Ipsig_pend) {
- Newz(0, PL_psig_pend, SIG_SIZE, int);
+ Newxz(PL_psig_pend, SIG_SIZE, int);
}
else {
PL_psig_pend = (int*)NULL;
}
if (proto_perl->Ipsig_ptr) {
- Newz(0, PL_psig_ptr, SIG_SIZE, SV*);
- Newz(0, PL_psig_name, SIG_SIZE, SV*);
+ Newxz(PL_psig_ptr, SIG_SIZE, SV*);
+ Newxz(PL_psig_name, SIG_SIZE, SV*);
for (i = 1; i < SIG_SIZE; i++) {
PL_psig_ptr[i] = sv_dup_inc(proto_perl->Ipsig_ptr[i], param);
PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i], param);
PL_tmps_ix = proto_perl->Ttmps_ix;
PL_tmps_max = proto_perl->Ttmps_max;
PL_tmps_floor = proto_perl->Ttmps_floor;
- Newz(50, PL_tmps_stack, PL_tmps_max, SV*);
+ Newxz(PL_tmps_stack, PL_tmps_max, SV*);
i = 0;
while (i <= PL_tmps_ix) {
PL_tmps_stack[i] = sv_dup_inc(proto_perl->Ttmps_stack[i], param);
/* next PUSHMARK() sets *(PL_markstack_ptr+1) */
i = proto_perl->Tmarkstack_max - proto_perl->Tmarkstack;
- Newz(54, PL_markstack, i, I32);
+ Newxz(PL_markstack, i, I32);
PL_markstack_max = PL_markstack + (proto_perl->Tmarkstack_max
- proto_perl->Tmarkstack);
PL_markstack_ptr = PL_markstack + (proto_perl->Tmarkstack_ptr
* NOTE: unlike the others! */
PL_scopestack_ix = proto_perl->Tscopestack_ix;
PL_scopestack_max = proto_perl->Tscopestack_max;
- Newz(54, PL_scopestack, PL_scopestack_max, I32);
+ Newxz(PL_scopestack, PL_scopestack_max, I32);
Copy(proto_perl->Tscopestack, PL_scopestack, PL_scopestack_ix, I32);
/* NOTE: si_dup() looks at PL_markstack */
* NOTE: unlike the others! */
PL_savestack_ix = proto_perl->Tsavestack_ix;
PL_savestack_max = proto_perl->Tsavestack_max;
- /*Newz(54, PL_savestack, PL_savestack_max, ANY);*/
+ /*Newxz(PL_savestack, PL_savestack_max, ANY);*/
PL_savestack = ss_dup(proto_perl, param);
}
else {
PL_sortstash = hv_dup(proto_perl->Tsortstash, param);
PL_firstgv = gv_dup(proto_perl->Tfirstgv, param);
PL_secondgv = gv_dup(proto_perl->Tsecondgv, param);
- PL_sortcxix = proto_perl->Tsortcxix;
PL_efloatbuf = Nullch; /* reinits on demand */
PL_efloatsize = 0; /* reinits on demand */
if (!(flags & CLONEf_KEEP_PTR_TABLE)) {
ptr_table_free(PL_ptr_table);
PL_ptr_table = NULL;
- ptr_table_free(PL_shared_hek_table);
- PL_shared_hek_table = NULL;
}
/* Call the ->CLONE method, if it exists, for each of the stashes
identified by sv_dup() above.
*/
while(av_len(param->stashes) != -1) {
- HV* stash = (HV*) av_shift(param->stashes);
- GV* cloner = gv_fetchmethod_autoload(stash, "CLONE", 0);
+ HV* const stash = (HV*) av_shift(param->stashes);
+ GV* const cloner = gv_fetchmethod_autoload(stash, "CLONE", 0);
if (cloner && GvCV(cloner)) {
dSP;
ENTER;
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);
+ }
+
+ break;
+
+ case OP_AASSIGN:
+ /* only examine RHS */
+ return find_uninit_var(cBINOPx(obase)->op_first, uninit_sv, match);
+
+ case OP_OPEN:
+ o = cUNOPx(obase)->op_first;
+ if (o->op_type == OP_PUSHMARK)
+ o = o->op_sibling;
+
+ if (!o->op_sibling) {
+ /* one-arg version of open is highly magical */
+
+ 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;
+
+ /* 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;
+
+ 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;
+
+
+ case OP_RV2SV:
+ case OP_CUSTOM:
+ case OP_ENTERSUB:
+ match = 1; /* XS or custom code could trigger random warnings */
+ goto do_op;
+
+ case OP_SCHOMP:
+ case OP_CHOMP:
+ if (SvROK(PL_rs) && uninit_sv == SvRV(PL_rs))
+ return sv_2mortal(newSVpvn("${$/}", 5));
+ /* FALL THROUGH */
+
+ default:
+ do_op:
+ if (!(obase->op_flags & OPf_KIDS))
+ break;
+ o = cUNOPx(obase)->op_first;
+
+ do_op2:
+ if (!o)
+ break;
+
+ /* 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);
+
+ /* scan all args */
+ while (o) {
+ sv = find_uninit_var(o, uninit_sv, 1);
+ if (sv)
+ return sv;
+ o = o->op_sibling;
+ }
+ break;
+ }
+ return Nullsv;
+}
+
+
+/*
+=for apidoc report_uninit
+
+Print appropriate "Use of uninitialized variable" warning
+
+=cut
+*/
+
+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,
+ "", "", "");
}
/*
projects / p5sagit/p5-mst-13.2.git / blobdiff