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);
- 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));
- }
+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)
+Perl_sv_upgrade(pTHX_ register SV *sv, U32 new_type)
{
- if (PL_op) {
- SV* varname = Nullsv;
- if (uninit_sv) {
- varname = find_uninit_var(PL_op, uninit_sv,0);
- if (varname)
- sv_insert(varname, 0, 0, " ", 1);
- }
- Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
- varname ? SvPV_nolen_const(varname) : "",
- " in ", OP_DESC(PL_op));
- }
- else
- Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
- "", "", "");
-}
-
-#define USE_S_MORE_THINGY
-
-#ifdef USE_S_MORE_THINGY
-
-#define S_more_thingy(TYPE,lctype) \
-STATIC void \
-S_more_## lctype (pTHX) \
-{ \
- TYPE* lctype; \
- TYPE* lctype ## end; \
- void *ptr; \
- New(711, ptr, PERL_ARENA_SIZE/sizeof(TYPE), TYPE); \
- *((void **) ptr) = (void *)PL_## lctype ## _arenaroot; \
- PL_## lctype ## _arenaroot = ptr; \
- \
- lctype = (TYPE*) ptr; \
- lctype ## end = &lctype[PERL_ARENA_SIZE / sizeof(TYPE) - 1]; \
- \
- /* fudge by sizeof XPVIV */ \
- lctype += (sizeof(XPVIV) - 1) / sizeof(TYPE) + 1; \
- \
- PL_ ## lctype ## _root = lctype; \
- while ( lctype < lctype ## end) { \
- *(TYPE**) lctype = (TYPE*)(lctype + 1); \
- lctype++; \
- } \
- *(TYPE**) lctype = 0; \
-}
-
-#define S_more_thingy_allocated(lctype) \
-STATIC void \
-S_more_## lctype (pTHX) \
-{ \
- lctype ## _allocated * lctype ; \
- lctype ## _allocated * lctype ## end; \
- void *ptr; \
- New(711, ptr, PERL_ARENA_SIZE/sizeof(lctype ## _allocated ), lctype ## _allocated ); \
- *((void **) ptr) = (void *)PL_ ## lctype ## _arenaroot; \
- PL_## lctype ## _arenaroot = ptr; \
- \
- lctype = (lctype ## _allocated *) ptr; \
- lctype ## end = &lctype[PERL_ARENA_SIZE / sizeof(lctype ## _allocated ) - 1]; \
- \
- /* fudge by sizeof XPVIV */ \
- lctype += (sizeof(XPVIV) - 1) / sizeof(lctype ## _allocated ) + 1; \
- \
- PL_ ## lctype ## _root = lctype; \
- while ( lctype < lctype ## end) { \
- *(lctype ## _allocated **) lctype = (lctype ## _allocated *)(lctype + 1); \
- lctype++; \
- } \
- *(lctype ## _allocated **) lctype = 0; \
-}
-
-S_more_thingy(NV, xnv)
-
-S_more_thingy_allocated(xpv)
-
-S_more_thingy_allocated(xpviv)
-
-S_more_thingy(XPVNV, xpvnv)
-
-S_more_thingy(XPVCV, xpvcv)
-
-S_more_thingy_allocated(xpvav)
-
-S_more_thingy_allocated(xpvhv)
-
-S_more_thingy(XPVGV, xpvgv)
-
-S_more_thingy(XPVMG, xpvmg)
-
-S_more_thingy(XPVBM, xpvbm)
-
-S_more_thingy(XPVLV, xpvlv)
-
+ 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;
-#else
-
-
-/* allocate another arena's worth of NV bodies */
+ if (new_type != SVt_PV && SvIsCOW(sv)) {
+ sv_force_normal_flags(sv, 0);
+ }
-STATIC void
-S_more_xnv(pTHX)
-{
- 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;
+ if (old_type == new_type)
+ return;
- 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++;
- }
- *(NV**)xnv = 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 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;
+ old_body = SvANY(sv);
- 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;
-}
+ /* Copying structures onto other structures that have been neatly zeroed
+ has a subtle gotcha. Consider XPVMG
-/* allocate another arena's worth of struct xpviv */
+ +------+------+------+------+------+-------+-------+
+ | NV | CUR | LEN | IV | MAGIC | STASH |
+ +------+------+------+------+------+-------+-------+
+ 0 4 8 12 16 20 24 28
-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;
+ 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:
- 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;
-}
+ +------+------+------+------+------+-------+-------+------+
+ | NV | CUR | LEN | IV | MAGIC | STASH | ??? |
+ +------+------+------+------+------+-------+-------+------+
+ 0 4 8 12 16 20 24 28 32
-/* allocate another arena's worth of struct xpvnv */
+ so what happens if you allocate memory for this structure:
-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;
+ +------+------+------+------+------+-------+-------+------+------+...
+ | NV | CUR | LEN | IV | MAGIC | STASH | GP | NAME |
+ +------+------+------+------+------+-------+-------+------+------+...
+ 0 4 8 12 16 20 24 28 32 36
- xpvnvend = &xpvnv[PERL_ARENA_SIZE / sizeof(XPVNV) - 1];
- PL_xpvnv_root = ++xpvnv;
- while (xpvnv < xpvnvend) {
- *((XPVNV**)xpvnv) = xpvnv + 1;
- xpvnv++;
- }
- *((XPVNV**)xpvnv) = 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 xpvcv */
+ (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_xpvcv(pTHX)
-{
- XPVCV* xpvcv;
- XPVCV* xpvcvend;
- New(716, xpvcv, PERL_ARENA_SIZE/sizeof(XPVCV), XPVCV);
- *((XPVCV**)xpvcv) = PL_xpvcv_arenaroot;
- PL_xpvcv_arenaroot = xpvcv;
+ So we are careful and work out the size of used parts of all the
+ structures. */
- xpvcvend = &xpvcv[PERL_ARENA_SIZE / sizeof(XPVCV) - 1];
- PL_xpvcv_root = ++xpvcv;
- while (xpvcv < xpvcvend) {
- *((XPVCV**)xpvcv) = xpvcv + 1;
- xpvcv++;
+ 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");
}
- *((XPVCV**)xpvcv) = 0;
-}
-/* allocate another arena's worth of struct xpvav */
+ SvFLAGS(sv) &= ~SVTYPEMASK;
+ SvFLAGS(sv) |= new_type;
-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;
+ 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;
- xpvavend = &xpvav[PERL_ARENA_SIZE / sizeof(xpvav_allocated) - 1];
- PL_xpvav_root = ++xpvav;
- while (xpvav < xpvavend) {
- *((xpvav_allocated**)xpvav) = xpvav + 1;
- xpvav++;
- }
- *((xpvav_allocated**)xpvav) = 0;
-}
+ goto hv_av_common;
-/* allocate another arena's worth of struct xpvhv */
+ 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_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;
+ /* Could put this in the else clause below, as PVMG must have SvPVX
+ 0 already (the assertion above) */
+ SvPV_set(sv, (char*)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;
-}
+ 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 xpvmg */
-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;
+ 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:
- xpvmgend = &xpvmg[PERL_ARENA_SIZE / sizeof(XPVMG) - 1];
- PL_xpvmg_root = ++xpvmg;
- while (xpvmg < xpvmgend) {
- *((XPVMG**)xpvmg) = xpvmg + 1;
- xpvmg++;
- }
- *((XPVMG**)xpvmg) = 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 xpvgv */
+ 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_xpvgv(pTHX)
-{
- XPVGV* xpvgv;
- XPVGV* xpvgvend;
- New(720, xpvgv, PERL_ARENA_SIZE/sizeof(XPVGV), XPVGV);
- *((XPVGV**)xpvgv) = PL_xpvgv_arenaroot;
- PL_xpvgv_arenaroot = xpvgv;
+#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
- xpvgvend = &xpvgv[PERL_ARENA_SIZE / sizeof(XPVGV) - 1];
- PL_xpvgv_root = ++xpvgv;
- while (xpvgv < xpvgvend) {
- *((XPVGV**)xpvgv) = xpvgv + 1;
- xpvgv++;
+ 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);
}
- *((XPVGV**)xpvgv) = 0;
-}
-
-/* allocate another arena's worth of struct xpvlv */
-
-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;
- xpvlvend = &xpvlv[PERL_ARENA_SIZE / sizeof(XPVLV) - 1];
- PL_xpvlv_root = ++xpvlv;
- while (xpvlv < xpvlvend) {
- *((XPVLV**)xpvlv) = xpvlv + 1;
- xpvlv++;
+ 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
}
- *((XPVLV**)xpvlv) = 0;
}
-/* allocate another arena's worth of struct xpvbm */
+/*
+=for apidoc sv_backoff
-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;
+Remove any string offset. You should normally use the C<SvOOK_off> macro
+wrapper instead.
+
+=cut
+*/
- xpvbmend = &xpvbm[PERL_ARENA_SIZE / sizeof(XPVBM) - 1];
- PL_xpvbm_root = ++xpvbm;
- while (xpvbm < xpvbmend) {
- *((XPVBM**)xpvbm) = xpvbm + 1;
- xpvbm++;
+int
+Perl_sv_backoff(pTHX_ register SV *sv)
+{
+ assert(SvOOK(sv));
+ assert(SvTYPE(sv) != SVt_PVHV);
+ assert(SvTYPE(sv) != SVt_PVAV);
+ if (SvIVX(sv)) {
+ const char * const s = SvPVX_const(sv);
+ SvLEN_set(sv, SvLEN(sv) + SvIVX(sv));
+ SvPV_set(sv, SvPVX(sv) - SvIVX(sv));
+ SvIV_set(sv, 0);
+ Move(s, SvPVX(sv), SvCUR(sv)+1, char);
}
- *((XPVBM**)xpvbm) = 0;
+ SvFLAGS(sv) &= ~SVf_OOK;
+ return 0;
}
-#endif
+/*
+=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.
-/* grab a new NV body from the free list, allocating more if necessary */
+=cut
+*/
-STATIC XPVNV*
-S_new_xnv(pTHX)
+char *
+Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen)
{
- 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));
-}
+ register char *s;
-/* return an NV body to the free list */
+#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 void
-S_del_xnv(pTHX_ XPVNV *p)
-{
- 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;
+ 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;
}
-/* grab a new struct xpv from the free list, allocating more if necessary */
+/*
+=for apidoc sv_setiv
-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));
-}
+Copies an integer into the given SV, upgrading first if necessary.
+Does not handle 'set' magic. See also C<sv_setiv_mg>.
-/* return a struct xpv to the free list */
+=cut
+*/
-STATIC void
-S_del_xpv(pTHX_ XPV *p)
+void
+Perl_sv_setiv(pTHX_ register SV *sv, IV i)
{
- 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;
+ 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);
}
-/* grab a new struct xpviv from the free list, allocating more if necessary */
+/*
+=for apidoc sv_setiv_mg
-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));
-}
+Like C<sv_setiv>, but also handles 'set' magic.
-/* return a struct xpviv to the free list */
+=cut
+*/
-STATIC void
-S_del_xpviv(pTHX_ XPVIV *p)
+void
+Perl_sv_setiv_mg(pTHX_ register SV *sv, IV i)
{
- 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;
+ sv_setiv(sv,i);
+ SvSETMAGIC(sv);
}
-/* grab a new struct xpvnv from the free list, allocating more if necessary */
+/*
+=for apidoc sv_setuv
-STATIC XPVNV*
-S_new_xpvnv(pTHX)
-{
- 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;
-}
+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 xpvnv to the free list */
+=cut
+*/
-STATIC void
-S_del_xpvnv(pTHX_ XPVNV *p)
+void
+Perl_sv_setuv(pTHX_ register SV *sv, UV u)
{
- LOCK_SV_MUTEX;
- *(XPVNV**)p = PL_xpvnv_root;
- PL_xpvnv_root = p;
- UNLOCK_SV_MUTEX;
-}
+ /* With these two if statements:
+ u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865
-/* grab a new struct xpvcv from the free list, allocating more if necessary */
+ without
+ u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865
-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;
-}
-
-/* return a struct xpvcv to the free list */
-
-STATIC void
-S_del_xpvcv(pTHX_ XPVCV *p)
-{
- LOCK_SV_MUTEX;
- *(XPVCV**)p = PL_xpvcv_root;
- PL_xpvcv_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 xpvav from the free list, allocating more if necessary */
+/*
+=for apidoc sv_setuv_mg
-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));
-}
+Like C<sv_setuv>, but also handles 'set' magic.
-/* return a struct xpvav to the free list */
+=cut
+*/
-STATIC void
-S_del_xpvav(pTHX_ XPVAV *p)
+void
+Perl_sv_setuv_mg(pTHX_ register SV *sv, UV u)
{
- 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;
+ sv_setiv(sv, 0);
+ SvIsUV_on(sv);
+ sv_setuv(sv,u);
+ SvSETMAGIC(sv);
}
-/* grab a new struct xpvhv from the free list, allocating more if necessary */
+/*
+=for apidoc sv_setnv
-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));
-}
+Copies a double into the given SV, upgrading first if necessary.
+Does not handle 'set' magic. See also C<sv_setnv_mg>.
-/* return a struct xpvhv to the free list */
+=cut
+*/
-STATIC void
-S_del_xpvhv(pTHX_ XPVHV *p)
+void
+Perl_sv_setnv(pTHX_ register SV *sv, NV num)
{
- 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 */
+ 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;
-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;
+ 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);
}
-/* return a struct xpvmg to the free list */
+/*
+=for apidoc sv_setnv_mg
-STATIC void
-S_del_xpvmg(pTHX_ XPVMG *p)
-{
- LOCK_SV_MUTEX;
- *(XPVMG**)p = PL_xpvmg_root;
- PL_xpvmg_root = p;
- UNLOCK_SV_MUTEX;
-}
+Like C<sv_setnv>, but also handles 'set' magic.
-/* grab a new struct xpvgv from the free list, allocating more if necessary */
+=cut
+*/
-STATIC XPVGV*
-S_new_xpvgv(pTHX)
+void
+Perl_sv_setnv_mg(pTHX_ register SV *sv, NV num)
{
- 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;
+ sv_setnv(sv,num);
+ SvSETMAGIC(sv);
}
-/* return a struct xpvgv to the free list */
+/* Print an "isn't numeric" warning, using a cleaned-up,
+ * printable version of the offending string
+ */
STATIC void
-S_del_xpvgv(pTHX_ XPVGV *p)
+S_not_a_number(pTHX_ SV *sv)
{
- LOCK_SV_MUTEX;
- *(XPVGV**)p = PL_xpvgv_root;
- PL_xpvgv_root = p;
- UNLOCK_SV_MUTEX;
-}
+ SV *dsv;
+ char tmpbuf[64];
+ const char *pv;
-/* grab a new struct xpvlv from the free list, allocating more if necessary */
+ if (DO_UTF8(sv)) {
+ dsv = sv_2mortal(newSVpvn("", 0));
+ pv = sv_uni_display(dsv, sv, 10, 0);
+ } else {
+ char *d = tmpbuf;
+ const char * const limit = tmpbuf + sizeof(tmpbuf) - 8;
+ /* each *s can expand to 4 chars + "...\0",
+ i.e. need room for 8 chars */
+
+ const char *s = SvPVX_const(sv);
+ const char * const end = s + SvCUR(sv);
+ for ( ; s < end && d < limit; s++ ) {
+ int ch = *s & 0xFF;
+ if (ch & 128 && !isPRINT_LC(ch)) {
+ *d++ = 'M';
+ *d++ = '-';
+ ch &= 127;
+ }
+ if (ch == '\n') {
+ *d++ = '\\';
+ *d++ = 'n';
+ }
+ else if (ch == '\r') {
+ *d++ = '\\';
+ *d++ = 'r';
+ }
+ else if (ch == '\f') {
+ *d++ = '\\';
+ *d++ = 'f';
+ }
+ else if (ch == '\\') {
+ *d++ = '\\';
+ *d++ = '\\';
+ }
+ else if (ch == '\0') {
+ *d++ = '\\';
+ *d++ = '0';
+ }
+ else if (isPRINT_LC(ch))
+ *d++ = ch;
+ else {
+ *d++ = '^';
+ *d++ = toCTRL(ch);
+ }
+ }
+ if (s < end) {
+ *d++ = '.';
+ *d++ = '.';
+ *d++ = '.';
+ }
+ *d = '\0';
+ pv = tmpbuf;
+ }
-STATIC XPVLV*
-S_new_xpvlv(pTHX)
-{
- 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;
+ if (PL_op)
+ Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
+ "Argument \"%s\" isn't numeric in %s", pv,
+ OP_DESC(PL_op));
+ else
+ Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
+ "Argument \"%s\" isn't numeric", pv);
}
-/* return a struct xpvlv to the free list */
+/*
+=for apidoc looks_like_number
-STATIC void
-S_del_xpvlv(pTHX_ XPVLV *p)
-{
- LOCK_SV_MUTEX;
- *(XPVLV**)p = PL_xpvlv_root;
- PL_xpvlv_root = p;
- UNLOCK_SV_MUTEX;
-}
+Test if the content of an SV looks like a number (or is a number).
+C<Inf> and C<Infinity> are treated as numbers (so will not issue a
+non-numeric warning), even if your atof() doesn't grok them.
-/* grab a new struct xpvbm from the free list, allocating more if necessary */
+=cut
+*/
-STATIC XPVBM*
-S_new_xpvbm(pTHX)
+I32
+Perl_looks_like_number(pTHX_ SV *sv)
{
- 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;
-}
-
-/* return a struct xpvbm to the free list */
+ register const char *sbegin;
+ STRLEN len;
-STATIC void
-S_del_xpvbm(pTHX_ XPVBM *p)
-{
- LOCK_SV_MUTEX;
- *(XPVBM**)p = PL_xpvbm_root;
- PL_xpvbm_root = p;
- UNLOCK_SV_MUTEX;
+ if (SvPOK(sv)) {
+ sbegin = SvPVX_const(sv);
+ len = SvCUR(sv);
+ }
+ else if (SvPOKp(sv))
+ sbegin = SvPV_const(sv, len);
+ else
+ return SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK);
+ return grok_number(sbegin, len, NULL);
}
-#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)
+/* Actually, ISO C leaves conversion of UV to IV undefined, but
+ until proven guilty, assume that things are not that bad... */
-#define new_XPVIV() my_safemalloc(sizeof(XPVIV))
-#define del_XPVIV(p) my_safefree(p)
+/*
+ NV_PRESERVES_UV:
-#define new_XPVNV() my_safemalloc(sizeof(XPVNV))
-#define del_XPVNV(p) my_safefree(p)
+ As 64 bit platforms often have an NV that doesn't preserve all bits of
+ an IV (an assumption perl has been based on to date) it becomes necessary
+ to remove the assumption that the NV always carries enough precision to
+ recreate the IV whenever needed, and that the NV is the canonical form.
+ Instead, IV/UV and NV need to be given equal rights. So as to not lose
+ precision as a side effect of conversion (which would lead to insanity
+ and the dragon(s) in t/op/numconvert.t getting very angry) the intent is
+ 1) to distinguish between IV/UV/NV slots that have cached a valid
+ conversion where precision was lost and IV/UV/NV slots that have a
+ valid conversion which has lost no precision
+ 2) to ensure that if a numeric conversion to one form is requested that
+ would lose precision, the precise conversion (or differently
+ imprecise conversion) is also performed and cached, to prevent
+ requests for different numeric formats on the same SV causing
+ lossy conversion chains. (lossless conversion chains are perfectly
+ acceptable (still))
-#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)
+ flags are used:
+ SvIOKp is true if the IV slot contains a valid value
+ SvIOK is true only if the IV value is accurate (UV if SvIOK_UV true)
+ SvNOKp is true if the NV slot contains a valid value
+ SvNOK is true only if the NV value is accurate
-#define new_XPVHV() my_safemalloc(sizeof(XPVHV))
-#define del_XPVHV(p) my_safefree(p)
+ so
+ while converting from PV to NV, check to see if converting that NV to an
+ IV(or UV) would lose accuracy over a direct conversion from PV to
+ IV(or UV). If it would, cache both conversions, return NV, but mark
+ SV as IOK NOKp (ie not NOK).
-#define new_XPVMG() my_safemalloc(sizeof(XPVMG))
-#define del_XPVMG(p) my_safefree(p)
+ While converting from PV to IV, check to see if converting that IV to an
+ NV would lose accuracy over a direct conversion from PV to NV. If it
+ would, cache both conversions, flag similarly.
-#define new_XPVGV() my_safemalloc(sizeof(XPVGV))
-#define del_XPVGV(p) my_safefree(p)
+ Before, the SV value "3.2" could become NV=3.2 IV=3 NOK, IOK quite
+ correctly because if IV & NV were set NV *always* overruled.
+ Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flag's meaning
+ changes - now IV and NV together means that the two are interchangeable:
+ SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX;
-#define new_XPVLV() my_safemalloc(sizeof(XPVLV))
-#define del_XPVLV(p) my_safefree(p)
+ The benefit of this is that operations such as pp_add know that if
+ SvIOK is true for both left and right operands, then integer addition
+ can be used instead of floating point (for cases where the result won't
+ overflow). Before, floating point was always used, which could lead to
+ loss of precision compared with integer addition.
-#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
-
-Upgrade an SV to a more complex form. Generally adds a new body type to the
-SV, then copies across as much information as possible from the old body.
-You generally want to use the C<SvUPGRADE> macro wrapper. See also C<svtype>.
-
-=cut
-*/
-
-void
-Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt)
-{
-
- 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;
-
- pv = NULL;
- cur = 0;
- len = 0;
- iv = 0;
- nv = 0.0;
- magic = NULL;
- stash = Nullhv;
-
- 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;
- 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);
- 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_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;
- }
-}
-
-/*
-=for apidoc sv_backoff
-
-Remove any string offset. You should normally use the C<SvOOK_off> macro
-wrapper instead.
-
-=cut
-*/
-
-int
-Perl_sv_backoff(pTHX_ register SV *sv)
-{
- assert(SvOOK(sv));
- assert(SvTYPE(sv) != SVt_PVHV);
- assert(SvTYPE(sv) != SVt_PVAV);
- if (SvIVX(sv)) {
- const char *s = SvPVX_const(sv);
- SvLEN_set(sv, SvLEN(sv) + SvIVX(sv));
- SvPV_set(sv, SvPVX(sv) - SvIVX(sv));
- SvIV_set(sv, 0);
- Move(s, SvPVX(sv), SvCUR(sv)+1, char);
- }
- SvFLAGS(sv) &= ~SVf_OOK;
- return 0;
-}
-
-/*
-=for apidoc sv_grow
-
-Expands the character buffer in the SV. If necessary, uses C<sv_unref> and
-upgrades the SV to C<SVt_PV>. Returns a pointer to the character buffer.
-Use the C<SvGROW> wrapper instead.
-
-=cut
-*/
-
-char *
-Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen)
-{
- register char *s;
-
-#ifdef HAS_64K_LIMIT
- if (newlen >= 0x10000) {
- PerlIO_printf(Perl_debug_log,
- "Allocation too large: %"UVxf"\n", (UV)newlen);
- my_exit(1);
- }
-#endif /* HAS_64K_LIMIT */
- if (SvROK(sv))
- sv_unref(sv);
- if (SvTYPE(sv) < SVt_PV) {
- sv_upgrade(sv, SVt_PV);
- s = SvPVX_mutable(sv);
- }
- else if (SvOOK(sv)) { /* pv is offset? */
- sv_backoff(sv);
- s = SvPVX_mutable(sv);
- if (newlen > SvLEN(sv))
- newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
-#ifdef HAS_64K_LIMIT
- if (newlen >= 0x10000)
- newlen = 0xFFFF;
-#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;
-
- if (DO_UTF8(sv)) {
- dsv = sv_2mortal(newSVpv("", 0));
- pv = sv_uni_display(dsv, sv, 10, 0);
- } else {
- char *d = tmpbuf;
- char *limit = tmpbuf + sizeof(tmpbuf) - 8;
- /* each *s can expand to 4 chars + "...\0",
- i.e. need room for 8 chars */
-
- const char *s, *end;
- for (s = SvPVX_const(sv), end = s + SvCUR(sv); s < end && d < limit;
- s++) {
- int ch = *s & 0xFF;
- if (ch & 128 && !isPRINT_LC(ch)) {
- *d++ = 'M';
- *d++ = '-';
- ch &= 127;
- }
- if (ch == '\n') {
- *d++ = '\\';
- *d++ = 'n';
- }
- else if (ch == '\r') {
- *d++ = '\\';
- *d++ = 'r';
- }
- else if (ch == '\f') {
- *d++ = '\\';
- *d++ = 'f';
- }
- else if (ch == '\\') {
- *d++ = '\\';
- *d++ = '\\';
- }
- else if (ch == '\0') {
- *d++ = '\\';
- *d++ = '0';
- }
- else if (isPRINT_LC(ch))
- *d++ = ch;
- else {
- *d++ = '^';
- *d++ = toCTRL(ch);
- }
- }
- if (s < end) {
- *d++ = '.';
- *d++ = '.';
- *d++ = '.';
- }
- *d = '\0';
- pv = tmpbuf;
- }
-
- if (PL_op)
- Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
- "Argument \"%s\" isn't numeric in %s", pv,
- OP_DESC(PL_op));
- else
- Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
- "Argument \"%s\" isn't numeric", pv);
-}
-
-/*
-=for apidoc looks_like_number
-
-Test if the content of an SV looks like a number (or is a number).
-C<Inf> and C<Infinity> are treated as numbers (so will not issue a
-non-numeric warning), even if your atof() doesn't grok them.
-
-=cut
-*/
-
-I32
-Perl_looks_like_number(pTHX_ SV *sv)
-{
- register const char *sbegin;
- STRLEN len;
-
- if (SvPOK(sv)) {
- sbegin = SvPVX_const(sv);
- len = SvCUR(sv);
- }
- else if (SvPOKp(sv))
- sbegin = SvPV_const(sv, len);
- else
- return SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK);
- return grok_number(sbegin, len, NULL);
-}
-
-/* Actually, ISO C leaves conversion of UV to IV undefined, but
- until proven guilty, assume that things are not that bad... */
-
-/*
- NV_PRESERVES_UV:
-
- As 64 bit platforms often have an NV that doesn't preserve all bits of
- an IV (an assumption perl has been based on to date) it becomes necessary
- to remove the assumption that the NV always carries enough precision to
- recreate the IV whenever needed, and that the NV is the canonical form.
- Instead, IV/UV and NV need to be given equal rights. So as to not lose
- precision as a side effect of conversion (which would lead to insanity
- and the dragon(s) in t/op/numconvert.t getting very angry) the intent is
- 1) to distinguish between IV/UV/NV slots that have cached a valid
- conversion where precision was lost and IV/UV/NV slots that have a
- valid conversion which has lost no precision
- 2) to ensure that if a numeric conversion to one form is requested that
- would lose precision, the precise conversion (or differently
- imprecise conversion) is also performed and cached, to prevent
- requests for different numeric formats on the same SV causing
- lossy conversion chains. (lossless conversion chains are perfectly
- acceptable (still))
-
-
- flags are used:
- SvIOKp is true if the IV slot contains a valid value
- SvIOK is true only if the IV value is accurate (UV if SvIOK_UV true)
- SvNOKp is true if the NV slot contains a valid value
- SvNOK is true only if the NV value is accurate
-
- so
- while converting from PV to NV, check to see if converting that NV to an
- IV(or UV) would lose accuracy over a direct conversion from PV to
- IV(or UV). If it would, cache both conversions, return NV, but mark
- SV as IOK NOKp (ie not NOK).
-
- While converting from PV to IV, check to see if converting that IV to an
- NV would lose accuracy over a direct conversion from PV to NV. If it
- would, cache both conversions, flag similarly.
-
- Before, the SV value "3.2" could become NV=3.2 IV=3 NOK, IOK quite
- correctly because if IV & NV were set NV *always* overruled.
- Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flag's meaning
- changes - now IV and NV together means that the two are interchangeable:
- SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX;
-
- The benefit of this is that operations such as pp_add know that if
- SvIOK is true for both left and right operands, then integer addition
- can be used instead of floating point (for cases where the result won't
- overflow). Before, floating point was always used, which could lead to
- loss of precision compared with integer addition.
-
- * making IV and NV equal status should make maths accurate on 64 bit
- platforms
- * may speed up maths somewhat if pp_add and friends start to use
- integers when possible instead of fp. (Hopefully the overhead in
- looking for SvIOK and checking for overflow will not outweigh the
- fp to integer speedup)
- * will slow down integer operations (callers of SvIV) on "inaccurate"
- values, as the change from SvIOK to SvIOKp will cause a call into
- sv_2iv each time rather than a macro access direct to the IV slot
- * should speed up number->string conversion on integers as IV is
- favoured when IV and NV are equally accurate
-
- ####################################################################
- You had better be using SvIOK_notUV if you want an IV for arithmetic:
- SvIOK is true if (IV or UV), so you might be getting (IV)SvUV.
- On the other hand, SvUOK is true iff UV.
- ####################################################################
-
- Your mileage will vary depending your CPU's relative fp to integer
- performance ratio.
-*/
-
-#ifndef NV_PRESERVES_UV
-# define IS_NUMBER_UNDERFLOW_IV 1
-# define IS_NUMBER_UNDERFLOW_UV 2
-# define IS_NUMBER_IV_AND_UV 2
-# define IS_NUMBER_OVERFLOW_IV 4
-# define IS_NUMBER_OVERFLOW_UV 5
-
-/* sv_2iuv_non_preserve(): private routine for use by sv_2iv() and sv_2uv() */
-
-/* For sv_2nv these three cases are "SvNOK and don't bother casting" */
-STATIC int
-S_sv_2iuv_non_preserve(pTHX_ register SV *sv, I32 numtype)
-{
- DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_2iuv_non '%s', IV=0x%"UVxf" NV=%"NVgf" inttype=%"UVXf"\n", SvPVX_const(sv), SvIVX(sv), SvNVX(sv), (UV)numtype));
- if (SvNVX(sv) < (NV)IV_MIN) {
- (void)SvIOKp_on(sv);
- (void)SvNOK_on(sv);
- SvIV_set(sv, IV_MIN);
- return IS_NUMBER_UNDERFLOW_IV;
- }
- if (SvNVX(sv) > (NV)UV_MAX) {
- (void)SvIOKp_on(sv);
- (void)SvNOK_on(sv);
- SvIsUV_on(sv);
- SvUV_set(sv, UV_MAX);
- return IS_NUMBER_OVERFLOW_UV;
- }
- (void)SvIOKp_on(sv);
- (void)SvNOK_on(sv);
- /* Can't use strtol etc to convert this string. (See truth table in
- sv_2iv */
- if (SvNVX(sv) <= (UV)IV_MAX) {
- SvIV_set(sv, I_V(SvNVX(sv)));
- if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
- SvIOK_on(sv); /* Integer is precise. NOK, IOK */
- } else {
- /* Integer is imprecise. NOK, IOKp */
- }
- return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
- }
- SvIsUV_on(sv);
- SvUV_set(sv, U_V(SvNVX(sv)));
- if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
- if (SvUVX(sv) == UV_MAX) {
- /* As we know that NVs don't preserve UVs, UV_MAX cannot
- possibly be preserved by NV. Hence, it must be overflow.
- NOK, IOKp */
- return IS_NUMBER_OVERFLOW_UV;
- }
- SvIOK_on(sv); /* Integer is precise. NOK, UOK */
- } else {
- /* Integer is imprecise. NOK, IOKp */
- }
- return IS_NUMBER_OVERFLOW_IV;
-}
-#endif /* !NV_PRESERVES_UV*/
-
-/* 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.
-
-=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);
-
- (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
- /* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost
- certainly cast into the IV range at IV_MAX, whereas the correct
- answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary
- cases go to UV */
- if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
- SvIV_set(sv, I_V(SvNVX(sv)));
- if (SvNVX(sv) == (NV) SvIVX(sv)
-#ifndef NV_PRESERVES_UV
- && (((UV)1 << NV_PRESERVES_UV_BITS) >
- (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
- /* Don't flag it as "accurately an integer" if the number
- came from a (by definition imprecise) NV operation, and
- we're outside the range of NV integer precision */
-#endif
- ) {
- SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
- DEBUG_c(PerlIO_printf(Perl_debug_log,
- "0x%"UVxf" iv(%"NVgf" => %"IVdf") (precise)\n",
- PTR2UV(sv),
- SvNVX(sv),
- SvIVX(sv)));
-
- } else {
- /* IV not precise. No need to convert from PV, as NV
- conversion would already have cached IV if it detected
- that PV->IV would be better than PV->NV->IV
- flags already correct - don't set public IOK. */
- DEBUG_c(PerlIO_printf(Perl_debug_log,
- "0x%"UVxf" iv(%"NVgf" => %"IVdf") (imprecise)\n",
- PTR2UV(sv),
- SvNVX(sv),
- SvIVX(sv)));
- }
- /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
- but the cast (NV)IV_MIN rounds to a the value less (more
- negative) than IV_MIN which happens to be equal to SvNVX ??
- Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
- NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
- (NV)UVX == NVX are both true, but the values differ. :-(
- Hopefully for 2s complement IV_MIN is something like
- 0x8000000000000000 which will be exact. NWC */
- }
- else {
- SvUV_set(sv, U_V(SvNVX(sv)));
- if (
- (SvNVX(sv) == (NV) SvUVX(sv))
-#ifndef NV_PRESERVES_UV
- /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
- /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
- && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
- /* Don't flag it as "accurately an integer" if the number
- came from a (by definition imprecise) NV operation, and
- we're outside the range of NV integer precision */
-#endif
- )
- SvIOK_on(sv);
- SvIsUV_on(sv);
- ret_iv_max:
- DEBUG_c(PerlIO_printf(Perl_debug_log,
- "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
- PTR2UV(sv),
- SvUVX(sv),
- SvUVX(sv)));
- return (IV)SvUVX(sv);
- }
- }
- else if (SvPOKp(sv) && SvLEN(sv)) {
- UV value;
- const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
- /* We want to avoid a possible problem when we cache an IV which
- may be later translated to an NV, and the resulting NV is not
- the same as the direct translation of the initial string
- (eg 123.456 can shortcut to the IV 123 with atol(), but we must
- be careful to ensure that the value with the .456 is around if the
- NV value is requested in the future).
-
- This means that if we cache such an IV, we need to cache the
- NV as well. Moreover, we trade speed for space, and do not
- cache the NV if we are sure it's not needed.
- */
-
- /* SVt_PVNV is one higher than SVt_PVIV, hence this order */
- if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
- == IS_NUMBER_IN_UV) {
- /* It's definitely an integer, only upgrade to PVIV */
- if (SvTYPE(sv) < SVt_PVIV)
- sv_upgrade(sv, SVt_PVIV);
- (void)SvIOK_on(sv);
- } else if (SvTYPE(sv) < SVt_PVNV)
- sv_upgrade(sv, SVt_PVNV);
-
- /* If NV preserves UV then we only use the UV value if we know that
- we aren't going to call atof() below. If NVs don't preserve UVs
- then the value returned may have more precision than atof() will
- return, even though value isn't perfectly accurate. */
- if ((numtype & (IS_NUMBER_IN_UV
-#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 {
- SvUV_set(sv, value);
- SvIsUV_on(sv);
- }
- } else {
- /* 2s complement assumption */
- if (value <= (UV)IV_MIN) {
- SvIV_set(sv, -(IV)value);
- } else {
- /* Too negative for an IV. This is a double upgrade, but
- I'm assuming it will be rare. */
- if (SvTYPE(sv) < SVt_PVNV)
- sv_upgrade(sv, SVt_PVNV);
- SvNOK_on(sv);
- SvIOK_off(sv);
- SvIOKp_on(sv);
- SvNV_set(sv, -(NV)value);
- SvIV_set(sv, IV_MIN);
- }
- }
- }
- /* For !NV_PRESERVES_UV and IS_NUMBER_IN_UV and IS_NUMBER_NOT_INT we
- will be in the previous block to set the IV slot, and the next
- block to set the NV slot. So no else here. */
-
- if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
- != IS_NUMBER_IN_UV) {
- /* It wasn't an (integer that doesn't overflow the UV). */
- SvNV_set(sv, Atof(SvPVX_const(sv)));
-
- if (! numtype && ckWARN(WARN_NUMERIC))
- not_a_number(sv);
-
-#if defined(USE_LONG_DOUBLE)
- DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" PERL_PRIgldbl ")\n",
- PTR2UV(sv), SvNVX(sv)));
-#else
- DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"NVgf")\n",
- PTR2UV(sv), SvNVX(sv)));
-#endif
-
-
-#ifdef NV_PRESERVES_UV
- (void)SvIOKp_on(sv);
- (void)SvNOK_on(sv);
- if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
- SvIV_set(sv, I_V(SvNVX(sv)));
- if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
- SvIOK_on(sv);
- } else {
- /* Integer is imprecise. NOK, IOKp */
- }
- /* UV will not work better than IV */
- } else {
- if (SvNVX(sv) > (NV)UV_MAX) {
- SvIsUV_on(sv);
- /* Integer is inaccurate. NOK, IOKp, is UV */
- SvUV_set(sv, UV_MAX);
- SvIsUV_on(sv);
- } else {
- SvUV_set(sv, U_V(SvNVX(sv)));
- /* 0xFFFFFFFFFFFFFFFF not an issue in here */
- if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
- SvIOK_on(sv);
- SvIsUV_on(sv);
- } else {
- /* Integer is imprecise. NOK, IOKp, is UV */
- SvIsUV_on(sv);
- }
- }
- goto ret_iv_max;
- }
-#else /* NV_PRESERVES_UV */
- if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
- == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
- /* The IV slot will have been set from value returned by
- grok_number above. The NV slot has just been set using
- Atof. */
- SvNOK_on(sv);
- assert (SvIOKp(sv));
- } else {
- if (((UV)1 << NV_PRESERVES_UV_BITS) >
- U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
- /* Small enough to preserve all bits. */
- (void)SvIOKp_on(sv);
- SvNOK_on(sv);
- SvIV_set(sv, I_V(SvNVX(sv)));
- if ((NV)(SvIVX(sv)) == SvNVX(sv))
- SvIOK_on(sv);
- /* Assumption: first non-preserved integer is < IV_MAX,
- this NV is in the preserved range, therefore: */
- if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
- < (UV)IV_MAX)) {
- Perl_croak(aTHX_ "sv_2iv assumed (U_V(fabs((double)SvNVX(sv))) < (UV)IV_MAX) but SvNVX(sv)=%"NVgf" U_V is 0x%"UVxf", IV_MAX is 0x%"UVxf"\n", SvNVX(sv), U_V(SvNVX(sv)), (UV)IV_MAX);
- }
- } else {
- /* IN_UV NOT_INT
- 0 0 already failed to read UV.
- 0 1 already failed to read UV.
- 1 0 you won't get here in this case. IV/UV
- slot set, public IOK, Atof() unneeded.
- 1 1 already read UV.
- so there's no point in sv_2iuv_non_preserve() attempting
- to use atol, strtol, strtoul etc. */
- if (sv_2iuv_non_preserve (sv, numtype)
- >= IS_NUMBER_OVERFLOW_IV)
- goto ret_iv_max;
- }
- }
-#endif /* NV_PRESERVES_UV */
- }
- } else {
- if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
- 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" 2iv(%"IVdf")\n",
- PTR2UV(sv),SvIVX(sv)));
- return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
-}
-
-/* sv_2uv() is now a macro using Perl_sv_2uv_flags();
- * this function provided for binary compatibility only
- */
+ * making IV and NV equal status should make maths accurate on 64 bit
+ platforms
+ * may speed up maths somewhat if pp_add and friends start to use
+ integers when possible instead of fp. (Hopefully the overhead in
+ looking for SvIOK and checking for overflow will not outweigh the
+ fp to integer speedup)
+ * will slow down integer operations (callers of SvIV) on "inaccurate"
+ values, as the change from SvIOK to SvIOKp will cause a call into
+ sv_2iv each time rather than a macro access direct to the IV slot
+ * should speed up number->string conversion on integers as IV is
+ favoured when IV and NV are equally accurate
-UV
-Perl_sv_2uv(pTHX_ register SV *sv)
-{
- return sv_2uv_flags(sv, SV_GMAGIC);
-}
+ ####################################################################
+ You had better be using SvIOK_notUV if you want an IV for arithmetic:
+ SvIOK is true if (IV or UV), so you might be getting (IV)SvUV.
+ On the other hand, SvUOK is true iff UV.
+ ####################################################################
-/*
-=for apidoc sv_2uv_flags
+ Your mileage will vary depending your CPU's relative fp to integer
+ performance ratio.
+*/
-Return the unsigned integer value of an SV, doing any necessary string
-conversion. If flags includes SV_GMAGIC, does an mg_get() first.
-Normally used via the C<SvUV(sv)> and C<SvUVx(sv)> macros.
+#ifndef NV_PRESERVES_UV
+# define IS_NUMBER_UNDERFLOW_IV 1
+# define IS_NUMBER_UNDERFLOW_UV 2
+# define IS_NUMBER_IV_AND_UV 2
+# define IS_NUMBER_OVERFLOW_IV 4
+# define IS_NUMBER_OVERFLOW_UV 5
-=cut
-*/
+/* sv_2iuv_non_preserve(): private routine for use by sv_2iv() and sv_2uv() */
-UV
-Perl_sv_2uv_flags(pTHX_ register SV *sv, I32 flags)
+/* For sv_2nv these three cases are "SvNOK and don't bother casting" */
+STATIC int
+S_sv_2iuv_non_preserve(pTHX_ register SV *sv, I32 numtype)
{
- if (!sv)
- return 0;
- if (SvGMAGICAL(sv)) {
- if (flags & SV_GMAGIC)
- mg_get(sv);
- if (SvIOKp(sv))
- return SvUVX(sv);
- if (SvNOKp(sv))
- return U_V(SvNVX(sv));
- if (SvPOKp(sv) && SvLEN(sv))
- return asUV(sv);
- if (!SvROK(sv)) {
- if (!(SvFLAGS(sv) & SVs_PADTMP)) {
- if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
- report_uninit(sv);
- }
- return 0;
- }
+ DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_2iuv_non '%s', IV=0x%"UVxf" NV=%"NVgf" inttype=%"UVXf"\n", SvPVX_const(sv), SvIVX(sv), SvNVX(sv), (UV)numtype));
+ if (SvNVX(sv) < (NV)IV_MIN) {
+ (void)SvIOKp_on(sv);
+ (void)SvNOK_on(sv);
+ SvIV_set(sv, IV_MIN);
+ return IS_NUMBER_UNDERFLOW_IV;
}
- if (SvTHINKFIRST(sv)) {
- if (SvROK(sv)) {
- SV* tmpstr;
- if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
- (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv))))
- return SvUV(tmpstr);
- return PTR2UV(SvRV(sv));
- }
- if (SvIsCOW(sv)) {
- sv_force_normal_flags(sv, 0);
- }
- if (SvREADONLY(sv) && !SvOK(sv)) {
- if (ckWARN(WARN_UNINITIALIZED))
- report_uninit(sv);
- return 0;
- }
+ if (SvNVX(sv) > (NV)UV_MAX) {
+ (void)SvIOKp_on(sv);
+ (void)SvNOK_on(sv);
+ SvIsUV_on(sv);
+ SvUV_set(sv, UV_MAX);
+ return IS_NUMBER_OVERFLOW_UV;
}
- if (SvIOKp(sv)) {
- if (SvIsUV(sv)) {
- return SvUVX(sv);
- }
- else {
- return (UV)SvIVX(sv);
- }
+ (void)SvIOKp_on(sv);
+ (void)SvNOK_on(sv);
+ /* Can't use strtol etc to convert this string. (See truth table in
+ sv_2iv */
+ if (SvNVX(sv) <= (UV)IV_MAX) {
+ SvIV_set(sv, I_V(SvNVX(sv)));
+ if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
+ SvIOK_on(sv); /* Integer is precise. NOK, IOK */
+ } else {
+ /* Integer is imprecise. NOK, IOKp */
+ }
+ return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
+ }
+ SvIsUV_on(sv);
+ SvUV_set(sv, U_V(SvNVX(sv)));
+ if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
+ if (SvUVX(sv) == UV_MAX) {
+ /* As we know that NVs don't preserve UVs, UV_MAX cannot
+ possibly be preserved by NV. Hence, it must be overflow.
+ NOK, IOKp */
+ return IS_NUMBER_OVERFLOW_UV;
+ }
+ SvIOK_on(sv); /* Integer is precise. NOK, UOK */
+ } else {
+ /* Integer is imprecise. NOK, IOKp */
}
+ return IS_NUMBER_OVERFLOW_IV;
+}
+#endif /* !NV_PRESERVES_UV*/
+
+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
sv_upgrade(sv, SVt_PVNV);
(void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
+ /* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost
+ certainly cast into the IV range at IV_MAX, whereas the correct
+ answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary
+ cases go to UV */
if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
SvIV_set(sv, I_V(SvNVX(sv)));
if (SvNVX(sv) == (NV) SvIVX(sv)
) {
SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
DEBUG_c(PerlIO_printf(Perl_debug_log,
- "0x%"UVxf" uv(%"NVgf" => %"IVdf") (precise)\n",
+ "0x%"UVxf" iv(%"NVgf" => %"IVdf") (precise)\n",
PTR2UV(sv),
SvNVX(sv),
SvIVX(sv)));
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",
+ "0x%"UVxf" iv(%"NVgf" => %"IVdf") (imprecise)\n",
PTR2UV(sv),
SvNVX(sv),
SvIVX(sv)));
SvIOK_on(sv);
SvIsUV_on(sv);
DEBUG_c(PerlIO_printf(Perl_debug_log,
- "0x%"UVxf" 2uv(%"UVuf" => %"IVdf") (as unsigned)\n",
+ "0x%"UVxf" 2iv(%"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
+ /* 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 translation of the initial data.
+ 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 a UV, 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 not needed.
+ cache the NV if we are sure it's not needed.
*/
/* SVt_PVNV is one higher than SVt_PVIV, hence this order */
/* 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. */
+ return, even though value isn't perfectly accurate. */
if ((numtype & (IS_NUMBER_IN_UV
#ifdef NV_PRESERVES_UV
| IS_NUMBER_NOT_INT
}
}
}
+ /* For !NV_PRESERVES_UV and IS_NUMBER_IN_UV and IS_NUMBER_NOT_INT we
+ will be in the previous block to set the IV slot, and the next
+ block to set the NV slot. So no else here. */
if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
!= IS_NUMBER_IN_UV) {
- /* It wasn't an integer, or it overflowed the UV. */
+ /* It wasn't an (integer that doesn't overflow the UV). */
SvNV_set(sv, Atof(SvPVX_const(sv)));
- if (! numtype && ckWARN(WARN_NUMERIC))
- not_a_number(sv);
+ if (! numtype && 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)));
+ DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" PERL_PRIgldbl ")\n",
+ PTR2UV(sv), SvNVX(sv)));
#else
- DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"NVgf")\n",
- PTR2UV(sv), SvNVX(sv)));
+ DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"NVgf")\n",
+ PTR2UV(sv), SvNVX(sv)));
#endif
#ifdef NV_PRESERVES_UV
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);
}
}
+ 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
+ /* 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);
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);
+ Perl_croak(aTHX_ "sv_2iv assumed (U_V(fabs((double)SvNVX(sv))) < (UV)IV_MAX) but SvNVX(sv)=%"NVgf" U_V is 0x%"UVxf", IV_MAX is 0x%"UVxf"\n", SvNVX(sv), U_V(SvNVX(sv)), (UV)IV_MAX);
}
- } else
+ } else {
+ /* IN_UV NOT_INT
+ 0 0 already failed to read UV.
+ 0 1 already failed to read UV.
+ 1 0 you won't get here in this case. IV/UV
+ slot set, public IOK, Atof() unneeded.
+ 1 1 already read UV.
+ so there's no point in sv_2iuv_non_preserve() attempting
+ to use atol, strtol, strtoul etc. */
sv_2iuv_non_preserve (sv, numtype);
+ }
}
#endif /* NV_PRESERVES_UV */
}
- }
- else {
- if (!(SvFLAGS(sv) & SVs_PADTMP)) {
- if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
+ }
+ else {
+ if (!(SvFLAGS(sv) & SVs_PADTMP)) {
+ if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
+ report_uninit(sv);
+ }
+ if (SvTYPE(sv) < SVt_IV)
+ /* Typically the caller expects that sv_any is not NULL now. */
+ sv_upgrade(sv, SVt_IV);
+ /* Return 0 from the caller. */
+ return TRUE;
+ }
+ return FALSE;
+}
+
+/*
+=for apidoc sv_2iv_flags
+
+Return the integer value of an SV, doing any necessary string
+conversion. If flags includes SV_GMAGIC, does an mg_get() first.
+Normally used via the C<SvIV(sv)> and C<SvIVx(sv)> macros.
+
+=cut
+*/
+
+IV
+Perl_sv_2iv_flags(pTHX_ register SV *sv, I32 flags)
+{
+ if (!sv)
+ return 0;
+ if (SvGMAGICAL(sv)) {
+ if (flags & SV_GMAGIC)
+ mg_get(sv);
+ if (SvIOKp(sv))
+ return SvIVX(sv);
+ if (SvNOKp(sv)) {
+ return I_V(SvNVX(sv));
+ }
+ if (SvPOKp(sv) && SvLEN(sv)) {
+ UV value;
+ const int numtype
+ = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
+
+ if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
+ == IS_NUMBER_IN_UV) {
+ /* It's definitely an integer */
+ if (numtype & IS_NUMBER_NEG) {
+ if (value < (UV)IV_MIN)
+ return -(IV)value;
+ } else {
+ if (value < (UV)IV_MAX)
+ return (IV)value;
+ }
+ }
+ if (!numtype) {
+ if (ckWARN(WARN_NUMERIC))
+ not_a_number(sv);
+ }
+ return I_V(Atof(SvPVX_const(sv)));
+ }
+ if (SvROK(sv)) {
+ goto return_rok;
+ }
+ assert(SvTYPE(sv) >= SVt_PVMG);
+ /* This falls through to the report_uninit inside S_sv_2iuv_common. */
+ } 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 (SvTYPE(sv) < SVt_IV)
- /* Typically the caller expects that sv_any is not NULL now. */
- sv_upgrade(sv, SVt_IV);
+ }
+ if (!SvIOKp(sv)) {
+ if (S_sv_2iuv_common(aTHX_ sv))
+ return 0;
+ }
+ DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
+ PTR2UV(sv),SvIVX(sv)));
+ return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
+}
+
+/*
+=for apidoc sv_2uv_flags
+
+Return the unsigned integer value of an SV, doing any necessary string
+conversion. If flags includes SV_GMAGIC, does an mg_get() first.
+Normally used via the C<SvUV(sv)> and C<SvUVx(sv)> macros.
+
+=cut
+*/
+
+UV
+Perl_sv_2uv_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 SvUVX(sv);
+ if (SvNOKp(sv))
+ return U_V(SvNVX(sv));
+ if (SvPOKp(sv) && SvLEN(sv)) {
+ UV value;
+ const int numtype
+ = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
+
+ if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
+ == IS_NUMBER_IN_UV) {
+ /* It's definitely an integer */
+ if (!(numtype & IS_NUMBER_NEG))
+ return value;
+ }
+ if (!numtype) {
+ if (ckWARN(WARN_NUMERIC))
+ not_a_number(sv);
+ }
+ return U_V(Atof(SvPVX_const(sv)));
+ }
+ if (SvROK(sv)) {
+ goto return_rok;
+ }
+ assert(SvTYPE(sv) >= SVt_PVMG);
+ /* This falls through to the report_uninit inside S_sv_2iuv_common. */
+ } 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 SvUV(tmpstr);
+ }
+ }
+ return PTR2UV(SvRV(sv));
+ }
+ if (SvIsCOW(sv)) {
+ sv_force_normal_flags(sv, 0);
+ }
+ if (SvREADONLY(sv) && !SvOK(sv)) {
+ if (ckWARN(WARN_UNINITIALIZED))
+ report_uninit(sv);
+ return 0;
+ }
+ }
+ if (!SvIOKp(sv)) {
+ if (S_sv_2iuv_common(aTHX_ sv))
+ return 0;
}
DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
if (SvNOKp(sv))
return SvNVX(sv);
if (SvPOKp(sv) && SvLEN(sv)) {
- if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) &&
+ if (!SvIOKp(sv) && ckWARN(WARN_NUMERIC) &&
!grok_number(SvPVX_const(sv), SvCUR(sv), NULL))
not_a_number(sv);
return Atof(SvPVX_const(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)) {
+ 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;
- if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
- (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv))))
- return SvNV(tmpstr);
- return PTR2NV(SvRV(sv));
+ return_rok:
+ if (SvAMAGIC(sv)) {
+ SV *const tmpstr = AMG_CALLun(sv,numer);
+ if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
+ return SvNV(tmpstr);
+ }
+ }
+ return PTR2NV(SvRV(sv));
}
if (SvIsCOW(sv)) {
sv_force_normal_flags(sv, 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 (SvROK(sv)) { /* XXX Skip this when sv_pvn_force calls */
+ /* Sneaky stuff here */
+ SV * const tsv = newSVpvn(tbuf, len);
+
+ sv_2mortal(tsv);
+ if (lp)
+ *lp = SvCUR(tsv);
+ return SvPVX(tsv);
}
- if (lp)
- *lp = 0;
- return (char *)"";
- }
- }
- if (SvTHINKFIRST(sv)) {
- if (SvROK(sv)) {
- SV* tmpstr;
- register const char *typestr;
- if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)) &&
- (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
- /* Unwrap this: */
- /* char *pv = lp ? SvPV(tmpstr, *lp) : SvPV_nolen(tmpstr); */
-
- char *pv;
- if ((SvFLAGS(tmpstr) & (SVf_POK)) == SVf_POK) {
- if (flags & SV_CONST_RETURN) {
- pv = (char *) SvPVX_const(tmpstr);
- } else {
- pv = (flags & SV_MUTABLE_RETURN)
- ? SvPVX_mutable(tmpstr) : SvPVX(tmpstr);
- }
- if (lp)
- *lp = SvCUR(tmpstr);
- } else {
- pv = sv_2pv_flags(tmpstr, lp, flags);
- }
- if (SvUTF8(tmpstr))
- SvUTF8_on(sv);
- else
- SvUTF8_off(sv);
- return pv;
- }
- origsv = sv;
- sv = (SV*)SvRV(sv);
- if (!sv)
- typestr = "NULLREF";
else {
- MAGIC *mg;
-
- switch (SvTYPE(sv)) {
- case SVt_PVMG:
- if ( ((SvFLAGS(sv) &
- (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
- == (SVs_OBJECT|SVs_SMG))
- && (mg = mg_find(sv, PERL_MAGIC_qr))) {
- const regexp *re = (regexp *)mg->mg_obj;
-
- if (!mg->mg_ptr) {
- const char *fptr = "msix";
- char reflags[6];
- char ch;
- int left = 0;
- int right = 4;
- char need_newline = 0;
- U16 reganch = (U16)((re->reganch & PMf_COMPILETIME) >> 12);
-
- while((ch = *fptr++)) {
- if(reganch & 1) {
- reflags[left++] = ch;
- }
- else {
- reflags[right--] = ch;
- }
- reganch >>= 1;
- }
- if(left != 4) {
- reflags[left] = '-';
- left = 5;
- }
-
- mg->mg_len = re->prelen + 4 + left;
- /*
- * If /x was used, we have to worry about a regex
- * ending with a comment later being embedded
- * within another regex. If so, we don't want this
- * regex's "commentization" to leak out to the
- * right part of the enclosing regex, we must cap
- * it with a newline.
- *
- * So, if /x was used, we scan backwards from the
- * end of the regex. If we find a '#' before we
- * find a newline, we need to add a newline
- * ourself. If we find a '\n' first (or if we
- * don't find '#' or '\n'), we don't need to add
- * anything. -jfriedl
- */
- if (PMf_EXTENDED & re->reganch)
- {
- const char *endptr = re->precomp + re->prelen;
- while (endptr >= re->precomp)
- {
- const char c = *(endptr--);
- if (c == '\n')
- break; /* don't need another */
- if (c == '#') {
- /* we end while in a comment, so we
- need a newline */
- mg->mg_len++; /* save space for it */
- need_newline = 1; /* note to add it */
- break;
- }
- }
- }
+ dVAR;
- 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;
+#ifdef FIXNEGATIVEZERO
+ if (len == 2 && tbuf[0] == '-' && tbuf[1] == '0') {
+ tbuf[0] = '0';
+ tbuf[1] = 0;
+ len = 1;
+ }
+#endif
+ SvUPGRADE(sv, SVt_PV);
+ if (lp)
+ *lp = len;
+ s = SvGROW_mutable(sv, len + 1);
+ SvCUR_set(sv, len);
+ SvPOKp_on(sv);
+ return memcpy(s, tbuf, len + 1);
+ }
+ }
+ if (SvROK(sv)) {
+ goto return_rok;
+ }
+ assert(SvTYPE(sv) >= SVt_PVMG);
+ /* This falls through to the report_uninit near the end of the
+ function. */
+ } else if (SvTHINKFIRST(sv)) {
+ if (SvROK(sv)) {
+ return_rok:
+ if (SvAMAGIC(sv)) {
+ SV *const tmpstr = AMG_CALLun(sv,string);
+ if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
+ /* Unwrap this: */
+ /* char *pv = lp ? SvPV(tmpstr, *lp) : SvPV_nolen(tmpstr);
+ */
+
+ char *pv;
+ if ((SvFLAGS(tmpstr) & (SVf_POK)) == SVf_POK) {
+ if (flags & SV_CONST_RETURN) {
+ pv = (char *) SvPVX_const(tmpstr);
+ } else {
+ pv = (flags & SV_MUTABLE_RETURN)
+ ? SvPVX_mutable(tmpstr) : SvPVX(tmpstr);
}
- PL_reginterp_cnt += re->program[0].next_off;
-
- if (re->reganch & ROPT_UTF8)
- SvUTF8_on(origsv);
- else
- SvUTF8_off(origsv);
if (lp)
- *lp = mg->mg_len;
- return mg->mg_ptr;
+ *lp = SvCUR(tmpstr);
+ } else {
+ pv = sv_2pv_flags(tmpstr, lp, flags);
}
- /* Fall through */
- case SVt_NULL:
- case SVt_IV:
- case SVt_NV:
- case SVt_RV:
- case SVt_PV:
- case SVt_PVIV:
- case SVt_PVNV:
- case SVt_PVBM: typestr = SvROK(sv) ? "REF" : "SCALAR"; break;
- case SVt_PVLV: typestr = SvROK(sv) ? "REF"
- /* tied lvalues should appear to be
- * scalars for backwards compatitbility */
- : (LvTYPE(sv) == 't' || LvTYPE(sv) == 'T')
- ? "SCALAR" : "LVALUE"; break;
- case SVt_PVAV: typestr = "ARRAY"; break;
- case SVt_PVHV: typestr = "HASH"; break;
- case SVt_PVCV: typestr = "CODE"; break;
- case SVt_PVGV: typestr = "GLOB"; break;
- case SVt_PVFM: typestr = "FORMAT"; break;
- case SVt_PVIO: typestr = "IO"; break;
- default: typestr = "UNKNOWN"; break;
+ if (SvUTF8(tmpstr))
+ SvUTF8_on(sv);
+ else
+ SvUTF8_off(sv);
+ return pv;
}
- tsv = NEWSV(0,0);
- if (SvOBJECT(sv)) {
- const char *name = HvNAME_get(SvSTASH(sv));
- Perl_sv_setpvf(aTHX_ tsv, "%s=%s(0x%"UVxf")",
- name ? name : "__ANON__" , typestr, PTR2UV(sv));
+ }
+ {
+ SV *tsv;
+ MAGIC *mg;
+ const SV *const referent = (SV*)SvRV(sv);
+
+ if (!referent) {
+ tsv = sv_2mortal(newSVpvn("NULLREF", 7));
+ } else if (SvTYPE(referent) == SVt_PVMG
+ && ((SvFLAGS(referent) &
+ (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
+ == (SVs_OBJECT|SVs_SMG))
+ && (mg = mg_find(referent, PERL_MAGIC_qr))) {
+ return S_stringify_regexp(aTHX_ sv, mg, lp);
+ } else {
+ const char *const typestr = sv_reftype(referent, 0);
+
+ tsv = sv_newmortal();
+ if (SvOBJECT(referent)) {
+ const char *const name = HvNAME_get(SvSTASH(referent));
+ Perl_sv_setpvf(aTHX_ tsv, "%s=%s(0x%"UVxf")",
+ name ? name : "__ANON__" , typestr,
+ PTR2UV(referent));
+ }
+ else
+ Perl_sv_setpvf(aTHX_ tsv, "%s(0x%"UVxf")", typestr,
+ PTR2UV(referent));
}
- else
- Perl_sv_setpvf(aTHX_ tsv, "%s(0x%"UVxf")", typestr, PTR2UV(sv));
- goto tokensaveref;
+ if (lp)
+ *lp = SvCUR(tsv);
+ return SvPVX(tsv);
}
- if (lp)
- *lp = strlen(typestr);
- return (char *)typestr;
}
if (SvREADONLY(sv) && !SvOK(sv)) {
if (ckWARN(WARN_UNINITIALIZED))
if (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
}
/*
-=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);
-}
-
-/*
=for apidoc sv_2pvutf8
Return a pointer to the UTF-8-encoded representation of the SV, and set *lp
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 */
- U8 *recoded = bytes_to_utf8((U8*)s, &len);
-
- SvPV_free(sv); /* No longer using what was there before. */
-
- SvPV_set(sv, (char*)recoded);
- SvCUR_set(sv, len - 1);
- SvLEN_set(sv, len); /* No longer know the real size. */
+ }
}
/* Mark as UTF-8 even if no hibit - saves scanning loop */
SvUTF8_on(sv);
return 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) {
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 (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);
SvLEN_set(sv, SvLEN(sv) - delta);
SvCUR_set(sv, SvCUR(sv) - delta);
SvPV_set(sv, SvPVX(sv) + delta);
- 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);
+ SvIV_set(sv, SvIVX(sv) + delta);
}
/*
*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;
+ }
+ }
}
/*
{
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
-*/
-
-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);
-}
-
-/*
-=for apidoc sv_uv
-
-A private implementation of the C<SvUVx> macro for compilers which can't
-cope with complex macro expressions. Always use the macro instead.
-
-=cut
-*/
-
-UV
-Perl_sv_uv(pTHX_ register SV *sv)
-{
- 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.
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));
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>. The C<cflags> argument can contain
-C<SV_IMMEDIATE_UNREF> to force the reference count to be decremented
-(otherwise the decrementing is conditional on the reference count being
-different from one or the reference being a readonly SV).
-See C<SvROK_off>.
-
-=cut
-*/
-
-void
-Perl_sv_unref_flags(pTHX_ SV *sv, U32 flags)
-{
- SV* rv = SvRV(sv);
-
- if (SvWEAKREF(sv)) {
- sv_del_backref(sv);
- SvWEAKREF_off(sv);
- SvRV_set(sv, NULL);
- return;
- }
- SvRV_set(sv, NULL);
- SvROK_off(sv);
- /* You can't have a || SvREADONLY(rv) 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);
- 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>.
+as a reversal of C<newSVrv>. The C<cflags> argument can contain
+C<SV_IMMEDIATE_UNREF> to force the reference count to be decremented
+(otherwise the decrementing is conditional on the reference count being
+different from one or the reference being a readonly SV).
+See C<SvROK_off>.
=cut
*/
void
-Perl_sv_unref(pTHX_ SV *sv)
+Perl_sv_unref_flags(pTHX_ SV *ref, U32 flags)
{
- sv_unref_flags(sv, 0);
-}
-
-/*
-=for apidoc sv_taint
+ SV* const target = SvRV(ref);
-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);
+ if (SvWEAKREF(ref)) {
+ sv_del_backref(target, ref);
+ SvWEAKREF_off(ref);
+ SvRV_set(ref, NULL);
+ return;
+ }
+ 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(target) != 1 || (flags & SV_IMMEDIATE_UNREF))
+ SvREFCNT_dec(target);
+ else /* XXX Hack, but hard to make $a=$a->[1] work otherwise */
+ 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
-
-
-
-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;
-}
+#define PTR_TABLE_HASH(ptr) \
+ ((PTR2UV(ptr) >> 3) ^ (PTR2UV(ptr) >> (3 + 7)) ^ (PTR2UV(ptr) >> (3 + 17)))
-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;
-}
+/*
+ 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_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)
-{
- 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)
}
}
+/* 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);
+ default:
+ {
+ /* 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 */
+ }
+ 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);
+ }
}
- items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr);
- while (items-- > 0) {
- *dst_ary++ = &PL_sv_undef;
+ 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));
}
- }
- 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));
- {
- 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;
+
+ /* 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);
}
- 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;
+ /* 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;
}
- else {
- SvPV_set(dstr, Nullch);
- }
- /* 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:
}
}
- return nss;
-}
+ return nss;
+}
+
+
+/* if sv is a stash, call $class->CLONE_SKIP(), and set the SVphv_CLONEABLE
+ * flag to the result. This is done for each stash before cloning starts,
+ * so we know which stashes want their objects cloned */
+
+static void
+do_mark_cloneable_stash(pTHX_ SV *sv)
+{
+ const HEK * const hvname = HvNAME_HEK((HV*)sv);
+ if (hvname) {
+ GV* const cloner = gv_fetchmethod_autoload((HV*)sv, "CLONE_SKIP", 0);
+ SvFLAGS(sv) |= SVphv_CLONEABLE; /* clone objects by default */
+ if (cloner && GvCV(cloner)) {
+ dSP;
+ UV status;
+
+ ENTER;
+ SAVETMPS;
+ PUSHMARK(SP);
+ XPUSHs(sv_2mortal(newSVhek(hvname)));
+ PUTBACK;
+ call_sv((SV*)GvCV(cloner), G_SCALAR);
+ SPAGAIN;
+ status = POPu;
+ PUTBACK;
+ FREETMPS;
+ LEAVE;
+ if (status)
+ SvFLAGS(sv) &= ~SVphv_CLONEABLE;
+ }
+ }
+}
+
+
+
+/*
+=for apidoc perl_clone
+
+Create and return a new interpreter by cloning the current one.
+
+perl_clone takes these flags as parameters:
+
+CLONEf_COPY_STACKS - is used to, well, copy the stacks also,
+without it we only clone the data and zero the stacks,
+with it we copy the stacks and the new perl interpreter is
+ready to run at the exact same point as the previous one.
+The pseudo-fork code uses COPY_STACKS while the
+threads->new doesn't.
+
+CLONEf_KEEP_PTR_TABLE
+perl_clone keeps a ptr_table with the pointer of the old
+variable as a key and the new variable as a value,
+this allows it to check if something has been cloned and not
+clone it again but rather just use the value and increase the
+refcount. If KEEP_PTR_TABLE is not set then perl_clone will kill
+the ptr_table using the function
+C<ptr_table_free(PL_ptr_table); PL_ptr_table = NULL;>,
+reason to keep it around is if you want to dup some of your own
+variable who are outside the graph perl scans, example of this
+code is in threads.xs create
+
+CLONEf_CLONE_HOST
+This is a win32 thing, it is ignored on unix, it tells perls
+win32host code (which is c++) to clone itself, this is needed on
+win32 if you want to run two threads at the same time,
+if you just want to do some stuff in a separate perl interpreter
+and then throw it away and return to the original one,
+you don't need to do anything.
+
+=cut
+*/
+
+/* XXX the above needs expanding by someone who actually understands it ! */
+EXTERN_C PerlInterpreter *
+perl_clone_host(PerlInterpreter* proto_perl, UV flags);
+
+PerlInterpreter *
+perl_clone(PerlInterpreter *proto_perl, UV flags)
+{
+ dVAR;
+#ifdef PERL_IMPLICIT_SYS
+
+ /* perlhost.h so we need to call into it
+ to clone the host, CPerlHost should have a c interface, sky */
+
+ if (flags & CLONEf_CLONE_HOST) {
+ return perl_clone_host(proto_perl,flags);
+ }
+ return perl_clone_using(proto_perl, flags,
+ proto_perl->IMem,
+ proto_perl->IMemShared,
+ proto_perl->IMemParse,
+ proto_perl->IEnv,
+ proto_perl->IStdIO,
+ proto_perl->ILIO,
+ proto_perl->IDir,
+ proto_perl->ISock,
+ proto_perl->IProc);
+}
+
+PerlInterpreter *
+perl_clone_using(PerlInterpreter *proto_perl, UV flags,
+ struct IPerlMem* ipM, struct IPerlMem* ipMS,
+ struct IPerlMem* ipMP, struct IPerlEnv* ipE,
+ struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
+ struct IPerlDir* ipD, struct IPerlSock* ipS,
+ struct IPerlProc* ipP)
+{
+ /* XXX many of the string copies here can be optimized if they're
+ * constants; they need to be allocated as common memory and just
+ * their pointers copied. */
+
+ IV i;
+ CLONE_PARAMS clone_params;
+ CLONE_PARAMS* param = &clone_params;
+
+ PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
+ /* for each stash, determine whether its objects should be cloned */
+ S_visit(proto_perl, do_mark_cloneable_stash, SVt_PVHV, SVTYPEMASK);
+ PERL_SET_THX(my_perl);
+
+# ifdef DEBUGGING
+ Poison(my_perl, 1, PerlInterpreter);
+ PL_op = Nullop;
+ PL_curcop = (COP *)Nullop;
+ PL_markstack = 0;
+ PL_scopestack = 0;
+ PL_savestack = 0;
+ PL_savestack_ix = 0;
+ PL_savestack_max = -1;
+ PL_sig_pending = 0;
+ Zero(&PL_debug_pad, 1, struct perl_debug_pad);
+# else /* !DEBUGGING */
+ Zero(my_perl, 1, PerlInterpreter);
+# endif /* DEBUGGING */
+
+ /* host pointers */
+ PL_Mem = ipM;
+ PL_MemShared = ipMS;
+ PL_MemParse = ipMP;
+ PL_Env = ipE;
+ PL_StdIO = ipStd;
+ PL_LIO = ipLIO;
+ PL_Dir = ipD;
+ PL_Sock = ipS;
+ PL_Proc = ipP;
+#else /* !PERL_IMPLICIT_SYS */
+ IV i;
+ CLONE_PARAMS clone_params;
+ CLONE_PARAMS* param = &clone_params;
+ PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
+ /* for each stash, determine whether its objects should be cloned */
+ S_visit(proto_perl, do_mark_cloneable_stash, SVt_PVHV, SVTYPEMASK);
+ PERL_SET_THX(my_perl);
+
+# ifdef DEBUGGING
+ Poison(my_perl, 1, PerlInterpreter);
+ PL_op = Nullop;
+ PL_curcop = (COP *)Nullop;
+ PL_markstack = 0;
+ PL_scopestack = 0;
+ PL_savestack = 0;
+ PL_savestack_ix = 0;
+ PL_savestack_max = -1;
+ PL_sig_pending = 0;
+ Zero(&PL_debug_pad, 1, struct perl_debug_pad);
+# else /* !DEBUGGING */
+ Zero(my_perl, 1, PerlInterpreter);
+# endif /* DEBUGGING */
+#endif /* PERL_IMPLICIT_SYS */
+ param->flags = flags;
+ param->proto_perl = proto_perl;
+
+ Zero(&PL_body_arenaroots, 1, PL_body_arenaroots);
+ Zero(&PL_body_roots, 1, PL_body_roots);
+
+ PL_nice_chunk = NULL;
+ PL_nice_chunk_size = 0;
+ PL_sv_count = 0;
+ PL_sv_objcount = 0;
+ PL_sv_root = Nullsv;
+ PL_sv_arenaroot = Nullsv;
+
+ PL_debug = proto_perl->Idebug;
+
+ PL_hash_seed = proto_perl->Ihash_seed;
+ PL_rehash_seed = proto_perl->Irehash_seed;
+
+#ifdef USE_REENTRANT_API
+ /* XXX: things like -Dm will segfault here in perlio, but doing
+ * PERL_SET_CONTEXT(proto_perl);
+ * breaks too many other things
+ */
+ Perl_reentrant_init(aTHX);
+#endif
+
+ /* create SV map for pointer relocation */
+ PL_ptr_table = ptr_table_new();
+
+ /* initialize these special pointers as early as possible */
+ SvANY(&PL_sv_undef) = NULL;
+ SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
+ SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL;
+ ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
+
+ SvANY(&PL_sv_no) = new_XPVNV();
+ SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
+ SvFLAGS(&PL_sv_no) = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
+ |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
+ SvPV_set(&PL_sv_no, SAVEPVN(PL_No, 0));
+ SvCUR_set(&PL_sv_no, 0);
+ SvLEN_set(&PL_sv_no, 1);
+ SvIV_set(&PL_sv_no, 0);
+ SvNV_set(&PL_sv_no, 0);
+ ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
+
+ SvANY(&PL_sv_yes) = new_XPVNV();
+ SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
+ SvFLAGS(&PL_sv_yes) = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
+ |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
+ SvPV_set(&PL_sv_yes, SAVEPVN(PL_Yes, 1));
+ SvCUR_set(&PL_sv_yes, 1);
+ SvLEN_set(&PL_sv_yes, 2);
+ SvIV_set(&PL_sv_yes, 1);
+ SvNV_set(&PL_sv_yes, 1);
+ ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
+
+ /* create (a non-shared!) shared string table */
+ PL_strtab = newHV();
+ HvSHAREKEYS_off(PL_strtab);
+ hv_ksplit(PL_strtab, HvTOTALKEYS(proto_perl->Istrtab));
+ ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
+
+ PL_compiling = proto_perl->Icompiling;
+
+ /* These two PVs will be free'd special way so must set them same way op.c does */
+ PL_compiling.cop_stashpv = savesharedpv(PL_compiling.cop_stashpv);
+ ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_stashpv, PL_compiling.cop_stashpv);
+
+ PL_compiling.cop_file = savesharedpv(PL_compiling.cop_file);
+ ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_file, PL_compiling.cop_file);
+
+ ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
+ if (!specialWARN(PL_compiling.cop_warnings))
+ PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings, param);
+ if (!specialCopIO(PL_compiling.cop_io))
+ PL_compiling.cop_io = sv_dup_inc(PL_compiling.cop_io, param);
+ PL_curcop = (COP*)any_dup(proto_perl->Tcurcop, proto_perl);
+ /* pseudo environmental stuff */
+ PL_origargc = proto_perl->Iorigargc;
+ PL_origargv = proto_perl->Iorigargv;
-/* if sv is a stash, call $class->CLONE_SKIP(), and set the SVphv_CLONEABLE
- * flag to the result. This is done for each stash before cloning starts,
- * so we know which stashes want their objects cloned */
+ param->stashes = newAV(); /* Setup array of objects to call clone on */
-static void
-do_mark_cloneable_stash(pTHX_ SV *sv)
-{
- const HEK *hvname = HvNAME_HEK((HV*)sv);
- if (hvname) {
- GV* cloner = gv_fetchmethod_autoload((HV*)sv, "CLONE_SKIP", 0);
- SvFLAGS(sv) |= SVphv_CLONEABLE; /* clone objects by default */
- if (cloner && GvCV(cloner)) {
- dSP;
- UV status;
+ /* Set tainting stuff before PerlIO_debug can possibly get called */
+ PL_tainting = proto_perl->Itainting;
+ PL_taint_warn = proto_perl->Itaint_warn;
- ENTER;
- SAVETMPS;
- PUSHMARK(SP);
- XPUSHs(sv_2mortal(newSVhek(hvname)));
- PUTBACK;
- call_sv((SV*)GvCV(cloner), G_SCALAR);
- SPAGAIN;
- status = POPu;
- PUTBACK;
- FREETMPS;
- LEAVE;
- if (status)
- SvFLAGS(sv) &= ~SVphv_CLONEABLE;
+#ifdef PERLIO_LAYERS
+ /* Clone PerlIO tables as soon as we can handle general xx_dup() */
+ PerlIO_clone(aTHX_ proto_perl, param);
+#endif
+
+ PL_envgv = gv_dup(proto_perl->Ienvgv, param);
+ PL_incgv = gv_dup(proto_perl->Iincgv, param);
+ PL_hintgv = gv_dup(proto_perl->Ihintgv, param);
+ PL_origfilename = SAVEPV(proto_perl->Iorigfilename);
+ PL_diehook = sv_dup_inc(proto_perl->Idiehook, param);
+ PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook, param);
+
+ /* switches */
+ PL_minus_c = proto_perl->Iminus_c;
+ PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel, param);
+ PL_localpatches = proto_perl->Ilocalpatches;
+ PL_splitstr = proto_perl->Isplitstr;
+ PL_preprocess = proto_perl->Ipreprocess;
+ PL_minus_n = proto_perl->Iminus_n;
+ PL_minus_p = proto_perl->Iminus_p;
+ PL_minus_l = proto_perl->Iminus_l;
+ PL_minus_a = proto_perl->Iminus_a;
+ PL_minus_E = proto_perl->Iminus_E;
+ PL_minus_F = proto_perl->Iminus_F;
+ PL_doswitches = proto_perl->Idoswitches;
+ PL_dowarn = proto_perl->Idowarn;
+ PL_doextract = proto_perl->Idoextract;
+ PL_sawampersand = proto_perl->Isawampersand;
+ PL_unsafe = proto_perl->Iunsafe;
+ PL_inplace = SAVEPV(proto_perl->Iinplace);
+ PL_e_script = sv_dup_inc(proto_perl->Ie_script, param);
+ PL_perldb = proto_perl->Iperldb;
+ PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
+ PL_exit_flags = proto_perl->Iexit_flags;
+
+ /* magical thingies */
+ /* XXX time(&PL_basetime) when asked for? */
+ PL_basetime = proto_perl->Ibasetime;
+ PL_formfeed = sv_dup(proto_perl->Iformfeed, param);
+
+ PL_maxsysfd = proto_perl->Imaxsysfd;
+ PL_multiline = proto_perl->Imultiline;
+ PL_statusvalue = proto_perl->Istatusvalue;
+#ifdef VMS
+ PL_statusvalue_vms = proto_perl->Istatusvalue_vms;
+#else
+ PL_statusvalue_posix = proto_perl->Istatusvalue_posix;
+#endif
+ PL_encoding = sv_dup(proto_perl->Iencoding, param);
+
+ sv_setpvn(PERL_DEBUG_PAD(0), "", 0); /* For regex debugging. */
+ sv_setpvn(PERL_DEBUG_PAD(1), "", 0); /* ext/re needs these */
+ sv_setpvn(PERL_DEBUG_PAD(2), "", 0); /* even without DEBUGGING. */
+
+ /* Clone the regex array */
+ PL_regex_padav = newAV();
+ {
+ const I32 len = av_len((AV*)proto_perl->Iregex_padav);
+ SV** const regexen = AvARRAY((AV*)proto_perl->Iregex_padav);
+ IV i;
+ av_push(PL_regex_padav,
+ sv_dup_inc(regexen[0],param));
+ for(i = 1; i <= len; i++) {
+ if(SvREPADTMP(regexen[i])) {
+ av_push(PL_regex_padav, sv_dup_inc(regexen[i], param));
+ } else {
+ av_push(PL_regex_padav,
+ SvREFCNT_inc(
+ newSViv(PTR2IV(re_dup(INT2PTR(REGEXP *,
+ SvIVX(regexen[i])), param)))
+ ));
+ }
}
}
-}
+ PL_regex_pad = AvARRAY(PL_regex_padav);
+ /* shortcuts to various I/O objects */
+ PL_stdingv = gv_dup(proto_perl->Istdingv, param);
+ PL_stderrgv = gv_dup(proto_perl->Istderrgv, param);
+ PL_defgv = gv_dup(proto_perl->Idefgv, param);
+ PL_argvgv = gv_dup(proto_perl->Iargvgv, param);
+ PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv, param);
+ PL_argvout_stack = av_dup_inc(proto_perl->Iargvout_stack, param);
+ /* shortcuts to regexp stuff */
+ PL_replgv = gv_dup(proto_perl->Ireplgv, param);
-/*
-=for apidoc perl_clone
+ /* shortcuts to misc objects */
+ PL_errgv = gv_dup(proto_perl->Ierrgv, param);
-Create and return a new interpreter by cloning the current one.
+ /* shortcuts to debugging objects */
+ PL_DBgv = gv_dup(proto_perl->IDBgv, param);
+ PL_DBline = gv_dup(proto_perl->IDBline, param);
+ PL_DBsub = gv_dup(proto_perl->IDBsub, param);
+ PL_DBsingle = sv_dup(proto_perl->IDBsingle, param);
+ PL_DBtrace = sv_dup(proto_perl->IDBtrace, param);
+ PL_DBsignal = sv_dup(proto_perl->IDBsignal, param);
+ PL_DBassertion = sv_dup(proto_perl->IDBassertion, param);
+ PL_lineary = av_dup(proto_perl->Ilineary, param);
+ PL_dbargs = av_dup(proto_perl->Idbargs, param);
-perl_clone takes these flags as parameters:
+ /* symbol tables */
+ PL_defstash = hv_dup_inc(proto_perl->Tdefstash, param);
+ PL_curstash = hv_dup(proto_perl->Tcurstash, param);
+ PL_debstash = hv_dup(proto_perl->Idebstash, param);
+ PL_globalstash = hv_dup(proto_perl->Iglobalstash, param);
+ PL_curstname = sv_dup_inc(proto_perl->Icurstname, param);
-CLONEf_COPY_STACKS - is used to, well, copy the stacks also,
-without it we only clone the data and zero the stacks,
-with it we copy the stacks and the new perl interpreter is
-ready to run at the exact same point as the previous one.
-The pseudo-fork code uses COPY_STACKS while the
-threads->new doesn't.
+ PL_beginav = av_dup_inc(proto_perl->Ibeginav, param);
+ PL_beginav_save = av_dup_inc(proto_perl->Ibeginav_save, param);
+ PL_checkav_save = av_dup_inc(proto_perl->Icheckav_save, param);
+ PL_endav = av_dup_inc(proto_perl->Iendav, param);
+ PL_checkav = av_dup_inc(proto_perl->Icheckav, param);
+ PL_initav = av_dup_inc(proto_perl->Iinitav, param);
-CLONEf_KEEP_PTR_TABLE
-perl_clone keeps a ptr_table with the pointer of the old
-variable as a key and the new variable as a value,
-this allows it to check if something has been cloned and not
-clone it again but rather just use the value and increase the
-refcount. If KEEP_PTR_TABLE is not set then perl_clone will kill
-the ptr_table using the function
-C<ptr_table_free(PL_ptr_table); PL_ptr_table = NULL;>,
-reason to keep it around is if you want to dup some of your own
-variable who are outside the graph perl scans, example of this
-code is in threads.xs create
+ PL_sub_generation = proto_perl->Isub_generation;
-CLONEf_CLONE_HOST
-This is a win32 thing, it is ignored on unix, it tells perls
-win32host code (which is c++) to clone itself, this is needed on
-win32 if you want to run two threads at the same time,
-if you just want to do some stuff in a separate perl interpreter
-and then throw it away and return to the original one,
-you don't need to do anything.
+ /* funky return mechanisms */
+ PL_forkprocess = proto_perl->Iforkprocess;
-=cut
-*/
+ /* subprocess state */
+ PL_fdpid = av_dup_inc(proto_perl->Ifdpid, param);
-/* XXX the above needs expanding by someone who actually understands it ! */
-EXTERN_C PerlInterpreter *
-perl_clone_host(PerlInterpreter* proto_perl, UV flags);
+ /* internal state */
+ PL_maxo = proto_perl->Imaxo;
+ if (proto_perl->Iop_mask)
+ PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
+ else
+ PL_op_mask = Nullch;
+ /* PL_asserting = proto_perl->Iasserting; */
-PerlInterpreter *
-perl_clone(PerlInterpreter *proto_perl, UV flags)
-{
- dVAR;
-#ifdef PERL_IMPLICIT_SYS
+ /* current interpreter roots */
+ PL_main_cv = cv_dup_inc(proto_perl->Imain_cv, param);
+ PL_main_root = OpREFCNT_inc(proto_perl->Imain_root);
+ PL_main_start = proto_perl->Imain_start;
+ PL_eval_root = proto_perl->Ieval_root;
+ PL_eval_start = proto_perl->Ieval_start;
- /* perlhost.h so we need to call into it
- to clone the host, CPerlHost should have a c interface, sky */
+ /* runtime control stuff */
+ PL_curcopdb = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
+ PL_copline = proto_perl->Icopline;
- if (flags & CLONEf_CLONE_HOST) {
- return perl_clone_host(proto_perl,flags);
- }
- return perl_clone_using(proto_perl, flags,
- proto_perl->IMem,
- proto_perl->IMemShared,
- proto_perl->IMemParse,
- proto_perl->IEnv,
- proto_perl->IStdIO,
- proto_perl->ILIO,
- proto_perl->IDir,
- proto_perl->ISock,
- proto_perl->IProc);
-}
+ PL_filemode = proto_perl->Ifilemode;
+ PL_lastfd = proto_perl->Ilastfd;
+ PL_oldname = proto_perl->Ioldname; /* XXX not quite right */
+ PL_Argv = NULL;
+ PL_Cmd = Nullch;
+ PL_gensym = proto_perl->Igensym;
+ PL_preambled = proto_perl->Ipreambled;
+ PL_preambleav = av_dup_inc(proto_perl->Ipreambleav, param);
+ PL_laststatval = proto_perl->Ilaststatval;
+ PL_laststype = proto_perl->Ilaststype;
+ PL_mess_sv = Nullsv;
-PerlInterpreter *
-perl_clone_using(PerlInterpreter *proto_perl, UV flags,
- struct IPerlMem* ipM, struct IPerlMem* ipMS,
- struct IPerlMem* ipMP, struct IPerlEnv* ipE,
- struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
- struct IPerlDir* ipD, struct IPerlSock* ipS,
- struct IPerlProc* ipP)
-{
- /* XXX many of the string copies here can be optimized if they're
- * constants; they need to be allocated as common memory and just
- * their pointers copied. */
+ PL_ors_sv = sv_dup_inc(proto_perl->Iors_sv, param);
+
+ /* interpreter atexit processing */
+ PL_exitlistlen = proto_perl->Iexitlistlen;
+ if (PL_exitlistlen) {
+ Newx(PL_exitlist, PL_exitlistlen, PerlExitListEntry);
+ Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
+ }
+ else
+ PL_exitlist = (PerlExitListEntry*)NULL;
+ PL_modglobal = hv_dup_inc(proto_perl->Imodglobal, param);
+ PL_custom_op_names = hv_dup_inc(proto_perl->Icustom_op_names,param);
+ PL_custom_op_descs = hv_dup_inc(proto_perl->Icustom_op_descs,param);
+
+ PL_profiledata = NULL;
+ PL_rsfp = fp_dup(proto_perl->Irsfp, '<', param);
+ /* PL_rsfp_filters entries have fake IoDIRP() */
+ PL_rsfp_filters = av_dup_inc(proto_perl->Irsfp_filters, param);
- IV i;
- CLONE_PARAMS clone_params;
- CLONE_PARAMS* param = &clone_params;
+ PL_compcv = cv_dup(proto_perl->Icompcv, param);
- PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
- /* for each stash, determine whether its objects should be cloned */
- S_visit(proto_perl, do_mark_cloneable_stash, SVt_PVHV, SVTYPEMASK);
- PERL_SET_THX(my_perl);
+ PAD_CLONE_VARS(proto_perl, param);
-# ifdef DEBUGGING
- Poison(my_perl, 1, PerlInterpreter);
- PL_op = Nullop;
- PL_curcop = (COP *)Nullop;
- PL_markstack = 0;
- PL_scopestack = 0;
- PL_savestack = 0;
- PL_savestack_ix = 0;
- PL_savestack_max = -1;
- PL_sig_pending = 0;
- Zero(&PL_debug_pad, 1, struct perl_debug_pad);
-# else /* !DEBUGGING */
- Zero(my_perl, 1, PerlInterpreter);
-# endif /* DEBUGGING */
+#ifdef HAVE_INTERP_INTERN
+ sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
+#endif
- /* host pointers */
- PL_Mem = ipM;
- PL_MemShared = ipMS;
- PL_MemParse = ipMP;
- PL_Env = ipE;
- PL_StdIO = ipStd;
- PL_LIO = ipLIO;
- PL_Dir = ipD;
- PL_Sock = ipS;
- PL_Proc = ipP;
-#else /* !PERL_IMPLICIT_SYS */
- IV i;
- CLONE_PARAMS clone_params;
- CLONE_PARAMS* param = &clone_params;
- PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
- /* for each stash, determine whether its objects should be cloned */
- S_visit(proto_perl, do_mark_cloneable_stash, SVt_PVHV, SVTYPEMASK);
- PERL_SET_THX(my_perl);
+ /* more statics moved here */
+ PL_generation = proto_perl->Igeneration;
+ PL_DBcv = cv_dup(proto_perl->IDBcv, param);
-# ifdef DEBUGGING
- Poison(my_perl, 1, PerlInterpreter);
- PL_op = Nullop;
- PL_curcop = (COP *)Nullop;
- PL_markstack = 0;
- PL_scopestack = 0;
- PL_savestack = 0;
- PL_savestack_ix = 0;
- PL_savestack_max = -1;
- PL_sig_pending = 0;
- Zero(&PL_debug_pad, 1, struct perl_debug_pad);
-# else /* !DEBUGGING */
- Zero(my_perl, 1, PerlInterpreter);
-# endif /* DEBUGGING */
-#endif /* PERL_IMPLICIT_SYS */
- param->flags = flags;
- param->proto_perl = proto_perl;
+ PL_in_clean_objs = proto_perl->Iin_clean_objs;
+ PL_in_clean_all = proto_perl->Iin_clean_all;
- /* 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;
+ PL_uid = proto_perl->Iuid;
+ PL_euid = proto_perl->Ieuid;
+ PL_gid = proto_perl->Igid;
+ PL_egid = proto_perl->Iegid;
+ PL_nomemok = proto_perl->Inomemok;
+ PL_an = proto_perl->Ian;
+ PL_evalseq = proto_perl->Ievalseq;
+ PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */
+ PL_origalen = proto_perl->Iorigalen;
+#ifdef PERL_USES_PL_PIDSTATUS
+ PL_pidstatus = newHV(); /* XXX flag for cloning? */
#endif
- PL_nice_chunk = NULL;
- PL_nice_chunk_size = 0;
- PL_sv_count = 0;
- PL_sv_objcount = 0;
- PL_sv_root = Nullsv;
- PL_sv_arenaroot = Nullsv;
+ PL_osname = SAVEPV(proto_perl->Iosname);
+ PL_sighandlerp = proto_perl->Isighandlerp;
- PL_debug = proto_perl->Idebug;
+ PL_runops = proto_perl->Irunops;
- PL_hash_seed = proto_perl->Ihash_seed;
- PL_rehash_seed = proto_perl->Irehash_seed;
+ Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char);
-#ifdef USE_REENTRANT_API
- /* XXX: things like -Dm will segfault here in perlio, but doing
- * PERL_SET_CONTEXT(proto_perl);
- * breaks too many other things
+#ifdef CSH
+ PL_cshlen = proto_perl->Icshlen;
+ PL_cshname = proto_perl->Icshname; /* XXX never deallocated */
+#endif
+
+ PL_lex_state = proto_perl->Ilex_state;
+ PL_lex_defer = proto_perl->Ilex_defer;
+ PL_lex_expect = proto_perl->Ilex_expect;
+ PL_lex_formbrack = proto_perl->Ilex_formbrack;
+ PL_lex_dojoin = proto_perl->Ilex_dojoin;
+ PL_lex_starts = proto_perl->Ilex_starts;
+ PL_lex_stuff = sv_dup_inc(proto_perl->Ilex_stuff, param);
+ PL_lex_repl = sv_dup_inc(proto_perl->Ilex_repl, param);
+ PL_lex_op = proto_perl->Ilex_op;
+ PL_lex_inpat = proto_perl->Ilex_inpat;
+ PL_lex_inwhat = proto_perl->Ilex_inwhat;
+ PL_lex_brackets = proto_perl->Ilex_brackets;
+ i = (PL_lex_brackets < 120 ? 120 : PL_lex_brackets);
+ PL_lex_brackstack = SAVEPVN(proto_perl->Ilex_brackstack,i);
+ PL_lex_casemods = proto_perl->Ilex_casemods;
+ i = (PL_lex_casemods < 12 ? 12 : PL_lex_casemods);
+ PL_lex_casestack = SAVEPVN(proto_perl->Ilex_casestack,i);
+
+ Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE);
+ Copy(proto_perl->Inexttype, PL_nexttype, 5, I32);
+ PL_nexttoke = proto_perl->Inexttoke;
+
+ /* XXX This is probably masking the deeper issue of why
+ * SvANY(proto_perl->Ilinestr) can be NULL at this point. For test case:
+ * http://archive.develooper.com/perl5-porters%40perl.org/msg83298.html
+ * (A little debugging with a watchpoint on it may help.)
*/
- Perl_reentrant_init(aTHX);
+ if (SvANY(proto_perl->Ilinestr)) {
+ PL_linestr = sv_dup_inc(proto_perl->Ilinestr, param);
+ i = proto_perl->Ibufptr - SvPVX_const(proto_perl->Ilinestr);
+ PL_bufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
+ i = proto_perl->Ioldbufptr - SvPVX_const(proto_perl->Ilinestr);
+ PL_oldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
+ i = proto_perl->Ioldoldbufptr - SvPVX_const(proto_perl->Ilinestr);
+ PL_oldoldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
+ i = proto_perl->Ilinestart - SvPVX_const(proto_perl->Ilinestr);
+ PL_linestart = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
+ }
+ else {
+ PL_linestr = NEWSV(65,79);
+ sv_upgrade(PL_linestr,SVt_PVIV);
+ sv_setpvn(PL_linestr,"",0);
+ PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
+ }
+ PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
+ PL_pending_ident = proto_perl->Ipending_ident;
+ PL_sublex_info = proto_perl->Isublex_info; /* XXX not quite right */
+
+ PL_expect = proto_perl->Iexpect;
+
+ PL_multi_start = proto_perl->Imulti_start;
+ PL_multi_end = proto_perl->Imulti_end;
+ PL_multi_open = proto_perl->Imulti_open;
+ PL_multi_close = proto_perl->Imulti_close;
+
+ PL_error_count = proto_perl->Ierror_count;
+ PL_subline = proto_perl->Isubline;
+ PL_subname = sv_dup_inc(proto_perl->Isubname, param);
+
+ /* XXX See comment on SvANY(proto_perl->Ilinestr) above */
+ if (SvANY(proto_perl->Ilinestr)) {
+ i = proto_perl->Ilast_uni - SvPVX_const(proto_perl->Ilinestr);
+ PL_last_uni = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
+ i = proto_perl->Ilast_lop - SvPVX_const(proto_perl->Ilinestr);
+ PL_last_lop = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
+ PL_last_lop_op = proto_perl->Ilast_lop_op;
+ }
+ else {
+ PL_last_uni = SvPVX(PL_linestr);
+ PL_last_lop = SvPVX(PL_linestr);
+ PL_last_lop_op = 0;
+ }
+ PL_in_my = proto_perl->Iin_my;
+ PL_in_my_stash = hv_dup(proto_perl->Iin_my_stash, param);
+#ifdef FCRYPT
+ PL_cryptseen = proto_perl->Icryptseen;
#endif
- /* create SV map for pointer relocation */
- PL_ptr_table = ptr_table_new();
+ PL_hints = proto_perl->Ihints;
- /* initialize these special pointers as early as possible */
- SvANY(&PL_sv_undef) = NULL;
- SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
- SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL;
- ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
+ PL_amagic_generation = proto_perl->Iamagic_generation;
- SvANY(&PL_sv_no) = new_XPVNV();
- SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
- SvFLAGS(&PL_sv_no) = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
- |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
- SvPV_set(&PL_sv_no, SAVEPVN(PL_No, 0));
- SvCUR_set(&PL_sv_no, 0);
- SvLEN_set(&PL_sv_no, 1);
- SvIV_set(&PL_sv_no, 0);
- SvNV_set(&PL_sv_no, 0);
- ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
+#ifdef USE_LOCALE_COLLATE
+ PL_collation_ix = proto_perl->Icollation_ix;
+ PL_collation_name = SAVEPV(proto_perl->Icollation_name);
+ PL_collation_standard = proto_perl->Icollation_standard;
+ PL_collxfrm_base = proto_perl->Icollxfrm_base;
+ PL_collxfrm_mult = proto_perl->Icollxfrm_mult;
+#endif /* USE_LOCALE_COLLATE */
- SvANY(&PL_sv_yes) = new_XPVNV();
- SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
- SvFLAGS(&PL_sv_yes) = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
- |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
- SvPV_set(&PL_sv_yes, SAVEPVN(PL_Yes, 1));
- SvCUR_set(&PL_sv_yes, 1);
- SvLEN_set(&PL_sv_yes, 2);
- SvIV_set(&PL_sv_yes, 1);
- SvNV_set(&PL_sv_yes, 1);
- ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
+#ifdef USE_LOCALE_NUMERIC
+ PL_numeric_name = SAVEPV(proto_perl->Inumeric_name);
+ PL_numeric_standard = proto_perl->Inumeric_standard;
+ PL_numeric_local = proto_perl->Inumeric_local;
+ PL_numeric_radix_sv = sv_dup_inc(proto_perl->Inumeric_radix_sv, param);
+#endif /* !USE_LOCALE_NUMERIC */
- /* create (a non-shared!) shared string table */
- PL_strtab = newHV();
- HvSHAREKEYS_off(PL_strtab);
- hv_ksplit(PL_strtab, HvTOTALKEYS(proto_perl->Istrtab));
- ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
+ /* utf8 character classes */
+ PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum, param);
+ PL_utf8_alnumc = sv_dup_inc(proto_perl->Iutf8_alnumc, param);
+ PL_utf8_ascii = sv_dup_inc(proto_perl->Iutf8_ascii, param);
+ PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha, param);
+ PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space, param);
+ PL_utf8_cntrl = sv_dup_inc(proto_perl->Iutf8_cntrl, param);
+ PL_utf8_graph = sv_dup_inc(proto_perl->Iutf8_graph, param);
+ PL_utf8_digit = sv_dup_inc(proto_perl->Iutf8_digit, param);
+ PL_utf8_upper = sv_dup_inc(proto_perl->Iutf8_upper, param);
+ PL_utf8_lower = sv_dup_inc(proto_perl->Iutf8_lower, param);
+ PL_utf8_print = sv_dup_inc(proto_perl->Iutf8_print, param);
+ PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct, param);
+ PL_utf8_xdigit = sv_dup_inc(proto_perl->Iutf8_xdigit, param);
+ PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark, param);
+ PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper, param);
+ PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle, param);
+ PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower, param);
+ PL_utf8_tofold = sv_dup_inc(proto_perl->Iutf8_tofold, param);
+ PL_utf8_idstart = sv_dup_inc(proto_perl->Iutf8_idstart, param);
+ PL_utf8_idcont = sv_dup_inc(proto_perl->Iutf8_idcont, param);
- PL_compiling = proto_perl->Icompiling;
+ /* Did the locale setup indicate UTF-8? */
+ PL_utf8locale = proto_perl->Iutf8locale;
+ /* Unicode features (see perlrun/-C) */
+ PL_unicode = proto_perl->Iunicode;
- /* These two PVs will be free'd special way so must set them same way op.c does */
- PL_compiling.cop_stashpv = savesharedpv(PL_compiling.cop_stashpv);
- ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_stashpv, PL_compiling.cop_stashpv);
+ /* Pre-5.8 signals control */
+ PL_signals = proto_perl->Isignals;
+
+ /* times() ticks per second */
+ PL_clocktick = proto_perl->Iclocktick;
- PL_compiling.cop_file = savesharedpv(PL_compiling.cop_file);
- ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_file, PL_compiling.cop_file);
+ /* Recursion stopper for PerlIO_find_layer */
+ PL_in_load_module = proto_perl->Iin_load_module;
- ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
- if (!specialWARN(PL_compiling.cop_warnings))
- PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings, param);
- if (!specialCopIO(PL_compiling.cop_io))
- PL_compiling.cop_io = sv_dup_inc(PL_compiling.cop_io, param);
- PL_curcop = (COP*)any_dup(proto_perl->Tcurcop, proto_perl);
+ /* sort() routine */
+ PL_sort_RealCmp = proto_perl->Isort_RealCmp;
- /* pseudo environmental stuff */
- PL_origargc = proto_perl->Iorigargc;
- PL_origargv = proto_perl->Iorigargv;
+ /* Not really needed/useful since the reenrant_retint is "volatile",
+ * but do it for consistency's sake. */
+ PL_reentrant_retint = proto_perl->Ireentrant_retint;
- param->stashes = newAV(); /* Setup array of objects to call clone on */
+ /* Hooks to shared SVs and locks. */
+ PL_sharehook = proto_perl->Isharehook;
+ PL_lockhook = proto_perl->Ilockhook;
+ PL_unlockhook = proto_perl->Iunlockhook;
+ PL_threadhook = proto_perl->Ithreadhook;
-#ifdef PERLIO_LAYERS
- /* Clone PerlIO tables as soon as we can handle general xx_dup() */
- PerlIO_clone(aTHX_ proto_perl, param);
+ PL_runops_std = proto_perl->Irunops_std;
+ PL_runops_dbg = proto_perl->Irunops_dbg;
+
+#ifdef THREADS_HAVE_PIDS
+ PL_ppid = proto_perl->Ippid;
#endif
- PL_envgv = gv_dup(proto_perl->Ienvgv, param);
- PL_incgv = gv_dup(proto_perl->Iincgv, param);
- PL_hintgv = gv_dup(proto_perl->Ihintgv, param);
- PL_origfilename = SAVEPV(proto_perl->Iorigfilename);
- PL_diehook = sv_dup_inc(proto_perl->Idiehook, param);
- PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook, param);
+ /* swatch cache */
+ PL_last_swash_hv = NULL; /* reinits on demand */
+ PL_last_swash_klen = 0;
+ PL_last_swash_key[0]= '\0';
+ PL_last_swash_tmps = (U8*)NULL;
+ PL_last_swash_slen = 0;
- /* switches */
- PL_minus_c = proto_perl->Iminus_c;
- PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel, param);
- PL_localpatches = proto_perl->Ilocalpatches;
- PL_splitstr = proto_perl->Isplitstr;
- PL_preprocess = proto_perl->Ipreprocess;
- PL_minus_n = proto_perl->Iminus_n;
- PL_minus_p = proto_perl->Iminus_p;
- PL_minus_l = proto_perl->Iminus_l;
- PL_minus_a = proto_perl->Iminus_a;
- PL_minus_F = proto_perl->Iminus_F;
- PL_doswitches = proto_perl->Idoswitches;
- PL_dowarn = proto_perl->Idowarn;
- PL_doextract = proto_perl->Idoextract;
- PL_sawampersand = proto_perl->Isawampersand;
- PL_unsafe = proto_perl->Iunsafe;
- PL_inplace = SAVEPV(proto_perl->Iinplace);
- PL_e_script = sv_dup_inc(proto_perl->Ie_script, param);
- PL_perldb = proto_perl->Iperldb;
- PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
- PL_exit_flags = proto_perl->Iexit_flags;
+ PL_glob_index = proto_perl->Iglob_index;
+ PL_srand_called = proto_perl->Isrand_called;
+ PL_uudmap['M'] = 0; /* reinits on demand */
+ PL_bitcount = Nullch; /* reinits on demand */
- /* magical thingies */
- /* XXX time(&PL_basetime) when asked for? */
- PL_basetime = proto_perl->Ibasetime;
- PL_formfeed = sv_dup(proto_perl->Iformfeed, param);
+ if (proto_perl->Ipsig_pend) {
+ Newxz(PL_psig_pend, SIG_SIZE, int);
+ }
+ else {
+ PL_psig_pend = (int*)NULL;
+ }
- PL_maxsysfd = proto_perl->Imaxsysfd;
- PL_multiline = proto_perl->Imultiline;
- PL_statusvalue = proto_perl->Istatusvalue;
-#ifdef VMS
- PL_statusvalue_vms = proto_perl->Istatusvalue_vms;
-#endif
- PL_encoding = sv_dup(proto_perl->Iencoding, param);
+ if (proto_perl->Ipsig_ptr) {
+ Newxz(PL_psig_ptr, SIG_SIZE, SV*);
+ Newxz(PL_psig_name, SIG_SIZE, SV*);
+ for (i = 1; i < SIG_SIZE; i++) {
+ PL_psig_ptr[i] = sv_dup_inc(proto_perl->Ipsig_ptr[i], param);
+ PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i], param);
+ }
+ }
+ else {
+ PL_psig_ptr = (SV**)NULL;
+ PL_psig_name = (SV**)NULL;
+ }
- sv_setpvn(PERL_DEBUG_PAD(0), "", 0); /* For regex debugging. */
- sv_setpvn(PERL_DEBUG_PAD(1), "", 0); /* ext/re needs these */
- sv_setpvn(PERL_DEBUG_PAD(2), "", 0); /* even without DEBUGGING. */
+ /* thrdvar.h stuff */
- /* Clone the regex array */
- PL_regex_padav = newAV();
- {
- const I32 len = av_len((AV*)proto_perl->Iregex_padav);
- SV** regexen = AvARRAY((AV*)proto_perl->Iregex_padav);
- IV i;
- av_push(PL_regex_padav,
- sv_dup_inc(regexen[0],param));
- for(i = 1; i <= len; i++) {
- if(SvREPADTMP(regexen[i])) {
- av_push(PL_regex_padav, sv_dup_inc(regexen[i], param));
- } else {
- av_push(PL_regex_padav,
- SvREFCNT_inc(
- newSViv(PTR2IV(re_dup(INT2PTR(REGEXP *,
- SvIVX(regexen[i])), param)))
- ));
- }
+ if (flags & CLONEf_COPY_STACKS) {
+ /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
+ PL_tmps_ix = proto_perl->Ttmps_ix;
+ PL_tmps_max = proto_perl->Ttmps_max;
+ PL_tmps_floor = proto_perl->Ttmps_floor;
+ Newxz(PL_tmps_stack, PL_tmps_max, SV*);
+ i = 0;
+ while (i <= PL_tmps_ix) {
+ PL_tmps_stack[i] = sv_dup_inc(proto_perl->Ttmps_stack[i], param);
+ ++i;
}
- }
- PL_regex_pad = AvARRAY(PL_regex_padav);
- /* shortcuts to various I/O objects */
- PL_stdingv = gv_dup(proto_perl->Istdingv, param);
- PL_stderrgv = gv_dup(proto_perl->Istderrgv, param);
- PL_defgv = gv_dup(proto_perl->Idefgv, param);
- PL_argvgv = gv_dup(proto_perl->Iargvgv, param);
- PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv, param);
- PL_argvout_stack = av_dup_inc(proto_perl->Iargvout_stack, param);
+ /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
+ i = proto_perl->Tmarkstack_max - proto_perl->Tmarkstack;
+ Newxz(PL_markstack, i, I32);
+ PL_markstack_max = PL_markstack + (proto_perl->Tmarkstack_max
+ - proto_perl->Tmarkstack);
+ PL_markstack_ptr = PL_markstack + (proto_perl->Tmarkstack_ptr
+ - proto_perl->Tmarkstack);
+ Copy(proto_perl->Tmarkstack, PL_markstack,
+ PL_markstack_ptr - PL_markstack + 1, I32);
- /* shortcuts to regexp stuff */
- PL_replgv = gv_dup(proto_perl->Ireplgv, param);
+ /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
+ * NOTE: unlike the others! */
+ PL_scopestack_ix = proto_perl->Tscopestack_ix;
+ PL_scopestack_max = proto_perl->Tscopestack_max;
+ Newxz(PL_scopestack, PL_scopestack_max, I32);
+ Copy(proto_perl->Tscopestack, PL_scopestack, PL_scopestack_ix, I32);
- /* shortcuts to misc objects */
- PL_errgv = gv_dup(proto_perl->Ierrgv, param);
+ /* NOTE: si_dup() looks at PL_markstack */
+ PL_curstackinfo = si_dup(proto_perl->Tcurstackinfo, param);
- /* shortcuts to debugging objects */
- PL_DBgv = gv_dup(proto_perl->IDBgv, param);
- PL_DBline = gv_dup(proto_perl->IDBline, param);
- PL_DBsub = gv_dup(proto_perl->IDBsub, param);
- PL_DBsingle = sv_dup(proto_perl->IDBsingle, param);
- PL_DBtrace = sv_dup(proto_perl->IDBtrace, param);
- PL_DBsignal = sv_dup(proto_perl->IDBsignal, param);
- PL_DBassertion = sv_dup(proto_perl->IDBassertion, param);
- PL_lineary = av_dup(proto_perl->Ilineary, param);
- PL_dbargs = av_dup(proto_perl->Idbargs, param);
+ /* PL_curstack = PL_curstackinfo->si_stack; */
+ PL_curstack = av_dup(proto_perl->Tcurstack, param);
+ PL_mainstack = av_dup(proto_perl->Tmainstack, param);
- /* symbol tables */
- PL_defstash = hv_dup_inc(proto_perl->Tdefstash, param);
- PL_curstash = hv_dup(proto_perl->Tcurstash, param);
- PL_debstash = hv_dup(proto_perl->Idebstash, param);
- PL_globalstash = hv_dup(proto_perl->Iglobalstash, param);
- PL_curstname = sv_dup_inc(proto_perl->Icurstname, param);
+ /* next PUSHs() etc. set *(PL_stack_sp+1) */
+ PL_stack_base = AvARRAY(PL_curstack);
+ PL_stack_sp = PL_stack_base + (proto_perl->Tstack_sp
+ - proto_perl->Tstack_base);
+ PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
- PL_beginav = av_dup_inc(proto_perl->Ibeginav, param);
- PL_beginav_save = av_dup_inc(proto_perl->Ibeginav_save, param);
- PL_checkav_save = av_dup_inc(proto_perl->Icheckav_save, param);
- PL_endav = av_dup_inc(proto_perl->Iendav, param);
- PL_checkav = av_dup_inc(proto_perl->Icheckav, param);
- PL_initav = av_dup_inc(proto_perl->Iinitav, param);
+ /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
+ * NOTE: unlike the others! */
+ PL_savestack_ix = proto_perl->Tsavestack_ix;
+ PL_savestack_max = proto_perl->Tsavestack_max;
+ /*Newxz(PL_savestack, PL_savestack_max, ANY);*/
+ PL_savestack = ss_dup(proto_perl, param);
+ }
+ else {
+ init_stacks();
+ ENTER; /* perl_destruct() wants to LEAVE; */
+ }
- PL_sub_generation = proto_perl->Isub_generation;
+ PL_start_env = proto_perl->Tstart_env; /* XXXXXX */
+ PL_top_env = &PL_start_env;
- /* funky return mechanisms */
- PL_forkprocess = proto_perl->Iforkprocess;
+ PL_op = proto_perl->Top;
- /* subprocess state */
- PL_fdpid = av_dup_inc(proto_perl->Ifdpid, param);
+ PL_Sv = Nullsv;
+ PL_Xpv = (XPV*)NULL;
+ PL_na = proto_perl->Tna;
- /* 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);
- else
- PL_op_mask = Nullch;
- /* PL_asserting = proto_perl->Iasserting; */
+ PL_statbuf = proto_perl->Tstatbuf;
+ PL_statcache = proto_perl->Tstatcache;
+ PL_statgv = gv_dup(proto_perl->Tstatgv, param);
+ PL_statname = sv_dup_inc(proto_perl->Tstatname, param);
+#ifdef HAS_TIMES
+ PL_timesbuf = proto_perl->Ttimesbuf;
+#endif
- /* current interpreter roots */
- PL_main_cv = cv_dup_inc(proto_perl->Imain_cv, param);
- PL_main_root = OpREFCNT_inc(proto_perl->Imain_root);
- PL_main_start = proto_perl->Imain_start;
- PL_eval_root = proto_perl->Ieval_root;
- PL_eval_start = proto_perl->Ieval_start;
+ PL_tainted = proto_perl->Ttainted;
+ PL_curpm = proto_perl->Tcurpm; /* XXX No PMOP ref count */
+ PL_rs = sv_dup_inc(proto_perl->Trs, param);
+ PL_last_in_gv = gv_dup(proto_perl->Tlast_in_gv, param);
+ PL_ofs_sv = sv_dup_inc(proto_perl->Tofs_sv, param);
+ PL_defoutgv = gv_dup_inc(proto_perl->Tdefoutgv, param);
+ PL_chopset = proto_perl->Tchopset; /* XXX never deallocated */
+ PL_toptarget = sv_dup_inc(proto_perl->Ttoptarget, param);
+ PL_bodytarget = sv_dup_inc(proto_perl->Tbodytarget, param);
+ PL_formtarget = sv_dup(proto_perl->Tformtarget, param);
- /* runtime control stuff */
- PL_curcopdb = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
- PL_copline = proto_perl->Icopline;
+ PL_restartop = proto_perl->Trestartop;
+ PL_in_eval = proto_perl->Tin_eval;
+ PL_delaymagic = proto_perl->Tdelaymagic;
+ PL_dirty = proto_perl->Tdirty;
+ PL_localizing = proto_perl->Tlocalizing;
+
+ PL_errors = sv_dup_inc(proto_perl->Terrors, param);
+ PL_hv_fetch_ent_mh = Nullhe;
+ PL_modcount = proto_perl->Tmodcount;
+ PL_lastgotoprobe = Nullop;
+ PL_dumpindent = proto_perl->Tdumpindent;
+
+ PL_sortcop = (OP*)any_dup(proto_perl->Tsortcop, proto_perl);
+ PL_sortstash = hv_dup(proto_perl->Tsortstash, param);
+ PL_firstgv = gv_dup(proto_perl->Tfirstgv, param);
+ PL_secondgv = gv_dup(proto_perl->Tsecondgv, param);
+ PL_efloatbuf = Nullch; /* reinits on demand */
+ PL_efloatsize = 0; /* reinits on demand */
+
+ /* regex stuff */
- PL_filemode = proto_perl->Ifilemode;
- PL_lastfd = proto_perl->Ilastfd;
- PL_oldname = proto_perl->Ioldname; /* XXX not quite right */
- PL_Argv = NULL;
- PL_Cmd = Nullch;
- PL_gensym = proto_perl->Igensym;
- PL_preambled = proto_perl->Ipreambled;
- PL_preambleav = av_dup_inc(proto_perl->Ipreambleav, param);
- PL_laststatval = proto_perl->Ilaststatval;
- PL_laststype = proto_perl->Ilaststype;
- PL_mess_sv = Nullsv;
+ PL_screamfirst = NULL;
+ PL_screamnext = NULL;
+ PL_maxscream = -1; /* reinits on demand */
+ PL_lastscream = Nullsv;
- PL_ors_sv = sv_dup_inc(proto_perl->Iors_sv, param);
- PL_ofmt = SAVEPV(proto_perl->Iofmt);
+ PL_watchaddr = NULL;
+ PL_watchok = Nullch;
- /* interpreter atexit processing */
- PL_exitlistlen = proto_perl->Iexitlistlen;
- if (PL_exitlistlen) {
- New(0, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
- Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
- }
- else
- PL_exitlist = (PerlExitListEntry*)NULL;
- PL_modglobal = hv_dup_inc(proto_perl->Imodglobal, param);
- PL_custom_op_names = hv_dup_inc(proto_perl->Icustom_op_names,param);
- PL_custom_op_descs = hv_dup_inc(proto_perl->Icustom_op_descs,param);
+ PL_regdummy = proto_perl->Tregdummy;
+ PL_regprecomp = Nullch;
+ PL_regnpar = 0;
+ PL_regsize = 0;
+ PL_colorset = 0; /* reinits PL_colors[] */
+ /*PL_colors[6] = {0,0,0,0,0,0};*/
+ PL_reginput = Nullch;
+ PL_regbol = Nullch;
+ PL_regeol = Nullch;
+ PL_regstartp = (I32*)NULL;
+ PL_regendp = (I32*)NULL;
+ PL_reglastparen = (U32*)NULL;
+ PL_reglastcloseparen = (U32*)NULL;
+ PL_regtill = Nullch;
+ PL_reg_start_tmp = (char**)NULL;
+ PL_reg_start_tmpl = 0;
+ PL_regdata = (struct reg_data*)NULL;
+ PL_bostr = Nullch;
+ PL_reg_flags = 0;
+ PL_reg_eval_set = 0;
+ PL_regnarrate = 0;
+ PL_regprogram = (regnode*)NULL;
+ PL_regindent = 0;
+ PL_regcc = (CURCUR*)NULL;
+ PL_reg_call_cc = (struct re_cc_state*)NULL;
+ PL_reg_re = (regexp*)NULL;
+ PL_reg_ganch = Nullch;
+ PL_reg_sv = Nullsv;
+ PL_reg_match_utf8 = FALSE;
+ PL_reg_magic = (MAGIC*)NULL;
+ PL_reg_oldpos = 0;
+ PL_reg_oldcurpm = (PMOP*)NULL;
+ PL_reg_curpm = (PMOP*)NULL;
+ PL_reg_oldsaved = Nullch;
+ PL_reg_oldsavedlen = 0;
+#ifdef PERL_OLD_COPY_ON_WRITE
+ PL_nrs = Nullsv;
+#endif
+ PL_reg_maxiter = 0;
+ PL_reg_leftiter = 0;
+ PL_reg_poscache = Nullch;
+ PL_reg_poscache_size= 0;
- PL_profiledata = NULL;
- PL_rsfp = fp_dup(proto_perl->Irsfp, '<', param);
- /* PL_rsfp_filters entries have fake IoDIRP() */
- PL_rsfp_filters = av_dup_inc(proto_perl->Irsfp_filters, param);
+ /* RE engine - function pointers */
+ PL_regcompp = proto_perl->Tregcompp;
+ PL_regexecp = proto_perl->Tregexecp;
+ PL_regint_start = proto_perl->Tregint_start;
+ PL_regint_string = proto_perl->Tregint_string;
+ PL_regfree = proto_perl->Tregfree;
- PL_compcv = cv_dup(proto_perl->Icompcv, param);
+ PL_reginterp_cnt = 0;
+ PL_reg_starttry = 0;
- PAD_CLONE_VARS(proto_perl, param);
+ /* Pluggable optimizer */
+ PL_peepp = proto_perl->Tpeepp;
-#ifdef HAVE_INTERP_INTERN
- sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
-#endif
+ PL_stashcache = newHV();
- /* more statics moved here */
- PL_generation = proto_perl->Igeneration;
- PL_DBcv = cv_dup(proto_perl->IDBcv, param);
+ if (!(flags & CLONEf_KEEP_PTR_TABLE)) {
+ ptr_table_free(PL_ptr_table);
+ PL_ptr_table = NULL;
+ }
- PL_in_clean_objs = proto_perl->Iin_clean_objs;
- PL_in_clean_all = proto_perl->Iin_clean_all;
+ /* Call the ->CLONE method, if it exists, for each of the stashes
+ identified by sv_dup() above.
+ */
+ while(av_len(param->stashes) != -1) {
+ HV* const stash = (HV*) av_shift(param->stashes);
+ GV* const cloner = gv_fetchmethod_autoload(stash, "CLONE", 0);
+ if (cloner && GvCV(cloner)) {
+ dSP;
+ ENTER;
+ SAVETMPS;
+ PUSHMARK(SP);
+ XPUSHs(sv_2mortal(newSVhek(HvNAME_HEK(stash))));
+ PUTBACK;
+ call_sv((SV*)GvCV(cloner), G_DISCARD);
+ FREETMPS;
+ LEAVE;
+ }
+ }
- PL_uid = proto_perl->Iuid;
- PL_euid = proto_perl->Ieuid;
- PL_gid = proto_perl->Igid;
- PL_egid = proto_perl->Iegid;
- PL_nomemok = proto_perl->Inomemok;
- PL_an = proto_perl->Ian;
- PL_evalseq = proto_perl->Ievalseq;
- PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */
- PL_origalen = proto_perl->Iorigalen;
- PL_pidstatus = newHV(); /* XXX flag for cloning? */
- PL_osname = SAVEPV(proto_perl->Iosname);
- PL_sh_path_compat = proto_perl->Ish_path_compat; /* XXX never deallocated */
- PL_sighandlerp = proto_perl->Isighandlerp;
+ SvREFCNT_dec(param->stashes);
+ /* orphaned? eg threads->new inside BEGIN or use */
+ if (PL_compcv && ! SvREFCNT(PL_compcv)) {
+ (void)SvREFCNT_inc(PL_compcv);
+ SAVEFREESV(PL_compcv);
+ }
- PL_runops = proto_perl->Irunops;
+ return my_perl;
+}
- Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char);
+#endif /* USE_ITHREADS */
-#ifdef CSH
- PL_cshlen = proto_perl->Icshlen;
- PL_cshname = proto_perl->Icshname; /* XXX never deallocated */
-#endif
+/*
+=head1 Unicode Support
- PL_lex_state = proto_perl->Ilex_state;
- PL_lex_defer = proto_perl->Ilex_defer;
- PL_lex_expect = proto_perl->Ilex_expect;
- PL_lex_formbrack = proto_perl->Ilex_formbrack;
- PL_lex_dojoin = proto_perl->Ilex_dojoin;
- PL_lex_starts = proto_perl->Ilex_starts;
- PL_lex_stuff = sv_dup_inc(proto_perl->Ilex_stuff, param);
- PL_lex_repl = sv_dup_inc(proto_perl->Ilex_repl, param);
- PL_lex_op = proto_perl->Ilex_op;
- PL_lex_inpat = proto_perl->Ilex_inpat;
- PL_lex_inwhat = proto_perl->Ilex_inwhat;
- PL_lex_brackets = proto_perl->Ilex_brackets;
- i = (PL_lex_brackets < 120 ? 120 : PL_lex_brackets);
- PL_lex_brackstack = SAVEPVN(proto_perl->Ilex_brackstack,i);
- PL_lex_casemods = proto_perl->Ilex_casemods;
- i = (PL_lex_casemods < 12 ? 12 : PL_lex_casemods);
- PL_lex_casestack = SAVEPVN(proto_perl->Ilex_casestack,i);
+=for apidoc sv_recode_to_utf8
- Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE);
- Copy(proto_perl->Inexttype, PL_nexttype, 5, I32);
- PL_nexttoke = proto_perl->Inexttoke;
+The encoding is assumed to be an Encode object, on entry the PV
+of the sv is assumed to be octets in that encoding, and the sv
+will be converted into Unicode (and UTF-8).
- /* XXX This is probably masking the deeper issue of why
- * SvANY(proto_perl->Ilinestr) can be NULL at this point. For test case:
- * http://archive.develooper.com/perl5-porters%40perl.org/msg83298.html
- * (A little debugging with a watchpoint on it may help.)
- */
- if (SvANY(proto_perl->Ilinestr)) {
- PL_linestr = sv_dup_inc(proto_perl->Ilinestr, param);
- i = proto_perl->Ibufptr - SvPVX_const(proto_perl->Ilinestr);
- PL_bufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
- i = proto_perl->Ioldbufptr - SvPVX_const(proto_perl->Ilinestr);
- PL_oldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
- i = proto_perl->Ioldoldbufptr - SvPVX_const(proto_perl->Ilinestr);
- PL_oldoldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
- i = proto_perl->Ilinestart - SvPVX_const(proto_perl->Ilinestr);
- PL_linestart = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
- }
- else {
- PL_linestr = NEWSV(65,79);
- sv_upgrade(PL_linestr,SVt_PVIV);
- sv_setpvn(PL_linestr,"",0);
- PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
- }
- PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
- PL_pending_ident = proto_perl->Ipending_ident;
- PL_sublex_info = proto_perl->Isublex_info; /* XXX not quite right */
+If the sv already is UTF-8 (or if it is not POK), or if the encoding
+is not a reference, nothing is done to the sv. If the encoding is not
+an C<Encode::XS> Encoding object, bad things will happen.
+(See F<lib/encoding.pm> and L<Encode>).
- PL_expect = proto_perl->Iexpect;
+The PV of the sv is returned.
- PL_multi_start = proto_perl->Imulti_start;
- PL_multi_end = proto_perl->Imulti_end;
- PL_multi_open = proto_perl->Imulti_open;
- PL_multi_close = proto_perl->Imulti_close;
+=cut */
- PL_error_count = proto_perl->Ierror_count;
- PL_subline = proto_perl->Isubline;
- PL_subname = sv_dup_inc(proto_perl->Isubname, param);
+char *
+Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding)
+{
+ dVAR;
+ if (SvPOK(sv) && !SvUTF8(sv) && !IN_BYTES && SvROK(encoding)) {
+ SV *uni;
+ STRLEN len;
+ const char *s;
+ dSP;
+ ENTER;
+ SAVETMPS;
+ save_re_context();
+ PUSHMARK(sp);
+ EXTEND(SP, 3);
+ XPUSHs(encoding);
+ XPUSHs(sv);
+/*
+ NI-S 2002/07/09
+ Passing sv_yes is wrong - it needs to be or'ed set of constants
+ for Encode::XS, while UTf-8 decode (currently) assumes a true value means
+ remove converted chars from source.
- /* XXX See comment on SvANY(proto_perl->Ilinestr) above */
- if (SvANY(proto_perl->Ilinestr)) {
- i = proto_perl->Ilast_uni - SvPVX_const(proto_perl->Ilinestr);
- PL_last_uni = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
- i = proto_perl->Ilast_lop - SvPVX_const(proto_perl->Ilinestr);
- PL_last_lop = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
- PL_last_lop_op = proto_perl->Ilast_lop_op;
- }
- else {
- PL_last_uni = SvPVX(PL_linestr);
- PL_last_lop = SvPVX(PL_linestr);
- PL_last_lop_op = 0;
+ Both will default the value - let them.
+
+ XPUSHs(&PL_sv_yes);
+*/
+ PUTBACK;
+ call_method("decode", G_SCALAR);
+ SPAGAIN;
+ uni = POPs;
+ PUTBACK;
+ s = SvPV_const(uni, len);
+ if (s != SvPVX_const(sv)) {
+ SvGROW(sv, len + 1);
+ Move(s, SvPVX(sv), len + 1, char);
+ SvCUR_set(sv, len);
+ }
+ FREETMPS;
+ LEAVE;
+ SvUTF8_on(sv);
+ return SvPVX(sv);
}
- PL_in_my = proto_perl->Iin_my;
- PL_in_my_stash = hv_dup(proto_perl->Iin_my_stash, param);
-#ifdef FCRYPT
- PL_cryptseen = proto_perl->Icryptseen;
-#endif
+ return SvPOKp(sv) ? SvPVX(sv) : NULL;
+}
- PL_hints = proto_perl->Ihints;
+/*
+=for apidoc sv_cat_decode
- PL_amagic_generation = proto_perl->Iamagic_generation;
+The encoding is assumed to be an Encode object, the PV of the ssv is
+assumed to be octets in that encoding and decoding the input starts
+from the position which (PV + *offset) pointed to. The dsv will be
+concatenated the decoded UTF-8 string from ssv. Decoding will terminate
+when the string tstr appears in decoding output or the input ends on
+the PV of the ssv. The value which the offset points will be modified
+to the last input position on the ssv.
-#ifdef USE_LOCALE_COLLATE
- PL_collation_ix = proto_perl->Icollation_ix;
- PL_collation_name = SAVEPV(proto_perl->Icollation_name);
- PL_collation_standard = proto_perl->Icollation_standard;
- PL_collxfrm_base = proto_perl->Icollxfrm_base;
- PL_collxfrm_mult = proto_perl->Icollxfrm_mult;
-#endif /* USE_LOCALE_COLLATE */
+Returns TRUE if the terminator was found, else returns FALSE.
-#ifdef USE_LOCALE_NUMERIC
- PL_numeric_name = SAVEPV(proto_perl->Inumeric_name);
- PL_numeric_standard = proto_perl->Inumeric_standard;
- PL_numeric_local = proto_perl->Inumeric_local;
- PL_numeric_radix_sv = sv_dup_inc(proto_perl->Inumeric_radix_sv, param);
-#endif /* !USE_LOCALE_NUMERIC */
+=cut */
- /* utf8 character classes */
- PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum, param);
- PL_utf8_alnumc = sv_dup_inc(proto_perl->Iutf8_alnumc, param);
- PL_utf8_ascii = sv_dup_inc(proto_perl->Iutf8_ascii, param);
- PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha, param);
- PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space, param);
- PL_utf8_cntrl = sv_dup_inc(proto_perl->Iutf8_cntrl, param);
- PL_utf8_graph = sv_dup_inc(proto_perl->Iutf8_graph, param);
- PL_utf8_digit = sv_dup_inc(proto_perl->Iutf8_digit, param);
- PL_utf8_upper = sv_dup_inc(proto_perl->Iutf8_upper, param);
- PL_utf8_lower = sv_dup_inc(proto_perl->Iutf8_lower, param);
- PL_utf8_print = sv_dup_inc(proto_perl->Iutf8_print, param);
- PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct, param);
- PL_utf8_xdigit = sv_dup_inc(proto_perl->Iutf8_xdigit, param);
- PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark, param);
- PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper, param);
- PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle, param);
- PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower, param);
- PL_utf8_tofold = sv_dup_inc(proto_perl->Iutf8_tofold, param);
- PL_utf8_idstart = sv_dup_inc(proto_perl->Iutf8_idstart, param);
- PL_utf8_idcont = sv_dup_inc(proto_perl->Iutf8_idcont, param);
+bool
+Perl_sv_cat_decode(pTHX_ SV *dsv, SV *encoding,
+ SV *ssv, int *offset, char *tstr, int tlen)
+{
+ dVAR;
+ bool ret = FALSE;
+ if (SvPOK(ssv) && SvPOK(dsv) && SvROK(encoding) && offset) {
+ SV *offsv;
+ dSP;
+ ENTER;
+ SAVETMPS;
+ save_re_context();
+ PUSHMARK(sp);
+ EXTEND(SP, 6);
+ XPUSHs(encoding);
+ XPUSHs(dsv);
+ XPUSHs(ssv);
+ XPUSHs(offsv = sv_2mortal(newSViv(*offset)));
+ XPUSHs(sv_2mortal(newSVpvn(tstr, tlen)));
+ PUTBACK;
+ call_method("cat_decode", G_SCALAR);
+ SPAGAIN;
+ ret = SvTRUE(TOPs);
+ *offset = SvIV(offsv);
+ PUTBACK;
+ FREETMPS;
+ LEAVE;
+ }
+ else
+ Perl_croak(aTHX_ "Invalid argument to sv_cat_decode");
+ return ret;
- /* Did the locale setup indicate UTF-8? */
- PL_utf8locale = proto_perl->Iutf8locale;
- /* Unicode features (see perlrun/-C) */
- PL_unicode = proto_perl->Iunicode;
+}
- /* Pre-5.8 signals control */
- PL_signals = proto_perl->Isignals;
+/* ---------------------------------------------------------------------
+ *
+ * support functions for report_uninit()
+ */
- /* times() ticks per second */
- PL_clocktick = proto_perl->Iclocktick;
+/* the maxiumum size of array or hash where we will scan looking
+ * for the undefined element that triggered the warning */
- /* Recursion stopper for PerlIO_find_layer */
- PL_in_load_module = proto_perl->Iin_load_module;
+#define FUV_MAX_SEARCH_SIZE 1000
- /* sort() routine */
- PL_sort_RealCmp = proto_perl->Isort_RealCmp;
+/* Look for an entry in the hash whose value has the same SV as val;
+ * If so, return a mortal copy of the key. */
- /* Not really needed/useful since the reenrant_retint is "volatile",
- * but do it for consistency's sake. */
- PL_reentrant_retint = proto_perl->Ireentrant_retint;
+STATIC SV*
+S_find_hash_subscript(pTHX_ HV *hv, SV* val)
+{
+ dVAR;
+ register HE **array;
+ I32 i;
- /* Hooks to shared SVs and locks. */
- PL_sharehook = proto_perl->Isharehook;
- PL_lockhook = proto_perl->Ilockhook;
- PL_unlockhook = proto_perl->Iunlockhook;
- PL_threadhook = proto_perl->Ithreadhook;
+ if (!hv || SvMAGICAL(hv) || !HvARRAY(hv) ||
+ (HvTOTALKEYS(hv) > FUV_MAX_SEARCH_SIZE))
+ return Nullsv;
- PL_runops_std = proto_perl->Irunops_std;
- PL_runops_dbg = proto_perl->Irunops_dbg;
+ array = HvARRAY(hv);
-#ifdef THREADS_HAVE_PIDS
- PL_ppid = proto_perl->Ippid;
-#endif
+ 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;
+}
- /* swatch cache */
- PL_last_swash_hv = Nullhv; /* reinits on demand */
- PL_last_swash_klen = 0;
- PL_last_swash_key[0]= '\0';
- PL_last_swash_tmps = (U8*)NULL;
- PL_last_swash_slen = 0;
+/* Look for an entry in the array whose value has the same SV as val;
+ * If so, return the index, otherwise return -1. */
- PL_glob_index = proto_perl->Iglob_index;
- PL_srand_called = proto_perl->Isrand_called;
- PL_uudmap['M'] = 0; /* reinits on demand */
- PL_bitcount = Nullch; /* reinits on demand */
+STATIC 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;
- if (proto_perl->Ipsig_pend) {
- Newz(0, PL_psig_pend, SIG_SIZE, int);
- }
- else {
- PL_psig_pend = (int*)NULL;
+ svp = AvARRAY(av);
+ for (i=AvFILLp(av); i>=0; i--) {
+ if (svp[i] == val && svp[i] != &PL_sv_undef)
+ return i;
}
+ return -1;
+}
- if (proto_perl->Ipsig_ptr) {
- Newz(0, PL_psig_ptr, SIG_SIZE, SV*);
- Newz(0, PL_psig_name, SIG_SIZE, SV*);
- for (i = 1; i < SIG_SIZE; i++) {
- PL_psig_ptr[i] = sv_dup_inc(proto_perl->Ipsig_ptr[i], param);
- PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i], param);
- }
- }
- else {
- PL_psig_ptr = (SV**)NULL;
- PL_psig_name = (SV**)NULL;
- }
+/* 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:
+ */
- /* thrdvar.h stuff */
+#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" */
- if (flags & CLONEf_COPY_STACKS) {
- /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
- PL_tmps_ix = proto_perl->Ttmps_ix;
- PL_tmps_max = proto_perl->Ttmps_max;
- PL_tmps_floor = proto_perl->Ttmps_floor;
- Newz(50, PL_tmps_stack, PL_tmps_max, SV*);
- i = 0;
- while (i <= PL_tmps_ix) {
- PL_tmps_stack[i] = sv_dup_inc(proto_perl->Ttmps_stack[i], param);
- ++i;
- }
+STATIC SV*
+S_varname(pTHX_ GV *gv, const char gvtype, PADOFFSET targ,
+ SV* keyname, I32 aindex, int subscript_type)
+{
- /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
- i = proto_perl->Tmarkstack_max - proto_perl->Tmarkstack;
- Newz(54, PL_markstack, i, I32);
- PL_markstack_max = PL_markstack + (proto_perl->Tmarkstack_max
- - proto_perl->Tmarkstack);
- PL_markstack_ptr = PL_markstack + (proto_perl->Tmarkstack_ptr
- - proto_perl->Tmarkstack);
- Copy(proto_perl->Tmarkstack, PL_markstack,
- PL_markstack_ptr - PL_markstack + 1, I32);
+ SV * const name = sv_newmortal();
+ if (gv) {
+ char buffer[2];
+ buffer[0] = gvtype;
+ buffer[1] = 0;
- /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
- * NOTE: unlike the others! */
- PL_scopestack_ix = proto_perl->Tscopestack_ix;
- PL_scopestack_max = proto_perl->Tscopestack_max;
- Newz(54, PL_scopestack, PL_scopestack_max, I32);
- Copy(proto_perl->Tscopestack, PL_scopestack, PL_scopestack_ix, I32);
+ /* as gv_fullname4(), but add literal '^' for $^FOO names */
- /* NOTE: si_dup() looks at PL_markstack */
- PL_curstackinfo = si_dup(proto_perl->Tcurstackinfo, param);
+ gv_fullname4(name, gv, buffer, 0);
- /* PL_curstack = PL_curstackinfo->si_stack; */
- PL_curstack = av_dup(proto_perl->Tcurstack, param);
- PL_mainstack = av_dup(proto_perl->Tmainstack, param);
+ if ((unsigned int)SvPVX(name)[1] <= 26) {
+ buffer[0] = '^';
+ buffer[1] = SvPVX(name)[1] + 'A' - 1;
- /* next PUSHs() etc. set *(PL_stack_sp+1) */
- PL_stack_base = AvARRAY(PL_curstack);
- PL_stack_sp = PL_stack_base + (proto_perl->Tstack_sp
- - proto_perl->Tstack_base);
- PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
+ /* Swap the 1 unprintable control character for the 2 byte pretty
+ version - ie substr($name, 1, 1) = $buffer; */
+ sv_insert(name, 1, 1, buffer, 2);
+ }
+ }
+ else {
+ U32 unused;
+ CV * const cv = find_runcv(&unused);
+ SV *sv;
+ AV *av;
- /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
- * NOTE: unlike the others! */
- PL_savestack_ix = proto_perl->Tsavestack_ix;
- PL_savestack_max = proto_perl->Tsavestack_max;
- /*Newz(54, PL_savestack, PL_savestack_max, ANY);*/
- PL_savestack = ss_dup(proto_perl, param);
+ 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 {
- init_stacks();
- ENTER; /* perl_destruct() wants to LEAVE; */
+ 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);
- PL_start_env = proto_perl->Tstart_env; /* XXXXXX */
- PL_top_env = &PL_start_env;
+ return name;
+}
- PL_op = proto_perl->Top;
- PL_Sv = Nullsv;
- PL_Xpv = (XPV*)NULL;
- PL_na = proto_perl->Tna;
+/*
+=for apidoc find_uninit_var
- PL_statbuf = proto_perl->Tstatbuf;
- PL_statcache = proto_perl->Tstatcache;
- PL_statgv = gv_dup(proto_perl->Tstatgv, param);
- PL_statname = sv_dup_inc(proto_perl->Tstatname, param);
-#ifdef HAS_TIMES
- PL_timesbuf = proto_perl->Ttimesbuf;
-#endif
+Find the name of the undefined variable (if any) that caused the operator o
+to issue a "Use of uninitialized value" warning.
+If match is true, only return a name if it's value matches uninit_sv.
+So roughly speaking, if a unary operator (such as OP_COS) generates a
+warning, then following the direct child of the op may yield an
+OP_PADSV or OP_GV that gives the name of the undefined variable. On the
+other hand, with OP_ADD there are two branches to follow, so we only print
+the variable name if we get an exact match.
- PL_tainted = proto_perl->Ttainted;
- PL_curpm = proto_perl->Tcurpm; /* XXX No PMOP ref count */
- PL_rs = sv_dup_inc(proto_perl->Trs, param);
- PL_last_in_gv = gv_dup(proto_perl->Tlast_in_gv, param);
- PL_ofs_sv = sv_dup_inc(proto_perl->Tofs_sv, param);
- PL_defoutgv = gv_dup_inc(proto_perl->Tdefoutgv, param);
- PL_chopset = proto_perl->Tchopset; /* XXX never deallocated */
- PL_toptarget = sv_dup_inc(proto_perl->Ttoptarget, param);
- PL_bodytarget = sv_dup_inc(proto_perl->Tbodytarget, param);
- PL_formtarget = sv_dup(proto_perl->Tformtarget, param);
+The name is returned as a mortal SV.
- PL_restartop = proto_perl->Trestartop;
- PL_in_eval = proto_perl->Tin_eval;
- PL_delaymagic = proto_perl->Tdelaymagic;
- PL_dirty = proto_perl->Tdirty;
- PL_localizing = proto_perl->Tlocalizing;
+Assumes that PL_op is the op that originally triggered the error, and that
+PL_comppad/PL_curpad points to the currently executing pad.
- PL_errors = sv_dup_inc(proto_perl->Terrors, param);
- PL_hv_fetch_ent_mh = Nullhe;
- PL_modcount = proto_perl->Tmodcount;
- PL_lastgotoprobe = Nullop;
- PL_dumpindent = proto_perl->Tdumpindent;
+=cut
+*/
- PL_sortcop = (OP*)any_dup(proto_perl->Tsortcop, proto_perl);
- PL_sortstash = hv_dup(proto_perl->Tsortstash, param);
- PL_firstgv = gv_dup(proto_perl->Tfirstgv, param);
- PL_secondgv = gv_dup(proto_perl->Tsecondgv, param);
- PL_sortcxix = proto_perl->Tsortcxix;
- PL_efloatbuf = Nullch; /* reinits on demand */
- PL_efloatsize = 0; /* reinits on demand */
+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;
- /* regex stuff */
+ if (!obase || (match && (!uninit_sv || uninit_sv == &PL_sv_undef ||
+ uninit_sv == &PL_sv_placeholder)))
+ return Nullsv;
- PL_screamfirst = NULL;
- PL_screamnext = NULL;
- PL_maxscream = -1; /* reinits on demand */
- PL_lastscream = Nullsv;
+ switch (obase->op_type) {
- PL_watchaddr = NULL;
- PL_watchok = Nullch;
+ case OP_RV2AV:
+ case OP_RV2HV:
+ case OP_PADAV:
+ case OP_PADHV:
+ {
+ const bool pad = (obase->op_type == OP_PADAV || obase->op_type == OP_PADHV);
+ const bool hash = (obase->op_type == OP_PADHV || obase->op_type == OP_RV2HV);
+ I32 index = 0;
+ SV *keysv = Nullsv;
+ int subscript_type = FUV_SUBSCRIPT_WITHIN;
- PL_regdummy = proto_perl->Tregdummy;
- PL_regprecomp = Nullch;
- PL_regnpar = 0;
- PL_regsize = 0;
- PL_colorset = 0; /* reinits PL_colors[] */
- /*PL_colors[6] = {0,0,0,0,0,0};*/
- PL_reginput = Nullch;
- PL_regbol = Nullch;
- PL_regeol = Nullch;
- PL_regstartp = (I32*)NULL;
- PL_regendp = (I32*)NULL;
- PL_reglastparen = (U32*)NULL;
- PL_reglastcloseparen = (U32*)NULL;
- PL_regtill = Nullch;
- PL_reg_start_tmp = (char**)NULL;
- PL_reg_start_tmpl = 0;
- PL_regdata = (struct reg_data*)NULL;
- PL_bostr = Nullch;
- PL_reg_flags = 0;
- PL_reg_eval_set = 0;
- PL_regnarrate = 0;
- PL_regprogram = (regnode*)NULL;
- PL_regindent = 0;
- PL_regcc = (CURCUR*)NULL;
- PL_reg_call_cc = (struct re_cc_state*)NULL;
- PL_reg_re = (regexp*)NULL;
- PL_reg_ganch = Nullch;
- PL_reg_sv = Nullsv;
- PL_reg_match_utf8 = FALSE;
- PL_reg_magic = (MAGIC*)NULL;
- PL_reg_oldpos = 0;
- PL_reg_oldcurpm = (PMOP*)NULL;
- PL_reg_curpm = (PMOP*)NULL;
- PL_reg_oldsaved = Nullch;
- PL_reg_oldsavedlen = 0;
-#ifdef PERL_OLD_COPY_ON_WRITE
- PL_nrs = Nullsv;
-#endif
- PL_reg_maxiter = 0;
- PL_reg_leftiter = 0;
- PL_reg_poscache = Nullch;
- PL_reg_poscache_size= 0;
+ 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);
+ }
- /* RE engine - function pointers */
- PL_regcompp = proto_perl->Tregcompp;
- PL_regexecp = proto_perl->Tregexecp;
- PL_regint_start = proto_perl->Tregint_start;
- PL_regint_string = proto_perl->Tregint_string;
- PL_regfree = proto_perl->Tregfree;
+ /* attempt to find a match within the aggregate */
+ if (hash) {
+ keysv = S_find_hash_subscript(aTHX_ (HV*)sv, uninit_sv);
+ if (keysv)
+ subscript_type = FUV_SUBSCRIPT_HASH;
+ }
+ else {
+ index = S_find_array_subscript(aTHX_ (AV*)sv, uninit_sv);
+ if (index >= 0)
+ subscript_type = FUV_SUBSCRIPT_ARRAY;
+ }
- PL_reginterp_cnt = 0;
- PL_reg_starttry = 0;
+ if (match && subscript_type == FUV_SUBSCRIPT_WITHIN)
+ break;
- /* Pluggable optimizer */
- PL_peepp = proto_perl->Tpeepp;
+ return varname(gv, hash ? '%' : '@', obase->op_targ,
+ keysv, index, subscript_type);
+ }
- PL_stashcache = newHV();
+ case OP_PADSV:
+ if (match && PAD_SVl(obase->op_targ) != uninit_sv)
+ break;
+ return varname(Nullgv, '$', obase->op_targ,
+ Nullsv, 0, FUV_SUBSCRIPT_NONE);
- if (!(flags & CLONEf_KEEP_PTR_TABLE)) {
- ptr_table_free(PL_ptr_table);
- PL_ptr_table = NULL;
- }
+ case OP_GVSV:
+ gv = cGVOPx_gv(obase);
+ if (!gv || (match && GvSV(gv) != uninit_sv))
+ break;
+ return varname(gv, '$', 0, Nullsv, 0, FUV_SUBSCRIPT_NONE);
- /* 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);
- if (cloner && GvCV(cloner)) {
- dSP;
- ENTER;
- SAVETMPS;
- PUSHMARK(SP);
- XPUSHs(sv_2mortal(newSVhek(HvNAME_HEK(stash))));
- PUTBACK;
- call_sv((SV*)GvCV(cloner), G_DISCARD);
- FREETMPS;
- LEAVE;
+ 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;
- SvREFCNT_dec(param->stashes);
+ 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);
+ }
- /* orphaned? eg threads->new inside BEGIN or use */
- if (PL_compcv && ! SvREFCNT(PL_compcv)) {
- (void)SvREFCNT_inc(PL_compcv);
- SAVEFREESV(PL_compcv);
- }
+ break;
- return my_perl;
-}
+ case OP_AASSIGN:
+ /* only examine RHS */
+ return find_uninit_var(cBINOPx(obase)->op_first, uninit_sv, match);
-#endif /* USE_ITHREADS */
+ case OP_OPEN:
+ o = cUNOPx(obase)->op_first;
+ if (o->op_type == OP_PUSHMARK)
+ o = o->op_sibling;
-/*
-=head1 Unicode Support
+ if (!o->op_sibling) {
+ /* one-arg version of open is highly magical */
-=for apidoc sv_recode_to_utf8
+ 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;
-The encoding is assumed to be an Encode object, on entry the PV
-of the sv is assumed to be octets in that encoding, and the sv
-will be converted into Unicode (and UTF-8).
+ /* 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;
-If the sv already is UTF-8 (or if it is not POK), or if the encoding
-is not a reference, nothing is done to the sv. If the encoding is not
-an C<Encode::XS> Encoding object, bad things will happen.
-(See F<lib/encoding.pm> and L<Encode>).
+ 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;
-The PV of the sv is returned.
-=cut */
+ case OP_RV2SV:
+ case OP_CUSTOM:
+ case OP_ENTERSUB:
+ match = 1; /* XS or custom code could trigger random warnings */
+ goto do_op;
-char *
-Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding)
-{
- dVAR;
- if (SvPOK(sv) && !SvUTF8(sv) && !IN_BYTES && SvROK(encoding)) {
- SV *uni;
- STRLEN len;
- const char *s;
- dSP;
- ENTER;
- SAVETMPS;
- save_re_context();
- PUSHMARK(sp);
- EXTEND(SP, 3);
- XPUSHs(encoding);
- XPUSHs(sv);
-/*
- NI-S 2002/07/09
- Passing sv_yes is wrong - it needs to be or'ed set of constants
- for Encode::XS, while UTf-8 decode (currently) assumes a true value means
- remove converted chars from source.
+ case OP_SCHOMP:
+ case OP_CHOMP:
+ if (SvROK(PL_rs) && uninit_sv == SvRV(PL_rs))
+ return sv_2mortal(newSVpvn("${$/}", 5));
+ /* FALL THROUGH */
- Both will default the value - let them.
+ default:
+ do_op:
+ if (!(obase->op_flags & OPf_KIDS))
+ break;
+ o = cUNOPx(obase)->op_first;
+
+ do_op2:
+ if (!o)
+ break;
- XPUSHs(&PL_sv_yes);
-*/
- PUTBACK;
- call_method("decode", G_SCALAR);
- SPAGAIN;
- uni = POPs;
- PUTBACK;
- s = SvPV_const(uni, len);
- if (s != SvPVX_const(sv)) {
- SvGROW(sv, len + 1);
- Move(s, SvPVX(sv), len + 1, char);
- SvCUR_set(sv, len);
+ /* 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;
}
- FREETMPS;
- LEAVE;
- SvUTF8_on(sv);
- return SvPVX(sv);
+ 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 SvPOKp(sv) ? SvPVX(sv) : NULL;
+ return Nullsv;
}
-/*
-=for apidoc sv_cat_decode
-The encoding is assumed to be an Encode object, the PV of the ssv is
-assumed to be octets in that encoding and decoding the input starts
-from the position which (PV + *offset) pointed to. The dsv will be
-concatenated the decoded UTF-8 string from ssv. Decoding will terminate
-when the string tstr appears in decoding output or the input ends on
-the PV of the ssv. The value which the offset points will be modified
-to the last input position on the ssv.
+/*
+=for apidoc report_uninit
-Returns TRUE if the terminator was found, else returns FALSE.
+Print appropriate "Use of uninitialized variable" warning
-=cut */
+=cut
+*/
-bool
-Perl_sv_cat_decode(pTHX_ SV *dsv, SV *encoding,
- SV *ssv, int *offset, char *tstr, int tlen)
+void
+Perl_report_uninit(pTHX_ SV* uninit_sv)
{
- dVAR;
- bool ret = FALSE;
- if (SvPOK(ssv) && SvPOK(dsv) && SvROK(encoding) && offset) {
- SV *offsv;
- dSP;
- ENTER;
- SAVETMPS;
- save_re_context();
- PUSHMARK(sp);
- EXTEND(SP, 6);
- XPUSHs(encoding);
- XPUSHs(dsv);
- XPUSHs(ssv);
- XPUSHs(offsv = sv_2mortal(newSViv(*offset)));
- XPUSHs(sv_2mortal(newSVpvn(tstr, tlen)));
- PUTBACK;
- call_method("cat_decode", G_SCALAR);
- SPAGAIN;
- ret = SvTRUE(TOPs);
- *offset = SvIV(offsv);
- PUTBACK;
- FREETMPS;
- LEAVE;
+ if (PL_op) {
+ SV* varname = Nullsv;
+ if (uninit_sv) {
+ varname = find_uninit_var(PL_op, uninit_sv,0);
+ if (varname)
+ sv_insert(varname, 0, 0, " ", 1);
+ }
+ Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
+ varname ? SvPV_nolen_const(varname) : "",
+ " in ", OP_DESC(PL_op));
}
else
- Perl_croak(aTHX_ "Invalid argument to sv_cat_decode");
- return ret;
+ Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
+ "", "", "");
}
/*
projects / p5sagit/p5-mst-13.2.git / blobdiff