/* 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.
-In all but the most memory-paranoid configuations (ex: PURIFY), this
-allocation is done using arenas, which by default are approximately 4K
-chunks of memory parcelled up into N heads or bodies (of same size).
+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.
-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.
+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_body_arenaroots[] array of pointers to list of arenas, 1 per svtype
- PL_body_roots[] array of pointers to list of free bodies of svtype
- arrays are indexed by the svtype needed
-
-Note that some of the larger and more rarely used body types (eg
-xpvio) are not allocated using arenas, but are instead just
-malloc()/free()ed as required.
+ 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
-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.
+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.
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.
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,
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 uproot_SV(p) \
STMT_START { \
(p) = PL_sv_root; \
- PL_sv_root = (SV*)SvARENA_CHAIN(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;
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;
Safefree(sva);
}
- for (i=0; i<SVt_LAST; i++) {
- S_free_arena(aTHX_ (void**) PL_body_arenaroots[i]);
- PL_body_arenaroots[i] = 0;
- PL_body_roots[i] = 0;
+ {
+ 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;
contexts below (line ~10k)
*/
-STATIC void *
-S_more_bodies (pTHX_ size_t size, svtype sv_type)
+/* 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)
{
- void **arena_root = &PL_body_arenaroots[sv_type];
- void **root = &PL_body_roots[sv_type];
- char *start;
- const char *end;
- const size_t count = PERL_ARENA_SIZE / size;
-
- Newx(start, count*size, char);
- *((void **) start) = *arena_root;
- *arena_root = (void *)start;
-
- end = start + (count-1) * size;
-
- /* The initial slot is used to link the arenas together, so it isn't to be
- linked into the list of ready-to-use bodies. */
-
- start += size;
+ struct arena_desc* adesc;
+ struct arena_set *newroot, **aroot = (struct arena_set**) &PL_body_arenas;
+ int curr;
- *root = (void *)start;
+ /* shouldnt need this
+ if (!arena_size) arena_size = PERL_ARENA_SIZE;
+ */
- while (start < end) {
- char * const next = start + size;
- *(void**) start = (void *)next;
- start = next;
+ /* 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));
}
- *(void **)start = 0;
-
- return *root;
-}
-
-/* grab a new thing from the free list, allocating more if necessary */
-
-/* 1st, the inline version */
-
-#define new_body_inline(xpv, size, sv_type) \
- STMT_START { \
- void **r3wt = &PL_body_roots[sv_type]; \
- LOCK_SV_MUTEX; \
- xpv = *((void **)(r3wt)) \
- ? *((void **)(r3wt)) : S_more_bodies(aTHX_ size, sv_type); \
- *(r3wt) = *(void**)(xpv); \
- UNLOCK_SV_MUTEX; \
- } STMT_END
-
-/* now use the inline version in the proper function */
-
-#ifndef PURIFY
-/* This isn't being used with -DPURIFY, so don't declare it. Otherwise
- compilers issue warnings. */
+ /* 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));
-STATIC void *
-S_new_body(pTHX_ size_t size, svtype sv_type)
-{
- void *xpv;
- new_body_inline(xpv, size, sv_type);
- return xpv;
+ return adesc->arena;
}
-#endif
/* return a thing to the free list */
#define del_body(thing, root) \
STMT_START { \
- void **thing_copy = (void **)thing; \
+ void ** const thing_copy = (void **)thing;\
LOCK_SV_MUTEX; \
*thing_copy = *root; \
*root = (void*)thing_copy; \
} STMT_END
/*
- Revisiting type 3 arenas, there are 4 body-types which have some
- members that are never accessed. They are XPV, XPVIV, XPVAV,
- XPVHV, which have corresponding types: xpv_allocated,
- xpviv_allocated, xpvav_allocated, xpvhv_allocated,
-
- For these types, the arenas are carved up into *_allocated size
- chunks, we thus avoid wasted memory for those unaccessed members.
- When bodies are allocated, we adjust the pointer back in memory by
- the size of the bit not allocated, so it's as if we allocated the
- full structure. (But things will all go boom if you write to the
- part that is "not there", because you'll be overwriting the last
- members of the preceding structure in memory.)
-
- We calculate the correction using the STRUCT_OFFSET macro. For example, if
- xpv_allocated is the same structure as XPV then the two OFFSETs sum to zero,
- and the pointer is unchanged. If the allocated structure is smaller (no
- initial NV actually allocated) then the net effect is to subtract the size
- of the NV from the pointer, to return a new pointer as if an initial NV were
- actually allocated.
-
- This is the same trick as was used for NV and IV bodies. Ironically it
- doesn't need to be used for NV bodies any more, because NV is now at the
- start of the structure. IV bodies don't need it either, because they are
- no longer allocated. */
-
-/* The following 2 arrays hide the above details in a pair of
- lookup-tables, allowing us to be body-type agnostic.
-
- size maps svtype to its body's allocated size.
- offset maps svtype to the body-pointer adjustment needed
-
- NB: elements in latter are 0 or <0, and are added during
- allocation, and subtracted during deallocation. It may be clearer
- to invert the values, and call it shrinkage_by_svtype.
+
+=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.
+
+*/
+
+/*
+
+For each sv-type, struct body_details bodies_by_type[] carries
+parameters which control these aspects of SV handling:
+
+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.
+
+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.
+
+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.
+
+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,
+
+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.
+
*/
struct body_details {
- size_t size; /* Size to allocate */
- size_t copy; /* Size of structure to copy (may be shorter) */
- size_t offset;
- bool cant_upgrade; /* Can upgrade this type */
- bool zero_nv; /* zero the NV when upgrading from this */
- bool arena; /* Allocated from an arena */
+ 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 */
};
#define HADNV FALSE
#define NONV TRUE
+
#ifdef PURIFY
/* With -DPURFIY we allocate everything directly, and don't use arenas.
This seems a rather elegant way to simplify some of the code below. */
#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 {
+ sizeof (((type*)SvANY((SV*)0))->last_member)
static const struct body_details bodies_by_type[] = {
- {0, 0, 0, FALSE, NONV, NOARENA},
- /* IVs are in the head, so the allocation size is 0 */
- {0, sizeof(IV), STRUCT_OFFSET(XPVIV, xiv_iv), FALSE, NONV, NOARENA},
+ { 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, FALSE, HADNV, HASARENA},
- /* RVs are in the head now */
- /* However, this slot is overloaded and used by the pte */
- {0, 0, 0, FALSE, NONV, NOARENA},
+ { 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, xpv_allocated, xpv_cur),
- - relative_STRUCT_OFFSET(XPV, xpv_allocated, xpv_cur),
- FALSE, NONV, HASARENA},
+ { 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, xpviv_allocated, xpv_cur),
- - relative_STRUCT_OFFSET(XPVIV, xpviv_allocated, xpv_cur),
- FALSE, NONV, HASARENA},
+ { 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, FALSE, HADNV, HASARENA},
+ { 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, FALSE, HADNV, HASARENA},
+ { sizeof(XPVMG), copy_length(XPVMG, xmg_stash), 0, SVt_PVMG, FALSE, HADNV,
+ HASARENA, FIT_ARENA(0, sizeof(XPVMG)) },
+
/* 36 */
- {sizeof(XPVBM), sizeof(XPVBM), 0, TRUE, HADNV, HASARENA},
+ { sizeof(XPVBM), sizeof(XPVBM), 0, SVt_PVBM, TRUE, HADNV,
+ HASARENA, FIT_ARENA(0, sizeof(XPVBM)) },
+
/* 48 */
- {sizeof(XPVGV), sizeof(XPVGV), 0, TRUE, HADNV, HASARENA},
+ { sizeof(XPVGV), sizeof(XPVGV), 0, SVt_PVGV, TRUE, HADNV,
+ HASARENA, FIT_ARENA(0, sizeof(XPVGV)) },
+
/* 64 */
- {sizeof(XPVLV), sizeof(XPVLV), 0, TRUE, HADNV, HASARENA},
- /* 20 */
- {sizeof(xpvav_allocated),
- copy_length(XPVAV, xmg_stash)
- + relative_STRUCT_OFFSET(XPVAV, xpvav_allocated, xav_fill),
- - relative_STRUCT_OFFSET(XPVAV, xpvav_allocated, xav_fill),
- TRUE, HADNV, HASARENA},
- /* 20 */
- {sizeof(xpvhv_allocated),
- copy_length(XPVHV, xmg_stash)
- + relative_STRUCT_OFFSET(XPVHV, xpvhv_allocated, xhv_fill),
- - relative_STRUCT_OFFSET(XPVHV, xpvhv_allocated, xhv_fill),
- TRUE, HADNV, HASARENA},
- /* 76 */
- {sizeof(XPVCV), sizeof(XPVCV), 0, TRUE, HADNV, HASARENA},
- /* 80 */
- {sizeof(XPVFM), sizeof(XPVFM), 0, TRUE, HADNV, NOARENA},
- /* 84 */
- {sizeof(XPVIO), sizeof(XPVIO), 0, TRUE, HADNV, NOARENA}
+ { sizeof(XPVLV), sizeof(XPVLV), 0, SVt_PVLV, TRUE, HADNV,
+ HASARENA, FIT_ARENA(0, sizeof(XPVLV)) },
+
+ { 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)) },
+
+ { 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)) },
+
+ /* 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)) },
+
+ { 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)) },
+
+ /* XPVIO is 84 bytes, fits 48x */
+ { sizeof(XPVIO), sizeof(XPVIO), 0, SVt_PVIO, TRUE, HADNV,
+ HASARENA, FIT_ARENA(24, sizeof(XPVIO)) },
};
-#define new_body_type(sv_type) \
- (void *)((char *)S_new_body(aTHX_ bodies_by_type[sv_type].size, sv_type)\
- - bodies_by_type[sv_type].offset)
+#define new_body_type(sv_type) \
+ (void *)((char *)S_new_body(aTHX_ sv_type))
#define del_body_type(p, sv_type) \
del_body(p, &PL_body_roots[sv_type])
#define new_body_allocated(sv_type) \
- (void *)((char *)S_new_body(aTHX_ bodies_by_type[sv_type].size, sv_type)\
+ (void *)((char *)S_new_body(aTHX_ sv_type) \
- bodies_by_type[sv_type].offset)
#define del_body_allocated(p, sv_type) \
/* no arena for you! */
#define new_NOARENA(details) \
- my_safemalloc((details)->size + (details)->offset)
+ my_safemalloc((details)->body_size + (details)->offset)
#define new_NOARENAZ(details) \
- my_safecalloc((details)->size + (details)->offset)
+ my_safecalloc((details)->body_size + (details)->offset)
+
+#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;
+
+ assert(bdp->arena_size);
+
+#ifdef DEBUGGING
+ if (!done_sanity_check) {
+ unsigned int i = SVt_LAST;
+
+ done_sanity_check = TRUE;
+
+ while (i--)
+ assert (bodies_by_type[i].type == i);
+ }
+#endif
+
+ start = (char*) Perl_get_arena(aTHX_ bdp->arena_size);
+
+ end = start + bdp->arena_size - body_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 + body_size;
+ *(void**) start = (void *)next;
+ start = next;
+ }
+ *(void **)start = 0;
+
+ return *root;
+}
+
+/* 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 **)(r3wt)) \
+ ? *((void **)(r3wt)) : S_more_bodies(aTHX_ sv_type); \
+ *(r3wt) = *(void**)(xpv); \
+ UNLOCK_SV_MUTEX; \
+ } STMT_END
+
+#ifndef PURIFY
+
+STATIC void *
+S_new_body(pTHX_ svtype sv_type)
+{
+ dVAR;
+ void *xpv;
+ new_body_inline(xpv, sv_type);
+ return xpv;
+}
+
+#endif
/*
=for apidoc sv_upgrade
void
Perl_sv_upgrade(pTHX_ register SV *sv, U32 new_type)
{
+ dVAR;
void* old_body;
void* new_body;
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;
- const struct body_details *new_type_details = bodies_by_type + new_type;
if (new_type != SVt_PV && SvIsCOW(sv)) {
sv_force_normal_flags(sv, 0);
if (new_type < SVt_PVIV) {
new_type = (new_type == SVt_NV)
? SVt_PVNV : SVt_PVIV;
- new_type_details = bodies_by_type + new_type;
}
break;
case SVt_NV:
if (new_type < SVt_PVNV) {
new_type = SVt_PVNV;
- new_type_details = bodies_by_type + new_type;
}
break;
case SVt_RV:
/* 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);
+ assert(!SvPAD_TYPED(sv));
break;
default:
if (old_type_details->cant_upgrade)
- Perl_croak(aTHX_ "Can't upgrade that kind of scalar");
+ 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) |= new_type;
+ /* 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_NULL:
- Perl_croak(aTHX_ "Can't upgrade to undef");
case SVt_IV:
assert(old_type == SVt_NULL);
SvANY(sv) = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
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_PVNV:
case SVt_PV:
- assert(new_type_details->size);
+ 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_details->size, new_type);
- Zero(new_body, new_type_details->size, char);
+ 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_type_details->copy) {
- Copy((char *)old_body + old_type_details->offset,
- (char *)new_body + old_type_details->offset,
- old_type_details->copy, char);
+ /* 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 NV 0.0 is store as all bits 0 then Zero() already creates a correct
- 0.0 for us. */
- if (old_type_details->zero_nv)
+ /* 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 (new_type == SVt_PVIO)
- IoPAGE_LEN(sv) = 60;
+ 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", new_type);
+ Perl_croak(aTHX_ "panic: sv_upgrade to unknown type %lu",
+ (unsigned long)new_type);
}
- if (old_type_details->size) {
- /* If the old body had an allocated size, then we need to free it. */
+ 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
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);
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);
- }
- }
- }
-#else /* NV_PRESERVES_UV */
- if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
- == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
- /* The IV slot will have been set from value returned by
- grok_number above. The NV slot has just been set using
- Atof. */
- SvNOK_on(sv);
+ (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/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) >
}
#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 */
-
-STATIC IV
-S_asIV(pTHX_ SV *sv)
-{
- UV value;
- const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
-
- if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
- == IS_NUMBER_IN_UV) {
- /* It's definitely an integer */
- if (numtype & IS_NUMBER_NEG) {
- if (value < (UV)IV_MIN)
- return -(IV)value;
- } else {
- if (value < (UV)IV_MAX)
- return (IV)value;
- }
- }
- if (!numtype) {
- if (ckWARN(WARN_NUMERIC))
- not_a_number(sv);
- }
- return I_V(Atof(SvPVX_const(sv)));
-}
-
-/* asUV(): extract an unsigned integer from the string value of an SV
- * Caller must validate PVX */
-
-STATIC UV
-S_asUV(pTHX_ SV *sv)
-{
- UV value;
- const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
-
- if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
- == IS_NUMBER_IN_UV) {
- /* It's definitely an integer */
- if (!(numtype & IS_NUMBER_NEG))
- return value;
- }
- if (!numtype) {
- if (ckWARN(WARN_NUMERIC))
- not_a_number(sv);
- }
- return U_V(Atof(SvPVX_const(sv)));
-}
-
/* uiv_2buf(): private routine for use by sv_2pv_flags(): print an IV or
* UV as a string towards the end of buf, and return pointers to start and
* end of it.
return ptr;
}
+/* 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;
- 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;
-
- 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;
- } else {
+ }
+ {
+ SV *tsv;
MAGIC *mg;
const SV *const referent = (SV*)SvRV(sv);
if (!referent) {
- tsv = sv_2mortal(newSVpvn("NULLREF", 7));
+ 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))) {
- 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(sv);
- else
- SvUTF8_off(sv);
- if (lp)
- *lp = mg->mg_len;
- return mg->mg_ptr;
+ return stringify_regexp(sv, mg, lp);
} else {
const char *const typestr = sv_reftype(referent, 0);
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 */
-
- 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);
- }
}
/*
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 (sflags & SVf_ROK) {
+ 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;
+ }
+ S_glob_assign_glob(aTHX_ dstr, sstr, dtype);
+ return;
+ }
+
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;
- }
- 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);
+ 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) {
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;
+ }
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) {
cv_undef((CV*)sv);
goto freescalar;
case SVt_PVHV:
+ Perl_hv_kill_backrefs(aTHX_ (HV*)sv);
hv_undef((HV*)sv);
break;
case SVt_PVAV:
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))
case SVt_PV:
case SVt_RV:
if (SvROK(sv)) {
- SV *target = SvRV(sv);
+ SV * const target = SvRV(sv);
if (SvWEAKREF(sv))
sv_del_backref(target, sv);
else
del_body(((char *)SvANY(sv) + sv_type_details->offset),
&PL_body_roots[type]);
}
- else if (sv_type_details->size) {
+ else if (sv_type_details->body_size) {
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. */
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 = veclen;
- 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) {
+ if (!vectorize && !args) {
if (efix) {
const I32 i = efix-1;
argsv = (i >= 0 && i < svmax) ? svargs[i] : &PL_sv_undef;
/* 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;
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 */
}
#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 * const amtp = (AMT*)mg->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++) {
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
/* 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, sizeof(struct ptr_tbl_ent), PTE_SVSLOT);
- tblent->oldval = oldsv;
- tblent->newval = newsv;
- tblent->next = *otblent;
- *otblent = tblent;
- tbl->tbl_items++;
- if (!empty && tbl->tbl_items > tbl->tbl_max)
- ptr_table_split(tbl);
}
/* double the hash bucket size of an existing ptr table */
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);
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)) {
- /* Do sharing here, and fall through */
+ /*EMPTY*/; /* Do sharing here, and fall through */
}
case SVt_PVIO:
case SVt_PVFM:
case SVt_PVNV:
case SVt_PVIV:
case SVt_PV:
- assert(sv_type_details->copy);
+ assert(sv_type_details->body_size);
if (sv_type_details->arena) {
- new_body_inline(new_body, sv_type_details->copy, sv_type);
+ new_body_inline(new_body, sv_type);
new_body
= (void*)((char*)new_body - sv_type_details->offset);
} else {
#else
Copy(((char*)SvANY(sstr)),
((char*)SvANY(dstr)),
- sv_type_details->size + sv_type_details->offset, char);
+ sv_type_details->body_size + sv_type_details->offset, char);
#endif
- if (sv_type != SVt_PVAV && sv_type != 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
missing by always going for the destination.
FIXME - instrument and check that assumption */
if (sv_type >= SVt_PVMG) {
- if (SvMAGIC(dstr))
+ 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));
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;
- Zero(&PL_body_arenaroots, 1, PL_body_arenaroots);
+ 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);
}
if (!hv || SvMAGICAL(hv) || !HvARRAY(hv) ||
(HvTOTALKEYS(hv) > FUV_MAX_SEARCH_SIZE))
- return Nullsv;
+ return NULL;
array = HvARRAY(hv);
HeVAL(entry) == &PL_sv_placeholder)
continue;
if (!HeKEY(entry))
- return Nullsv;
+ return NULL;
if (HeKLEN(entry) == HEf_SVKEY)
return sv_mortalcopy(HeKEY_sv(entry));
return sv_2mortal(newSVpvn(HeKEY(entry), HeKLEN(entry)));
}
}
- return Nullsv;
+ return NULL;
}
/* Look for an entry in the array whose value has the same SV as val;
STATIC I32
S_find_array_subscript(pTHX_ AV *av, SV* val)
{
+ dVAR;
SV** svp;
I32 i;
if (!av || SvMAGICAL(av) || !AvARRAY(av) ||
AV *av;
if (!cv || !CvPADLIST(cv))
- return Nullsv;
+ 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 */
}
if (subscript_type == FUV_SUBSCRIPT_HASH) {
- SV * const sv = NEWSV(0,0);
+ SV * const sv = newSV(0);
*SvPVX(name) = '$';
Perl_sv_catpvf(aTHX_ name, "{%s}",
pv_display(sv,SvPVX_const(keyname), SvCUR(keyname), 0, 32));
Perl_sv_catpvf(aTHX_ name, "[%"IVdf"]", (IV)aindex);
}
else if (subscript_type == FUV_SUBSCRIPT_WITHIN)
- sv_insert(name, 0, 0, "within ", 7);
+ Perl_sv_insert(aTHX_ name, 0, 0, STR_WITH_LEN("within "));
return name;
}
if (!obase || (match && (!uninit_sv || uninit_sv == &PL_sv_undef ||
uninit_sv == &PL_sv_placeholder)))
- return Nullsv;
+ return NULL;
switch (obase->op_type) {
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;
+ SV *keysv = NULL;
int subscript_type = FUV_SUBSCRIPT_WITHIN;
if (pad) { /* @lex, %lex */
sv = PAD_SVl(obase->op_targ);
- gv = Nullgv;
+ gv = NULL;
}
else {
if (cUNOPx(obase)->op_first->op_type == OP_GV) {
case OP_PADSV:
if (match && PAD_SVl(obase->op_targ) != uninit_sv)
break;
- return varname(Nullgv, '$', obase->op_targ,
- Nullsv, 0, FUV_SUBSCRIPT_NONE);
+ 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, Nullsv, 0, FUV_SUBSCRIPT_NONE);
+ return varname(gv, '$', 0, NULL, 0, FUV_SUBSCRIPT_NONE);
case OP_AELEMFAST:
if (obase->op_flags & OPf_SPECIAL) { /* lexical array */
if (!svp || *svp != uninit_sv)
break;
}
- return varname(Nullgv, '$', obase->op_targ,
- Nullsv, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY);
+ return varname(NULL, '$', obase->op_targ,
+ NULL, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY);
}
else {
gv = cGVOPx_gv(obase);
break;
}
return varname(gv, '$', 0,
- Nullsv, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY);
+ NULL, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY);
}
break;
/* $a[uninit_expr] or $h{uninit_expr} */
return find_uninit_var(cBINOPx(obase)->op_last, uninit_sv, match);
- gv = Nullgv;
+ gv = NULL;
o = cBINOPx(obase)->op_first;
kid = cBINOPx(obase)->op_last;
/* get the av or hv, and optionally the gv */
- sv = Nullsv;
+ sv = NULL;
if (o->op_type == OP_PADAV || o->op_type == OP_PADHV) {
sv = PAD_SV(o->op_targ);
}
break;
}
else {
- SV ** const svp = av_fetch((AV*)sv, SvIV(cSVOPx_sv(kid)), FALSE);
+ SV * const * const svp = av_fetch((AV*)sv, SvIV(cSVOPx_sv(kid)), FALSE);
if (!svp || *svp != uninit_sv)
break;
}
return varname(gv, '%', o->op_targ,
cSVOPx_sv(kid), 0, FUV_SUBSCRIPT_HASH);
else
- return varname(gv, '@', o->op_targ, Nullsv,
+ return varname(gv, '@', o->op_targ, NULL,
SvIV(cSVOPx_sv(kid)), FUV_SUBSCRIPT_ARRAY);
- ;
}
else {
/* index is an expression;
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);
+ NULL, 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);
+ o->op_targ, NULL, 0, FUV_SUBSCRIPT_WITHIN);
}
-
break;
case OP_AASSIGN:
if (match && GvSV(gv) != uninit_sv)
break;
return varname(gv, '$', 0,
- Nullsv, 0, FUV_SUBSCRIPT_NONE);
+ NULL, 0, FUV_SUBSCRIPT_NONE);
}
/* other possibilities not handled are:
* open $x; or open my $x; should return '${*$x}'
case OP_SCHOMP:
case OP_CHOMP:
if (SvROK(PL_rs) && uninit_sv == SvRV(PL_rs))
- return sv_2mortal(newSVpvn("${$/}", 5));
- /* FALL THROUGH */
+ return sv_2mortal(newSVpvs("${$/}"));
+ /*FALLTHROUGH*/
default:
do_op:
/* if all except one arg are constant, or have no side-effects,
* or are optimized away, then it's unambiguous */
- o2 = Nullop;
+ o2 = NULL;
for (kid=o; kid; kid = kid->op_sibling) {
if (kid &&
( (kid->op_type == OP_CONST && SvOK(cSVOPx_sv(kid)))
)
continue;
if (o2) { /* more than one found */
- o2 = Nullop;
+ o2 = NULL;
break;
}
o2 = kid;
}
break;
}
- return Nullsv;
+ return NULL;
}
void
Perl_report_uninit(pTHX_ SV* uninit_sv)
{
+ dVAR;
if (PL_op) {
- SV* varname = Nullsv;
+ SV* varname = NULL;
if (uninit_sv) {
varname = find_uninit_var(PL_op, uninit_sv,0);
if (varname)
projects / p5sagit/p5-mst-13.2.git / blobdiff