/* sv.c
*
* Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
- * 2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others
+ * 2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
* --jhi
*/
#define ASSERT_UTF8_CACHE(cache) \
- STMT_START { if (cache) { assert((cache)[0] <= (cache)[1]); } } STMT_END
+ STMT_START { if (cache) { assert((cache)[0] <= (cache)[1]); } } STMT_END
#else
#define ASSERT_UTF8_CACHE(cache) NOOP
#endif
=head1 Allocation and deallocation of SVs.
-An SV (or AV, HV, etc.) is allocated in two parts: the head (struct sv,
-av, hv...) contains type and reference count information, as well as a
-pointer to the body (struct xrv, xpv, xpviv...), which contains fields
-specific to each type.
+An SV (or AV, HV, etc.) is allocated in two parts: the head (struct
+sv, av, hv...) contains type and reference count information, and for
+many types, a pointer to the body (struct xrv, xpv, xpviv...), which
+contains fields specific to each type. Some types store all they need
+in the head, so don't have a body.
-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), heads
+and bodies are allocated out of arenas, which by default are
+approximately 4K chunks of memory parcelled up into N heads or bodies.
+Sv-bodies are allocated by their sv-type, guaranteeing size
+consistency needed to allocate safely from arrays.
+
+For SV-heads, the first slot in each arena is reserved, and holds a
+link to the next arena, 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.
+
+SV-bodies are similar, but they use arena-sets by default, which
+separate the link and info from the arena itself, and reclaim the 1st
+slot in the arena. SV-bodies are further described later.
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_arenas head of linked-list of body arenas
+ 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.
+A few special SV heads are not allocated from an arena, but are
+instead directly created in the interpreter structure, 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.
more_sv() / sv_add_arena() to add an extra arena if the free list is empty.
SVs in the free list have their SvTYPE field set to all ones.
-Similarly, there are macros new_XIV()/del_XIV(), new_XNV()/del_XNV() etc
-that allocate and return individual body types. Normally these are mapped
-to the arena-manipulating functions new_xiv()/del_xiv() etc, but may be
-instead mapped directly to malloc()/free() if PURIFY is defined. The
-new/del functions remove from, or add to, the appropriate PL_foo_root
-list, and call more_xiv() etc to add a new arena if the list is empty.
-
At the time of very final cleanup, sv_free_arenas() is called from
perl_destruct() to physically free all the arenas allocated since the
-start of the interpreter. Note that this also clears PL_he_arenaroot,
-which is otherwise dealt with in hv.c.
+start of the interpreter.
Manipulation of any of the PL_*root pointers is protected by enclosing
LOCK_SV_MUTEX; ... UNLOCK_SV_MUTEX calls which should Do the Right Thing
called by visit() for each SV]):
sv_report_used() / do_report_used()
- dump all remaining SVs (debugging aid)
+ dump all remaining SVs (debugging aid)
sv_clean_objs() / do_clean_objs(),do_clean_named_objs()
Attempt to free all objects pointed to by RVs,
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
sv_report_used(), sv_clean_objs(), sv_clean_all(), sv_free_arenas()
-
=cut
============================================================================ */
-
-
/*
* "A time to plant, and a time to uproot what was planted..."
*/
void
Perl_offer_nice_chunk(pTHX_ void *chunk, U32 chunk_size)
{
+ dVAR;
void *new_chunk;
U32 new_chunk_size;
LOCK_SV_MUTEX;
# 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
STATIC SV*
S_more_sv(pTHX)
{
+ dVAR;
SV* sv;
if (PL_nice_chunk) {
sv_add_arena(PL_nice_chunk, PL_nice_chunk_size, 0);
- PL_nice_chunk = Nullch;
+ PL_nice_chunk = NULL;
PL_nice_chunk_size = 0;
}
else {
char *chunk; /* must use New here to match call to */
- Newx(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);
STATIC void
S_del_sv(pTHX_ SV *p)
{
+ dVAR;
if (DEBUG_D_TEST) {
SV* sva;
bool ok = 0;
void
Perl_sv_add_arena(pTHX_ char *ptr, U32 size, U32 flags)
{
- SV* sva = (SV*)ptr;
+ dVAR;
+ 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
STATIC I32
S_visit(pTHX_ SVFUNC_t f, U32 flags, U32 mask)
{
+ dVAR;
SV* sva;
I32 visited = 0;
{
#ifdef DEBUGGING
visit(do_report_used, 0, 0);
+#else
+ PERL_UNUSED_CONTEXT;
#endif
}
static void
do_clean_objs(pTHX_ SV *ref)
{
+ dVAR;
if (SvROK(ref)) {
SV * const target = SvRV(ref);
if (SvOBJECT(target)) {
static void
do_clean_named_objs(pTHX_ SV *sv)
{
- if (SvTYPE(sv) == SVt_PVGV && GvGP(sv)) {
+ dVAR;
+ if (SvTYPE(sv) == SVt_PVGV && isGV_with_GP(sv) && GvGP(sv)) {
if ((
#ifdef PERL_DONT_CREATE_GVSV
GvSV(sv) &&
void
Perl_sv_clean_objs(pTHX)
{
+ dVAR;
PL_in_clean_objs = TRUE;
visit(do_clean_objs, SVf_ROK, SVf_ROK);
#ifndef DISABLE_DESTRUCTOR_KLUDGE
static void
do_clean_all(pTHX_ SV *sv)
{
+ dVAR;
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_curpad = Null(SV**);
+ PL_comppad = NULL;
+ PL_curpad = NULL;
}
SvREFCNT_dec(sv);
}
I32
Perl_sv_clean_all(pTHX)
{
+ dVAR;
I32 cleaned;
PL_in_clean_all = TRUE;
cleaned = visit(do_clean_all, 0,0);
return cleaned;
}
-static void
-S_free_arena(pTHX_ void **root) {
- while (root) {
- void ** const next = *(void **)root;
- Safefree(root);
- root = next;
- }
-}
-
+/*
+ ARENASETS: a meta-arena implementation which separates arena-info
+ into struct arena_set, which contains an array of struct
+ arena_descs, each holding info for a single arena. By separating
+ the meta-info from the arena, we recover the 1st slot, formerly
+ borrowed for list management. The arena_set is about the size of an
+ arena, avoiding the needless malloc overhead of a naive linked-list
+
+ The cost is 1 arena-set malloc per ~320 arena-mallocs, + the unused
+ memory in the last arena-set (1/2 on average). In trade, we get
+ back the 1st slot in each arena (ie 1.7% of a CV-arena, less for
+ smaller types). The recovery of the wasted space allows use of
+ small arenas for large, rare body types,
+*/
+struct arena_desc {
+ char *arena; /* the raw storage, allocated aligned */
+ size_t size; /* its size ~4k typ */
+ int unit_type; /* useful for arena audits */
+ /* info for sv-heads (eventually)
+ int count, flags;
+ */
+};
+
+struct arena_set;
+
+/* Get the maximum number of elements in set[] such that struct arena_set
+ will fit within PERL_ARENA_SIZE, which is probabably just under 4K, and
+ therefore likely to be 1 aligned memory page. */
+
+#define ARENAS_PER_SET ((PERL_ARENA_SIZE - sizeof(struct arena_set*) \
+ - 2 * sizeof(int)) / sizeof (struct arena_desc))
+
+struct arena_set {
+ struct arena_set* next;
+ int set_size; /* ie ARENAS_PER_SET */
+ int curr; /* index of next available arena-desc */
+ struct arena_desc set[ARENAS_PER_SET];
+};
+
/*
=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)
{
+ dVAR;
SV* sva;
SV* svanext;
+ int i;
/* Free arenas here, but be careful about fake ones. (We assume
contiguity of the fake ones with the corresponding real ones.) */
if (!SvFAKE(sva))
Safefree(sva);
}
-
- free_arena(xnv);
- free_arena(xpv);
- free_arena(xpviv);
- free_arena(xpvnv);
- free_arena(xpvcv);
- free_arena(xpvav);
- free_arena(xpvhv);
- free_arena(xpvmg);
- free_arena(xpvgv);
- free_arena(xpvlv);
- free_arena(xpvbm);
- free_arena(he);
-#if defined(USE_ITHREADS)
- free_arena(pte);
-#endif
+
+ {
+ struct arena_set *next, *aroot = (struct arena_set*) PL_body_arenas;
+
+ for (; aroot; aroot = next) {
+ const int max = aroot->curr;
+ for (i=0; i<max; i++) {
+ assert(aroot->set[i].arena);
+ Safefree(aroot->set[i].arena);
+ }
+ next = aroot->next;
+ Safefree(aroot);
+ }
+ }
+ PL_body_arenas = 0;
+
+ for (i=0; i<PERL_ARENA_ROOTS_SIZE; i++)
+ PL_body_roots[i] = 0;
Safefree(PL_nice_chunk);
- PL_nice_chunk = Nullch;
+ PL_nice_chunk = NULL;
PL_nice_chunk_size = 0;
PL_sv_arenaroot = 0;
PL_sv_root = 0;
}
-/* ---------------------------------------------------------------------
- *
- * support functions for report_uninit()
- */
+/*
+ Here are mid-level routines that manage the allocation of bodies out
+ of the various arenas. There are 5 kinds of arenas:
+
+ 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)
+
+ Arena types 2 & 3 are chained by body-type off an array of
+ arena-root pointers, which is indexed by svtype. Some of the
+ larger/less used body types are malloced singly, since a large
+ unused block of them is wasteful. Also, several svtypes dont have
+ bodies; the data fits into the sv-head itself. The arena-root
+ pointer thus has a few unused root-pointers (which may be hijacked
+ later for arena types 4,5)
+
+ 3 differs from 2 as an optimization; some body types have several
+ unused fields in the front of the structure (which are kept in-place
+ for consistency). These bodies can be allocated in smaller chunks,
+ because the leading fields arent accessed. Pointers to such bodies
+ are decremented to point at the unused 'ghost' memory, knowing that
+ the pointers are used with offsets to the real memory.
+
+ HE, HEK arenas are managed separately, with separate code, but may
+ be merge-able later..
+
+ PTE arenas are not sv-bodies, but they share these mid-level
+ mechanics, so are considered here. The new mid-level mechanics rely
+ on the sv_type of the body being allocated, so we just reserve one
+ of the unused body-slots for PTEs, then use it in those (2) PTE
+ contexts below (line ~10k)
+*/
-/* the maxiumum size of array or hash where we will scan looking
- * for the undefined element that triggered the warning */
+/* get_arena(size): this creates custom-sized arenas
+ TBD: export properly for hv.c: S_more_he().
+*/
+void*
+Perl_get_arena(pTHX_ int arena_size)
+{
+ struct arena_desc* adesc;
+ struct arena_set *newroot, **aroot = (struct arena_set**) &PL_body_arenas;
+ int curr;
-#define FUV_MAX_SEARCH_SIZE 1000
+ /* shouldnt need this
+ if (!arena_size) arena_size = PERL_ARENA_SIZE;
+ */
-/* Look for an entry in the hash whose value has the same SV as val;
- * If so, return a mortal copy of the key. */
+ /* may need new arena-set to hold new arena */
+ if (!*aroot || (*aroot)->curr >= (*aroot)->set_size) {
+ Newxz(newroot, 1, struct arena_set);
+ newroot->set_size = ARENAS_PER_SET;
+ newroot->next = *aroot;
+ *aroot = newroot;
+ DEBUG_m(PerlIO_printf(Perl_debug_log, "new arenaset %p\n", *aroot));
+ }
-STATIC SV*
-S_find_hash_subscript(pTHX_ HV *hv, SV* val)
-{
- dVAR;
- register HE **array;
- I32 i;
+ /* ok, now have arena-set with at least 1 empty/available arena-desc */
+ curr = (*aroot)->curr++;
+ adesc = &((*aroot)->set[curr]);
+ assert(!adesc->arena);
+
+ Newxz(adesc->arena, arena_size, char);
+ adesc->size = arena_size;
+ DEBUG_m(PerlIO_printf(Perl_debug_log, "arena %d added: %p size %d\n",
+ curr, adesc->arena, arena_size));
- if (!hv || SvMAGICAL(hv) || !HvARRAY(hv) ||
- (HvTOTALKEYS(hv) > FUV_MAX_SEARCH_SIZE))
- return Nullsv;
+ return adesc->arena;
+}
- array = HvARRAY(hv);
- for (i=HvMAX(hv); i>0; i--) {
- register HE *entry;
- for (entry = array[i]; entry; entry = HeNEXT(entry)) {
- if (HeVAL(entry) != val)
- continue;
- if ( HeVAL(entry) == &PL_sv_undef ||
- HeVAL(entry) == &PL_sv_placeholder)
- continue;
- if (!HeKEY(entry))
- return Nullsv;
- if (HeKLEN(entry) == HEf_SVKEY)
- return sv_mortalcopy(HeKEY_sv(entry));
- return sv_2mortal(newSVpvn(HeKEY(entry), HeKLEN(entry)));
- }
- }
- return Nullsv;
-}
+/* return a thing to the free list */
-/* Look for an entry in the array whose value has the same SV as val;
- * If so, return the index, otherwise return -1. */
+#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
-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;
+/*
+
+=head1 SV-Body Allocation
+
+Allocation of SV-bodies is similar to SV-heads, differing as follows;
+the allocation mechanism is used for many body types, so is somewhat
+more complicated, it uses arena-sets, and has no need for still-live
+SV detection.
+
+At the outermost level, (new|del)_X*V macros return bodies of the
+appropriate type. These macros call either (new|del)_body_type or
+(new|del)_body_allocated macro pairs, depending on specifics of the
+type. Most body types use the former pair, the latter pair is used to
+allocate body types with "ghost fields".
+
+"ghost fields" are fields that are unused in certain types, and
+consequently dont need to actually exist. They are declared because
+they're part of a "base type", which allows use of functions as
+methods. The simplest examples are AVs and HVs, 2 aggregate types
+which don't use the fields which support SCALAR semantics.
+
+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.
+
+In turn, the new_body_* allocators call S_new_body(), which invokes
+new_body_inline macro, which takes a lock, and takes a body off the
+linked list at PL_body_roots[sv_type], calling S_more_bodies() if
+necessary to refresh an empty list. Then the lock is released, and
+the body is returned.
+
+S_more_bodies calls get_arena(), and carves it up into an array of N
+bodies, which it strings into a linked list. It looks up arena-size
+and body-size from the body_details table described below, thus
+supporting the multiple body-types.
+
+If PURIFY is defined, or PERL_ARENA_SIZE=0, arenas are not used, and
+the (new|del)_X*V macros are mapped directly to malloc/free.
- svp = AvARRAY(av);
- for (i=AvFILLp(av); i>=0; i--) {
- if (svp[i] == val && svp[i] != &PL_sv_undef)
- return i;
- }
- return -1;
-}
+*/
-/* S_varname(): return the name of a variable, optionally with a subscript.
- * If gv is non-zero, use the name of that global, along with gvtype (one
- * of "$", "@", "%"); otherwise use the name of the lexical at pad offset
- * targ. Depending on the value of the subscript_type flag, return:
- */
+/*
-#define FUV_SUBSCRIPT_NONE 1 /* "@foo" */
-#define FUV_SUBSCRIPT_ARRAY 2 /* "$foo[aindex]" */
-#define FUV_SUBSCRIPT_HASH 3 /* "$foo{keyname}" */
-#define FUV_SUBSCRIPT_WITHIN 4 /* "within @foo" */
+For each sv-type, struct body_details bodies_by_type[] carries
+parameters which control these aspects of SV handling:
-STATIC SV*
-S_varname(pTHX_ GV *gv, const char gvtype, PADOFFSET targ,
- SV* keyname, I32 aindex, int subscript_type)
-{
+Arena_size determines whether arenas are used for this body type, and if
+so, how big they are. PURIFY or PERL_ARENA_SIZE=0 set this field to
+zero, forcing individual mallocs and frees.
- SV * const name = sv_newmortal();
- if (gv) {
- char buffer[2];
- buffer[0] = gvtype;
- buffer[1] = 0;
+Body_size determines how big a body is, and therefore how many fit into
+each arena. Offset carries the body-pointer adjustment needed for
+*_allocated body types, and is used in *_allocated macros.
- /* as gv_fullname4(), but add literal '^' for $^FOO names */
+But its main purpose is to parameterize info needed in
+Perl_sv_upgrade(). The info here dramatically simplifies the function
+vs the implementation in 5.8.7, making it table-driven. All fields
+are used for this, except for arena_size.
- gv_fullname4(name, gv, buffer, 0);
+For the sv-types that have no bodies, arenas are not used, so those
+PL_body_roots[sv_type] are unused, and can be overloaded. In
+something of a special case, SVt_NULL is borrowed for HE arenas;
+PL_body_roots[SVt_NULL] is filled by S_more_he, but the
+bodies_by_type[SVt_NULL] slot is not used, as the table is not
+available in hv.c,
- if ((unsigned int)SvPVX(name)[1] <= 26) {
- buffer[0] = '^';
- buffer[1] = SvPVX(name)[1] + 'A' - 1;
+PTEs also use arenas, but are never seen in Perl_sv_upgrade.
+Nonetheless, they get their own slot in bodies_by_type[SVt_NULL], so
+they can just use the same allocation semantics. At first, PTEs were
+also overloaded to a non-body sv-type, but this yielded hard-to-find
+malloc bugs, so was simplified by claiming a new slot. This choice
+has no consequence at this time.
- /* Swap the 1 unprintable control character for the 2 byte pretty
- version - ie substr($name, 1, 1) = $buffer; */
- sv_insert(name, 1, 1, buffer, 2);
- }
- }
- else {
- U32 unused;
- CV * const cv = find_runcv(&unused);
- SV *sv;
- AV *av;
+*/
- if (!cv || !CvPADLIST(cv))
- return Nullsv;
- av = (AV*)(*av_fetch(CvPADLIST(cv), 0, FALSE));
- sv = *av_fetch(av, targ, FALSE);
- /* SvLEN in a pad name is not to be trusted */
- sv_setpv(name, SvPV_nolen_const(sv));
- }
+struct body_details {
+ U8 body_size; /* Size to allocate */
+ U8 copy; /* Size of structure to copy (may be shorter) */
+ U8 offset;
+ unsigned int type : 4; /* We have space for a sanity check. */
+ unsigned int cant_upgrade : 1; /* Cannot upgrade this type */
+ unsigned int zero_nv : 1; /* zero the NV when upgrading from this */
+ unsigned int arena : 1; /* Allocated from an arena */
+ size_t arena_size; /* Size of arena to allocate */
+};
- if (subscript_type == FUV_SUBSCRIPT_HASH) {
- SV * const sv = NEWSV(0,0);
- *SvPVX(name) = '$';
- Perl_sv_catpvf(aTHX_ name, "{%s}",
- pv_display(sv,SvPVX_const(keyname), SvCUR(keyname), 0, 32));
- SvREFCNT_dec(sv);
- }
- else if (subscript_type == FUV_SUBSCRIPT_ARRAY) {
- *SvPVX(name) = '$';
- Perl_sv_catpvf(aTHX_ name, "[%"IVdf"]", (IV)aindex);
- }
- else if (subscript_type == FUV_SUBSCRIPT_WITHIN)
- sv_insert(name, 0, 0, "within ", 7);
+#define HADNV FALSE
+#define NONV TRUE
- return name;
-}
+#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
+
+/* Size the arenas to exactly fit a given number of bodies. A count
+ of 0 fits the max number bodies into a PERL_ARENA_SIZE.block,
+ simplifying the default. If count > 0, the arena is sized to fit
+ only that many bodies, allowing arenas to be used for large, rare
+ bodies (XPVFM, XPVIO) without undue waste. The arena size is
+ limited by PERL_ARENA_SIZE, so we can safely oversize the
+ declarations.
+ */
+#define FIT_ARENA0(body_size) \
+ ((size_t)(PERL_ARENA_SIZE / body_size) * body_size)
+#define FIT_ARENAn(count,body_size) \
+ ( count * body_size <= PERL_ARENA_SIZE) \
+ ? count * body_size \
+ : FIT_ARENA0 (body_size)
+#define FIT_ARENA(count,body_size) \
+ count \
+ ? FIT_ARENAn (count, body_size) \
+ : FIT_ARENA0 (body_size)
+
+/* A macro to work out the offset needed to subtract from a pointer to (say)
+
+typedef struct {
+ STRLEN xpv_cur;
+ STRLEN xpv_len;
+} xpv_allocated;
+
+to make its members accessible via a pointer to (say)
+
+struct xpv {
+ NV xnv_nv;
+ STRLEN xpv_cur;
+ STRLEN xpv_len;
+};
-/*
-=for apidoc find_uninit_var
+*/
-Find the name of the undefined variable (if any) that caused the operator o
-to issue a "Use of uninitialized value" warning.
-If match is true, only return a name if it's value matches uninit_sv.
-So roughly speaking, if a unary operator (such as OP_COS) generates a
-warning, then following the direct child of the op may yield an
-OP_PADSV or OP_GV that gives the name of the undefined variable. On the
-other hand, with OP_ADD there are two branches to follow, so we only print
-the variable name if we get an exact match.
+#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[] = {
+ { sizeof(HE), 0, 0, SVt_NULL,
+ FALSE, NONV, NOARENA, FIT_ARENA(0, sizeof(HE)) },
+
+ /* IVs are in the head, so the allocation size is 0.
+ However, the slot is overloaded for PTEs. */
+ { sizeof(struct ptr_tbl_ent), /* This is used for PTEs. */
+ sizeof(IV), /* This is used to copy out the IV body. */
+ STRUCT_OFFSET(XPVIV, xiv_iv), SVt_IV, FALSE, NONV,
+ NOARENA /* IVS don't need an arena */,
+ /* But PTEs need to know the size of their arena */
+ FIT_ARENA(0, sizeof(struct ptr_tbl_ent))
+ },
+
+ /* 8 bytes on most ILP32 with IEEE doubles */
+ { sizeof(NV), sizeof(NV), 0, SVt_NV, FALSE, HADNV, HASARENA,
+ FIT_ARENA(0, sizeof(NV)) },
+
+ /* RVs are in the head now. */
+ { 0, 0, 0, SVt_RV, FALSE, NONV, NOARENA, 0 },
+
+ /* 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),
+ SVt_PV, FALSE, NONV, HASARENA, FIT_ARENA(0, sizeof(xpv_allocated)) },
+
+ /* 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),
+ SVt_PVIV, FALSE, NONV, HASARENA, FIT_ARENA(0, sizeof(xpviv_allocated)) },
+
+ /* 20 */
+ { sizeof(XPVNV), copy_length(XPVNV, xiv_u), 0, SVt_PVNV, FALSE, HADNV,
+ HASARENA, FIT_ARENA(0, sizeof(XPVNV)) },
+
+ /* 28 */
+ { sizeof(XPVMG), copy_length(XPVMG, xmg_stash), 0, SVt_PVMG, FALSE, HADNV,
+ HASARENA, FIT_ARENA(0, sizeof(XPVMG)) },
+
+ /* 36 */
+ { sizeof(XPVBM), sizeof(XPVBM), 0, SVt_PVBM, TRUE, HADNV,
+ HASARENA, FIT_ARENA(0, sizeof(XPVBM)) },
-The name is returned as a mortal SV.
+ /* 48 */
+ { sizeof(XPVGV), sizeof(XPVGV), 0, SVt_PVGV, TRUE, HADNV,
+ HASARENA, FIT_ARENA(0, sizeof(XPVGV)) },
+
+ /* 64 */
+ { sizeof(XPVLV), sizeof(XPVLV), 0, SVt_PVLV, TRUE, HADNV,
+ HASARENA, FIT_ARENA(0, sizeof(XPVLV)) },
-Assumes that PL_op is the op that originally triggered the error, and that
-PL_comppad/PL_curpad points to the currently executing pad.
+ { sizeof(xpvav_allocated),
+ copy_length(XPVAV, xmg_stash)
+ - relative_STRUCT_OFFSET(xpvav_allocated, XPVAV, xav_fill),
+ + relative_STRUCT_OFFSET(xpvav_allocated, XPVAV, xav_fill),
+ SVt_PVAV, TRUE, HADNV, HASARENA, FIT_ARENA(0, sizeof(xpvav_allocated)) },
-=cut
-*/
+ { sizeof(xpvhv_allocated),
+ copy_length(XPVHV, xmg_stash)
+ - relative_STRUCT_OFFSET(xpvhv_allocated, XPVHV, xhv_fill),
+ + relative_STRUCT_OFFSET(xpvhv_allocated, XPVHV, xhv_fill),
+ SVt_PVHV, TRUE, HADNV, HASARENA, FIT_ARENA(0, sizeof(xpvhv_allocated)) },
-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;
+ /* 56 */
+ { sizeof(xpvcv_allocated), sizeof(xpvcv_allocated),
+ + relative_STRUCT_OFFSET(xpvcv_allocated, XPVCV, xpv_cur),
+ SVt_PVCV, TRUE, NONV, HASARENA, FIT_ARENA(0, sizeof(xpvcv_allocated)) },
- if (!obase || (match && (!uninit_sv || uninit_sv == &PL_sv_undef ||
- uninit_sv == &PL_sv_placeholder)))
- return Nullsv;
+ { sizeof(xpvfm_allocated), sizeof(xpvfm_allocated),
+ + relative_STRUCT_OFFSET(xpvfm_allocated, XPVFM, xpv_cur),
+ SVt_PVFM, TRUE, NONV, NOARENA, FIT_ARENA(20, sizeof(xpvfm_allocated)) },
- switch (obase->op_type) {
+ /* XPVIO is 84 bytes, fits 48x */
+ { sizeof(XPVIO), sizeof(XPVIO), 0, SVt_PVIO, TRUE, HADNV,
+ HASARENA, FIT_ARENA(24, sizeof(XPVIO)) },
+};
- 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;
+#define new_body_type(sv_type) \
+ (void *)((char *)S_new_body(aTHX_ sv_type))
- 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 del_body_type(p, sv_type) \
+ del_body(p, &PL_body_roots[sv_type])
- /* attempt to find a match within the aggregate */
- if (hash) {
- keysv = S_find_hash_subscript(aTHX_ (HV*)sv, uninit_sv);
- if (keysv)
- subscript_type = FUV_SUBSCRIPT_HASH;
- }
- else {
- index = S_find_array_subscript(aTHX_ (AV*)sv, uninit_sv);
- if (index >= 0)
- subscript_type = FUV_SUBSCRIPT_ARRAY;
- }
- if (match && subscript_type == FUV_SUBSCRIPT_WITHIN)
- break;
+#define new_body_allocated(sv_type) \
+ (void *)((char *)S_new_body(aTHX_ sv_type) \
+ - bodies_by_type[sv_type].offset)
- return varname(gv, hash ? '%' : '@', obase->op_targ,
- keysv, index, subscript_type);
- }
+#define del_body_allocated(p, sv_type) \
+ del_body(p + bodies_by_type[sv_type].offset, &PL_body_roots[sv_type])
- case OP_PADSV:
- if (match && PAD_SVl(obase->op_targ) != uninit_sv)
- break;
- return varname(Nullgv, '$', obase->op_targ,
- Nullsv, 0, FUV_SUBSCRIPT_NONE);
- case OP_GVSV:
- gv = cGVOPx_gv(obase);
- if (!gv || (match && GvSV(gv) != uninit_sv))
- break;
- return varname(gv, '$', 0, Nullsv, 0, FUV_SUBSCRIPT_NONE);
+#define my_safemalloc(s) (void*)safemalloc(s)
+#define my_safecalloc(s) (void*)safecalloc(s, 1)
+#define my_safefree(p) safefree((char*)p)
- 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);
+#ifdef PURIFY
- case OP_AELEM:
- case OP_HELEM:
- if (PL_op == obase)
- /* $a[uninit_expr] or $h{uninit_expr} */
- return find_uninit_var(cBINOPx(obase)->op_last, uninit_sv, match);
+#define new_XNV() my_safemalloc(sizeof(XPVNV))
+#define del_XNV(p) my_safefree(p)
- gv = Nullgv;
- o = cBINOPx(obase)->op_first;
- kid = cBINOPx(obase)->op_last;
+#define new_XPVNV() my_safemalloc(sizeof(XPVNV))
+#define del_XPVNV(p) my_safefree(p)
- /* get the av or hv, and optionally the gv */
- sv = Nullsv;
- if (o->op_type == OP_PADAV || o->op_type == OP_PADHV) {
- sv = PAD_SV(o->op_targ);
- }
- else if ((o->op_type == OP_RV2AV || o->op_type == OP_RV2HV)
- && cUNOPo->op_first->op_type == OP_GV)
- {
- gv = cGVOPx_gv(cUNOPo->op_first);
- if (!gv)
- break;
- sv = o->op_type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)GvAV(gv);
- }
- if (!sv)
- break;
+#define new_XPVAV() my_safemalloc(sizeof(XPVAV))
+#define del_XPVAV(p) my_safefree(p)
- if (kid && kid->op_type == OP_CONST && SvOK(cSVOPx_sv(kid))) {
- /* index is constant */
- if (match) {
- if (SvMAGICAL(sv))
- break;
- if (obase->op_type == OP_HELEM) {
- HE* he = hv_fetch_ent((HV*)sv, cSVOPx_sv(kid), 0, 0);
- if (!he || HeVAL(he) != uninit_sv)
- break;
- }
- else {
- SV ** const svp = av_fetch((AV*)sv, SvIV(cSVOPx_sv(kid)), FALSE);
- if (!svp || *svp != uninit_sv)
- break;
- }
- }
- if (obase->op_type == OP_HELEM)
- return varname(gv, '%', o->op_targ,
- cSVOPx_sv(kid), 0, FUV_SUBSCRIPT_HASH);
- else
- return varname(gv, '@', o->op_targ, Nullsv,
- SvIV(cSVOPx_sv(kid)), FUV_SUBSCRIPT_ARRAY);
- ;
- }
- else {
- /* index is an expression;
- * attempt to find a match within the aggregate */
- if (obase->op_type == OP_HELEM) {
- SV * const keysv = S_find_hash_subscript(aTHX_ (HV*)sv, uninit_sv);
- if (keysv)
- return varname(gv, '%', o->op_targ,
- keysv, 0, FUV_SUBSCRIPT_HASH);
- }
- else {
- const I32 index = S_find_array_subscript(aTHX_ (AV*)sv, uninit_sv);
- if (index >= 0)
- return varname(gv, '@', o->op_targ,
- Nullsv, index, FUV_SUBSCRIPT_ARRAY);
- }
- if (match)
- break;
- return varname(gv,
- (o->op_type == OP_PADAV || o->op_type == OP_RV2AV)
- ? '@' : '%',
- o->op_targ, Nullsv, 0, FUV_SUBSCRIPT_WITHIN);
- }
+#define new_XPVHV() my_safemalloc(sizeof(XPVHV))
+#define del_XPVHV(p) my_safefree(p)
- break;
+#define new_XPVMG() my_safemalloc(sizeof(XPVMG))
+#define del_XPVMG(p) my_safefree(p)
- case OP_AASSIGN:
- /* only examine RHS */
- return find_uninit_var(cBINOPx(obase)->op_first, uninit_sv, match);
+#define new_XPVGV() my_safemalloc(sizeof(XPVGV))
+#define del_XPVGV(p) my_safefree(p)
- case OP_OPEN:
- o = cUNOPx(obase)->op_first;
- if (o->op_type == OP_PUSHMARK)
- o = o->op_sibling;
+#else /* !PURIFY */
- if (!o->op_sibling) {
- /* one-arg version of open is highly magical */
+#define new_XNV() new_body_type(SVt_NV)
+#define del_XNV(p) del_body_type(p, SVt_NV)
- if (o->op_type == OP_GV) { /* open FOO; */
- gv = cGVOPx_gv(o);
- if (match && GvSV(gv) != uninit_sv)
- break;
- return varname(gv, '$', 0,
- Nullsv, 0, FUV_SUBSCRIPT_NONE);
- }
- /* other possibilities not handled are:
- * open $x; or open my $x; should return '${*$x}'
- * open expr; should return '$'.expr ideally
- */
- break;
- }
- goto do_op;
+#define new_XPVNV() new_body_type(SVt_PVNV)
+#define del_XPVNV(p) del_body_type(p, SVt_PVNV)
- /* ops where $_ may be an implicit arg */
- case OP_TRANS:
- case OP_SUBST:
- case OP_MATCH:
- if ( !(obase->op_flags & OPf_STACKED)) {
- if (uninit_sv == ((obase->op_private & OPpTARGET_MY)
- ? PAD_SVl(obase->op_targ)
- : DEFSV))
- {
- sv = sv_newmortal();
- sv_setpvn(sv, "$_", 2);
- return sv;
- }
- }
- goto do_op;
+#define new_XPVAV() new_body_allocated(SVt_PVAV)
+#define del_XPVAV(p) del_body_allocated(p, SVt_PVAV)
- case OP_PRTF:
- case OP_PRINT:
- /* skip filehandle as it can't produce 'undef' warning */
- o = cUNOPx(obase)->op_first;
- if ((obase->op_flags & OPf_STACKED) && o->op_type == OP_PUSHMARK)
- o = o->op_sibling->op_sibling;
- goto do_op2;
+#define new_XPVHV() new_body_allocated(SVt_PVHV)
+#define del_XPVHV(p) del_body_allocated(p, SVt_PVHV)
+#define new_XPVMG() new_body_type(SVt_PVMG)
+#define del_XPVMG(p) del_body_type(p, SVt_PVMG)
- case OP_RV2SV:
- case OP_CUSTOM:
- case OP_ENTERSUB:
- match = 1; /* XS or custom code could trigger random warnings */
- goto do_op;
+#define new_XPVGV() new_body_type(SVt_PVGV)
+#define del_XPVGV(p) del_body_type(p, SVt_PVGV)
- case OP_SCHOMP:
- case OP_CHOMP:
- if (SvROK(PL_rs) && uninit_sv == SvRV(PL_rs))
- return sv_2mortal(newSVpvn("${$/}", 5));
- /* FALL THROUGH */
+#endif /* PURIFY */
- default:
- do_op:
- if (!(obase->op_flags & OPf_KIDS))
- break;
- o = cUNOPx(obase)->op_first;
-
- do_op2:
- if (!o)
- break;
+/* no arena for you! */
- /* if all except one arg are constant, or have no side-effects,
- * or are optimized away, then it's unambiguous */
- o2 = Nullop;
- for (kid=o; kid; kid = kid->op_sibling) {
- if (kid &&
- ( (kid->op_type == OP_CONST && SvOK(cSVOPx_sv(kid)))
- || (kid->op_type == OP_NULL && ! (kid->op_flags & OPf_KIDS))
- || (kid->op_type == OP_PUSHMARK)
- )
- )
- continue;
- if (o2) { /* more than one found */
- o2 = Nullop;
- break;
- }
- o2 = kid;
- }
- if (o2)
- return find_uninit_var(o2, uninit_sv, match);
+#define new_NOARENA(details) \
+ my_safemalloc((details)->body_size + (details)->offset)
+#define new_NOARENAZ(details) \
+ my_safecalloc((details)->body_size + (details)->offset)
- /* scan all args */
- while (o) {
- sv = find_uninit_var(o, uninit_sv, 1);
- if (sv)
- return sv;
- o = o->op_sibling;
- }
- break;
- }
- return Nullsv;
-}
+#ifdef DEBUGGING
+static bool done_sanity_check;
+#endif
+STATIC void *
+S_more_bodies (pTHX_ svtype sv_type)
+{
+ dVAR;
+ void ** const root = &PL_body_roots[sv_type];
+ const struct body_details * const bdp = &bodies_by_type[sv_type];
+ const size_t body_size = bdp->body_size;
+ char *start;
+ const char *end;
-/*
-=for apidoc report_uninit
+ assert(bdp->arena_size);
-Print appropriate "Use of uninitialized variable" warning
+#ifdef DEBUGGING
+ if (!done_sanity_check) {
+ unsigned int i = SVt_LAST;
-=cut
-*/
+ done_sanity_check = TRUE;
-void
-Perl_report_uninit(pTHX_ SV* uninit_sv)
-{
- if (PL_op) {
- SV* varname = Nullsv;
- if (uninit_sv) {
- varname = find_uninit_var(PL_op, uninit_sv,0);
- if (varname)
- sv_insert(varname, 0, 0, " ", 1);
- }
- Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
- varname ? SvPV_nolen_const(varname) : "",
- " in ", OP_DESC(PL_op));
+ while (i--)
+ assert (bodies_by_type[i].type == i);
}
- else
- Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
- "", "", "");
-}
-
-STATIC void *
-S_more_bodies (pTHX_ void **arena_root, void **root, size_t size)
-{
- char *start;
- const char *end;
- const size_t count = PERL_ARENA_SIZE/size;
- Newx(start, count*size, char);
- *((void **) start) = *arena_root;
- *arena_root = (void *)start;
+#endif
- end = start + (count-1) * size;
+ start = (char*) Perl_get_arena(aTHX_ bdp->arena_size);
- /* The initial slot is used to link the arenas together, so it isn't to be
- linked into the list of ready-to-use bodies. */
+ end = start + bdp->arena_size - body_size;
- start += size;
+ /* computed count doesnt reflect the 1st slot reservation */
+ DEBUG_m(PerlIO_printf(Perl_debug_log,
+ "arena %p end %p arena-size %d type %d size %d ct %d\n",
+ start, end, bdp->arena_size, sv_type, body_size,
+ bdp->arena_size / body_size));
*root = (void *)start;
while (start < end) {
- char * const next = start + size;
+ char * const next = start + body_size;
*(void**) start = (void *)next;
start = next;
}
return *root;
}
-/* grab a new thing from the free list, allocating more if necessary */
-
-/* 1st, the inline version */
-
-#define new_body_inline(xpv, arena_root, root, size) \
+/* grab a new thing from the free list, allocating more if necessary.
+ The inline version is used for speed in hot routines, and the
+ function using it serves the rest (unless PURIFY).
+*/
+#define new_body_inline(xpv, sv_type) \
STMT_START { \
+ void ** const r3wt = &PL_body_roots[sv_type]; \
LOCK_SV_MUTEX; \
- xpv = *((void **)(root)) \
- ? *((void **)(root)) : S_more_bodies(aTHX_ arena_root, root, size); \
- *(root) = *(void**)(xpv); \
+ xpv = *((void **)(r3wt)) \
+ ? *((void **)(r3wt)) : S_more_bodies(aTHX_ sv_type); \
+ *(r3wt) = *(void**)(xpv); \
UNLOCK_SV_MUTEX; \
} STMT_END
-/* now use the inline version in the proper function */
+#ifndef PURIFY
STATIC void *
-S_new_body(pTHX_ void **arena_root, void **root, size_t size)
+S_new_body(pTHX_ svtype sv_type)
{
+ dVAR;
void *xpv;
- new_body_inline(xpv, arena_root, root, size);
+ new_body_inline(xpv, sv_type);
return xpv;
}
-/* return a thing to the free list */
-
-#define del_body(thing, root) \
- STMT_START { \
- void **thing_copy = (void **)thing; \
- LOCK_SV_MUTEX; \
- *thing_copy = *root; \
- *root = (void*)thing_copy; \
- UNLOCK_SV_MUTEX; \
- } STMT_END
+#endif
-/* Conventionally we simply malloc() a big block of memory, then divide it
- up into lots of the thing that we're allocating.
+/*
+=for apidoc sv_upgrade
- This macro will expand to call to S_new_body. So for XPVBM (with ithreads),
- it would become
+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>.
- S_new_body(my_perl, (void**)&(my_perl->Ixpvbm_arenaroot),
- (void**)&(my_perl->Ixpvbm_root), sizeof(XPVBM), 0)
-*/
-
-#define new_body_type(TYPE,lctype) \
- S_new_body(aTHX_ (void**)&PL_ ## lctype ## _arenaroot, \
- (void**)&PL_ ## lctype ## _root, \
- sizeof(TYPE))
-
-#define del_body_type(p,TYPE,lctype) \
- del_body((void*)p, (void**)&PL_ ## lctype ## _root)
-
-/* But for some types, we cheat. The type starts with some members that are
- never accessed. So we allocate the substructure, starting at the first used
- member, then 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. */
-
-#define new_body_allocated(TYPE,lctype,member) \
- (void*)((char*)S_new_body(aTHX_ (void**)&PL_ ## lctype ## _arenaroot, \
- (void**)&PL_ ## lctype ## _root, \
- sizeof(lctype ## _allocated)) - \
- STRUCT_OFFSET(TYPE, member) \
- + STRUCT_OFFSET(lctype ## _allocated, member))
-
-
-#define del_body_allocated(p,TYPE,lctype,member) \
- del_body((void*)((char*)p + STRUCT_OFFSET(TYPE, member) \
- - STRUCT_OFFSET(lctype ## _allocated, member)), \
- (void**)&PL_ ## lctype ## _root)
-
-#define my_safemalloc(s) (void*)safemalloc(s)
-#define my_safefree(p) safefree((char*)p)
-
-#ifdef PURIFY
-
-#define new_XNV() my_safemalloc(sizeof(XPVNV))
-#define del_XNV(p) my_safefree(p)
-
-#define new_XPV() my_safemalloc(sizeof(XPV))
-#define del_XPV(p) my_safefree(p)
-
-#define new_XPVIV() my_safemalloc(sizeof(XPVIV))
-#define del_XPVIV(p) my_safefree(p)
-
-#define new_XPVNV() my_safemalloc(sizeof(XPVNV))
-#define del_XPVNV(p) my_safefree(p)
-
-#define new_XPVCV() my_safemalloc(sizeof(XPVCV))
-#define del_XPVCV(p) my_safefree(p)
-
-#define new_XPVAV() my_safemalloc(sizeof(XPVAV))
-#define del_XPVAV(p) my_safefree(p)
-
-#define new_XPVHV() my_safemalloc(sizeof(XPVHV))
-#define del_XPVHV(p) my_safefree(p)
-
-#define new_XPVMG() my_safemalloc(sizeof(XPVMG))
-#define del_XPVMG(p) my_safefree(p)
-
-#define new_XPVGV() my_safemalloc(sizeof(XPVGV))
-#define del_XPVGV(p) my_safefree(p)
-
-#define new_XPVLV() my_safemalloc(sizeof(XPVLV))
-#define del_XPVLV(p) my_safefree(p)
-
-#define new_XPVBM() my_safemalloc(sizeof(XPVBM))
-#define del_XPVBM(p) my_safefree(p)
-
-#else /* !PURIFY */
-
-#define new_XNV() new_body_type(NV, xnv)
-#define del_XNV(p) del_body_type(p, NV, xnv)
-
-#define new_XPV() new_body_allocated(XPV, xpv, xpv_cur)
-#define del_XPV(p) del_body_allocated(p, XPV, xpv, xpv_cur)
-
-#define new_XPVIV() new_body_allocated(XPVIV, xpviv, xpv_cur)
-#define del_XPVIV(p) del_body_allocated(p, XPVIV, xpviv, xpv_cur)
-
-#define new_XPVNV() new_body_type(XPVNV, xpvnv)
-#define del_XPVNV(p) del_body_type(p, XPVNV, xpvnv)
-
-#define new_XPVCV() new_body_type(XPVCV, xpvcv)
-#define del_XPVCV(p) del_body_type(p, XPVCV, xpvcv)
-
-#define new_XPVAV() new_body_allocated(XPVAV, xpvav, xav_fill)
-#define del_XPVAV(p) del_body_allocated(p, XPVAV, xpvav, xav_fill)
-
-#define new_XPVHV() new_body_allocated(XPVHV, xpvhv, xhv_fill)
-#define del_XPVHV(p) del_body_allocated(p, XPVHV, xpvhv, xhv_fill)
-
-#define new_XPVMG() new_body_type(XPVMG, xpvmg)
-#define del_XPVMG(p) del_body_type(p, XPVMG, xpvmg)
-
-#define new_XPVGV() new_body_type(XPVGV, xpvgv)
-#define del_XPVGV(p) del_body_type(p, XPVGV, xpvgv)
-
-#define new_XPVLV() new_body_type(XPVLV, xpvlv)
-#define del_XPVLV(p) del_body_type(p, XPVLV, xpvlv)
-
-#define new_XPVBM() new_body_type(XPVBM, xpvbm)
-#define del_XPVBM(p) del_body_type(p, XPVBM, xpvbm)
-
-#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
+=cut
*/
void
-Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt)
+Perl_sv_upgrade(pTHX_ register SV *sv, U32 new_type)
{
- void** old_body_arena;
- size_t old_body_offset;
- size_t old_body_length; /* Well, the length to copy. */
+ dVAR;
void* old_body;
-#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. */
- bool zero_nv = TRUE;
-#endif
void* new_body;
- size_t new_body_length;
- size_t new_body_offset;
- void** new_body_arena;
- void** new_body_arenaroot;
const U32 old_type = SvTYPE(sv);
+ const struct body_details *new_type_details;
+ const struct body_details *const old_type_details
+ = bodies_by_type + old_type;
- if (mt != SVt_PV && SvIsCOW(sv)) {
+ if (new_type != SVt_PV && SvIsCOW(sv)) {
sv_force_normal_flags(sv, 0);
}
- if (SvTYPE(sv) == mt)
+ if (old_type == new_type)
return;
- if (SvTYPE(sv) > mt)
+ if (old_type > new_type)
Perl_croak(aTHX_ "sv_upgrade from type %d down to type %d",
- (int)SvTYPE(sv), (int)mt);
+ (int)old_type, (int)new_type);
old_body = SvANY(sv);
- old_body_arena = 0;
- old_body_offset = 0;
- old_body_length = 0;
- new_body_offset = 0;
- new_body_length = ~0;
/* Copying structures onto other structures that have been neatly zeroed
has a subtle gotcha. Consider XPVMG
So we are careful and work out the size of used parts of all the
structures. */
- switch (SvTYPE(sv)) {
+ switch (old_type) {
case SVt_NULL:
break;
case SVt_IV:
- if (mt == SVt_NV)
- mt = SVt_PVNV;
- else if (mt < SVt_PVIV)
- mt = SVt_PVIV;
- old_body_offset = STRUCT_OFFSET(XPVIV, xiv_iv);
- old_body_length = sizeof(IV);
+ if (new_type < SVt_PVIV) {
+ new_type = (new_type == SVt_NV)
+ ? SVt_PVNV : SVt_PVIV;
+ }
break;
case SVt_NV:
- old_body_arena = (void **) &PL_xnv_root;
- old_body_length = sizeof(NV);
-#ifndef NV_ZERO_IS_ALLBITS_ZERO
- zero_nv = FALSE;
-#endif
- if (mt < SVt_PVNV)
- mt = SVt_PVNV;
+ if (new_type < SVt_PVNV) {
+ new_type = SVt_PVNV;
+ }
break;
case SVt_RV:
break;
case SVt_PV:
- old_body_arena = (void **) &PL_xpv_root;
- old_body_offset = STRUCT_OFFSET(XPV, xpv_cur)
- - STRUCT_OFFSET(xpv_allocated, xpv_cur);
- old_body_length = STRUCT_OFFSET(XPV, xpv_len)
- + sizeof (((XPV*)SvANY(sv))->xpv_len)
- - old_body_offset;
- if (mt <= SVt_IV)
- mt = SVt_PVIV;
- else if (mt == SVt_NV)
- mt = SVt_PVNV;
+ assert(new_type > SVt_PV);
+ assert(SVt_IV < SVt_PV);
+ assert(SVt_NV < SVt_PV);
break;
case SVt_PVIV:
- old_body_arena = (void **) &PL_xpviv_root;
- old_body_offset = STRUCT_OFFSET(XPVIV, xpv_cur)
- - STRUCT_OFFSET(xpviv_allocated, xpv_cur);
- old_body_length = STRUCT_OFFSET(XPVIV, xiv_u)
- + sizeof (((XPVIV*)SvANY(sv))->xiv_u)
- - old_body_offset;
break;
case SVt_PVNV:
- old_body_arena = (void **) &PL_xpvnv_root;
- old_body_length = STRUCT_OFFSET(XPVNV, xiv_u)
- + sizeof (((XPVNV*)SvANY(sv))->xiv_u);
-#ifndef NV_ZERO_IS_ALLBITS_ZERO
- zero_nv = FALSE;
-#endif
break;
case SVt_PVMG:
/* Because the XPVMG of PL_mess_sv isn't allocated from the arena,
/* 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);
- old_body_arena = (void **) &PL_xpvmg_root;
- old_body_length = STRUCT_OFFSET(XPVMG, xmg_stash)
- + sizeof (((XPVMG*)SvANY(sv))->xmg_stash);
-#ifndef NV_ZERO_IS_ALLBITS_ZERO
- zero_nv = FALSE;
-#endif
+ assert(!SvPAD_TYPED(sv));
break;
default:
- Perl_croak(aTHX_ "Can't upgrade that kind of scalar");
+ if (old_type_details->cant_upgrade)
+ Perl_croak(aTHX_ "Can't upgrade %s (%" UVuf ") to %" UVuf,
+ sv_reftype(sv, 0), (UV) old_type, (UV) new_type);
}
+ new_type_details = bodies_by_type + new_type;
SvFLAGS(sv) &= ~SVTYPEMASK;
- SvFLAGS(sv) |= mt;
+ SvFLAGS(sv) |= new_type;
- switch (mt) {
- case SVt_NULL:
- Perl_croak(aTHX_ "Can't upgrade to undef");
+ /* This can't happen, as SVt_NULL is <= all values of new_type, so one of
+ the return statements above will have triggered. */
+ assert (new_type != SVt_NULL);
+ switch (new_type) {
case SVt_IV:
assert(old_type == SVt_NULL);
SvANY(sv) = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
SvRV_set(sv, 0);
return;
case SVt_PVHV:
- SvANY(sv) = new_XPVHV();
- HvFILL(sv) = 0;
- HvMAX(sv) = 0;
- HvTOTALKEYS(sv) = 0;
-
- goto hv_av_common;
-
case SVt_PVAV:
- SvANY(sv) = new_XPVAV();
- AvMAX(sv) = -1;
- AvFILLp(sv) = -1;
- AvALLOC(sv) = 0;
- AvREAL_only(sv);
+ assert(new_type_details->body_size);
+
+#ifndef PURIFY
+ assert(new_type_details->arena);
+ assert(new_type_details->arena_size);
+ /* This points to the start of the allocated area. */
+ new_body_inline(new_body, new_type);
+ Zero(new_body, new_type_details->body_size, char);
+ new_body = ((char *)new_body) - new_type_details->offset;
+#else
+ /* We always allocated the full length item with PURIFY. To do this
+ we fake things so that arena is false for all 16 types.. */
+ new_body = new_NOARENAZ(new_type_details);
+#endif
+ SvANY(sv) = new_body;
+ if (new_type == SVt_PVAV) {
+ AvMAX(sv) = -1;
+ AvFILLp(sv) = -1;
+ 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.
/* Could put this in the else clause below, as PVMG must have SvPVX
0 already (the assertion above) */
- SvPV_set(sv, (char*)0);
+ SvPV_set(sv, NULL);
if (old_type >= SVt_PVMG) {
- SvMAGIC_set(sv, ((XPVMG*)old_body)->xmg_magic);
+ SvMAGIC_set(sv, ((XPVMG*)old_body)->xmg_u.xmg_magic);
SvSTASH_set(sv, ((XPVMG*)old_body)->xmg_stash);
- } else {
- SvMAGIC_set(sv, 0);
- SvSTASH_set(sv, 0);
}
break;
+
+ 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:
- new_body = new_XPVIO();
- new_body_length = sizeof(XPVIO);
- goto zero;
case SVt_PVFM:
- new_body = new_XPVFM();
- new_body_length = sizeof(XPVFM);
- goto zero;
-
case SVt_PVBM:
- new_body_length = sizeof(XPVBM);
- new_body_arena = (void **) &PL_xpvbm_root;
- new_body_arenaroot = (void **) &PL_xpvbm_arenaroot;
- goto new_body;
case SVt_PVGV:
- new_body_length = sizeof(XPVGV);
- new_body_arena = (void **) &PL_xpvgv_root;
- new_body_arenaroot = (void **) &PL_xpvgv_arenaroot;
- goto new_body;
case SVt_PVCV:
- new_body_length = sizeof(XPVCV);
- new_body_arena = (void **) &PL_xpvcv_root;
- new_body_arenaroot = (void **) &PL_xpvcv_arenaroot;
- goto new_body;
case SVt_PVLV:
- new_body_length = sizeof(XPVLV);
- new_body_arena = (void **) &PL_xpvlv_root;
- new_body_arenaroot = (void **) &PL_xpvlv_arenaroot;
- goto new_body;
case SVt_PVMG:
- new_body_length = sizeof(XPVMG);
- new_body_arena = (void **) &PL_xpvmg_root;
- new_body_arenaroot = (void **) &PL_xpvmg_arenaroot;
- goto new_body;
case SVt_PVNV:
- new_body_length = sizeof(XPVNV);
- new_body_arena = (void **) &PL_xpvnv_root;
- new_body_arenaroot = (void **) &PL_xpvnv_arenaroot;
- goto new_body;
- case SVt_PVIV:
- new_body_offset = STRUCT_OFFSET(XPVIV, xpv_cur)
- - STRUCT_OFFSET(xpviv_allocated, xpv_cur);
- new_body_length = sizeof(XPVIV) - new_body_offset;
- new_body_arena = (void **) &PL_xpviv_root;
- new_body_arenaroot = (void **) &PL_xpviv_arenaroot;
- /* XXX Is this still needed? Was it ever needed? Surely as there is
- no route from NV to PVIV, NOK can never be true */
- if (SvNIOK(sv))
- (void)SvIOK_on(sv);
- SvNOK_off(sv);
- goto new_body_no_NV;
case SVt_PV:
- new_body_offset = STRUCT_OFFSET(XPV, xpv_cur)
- - STRUCT_OFFSET(xpv_allocated, xpv_cur);
- new_body_length = sizeof(XPV) - new_body_offset;
- new_body_arena = (void **) &PL_xpv_root;
- new_body_arenaroot = (void **) &PL_xpv_arenaroot;
- new_body_no_NV:
- /* PV and PVIV don't have an NV slot. */
-#ifndef NV_ZERO_IS_ALLBITS_ZERO
- zero_nv = FALSE;
-#endif
-
- new_body:
- assert(new_body_length);
-#ifndef PURIFY
- /* This points to the start of the allocated area. */
- new_body_inline(new_body, new_body_arenaroot, new_body_arena,
- new_body_length);
-#else
- /* We always allocated the full length item with PURIFY */
- new_body_length += new_body_offset;
- new_body_offset = 0;
- new_body = my_safemalloc(new_body_length);
-#endif
- zero:
- Zero(new_body, new_body_length, char);
- new_body = ((char *)new_body) - new_body_offset;
+ assert(new_type_details->body_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);
+ Zero(new_body, new_type_details->body_size, char);
+ new_body = ((char *)new_body) - new_type_details->offset;
+ } else {
+ new_body = new_NOARENAZ(new_type_details);
+ }
SvANY(sv) = new_body;
- if (old_body_length) {
- Copy((char *)old_body + old_body_offset,
- (char *)new_body + old_body_offset,
- old_body_length, char);
+ if (old_type_details->copy) {
+ /* There is now the potential for an upgrade from something without
+ an offset (PVNV or PVMG) to something with one (PVCV, PVFM) */
+ int offset = old_type_details->offset;
+ int length = old_type_details->copy;
+
+ if (new_type_details->offset > old_type_details->offset) {
+ int difference
+ = new_type_details->offset - old_type_details->offset;
+ offset += difference;
+ length -= difference;
+ }
+ assert (length >= 0);
+
+ Copy((char *)old_body + offset, (char *)new_body + offset, length,
+ char);
}
#ifndef NV_ZERO_IS_ALLBITS_ZERO
- if (zero_nv)
+ /* If NV 0.0 is stores as all bits 0 then Zero() already creates a
+ * correct 0.0 for us. Otherwise, if the old body didn't have an
+ * NV slot, but the new one does, then we need to initialise the
+ * freshly created NV slot with whatever the correct bit pattern is
+ * for 0.0 */
+ if (old_type_details->zero_nv && !new_type_details->zero_nv)
SvNV_set(sv, 0);
#endif
- if (mt == SVt_PVIO)
- IoPAGE_LEN(sv) = 60;
+ if (new_type == SVt_PVIO)
+ IoPAGE_LEN(sv) = 60;
if (old_type < SVt_RV)
- SvPV_set(sv, 0);
+ SvPV_set(sv, NULL);
break;
default:
- Perl_croak(aTHX_ "panic: sv_upgrade to unknown type %lu", mt);
+ Perl_croak(aTHX_ "panic: sv_upgrade to unknown type %lu",
+ (unsigned long)new_type);
}
-
- if (old_body_arena) {
+ if (old_type_details->arena) {
+ /* If there was an old body, then we need to free it.
+ Note that there is an assumption that all bodies of types that
+ can be upgraded came from arenas. Only the more complex non-
+ upgradable types are allowed to be directly malloc()ed. */
#ifdef PURIFY
my_safefree(old_body);
#else
- del_body((void*)((char*)old_body + old_body_offset),
- old_body_arena);
+ del_body((void*)((char*)old_body + old_type_details->offset),
+ &PL_body_roots[old_type]);
#endif
}
}
int
Perl_sv_backoff(pTHX_ register SV *sv)
{
+ PERL_UNUSED_CONTEXT;
assert(SvOOK(sv));
assert(SvTYPE(sv) != SVt_PVHV);
assert(SvTYPE(sv) != SVt_PVAV);
{
register char *s;
+ if (PL_madskills && newlen >= 0x100000) {
+ PerlIO_printf(Perl_debug_log,
+ "Allocation too large: %"UVxf"\n", (UV)newlen);
+ }
#ifdef HAS_64K_LIMIT
if (newlen >= 0x10000) {
PerlIO_printf(Perl_debug_log,
void
Perl_sv_setiv(pTHX_ register SV *sv, IV i)
{
+ dVAR;
SV_CHECK_THINKFIRST_COW_DROP(sv);
switch (SvTYPE(sv)) {
case SVt_NULL:
void
Perl_sv_setnv(pTHX_ register SV *sv, NV num)
{
+ dVAR;
SV_CHECK_THINKFIRST_COW_DROP(sv);
switch (SvTYPE(sv)) {
case SVt_NULL:
STATIC void
S_not_a_number(pTHX_ SV *sv)
{
+ dVAR;
SV *dsv;
char tmpbuf[64];
const char *pv;
if (DO_UTF8(sv)) {
- dsv = sv_2mortal(newSVpvn("", 0));
+ dsv = sv_2mortal(newSVpvs(""));
pv = sv_uni_display(dsv, sv, 10, 0);
} else {
char *d = tmpbuf;
/* each *s can expand to 4 chars + "...\0",
i.e. need room for 8 chars */
- const char *s, *end;
- for (s = SvPVX_const(sv), end = s + SvCUR(sv); s < end && d < limit;
- s++) {
+ const char *s = SvPVX_const(sv);
+ const char * const end = s + SvCUR(sv);
+ for ( ; s < end && d < limit; s++ ) {
int ch = *s & 0xFF;
if (ch & 128 && !isPRINT_LC(ch)) {
*d++ = 'M';
return grok_number(sbegin, len, NULL);
}
+STATIC char *
+S_glob_2inpuv(pTHX_ GV *gv, STRLEN *len, bool want_number)
+{
+ const U32 wasfake = SvFLAGS(gv) & SVf_FAKE;
+ SV *const buffer = sv_newmortal();
+
+ /* FAKE globs can get coerced, so need to turn this off temporarily if it
+ is on. */
+ SvFAKE_off(gv);
+ gv_efullname3(buffer, gv, "*");
+ SvFLAGS(gv) |= wasfake;
+
+ if (want_number) {
+ /* We know that all GVs stringify to something that is not-a-number,
+ so no need to test that. */
+ if (ckWARN(WARN_NUMERIC))
+ not_a_number(buffer);
+ /* We just want something true to return, so that S_sv_2iuv_common
+ can tail call us and return true. */
+ return (char *) 1;
+ } else {
+ return SvPV(buffer, *len);
+ }
+}
+
/* Actually, ISO C leaves conversion of UV to IV undefined, but
until proven guilty, assume that things are not that bad... */
STATIC int
S_sv_2iuv_non_preserve(pTHX_ register SV *sv, I32 numtype)
{
+ dVAR;
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);
}
#endif /* !NV_PRESERVES_UV*/
-/*
-=for apidoc sv_2iv_flags
-
-Return the integer value of an SV, doing any necessary string
-conversion. If flags includes SV_GMAGIC, does an mg_get() first.
-Normally used via the C<SvIV(sv)> and C<SvIVx(sv)> macros.
-
-=cut
-*/
-
-IV
-Perl_sv_2iv_flags(pTHX_ register SV *sv, I32 flags)
-{
- if (!sv)
- return 0;
- if (SvGMAGICAL(sv)) {
- if (flags & SV_GMAGIC)
- mg_get(sv);
- if (SvIOKp(sv))
- return SvIVX(sv);
- if (SvNOKp(sv)) {
- return I_V(SvNVX(sv));
- }
- if (SvPOKp(sv) && SvLEN(sv))
- return asIV(sv);
- if (!SvROK(sv)) {
- if (!(SvFLAGS(sv) & SVs_PADTMP)) {
- if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
- report_uninit(sv);
- }
- return 0;
- }
- }
- if (SvTHINKFIRST(sv)) {
- if (SvROK(sv)) {
- if (SvAMAGIC(sv)) {
- SV * const tmpstr=AMG_CALLun(sv,numer);
- if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
- return SvIV(tmpstr);
- }
- }
- return PTR2IV(SvRV(sv));
- }
- if (SvIsCOW(sv)) {
- sv_force_normal_flags(sv, 0);
- }
- if (SvREADONLY(sv) && !SvOK(sv)) {
- if (ckWARN(WARN_UNINITIALIZED))
- report_uninit(sv);
- return 0;
- }
- }
- if (SvIOKp(sv)) {
- if (SvIsUV(sv)) {
- return (IV)(SvUVX(sv));
- }
- else {
- return SvIVX(sv);
- }
- }
+STATIC bool
+S_sv_2iuv_common(pTHX_ SV *sv) {
+ dVAR;
if (SvNOKp(sv)) {
/* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
* without also getting a cached IV/UV from it at the same time
* (ie PV->NV conversion should detect loss of accuracy and cache
- * IV or UV at same time to avoid this. NWC */
+ * IV or UV at same time to avoid this. */
+ /* IV-over-UV optimisation - choose to cache IV if possible */
if (SvTYPE(sv) == SVt_NV)
sv_upgrade(sv, SVt_PVNV);
)
SvIOK_on(sv);
SvIsUV_on(sv);
- ret_iv_max:
DEBUG_c(PerlIO_printf(Perl_debug_log,
"0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
PTR2UV(sv),
SvUVX(sv),
SvUVX(sv)));
- return (IV)SvUVX(sv);
}
}
else if (SvPOKp(sv) && SvLEN(sv)) {
UV value;
const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
- /* We want to avoid a possible problem when we cache an IV which
+ /* We want to avoid a possible problem when we cache an IV/ a UV which
may be later translated to an NV, and the resulting NV is not
the same as the direct translation of the initial string
(eg 123.456 can shortcut to the IV 123 with atol(), but we must
be careful to ensure that the value with the .456 is around if the
NV value is requested in the future).
- This means that if we cache such an IV, we need to cache the
+ This means that if we cache such an IV/a UV, we need to cache the
NV as well. Moreover, we trade speed for space, and do not
cache the NV if we are sure it's not needed.
*/
} 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
+ /* If NVs preserve UVs 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 (value <= (UV)IV_MAX) {
SvIV_set(sv, (IV)value);
} else {
+ /* it didn't overflow, and it was positive. */
SvUV_set(sv, value);
SvIsUV_on(sv);
}
PTR2UV(sv), SvNVX(sv)));
#endif
-
#ifdef NV_PRESERVES_UV
- (void)SvIOKp_on(sv);
- (void)SvNOK_on(sv);
- if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
- SvIV_set(sv, I_V(SvNVX(sv)));
- if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
- SvIOK_on(sv);
- } else {
- /* Integer is imprecise. NOK, IOKp */
- }
- /* UV will not work better than IV */
- } else {
- if (SvNVX(sv) > (NV)UV_MAX) {
- SvIsUV_on(sv);
- /* Integer is inaccurate. NOK, IOKp, is UV */
- SvUV_set(sv, UV_MAX);
- SvIsUV_on(sv);
- } else {
- SvUV_set(sv, U_V(SvNVX(sv)));
- /* 0xFFFFFFFFFFFFFFFF not an issue in here */
- if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
- SvIOK_on(sv);
- SvIsUV_on(sv);
- } else {
- /* Integer is imprecise. NOK, IOKp, is UV */
- SvIsUV_on(sv);
- }
- }
- goto ret_iv_max;
- }
+ (void)SvIOKp_on(sv);
+ (void)SvNOK_on(sv);
+ if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
+ SvIV_set(sv, I_V(SvNVX(sv)));
+ if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
+ SvIOK_on(sv);
+ } else {
+ /*EMPTY*/; /* Integer is imprecise. NOK, IOKp */
+ }
+ /* UV will not work better than IV */
+ } else {
+ if (SvNVX(sv) > (NV)UV_MAX) {
+ SvIsUV_on(sv);
+ /* Integer is inaccurate. NOK, IOKp, is UV */
+ SvUV_set(sv, UV_MAX);
+ } else {
+ SvUV_set(sv, U_V(SvNVX(sv)));
+ /* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs
+ NV preservse UV so can do correct comparison. */
+ if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
+ SvIOK_on(sv);
+ } else {
+ /*EMPTY*/; /* Integer is imprecise. NOK, IOKp, is UV */
+ }
+ }
+ SvIsUV_on(sv);
+ }
#else /* NV_PRESERVES_UV */
if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
== (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
- /* The IV slot will have been set from value returned by
+ /* The IV/UV slot will have been set from value returned by
grok_number above. The NV slot has just been set using
Atof. */
SvNOK_on(sv);
1 1 already read UV.
so there's no point in sv_2iuv_non_preserve() attempting
to use atol, strtol, strtoul etc. */
- if (sv_2iuv_non_preserve (sv, numtype)
- >= IS_NUMBER_OVERFLOW_IV)
- goto ret_iv_max;
+ sv_2iuv_non_preserve (sv, numtype);
}
}
#endif /* NV_PRESERVES_UV */
}
- } else {
- if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED))
- report_uninit(sv);
+ }
+ else {
+ if (isGV_with_GP(sv)) {
+ return (bool)PTR2IV(glob_2inpuv((GV *)sv, NULL, TRUE));
+ }
+
+ if (!(SvFLAGS(sv) & SVs_PADTMP)) {
+ if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
+ report_uninit(sv);
+ }
if (SvTYPE(sv) < SVt_IV)
/* Typically the caller expects that sv_any is not NULL now. */
sv_upgrade(sv, SVt_IV);
- return 0;
+ /* Return 0 from the caller. */
+ return TRUE;
}
- DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
- PTR2UV(sv),SvIVX(sv)));
- return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
+ return FALSE;
}
/*
-=for apidoc sv_2uv_flags
+=for apidoc sv_2iv_flags
-Return the unsigned integer value of an SV, doing any necessary string
+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<SvUV(sv)> and C<SvUVx(sv)> macros.
+Normally used via the C<SvIV(sv)> and C<SvIVx(sv)> macros.
=cut
*/
-UV
-Perl_sv_2uv_flags(pTHX_ register SV *sv, I32 flags)
+IV
+Perl_sv_2iv_flags(pTHX_ register SV *sv, I32 flags)
{
+ dVAR;
if (!sv)
return 0;
if (SvGMAGICAL(sv)) {
if (flags & SV_GMAGIC)
mg_get(sv);
if (SvIOKp(sv))
- return SvUVX(sv);
- if (SvNOKp(sv))
- return U_V(SvNVX(sv));
- if (SvPOKp(sv) && SvLEN(sv))
- return asUV(sv);
- if (!SvROK(sv)) {
- if (!(SvFLAGS(sv) & SVs_PADTMP)) {
- if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
- report_uninit(sv);
+ return 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;
+ }
}
- return 0;
+ if (!numtype) {
+ if (ckWARN(WARN_NUMERIC))
+ not_a_number(sv);
+ }
+ return I_V(Atof(SvPVX_const(sv)));
}
- }
- if (SvTHINKFIRST(sv)) {
+ if (SvROK(sv)) {
+ goto return_rok;
+ }
+ assert(SvTYPE(sv) >= SVt_PVMG);
+ /* This falls through to the report_uninit inside S_sv_2iuv_common. */
+ } else if (SvTHINKFIRST(sv)) {
if (SvROK(sv)) {
- SV* tmpstr;
- if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
- (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv))))
- return SvUV(tmpstr);
- return PTR2UV(SvRV(sv));
+ return_rok:
+ if (SvAMAGIC(sv)) {
+ SV * const tmpstr=AMG_CALLun(sv,numer);
+ if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
+ return SvIV(tmpstr);
+ }
+ }
+ return PTR2IV(SvRV(sv));
}
if (SvIsCOW(sv)) {
sv_force_normal_flags(sv, 0);
return 0;
}
}
- if (SvIOKp(sv)) {
- if (SvIsUV(sv)) {
- return SvUVX(sv);
- }
- else {
- return (UV)SvIVX(sv);
- }
+ if (!SvIOKp(sv)) {
+ if (S_sv_2iuv_common(aTHX_ sv))
+ return 0;
}
- if (SvNOKp(sv)) {
- /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
- * without also getting a cached IV/UV from it at the same time
- * (ie PV->NV conversion should detect loss of accuracy and cache
- * IV or UV at same time to avoid this. */
- /* IV-over-UV optimisation - choose to cache IV if possible */
+ DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
+ PTR2UV(sv),SvIVX(sv)));
+ return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
+}
- if (SvTYPE(sv) == SVt_NV)
- sv_upgrade(sv, SVt_PVNV);
+/*
+=for apidoc sv_2uv_flags
- (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
- if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
- SvIV_set(sv, I_V(SvNVX(sv)));
- if (SvNVX(sv) == (NV) SvIVX(sv)
-#ifndef NV_PRESERVES_UV
- && (((UV)1 << NV_PRESERVES_UV_BITS) >
- (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
- /* Don't flag it as "accurately an integer" if the number
- came from a (by definition imprecise) NV operation, and
- we're outside the range of NV integer precision */
-#endif
- ) {
- SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
- DEBUG_c(PerlIO_printf(Perl_debug_log,
- "0x%"UVxf" uv(%"NVgf" => %"IVdf") (precise)\n",
- PTR2UV(sv),
- SvNVX(sv),
- SvIVX(sv)));
+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.
- } else {
- /* IV not precise. No need to convert from PV, as NV
- conversion would already have cached IV if it detected
- that PV->IV would be better than PV->NV->IV
- flags already correct - don't set public IOK. */
- DEBUG_c(PerlIO_printf(Perl_debug_log,
- "0x%"UVxf" uv(%"NVgf" => %"IVdf") (imprecise)\n",
- PTR2UV(sv),
- SvNVX(sv),
- SvIVX(sv)));
+=cut
+*/
+
+UV
+Perl_sv_2uv_flags(pTHX_ register SV *sv, I32 flags)
+{
+ dVAR;
+ 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;
}
- /* 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 */
+ if (!numtype) {
+ if (ckWARN(WARN_NUMERIC))
+ not_a_number(sv);
+ }
+ return U_V(Atof(SvPVX_const(sv)));
}
- else {
- SvUV_set(sv, U_V(SvNVX(sv)));
- if (
- (SvNVX(sv) == (NV) SvUVX(sv))
-#ifndef NV_PRESERVES_UV
- /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
- /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
- && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
- /* Don't flag it as "accurately an integer" if the number
- came from a (by definition imprecise) NV operation, and
- we're outside the range of NV integer precision */
-#endif
- )
- SvIOK_on(sv);
- SvIsUV_on(sv);
- DEBUG_c(PerlIO_printf(Perl_debug_log,
- "0x%"UVxf" 2uv(%"UVuf" => %"IVdf") (as unsigned)\n",
- PTR2UV(sv),
- SvUVX(sv),
- SvUVX(sv)));
+ if (SvROK(sv)) {
+ goto return_rok;
}
- }
- else if (SvPOKp(sv) && SvLEN(sv)) {
- UV value;
- const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
-
- /* We want to avoid a possible problem when we cache a UV which
- may be later translated to an NV, and the resulting NV is not
- the translation of the initial data.
-
- This means that if we cache such a UV, we need to cache the
- NV as well. Moreover, we trade speed for space, and do not
- cache the NV if not needed.
- */
-
- /* SVt_PVNV is one higher than SVt_PVIV, hence this order */
- if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
- == IS_NUMBER_IN_UV) {
- /* It's definitely an integer, only upgrade to PVIV */
- if (SvTYPE(sv) < SVt_PVIV)
- sv_upgrade(sv, SVt_PVIV);
- (void)SvIOK_on(sv);
- } else if (SvTYPE(sv) < SVt_PVNV)
- sv_upgrade(sv, SVt_PVNV);
-
- /* If NV preserves UV then we only use the UV value if we know that
- we aren't going to call atof() below. If NVs don't preserve UVs
- then the value returned may have more precision than atof() will
- return, even though it isn't accurate. */
- if ((numtype & (IS_NUMBER_IN_UV
-#ifdef NV_PRESERVES_UV
- | IS_NUMBER_NOT_INT
-#endif
- )) == IS_NUMBER_IN_UV) {
- /* This won't turn off the public IOK flag if it was set above */
- (void)SvIOKp_on(sv);
-
- if (!(numtype & IS_NUMBER_NEG)) {
- /* positive */;
- if (value <= (UV)IV_MAX) {
- SvIV_set(sv, (IV)value);
- } else {
- /* it didn't overflow, and it was positive. */
- SvUV_set(sv, value);
- SvIsUV_on(sv);
- }
- } else {
- /* 2s complement assumption */
- if (value <= (UV)IV_MIN) {
- SvIV_set(sv, -(IV)value);
- } else {
- /* Too negative for an IV. This is a double upgrade, but
- I'm assuming it will be rare. */
- if (SvTYPE(sv) < SVt_PVNV)
- sv_upgrade(sv, SVt_PVNV);
- SvNOK_on(sv);
- SvIOK_off(sv);
- SvIOKp_on(sv);
- SvNV_set(sv, -(NV)value);
- SvIV_set(sv, IV_MIN);
+ 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 ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
- != IS_NUMBER_IN_UV) {
- /* It wasn't an integer, or it overflowed the UV. */
- SvNV_set(sv, Atof(SvPVX_const(sv)));
-
- if (! numtype && ckWARN(WARN_NUMERIC))
- not_a_number(sv);
-
-#if defined(USE_LONG_DOUBLE)
- DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%" PERL_PRIgldbl ")\n",
- PTR2UV(sv), SvNVX(sv)));
-#else
- DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"NVgf")\n",
- PTR2UV(sv), SvNVX(sv)));
-#endif
-
-#ifdef NV_PRESERVES_UV
- (void)SvIOKp_on(sv);
- (void)SvNOK_on(sv);
- if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
- SvIV_set(sv, I_V(SvNVX(sv)));
- if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
- SvIOK_on(sv);
- } else {
- /* Integer is imprecise. NOK, IOKp */
- }
- /* UV will not work better than IV */
- } else {
- if (SvNVX(sv) > (NV)UV_MAX) {
- SvIsUV_on(sv);
- /* Integer is inaccurate. NOK, IOKp, is UV */
- SvUV_set(sv, UV_MAX);
- SvIsUV_on(sv);
- } else {
- SvUV_set(sv, U_V(SvNVX(sv)));
- /* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs
- NV preservse UV so can do correct comparison. */
- if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
- SvIOK_on(sv);
- SvIsUV_on(sv);
- } else {
- /* Integer is imprecise. NOK, IOKp, is UV */
- SvIsUV_on(sv);
- }
- }
- }
-#else /* NV_PRESERVES_UV */
- if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
- == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
- /* The UV slot will have been set from value returned by
- grok_number above. The NV slot has just been set using
- Atof. */
- SvNOK_on(sv);
- assert (SvIOKp(sv));
- } else {
- if (((UV)1 << NV_PRESERVES_UV_BITS) >
- U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
- /* Small enough to preserve all bits. */
- (void)SvIOKp_on(sv);
- SvNOK_on(sv);
- SvIV_set(sv, I_V(SvNVX(sv)));
- if ((NV)(SvIVX(sv)) == SvNVX(sv))
- SvIOK_on(sv);
- /* Assumption: first non-preserved integer is < IV_MAX,
- this NV is in the preserved range, therefore: */
- if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
- < (UV)IV_MAX)) {
- Perl_croak(aTHX_ "sv_2uv assumed (U_V(fabs((double)SvNVX(sv))) < (UV)IV_MAX) but SvNVX(sv)=%"NVgf" U_V is 0x%"UVxf", IV_MAX is 0x%"UVxf"\n", SvNVX(sv), U_V(SvNVX(sv)), (UV)IV_MAX);
- }
- } else
- sv_2iuv_non_preserve (sv, numtype);
- }
-#endif /* NV_PRESERVES_UV */
+ if (SvIsCOW(sv)) {
+ sv_force_normal_flags(sv, 0);
}
- }
- else {
- if (!(SvFLAGS(sv) & SVs_PADTMP)) {
- if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
+ 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);
- 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",
NV
Perl_sv_2nv(pTHX_ register SV *sv)
{
+ dVAR;
if (!sv)
return 0.0;
if (SvGMAGICAL(sv)) {
mg_get(sv);
if (SvNOKp(sv))
return SvNVX(sv);
- if (SvPOKp(sv) && SvLEN(sv)) {
+ if ((SvPOKp(sv) && SvLEN(sv)) && !SvIOKp(sv)) {
if (!SvIOKp(sv) && ckWARN(WARN_NUMERIC) &&
!grok_number(SvPVX_const(sv), SvCUR(sv), NULL))
not_a_number(sv);
return (NV)SvUVX(sv);
else
return (NV)SvIVX(sv);
- }
- if (!SvROK(sv)) {
- if (!(SvFLAGS(sv) & SVs_PADTMP)) {
- if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
- report_uninit(sv);
- }
- return (NV)0;
- }
- }
- if (SvTHINKFIRST(sv)) {
+ }
+ if (SvROK(sv)) {
+ 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();
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 (isGV_with_GP(sv)) {
+ glob_2inpuv((GV *)sv, NULL, TRUE);
+ return 0.0;
+ }
+
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 */
+/* uiv_2buf(): private routine for use by sv_2pv_flags(): print an IV or
+ * UV as a string towards the end of buf, and return pointers to start and
+ * end of it.
+ *
+ * We assume that buf is at least TYPE_CHARS(UV) long.
+ */
-STATIC IV
-S_asIV(pTHX_ SV *sv)
+static char *
+S_uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
{
- UV value;
- const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
-
- if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
- == IS_NUMBER_IN_UV) {
- /* It's definitely an integer */
- if (numtype & IS_NUMBER_NEG) {
- if (value < (UV)IV_MIN)
- return -(IV)value;
- } else {
- if (value < (UV)IV_MAX)
- return (IV)value;
- }
- }
- if (!numtype) {
- if (ckWARN(WARN_NUMERIC))
- not_a_number(sv);
- }
- return I_V(Atof(SvPVX_const(sv)));
-}
-
-/* asUV(): extract an unsigned integer from the string value of an SV
- * Caller must validate PVX */
-
-STATIC UV
-S_asUV(pTHX_ SV *sv)
-{
- UV value;
- const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
-
- if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
- == IS_NUMBER_IN_UV) {
- /* It's definitely an integer */
- if (!(numtype & IS_NUMBER_NEG))
- return value;
- }
- if (!numtype) {
- if (ckWARN(WARN_NUMERIC))
- not_a_number(sv);
- }
- return U_V(Atof(SvPVX_const(sv)));
-}
-
-/* uiv_2buf(): private routine for use by sv_2pv_flags(): print an IV or
- * UV as a string towards the end of buf, and return pointers to start and
- * end of it.
- *
- * We assume that buf is at least TYPE_CHARS(UV) long.
- */
-
-static char *
-S_uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
-{
- char *ptr = buf + TYPE_CHARS(UV);
- char * const ebuf = ptr;
- int sign;
+ char *ptr = buf + TYPE_CHARS(UV);
+ char * const ebuf = ptr;
+ int sign;
if (is_uv)
sign = 0;
return ptr;
}
+/* stringify_regexp(): private routine for use by sv_2pv_flags(): converts
+ * a regexp to its stringified form.
+ */
+
+static char *
+S_stringify_regexp(pTHX_ SV *sv, MAGIC *mg, STRLEN *lp) {
+ dVAR;
+ 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;
+}
+
/*
=for apidoc sv_2pv_flags
char *
Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags)
{
+ dVAR;
register char *s;
- int olderrno;
- SV *tsv, *origsv;
- char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */
- char *tmpbuf = tbuf;
- STRLEN len = 0; /* Hush gcc. len is always initialised before use. */
if (!sv) {
if (lp)
return (char *)SvPVX_const(sv);
return SvPVX(sv);
}
- if (SvIOKp(sv)) {
- len = SvIsUV(sv) ? my_sprintf(tmpbuf,"%"UVuf, (UV)SvUVX(sv))
- : my_sprintf(tmpbuf,"%"IVdf, (IV)SvIVX(sv));
- tsv = Nullsv;
- goto tokensave_has_len;
+ if (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);
+ }
+ assert(!SvROK(sv));
+ {
+ dVAR;
+
+#ifdef FIXNEGATIVEZERO
+ if (len == 2 && tbuf[0] == '-' && tbuf[1] == '0') {
+ tbuf[0] = '0';
+ tbuf[1] = 0;
+ len = 1;
+ }
+#endif
+ SvUPGRADE(sv, SVt_PV);
+ if (lp)
+ *lp = len;
+ s = SvGROW_mutable(sv, len + 1);
+ SvCUR_set(sv, len);
+ SvPOKp_on(sv);
+ return memcpy(s, tbuf, len + 1);
+ }
}
- if (SvNOKp(sv)) {
- Gconvert(SvNVX(sv), NV_DIG, 0, tmpbuf);
- tsv = Nullsv;
- goto tokensave;
+ if (SvROK(sv)) {
+ goto return_rok;
}
- if (!SvROK(sv)) {
- if (!(SvFLAGS(sv) & SVs_PADTMP)) {
- if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
- report_uninit(sv);
- }
- if (lp)
- *lp = 0;
- return (char *)"";
- }
- }
- if (SvTHINKFIRST(sv)) {
+ assert(SvTYPE(sv) >= SVt_PVMG);
+ /* This falls through to the report_uninit near the end of the
+ function. */
+ } else if (SvTHINKFIRST(sv)) {
if (SvROK(sv)) {
- SV* tmpstr;
- register const char *typestr;
- if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)) &&
- (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
- /* Unwrap this: */
- /* char *pv = lp ? SvPV(tmpstr, *lp) : SvPV_nolen(tmpstr); */
-
- char *pv;
- if ((SvFLAGS(tmpstr) & (SVf_POK)) == SVf_POK) {
- if (flags & SV_CONST_RETURN) {
- pv = (char *) SvPVX_const(tmpstr);
+ return_rok:
+ if (SvAMAGIC(sv)) {
+ SV *const tmpstr = AMG_CALLun(sv,string);
+ if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
+ /* Unwrap this: */
+ /* char *pv = lp ? SvPV(tmpstr, *lp) : SvPV_nolen(tmpstr);
+ */
+
+ char *pv;
+ if ((SvFLAGS(tmpstr) & (SVf_POK)) == SVf_POK) {
+ if (flags & SV_CONST_RETURN) {
+ pv = (char *) SvPVX_const(tmpstr);
+ } else {
+ pv = (flags & SV_MUTABLE_RETURN)
+ ? SvPVX_mutable(tmpstr) : SvPVX(tmpstr);
+ }
+ if (lp)
+ *lp = SvCUR(tmpstr);
} else {
- pv = (flags & SV_MUTABLE_RETURN)
- ? SvPVX_mutable(tmpstr) : SvPVX(tmpstr);
+ pv = sv_2pv_flags(tmpstr, lp, flags);
}
- if (lp)
- *lp = SvCUR(tmpstr);
- } else {
- pv = sv_2pv_flags(tmpstr, lp, flags);
+ if (SvUTF8(tmpstr))
+ SvUTF8_on(sv);
+ else
+ SvUTF8_off(sv);
+ return pv;
}
- if (SvUTF8(tmpstr))
- SvUTF8_on(sv);
- else
- SvUTF8_off(sv);
- return pv;
- }
- origsv = sv;
- sv = (SV*)SvRV(sv);
- if (!sv)
- typestr = "NULLREF";
- else {
+ }
+ {
+ SV *tsv;
MAGIC *mg;
-
- switch (SvTYPE(sv)) {
- case SVt_PVMG:
- if ( ((SvFLAGS(sv) &
- (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
- == (SVs_OBJECT|SVs_SMG))
- && (mg = mg_find(sv, PERL_MAGIC_qr))) {
- const regexp *re = (regexp *)mg->mg_obj;
-
- if (!mg->mg_ptr) {
- const char *fptr = "msix";
- char reflags[6];
- char ch;
- int left = 0;
- int right = 4;
- char need_newline = 0;
- U16 reganch = (U16)((re->reganch & PMf_COMPILETIME) >> 12);
-
- while((ch = *fptr++)) {
- if(reganch & 1) {
- reflags[left++] = ch;
- }
- else {
- reflags[right--] = ch;
- }
- reganch >>= 1;
- }
- if(left != 4) {
- reflags[left] = '-';
- left = 5;
- }
-
- mg->mg_len = re->prelen + 4 + left;
- /*
- * If /x was used, we have to worry about a regex
- * ending with a comment later being embedded
- * within another regex. If so, we don't want this
- * regex's "commentization" to leak out to the
- * right part of the enclosing regex, we must cap
- * it with a newline.
- *
- * So, if /x was used, we scan backwards from the
- * end of the regex. If we find a '#' before we
- * find a newline, we need to add a newline
- * ourself. If we find a '\n' first (or if we
- * don't find '#' or '\n'), we don't need to add
- * anything. -jfriedl
- */
- if (PMf_EXTENDED & re->reganch)
- {
- const char *endptr = re->precomp + re->prelen;
- while (endptr >= re->precomp)
- {
- const char c = *(endptr--);
- if (c == '\n')
- break; /* don't need another */
- if (c == '#') {
- /* we end while in a comment, so we
- need a newline */
- mg->mg_len++; /* save space for it */
- need_newline = 1; /* note to add it */
- break;
- }
- }
- }
-
- Newx(mg->mg_ptr, mg->mg_len + 1 + left, char);
- Copy("(?", mg->mg_ptr, 2, char);
- Copy(reflags, mg->mg_ptr+2, left, char);
- Copy(":", mg->mg_ptr+left+2, 1, char);
- Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char);
- if (need_newline)
- mg->mg_ptr[mg->mg_len - 2] = '\n';
- mg->mg_ptr[mg->mg_len - 1] = ')';
- mg->mg_ptr[mg->mg_len] = 0;
- }
- PL_reginterp_cnt += re->program[0].next_off;
-
- if (re->reganch & ROPT_UTF8)
- SvUTF8_on(origsv);
- else
- SvUTF8_off(origsv);
- if (lp)
- *lp = mg->mg_len;
- return mg->mg_ptr;
+ const SV *const referent = (SV*)SvRV(sv);
+
+ if (!referent) {
+ tsv = sv_2mortal(newSVpvs("NULLREF"));
+ } 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 stringify_regexp(sv, mg, lp);
+ } else {
+ const char *const typestr = sv_reftype(referent, 0);
+
+ tsv = sv_newmortal();
+ if (SvOBJECT(referent)) {
+ const char *const name = HvNAME_get(SvSTASH(referent));
+ Perl_sv_setpvf(aTHX_ tsv, "%s=%s(0x%"UVxf")",
+ name ? name : "__ANON__" , typestr,
+ PTR2UV(referent));
}
- /* Fall through */
- case SVt_NULL:
- case SVt_IV:
- case SVt_NV:
- case SVt_RV:
- case SVt_PV:
- case SVt_PVIV:
- case SVt_PVNV:
- case SVt_PVBM: typestr = SvROK(sv) ? "REF" : "SCALAR"; break;
- case SVt_PVLV: typestr = SvROK(sv) ? "REF"
- /* tied lvalues should appear to be
- * scalars for backwards compatitbility */
- : (LvTYPE(sv) == 't' || LvTYPE(sv) == 'T')
- ? "SCALAR" : "LVALUE"; break;
- case SVt_PVAV: typestr = "ARRAY"; break;
- case SVt_PVHV: typestr = "HASH"; break;
- case SVt_PVCV: typestr = "CODE"; break;
- case SVt_PVGV: typestr = "GLOB"; break;
- case SVt_PVFM: typestr = "FORMAT"; break;
- case SVt_PVIO: typestr = "IO"; break;
- default: typestr = "UNKNOWN"; break;
- }
- tsv = NEWSV(0,0);
- if (SvOBJECT(sv)) {
- const char * const name = HvNAME_get(SvSTASH(sv));
- Perl_sv_setpvf(aTHX_ tsv, "%s=%s(0x%"UVxf")",
- name ? name : "__ANON__" , typestr, PTR2UV(sv));
+ else
+ Perl_sv_setpvf(aTHX_ tsv, "%s(0x%"UVxf")", typestr,
+ PTR2UV(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 (isGV_with_GP(sv)) {
+ return glob_2inpuv((GV *)sv, lp, FALSE);
+ }
+
if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED))
report_uninit(sv);
if (lp)
- *lp = 0;
+ *lp = 0;
if (SvTYPE(sv) < SVt_PV)
/* Typically the caller expects that sv_any is not NULL now. */
sv_upgrade(sv, SVt_PV);
if (flags & SV_MUTABLE_RETURN)
return SvPVX_mutable(sv);
return SvPVX(sv);
-
- tokensave:
- len = strlen(tmpbuf);
- tokensave_has_len:
- assert (!tsv);
- if (SvROK(sv)) { /* XXX Skip this when sv_pvn_force calls */
- /* Sneaky stuff here */
-
- tokensaveref:
- if (!tsv)
- tsv = newSVpvn(tmpbuf, len);
- sv_2mortal(tsv);
- if (lp)
- *lp = SvCUR(tsv);
- return SvPVX(tsv);
- }
- else {
- dVAR;
-
-#ifdef FIXNEGATIVEZERO
- if (len == 2 && tmpbuf[0] == '-' && tmpbuf[1] == '0') {
- tmpbuf[0] = '0';
- tmpbuf[1] = 0;
- len = 1;
- }
-#endif
- SvUPGRADE(sv, SVt_PV);
- if (lp)
- *lp = len;
- s = SvGROW_mutable(sv, len + 1);
- SvCUR_set(sv, len);
- SvPOKp_on(sv);
- return memcpy(s, tmpbuf, len + 1);
- }
}
/*
}
/*
- * =for apidoc sv_2pvutf8
- *
- * Return a pointer to the UTF-8-encoded representation of the SV, and set *lp
- * to its length. May cause the SV to be upgraded to UTF-8 as a side-effect.
- *
- * Usually accessed via the C<SvPVutf8> macro.
- *
- * =cut
- * */
+=for apidoc sv_2pvutf8
+
+Return a pointer to the UTF-8-encoded representation of the SV, and set *lp
+to its length. May cause the SV to be upgraded to UTF-8 as a side-effect.
+
+Usually accessed via the C<SvPVutf8> macro.
+
+=cut
+*/
char *
Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp)
{
- sv_utf8_upgrade(sv);
- return lp ? SvPV(sv,*lp) : SvPV_nolen(sv);
+ sv_utf8_upgrade(sv);
+ return lp ? SvPV(sv,*lp) : SvPV_nolen(sv);
}
bool
Perl_sv_2bool(pTHX_ register SV *sv)
{
+ dVAR;
SvGETMAGIC(sv);
if (!SvOK(sv))
return 0;
if (SvROK(sv)) {
- SV* tmpsv;
- if (SvAMAGIC(sv) && (tmpsv=AMG_CALLun(sv,bool_)) &&
- (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
- return (bool)SvTRUE(tmpsv);
- return SvRV(sv) != 0;
+ if (SvAMAGIC(sv)) {
+ SV * const tmpsv = AMG_CALLun(sv,bool_);
+ if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
+ return (bool)SvTRUE(tmpsv);
+ }
+ return SvRV(sv) != 0;
}
if (SvPOKp(sv)) {
register XPV* const Xpvtmp = (XPV*)SvANY(sv);
else {
if (SvNOKp(sv))
return SvNVX(sv) != 0.0;
- else
- return FALSE;
+ else {
+ if (isGV_with_GP(sv))
+ return TRUE;
+ else
+ return FALSE;
+ }
}
}
}
STRLEN
Perl_sv_utf8_upgrade_flags(pTHX_ register SV *sv, I32 flags)
{
+ dVAR;
if (sv == &PL_sv_undef)
return 0;
if (!SvPOK(sv)) {
* had a FLAG in SVs to signal if there are any hibit
* chars in the PV. Given that there isn't such a flag
* make the loop as fast as possible. */
- const U8 *s = (U8 *) SvPVX_const(sv);
+ const U8 * const s = (U8 *) SvPVX_const(sv);
const U8 * const e = (U8 *) SvEND(sv);
const U8 *t = s;
- int hibit = 0;
while (t < e) {
const U8 ch = *t++;
- if ((hibit = !NATIVE_IS_INVARIANT(ch)))
+ /* Check for hi bit */
+ if (!NATIVE_IS_INVARIANT(ch)) {
+ STRLEN len = SvCUR(sv) + 1; /* Plus the \0 */
+ U8 * const recoded = bytes_to_utf8((U8*)s, &len);
+
+ SvPV_free(sv); /* No longer using what was there before. */
+ SvPV_set(sv, (char*)recoded);
+ SvCUR_set(sv, len - 1);
+ SvLEN_set(sv, len); /* No longer know the real size. */
break;
- }
- if (hibit) {
- STRLEN len = SvCUR(sv) + 1; /* Plus the \0 */
- U8 * const recoded = bytes_to_utf8((U8*)s, &len);
-
- SvPV_free(sv); /* No longer using what was there before. */
-
- SvPV_set(sv, (char*)recoded);
- SvCUR_set(sv, len - 1);
- SvLEN_set(sv, len); /* No longer know the real size. */
+ }
}
/* Mark as UTF-8 even if no hibit - saves scanning loop */
SvUTF8_on(sv);
bool
Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok)
{
+ dVAR;
if (SvPOKp(sv) && SvUTF8(sv)) {
if (SvCUR(sv)) {
U8 *s;
=cut
*/
+static void
+S_glob_assign_glob(pTHX_ SV *dstr, SV *sstr, const int dtype)
+{
+ if (dtype != SVt_PVGV) {
+ const char * const name = GvNAME(sstr);
+ const STRLEN len = GvNAMELEN(sstr);
+ /* don't upgrade SVt_PVLV: it can hold a glob */
+ if (dtype != SVt_PVLV) {
+ if (dtype >= SVt_PV) {
+ SvPV_free(dstr);
+ SvPV_set(dstr, 0);
+ SvLEN_set(dstr, 0);
+ SvCUR_set(dstr, 0);
+ }
+ sv_upgrade(dstr, SVt_PVGV);
+ (void)SvOK_off(dstr);
+ SvSCREAM_on(dstr);
+ }
+ GvSTASH(dstr) = GvSTASH(sstr);
+ if (GvSTASH(dstr))
+ Perl_sv_add_backref(aTHX_ (SV*)GvSTASH(dstr), dstr);
+ gv_name_set((GV *)dstr, name, len, GV_ADD);
+ SvFAKE_on(dstr); /* can coerce to non-glob */
+ }
+
+#ifdef GV_UNIQUE_CHECK
+ if (GvUNIQUE((GV*)dstr)) {
+ Perl_croak(aTHX_ PL_no_modify);
+ }
+#endif
+
+ gp_free((GV*)dstr);
+ SvSCREAM_off(dstr);
+ (void)SvOK_off(dstr);
+ SvSCREAM_on(dstr);
+ GvINTRO_off(dstr); /* one-shot flag */
+ GvGP(dstr) = gp_ref(GvGP(sstr));
+ if (SvTAINTED(sstr))
+ SvTAINT(dstr);
+ if (GvIMPORTED(dstr) != GVf_IMPORTED
+ && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
+ {
+ GvIMPORTED_on(dstr);
+ }
+ GvMULTI_on(dstr);
+ return;
+}
+
+static void
+S_glob_assign_ref(pTHX_ SV *dstr, SV *sstr) {
+ SV * const sref = SvREFCNT_inc(SvRV(sstr));
+ SV *dref = NULL;
+ const int intro = GvINTRO(dstr);
+ SV **location;
+ U8 import_flag = 0;
+ const U32 stype = SvTYPE(sref);
+
+
+#ifdef GV_UNIQUE_CHECK
+ if (GvUNIQUE((GV*)dstr)) {
+ Perl_croak(aTHX_ PL_no_modify);
+ }
+#endif
+
+ if (intro) {
+ GvINTRO_off(dstr); /* one-shot flag */
+ GvLINE(dstr) = CopLINE(PL_curcop);
+ GvEGV(dstr) = (GV*)dstr;
+ }
+ GvMULTI_on(dstr);
+ switch (stype) {
+ case SVt_PVCV:
+ location = (SV **) &GvCV(dstr);
+ import_flag = GVf_IMPORTED_CV;
+ goto common;
+ case SVt_PVHV:
+ location = (SV **) &GvHV(dstr);
+ import_flag = GVf_IMPORTED_HV;
+ goto common;
+ case SVt_PVAV:
+ location = (SV **) &GvAV(dstr);
+ import_flag = GVf_IMPORTED_AV;
+ goto common;
+ case SVt_PVIO:
+ location = (SV **) &GvIOp(dstr);
+ goto common;
+ case SVt_PVFM:
+ location = (SV **) &GvFORM(dstr);
+ default:
+ location = &GvSV(dstr);
+ import_flag = GVf_IMPORTED_SV;
+ common:
+ if (intro) {
+ if (stype == SVt_PVCV) {
+ if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
+ SvREFCNT_dec(GvCV(dstr));
+ GvCV(dstr) = NULL;
+ GvCVGEN(dstr) = 0; /* Switch off cacheness. */
+ PL_sub_generation++;
+ }
+ }
+ SAVEGENERICSV(*location);
+ }
+ else
+ dref = *location;
+ if (stype == SVt_PVCV && *location != sref) {
+ CV* const cv = (CV*)*location;
+ if (cv) {
+ if (!GvCVGEN((GV*)dstr) &&
+ (CvROOT(cv) || CvXSUB(cv)))
+ {
+ /* Redefining a sub - warning is mandatory if
+ it was a const and its value changed. */
+ if (CvCONST(cv) && CvCONST((CV*)sref)
+ && cv_const_sv(cv) == cv_const_sv((CV*)sref)) {
+ /*EMPTY*/
+ /* They are 2 constant subroutines generated from
+ the same constant. This probably means that
+ they are really the "same" proxy subroutine
+ instantiated in 2 places. Most likely this is
+ when a constant is exported twice. Don't warn.
+ */
+ }
+ else if (ckWARN(WARN_REDEFINE)
+ || (CvCONST(cv)
+ && (!CvCONST((CV*)sref)
+ || sv_cmp(cv_const_sv(cv),
+ cv_const_sv((CV*)sref))))) {
+ Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
+ CvCONST(cv)
+ ? "Constant subroutine %s::%s redefined"
+ : "Subroutine %s::%s redefined",
+ HvNAME_get(GvSTASH((GV*)dstr)),
+ GvENAME((GV*)dstr));
+ }
+ }
+ if (!intro)
+ cv_ckproto(cv, (GV*)dstr,
+ SvPOK(sref) ? SvPVX_const(sref) : NULL);
+ }
+ GvCVGEN(dstr) = 0; /* Switch off cacheness. */
+ GvASSUMECV_on(dstr);
+ PL_sub_generation++;
+ }
+ *location = sref;
+ if (import_flag && !(GvFLAGS(dstr) & import_flag)
+ && CopSTASH_ne(PL_curcop, GvSTASH(dstr))) {
+ GvFLAGS(dstr) |= import_flag;
+ }
+ break;
+ }
+ SvREFCNT_dec(dref);
+ if (SvTAINTED(sstr))
+ SvTAINT(dstr);
+ return;
+}
+
void
Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
{
+ dVAR;
register U32 sflags;
register int dtype;
register int stype;
sv_upgrade(dstr, SVt_IV);
break;
case SVt_NV:
- sv_upgrade(dstr, SVt_PVNV);
- break;
case SVt_RV:
case SVt_PV:
sv_upgrade(dstr, SVt_PVIV);
SvIV_set(dstr, SvIVX(sstr));
if (SvIsUV(sstr))
SvIsUV_on(dstr);
- if (SvTAINTED(sstr))
- SvTAINT(dstr);
+ /* SvTAINTED can only be true if the SV has taint magic, which in
+ turn means that the SV type is PVMG (or greater). This is the
+ case statement for SVt_IV, so this cannot be true (whatever gcov
+ may say). */
+ assert(!SvTAINTED(sstr));
return;
}
goto undef_sstr;
}
SvNV_set(dstr, SvNVX(sstr));
(void)SvNOK_only(dstr);
- if (SvTAINTED(sstr))
- SvTAINT(dstr);
+ /* SvTAINTED can only be true if the SV has taint magic, which in
+ turn means that the SV type is PVMG (or greater). This is the
+ case statement for SVt_NV, so this cannot be true (whatever gcov
+ may say). */
+ assert(!SvTAINTED(sstr));
return;
}
goto undef_sstr;
case SVt_RV:
if (dtype < SVt_RV)
sv_upgrade(dstr, SVt_RV);
- else if (dtype == SVt_PVGV &&
- SvROK(sstr) && SvTYPE(SvRV(sstr)) == SVt_PVGV) {
- sstr = SvRV(sstr);
- if (sstr == dstr) {
- if (GvIMPORTED(dstr) != GVf_IMPORTED
- && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
- {
- GvIMPORTED_on(dstr);
- }
- GvMULTI_on(dstr);
- return;
- }
- goto glob_assign;
- }
break;
case SVt_PVFM:
#ifdef PERL_OLD_COPY_ON_WRITE
if (dtype < SVt_PVNV)
sv_upgrade(dstr, SVt_PVNV);
break;
- case SVt_PVAV:
- case SVt_PVHV:
- case SVt_PVCV:
- case SVt_PVIO:
+ default:
{
const char * const type = sv_reftype(sstr,0);
if (PL_op)
case SVt_PVGV:
if (dtype <= SVt_PVGV) {
- glob_assign:
- if (dtype != SVt_PVGV) {
- const char * const name = GvNAME(sstr);
- const STRLEN len = GvNAMELEN(sstr);
- /* don't upgrade SVt_PVLV: it can hold a glob */
- if (dtype != SVt_PVLV)
- sv_upgrade(dstr, SVt_PVGV);
- sv_magic(dstr, dstr, PERL_MAGIC_glob, Nullch, 0);
- 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 */
- }
-
-#ifdef GV_UNIQUE_CHECK
- if (GvUNIQUE((GV*)dstr)) {
- Perl_croak(aTHX_ PL_no_modify);
- }
-#endif
-
- (void)SvOK_off(dstr);
- GvINTRO_off(dstr); /* one-shot flag */
- gp_free((GV*)dstr);
- GvGP(dstr) = gp_ref(GvGP(sstr));
- if (SvTAINTED(sstr))
- SvTAINT(dstr);
- if (GvIMPORTED(dstr) != GVf_IMPORTED
- && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
- {
- GvIMPORTED_on(dstr);
- }
- GvMULTI_on(dstr);
+ S_glob_assign_glob(aTHX_ dstr, sstr, dtype);
return;
}
- /* FALL THROUGH */
+ /*FALLTHROUGH*/
- default:
+ case SVt_PVMG:
+ case SVt_PVLV:
+ case SVt_PVBM:
if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) {
mg_get(sstr);
if ((int)SvTYPE(sstr) != stype) {
stype = SvTYPE(sstr);
- if (stype == SVt_PVGV && dtype <= SVt_PVGV)
- goto glob_assign;
+ if (stype == SVt_PVGV && dtype <= SVt_PVGV) {
+ S_glob_assign_glob(aTHX_ dstr, sstr, dtype);
+ return;
+ }
}
}
if (stype == SVt_PVLV)
SvUPGRADE(dstr, (U32)stype);
}
+ /* dstr may have been upgraded. */
+ dtype = SvTYPE(dstr);
sflags = SvFLAGS(sstr);
if (sflags & SVf_ROK) {
- if (dtype >= SVt_PV) {
- if (dtype == SVt_PVGV) {
- SV * const sref = SvREFCNT_inc(SvRV(sstr));
- SV *dref = 0;
- const int intro = GvINTRO(dstr);
-
-#ifdef GV_UNIQUE_CHECK
- if (GvUNIQUE((GV*)dstr)) {
- Perl_croak(aTHX_ PL_no_modify);
- }
-#endif
-
- if (intro) {
- GvINTRO_off(dstr); /* one-shot flag */
- GvLINE(dstr) = CopLINE(PL_curcop);
- GvEGV(dstr) = (GV*)dstr;
+ if (dtype == SVt_PVGV &&
+ SvROK(sstr) && SvTYPE(SvRV(sstr)) == SVt_PVGV) {
+ sstr = SvRV(sstr);
+ if (sstr == dstr) {
+ if (GvIMPORTED(dstr) != GVf_IMPORTED
+ && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
+ {
+ GvIMPORTED_on(dstr);
}
GvMULTI_on(dstr);
- switch (SvTYPE(sref)) {
- case SVt_PVAV:
- if (intro)
- SAVEGENERICSV(GvAV(dstr));
- else
- dref = (SV*)GvAV(dstr);
- GvAV(dstr) = (AV*)sref;
- if (!GvIMPORTED_AV(dstr)
- && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
- {
- GvIMPORTED_AV_on(dstr);
- }
- break;
- case SVt_PVHV:
- if (intro)
- SAVEGENERICSV(GvHV(dstr));
- else
- dref = (SV*)GvHV(dstr);
- GvHV(dstr) = (HV*)sref;
- if (!GvIMPORTED_HV(dstr)
- && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
- {
- GvIMPORTED_HV_on(dstr);
- }
- break;
- case SVt_PVCV:
- if (intro) {
- if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
- SvREFCNT_dec(GvCV(dstr));
- GvCV(dstr) = Nullcv;
- GvCVGEN(dstr) = 0; /* Switch off cacheness. */
- PL_sub_generation++;
- }
- SAVEGENERICSV(GvCV(dstr));
- }
- else
- dref = (SV*)GvCV(dstr);
- if (GvCV(dstr) != (CV*)sref) {
- CV* const cv = GvCV(dstr);
- if (cv) {
- if (!GvCVGEN((GV*)dstr) &&
- (CvROOT(cv) || CvXSUB(cv)))
- {
- /* Redefining a sub - warning is mandatory if
- it was a const and its value changed. */
- if (ckWARN(WARN_REDEFINE)
- || (CvCONST(cv)
- && (!CvCONST((CV*)sref)
- || sv_cmp(cv_const_sv(cv),
- cv_const_sv((CV*)sref)))))
- {
- Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
- CvCONST(cv)
- ? "Constant subroutine %s::%s redefined"
- : "Subroutine %s::%s redefined",
- HvNAME_get(GvSTASH((GV*)dstr)),
- GvENAME((GV*)dstr));
- }
- }
- if (!intro)
- cv_ckproto(cv, (GV*)dstr,
- SvPOK(sref)
- ? SvPVX_const(sref) : Nullch);
- }
- GvCV(dstr) = (CV*)sref;
- GvCVGEN(dstr) = 0; /* Switch off cacheness. */
- GvASSUMECV_on(dstr);
- PL_sub_generation++;
- }
- if (!GvIMPORTED_CV(dstr)
- && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
- {
- GvIMPORTED_CV_on(dstr);
- }
- break;
- case SVt_PVIO:
- if (intro)
- SAVEGENERICSV(GvIOp(dstr));
- else
- dref = (SV*)GvIOp(dstr);
- GvIOp(dstr) = (IO*)sref;
- break;
- case SVt_PVFM:
- if (intro)
- SAVEGENERICSV(GvFORM(dstr));
- else
- dref = (SV*)GvFORM(dstr);
- GvFORM(dstr) = (CV*)sref;
- break;
- default:
- if (intro)
- SAVEGENERICSV(GvSV(dstr));
- else
- dref = (SV*)GvSV(dstr);
- GvSV(dstr) = sref;
- if (!GvIMPORTED_SV(dstr)
- && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
- {
- GvIMPORTED_SV_on(dstr);
- }
- break;
- }
- if (dref)
- SvREFCNT_dec(dref);
- if (SvTAINTED(sstr))
- SvTAINT(dstr);
+ return;
+ }
+ S_glob_assign_glob(aTHX_ dstr, sstr, dtype);
+ return;
+ }
+
+ if (dtype >= SVt_PV) {
+ if (dtype == SVt_PVGV) {
+ S_glob_assign_ref(aTHX_ dstr, sstr);
return;
}
if (SvPVX_const(dstr)) {
}
(void)SvOK_off(dstr);
SvRV_set(dstr, SvREFCNT_inc(SvRV(sstr)));
- SvROK_on(dstr);
- if (sflags & SVp_NOK) {
- SvNOKp_on(dstr);
- /* Only set the public OK flag if the source has public OK. */
- if (sflags & SVf_NOK)
- SvFLAGS(dstr) |= SVf_NOK;
- SvNV_set(dstr, SvNVX(sstr));
- }
- if (sflags & SVp_IOK) {
- (void)SvIOKp_on(dstr);
- if (sflags & SVf_IOK)
- SvFLAGS(dstr) |= SVf_IOK;
- if (sflags & SVf_IVisUV)
- SvIsUV_on(dstr);
- SvIV_set(dstr, SvIVX(sstr));
+ SvFLAGS(dstr) |= sflags & (SVf_ROK|SVf_AMAGIC);
+ assert(!(sflags & SVp_NOK));
+ assert(!(sflags & SVp_IOK));
+ assert(!(sflags & SVf_NOK));
+ assert(!(sflags & SVf_IOK));
+ }
+ else if (dtype == SVt_PVGV) {
+ if (!(sflags & SVf_OK)) {
+ if (ckWARN(WARN_MISC))
+ Perl_warner(aTHX_ packWARN(WARN_MISC),
+ "Undefined value assigned to typeglob");
}
- if (SvAMAGIC(sstr)) {
- SvAMAGIC_on(dstr);
+ else {
+ GV *gv = gv_fetchsv(sstr, GV_ADD, SVt_PVGV);
+ if (dstr != (SV*)gv) {
+ if (GvGP(dstr))
+ gp_free((GV*)dstr);
+ GvGP(dstr) = gp_ref(GvGP(gv));
+ }
}
}
else if (sflags & SVp_POK) {
SvTEMP_off(dstr);
(void)SvOK_off(sstr); /* NOTE: nukes most SvFLAGS on sstr */
- SvPV_set(sstr, Nullch);
+ SvPV_set(sstr, NULL);
SvLEN_set(sstr, 0);
SvCUR_set(sstr, 0);
SvTEMP_off(sstr);
}
}
- if (sflags & SVf_UTF8)
- SvUTF8_on(dstr);
if (sflags & SVp_NOK) {
- SvNOKp_on(dstr);
- if (sflags & SVf_NOK)
- SvFLAGS(dstr) |= SVf_NOK;
SvNV_set(dstr, SvNVX(sstr));
}
if (sflags & SVp_IOK) {
- (void)SvIOKp_on(dstr);
- if (sflags & SVf_IOK)
- SvFLAGS(dstr) |= SVf_IOK;
+ SvRELEASE_IVX(dstr);
+ SvIV_set(dstr, SvIVX(sstr));
+ /* Must do this otherwise some other overloaded use of 0x80000000
+ gets confused. I guess SVpbm_VALID */
if (sflags & SVf_IVisUV)
SvIsUV_on(dstr);
- SvIV_set(dstr, SvIVX(sstr));
}
- if (SvVOK(sstr)) {
- MAGIC *smg = mg_find(sstr,PERL_MAGIC_vstring);
- sv_magic(dstr, NULL, PERL_MAGIC_vstring,
- smg->mg_ptr, smg->mg_len);
- SvRMAGICAL_on(dstr);
+ SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_NOK|SVp_NOK|SVf_UTF8);
+ {
+ const MAGIC * const smg = SvVOK(sstr);
+ if (smg) {
+ sv_magic(dstr, NULL, PERL_MAGIC_vstring,
+ smg->mg_ptr, smg->mg_len);
+ SvRMAGICAL_on(dstr);
+ }
}
}
- else if (sflags & SVp_IOK) {
- if (sflags & SVf_IOK)
- (void)SvIOK_only(dstr);
- else {
- (void)SvOK_off(dstr);
- (void)SvIOKp_on(dstr);
+ else if (sflags & (SVp_IOK|SVp_NOK)) {
+ (void)SvOK_off(dstr);
+ SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_IVisUV|SVf_NOK|SVp_NOK);
+ if (sflags & SVp_IOK) {
+ /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
+ SvIV_set(dstr, SvIVX(sstr));
}
- /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
- if (sflags & SVf_IVisUV)
- SvIsUV_on(dstr);
- SvIV_set(dstr, SvIVX(sstr));
if (sflags & SVp_NOK) {
- if (sflags & SVf_NOK)
- (void)SvNOK_on(dstr);
- else
- (void)SvNOKp_on(dstr);
SvNV_set(dstr, SvNVX(sstr));
}
}
- else if (sflags & SVp_NOK) {
- if (sflags & SVf_NOK)
- (void)SvNOK_only(dstr);
- else {
- (void)SvOK_off(dstr);
- SvNOKp_on(dstr);
- }
- SvNV_set(dstr, SvNVX(sstr));
- }
else {
- if (dtype == SVt_PVGV) {
- if (ckWARN(WARN_MISC))
- Perl_warner(aTHX_ packWARN(WARN_MISC), "Undefined value assigned to typeglob");
+ if (isGV_with_GP(sstr)) {
+ /* This stringification rule for globs is spread in 3 places.
+ This feels bad. FIXME. */
+ const U32 wasfake = sflags & SVf_FAKE;
+
+ /* FAKE globs can get coerced, so need to turn this off
+ temporarily if it is on. */
+ SvFAKE_off(sstr);
+ gv_efullname3(dstr, (GV *)sstr, "*");
+ SvFLAGS(sstr) |= wasfake;
}
else
(void)SvOK_off(dstr);
void
Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
{
+ dVAR;
register char *dptr;
SV_CHECK_THINKFIRST_COW_DROP(sv);
void
Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr)
{
+ dVAR;
register STRLEN len;
SV_CHECK_THINKFIRST_COW_DROP(sv);
void
Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
{
+ dVAR;
STRLEN allocate;
SV_CHECK_THINKFIRST_COW_DROP(sv);
SvUPGRADE(sv, SVt_PV);
{
if (len) { /* this SV was SvIsCOW_normal(sv) */
/* we need to find the SV pointing to us. */
- SV * const current = SV_COW_NEXT_SV(after);
+ SV *current = SV_COW_NEXT_SV(after);
if (current == sv) {
/* The SV we point to points back to us (there were only two of us
void
Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags)
{
+ dVAR;
#ifdef PERL_OLD_COPY_ON_WRITE
if (SvREADONLY(sv)) {
/* At this point I believe I should acquire a global SV mutex. */
SvFAKE_off(sv);
SvREADONLY_off(sv);
/* This SV doesn't own the buffer, so need to Newx() a new one: */
- SvPV_set(sv, (char*)0);
+ SvPV_set(sv, NULL);
SvLEN_set(sv, 0);
if (flags & SV_COW_DROP_PV) {
/* OK, so we don't need to copy our buffer. */
const STRLEN len = SvCUR(sv);
SvFAKE_off(sv);
SvREADONLY_off(sv);
- SvPV_set(sv, Nullch);
+ SvPV_set(sv, NULL);
SvLEN_set(sv, 0);
SvGROW(sv, len + 1);
Move(pvx,SvPVX(sv),len,char);
void
Perl_sv_catpvn_flags(pTHX_ register SV *dsv, register const char *sstr, register STRLEN slen, I32 flags)
{
+ dVAR;
STRLEN dlen;
- const char *dstr = SvPV_force_flags(dsv, dlen, flags);
+ const char * const dstr = SvPV_force_flags(dsv, dlen, flags);
SvGROW(dsv, dlen + slen + 1);
if (sstr == dstr)
void
Perl_sv_catsv_flags(pTHX_ SV *dsv, register SV *ssv, I32 flags)
{
- const char *spv;
- STRLEN slen;
+ dVAR;
if (ssv) {
- if ((spv = SvPV_const(ssv, slen))) {
+ STRLEN slen;
+ const char *spv = SvPV_const(ssv, slen);
+ if (spv) {
/* sutf8 and dutf8 were type bool, but under USE_ITHREADS,
gcc version 2.95.2 20000220 (Debian GNU/Linux) for
Linux xxx 2.2.17 on sparc64 with gcc -O2, we erroneously
if (dutf8 != sutf8) {
if (dutf8) {
/* Not modifying source SV, so taking a temporary copy. */
- SV* csv = sv_2mortal(newSVpvn(spv, slen));
+ SV* const csv = sv_2mortal(newSVpvn(spv, slen));
sv_utf8_upgrade(csv);
spv = SvPV_const(csv, slen);
void
Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr)
{
+ dVAR;
register STRLEN len;
STRLEN tlen;
char *junk;
/*
=for apidoc newSV
-Create a new null SV, or if len > 0, create a new empty SVt_PV type SV
-with an initial PV allocation of len+1. Normally accessed via the C<NEWSV>
-macro.
+Creates a new SV. A non-zero C<len> parameter indicates the number of
+bytes of preallocated string space the SV should have. An extra byte for a
+trailing NUL is also reserved. (SvPOK is not set for the SV even if string
+space is allocated.) The reference count for the new SV is set to 1.
+
+In 5.9.3, newSV() replaces the older NEWSV() API, and drops the first
+parameter, I<x>, a debug aid which allowed callers to identify themselves.
+This aid has been superseded by a new build option, PERL_MEM_LOG (see
+L<perlhack/PERL_MEM_LOG>). The older API is still there for use in XS
+modules supporting older perls.
=cut
*/
SV *
Perl_newSV(pTHX_ STRLEN len)
{
+ dVAR;
register SV *sv;
new_SV(sv);
=cut
*/
MAGIC *
-Perl_sv_magicext(pTHX_ SV* sv, SV* obj, int how, const MGVTBL *vtable,
+Perl_sv_magicext(pTHX_ SV* sv, SV* obj, int how, MGVTBL *vtable,
const char* name, I32 namlen)
{
+ dVAR;
MAGIC* mg;
if (SvTYPE(sv) < SVt_PVMG) {
mg->mg_obj = obj;
}
else {
- mg->mg_obj = SvREFCNT_inc(obj);
+ mg->mg_obj = SvREFCNT_inc_simple(obj);
mg->mg_flags |= MGf_REFCOUNTED;
}
if (namlen > 0)
mg->mg_ptr = savepvn(name, namlen);
else if (namlen == HEf_SVKEY)
- mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
+ mg->mg_ptr = (char*)SvREFCNT_inc_simple_NN((SV*)name);
else
mg->mg_ptr = (char *) name;
}
void
Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
{
- const MGVTBL *vtable;
+ dVAR;
+ MGVTBL *vtable;
MAGIC* mg;
#ifdef PERL_OLD_COPY_ON_WRITE
/* sv_magic() refuses to add a magic of the same 'how' as an
existing one
*/
- if (how == PERL_MAGIC_taint)
+ if (how == PERL_MAGIC_taint) {
mg->mg_len |= 1;
+ /* Any scalar which already had taint magic on which someone
+ (erroneously?) did SvIOK_on() or similar will now be
+ incorrectly sporting public "OK" flags. */
+ SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
+ }
return;
}
}
case PERL_MAGIC_defelem:
vtable = &PL_vtbl_defelem;
break;
- case PERL_MAGIC_glob:
- vtable = &PL_vtbl_glob;
- break;
case PERL_MAGIC_arylen:
vtable = &PL_vtbl_arylen;
break;
MAGIC** mgp;
if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
return 0;
- mgp = &SvMAGIC(sv);
+ mgp = &(((XPVMG*) SvANY(sv))->xmg_u.xmg_magic);
for (mg = *mgp; mg; mg = *mgp) {
if (mg->mg_type == type) {
const MGVTBL* const vtbl = mg->mg_virtual;
}
if (!SvMAGIC(sv)) {
SvMAGICAL_off(sv);
- SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_NOK|SVp_POK)) >> PRIVSHIFT;
+ SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
+ SvMAGIC_set(sv, NULL);
}
return 0;
void
Perl_sv_add_backref(pTHX_ SV *tsv, SV *sv)
{
+ dVAR;
AV *av;
- MAGIC *mg;
- if (SvMAGICAL(tsv) && (mg = mg_find(tsv, PERL_MAGIC_backref)))
- av = (AV*)mg->mg_obj;
- else {
- av = newAV();
- sv_magic(tsv, (SV*)av, PERL_MAGIC_backref, NULL, 0);
- /* av now has a refcnt of 2, which avoids it getting freed
- * before us during global cleanup. The extra ref is removed
- * by magic_killbackrefs() when tsv is being freed */
+
+ if (SvTYPE(tsv) == SVt_PVHV) {
+ AV **const avp = Perl_hv_backreferences_p(aTHX_ (HV*)tsv);
+
+ av = *avp;
+ if (!av) {
+ /* There is no AV in the offical place - try a fixup. */
+ MAGIC *const mg = mg_find(tsv, PERL_MAGIC_backref);
+
+ if (mg) {
+ /* Aha. They've got it stowed in magic. Bring it back. */
+ av = (AV*)mg->mg_obj;
+ /* Stop mg_free decreasing the refernce count. */
+ mg->mg_obj = NULL;
+ /* Stop mg_free even calling the destructor, given that
+ there's no AV to free up. */
+ mg->mg_virtual = 0;
+ sv_unmagic(tsv, PERL_MAGIC_backref);
+ } else {
+ av = newAV();
+ AvREAL_off(av);
+ SvREFCNT_inc_simple_void(av);
+ }
+ *avp = av;
+ }
+ } else {
+ const MAGIC *const mg
+ = SvMAGICAL(tsv) ? mg_find(tsv, PERL_MAGIC_backref) : NULL;
+ if (mg)
+ av = (AV*)mg->mg_obj;
+ else {
+ av = newAV();
+ AvREAL_off(av);
+ sv_magic(tsv, (SV*)av, PERL_MAGIC_backref, NULL, 0);
+ /* av now has a refcnt of 2, which avoids it getting freed
+ * before us during global cleanup. The extra ref is removed
+ * by magic_killbackrefs() when tsv is being freed */
+ }
}
if (AvFILLp(av) >= AvMAX(av)) {
av_extend(av, AvFILLp(av)+1);
STATIC void
S_sv_del_backref(pTHX_ SV *tsv, SV *sv)
{
- AV *av;
+ dVAR;
+ AV *av = NULL;
SV **svp;
I32 i;
- MAGIC *mg = NULL;
- if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, PERL_MAGIC_backref))) {
+
+ if (SvTYPE(tsv) == SVt_PVHV && SvOOK(tsv)) {
+ av = *Perl_hv_backreferences_p(aTHX_ (HV*)tsv);
+ /* We mustn't attempt to "fix up" the hash here by moving the
+ backreference array back to the hv_aux structure, as that is stored
+ in the main HvARRAY(), and hfreentries assumes that no-one
+ reallocates HvARRAY() while it is running. */
+ }
+ if (!av) {
+ const MAGIC *const mg
+ = SvMAGICAL(tsv) ? mg_find(tsv, PERL_MAGIC_backref) : NULL;
+ if (mg)
+ av = (AV *)mg->mg_obj;
+ }
+ if (!av) {
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;
+ }
+
+ if (SvIS_FREED(av))
+ return;
+
svp = AvARRAY(av);
/* We shouldn't be in here more than once, but for paranoia reasons lets
not assume this. */
*/
svp[i] = svp[fill];
}
- svp[fill] = Nullsv;
+ svp[fill] = NULL;
AvFILLp(av) = fill - 1;
}
}
}
+int
+Perl_sv_kill_backrefs(pTHX_ SV *sv, AV *av)
+{
+ SV **svp = AvARRAY(av);
+
+ PERL_UNUSED_ARG(sv);
+
+ /* Not sure why the av can get freed ahead of its sv, but somehow it does
+ in ext/B/t/bytecode.t test 15 (involving print <DATA>) */
+ if (svp && !SvIS_FREED(av)) {
+ SV *const *const last = svp + AvFILLp(av);
+
+ while (svp <= last) {
+ if (*svp) {
+ SV *const referrer = *svp;
+ if (SvWEAKREF(referrer)) {
+ /* XXX Should we check that it hasn't changed? */
+ SvRV_set(referrer, 0);
+ SvOK_off(referrer);
+ SvWEAKREF_off(referrer);
+ } else if (SvTYPE(referrer) == SVt_PVGV ||
+ SvTYPE(referrer) == SVt_PVLV) {
+ /* You lookin' at me? */
+ assert(GvSTASH(referrer));
+ assert(GvSTASH(referrer) == (HV*)sv);
+ GvSTASH(referrer) = 0;
+ } else {
+ Perl_croak(aTHX_
+ "panic: magic_killbackrefs (flags=%"UVxf")",
+ (UV)SvFLAGS(referrer));
+ }
+
+ *svp = NULL;
+ }
+ svp++;
+ }
+ }
+ SvREFCNT_dec(av); /* remove extra count added by sv_add_backref() */
+ return 0;
+}
+
/*
=for apidoc sv_insert
void
Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, const char *little, STRLEN littlelen)
{
+ dVAR;
register char *big;
register char *mid;
register char *midend;
void
Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
{
+ dVAR;
const U32 refcnt = SvREFCNT(sv);
SV_CHECK_THINKFIRST_COW_DROP(sv);
if (SvREFCNT(nsv) != 1) {
Perl_sv_clear(pTHX_ register SV *sv)
{
dVAR;
- void** old_body_arena;
- size_t old_body_offset;
const U32 type = SvTYPE(sv);
+ const struct body_details *const sv_type_details
+ = bodies_by_type + type;
assert(sv);
assert(SvREFCNT(sv) == 0);
- if (type <= SVt_IV)
+ if (type <= SVt_IV) {
+ /* See the comment in sv.h about the collusion between this early
+ return and the overloading of the NULL and IV slots in the size
+ table. */
return;
-
- old_body_arena = 0;
- old_body_offset = 0;
+ }
if (SvOBJECT(sv)) {
if (PL_defstash) { /* Still have a symbol table? */
}
}
if (type >= SVt_PVMG) {
- if (SvMAGIC(sv))
+ HV *ourstash;
+ if ((type == SVt_PVMG || type == SVt_PVGV) &&
+ (ourstash = OURSTASH(sv))) {
+ SvREFCNT_dec(ourstash);
+ } else if (SvMAGIC(sv))
mg_free(sv);
- if (type == SVt_PVMG && SvFLAGS(sv) & SVpad_TYPED)
+ if (type == SVt_PVMG && SvPAD_TYPED(sv))
SvREFCNT_dec(SvSTASH(sv));
}
switch (type) {
Safefree(IoTOP_NAME(sv));
Safefree(IoFMT_NAME(sv));
Safefree(IoBOTTOM_NAME(sv));
- /* PVIOs aren't from arenas */
goto freescalar;
case SVt_PVBM:
- old_body_arena = (void **) &PL_xpvbm_root;
goto freescalar;
case SVt_PVCV:
- old_body_arena = (void **) &PL_xpvcv_root;
case SVt_PVFM:
- /* PVFMs aren't from arenas */
cv_undef((CV*)sv);
goto freescalar;
case SVt_PVHV:
+ Perl_hv_kill_backrefs(aTHX_ (HV*)sv);
hv_undef((HV*)sv);
- old_body_arena = (void **) &PL_xpvhv_root;
- old_body_offset = STRUCT_OFFSET(XPVHV, xhv_fill);
break;
case SVt_PVAV:
av_undef((AV*)sv);
- old_body_arena = (void **) &PL_xpvav_root;
- old_body_offset = STRUCT_OFFSET(XPVAV, xav_fill);
break;
case SVt_PVLV:
if (LvTYPE(sv) == 'T') { /* for tie: return HE to pool */
}
else if (LvTYPE(sv) != 't') /* unless tie: unrefcnted fake SV** */
SvREFCNT_dec(LvTARG(sv));
- old_body_arena = (void **) &PL_xpvlv_root;
goto freescalar;
case SVt_PVGV:
gp_free((GV*)sv);
- Safefree(GvNAME(sv));
+ if (GvNAME_HEK(sv)) {
+ unshare_hek(GvNAME_HEK(sv));
+ }
/* 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);
- old_body_arena = (void **) &PL_xpvgv_root;
- goto freescalar;
case SVt_PVMG:
- old_body_arena = (void **) &PL_xpvmg_root;
- goto freescalar;
case SVt_PVNV:
- old_body_arena = (void **) &PL_xpvnv_root;
- goto freescalar;
case SVt_PVIV:
- old_body_arena = (void **) &PL_xpviv_root;
- old_body_offset = STRUCT_OFFSET(XPVIV, xpv_cur);
freescalar:
/* Don't bother with SvOOK_off(sv); as we're only going to free it. */
if (SvOOK(sv)) {
SvPV_set(sv, SvPVX_mutable(sv) - SvIVX(sv));
/* Don't even bother with turning off the OOK flag. */
}
- goto pvrv_common;
case SVt_PV:
- old_body_arena = (void **) &PL_xpv_root;
- old_body_offset = STRUCT_OFFSET(XPV, xpv_cur);
case SVt_RV:
- pvrv_common:
if (SvROK(sv)) {
- SV *target = SvRV(sv);
+ SV * const target = SvRV(sv);
if (SvWEAKREF(sv))
sv_del_backref(target, sv);
else
#endif
break;
case SVt_NV:
- old_body_arena = (void **) &PL_xnv_root;
break;
}
SvFLAGS(sv) &= SVf_BREAK;
SvFLAGS(sv) |= SVTYPEMASK;
-#ifndef PURIFY
- if (old_body_arena) {
- del_body(((char *)SvANY(sv) + old_body_offset), old_body_arena);
+ if (sv_type_details->arena) {
+ del_body(((char *)SvANY(sv) + sv_type_details->offset),
+ &PL_body_roots[type]);
+ }
+ else if (sv_type_details->body_size) {
+ my_safefree(SvANY(sv));
}
- else
-#endif
- if (type > SVt_RV) {
- my_safefree(SvANY(sv));
- }
}
/*
SV *
Perl_sv_newref(pTHX_ SV *sv)
{
+ PERL_UNUSED_CONTEXT;
if (sv)
(SvREFCNT(sv))++;
return sv;
start = (U8*)SvPV_const(sv, len);
if (len) {
STRLEN boffset = 0;
- STRLEN *cache = 0;
+ STRLEN *cache = NULL;
const U8 *s = start;
I32 uoffset = *offsetp;
const U8 * const send = s + len;
- MAGIC *mg = 0;
- bool found = FALSE;
+ MAGIC *mg = NULL;
+ bool found = utf8_mg_pos(sv, &mg, &cache, 0, offsetp, *offsetp, &s, start, send);
- if (utf8_mg_pos(sv, &mg, &cache, 0, offsetp, *offsetp, &s, start, send))
- found = TRUE;
if (!found && uoffset > 0) {
while (s < send && uoffset--)
s += UTF8SKIP(s);
I32
Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2)
{
+ dVAR;
const char *pv1;
STRLEN cur1;
const char *pv2;
STRLEN cur2;
I32 eq = 0;
- char *tpv = Nullch;
- SV* svrecode = Nullsv;
+ char *tpv = NULL;
+ SV* svrecode = NULL;
if (!sv1) {
pv1 = "";
if (cur1 == cur2)
eq = (pv1 == pv2) || memEQ(pv1, pv2, cur1);
- if (svrecode)
- SvREFCNT_dec(svrecode);
-
+ SvREFCNT_dec(svrecode);
if (tpv)
Safefree(tpv);
I32
Perl_sv_cmp(pTHX_ register SV *sv1, register SV *sv2)
{
+ dVAR;
STRLEN cur1, cur2;
const char *pv1, *pv2;
- char *tpv = Nullch;
+ char *tpv = NULL;
I32 cmp;
- SV *svrecode = Nullsv;
+ SV *svrecode = NULL;
if (!sv1) {
pv1 = "";
}
}
- if (svrecode)
- SvREFCNT_dec(svrecode);
-
+ SvREFCNT_dec(svrecode);
if (tpv)
Safefree(tpv);
I32
Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2)
{
+ dVAR;
#ifdef USE_LOCALE_COLLATE
char *pv1, *pv2;
*/
raw_compare:
- /* FALL THROUGH */
+ /*FALLTHROUGH*/
#endif /* USE_LOCALE_COLLATE */
char *
Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp)
{
+ dVAR;
MAGIC *mg;
mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_collxfrm) : (MAGIC *) NULL;
char *
Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
{
+ dVAR;
const char *rsptr;
STRLEN rslen;
register STDCHAR rslast;
sv_pos_u2b(sv,&append,0);
}
} else if (SvUTF8(sv)) {
- SV * const tsv = NEWSV(0,0);
+ SV * const tsv = newSV(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;
+ STDCHAR *buf = NULL;
Newx(buf, 8192, STDCHAR);
assert(buf);
#else
screamer2:
if (rslen) {
- register const STDCHAR *bpe = buf + sizeof(buf);
+ register const STDCHAR * const bpe = buf + sizeof(buf);
bp = buf;
while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = (STDCHAR)i) != rslast && bp < bpe)
; /* keep reading */
}
return_string_or_null:
- return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
+ return (SvCUR(sv) - append) ? SvPVX(sv) : NULL;
}
/*
void
Perl_sv_inc(pTHX_ register SV *sv)
{
+ dVAR;
register char *d;
int flags;
void
Perl_sv_dec(pTHX_ register SV *sv)
{
+ dVAR;
int flags;
if (!sv)
SV *
Perl_sv_mortalcopy(pTHX_ SV *oldstr)
{
+ dVAR;
register SV *sv;
new_SV(sv);
SV *
Perl_sv_newmortal(pTHX)
{
+ dVAR;
register SV *sv;
new_SV(sv);
{
dVAR;
if (!sv)
- return sv;
+ return NULL;
if (SvREADONLY(sv) && SvIMMORTAL(sv))
return sv;
EXTEND_MORTAL(1);
SV *
Perl_newSVpv(pTHX_ const char *s, STRLEN len)
{
+ dVAR;
register SV *sv;
new_SV(sv);
SV *
Perl_newSVpvn(pTHX_ const char *s, STRLEN len)
{
+ dVAR;
register SV *sv;
new_SV(sv);
SV *
Perl_newSVhek(pTHX_ const HEK *hek)
{
+ dVAR;
if (!hek) {
SV *sv;
SV *
Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash)
{
+ dVAR;
register SV *sv;
bool is_utf8 = FALSE;
if (len < 0) {
SV *
Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args)
{
+ dVAR;
register SV *sv;
new_SV(sv);
- sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
+ sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
return sv;
}
SV *
Perl_newSVnv(pTHX_ NV n)
{
+ dVAR;
register SV *sv;
new_SV(sv);
SV *
Perl_newSViv(pTHX_ IV i)
{
+ dVAR;
register SV *sv;
new_SV(sv);
SV *
Perl_newSVuv(pTHX_ UV u)
{
+ dVAR;
register SV *sv;
new_SV(sv);
SV *
Perl_newRV_noinc(pTHX_ SV *tmpRef)
{
+ dVAR;
register SV *sv;
new_SV(sv);
*/
SV *
-Perl_newRV(pTHX_ SV *tmpRef)
+Perl_newRV(pTHX_ SV *sv)
{
- return newRV_noinc(SvREFCNT_inc(tmpRef));
+ dVAR;
+ return newRV_noinc(SvREFCNT_inc_simple_NN(sv));
}
/*
SV *
Perl_newSVsv(pTHX_ register SV *old)
{
+ dVAR;
register SV *sv;
if (!old)
- return Nullsv;
+ return NULL;
if (SvTYPE(old) == SVTYPEMASK) {
if (ckWARN_d(WARN_INTERNAL))
Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "semi-panic: attempt to dup freed string");
- return Nullsv;
+ return NULL;
}
new_SV(sv);
/* SV_GMAGIC is the default for sv_setv()
SvOK_off(sv);
if (SvTYPE(sv) >= SVt_PV) {
SvCUR_set(sv, 0);
- if (SvPVX_const(sv) != Nullch)
+ if (SvPVX_const(sv) != NULL)
*SvPVX(sv) = '\0';
SvTAINT(sv);
}
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
*/
Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
{
dVAR;
- GV *gv = Nullgv;
- CV *cv = Nullcv;
+ GV *gv = NULL;
+ CV *cv = NULL;
- if (!sv)
- return *gvp = Nullgv, Nullcv;
+ if (!sv) {
+ *st = NULL;
+ *gvp = NULL;
+ return NULL;
+ }
switch (SvTYPE(sv)) {
case SVt_PVCV:
*st = CvSTASH(sv);
- *gvp = Nullgv;
+ *gvp = NULL;
return (CV*)sv;
case SVt_PVHV:
case SVt_PVAV:
- *gvp = Nullgv;
- return Nullcv;
+ *st = NULL;
+ *gvp = NULL;
+ return NULL;
case SVt_PVGV:
gv = (GV*)sv;
*gvp = gv;
sv = SvRV(sv);
if (SvTYPE(sv) == SVt_PVCV) {
cv = (CV*)sv;
- *gvp = Nullgv;
+ *gvp = NULL;
*st = CvSTASH(cv);
return cv;
}
else
gv = gv_fetchsv(sv, lref, SVt_PVCV);
*gvp = gv;
- if (!gv)
- return Nullcv;
+ if (!gv) {
+ *st = NULL;
+ return NULL;
+ }
+ /* Some flags to gv_fetchsv mean don't really create the GV */
+ if (SvTYPE(gv) != SVt_PVGV) {
+ *st = NULL;
+ return NULL;
+ }
*st = GvESTASH(gv);
fix_gv:
if (lref && !GvCVu(gv)) {
SV *tmpsv;
ENTER;
- tmpsv = NEWSV(704,0);
- gv_efullname3(tmpsv, gv, Nullch);
+ tmpsv = newSV(0);
+ gv_efullname3(tmpsv, gv, NULL);
/* XXX this is probably not what they think they're getting.
* It has the same effect as "sub name;", i.e. just a forward
* declaration! */
newSUB(start_subparse(FALSE, 0),
newSVOP(OP_CONST, 0, tmpsv),
- Nullop,
- Nullop);
+ NULL, NULL);
LEAVE;
if (!GvCVu(gv))
Perl_croak(aTHX_ "Unable to create sub named \"%"SVf"\"",
char *
Perl_sv_pvn_force_flags(pTHX_ SV *sv, STRLEN *lp, I32 flags)
{
-
+ dVAR;
if (SvTHINKFIRST(sv) && !SvROK(sv))
sv_force_normal_flags(sv, 0);
SV*
Perl_newSVrv(pTHX_ SV *rv, const char *classname)
{
+ dVAR;
SV *sv;
new_SV(sv);
argument will be upgraded to an RV. That RV will be modified to point to
the new SV. If the C<pv> argument is NULL then C<PL_sv_undef> will be placed
into the SV. The C<classname> argument indicates the package for the
-blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
+blessing. Set C<classname> to C<NULL> to avoid the blessing. The new SV
will have a reference count of 1, and the RV will be returned.
Do not use with other Perl types such as HV, AV, SV, CV, because those
SV*
Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv)
{
+ dVAR;
if (!pv) {
sv_setsv(rv, &PL_sv_undef);
SvSETMAGIC(rv);
Copies an integer into a new SV, optionally blessing the SV. The C<rv>
argument will be upgraded to an RV. That RV will be modified to point to
the new SV. The C<classname> argument indicates the package for the
-blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
+blessing. Set C<classname> to C<NULL> to avoid the blessing. The new SV
will have a reference count of 1, and the RV will be returned.
=cut
Copies an unsigned integer into a new SV, optionally blessing the SV. The C<rv>
argument will be upgraded to an RV. That RV will be modified to point to
the new SV. The C<classname> argument indicates the package for the
-blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
+blessing. Set C<classname> to C<NULL> to avoid the blessing. The new SV
will have a reference count of 1, and the RV will be returned.
=cut
Copies a double into a new SV, optionally blessing the SV. The C<rv>
argument will be upgraded to an RV. That RV will be modified to point to
the new SV. The C<classname> argument indicates the package for the
-blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
+blessing. Set C<classname> to C<NULL> to avoid the blessing. The new SV
will have a reference count of 1, and the RV will be returned.
=cut
string must be specified with C<n>. The C<rv> argument will be upgraded to
an RV. That RV will be modified to point to the new SV. The C<classname>
argument indicates the package for the blessing. Set C<classname> to
-C<Nullch> to avoid the blessing. The new SV will have a reference count
+C<NULL> to avoid the blessing. The new SV will have a reference count
of 1, and the RV will be returned.
Note that C<sv_setref_pv> copies the pointer while this copies the string.
SV*
Perl_sv_bless(pTHX_ SV *sv, HV *stash)
{
+ dVAR;
SV *tmpRef;
if (!SvROK(sv))
Perl_croak(aTHX_ "Can't bless non-reference value");
if (SvTYPE(tmpRef) != SVt_PVIO)
++PL_sv_objcount;
SvUPGRADE(tmpRef, SVt_PVMG);
- SvSTASH_set(tmpRef, (HV*)SvREFCNT_inc(stash));
+ SvSTASH_set(tmpRef, (HV*)SvREFCNT_inc_simple(stash));
if (Gv_AMG(stash))
SvAMAGIC_on(sv);
STATIC void
S_sv_unglob(pTHX_ SV *sv)
{
+ dVAR;
void *xpvmg;
+ SV * const temp = sv_newmortal();
assert(SvTYPE(sv) == SVt_PVGV);
SvFAKE_off(sv);
- if (GvGP(sv))
+ gv_efullname3(temp, (GV *) sv, "*");
+
+ if (GvGP(sv)) {
gp_free((GV*)sv);
+ }
if (GvSTASH(sv)) {
sv_del_backref((SV*)GvSTASH(sv), sv);
- GvSTASH(sv) = Nullhv;
+ GvSTASH(sv) = NULL;
}
- sv_unmagic(sv, PERL_MAGIC_glob);
- Safefree(GvNAME(sv));
GvMULTI_off(sv);
+ if (GvNAME_HEK(sv)) {
+ unshare_hek(GvNAME_HEK(sv));
+ }
+ SvSCREAM_off(sv);
/* need to keep SvANY(sv) in the right arena */
xpvmg = new_XPVMG();
SvFLAGS(sv) &= ~SVTYPEMASK;
SvFLAGS(sv) |= SVt_PVMG;
+
+ /* Intentionally not calling any local SET magic, as this isn't so much a
+ set operation as merely an internal storage change. */
+ sv_setsv_flags(sv, temp, 0);
}
/*
void
Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args)
{
- sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
+ sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
}
/*
void
Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
{
- sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
+ sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
SvSETMAGIC(sv);
}
void
Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args)
{
- sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
+ sv_vcatpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
}
/*
void
Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
{
- sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
+ sv_vcatpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
SvSETMAGIC(sv);
}
sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
}
-/* private function for use in sv_vcatpvfn via the EXPECT_NUMBER macro */
-
STATIC I32
S_expect_number(pTHX_ char** pattern)
{
+ dVAR;
I32 var = 0;
switch (**pattern) {
case '1': case '2': case '3':
case '4': case '5': case '6':
case '7': case '8': case '9':
- while (isDIGIT(**pattern))
- var = var * 10 + (*(*pattern)++ - '0');
+ var = *(*pattern)++ - '0';
+ while (isDIGIT(**pattern)) {
+ const 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;
}
-#define EXPECT_NUMBER(pattern, var) (var = S_expect_number(aTHX_ &pattern))
-static char *
-F0convert(NV nv, char *endbuf, STRLEN *len)
+STATIC char *
+S_F0convert(NV nv, char *endbuf, STRLEN *len)
{
const int neg = nv < 0;
UV uv;
*len = endbuf - p;
return p;
}
- return Nullch;
+ return NULL;
}
void
Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
{
+ dVAR;
char *p;
char *q;
const char *patend;
STRLEN origlen;
I32 svix = 0;
static const char nullstr[] = "(null)";
- SV *argsv = Nullsv;
+ SV *argsv = NULL;
bool has_utf8 = DO_UTF8(sv); /* has the result utf8? */
const bool pat_utf8 = has_utf8; /* the pattern is in utf8? */
- SV *nsv = Nullsv;
+ SV *nsv = NULL;
/* Times 4: a decimal digit takes more than 3 binary digits.
* NV_DIG: mantissa takes than many decimal digits.
* Plus 32: Playing safe. */
}
else if (svix < svmax) {
sv_catsv(sv, *svargs);
- if (DO_UTF8(*svargs))
- SvUTF8_on(sv);
}
return;
}
pat[1] == '-' && pat[2] == 'p') {
argsv = va_arg(*args, SV*);
sv_catsv(sv, argsv);
- if (DO_UTF8(argsv))
- SvUTF8_on(sv);
return;
}
STRLEN zeros = 0;
bool has_precis = FALSE;
STRLEN precis = 0;
- I32 osvix = svix;
+ const I32 osvix = svix;
bool is_utf8 = FALSE; /* is this item utf8? */
#ifdef HAS_LDBL_SPRINTF_BUG
/* This is to try to fix a bug with irix/nonstop-ux/powerux and
U8 utf8buf[UTF8_MAXBYTES+1];
STRLEN esignlen = 0;
- const char *eptr = Nullch;
+ const char *eptr = NULL;
STRLEN elen = 0;
- SV *vecsv = Nullsv;
- const U8 *vecstr = Null(U8*);
+ SV *vecsv = NULL;
+ const U8 *vecstr = NULL;
STRLEN veclen = 0;
char c = 0;
int i;
STRLEN n = 0;
if (*q == '-')
sv = *q++;
- EXPECT_NUMBER(q, n);
+ n = expect_number(&q);
if (*q++ == 'p') {
if (sv) { /* SVf */
if (n) {
q = r;
}
- if (EXPECT_NUMBER(q, width)) {
+ if ( (width = expect_number(&q)) ) {
if (*q == '$') {
++q;
efix = width;
tryasterisk:
if (*q == '*') {
q++;
- if (EXPECT_NUMBER(q, ewix))
+ if ( (ewix = expect_number(&q)) )
if (*q++ != '$')
goto unknown;
asterisk = TRUE;
{
if( *q == '0' )
fill = *q++;
- EXPECT_NUMBER(q, width);
+ width = expect_number(&q);
}
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) {
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);
+ if ( hv_exists((HV*)SvRV(vecsv), "alpha", 5 ) ) {
+ Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
+ "vector argument not supported with alpha versions");
+ goto unknown;
+ }
+ 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 {
q++;
if (*q == '*') {
q++;
- if (EXPECT_NUMBER(q, epix) && *q++ != '$')
+ if ( ((epix = expect_number(&q))) && (*q++ != '$') )
goto unknown;
/* XXX: todo, support specified precision parameter */
if (epix)
#endif
#if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
case 'L': /* Ld */
- /* FALL THROUGH */
+ /*FALLTHROUGH*/
#ifdef HAS_QUAD
case 'q': /* qd */
#endif
break;
}
#endif
- /* FALL THROUGH */
+ /*FALLTHROUGH*/
case 'h':
- /* FALL THROUGH */
+ /*FALLTHROUGH*/
case 'V':
intsize = *q++;
break;
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;
#else
intsize = 'l';
#endif
- /* FALL THROUGH */
+ /*FALLTHROUGH*/
case 'd':
case 'i':
#if vdNUMBER
#else
intsize = 'l';
#endif
- /* FALL THROUGH */
+ /*FALLTHROUGH*/
case 'u':
base = 10;
goto uns_integer;
#else
intsize = 'l';
#endif
- /* FALL THROUGH */
+ /*FALLTHROUGH*/
case 'o':
base = 8;
goto uns_integer;
*--ptr = '0';
break;
case 2:
+ if (!uv)
+ alt = FALSE;
do {
dig = uv & 1;
*--ptr = '0' + dig;
case 'F':
c = 'f'; /* maybe %F isn't supported here */
- /* FALL THROUGH */
+ /*FALLTHROUGH*/
case 'e': case 'E':
case 'f':
case 'g': case 'G':
+ if (vectorize)
+ goto unknown;
/* This is evil, but floating point is even more evil */
break;
/* [perl #20339] - we should accept and ignore %lf rather than die */
case 'l':
- /* FALL THROUGH */
+ /*FALLTHROUGH*/
default:
#if defined(USE_LONG_DOUBLE)
intsize = args ? 0 : 'q';
#if defined(HAS_LONG_DOUBLE)
break;
#else
- /* FALL THROUGH */
+ /*FALLTHROUGH*/
#endif
case 'h':
goto unknown;
}
/* now we need (long double) if intsize == 'q', else (double) */
- nv = (args && !vectorize) ?
+ nv = (args) ?
#if LONG_DOUBLESIZE > DOUBLESIZE
intsize == 'q' ?
va_arg(*args, long double) :
: SvNVx(argsv);
need = 0;
- vectorize = FALSE;
if (c != 'e' && c != 'E') {
i = PERL_INT_MIN;
/* FIXME: if HAS_LONG_DOUBLE but not USE_LONG_DOUBLE this
/* SPECIAL */
case 'n':
+ if (vectorize)
+ goto unknown;
i = SvCUR(sv) - origlen;
- if (args && !vectorize) {
+ if (args) {
switch (intsize) {
case 'h': *(va_arg(*args, short*)) = i; break;
default: *(va_arg(*args, int*)) = i; break;
}
else
sv_setuv_mg(argsv, (UV)i);
- vectorize = FALSE;
continue; /* not "break" */
/* UNKNOWN */
"\"%%\\%03"UVof"\"",
(UV)c & 0xFF);
} else
- sv_catpv(msg, "end of string");
+ sv_catpvs(msg, "end of string");
Perl_warner(aTHX_ packWARN(WARN_PRINTF), "%"SVf, msg); /* yes, this is reentrant */
}
/* calculate width before utf8_upgrade changes it */
have = esignlen + zeros + elen;
+ if (have < zeros)
+ Perl_croak_nocontext(PL_memory_wrap);
if (is_utf8 != has_utf8) {
if (is_utf8) {
need = (have > width ? have : width);
gap = need - have;
+ if (need >= (((STRLEN)~0) - SvCUR(sv) - dotstrlen - 1))
+ Perl_croak_nocontext(PL_memory_wrap);
SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
p = SvEND(sv);
if (esignlen && fill == '0') {
#define sv_dup_inc(s,t) SvREFCNT_inc(sv_dup(s,t))
+#define sv_dup_inc_NN(s,t) SvREFCNT_inc_NN(sv_dup(s,t))
#define av_dup(s,t) (AV*)sv_dup((SV*)s,t)
#define av_dup_inc(s,t) (AV*)SvREFCNT_inc(sv_dup((SV*)s,t))
#define hv_dup(s,t) (HV*)sv_dup((SV*)s,t)
#define io_dup_inc(s,t) (IO*)SvREFCNT_inc(sv_dup((SV*)s,t))
#define gv_dup(s,t) (GV*)sv_dup((SV*)s,t)
#define gv_dup_inc(s,t) (GV*)SvREFCNT_inc(sv_dup((SV*)s,t))
-#define SAVEPV(p) (p ? savepv(p) : Nullch)
-#define SAVEPVN(p,n) (p ? savepvn(p,n) : Nullch)
+#define SAVEPV(p) ((p) ? savepv(p) : NULL)
+#define SAVEPVN(p,n) ((p) ? savepvn(p,n) : NULL)
/* Duplicate a regexp. Required reading: pregcomp() and pregfree() in
if (RX_MATCH_COPIED(ret))
ret->subbeg = SAVEPVN(r->subbeg, r->sublen);
else
- ret->subbeg = Nullch;
+ ret->subbeg = NULL;
#ifdef PERL_OLD_COPY_ON_WRITE
- ret->saved_copy = Nullsv;
+ ret->saved_copy = NULL;
#endif
ptr_table_store(PL_ptr_table, r, ret);
DIR *
Perl_dirp_dup(pTHX_ DIR *dp)
{
+ PERL_UNUSED_CONTEXT;
if (!dp)
return (DIR*)NULL;
/* XXX TODO */
Perl_gp_dup(pTHX_ GP *gp, CLONE_PARAMS* param)
{
GP *ret;
+
if (!gp)
return (GP*)NULL;
/* look for it in the table first */
nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj, param);
}
else if(mg->mg_type == PERL_MAGIC_backref) {
- const AV * const av = (AV*) mg->mg_obj;
- SV **svp;
- I32 i;
- (void)SvREFCNT_inc(nmg->mg_obj = (SV*)newAV());
- svp = AvARRAY(av);
- for (i = AvFILLp(av); i >= 0; i--) {
- if (!svp[i]) continue;
- av_push((AV*)nmg->mg_obj,sv_dup(svp[i],param));
- }
+ /* The backref AV has its reference count deliberately bumped by
+ 1. */
+ nmg->mg_obj = SvREFCNT_inc(av_dup_inc((AV*) mg->mg_obj, param));
}
else if (mg->mg_type == PERL_MAGIC_symtab) {
nmg->mg_obj = mg->mg_obj;
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;
+ const 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;
+ PERL_UNUSED_CONTEXT;
+
Newxz(tbl, 1, PTR_TBL_t);
tbl->tbl_max = 511;
tbl->tbl_items = 0;
return tbl;
}
-#if (PTRSIZE == 8)
-# define PTR_TABLE_HASH(ptr) (PTR2UV(ptr) >> 3)
-#else
-# define PTR_TABLE_HASH(ptr) (PTR2UV(ptr) >> 2)
-#endif
+#define PTR_TABLE_HASH(ptr) \
+ ((PTR2UV(ptr) >> 3) ^ (PTR2UV(ptr) >> (3 + 7)) ^ (PTR2UV(ptr) >> (3 + 17)))
+
+/*
+ we use the PTE_SVSLOT 'reservation' made above, both here (in the
+ following define) and at call to new_body_inline made below in
+ Perl_ptr_table_store()
+ */
-#define del_pte(p) del_body_type(p, struct ptr_tbl_ent, pte)
+#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, const void *sv)
-{
+STATIC PTR_TBL_ENT_t *
+S_ptr_table_find(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 = ptr_table_find(tbl, sv);
+ PERL_UNUSED_CONTEXT;
+ return tblent ? tblent->newval : (void *) 0;
}
/* add a new entry to a pointer-mapping table */
void
Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, const void *oldsv, void *newsv)
{
- PTR_TBL_ENT_t *tblent, **otblent;
- /* XXX this may be pessimal on platforms where pointers aren't good
- * hash values e.g. if they grow faster in the most significant
- * bits */
- const UV hash = PTR_TABLE_HASH(oldsv);
- bool empty = 1;
+ PTR_TBL_ENT_t *tblent = ptr_table_find(tbl, oldsv);
+ PERL_UNUSED_CONTEXT;
- assert(tbl);
- otblent = &tbl->tbl_ary[hash & tbl->tbl_max];
- for (tblent = *otblent; tblent; empty=0, tblent = tblent->next) {
- if (tblent->oldval == oldsv) {
- tblent->newval = newsv;
- return;
- }
+ if (tblent) {
+ tblent->newval = newsv;
+ } else {
+ const UV entry = PTR_TABLE_HASH(oldsv) & tbl->tbl_max;
+
+ new_body_inline(tblent, PTE_SVSLOT);
+
+ tblent->oldval = oldsv;
+ tblent->newval = newsv;
+ tblent->next = tbl->tbl_ary[entry];
+ tbl->tbl_ary[entry] = tblent;
+ tbl->tbl_items++;
+ if (tblent->next && tbl->tbl_items > tbl->tbl_max)
+ ptr_table_split(tbl);
}
- new_body_inline(tblent, (void**)&PL_pte_arenaroot, (void**)&PL_pte_root,
- sizeof(struct ptr_tbl_ent));
- tblent->oldval = oldsv;
- tblent->newval = newsv;
- tblent->next = *otblent;
- *otblent = tblent;
- tbl->tbl_items++;
- if (!empty && tbl->tbl_items > tbl->tbl_max)
- ptr_table_split(tbl);
}
/* double the hash bucket size of an existing ptr table */
const UV oldsize = tbl->tbl_max + 1;
UV newsize = oldsize * 2;
UV i;
+ PERL_UNUSED_CONTEXT;
Renew(ary, newsize, PTR_TBL_ENT_t*);
Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
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 * const * const array = tbl->tbl_ary;
+ UV riter = tbl->tbl_max;
- if (!tbl || !tbl->tbl_items) {
- return;
- }
+ do {
+ PTR_TBL_ENT_t *entry = array[riter];
- array = tbl->tbl_ary;
- entry = array[0];
- max = tbl->tbl_max;
+ while (entry) {
+ PTR_TBL_ENT_t * const oentry = entry;
+ entry = entry->next;
+ del_pte(oentry);
+ }
+ } while (riter--);
- for (;;) {
- if (entry) {
- PTR_TBL_ENT_t *oentry = entry;
- entry = entry->next;
- del_pte(oentry);
- }
- if (!entry) {
- if (++riter > max) {
- break;
- }
- entry = array[riter];
- }
+ tbl->tbl_items = 0;
}
-
- tbl->tbl_items = 0;
}
/* clear and free a ptr table */
void
-Perl_rvpv_dup(pTHX_ SV *dstr, SV *sstr, CLONE_PARAMS* param)
+Perl_rvpv_dup(pTHX_ SV *dstr, const SV *sstr, CLONE_PARAMS* param)
{
if (SvROK(sstr)) {
SvRV_set(dstr, SvWEAKREF(sstr)
}
else {
/* Special case - not normally malloced for some reason */
- if ((SvREADONLY(sstr) && SvFAKE(sstr))) {
+ if (isGV_with_GP(sstr)) {
+ /* Don't need to do anything here. */
+ }
+ else if ((SvREADONLY(sstr) && SvFAKE(sstr))) {
/* A "shared" PV - clone it as "shared" PV */
SvPV_set(dstr,
HEK_KEY(hek_dup(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)),
}
}
else {
- /* Copy the Null */
+ /* Copy the NULL */
if (SvTYPE(dstr) == SVt_RV)
SvRV_set(dstr, NULL);
else
- SvPV_set(dstr, 0);
+ SvPV_set(dstr, NULL);
}
}
/* duplicate an SV of any type (including AV, HV etc) */
SV *
-Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param)
+Perl_sv_dup(pTHX_ const SV *sstr, CLONE_PARAMS* param)
{
dVAR;
SV *dstr;
if (!sstr || SvTYPE(sstr) == SVTYPEMASK)
- return Nullsv;
+ return NULL;
/* look for it in the table first */
dstr = (SV*)ptr_table_fetch(PL_ptr_table, sstr);
if (dstr)
if(param->flags & CLONEf_JOIN_IN) {
/** We are joining here so we don't want do clone
something that is bad **/
- const char *hvname;
-
- if(SvTYPE(sstr) == SVt_PVHV &&
- (hvname = HvNAME_get(sstr))) {
- /** don't clone stashes if they already exist **/
- return (SV*)gv_stashpv(hvname,0);
+ if (SvTYPE(sstr) == SVt_PVHV) {
+ const char * const hvname = HvNAME_get(sstr);
+ if (hvname)
+ /** don't clone stashes if they already exist **/
+ return (SV*)gv_stashpv(hvname,0);
}
}
dstr->sv_debug_line = sstr->sv_debug_line;
dstr->sv_debug_inpad = sstr->sv_debug_inpad;
dstr->sv_debug_cloned = 1;
-# ifdef NETWARE
dstr->sv_debug_file = savepv(sstr->sv_debug_file);
-# else
- dstr->sv_debug_file = savesharedpv(sstr->sv_debug_file);
-# endif
#endif
ptr_table_store(PL_ptr_table, sstr, dstr);
default:
{
/* These are all the types that need complex bodies allocating. */
- size_t new_body_length;
- size_t new_body_offset = 0;
- void **new_body_arena;
- void **new_body_arenaroot;
void *new_body;
+ const svtype sv_type = SvTYPE(sstr);
+ const struct body_details *const sv_type_details
+ = bodies_by_type + sv_type;
- switch (SvTYPE(sstr)) {
+ switch (sv_type) {
default:
- Perl_croak(aTHX_ "Bizarre SvTYPE [%" IVdf "]",
- (IV)SvTYPE(sstr));
+ Perl_croak(aTHX_ "Bizarre SvTYPE [%" IVdf "]", (IV)SvTYPE(sstr));
break;
+ case SVt_PVGV:
+ if (GvUNIQUE((GV*)sstr)) {
+ /*EMPTY*/; /* Do sharing here, and fall through */
+ }
case SVt_PVIO:
- new_body = new_XPVIO();
- new_body_length = sizeof(XPVIO);
- break;
case SVt_PVFM:
- new_body = new_XPVFM();
- new_body_length = sizeof(XPVFM);
- break;
-
case SVt_PVHV:
- new_body_arena = (void **) &PL_xpvhv_root;
- new_body_arenaroot = (void **) &PL_xpvhv_arenaroot;
- new_body_offset = STRUCT_OFFSET(XPVHV, xhv_fill)
- - STRUCT_OFFSET(xpvhv_allocated, xhv_fill);
- new_body_length = STRUCT_OFFSET(XPVHV, xmg_stash)
- + sizeof (((XPVHV*)SvANY(sstr))->xmg_stash)
- - new_body_offset;
- goto new_body;
case SVt_PVAV:
- new_body_arena = (void **) &PL_xpvav_root;
- new_body_arenaroot = (void **) &PL_xpvav_arenaroot;
- new_body_offset = STRUCT_OFFSET(XPVAV, xav_fill)
- - STRUCT_OFFSET(xpvav_allocated, xav_fill);
- new_body_length = STRUCT_OFFSET(XPVHV, xmg_stash)
- + sizeof (((XPVHV*)SvANY(sstr))->xmg_stash)
- - new_body_offset;
- goto new_body;
case SVt_PVBM:
- new_body_length = sizeof(XPVBM);
- new_body_arena = (void **) &PL_xpvbm_root;
- new_body_arenaroot = (void **) &PL_xpvbm_arenaroot;
- goto new_body;
- case SVt_PVGV:
- if (GvUNIQUE((GV*)sstr)) {
- /* Do sharing here. */
- }
- new_body_length = sizeof(XPVGV);
- new_body_arena = (void **) &PL_xpvgv_root;
- new_body_arenaroot = (void **) &PL_xpvgv_arenaroot;
- goto new_body;
case SVt_PVCV:
- new_body_length = sizeof(XPVCV);
- new_body_arena = (void **) &PL_xpvcv_root;
- new_body_arenaroot = (void **) &PL_xpvcv_arenaroot;
- goto new_body;
case SVt_PVLV:
- new_body_length = sizeof(XPVLV);
- new_body_arena = (void **) &PL_xpvlv_root;
- new_body_arenaroot = (void **) &PL_xpvlv_arenaroot;
- goto new_body;
case SVt_PVMG:
- new_body_length = sizeof(XPVMG);
- new_body_arena = (void **) &PL_xpvmg_root;
- new_body_arenaroot = (void **) &PL_xpvmg_arenaroot;
- goto new_body;
case SVt_PVNV:
- new_body_length = sizeof(XPVNV);
- new_body_arena = (void **) &PL_xpvnv_root;
- new_body_arenaroot = (void **) &PL_xpvnv_arenaroot;
- goto new_body;
case SVt_PVIV:
- new_body_offset = STRUCT_OFFSET(XPVIV, xpv_cur)
- - STRUCT_OFFSET(xpviv_allocated, xpv_cur);
- new_body_length = sizeof(XPVIV) - new_body_offset;
- new_body_arena = (void **) &PL_xpviv_root;
- new_body_arenaroot = (void **) &PL_xpviv_arenaroot;
- goto new_body;
case SVt_PV:
- new_body_offset = STRUCT_OFFSET(XPV, xpv_cur)
- - STRUCT_OFFSET(xpv_allocated, xpv_cur);
- new_body_length = sizeof(XPV) - new_body_offset;
- new_body_arena = (void **) &PL_xpv_root;
- new_body_arenaroot = (void **) &PL_xpv_arenaroot;
- new_body:
- assert(new_body_length);
-#ifndef PURIFY
- new_body_inline(new_body, new_body_arenaroot, new_body_arena,
- new_body_length);
- new_body = (void*)((char*)new_body - new_body_offset);
-#else
- /* We always allocated the full length item with PURIFY */
- new_body_length += new_body_offset;
- new_body_offset = 0;
- new_body = my_safemalloc(new_body_length);
-#endif
+ assert(sv_type_details->body_size);
+ if (sv_type_details->arena) {
+ new_body_inline(new_body, sv_type);
+ new_body
+ = (void*)((char*)new_body - sv_type_details->offset);
+ } else {
+ new_body = new_NOARENA(sv_type_details);
+ }
}
assert(new_body);
SvANY(dstr) = new_body;
- Copy(((char*)SvANY(sstr)) + new_body_offset,
- ((char*)SvANY(dstr)) + new_body_offset,
- new_body_length, char);
+#ifndef PURIFY
+ Copy(((char*)SvANY(sstr)) + sv_type_details->offset,
+ ((char*)SvANY(dstr)) + sv_type_details->offset,
+ sv_type_details->copy, char);
+#else
+ Copy(((char*)SvANY(sstr)),
+ ((char*)SvANY(dstr)),
+ sv_type_details->body_size + sv_type_details->offset, char);
+#endif
- if (SvTYPE(sstr) != SVt_PVAV && SvTYPE(sstr) != SVt_PVHV)
+ if (sv_type != SVt_PVAV && sv_type != SVt_PVHV
+ && !isGV_with_GP(dstr))
Perl_rvpv_dup(aTHX_ dstr, sstr, param);
/* The Copy above means that all the source (unduplicated) pointers
pointers in either, but it's possible that there's less cache
missing by always going for the destination.
FIXME - instrument and check that assumption */
- if (SvTYPE(sstr) >= SVt_PVMG) {
- if (SvMAGIC(dstr))
+ if (sv_type >= SVt_PVMG) {
+ HV *ourstash;
+ if ((sv_type == SVt_PVMG) && (ourstash = OURSTASH(dstr))) {
+ OURSTASH_set(dstr, hv_dup_inc(ourstash, param));
+ } else if (SvMAGIC(dstr))
SvMAGIC_set(dstr, mg_dup(SvMAGIC(dstr), param));
if (SvSTASH(dstr))
SvSTASH_set(dstr, hv_dup_inc(SvSTASH(dstr), param));
}
- switch (SvTYPE(sstr)) {
+ /* The cast silences a GCC warning about unhandled types. */
+ switch ((int)sv_type) {
case SVt_PV:
break;
case SVt_PVIV:
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);
+ if (GvNAME_HEK(dstr))
+ GvNAME_HEK(dstr) = hek_dup(GvNAME_HEK(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));
+ GvSTASH(dstr) = hv_dup(GvSTASH(dstr), param);
+ if(isGV_with_GP(sstr)) {
+ /* Danger Will Robinson - GvGP(dstr) isn't initialised
+ at the point of this comment. */
+ GvGP(dstr) = gp_dup(GvGP(sstr), param);
+ (void)GpREFCNT_inc(GvGP(dstr));
+ } else
+ Perl_rvpv_dup(aTHX_ dstr, sstr, param);
break;
case SVt_PVIO:
IoIFP(dstr) = fp_dup(IoIFP(dstr), IoTYPE(dstr), param);
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
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);
+ if (IoDIRP(dstr)) {
+ IoDIRP(dstr) = dirp_dup(IoDIRP(dstr));
+ } else {
+ /*EMPTY*/;
+ /* IoDIRP(dstr) is already a copy of IoDIRP(sstr) */
+ }
}
IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(dstr));
IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(dstr));
}
}
else {
- SvPV_set(dstr, Nullch);
+ SvPV_set(dstr, NULL);
AvALLOC((AV*)dstr) = (SV**)NULL;
}
break;
case SVt_PVHV:
{
- HEK *hvname = 0;
+ HEK *hvname = NULL;
if (HvARRAY((HV*)sstr)) {
STRLEN i = 0;
++i;
}
if (SvOOK(sstr)) {
- struct xpvhv_aux *saux = HvAUX(sstr);
- struct xpvhv_aux *daux = HvAUX(dstr);
+ struct xpvhv_aux * const saux = HvAUX(sstr);
+ struct xpvhv_aux * const daux = HvAUX(dstr);
/* This flag isn't copied. */
/* SvOOK_on(hv) attacks the IV flags. */
SvFLAGS(dstr) |= SVf_OOK;
daux->xhv_eiter = saux->xhv_eiter
? he_dup(saux->xhv_eiter,
(bool)!!HvSHAREKEYS(sstr), param) : 0;
+ daux->xhv_backreferences = saux->xhv_backreferences
+ ? (AV*) SvREFCNT_inc(
+ sv_dup((SV*)saux->
+ xhv_backreferences,
+ param))
+ : 0;
}
}
else {
- SvPV_set(dstr, Nullch);
+ SvPV_set(dstr, NULL);
}
/* Record stashes for possible cloning in Perl_clone(). */
if(hvname)
av_push(param->stashes, dstr);
}
break;
- case SVt_PVFM:
case SVt_PVCV:
+ if (!(param->flags & CLONEf_COPY_STACKS)) {
+ CvDEPTH(dstr) = 0;
+ }
+ case SVt_PVFM:
/* NOTE: not refcounted */
CvSTASH(dstr) = hv_dup(CvSTASH(dstr), param);
OP_REFCNT_LOCK;
- CvROOT(dstr) = OpREFCNT_inc(CvROOT(dstr));
+ if (!CvISXSUB(dstr))
+ CvROOT(dstr) = OpREFCNT_inc(CvROOT(dstr));
OP_REFCNT_UNLOCK;
- if (CvCONST(dstr)) {
+ if (CvCONST(dstr) && CvISXSUB(dstr)) {
CvXSUBANY(dstr).any_ptr = GvUNIQUE(CvGV(dstr)) ?
SvREFCNT_inc(CvXSUBANY(dstr).any_ptr) :
sv_dup_inc((SV *)CvXSUBANY(dstr).any_ptr, param);
/* don't dup if copying back - CvGV isn't refcounted, so the
* duped GV may never be freed. A bit of a hack! DAPM */
CvGV(dstr) = (param->flags & CLONEf_JOIN_IN) ?
- Nullgv : gv_dup(CvGV(dstr), param) ;
- if (!(param->flags & CLONEf_COPY_STACKS)) {
- CvDEPTH(dstr) = 0;
- }
+ NULL : gv_dup(CvGV(dstr), param) ;
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))
+ if (!CvISXSUB(dstr))
CvFILE(dstr) = SAVEPV(CvFILE(dstr));
break;
}
ptr_table_store(PL_ptr_table, cxs, ncxs);
while (ix >= 0) {
- PERL_CONTEXT *cx = &cxs[ix];
- PERL_CONTEXT *ncx = &ncxs[ix];
+ PERL_CONTEXT * const cx = &cxs[ix];
+ PERL_CONTEXT * const ncx = &ncxs[ix];
ncx->cx_type = cx->cx_type;
if (CxTYPE(cx) == CXt_SUBST) {
Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
: 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;
OpREFCNT_inc(o);
break;
default:
- TOPPTR(nss,ix) = Nullop;
+ TOPPTR(nss,ix) = NULL;
break;
}
}
else
- TOPPTR(nss,ix) = Nullop;
+ TOPPTR(nss,ix) = NULL;
break;
case SAVEt_FREEPV:
c = (char*)POPPTR(ss,ix);
IV i;
CLONE_PARAMS clone_params;
- CLONE_PARAMS* param = &clone_params;
+ CLONE_PARAMS* const param = &clone_params;
- PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
+ PerlInterpreter * const 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_op = NULL;
+ PL_curcop = NULL;
PL_markstack = 0;
PL_scopestack = 0;
PL_savestack = 0;
IV i;
CLONE_PARAMS clone_params;
CLONE_PARAMS* param = &clone_params;
- PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
+ PerlInterpreter * const 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_op = NULL;
+ PL_curcop = NULL;
PL_markstack = 0;
PL_scopestack = 0;
PL_savestack = 0;
param->flags = flags;
param->proto_perl = proto_perl;
- /* arena roots */
- PL_xnv_arenaroot = NULL;
- PL_xnv_root = NULL;
- PL_xpv_arenaroot = NULL;
- PL_xpv_root = NULL;
- PL_xpviv_arenaroot = NULL;
- PL_xpviv_root = NULL;
- PL_xpvnv_arenaroot = NULL;
- PL_xpvnv_root = NULL;
- PL_xpvcv_arenaroot = NULL;
- PL_xpvcv_root = NULL;
- PL_xpvav_arenaroot = NULL;
- PL_xpvav_root = NULL;
- PL_xpvhv_arenaroot = NULL;
- PL_xpvhv_root = NULL;
- PL_xpvmg_arenaroot = NULL;
- PL_xpvmg_root = NULL;
- PL_xpvgv_arenaroot = NULL;
- PL_xpvgv_root = NULL;
- PL_xpvlv_arenaroot = NULL;
- PL_xpvlv_root = NULL;
- PL_xpvbm_arenaroot = NULL;
- PL_xpvbm_root = NULL;
- PL_he_arenaroot = NULL;
- PL_he_root = NULL;
-#if defined(USE_ITHREADS)
- PL_pte_arenaroot = NULL;
- PL_pte_root = NULL;
-#endif
+ INIT_TRACK_MEMPOOL(my_perl->Imemory_debug_header, my_perl);
+
+ PL_body_arenas = NULL;
+ 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_sv_root = NULL;
+ PL_sv_arenaroot = NULL;
PL_debug = proto_perl->Idebug;
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_regex_padav = newAV();
{
const I32 len = av_len((AV*)proto_perl->Iregex_padav);
- SV** const regexen = AvARRAY((AV*)proto_perl->Iregex_padav);
+ SV* const * const regexen = AvARRAY((AV*)proto_perl->Iregex_padav);
IV i;
- av_push(PL_regex_padav,
- sv_dup_inc(regexen[0],param));
+ av_push(PL_regex_padav, sv_dup_inc_NN(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)))
- ));
- }
+ const SV * const regex = regexen[i];
+ SV * const sv =
+ SvREPADTMP(regex)
+ ? sv_dup_inc(regex, param)
+ : SvREFCNT_inc(
+ newSViv(PTR2IV(re_dup(
+ INT2PTR(REGEXP *, SvIVX(regex)), param))))
+ ;
+ av_push(PL_regex_padav, sv);
}
}
PL_regex_pad = AvARRAY(PL_regex_padav);
if (proto_perl->Iop_mask)
PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
else
- PL_op_mask = Nullch;
+ PL_op_mask = NULL;
/* PL_asserting = proto_perl->Iasserting; */
/* current interpreter roots */
PL_lastfd = proto_perl->Ilastfd;
PL_oldname = proto_perl->Ioldname; /* XXX not quite right */
PL_Argv = NULL;
- PL_Cmd = Nullch;
+ PL_Cmd = NULL;
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_mess_sv = NULL;
PL_ors_sv = sv_dup_inc(proto_perl->Iors_sv, param);
}
else
PL_exitlist = (PerlExitListEntry*)NULL;
+
+ PL_my_cxt_size = proto_perl->Imy_cxt_size;
+ if (PL_my_cxt_size) {
+ Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
+ Copy(proto_perl->Imy_cxt_list, PL_my_cxt_list, PL_my_cxt_size, void *);
+ }
+ else
+ PL_my_cxt_list = (void**)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);
i = (PL_lex_casemods < 12 ? 12 : PL_lex_casemods);
PL_lex_casestack = SAVEPVN(proto_perl->Ilex_casestack,i);
+#ifdef PERL_MAD
+ Copy(proto_perl->Inexttoke, PL_nexttoke, 5, NEXTTOKE);
+ PL_lasttoke = proto_perl->Ilasttoke;
+ PL_realtokenstart = proto_perl->Irealtokenstart;
+ PL_faketokens = proto_perl->Ifaketokens;
+ PL_thismad = proto_perl->Ithismad;
+ PL_thistoken = proto_perl->Ithistoken;
+ PL_thisopen = proto_perl->Ithisopen;
+ PL_thisstuff = proto_perl->Ithisstuff;
+ PL_thisclose = proto_perl->Ithisclose;
+ PL_thiswhite = proto_perl->Ithiswhite;
+ PL_nextwhite = proto_perl->Inextwhite;
+ PL_skipwhite = proto_perl->Iskipwhite;
+ PL_endwhite = proto_perl->Iendwhite;
+ PL_curforce = proto_perl->Icurforce;
+#else
Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE);
Copy(proto_perl->Inexttype, PL_nexttype, 5, I32);
PL_nexttoke = proto_perl->Inexttoke;
+#endif
/* XXX This is probably masking the deeper issue of why
* SvANY(proto_perl->Ilinestr) can be NULL at this point. For test case:
PL_linestart = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
}
else {
- PL_linestr = NEWSV(65,79);
+ PL_linestr = newSV(79);
sv_upgrade(PL_linestr,SVt_PVIV);
sv_setpvn(PL_linestr,"",0);
PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
#endif
/* swatch cache */
- PL_last_swash_hv = Nullhv; /* reinits on demand */
+ PL_last_swash_hv = NULL; /* reinits on demand */
PL_last_swash_klen = 0;
PL_last_swash_key[0]= '\0';
PL_last_swash_tmps = (U8*)NULL;
PL_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 */
+ PL_bitcount = NULL; /* reinits on demand */
if (proto_perl->Ipsig_pend) {
Newxz(PL_psig_pend, SIG_SIZE, int);
else {
init_stacks();
ENTER; /* perl_destruct() wants to LEAVE; */
+
+ /* although we're not duplicating the tmps stack, we should still
+ * add entries for any SVs on the tmps stack that got cloned by a
+ * non-refcount means (eg a temp in @_); otherwise they will be
+ * orphaned
+ */
+ for (i = 0; i<= proto_perl->Ttmps_ix; i++) {
+ SV * const nsv = (SV*)ptr_table_fetch(PL_ptr_table,
+ proto_perl->Ttmps_stack[i]);
+ if (nsv && !SvREFCNT(nsv)) {
+ EXTEND_MORTAL(1);
+ PL_tmps_stack[++PL_tmps_ix] = SvREFCNT_inc_simple(nsv);
+ }
+ }
}
PL_start_env = proto_perl->Tstart_env; /* XXXXXX */
PL_op = proto_perl->Top;
- PL_Sv = Nullsv;
+ PL_Sv = NULL;
PL_Xpv = (XPV*)NULL;
PL_na = proto_perl->Tna;
PL_localizing = proto_perl->Tlocalizing;
PL_errors = sv_dup_inc(proto_perl->Terrors, param);
- PL_hv_fetch_ent_mh = Nullhe;
+ PL_hv_fetch_ent_mh = NULL;
PL_modcount = proto_perl->Tmodcount;
- PL_lastgotoprobe = Nullop;
+ PL_lastgotoprobe = NULL;
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_efloatbuf = NULL; /* reinits on demand */
PL_efloatsize = 0; /* reinits on demand */
/* regex stuff */
PL_screamfirst = NULL;
PL_screamnext = NULL;
PL_maxscream = -1; /* reinits on demand */
- PL_lastscream = Nullsv;
+ PL_lastscream = NULL;
PL_watchaddr = NULL;
- PL_watchok = Nullch;
+ PL_watchok = NULL;
PL_regdummy = proto_perl->Tregdummy;
- PL_regprecomp = Nullch;
+ PL_regprecomp = NULL;
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_reginput = NULL;
+ PL_regbol = NULL;
+ PL_regeol = NULL;
PL_regstartp = (I32*)NULL;
PL_regendp = (I32*)NULL;
PL_reglastparen = (U32*)NULL;
PL_reglastcloseparen = (U32*)NULL;
- PL_regtill = Nullch;
+ PL_regtill = NULL;
PL_reg_start_tmp = (char**)NULL;
PL_reg_start_tmpl = 0;
PL_regdata = (struct reg_data*)NULL;
- PL_bostr = Nullch;
+ PL_bostr = NULL;
PL_reg_flags = 0;
PL_reg_eval_set = 0;
PL_regnarrate = 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_ganch = NULL;
+ PL_reg_sv = NULL;
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_oldsaved = NULL;
PL_reg_oldsavedlen = 0;
#ifdef PERL_OLD_COPY_ON_WRITE
- PL_nrs = Nullsv;
+ PL_nrs = NULL;
#endif
PL_reg_maxiter = 0;
PL_reg_leftiter = 0;
- PL_reg_poscache = Nullch;
+ PL_reg_poscache = NULL;
PL_reg_poscache_size= 0;
/* RE engine - function pointers */
/* orphaned? eg threads->new inside BEGIN or use */
if (PL_compcv && ! SvREFCNT(PL_compcv)) {
- (void)SvREFCNT_inc(PL_compcv);
+ SvREFCNT_inc_simple_void(PL_compcv);
SAVEFREESV(PL_compcv);
}
else
Perl_croak(aTHX_ "Invalid argument to sv_cat_decode");
return ret;
+
+}
+
+/* ---------------------------------------------------------------------
+ *
+ * support functions for report_uninit()
+ */
+
+/* the maxiumum size of array or hash where we will scan looking
+ * for the undefined element that triggered the warning */
+
+#define FUV_MAX_SEARCH_SIZE 1000
+
+/* Look for an entry in the hash whose value has the same SV as val;
+ * If so, return a mortal copy of the key. */
+
+STATIC SV*
+S_find_hash_subscript(pTHX_ HV *hv, SV* val)
+{
+ dVAR;
+ register HE **array;
+ I32 i;
+
+ if (!hv || SvMAGICAL(hv) || !HvARRAY(hv) ||
+ (HvTOTALKEYS(hv) > FUV_MAX_SEARCH_SIZE))
+ return NULL;
+
+ array = HvARRAY(hv);
+
+ for (i=HvMAX(hv); i>0; i--) {
+ register HE *entry;
+ for (entry = array[i]; entry; entry = HeNEXT(entry)) {
+ if (HeVAL(entry) != val)
+ continue;
+ if ( HeVAL(entry) == &PL_sv_undef ||
+ HeVAL(entry) == &PL_sv_placeholder)
+ continue;
+ if (!HeKEY(entry))
+ return NULL;
+ if (HeKLEN(entry) == HEf_SVKEY)
+ return sv_mortalcopy(HeKEY_sv(entry));
+ return sv_2mortal(newSVpvn(HeKEY(entry), HeKLEN(entry)));
+ }
+ }
+ return NULL;
+}
+
+/* Look for an entry in the array whose value has the same SV as val;
+ * If so, return the index, otherwise return -1. */
+
+STATIC I32
+S_find_array_subscript(pTHX_ AV *av, SV* val)
+{
+ dVAR;
+ SV** svp;
+ I32 i;
+ if (!av || SvMAGICAL(av) || !AvARRAY(av) ||
+ (AvFILLp(av) > FUV_MAX_SEARCH_SIZE))
+ return -1;
+
+ svp = AvARRAY(av);
+ for (i=AvFILLp(av); i>=0; i--) {
+ if (svp[i] == val && svp[i] != &PL_sv_undef)
+ return i;
+ }
+ return -1;
+}
+
+/* S_varname(): return the name of a variable, optionally with a subscript.
+ * If gv is non-zero, use the name of that global, along with gvtype (one
+ * of "$", "@", "%"); otherwise use the name of the lexical at pad offset
+ * targ. Depending on the value of the subscript_type flag, return:
+ */
+
+#define FUV_SUBSCRIPT_NONE 1 /* "@foo" */
+#define FUV_SUBSCRIPT_ARRAY 2 /* "$foo[aindex]" */
+#define FUV_SUBSCRIPT_HASH 3 /* "$foo{keyname}" */
+#define FUV_SUBSCRIPT_WITHIN 4 /* "within @foo" */
+
+STATIC SV*
+S_varname(pTHX_ GV *gv, const char gvtype, PADOFFSET targ,
+ SV* keyname, I32 aindex, int subscript_type)
+{
+
+ SV * const name = sv_newmortal();
+ if (gv) {
+ char buffer[2];
+ buffer[0] = gvtype;
+ buffer[1] = 0;
+
+ /* as gv_fullname4(), but add literal '^' for $^FOO names */
+
+ gv_fullname4(name, gv, buffer, 0);
+
+ if ((unsigned int)SvPVX(name)[1] <= 26) {
+ buffer[0] = '^';
+ buffer[1] = SvPVX(name)[1] + 'A' - 1;
+
+ /* Swap the 1 unprintable control character for the 2 byte pretty
+ version - ie substr($name, 1, 1) = $buffer; */
+ sv_insert(name, 1, 1, buffer, 2);
+ }
+ }
+ else {
+ U32 unused;
+ CV * const cv = find_runcv(&unused);
+ SV *sv;
+ AV *av;
+
+ if (!cv || !CvPADLIST(cv))
+ return NULL;
+ 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);
+ *SvPVX(name) = '$';
+ Perl_sv_catpvf(aTHX_ name, "{%s}",
+ pv_display(sv,SvPVX_const(keyname), SvCUR(keyname), 0, 32));
+ SvREFCNT_dec(sv);
+ }
+ else if (subscript_type == FUV_SUBSCRIPT_ARRAY) {
+ *SvPVX(name) = '$';
+ Perl_sv_catpvf(aTHX_ name, "[%"IVdf"]", (IV)aindex);
+ }
+ else if (subscript_type == FUV_SUBSCRIPT_WITHIN)
+ Perl_sv_insert(aTHX_ name, 0, 0, STR_WITH_LEN("within "));
+
+ return name;
+}
+
+
+/*
+=for apidoc find_uninit_var
+
+Find the name of the undefined variable (if any) that caused the operator o
+to issue a "Use of uninitialized value" warning.
+If match is true, only return a name if it's value matches uninit_sv.
+So roughly speaking, if a unary operator (such as OP_COS) generates a
+warning, then following the direct child of the op may yield an
+OP_PADSV or OP_GV that gives the name of the undefined variable. On the
+other hand, with OP_ADD there are two branches to follow, so we only print
+the variable name if we get an exact match.
+
+The name is returned as a mortal SV.
+
+Assumes that PL_op is the op that originally triggered the error, and that
+PL_comppad/PL_curpad points to the currently executing pad.
+
+=cut
+*/
+
+STATIC SV *
+S_find_uninit_var(pTHX_ OP* obase, SV* uninit_sv, bool match)
+{
+ dVAR;
+ SV *sv;
+ AV *av;
+ GV *gv;
+ OP *o, *o2, *kid;
+
+ if (!obase || (match && (!uninit_sv || uninit_sv == &PL_sv_undef ||
+ uninit_sv == &PL_sv_placeholder)))
+ return NULL;
+
+ switch (obase->op_type) {
+
+ case OP_RV2AV:
+ case OP_RV2HV:
+ case OP_PADAV:
+ case OP_PADHV:
+ {
+ const bool pad = (obase->op_type == OP_PADAV || obase->op_type == OP_PADHV);
+ const bool hash = (obase->op_type == OP_PADHV || obase->op_type == OP_RV2HV);
+ I32 index = 0;
+ SV *keysv = NULL;
+ int subscript_type = FUV_SUBSCRIPT_WITHIN;
+
+ if (pad) { /* @lex, %lex */
+ sv = PAD_SVl(obase->op_targ);
+ gv = NULL;
+ }
+ else {
+ if (cUNOPx(obase)->op_first->op_type == OP_GV) {
+ /* @global, %global */
+ gv = cGVOPx_gv(cUNOPx(obase)->op_first);
+ if (!gv)
+ break;
+ sv = hash ? (SV*)GvHV(gv): (SV*)GvAV(gv);
+ }
+ else /* @{expr}, %{expr} */
+ return find_uninit_var(cUNOPx(obase)->op_first,
+ uninit_sv, match);
+ }
+
+ /* attempt to find a match within the aggregate */
+ if (hash) {
+ keysv = S_find_hash_subscript(aTHX_ (HV*)sv, uninit_sv);
+ if (keysv)
+ subscript_type = FUV_SUBSCRIPT_HASH;
+ }
+ else {
+ index = S_find_array_subscript(aTHX_ (AV*)sv, uninit_sv);
+ if (index >= 0)
+ subscript_type = FUV_SUBSCRIPT_ARRAY;
+ }
+
+ if (match && subscript_type == FUV_SUBSCRIPT_WITHIN)
+ break;
+
+ return varname(gv, hash ? '%' : '@', obase->op_targ,
+ keysv, index, subscript_type);
+ }
+
+ case OP_PADSV:
+ if (match && PAD_SVl(obase->op_targ) != uninit_sv)
+ break;
+ return varname(NULL, '$', obase->op_targ,
+ NULL, 0, FUV_SUBSCRIPT_NONE);
+
+ case OP_GVSV:
+ gv = cGVOPx_gv(obase);
+ if (!gv || (match && GvSV(gv) != uninit_sv))
+ break;
+ return varname(gv, '$', 0, NULL, 0, FUV_SUBSCRIPT_NONE);
+
+ case OP_AELEMFAST:
+ if (obase->op_flags & OPf_SPECIAL) { /* lexical array */
+ if (match) {
+ SV **svp;
+ av = (AV*)PAD_SV(obase->op_targ);
+ if (!av || SvRMAGICAL(av))
+ break;
+ svp = av_fetch(av, (I32)obase->op_private, FALSE);
+ if (!svp || *svp != uninit_sv)
+ break;
+ }
+ return varname(NULL, '$', obase->op_targ,
+ NULL, (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,
+ NULL, (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 = NULL;
+ o = cBINOPx(obase)->op_first;
+ kid = cBINOPx(obase)->op_last;
+
+ /* get the av or hv, and optionally the gv */
+ sv = NULL;
+ if (o->op_type == OP_PADAV || o->op_type == OP_PADHV) {
+ sv = PAD_SV(o->op_targ);
+ }
+ else if ((o->op_type == OP_RV2AV || o->op_type == OP_RV2HV)
+ && cUNOPo->op_first->op_type == OP_GV)
+ {
+ gv = cGVOPx_gv(cUNOPo->op_first);
+ if (!gv)
+ break;
+ sv = o->op_type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)GvAV(gv);
+ }
+ if (!sv)
+ break;
+
+ if (kid && kid->op_type == OP_CONST && SvOK(cSVOPx_sv(kid))) {
+ /* index is constant */
+ if (match) {
+ if (SvMAGICAL(sv))
+ break;
+ if (obase->op_type == OP_HELEM) {
+ HE* he = hv_fetch_ent((HV*)sv, cSVOPx_sv(kid), 0, 0);
+ if (!he || HeVAL(he) != uninit_sv)
+ break;
+ }
+ else {
+ SV * const * const svp = av_fetch((AV*)sv, SvIV(cSVOPx_sv(kid)), FALSE);
+ if (!svp || *svp != uninit_sv)
+ break;
+ }
+ }
+ if (obase->op_type == OP_HELEM)
+ return varname(gv, '%', o->op_targ,
+ cSVOPx_sv(kid), 0, FUV_SUBSCRIPT_HASH);
+ else
+ return varname(gv, '@', o->op_targ, NULL,
+ 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,
+ NULL, index, FUV_SUBSCRIPT_ARRAY);
+ }
+ if (match)
+ break;
+ return varname(gv,
+ (o->op_type == OP_PADAV || o->op_type == OP_RV2AV)
+ ? '@' : '%',
+ o->op_targ, NULL, 0, FUV_SUBSCRIPT_WITHIN);
+ }
+ break;
+
+ case OP_AASSIGN:
+ /* only examine RHS */
+ return find_uninit_var(cBINOPx(obase)->op_first, uninit_sv, match);
+
+ case OP_OPEN:
+ o = cUNOPx(obase)->op_first;
+ if (o->op_type == OP_PUSHMARK)
+ o = o->op_sibling;
+
+ if (!o->op_sibling) {
+ /* one-arg version of open is highly magical */
+
+ if (o->op_type == OP_GV) { /* open FOO; */
+ gv = cGVOPx_gv(o);
+ if (match && GvSV(gv) != uninit_sv)
+ break;
+ return varname(gv, '$', 0,
+ NULL, 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(newSVpvs("${$/}"));
+ /*FALLTHROUGH*/
+
+ default:
+ do_op:
+ if (!(obase->op_flags & OPf_KIDS))
+ break;
+ o = cUNOPx(obase)->op_first;
+
+ do_op2:
+ if (!o)
+ break;
+
+ /* if all except one arg are constant, or have no side-effects,
+ * or are optimized away, then it's unambiguous */
+ o2 = NULL;
+ 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 = NULL;
+ break;
+ }
+ o2 = kid;
+ }
+ if (o2)
+ return find_uninit_var(o2, uninit_sv, match);
+
+ /* scan all args */
+ while (o) {
+ sv = find_uninit_var(o, uninit_sv, 1);
+ if (sv)
+ return sv;
+ o = o->op_sibling;
+ }
+ break;
+ }
+ return NULL;
+}
+
+
+/*
+=for apidoc report_uninit
+
+Print appropriate "Use of uninitialized variable" warning
+
+=cut
+*/
+
+void
+Perl_report_uninit(pTHX_ SV* uninit_sv)
+{
+ dVAR;
+ if (PL_op) {
+ SV* varname = NULL;
+ if (uninit_sv) {
+ varname = find_uninit_var(PL_op, uninit_sv,0);
+ if (varname)
+ sv_insert(varname, 0, 0, " ", 1);
+ }
+ Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
+ varname ? SvPV_nolen_const(varname) : "",
+ " in ", OP_DESC(PL_op));
+ }
+ else
+ Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
+ "", "", "");
}
/*
projects / p5sagit/p5-mst-13.2.git / blobdiff