#ifdef PERL_COPY_ON_WRITE
#define SV_COW_NEXT_SV(sv) INT2PTR(SV *,SvUVX(sv))
-#define SV_COW_NEXT_SV_SET(current,next) SvUVX(current) = PTR2UV(next)
+#define SV_COW_NEXT_SV_SET(current,next) SvUV_set(current, PTR2UV(next))
/* This is a pessimistic view. Scalar must be purely a read-write PV to copy-
on-write. */
#endif
pointer to the body (struct xrv, xpv, xpviv...), which contains fields
specific to each type.
-Normally, this allocation is done using arenas, which are approximately
-1K chunks of memory parcelled up into N heads or bodies. The first slot
-in each arena is reserved, and is used to hold a link to the next arena.
-In the case of heads, the unused first slot also contains some flags and
-a note of the number of slots. Snaked through each arena chain is a
+Normally, this allocation is done using arenas, which by default are
+approximately 4K chunks of memory parcelled up into N heads or bodies. The
+first slot in each arena is reserved, and is used to hold a link to the next
+arena. In the case of heads, the unused first slot also contains some flags
+and a note of the number of slots. Snaked through each arena chain is a
linked list of free items; when this becomes empty, an extra arena is
-allocated and divided up into N items which are threaded into the free
-list.
+allocated and divided up into N items which are threaded into the free list.
The following global variables are associated with arenas:
required. Also, if PURIFY is defined, arenas are abandoned altogether,
with all items individually malloc()ed. In addition, a few SV heads are
not allocated from an arena, but are instead directly created as static
-or auto variables, eg PL_sv_undef.
+or auto variables, eg PL_sv_undef. The size of arenas can be changed from
+the default by setting PERL_ARENA_SIZE appropriately at compile time.
The SV arena serves the secondary purpose of allowing still-live SVs
to be located and destroyed during final cleanup.
* "A time to plant, and a time to uproot what was planted..."
*/
+
+#ifdef DEBUG_LEAKING_SCALARS
+# ifdef NETWARE
+# define FREE_SV_DEBUG_FILE(sv) PerlMemfree((sv)->sv_debug_file)
+# else
+# define FREE_SV_DEBUG_FILE(sv) PerlMemShared_free((sv)->sv_debug_file)
+# endif
+#else
+# define FREE_SV_DEBUG_FILE(sv)
+#endif
+
#define plant_SV(p) \
STMT_START { \
+ FREE_SV_DEBUG_FILE(p); \
SvANY(p) = (void *)PL_sv_root; \
SvFLAGS(p) = SVTYPEMASK; \
PL_sv_root = (p); \
} STMT_END
+/* make some more SVs by adding another arena */
+
+/* sv_mutex must be held while calling more_sv() */
+STATIC SV*
+S_more_sv(pTHX)
+{
+ SV* sv;
+
+ if (PL_nice_chunk) {
+ sv_add_arena(PL_nice_chunk, PL_nice_chunk_size, 0);
+ PL_nice_chunk = Nullch;
+ PL_nice_chunk_size = 0;
+ }
+ else {
+ char *chunk; /* must use New here to match call to */
+ New(704,chunk,PERL_ARENA_SIZE,char); /* Safefree() in sv_free_arenas() */
+ sv_add_arena(chunk, PERL_ARENA_SIZE, 0);
+ }
+ uproot_SV(sv);
+ return sv;
+}
+
/* new_SV(): return a new, empty SV head */
#ifdef DEBUG_LEAKING_SCALARS
if (PL_sv_root)
uproot_SV(sv);
else
- sv = more_sv();
+ sv = S_more_sv(aTHX);
UNLOCK_SV_MUTEX;
SvANY(sv) = 0;
SvREFCNT(sv) = 1;
SvFLAGS(sv) = 0;
+ sv->sv_debug_optype = PL_op ? PL_op->op_type : 0;
+ sv->sv_debug_line = (U16) ((PL_copline == NOLINE) ?
+ (PL_curcop ? CopLINE(PL_curcop) : 0) : PL_copline);
+ sv->sv_debug_inpad = 0;
+ sv->sv_debug_cloned = 0;
+# ifdef NETWARE
+ sv->sv_debug_file = PL_curcop ? savepv(CopFILE(PL_curcop)): NULL;
+# else
+ sv->sv_debug_file = PL_curcop ? savesharedpv(CopFILE(PL_curcop)): NULL;
+# endif
+
return sv;
}
# define new_SV(p) (p)=S_new_SV(aTHX)
if (PL_sv_root) \
uproot_SV(p); \
else \
- (p) = more_sv(); \
+ (p) = S_more_sv(aTHX); \
UNLOCK_SV_MUTEX; \
SvANY(p) = 0; \
SvREFCNT(p) = 1; \
{
if (DEBUG_D_TEST) {
SV* sva;
- SV* sv;
- SV* svend;
- int ok = 0;
+ bool ok = 0;
for (sva = PL_sv_arenaroot; sva; sva = (SV *) SvANY(sva)) {
- sv = sva + 1;
- svend = &sva[SvREFCNT(sva)];
- if (p >= sv && p < svend)
+ SV *sv = sva + 1;
+ SV *svend = &sva[SvREFCNT(sva)];
+ if (p >= sv && p < svend) {
ok = 1;
+ break;
+ }
}
if (!ok) {
if (ckWARN_d(WARN_INTERNAL))
sv = sva + 1;
while (sv < svend) {
SvANY(sv) = (void *)(SV*)(sv + 1);
+#ifdef DEBUGGING
SvREFCNT(sv) = 0;
+#endif
+ /* Must always set typemask because it's awlays checked in on cleanup
+ when the arenas are walked looking for objects. */
SvFLAGS(sv) = SVTYPEMASK;
sv++;
}
SvANY(sv) = 0;
+#ifdef DEBUGGING
+ SvREFCNT(sv) = 0;
+#endif
SvFLAGS(sv) = SVTYPEMASK;
}
-/* make some more SVs by adding another arena */
-
-/* sv_mutex must be held while calling more_sv() */
-STATIC SV*
-S_more_sv(pTHX)
-{
- register SV* sv;
-
- if (PL_nice_chunk) {
- sv_add_arena(PL_nice_chunk, PL_nice_chunk_size, 0);
- PL_nice_chunk = Nullch;
- PL_nice_chunk_size = 0;
- }
- else {
- char *chunk; /* must use New here to match call to */
- New(704,chunk,1008,char); /* Safefree() in sv_free_arenas() */
- sv_add_arena(chunk, 1008, 0);
- }
- uproot_SV(sv);
- return sv;
-}
-
/* visit(): call the named function for each non-free SV in the arenas
* whose flags field matches the flags/mask args. */
S_visit(pTHX_ SVFUNC_t f, U32 flags, U32 mask)
{
SV* sva;
- SV* sv;
- register SV* svend;
I32 visited = 0;
for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
- svend = &sva[SvREFCNT(sva)];
+ register SV * const svend = &sva[SvREFCNT(sva)];
+ register SV* sv;
for (sv = sva + 1; sv < svend; ++sv) {
if (SvTYPE(sv) != SVTYPEMASK
&& (sv->sv_flags & mask) == flags
if (SvWEAKREF(sv)) {
sv_del_backref(sv);
SvWEAKREF_off(sv);
- SvRV(sv) = 0;
+ SvRV_set(sv, NULL);
} else {
SvROK_off(sv);
- SvRV(sv) = 0;
+ SvRV_set(sv, NULL);
SvREFCNT_dec(rv);
}
}
{
SV* sva;
SV* svanext;
- XPV *arena, *arenanext;
+ void *arena, *arenanext;
/* Free arenas here, but be careful about fake ones. (We assume
contiguity of the fake ones with the corresponding real ones.) */
svanext = (SV*) SvANY(svanext);
if (!SvFAKE(sva))
- Safefree((void *)sva);
+ Safefree(sva);
}
- for (arena = PL_xiv_arenaroot; arena; arena = arenanext) {
- arenanext = (XPV*)arena->xpv_pv;
- Safefree(arena);
- }
- PL_xiv_arenaroot = 0;
- PL_xiv_root = 0;
-
for (arena = PL_xnv_arenaroot; arena; arena = arenanext) {
- arenanext = (XPV*)arena->xpv_pv;
+ arenanext = *(void **)arena;
Safefree(arena);
}
PL_xnv_arenaroot = 0;
PL_xnv_root = 0;
- for (arena = PL_xrv_arenaroot; arena; arena = arenanext) {
- arenanext = (XPV*)arena->xpv_pv;
- Safefree(arena);
- }
- PL_xrv_arenaroot = 0;
- PL_xrv_root = 0;
-
for (arena = PL_xpv_arenaroot; arena; arena = arenanext) {
- arenanext = (XPV*)arena->xpv_pv;
+ arenanext = *(void **)arena;
Safefree(arena);
}
PL_xpv_arenaroot = 0;
PL_xpv_root = 0;
- for (arena = (XPV*)PL_xpviv_arenaroot; arena; arena = arenanext) {
- arenanext = (XPV*)arena->xpv_pv;
+ for (arena = PL_xpviv_arenaroot; arena; arena = arenanext) {
+ arenanext = *(void **)arena;
Safefree(arena);
}
PL_xpviv_arenaroot = 0;
PL_xpviv_root = 0;
- for (arena = (XPV*)PL_xpvnv_arenaroot; arena; arena = arenanext) {
- arenanext = (XPV*)arena->xpv_pv;
+ for (arena = PL_xpvnv_arenaroot; arena; arena = arenanext) {
+ arenanext = *(void **)arena;
Safefree(arena);
}
PL_xpvnv_arenaroot = 0;
PL_xpvnv_root = 0;
- for (arena = (XPV*)PL_xpvcv_arenaroot; arena; arena = arenanext) {
- arenanext = (XPV*)arena->xpv_pv;
+ for (arena = PL_xpvcv_arenaroot; arena; arena = arenanext) {
+ arenanext = *(void **)arena;
Safefree(arena);
}
PL_xpvcv_arenaroot = 0;
PL_xpvcv_root = 0;
- for (arena = (XPV*)PL_xpvav_arenaroot; arena; arena = arenanext) {
- arenanext = (XPV*)arena->xpv_pv;
+ for (arena = PL_xpvav_arenaroot; arena; arena = arenanext) {
+ arenanext = *(void **)arena;
Safefree(arena);
}
PL_xpvav_arenaroot = 0;
PL_xpvav_root = 0;
- for (arena = (XPV*)PL_xpvhv_arenaroot; arena; arena = arenanext) {
- arenanext = (XPV*)arena->xpv_pv;
+ for (arena = PL_xpvhv_arenaroot; arena; arena = arenanext) {
+ arenanext = *(void **)arena;
Safefree(arena);
}
PL_xpvhv_arenaroot = 0;
PL_xpvhv_root = 0;
- for (arena = (XPV*)PL_xpvmg_arenaroot; arena; arena = arenanext) {
- arenanext = (XPV*)arena->xpv_pv;
+ for (arena = PL_xpvmg_arenaroot; arena; arena = arenanext) {
+ arenanext = *(void **)arena;
Safefree(arena);
}
PL_xpvmg_arenaroot = 0;
PL_xpvmg_root = 0;
- for (arena = (XPV*)PL_xpvlv_arenaroot; arena; arena = arenanext) {
- arenanext = (XPV*)arena->xpv_pv;
+ for (arena = PL_xpvgv_arenaroot; arena; arena = arenanext) {
+ arenanext = *(void **)arena;
+ Safefree(arena);
+ }
+ PL_xpvgv_arenaroot = 0;
+ PL_xpvgv_root = 0;
+
+ for (arena = PL_xpvlv_arenaroot; arena; arena = arenanext) {
+ arenanext = *(void **)arena;
Safefree(arena);
}
PL_xpvlv_arenaroot = 0;
PL_xpvlv_root = 0;
- for (arena = (XPV*)PL_xpvbm_arenaroot; arena; arena = arenanext) {
- arenanext = (XPV*)arena->xpv_pv;
+ for (arena = PL_xpvbm_arenaroot; arena; arena = arenanext) {
+ arenanext = *(void **)arena;
Safefree(arena);
}
PL_xpvbm_arenaroot = 0;
PL_xpvbm_root = 0;
- for (arena = (XPV*)PL_he_arenaroot; arena; arena = arenanext) {
- arenanext = (XPV*)arena->xpv_pv;
- Safefree(arena);
+ {
+ HE *he;
+ HE *he_next;
+ for (he = PL_he_arenaroot; he; he = he_next) {
+ he_next = HeNEXT(he);
+ Safefree(he);
+ }
}
PL_he_arenaroot = 0;
PL_he_root = 0;
+#if defined(USE_ITHREADS)
+ {
+ struct ptr_tbl_ent *pte;
+ struct ptr_tbl_ent *pte_next;
+ for (pte = PL_pte_arenaroot; pte; pte = pte_next) {
+ pte_next = pte->next;
+ Safefree(pte);
+ }
+ }
+ PL_pte_arenaroot = 0;
+ PL_pte_root = 0;
+#endif
+
if (PL_nice_chunk)
Safefree(PL_nice_chunk);
PL_nice_chunk = Nullch;
STATIC SV*
S_find_hash_subscript(pTHX_ HV *hv, SV* val)
{
+ dVAR;
register HE **array;
- register HE *entry;
I32 i;
if (!hv || SvMAGICAL(hv) || !HvARRAY(hv) ||
array = HvARRAY(hv);
for (i=HvMAX(hv); i>0; i--) {
+ register HE *entry;
for (entry = array[i]; entry; entry = HeNEXT(entry)) {
if (HeVAL(entry) != val)
continue;
#define FUV_SUBSCRIPT_WITHIN 4 /* "within @foo" */
STATIC SV*
-S_varname(pTHX_ GV *gv, char *gvtype, PADOFFSET targ,
+S_varname(pTHX_ GV *gv, const char *gvtype, PADOFFSET targ,
SV* keyname, I32 aindex, int subscript_type)
{
AV *av;
+ SV *sv;
- SV *sv, *name;
-
- name = sv_newmortal();
+ SV * const name = sv_newmortal();
if (gv) {
/* simulate gv_fullname4(), but add literal '^' for $^FOO names
* XXX get rid of all this if gv_fullnameX() ever supports this
* directly */
- char *p;
+ const char *p;
HV *hv = GvSTASH(gv);
sv_setpv(name, gvtype);
if (!hv)
p = "???";
- else if (!HvNAME(hv))
+ else if (!(p=HvNAME_get(hv)))
p = "__ANON__";
- else
- p = HvNAME(hv);
if (strNE(p, "main")) {
sv_catpv(name,p);
sv_catpvn(name,"::", 2);
else {
U32 u;
CV *cv = find_runcv(&u);
+ STRLEN len;
+ const char *str;
if (!cv || !CvPADLIST(cv))
return Nullsv;;
av = (AV*)(*av_fetch(CvPADLIST(cv), 0, FALSE));
sv = *av_fetch(av, targ, FALSE);
/* SvLEN in a pad name is not to be trusted */
- sv_setpv(name, SvPV_nolen(sv));
+ str = SvPV(sv,len);
+ sv_setpvn(name, str, len);
}
if (subscript_type == FUV_SUBSCRIPT_HASH) {
STATIC SV *
S_find_uninit_var(pTHX_ OP* obase, SV* uninit_sv, bool match)
{
+ dVAR;
SV *sv;
AV *av;
SV **svp;
case OP_PADAV:
case OP_PADHV:
{
- bool pad = (obase->op_type == OP_PADAV || obase->op_type == OP_PADHV);
- bool hash = (obase->op_type == OP_PADHV || obase->op_type == OP_RV2HV);
+ const bool pad = (obase->op_type == OP_PADAV || obase->op_type == OP_PADHV);
+ const bool hash = (obase->op_type == OP_PADHV || obase->op_type == OP_RV2HV);
I32 index = 0;
SV *keysv = Nullsv;
int subscript_type = FUV_SUBSCRIPT_WITHIN;
keysv, 0, FUV_SUBSCRIPT_HASH);
}
else {
- I32 index = S_find_array_subscript(aTHX_ (AV*)sv, uninit_sv);
+ const I32 index = S_find_array_subscript(aTHX_ (AV*)sv, uninit_sv);
if (index >= 0)
- return S_varname(aTHX_ gv, "@", o->op_targ,
+ return S_varname(aTHX_ gv, "@", o->op_targ,
Nullsv, index, FUV_SUBSCRIPT_ARRAY);
}
if (match)
: DEFSV))
{
sv = sv_newmortal();
- sv_setpv(sv, "$_");
+ sv_setpvn(sv, "$_", 2);
return sv;
}
}
"", "", "");
}
-/* grab a new IV body from the free list, allocating more if necessary */
+/* allocate another arena's worth of NV bodies */
-STATIC XPVIV*
-S_new_xiv(pTHX)
+STATIC void
+S_more_xnv(pTHX)
{
- IV* xiv;
- LOCK_SV_MUTEX;
- if (!PL_xiv_root)
- more_xiv();
- xiv = PL_xiv_root;
- /*
- * See comment in more_xiv() -- RAM.
- */
- PL_xiv_root = *(IV**)xiv;
- UNLOCK_SV_MUTEX;
- return (XPVIV*)((char*)xiv - STRUCT_OFFSET(XPVIV, xiv_iv));
+ NV* xnv;
+ NV* xnvend;
+ void *ptr;
+ New(711, ptr, PERL_ARENA_SIZE/sizeof(NV), NV);
+ *((void **) ptr) = (void *)PL_xnv_arenaroot;
+ PL_xnv_arenaroot = ptr;
+
+ xnv = (NV*) ptr;
+ xnvend = &xnv[PERL_ARENA_SIZE / sizeof(NV) - 1];
+ xnv += (sizeof(XPVIV) - 1) / sizeof(NV) + 1; /* fudge by sizeof XPVIV */
+ PL_xnv_root = xnv;
+ while (xnv < xnvend) {
+ *(NV**)xnv = (NV*)(xnv + 1);
+ xnv++;
+ }
+ *(NV**)xnv = 0;
}
-/* return an IV body to the free list */
+/* allocate another arena's worth of struct xpv */
STATIC void
-S_del_xiv(pTHX_ XPVIV *p)
+S_more_xpv(pTHX)
{
- IV* xiv = (IV*)((char*)(p) + STRUCT_OFFSET(XPVIV, xiv_iv));
- LOCK_SV_MUTEX;
- *(IV**)xiv = PL_xiv_root;
- PL_xiv_root = xiv;
- UNLOCK_SV_MUTEX;
+ xpv_allocated* xpv;
+ xpv_allocated* xpvend;
+ New(713, xpv, PERL_ARENA_SIZE/sizeof(xpv_allocated), xpv_allocated);
+ *((xpv_allocated**)xpv) = PL_xpv_arenaroot;
+ PL_xpv_arenaroot = xpv;
+
+ xpvend = &xpv[PERL_ARENA_SIZE / sizeof(xpv_allocated) - 1];
+ PL_xpv_root = ++xpv;
+ while (xpv < xpvend) {
+ *((xpv_allocated**)xpv) = xpv + 1;
+ xpv++;
+ }
+ *((xpv_allocated**)xpv) = 0;
}
-/* allocate another arena's worth of IV bodies */
+/* allocate another arena's worth of struct xpviv */
STATIC void
-S_more_xiv(pTHX)
+S_more_xpviv(pTHX)
{
- register IV* xiv;
- register IV* xivend;
- XPV* ptr;
- New(705, ptr, 1008/sizeof(XPV), XPV);
- ptr->xpv_pv = (char*)PL_xiv_arenaroot; /* linked list of xiv arenas */
- PL_xiv_arenaroot = ptr; /* to keep Purify happy */
+ xpviv_allocated* xpviv;
+ xpviv_allocated* xpvivend;
+ New(713, xpviv, PERL_ARENA_SIZE/sizeof(xpviv_allocated), xpviv_allocated);
+ *((xpviv_allocated**)xpviv) = PL_xpviv_arenaroot;
+ PL_xpviv_arenaroot = xpviv;
- xiv = (IV*) ptr;
- xivend = &xiv[1008 / sizeof(IV) - 1];
- xiv += (sizeof(XPV) - 1) / sizeof(IV) + 1; /* fudge by size of XPV */
- PL_xiv_root = xiv;
- while (xiv < xivend) {
- *(IV**)xiv = (IV *)(xiv + 1);
- xiv++;
+ xpvivend = &xpviv[PERL_ARENA_SIZE / sizeof(xpviv_allocated) - 1];
+ PL_xpviv_root = ++xpviv;
+ while (xpviv < xpvivend) {
+ *((xpviv_allocated**)xpviv) = xpviv + 1;
+ xpviv++;
}
- *(IV**)xiv = 0;
+ *((xpviv_allocated**)xpviv) = 0;
}
-/* grab a new NV body from the free list, allocating more if necessary */
+/* allocate another arena's worth of struct xpvnv */
-STATIC XPVNV*
-S_new_xnv(pTHX)
+STATIC void
+S_more_xpvnv(pTHX)
{
- NV* xnv;
- LOCK_SV_MUTEX;
- if (!PL_xnv_root)
- more_xnv();
- xnv = PL_xnv_root;
- PL_xnv_root = *(NV**)xnv;
- UNLOCK_SV_MUTEX;
- return (XPVNV*)((char*)xnv - STRUCT_OFFSET(XPVNV, xnv_nv));
+ XPVNV* xpvnv;
+ XPVNV* xpvnvend;
+ New(715, xpvnv, PERL_ARENA_SIZE/sizeof(XPVNV), XPVNV);
+ *((XPVNV**)xpvnv) = PL_xpvnv_arenaroot;
+ PL_xpvnv_arenaroot = xpvnv;
+
+ xpvnvend = &xpvnv[PERL_ARENA_SIZE / sizeof(XPVNV) - 1];
+ PL_xpvnv_root = ++xpvnv;
+ while (xpvnv < xpvnvend) {
+ *((XPVNV**)xpvnv) = xpvnv + 1;
+ xpvnv++;
+ }
+ *((XPVNV**)xpvnv) = 0;
}
-/* return an NV body to the free list */
+/* allocate another arena's worth of struct xpvcv */
STATIC void
-S_del_xnv(pTHX_ XPVNV *p)
+S_more_xpvcv(pTHX)
{
- NV* xnv = (NV*)((char*)(p) + STRUCT_OFFSET(XPVNV, xnv_nv));
- LOCK_SV_MUTEX;
- *(NV**)xnv = PL_xnv_root;
- PL_xnv_root = xnv;
- UNLOCK_SV_MUTEX;
+ XPVCV* xpvcv;
+ XPVCV* xpvcvend;
+ New(716, xpvcv, PERL_ARENA_SIZE/sizeof(XPVCV), XPVCV);
+ *((XPVCV**)xpvcv) = PL_xpvcv_arenaroot;
+ PL_xpvcv_arenaroot = xpvcv;
+
+ xpvcvend = &xpvcv[PERL_ARENA_SIZE / sizeof(XPVCV) - 1];
+ PL_xpvcv_root = ++xpvcv;
+ while (xpvcv < xpvcvend) {
+ *((XPVCV**)xpvcv) = xpvcv + 1;
+ xpvcv++;
+ }
+ *((XPVCV**)xpvcv) = 0;
}
-/* allocate another arena's worth of NV bodies */
+/* allocate another arena's worth of struct xpvav */
STATIC void
-S_more_xnv(pTHX)
+S_more_xpvav(pTHX)
{
- register NV* xnv;
- register NV* xnvend;
- XPV *ptr;
- New(711, ptr, 1008/sizeof(XPV), XPV);
- ptr->xpv_pv = (char*)PL_xnv_arenaroot;
- PL_xnv_arenaroot = ptr;
+ xpvav_allocated* xpvav;
+ xpvav_allocated* xpvavend;
+ New(717, xpvav, PERL_ARENA_SIZE/sizeof(xpvav_allocated),
+ xpvav_allocated);
+ *((xpvav_allocated**)xpvav) = PL_xpvav_arenaroot;
+ PL_xpvav_arenaroot = xpvav;
- xnv = (NV*) ptr;
- xnvend = &xnv[1008 / sizeof(NV) - 1];
- xnv += (sizeof(XPVIV) - 1) / sizeof(NV) + 1; /* fudge by sizeof XPVIV */
- PL_xnv_root = xnv;
- while (xnv < xnvend) {
- *(NV**)xnv = (NV*)(xnv + 1);
- xnv++;
+ xpvavend = &xpvav[PERL_ARENA_SIZE / sizeof(xpvav_allocated) - 1];
+ PL_xpvav_root = ++xpvav;
+ while (xpvav < xpvavend) {
+ *((xpvav_allocated**)xpvav) = xpvav + 1;
+ xpvav++;
}
- *(NV**)xnv = 0;
+ *((xpvav_allocated**)xpvav) = 0;
}
-/* grab a new struct xrv from the free list, allocating more if necessary */
+/* allocate another arena's worth of struct xpvhv */
-STATIC XRV*
-S_new_xrv(pTHX)
+STATIC void
+S_more_xpvhv(pTHX)
{
- XRV* xrv;
- LOCK_SV_MUTEX;
- if (!PL_xrv_root)
- more_xrv();
- xrv = PL_xrv_root;
- PL_xrv_root = (XRV*)xrv->xrv_rv;
- UNLOCK_SV_MUTEX;
- return xrv;
+ xpvhv_allocated* xpvhv;
+ xpvhv_allocated* xpvhvend;
+ New(718, xpvhv, PERL_ARENA_SIZE/sizeof(xpvhv_allocated),
+ xpvhv_allocated);
+ *((xpvhv_allocated**)xpvhv) = PL_xpvhv_arenaroot;
+ PL_xpvhv_arenaroot = xpvhv;
+
+ xpvhvend = &xpvhv[PERL_ARENA_SIZE / sizeof(xpvhv_allocated) - 1];
+ PL_xpvhv_root = ++xpvhv;
+ while (xpvhv < xpvhvend) {
+ *((xpvhv_allocated**)xpvhv) = xpvhv + 1;
+ xpvhv++;
+ }
+ *((xpvhv_allocated**)xpvhv) = 0;
}
-/* return a struct xrv to the free list */
+/* allocate another arena's worth of struct xpvmg */
STATIC void
-S_del_xrv(pTHX_ XRV *p)
+S_more_xpvmg(pTHX)
{
- LOCK_SV_MUTEX;
- p->xrv_rv = (SV*)PL_xrv_root;
- PL_xrv_root = p;
- UNLOCK_SV_MUTEX;
+ XPVMG* xpvmg;
+ XPVMG* xpvmgend;
+ New(719, xpvmg, PERL_ARENA_SIZE/sizeof(XPVMG), XPVMG);
+ *((XPVMG**)xpvmg) = PL_xpvmg_arenaroot;
+ PL_xpvmg_arenaroot = xpvmg;
+
+ xpvmgend = &xpvmg[PERL_ARENA_SIZE / sizeof(XPVMG) - 1];
+ PL_xpvmg_root = ++xpvmg;
+ while (xpvmg < xpvmgend) {
+ *((XPVMG**)xpvmg) = xpvmg + 1;
+ xpvmg++;
+ }
+ *((XPVMG**)xpvmg) = 0;
}
-/* allocate another arena's worth of struct xrv */
+/* allocate another arena's worth of struct xpvgv */
STATIC void
-S_more_xrv(pTHX)
+S_more_xpvgv(pTHX)
{
- register XRV* xrv;
- register XRV* xrvend;
- XPV *ptr;
- New(712, ptr, 1008/sizeof(XPV), XPV);
- ptr->xpv_pv = (char*)PL_xrv_arenaroot;
- PL_xrv_arenaroot = ptr;
+ XPVGV* xpvgv;
+ XPVGV* xpvgvend;
+ New(720, xpvgv, PERL_ARENA_SIZE/sizeof(XPVGV), XPVGV);
+ *((XPVGV**)xpvgv) = PL_xpvgv_arenaroot;
+ PL_xpvgv_arenaroot = xpvgv;
- xrv = (XRV*) ptr;
- xrvend = &xrv[1008 / sizeof(XRV) - 1];
- xrv += (sizeof(XPV) - 1) / sizeof(XRV) + 1;
- PL_xrv_root = xrv;
- while (xrv < xrvend) {
- xrv->xrv_rv = (SV*)(xrv + 1);
- xrv++;
+ xpvgvend = &xpvgv[PERL_ARENA_SIZE / sizeof(XPVGV) - 1];
+ PL_xpvgv_root = ++xpvgv;
+ while (xpvgv < xpvgvend) {
+ *((XPVGV**)xpvgv) = xpvgv + 1;
+ xpvgv++;
}
- xrv->xrv_rv = 0;
+ *((XPVGV**)xpvgv) = 0;
+}
+
+/* allocate another arena's worth of struct xpvlv */
+
+STATIC void
+S_more_xpvlv(pTHX)
+{
+ XPVLV* xpvlv;
+ XPVLV* xpvlvend;
+ New(720, xpvlv, PERL_ARENA_SIZE/sizeof(XPVLV), XPVLV);
+ *((XPVLV**)xpvlv) = PL_xpvlv_arenaroot;
+ PL_xpvlv_arenaroot = xpvlv;
+
+ xpvlvend = &xpvlv[PERL_ARENA_SIZE / sizeof(XPVLV) - 1];
+ PL_xpvlv_root = ++xpvlv;
+ while (xpvlv < xpvlvend) {
+ *((XPVLV**)xpvlv) = xpvlv + 1;
+ xpvlv++;
+ }
+ *((XPVLV**)xpvlv) = 0;
+}
+
+/* allocate another arena's worth of struct xpvbm */
+
+STATIC void
+S_more_xpvbm(pTHX)
+{
+ XPVBM* xpvbm;
+ XPVBM* xpvbmend;
+ New(721, xpvbm, PERL_ARENA_SIZE/sizeof(XPVBM), XPVBM);
+ *((XPVBM**)xpvbm) = PL_xpvbm_arenaroot;
+ PL_xpvbm_arenaroot = xpvbm;
+
+ xpvbmend = &xpvbm[PERL_ARENA_SIZE / sizeof(XPVBM) - 1];
+ PL_xpvbm_root = ++xpvbm;
+ while (xpvbm < xpvbmend) {
+ *((XPVBM**)xpvbm) = xpvbm + 1;
+ xpvbm++;
+ }
+ *((XPVBM**)xpvbm) = 0;
+}
+
+/* grab a new NV body from the free list, allocating more if necessary */
+
+STATIC XPVNV*
+S_new_xnv(pTHX)
+{
+ NV* xnv;
+ LOCK_SV_MUTEX;
+ if (!PL_xnv_root)
+ S_more_xnv(aTHX);
+ xnv = PL_xnv_root;
+ PL_xnv_root = *(NV**)xnv;
+ UNLOCK_SV_MUTEX;
+ return (XPVNV*)((char*)xnv - STRUCT_OFFSET(XPVNV, xnv_nv));
+}
+
+/* return an NV body to the free list */
+
+STATIC void
+S_del_xnv(pTHX_ XPVNV *p)
+{
+ NV* xnv = (NV*)((char*)(p) + STRUCT_OFFSET(XPVNV, xnv_nv));
+ LOCK_SV_MUTEX;
+ *(NV**)xnv = PL_xnv_root;
+ PL_xnv_root = xnv;
+ UNLOCK_SV_MUTEX;
}
/* grab a new struct xpv from the free list, allocating more if necessary */
STATIC XPV*
S_new_xpv(pTHX)
{
- XPV* xpv;
+ xpv_allocated* xpv;
LOCK_SV_MUTEX;
if (!PL_xpv_root)
- more_xpv();
+ S_more_xpv(aTHX);
xpv = PL_xpv_root;
- PL_xpv_root = (XPV*)xpv->xpv_pv;
+ PL_xpv_root = *(xpv_allocated**)xpv;
UNLOCK_SV_MUTEX;
- return xpv;
+ /* If xpv_allocated is the same structure as XPV then the two OFFSETs
+ sum to zero, and the pointer is unchanged. If the allocated structure
+ is smaller (no initial IV actually allocated) then the net effect is
+ to subtract the size of the IV from the pointer, to return a new pointer
+ as if an initial IV were actually allocated. */
+ return (XPV*)((char*)xpv - STRUCT_OFFSET(XPV, xpv_cur)
+ + STRUCT_OFFSET(xpv_allocated, xpv_cur));
}
/* return a struct xpv to the free list */
STATIC void
S_del_xpv(pTHX_ XPV *p)
{
+ xpv_allocated* xpv
+ = (xpv_allocated*)((char*)(p) + STRUCT_OFFSET(XPV, xpv_cur)
+ - STRUCT_OFFSET(xpv_allocated, xpv_cur));
LOCK_SV_MUTEX;
- p->xpv_pv = (char*)PL_xpv_root;
- PL_xpv_root = p;
+ *(xpv_allocated**)xpv = PL_xpv_root;
+ PL_xpv_root = xpv;
UNLOCK_SV_MUTEX;
}
-/* allocate another arena's worth of struct xpv */
-
-STATIC void
-S_more_xpv(pTHX)
-{
- register XPV* xpv;
- register XPV* xpvend;
- New(713, xpv, 1008/sizeof(XPV), XPV);
- xpv->xpv_pv = (char*)PL_xpv_arenaroot;
- PL_xpv_arenaroot = xpv;
-
- xpvend = &xpv[1008 / sizeof(XPV) - 1];
- PL_xpv_root = ++xpv;
- while (xpv < xpvend) {
- xpv->xpv_pv = (char*)(xpv + 1);
- xpv++;
- }
- xpv->xpv_pv = 0;
-}
-
/* grab a new struct xpviv from the free list, allocating more if necessary */
STATIC XPVIV*
S_new_xpviv(pTHX)
{
- XPVIV* xpviv;
+ xpviv_allocated* xpviv;
LOCK_SV_MUTEX;
if (!PL_xpviv_root)
- more_xpviv();
+ S_more_xpviv(aTHX);
xpviv = PL_xpviv_root;
- PL_xpviv_root = (XPVIV*)xpviv->xpv_pv;
+ PL_xpviv_root = *(xpviv_allocated**)xpviv;
UNLOCK_SV_MUTEX;
- return xpviv;
+ /* If xpviv_allocated is the same structure as XPVIV then the two OFFSETs
+ sum to zero, and the pointer is unchanged. If the allocated structure
+ is smaller (no initial IV actually allocated) then the net effect is
+ to subtract the size of the IV from the pointer, to return a new pointer
+ as if an initial IV were actually allocated. */
+ return (XPVIV*)((char*)xpviv - STRUCT_OFFSET(XPVIV, xpv_cur)
+ + STRUCT_OFFSET(xpviv_allocated, xpv_cur));
}
/* return a struct xpviv to the free list */
STATIC void
S_del_xpviv(pTHX_ XPVIV *p)
{
+ xpviv_allocated* xpviv
+ = (xpviv_allocated*)((char*)(p) + STRUCT_OFFSET(XPVIV, xpv_cur)
+ - STRUCT_OFFSET(xpviv_allocated, xpv_cur));
LOCK_SV_MUTEX;
- p->xpv_pv = (char*)PL_xpviv_root;
- PL_xpviv_root = p;
+ *(xpviv_allocated**)xpviv = PL_xpviv_root;
+ PL_xpviv_root = xpviv;
UNLOCK_SV_MUTEX;
}
-/* allocate another arena's worth of struct xpviv */
-
-STATIC void
-S_more_xpviv(pTHX)
-{
- register XPVIV* xpviv;
- register XPVIV* xpvivend;
- New(714, xpviv, 1008/sizeof(XPVIV), XPVIV);
- xpviv->xpv_pv = (char*)PL_xpviv_arenaroot;
- PL_xpviv_arenaroot = xpviv;
-
- xpvivend = &xpviv[1008 / sizeof(XPVIV) - 1];
- PL_xpviv_root = ++xpviv;
- while (xpviv < xpvivend) {
- xpviv->xpv_pv = (char*)(xpviv + 1);
- xpviv++;
- }
- xpviv->xpv_pv = 0;
-}
-
/* grab a new struct xpvnv from the free list, allocating more if necessary */
STATIC XPVNV*
XPVNV* xpvnv;
LOCK_SV_MUTEX;
if (!PL_xpvnv_root)
- more_xpvnv();
+ S_more_xpvnv(aTHX);
xpvnv = PL_xpvnv_root;
- PL_xpvnv_root = (XPVNV*)xpvnv->xpv_pv;
+ PL_xpvnv_root = *(XPVNV**)xpvnv;
UNLOCK_SV_MUTEX;
return xpvnv;
}
S_del_xpvnv(pTHX_ XPVNV *p)
{
LOCK_SV_MUTEX;
- p->xpv_pv = (char*)PL_xpvnv_root;
+ *(XPVNV**)p = PL_xpvnv_root;
PL_xpvnv_root = p;
UNLOCK_SV_MUTEX;
}
-/* allocate another arena's worth of struct xpvnv */
-
-STATIC void
-S_more_xpvnv(pTHX)
-{
- register XPVNV* xpvnv;
- register XPVNV* xpvnvend;
- New(715, xpvnv, 1008/sizeof(XPVNV), XPVNV);
- xpvnv->xpv_pv = (char*)PL_xpvnv_arenaroot;
- PL_xpvnv_arenaroot = xpvnv;
-
- xpvnvend = &xpvnv[1008 / sizeof(XPVNV) - 1];
- PL_xpvnv_root = ++xpvnv;
- while (xpvnv < xpvnvend) {
- xpvnv->xpv_pv = (char*)(xpvnv + 1);
- xpvnv++;
- }
- xpvnv->xpv_pv = 0;
-}
-
/* grab a new struct xpvcv from the free list, allocating more if necessary */
STATIC XPVCV*
XPVCV* xpvcv;
LOCK_SV_MUTEX;
if (!PL_xpvcv_root)
- more_xpvcv();
+ S_more_xpvcv(aTHX);
xpvcv = PL_xpvcv_root;
- PL_xpvcv_root = (XPVCV*)xpvcv->xpv_pv;
+ PL_xpvcv_root = *(XPVCV**)xpvcv;
UNLOCK_SV_MUTEX;
return xpvcv;
}
S_del_xpvcv(pTHX_ XPVCV *p)
{
LOCK_SV_MUTEX;
- p->xpv_pv = (char*)PL_xpvcv_root;
+ *(XPVCV**)p = PL_xpvcv_root;
PL_xpvcv_root = p;
UNLOCK_SV_MUTEX;
}
-/* allocate another arena's worth of struct xpvcv */
-
-STATIC void
-S_more_xpvcv(pTHX)
-{
- register XPVCV* xpvcv;
- register XPVCV* xpvcvend;
- New(716, xpvcv, 1008/sizeof(XPVCV), XPVCV);
- xpvcv->xpv_pv = (char*)PL_xpvcv_arenaroot;
- PL_xpvcv_arenaroot = xpvcv;
-
- xpvcvend = &xpvcv[1008 / sizeof(XPVCV) - 1];
- PL_xpvcv_root = ++xpvcv;
- while (xpvcv < xpvcvend) {
- xpvcv->xpv_pv = (char*)(xpvcv + 1);
- xpvcv++;
- }
- xpvcv->xpv_pv = 0;
-}
-
/* grab a new struct xpvav from the free list, allocating more if necessary */
STATIC XPVAV*
S_new_xpvav(pTHX)
{
- XPVAV* xpvav;
+ xpvav_allocated* xpvav;
LOCK_SV_MUTEX;
if (!PL_xpvav_root)
- more_xpvav();
+ S_more_xpvav(aTHX);
xpvav = PL_xpvav_root;
- PL_xpvav_root = (XPVAV*)xpvav->xav_array;
+ PL_xpvav_root = *(xpvav_allocated**)xpvav;
UNLOCK_SV_MUTEX;
- return xpvav;
+ return (XPVAV*)((char*)xpvav - STRUCT_OFFSET(XPVAV, xav_fill)
+ + STRUCT_OFFSET(xpvav_allocated, xav_fill));
}
/* return a struct xpvav to the free list */
STATIC void
S_del_xpvav(pTHX_ XPVAV *p)
{
+ xpvav_allocated* xpvav
+ = (xpvav_allocated*)((char*)(p) + STRUCT_OFFSET(XPVAV, xav_fill)
+ - STRUCT_OFFSET(xpvav_allocated, xav_fill));
LOCK_SV_MUTEX;
- p->xav_array = (char*)PL_xpvav_root;
- PL_xpvav_root = p;
+ *(xpvav_allocated**)xpvav = PL_xpvav_root;
+ PL_xpvav_root = xpvav;
UNLOCK_SV_MUTEX;
}
-/* allocate another arena's worth of struct xpvav */
-
-STATIC void
-S_more_xpvav(pTHX)
-{
- register XPVAV* xpvav;
- register XPVAV* xpvavend;
- New(717, xpvav, 1008/sizeof(XPVAV), XPVAV);
- xpvav->xav_array = (char*)PL_xpvav_arenaroot;
- PL_xpvav_arenaroot = xpvav;
-
- xpvavend = &xpvav[1008 / sizeof(XPVAV) - 1];
- PL_xpvav_root = ++xpvav;
- while (xpvav < xpvavend) {
- xpvav->xav_array = (char*)(xpvav + 1);
- xpvav++;
- }
- xpvav->xav_array = 0;
-}
-
/* grab a new struct xpvhv from the free list, allocating more if necessary */
STATIC XPVHV*
S_new_xpvhv(pTHX)
{
- XPVHV* xpvhv;
+ xpvhv_allocated* xpvhv;
LOCK_SV_MUTEX;
if (!PL_xpvhv_root)
- more_xpvhv();
+ S_more_xpvhv(aTHX);
xpvhv = PL_xpvhv_root;
- PL_xpvhv_root = (XPVHV*)xpvhv->xhv_array;
+ PL_xpvhv_root = *(xpvhv_allocated**)xpvhv;
UNLOCK_SV_MUTEX;
- return xpvhv;
+ return (XPVHV*)((char*)xpvhv - STRUCT_OFFSET(XPVHV, xhv_fill)
+ + STRUCT_OFFSET(xpvhv_allocated, xhv_fill));
}
/* return a struct xpvhv to the free list */
STATIC void
S_del_xpvhv(pTHX_ XPVHV *p)
{
+ xpvhv_allocated* xpvhv
+ = (xpvhv_allocated*)((char*)(p) + STRUCT_OFFSET(XPVHV, xhv_fill)
+ - STRUCT_OFFSET(xpvhv_allocated, xhv_fill));
LOCK_SV_MUTEX;
- p->xhv_array = (char*)PL_xpvhv_root;
- PL_xpvhv_root = p;
+ *(xpvhv_allocated**)xpvhv = PL_xpvhv_root;
+ PL_xpvhv_root = xpvhv;
UNLOCK_SV_MUTEX;
}
-/* allocate another arena's worth of struct xpvhv */
-
-STATIC void
-S_more_xpvhv(pTHX)
-{
- register XPVHV* xpvhv;
- register XPVHV* xpvhvend;
- New(718, xpvhv, 1008/sizeof(XPVHV), XPVHV);
- xpvhv->xhv_array = (char*)PL_xpvhv_arenaroot;
- PL_xpvhv_arenaroot = xpvhv;
-
- xpvhvend = &xpvhv[1008 / sizeof(XPVHV) - 1];
- PL_xpvhv_root = ++xpvhv;
- while (xpvhv < xpvhvend) {
- xpvhv->xhv_array = (char*)(xpvhv + 1);
- xpvhv++;
- }
- xpvhv->xhv_array = 0;
-}
-
/* grab a new struct xpvmg from the free list, allocating more if necessary */
STATIC XPVMG*
XPVMG* xpvmg;
LOCK_SV_MUTEX;
if (!PL_xpvmg_root)
- more_xpvmg();
+ S_more_xpvmg(aTHX);
xpvmg = PL_xpvmg_root;
- PL_xpvmg_root = (XPVMG*)xpvmg->xpv_pv;
+ PL_xpvmg_root = *(XPVMG**)xpvmg;
+ UNLOCK_SV_MUTEX;
+ return xpvmg;
+}
+
+/* return a struct xpvmg to the free list */
+
+STATIC void
+S_del_xpvmg(pTHX_ XPVMG *p)
+{
+ LOCK_SV_MUTEX;
+ *(XPVMG**)p = PL_xpvmg_root;
+ PL_xpvmg_root = p;
UNLOCK_SV_MUTEX;
- return xpvmg;
}
-/* return a struct xpvmg to the free list */
+/* grab a new struct xpvgv from the free list, allocating more if necessary */
-STATIC void
-S_del_xpvmg(pTHX_ XPVMG *p)
+STATIC XPVGV*
+S_new_xpvgv(pTHX)
{
+ XPVGV* xpvgv;
LOCK_SV_MUTEX;
- p->xpv_pv = (char*)PL_xpvmg_root;
- PL_xpvmg_root = p;
+ if (!PL_xpvgv_root)
+ S_more_xpvgv(aTHX);
+ xpvgv = PL_xpvgv_root;
+ PL_xpvgv_root = *(XPVGV**)xpvgv;
UNLOCK_SV_MUTEX;
+ return xpvgv;
}
-/* allocate another arena's worth of struct xpvmg */
+/* return a struct xpvgv to the free list */
STATIC void
-S_more_xpvmg(pTHX)
+S_del_xpvgv(pTHX_ XPVGV *p)
{
- register XPVMG* xpvmg;
- register XPVMG* xpvmgend;
- New(719, xpvmg, 1008/sizeof(XPVMG), XPVMG);
- xpvmg->xpv_pv = (char*)PL_xpvmg_arenaroot;
- PL_xpvmg_arenaroot = xpvmg;
-
- xpvmgend = &xpvmg[1008 / sizeof(XPVMG) - 1];
- PL_xpvmg_root = ++xpvmg;
- while (xpvmg < xpvmgend) {
- xpvmg->xpv_pv = (char*)(xpvmg + 1);
- xpvmg++;
- }
- xpvmg->xpv_pv = 0;
+ LOCK_SV_MUTEX;
+ *(XPVGV**)p = PL_xpvgv_root;
+ PL_xpvgv_root = p;
+ UNLOCK_SV_MUTEX;
}
/* grab a new struct xpvlv from the free list, allocating more if necessary */
XPVLV* xpvlv;
LOCK_SV_MUTEX;
if (!PL_xpvlv_root)
- more_xpvlv();
+ S_more_xpvlv(aTHX);
xpvlv = PL_xpvlv_root;
- PL_xpvlv_root = (XPVLV*)xpvlv->xpv_pv;
+ PL_xpvlv_root = *(XPVLV**)xpvlv;
UNLOCK_SV_MUTEX;
return xpvlv;
}
S_del_xpvlv(pTHX_ XPVLV *p)
{
LOCK_SV_MUTEX;
- p->xpv_pv = (char*)PL_xpvlv_root;
+ *(XPVLV**)p = PL_xpvlv_root;
PL_xpvlv_root = p;
UNLOCK_SV_MUTEX;
}
-/* allocate another arena's worth of struct xpvlv */
-
-STATIC void
-S_more_xpvlv(pTHX)
-{
- register XPVLV* xpvlv;
- register XPVLV* xpvlvend;
- New(720, xpvlv, 1008/sizeof(XPVLV), XPVLV);
- xpvlv->xpv_pv = (char*)PL_xpvlv_arenaroot;
- PL_xpvlv_arenaroot = xpvlv;
-
- xpvlvend = &xpvlv[1008 / sizeof(XPVLV) - 1];
- PL_xpvlv_root = ++xpvlv;
- while (xpvlv < xpvlvend) {
- xpvlv->xpv_pv = (char*)(xpvlv + 1);
- xpvlv++;
- }
- xpvlv->xpv_pv = 0;
-}
-
/* grab a new struct xpvbm from the free list, allocating more if necessary */
STATIC XPVBM*
XPVBM* xpvbm;
LOCK_SV_MUTEX;
if (!PL_xpvbm_root)
- more_xpvbm();
+ S_more_xpvbm(aTHX);
xpvbm = PL_xpvbm_root;
- PL_xpvbm_root = (XPVBM*)xpvbm->xpv_pv;
+ PL_xpvbm_root = *(XPVBM**)xpvbm;
UNLOCK_SV_MUTEX;
return xpvbm;
}
S_del_xpvbm(pTHX_ XPVBM *p)
{
LOCK_SV_MUTEX;
- p->xpv_pv = (char*)PL_xpvbm_root;
+ *(XPVBM**)p = PL_xpvbm_root;
PL_xpvbm_root = p;
UNLOCK_SV_MUTEX;
}
-/* allocate another arena's worth of struct xpvbm */
-
-STATIC void
-S_more_xpvbm(pTHX)
-{
- register XPVBM* xpvbm;
- register XPVBM* xpvbmend;
- New(721, xpvbm, 1008/sizeof(XPVBM), XPVBM);
- xpvbm->xpv_pv = (char*)PL_xpvbm_arenaroot;
- PL_xpvbm_arenaroot = xpvbm;
-
- xpvbmend = &xpvbm[1008 / sizeof(XPVBM) - 1];
- PL_xpvbm_root = ++xpvbm;
- while (xpvbm < xpvbmend) {
- xpvbm->xpv_pv = (char*)(xpvbm + 1);
- xpvbm++;
- }
- xpvbm->xpv_pv = 0;
-}
-
#define my_safemalloc(s) (void*)safemalloc(s)
#define my_safefree(p) safefree((char*)p)
#ifdef PURIFY
-#define new_XIV() my_safemalloc(sizeof(XPVIV))
-#define del_XIV(p) my_safefree(p)
-
#define new_XNV() my_safemalloc(sizeof(XPVNV))
#define del_XNV(p) my_safefree(p)
-#define new_XRV() my_safemalloc(sizeof(XRV))
-#define del_XRV(p) my_safefree(p)
-
#define new_XPV() my_safemalloc(sizeof(XPV))
#define del_XPV(p) my_safefree(p)
#define new_XPVMG() my_safemalloc(sizeof(XPVMG))
#define del_XPVMG(p) my_safefree(p)
+#define new_XPVGV() my_safemalloc(sizeof(XPVGV))
+#define del_XPVGV(p) my_safefree(p)
+
#define new_XPVLV() my_safemalloc(sizeof(XPVLV))
#define del_XPVLV(p) my_safefree(p)
#else /* !PURIFY */
-#define new_XIV() (void*)new_xiv()
-#define del_XIV(p) del_xiv((XPVIV*) p)
-
#define new_XNV() (void*)new_xnv()
#define del_XNV(p) del_xnv((XPVNV*) p)
-#define new_XRV() (void*)new_xrv()
-#define del_XRV(p) del_xrv((XRV*) p)
-
#define new_XPV() (void*)new_xpv()
#define del_XPV(p) del_xpv((XPV *)p)
#define new_XPVMG() (void*)new_xpvmg()
#define del_XPVMG(p) del_xpvmg((XPVMG *)p)
+#define new_XPVGV() (void*)new_xpvgv()
+#define del_XPVGV(p) del_xpvgv((XPVGV *)p)
+
#define new_XPVLV() (void*)new_xpvlv()
#define del_XPVLV(p) del_xpvlv((XPVLV *)p)
#endif /* PURIFY */
-#define new_XPVGV() my_safemalloc(sizeof(XPVGV))
-#define del_XPVGV(p) my_safefree(p)
-
#define new_XPVFM() my_safemalloc(sizeof(XPVFM))
#define del_XPVFM(p) my_safefree(p)
Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt)
{
- char* pv = NULL;
- U32 cur = 0;
- U32 len = 0;
- IV iv = 0;
- NV nv = 0.0;
- MAGIC* magic = NULL;
- HV* stash = Nullhv;
+ char* pv;
+ U32 cur;
+ U32 len;
+ IV iv;
+ NV nv;
+ MAGIC* magic;
+ HV* stash;
if (mt != SVt_PV && SvIsCOW(sv)) {
sv_force_normal_flags(sv, 0);
if (SvTYPE(sv) == mt)
return TRUE;
- if (mt < SVt_PVIV)
- (void)SvOOK_off(sv);
+ pv = NULL;
+ cur = 0;
+ len = 0;
+ iv = 0;
+ nv = 0.0;
+ magic = NULL;
+ stash = Nullhv;
switch (SvTYPE(sv)) {
case SVt_NULL:
- pv = 0;
- cur = 0;
- len = 0;
- iv = 0;
- nv = 0.0;
- magic = 0;
- stash = 0;
break;
case SVt_IV:
- pv = 0;
- cur = 0;
- len = 0;
iv = SvIVX(sv);
- nv = (NV)SvIVX(sv);
- del_XIV(SvANY(sv));
- magic = 0;
- stash = 0;
if (mt == SVt_NV)
mt = SVt_PVNV;
else if (mt < SVt_PVIV)
mt = SVt_PVIV;
break;
case SVt_NV:
- pv = 0;
- cur = 0;
- len = 0;
nv = SvNVX(sv);
- iv = I_V(nv);
- magic = 0;
- stash = 0;
del_XNV(SvANY(sv));
- SvANY(sv) = 0;
if (mt < SVt_PVNV)
mt = SVt_PVNV;
break;
case SVt_RV:
pv = (char*)SvRV(sv);
- cur = 0;
- len = 0;
- iv = PTR2IV(pv);
- nv = PTR2NV(pv);
- del_XRV(SvANY(sv));
- magic = 0;
- stash = 0;
break;
case SVt_PV:
pv = SvPVX(sv);
cur = SvCUR(sv);
len = SvLEN(sv);
- iv = 0;
- nv = 0.0;
- magic = 0;
- stash = 0;
del_XPV(SvANY(sv));
if (mt <= SVt_IV)
mt = SVt_PVIV;
cur = SvCUR(sv);
len = SvLEN(sv);
iv = SvIVX(sv);
- nv = 0.0;
- magic = 0;
- stash = 0;
del_XPVIV(SvANY(sv));
break;
case SVt_PVNV:
len = SvLEN(sv);
iv = SvIVX(sv);
nv = SvNVX(sv);
- magic = 0;
- stash = 0;
del_XPVNV(SvANY(sv));
break;
case SVt_PVMG:
+ /* Because the XPVMG of PL_mess_sv isn't allocated from the arena,
+ there's no way that it can be safely upgraded, because perl.c
+ expects to Safefree(SvANY(PL_mess_sv)) */
+ assert(sv != PL_mess_sv);
+ /* This flag bit is used to mean other things in other scalar types.
+ Given that it only has meaning inside the pad, it shouldn't be set
+ on anything that can get upgraded. */
+ assert((SvFLAGS(sv) & SVpad_TYPED) == 0);
pv = SvPVX(sv);
cur = SvCUR(sv);
len = SvLEN(sv);
case SVt_NULL:
Perl_croak(aTHX_ "Can't upgrade to undef");
case SVt_IV:
- SvANY(sv) = new_XIV();
- SvIVX(sv) = iv;
+ SvANY(sv) = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
+ SvIV_set(sv, iv);
break;
case SVt_NV:
SvANY(sv) = new_XNV();
- SvNVX(sv) = nv;
+ SvNV_set(sv, nv);
break;
case SVt_RV:
- SvANY(sv) = new_XRV();
- SvRV(sv) = (SV*)pv;
- break;
- case SVt_PV:
- SvANY(sv) = new_XPV();
- SvPVX(sv) = pv;
- SvCUR(sv) = cur;
- SvLEN(sv) = len;
- break;
- case SVt_PVIV:
- SvANY(sv) = new_XPVIV();
- SvPVX(sv) = pv;
- SvCUR(sv) = cur;
- SvLEN(sv) = len;
- SvIVX(sv) = iv;
- if (SvNIOK(sv))
- (void)SvIOK_on(sv);
- SvNOK_off(sv);
- break;
- case SVt_PVNV:
- SvANY(sv) = new_XPVNV();
- SvPVX(sv) = pv;
- SvCUR(sv) = cur;
- SvLEN(sv) = len;
- SvIVX(sv) = iv;
- SvNVX(sv) = nv;
- break;
- case SVt_PVMG:
- SvANY(sv) = new_XPVMG();
- SvPVX(sv) = pv;
- SvCUR(sv) = cur;
- SvLEN(sv) = len;
- SvIVX(sv) = iv;
- SvNVX(sv) = nv;
- SvMAGIC(sv) = magic;
- SvSTASH(sv) = stash;
- break;
- case SVt_PVLV:
- SvANY(sv) = new_XPVLV();
- SvPVX(sv) = pv;
- SvCUR(sv) = cur;
- SvLEN(sv) = len;
- SvIVX(sv) = iv;
- SvNVX(sv) = nv;
- SvMAGIC(sv) = magic;
- SvSTASH(sv) = stash;
- LvTARGOFF(sv) = 0;
- LvTARGLEN(sv) = 0;
- LvTARG(sv) = 0;
- LvTYPE(sv) = 0;
- GvGP(sv) = 0;
- GvNAME(sv) = 0;
- GvNAMELEN(sv) = 0;
- GvSTASH(sv) = 0;
- GvFLAGS(sv) = 0;
- break;
- case SVt_PVAV:
- SvANY(sv) = new_XPVAV();
- if (pv)
- Safefree(pv);
- SvPVX(sv) = 0;
- AvMAX(sv) = -1;
- AvFILLp(sv) = -1;
- SvIVX(sv) = 0;
- SvNVX(sv) = 0.0;
- SvMAGIC(sv) = magic;
- SvSTASH(sv) = stash;
- AvALLOC(sv) = 0;
- AvARYLEN(sv) = 0;
- AvFLAGS(sv) = AVf_REAL;
+ SvANY(sv) = &sv->sv_u.svu_rv;
+ SvRV_set(sv, (SV*)pv);
break;
case SVt_PVHV:
SvANY(sv) = new_XPVHV();
- if (pv)
- Safefree(pv);
- SvPVX(sv) = 0;
HvFILL(sv) = 0;
HvMAX(sv) = 0;
HvTOTALKEYS(sv) = 0;
- HvPLACEHOLDERS(sv) = 0;
- SvMAGIC(sv) = magic;
- SvSTASH(sv) = stash;
- HvRITER(sv) = 0;
- HvEITER(sv) = 0;
- HvPMROOT(sv) = 0;
- HvNAME(sv) = 0;
+
+ /* Fall through... */
+ if (0) {
+ case SVt_PVAV:
+ SvANY(sv) = new_XPVAV();
+ AvMAX(sv) = -1;
+ AvFILLp(sv) = -1;
+ AvALLOC(sv) = 0;
+ AvREAL_only(sv);
+ }
+ /* to here. */
+ /* XXX? Only SVt_NULL is ever upgraded to AV or HV? */
+ assert(!pv);
+ /* FIXME. Should be able to remove all this if()... if the above
+ assertion is genuinely always true. */
+ if(SvOOK(sv)) {
+ pv -= iv;
+ SvFLAGS(sv) &= ~SVf_OOK;
+ }
+ Safefree(pv);
+ SvPV_set(sv, (char*)0);
+ SvMAGIC_set(sv, magic);
+ SvSTASH_set(sv, stash);
break;
+
+ case SVt_PVIO:
+ SvANY(sv) = new_XPVIO();
+ Zero(SvANY(sv), 1, XPVIO);
+ IoPAGE_LEN(sv) = 60;
+ goto set_magic_common;
+ case SVt_PVFM:
+ SvANY(sv) = new_XPVFM();
+ Zero(SvANY(sv), 1, XPVFM);
+ goto set_magic_common;
+ case SVt_PVBM:
+ SvANY(sv) = new_XPVBM();
+ BmRARE(sv) = 0;
+ BmUSEFUL(sv) = 0;
+ BmPREVIOUS(sv) = 0;
+ goto set_magic_common;
+ case SVt_PVGV:
+ SvANY(sv) = new_XPVGV();
+ GvGP(sv) = 0;
+ GvNAME(sv) = 0;
+ GvNAMELEN(sv) = 0;
+ GvSTASH(sv) = 0;
+ GvFLAGS(sv) = 0;
+ goto set_magic_common;
case SVt_PVCV:
SvANY(sv) = new_XPVCV();
Zero(SvANY(sv), 1, XPVCV);
- SvPVX(sv) = pv;
- SvCUR(sv) = cur;
- SvLEN(sv) = len;
- SvIVX(sv) = iv;
- SvNVX(sv) = nv;
- SvMAGIC(sv) = magic;
- SvSTASH(sv) = stash;
- break;
- case SVt_PVGV:
- SvANY(sv) = new_XPVGV();
- SvPVX(sv) = pv;
- SvCUR(sv) = cur;
- SvLEN(sv) = len;
- SvIVX(sv) = iv;
- SvNVX(sv) = nv;
- SvMAGIC(sv) = magic;
- SvSTASH(sv) = stash;
+ goto set_magic_common;
+ case SVt_PVLV:
+ SvANY(sv) = new_XPVLV();
+ LvTARGOFF(sv) = 0;
+ LvTARGLEN(sv) = 0;
+ LvTARG(sv) = 0;
+ LvTYPE(sv) = 0;
GvGP(sv) = 0;
GvNAME(sv) = 0;
GvNAMELEN(sv) = 0;
GvSTASH(sv) = 0;
GvFLAGS(sv) = 0;
- break;
- case SVt_PVBM:
- SvANY(sv) = new_XPVBM();
- SvPVX(sv) = pv;
- SvCUR(sv) = cur;
- SvLEN(sv) = len;
- SvIVX(sv) = iv;
- SvNVX(sv) = nv;
- SvMAGIC(sv) = magic;
- SvSTASH(sv) = stash;
- BmRARE(sv) = 0;
- BmUSEFUL(sv) = 0;
- BmPREVIOUS(sv) = 0;
- break;
- case SVt_PVFM:
- SvANY(sv) = new_XPVFM();
- Zero(SvANY(sv), 1, XPVFM);
- SvPVX(sv) = pv;
- SvCUR(sv) = cur;
- SvLEN(sv) = len;
- SvIVX(sv) = iv;
- SvNVX(sv) = nv;
- SvMAGIC(sv) = magic;
- SvSTASH(sv) = stash;
- break;
- case SVt_PVIO:
- SvANY(sv) = new_XPVIO();
- Zero(SvANY(sv), 1, XPVIO);
- SvPVX(sv) = pv;
- SvCUR(sv) = cur;
- SvLEN(sv) = len;
- SvIVX(sv) = iv;
- SvNVX(sv) = nv;
- SvMAGIC(sv) = magic;
- SvSTASH(sv) = stash;
- IoPAGE_LEN(sv) = 60;
+ /* Fall through. */
+ if (0) {
+ case SVt_PVMG:
+ SvANY(sv) = new_XPVMG();
+ }
+ set_magic_common:
+ SvMAGIC_set(sv, magic);
+ SvSTASH_set(sv, stash);
+ /* Fall through. */
+ if (0) {
+ case SVt_PVNV:
+ SvANY(sv) = new_XPVNV();
+ }
+ SvNV_set(sv, nv);
+ /* Fall through. */
+ if (0) {
+ case SVt_PVIV:
+ SvANY(sv) = new_XPVIV();
+ if (SvNIOK(sv))
+ (void)SvIOK_on(sv);
+ SvNOK_off(sv);
+ }
+ SvIV_set(sv, iv);
+ /* Fall through. */
+ if (0) {
+ case SVt_PV:
+ SvANY(sv) = new_XPV();
+ }
+ SvPV_set(sv, pv);
+ SvCUR_set(sv, cur);
+ SvLEN_set(sv, len);
break;
}
return TRUE;
Perl_sv_backoff(pTHX_ register SV *sv)
{
assert(SvOOK(sv));
+ assert(SvTYPE(sv) != SVt_PVHV);
+ assert(SvTYPE(sv) != SVt_PVAV);
if (SvIVX(sv)) {
char *s = SvPVX(sv);
- SvLEN(sv) += SvIVX(sv);
- SvPVX(sv) -= SvIVX(sv);
+ SvLEN_set(sv, SvLEN(sv) + SvIVX(sv));
+ SvPV_set(sv, SvPVX(sv) - SvIVX(sv));
SvIV_set(sv, 0);
Move(s, SvPVX(sv), SvCUR(sv)+1, char);
}
if (newlen > SvLEN(sv)) { /* need more room? */
if (SvLEN(sv) && s) {
+ newlen = PERL_STRLEN_ROUNDUP(newlen);
#ifdef MYMALLOC
- STRLEN l = malloced_size((void*)SvPVX(sv));
+ const STRLEN l = malloced_size((void*)SvPVX(sv));
if (newlen <= l) {
SvLEN_set(sv, l);
return s;
} else
#endif
- Renew(s,newlen,char);
+ s = saferealloc(s, newlen);
}
- else {
- New(703, s, newlen, char);
+ else {
+ newlen = PERL_STRLEN_ROUNDUP(newlen);
+ s = safemalloc(newlen);
if (SvPVX(sv) && SvCUR(sv)) {
Move(SvPVX(sv), s, (newlen < SvCUR(sv)) ? newlen : SvCUR(sv), char);
}
OP_DESC(PL_op));
}
(void)SvIOK_only(sv); /* validate number */
- SvIVX(sv) = i;
+ SvIV_set(sv, i);
SvTAINT(sv);
}
}
sv_setiv(sv, 0);
SvIsUV_on(sv);
- SvUVX(sv) = u;
+ SvUV_set(sv, u);
}
/*
Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
OP_NAME(PL_op));
}
- SvNVX(sv) = num;
+ SvNV_set(sv, num);
(void)SvNOK_only(sv); /* validate number */
SvTAINT(sv);
}
I32
Perl_looks_like_number(pTHX_ SV *sv)
{
- register char *sbegin;
+ register const char *sbegin;
STRLEN len;
if (SvPOK(sv)) {
if (SvNVX(sv) < (NV)IV_MIN) {
(void)SvIOKp_on(sv);
(void)SvNOK_on(sv);
- SvIVX(sv) = IV_MIN;
+ SvIV_set(sv, IV_MIN);
return IS_NUMBER_UNDERFLOW_IV;
}
if (SvNVX(sv) > (NV)UV_MAX) {
(void)SvIOKp_on(sv);
(void)SvNOK_on(sv);
SvIsUV_on(sv);
- SvUVX(sv) = UV_MAX;
+ SvUV_set(sv, UV_MAX);
return IS_NUMBER_OVERFLOW_UV;
}
(void)SvIOKp_on(sv);
/* Can't use strtol etc to convert this string. (See truth table in
sv_2iv */
if (SvNVX(sv) <= (UV)IV_MAX) {
- SvIVX(sv) = I_V(SvNVX(sv));
+ SvIV_set(sv, I_V(SvNVX(sv)));
if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
SvIOK_on(sv); /* Integer is precise. NOK, IOK */
} else {
return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
}
SvIsUV_on(sv);
- SvUVX(sv) = U_V(SvNVX(sv));
+ SvUV_set(sv, U_V(SvNVX(sv)));
if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
if (SvUVX(sv) == UV_MAX) {
/* As we know that NVs don't preserve UVs, UV_MAX cannot
answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary
cases go to UV */
if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
- SvIVX(sv) = I_V(SvNVX(sv));
+ SvIV_set(sv, I_V(SvNVX(sv)));
if (SvNVX(sv) == (NV) SvIVX(sv)
#ifndef NV_PRESERVES_UV
&& (((UV)1 << NV_PRESERVES_UV_BITS) >
0x8000000000000000 which will be exact. NWC */
}
else {
- SvUVX(sv) = U_V(SvNVX(sv));
+ SvUV_set(sv, U_V(SvNVX(sv)));
if (
(SvNVX(sv) == (NV) SvUVX(sv))
#ifndef NV_PRESERVES_UV
}
else if (SvPOKp(sv) && SvLEN(sv)) {
UV value;
- int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
+ const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
/* We want to avoid a possible problem when we cache an IV which
may be later translated to an NV, and the resulting NV is not
the same as the direct translation of the initial string
if (!(numtype & IS_NUMBER_NEG)) {
/* positive */;
if (value <= (UV)IV_MAX) {
- SvIVX(sv) = (IV)value;
+ SvIV_set(sv, (IV)value);
} else {
- SvUVX(sv) = value;
+ SvUV_set(sv, value);
SvIsUV_on(sv);
}
} else {
/* 2s complement assumption */
if (value <= (UV)IV_MIN) {
- SvIVX(sv) = -(IV)value;
+ SvIV_set(sv, -(IV)value);
} else {
/* Too negative for an IV. This is a double upgrade, but
I'm assuming it will be rare. */
SvNOK_on(sv);
SvIOK_off(sv);
SvIOKp_on(sv);
- SvNVX(sv) = -(NV)value;
- SvIVX(sv) = IV_MIN;
+ SvNV_set(sv, -(NV)value);
+ SvIV_set(sv, IV_MIN);
}
}
}
if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
!= IS_NUMBER_IN_UV) {
/* It wasn't an (integer that doesn't overflow the UV). */
- SvNVX(sv) = Atof(SvPVX(sv));
+ SvNV_set(sv, Atof(SvPVX(sv)));
if (! numtype && ckWARN(WARN_NUMERIC))
not_a_number(sv);
(void)SvIOKp_on(sv);
(void)SvNOK_on(sv);
if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
- SvIVX(sv) = I_V(SvNVX(sv));
+ SvIV_set(sv, I_V(SvNVX(sv)));
if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
SvIOK_on(sv);
} else {
if (SvNVX(sv) > (NV)UV_MAX) {
SvIsUV_on(sv);
/* Integer is inaccurate. NOK, IOKp, is UV */
- SvUVX(sv) = UV_MAX;
+ SvUV_set(sv, UV_MAX);
SvIsUV_on(sv);
} else {
- SvUVX(sv) = U_V(SvNVX(sv));
+ SvUV_set(sv, U_V(SvNVX(sv)));
/* 0xFFFFFFFFFFFFFFFF not an issue in here */
if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
SvIOK_on(sv);
/* Small enough to preserve all bits. */
(void)SvIOKp_on(sv);
SvNOK_on(sv);
- SvIVX(sv) = I_V(SvNVX(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,
(void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
- SvIVX(sv) = I_V(SvNVX(sv));
+ SvIV_set(sv, I_V(SvNVX(sv)));
if (SvNVX(sv) == (NV) SvIVX(sv)
#ifndef NV_PRESERVES_UV
&& (((UV)1 << NV_PRESERVES_UV_BITS) >
0x8000000000000000 which will be exact. NWC */
}
else {
- SvUVX(sv) = U_V(SvNVX(sv));
+ SvUV_set(sv, U_V(SvNVX(sv)));
if (
(SvNVX(sv) == (NV) SvUVX(sv))
#ifndef NV_PRESERVES_UV
}
else if (SvPOKp(sv) && SvLEN(sv)) {
UV value;
- int numtype = grok_number(SvPVX(sv), SvCUR(sv), &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
if (!(numtype & IS_NUMBER_NEG)) {
/* positive */;
if (value <= (UV)IV_MAX) {
- SvIVX(sv) = (IV)value;
+ SvIV_set(sv, (IV)value);
} else {
/* it didn't overflow, and it was positive. */
- SvUVX(sv) = value;
+ SvUV_set(sv, value);
SvIsUV_on(sv);
}
} else {
/* 2s complement assumption */
if (value <= (UV)IV_MIN) {
- SvIVX(sv) = -(IV)value;
+ SvIV_set(sv, -(IV)value);
} else {
/* Too negative for an IV. This is a double upgrade, but
I'm assuming it will be rare. */
SvNOK_on(sv);
SvIOK_off(sv);
SvIOKp_on(sv);
- SvNVX(sv) = -(NV)value;
- SvIVX(sv) = IV_MIN;
+ SvNV_set(sv, -(NV)value);
+ SvIV_set(sv, IV_MIN);
}
}
}
if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
!= IS_NUMBER_IN_UV) {
/* It wasn't an integer, or it overflowed the UV. */
- SvNVX(sv) = Atof(SvPVX(sv));
+ SvNV_set(sv, Atof(SvPVX(sv)));
if (! numtype && ckWARN(WARN_NUMERIC))
not_a_number(sv);
(void)SvIOKp_on(sv);
(void)SvNOK_on(sv);
if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
- SvIVX(sv) = I_V(SvNVX(sv));
+ SvIV_set(sv, I_V(SvNVX(sv)));
if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
SvIOK_on(sv);
} else {
if (SvNVX(sv) > (NV)UV_MAX) {
SvIsUV_on(sv);
/* Integer is inaccurate. NOK, IOKp, is UV */
- SvUVX(sv) = UV_MAX;
+ SvUV_set(sv, UV_MAX);
SvIsUV_on(sv);
} else {
- SvUVX(sv) = U_V(SvNVX(sv));
+ 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)) {
/* Small enough to preserve all bits. */
(void)SvIOKp_on(sv);
SvNOK_on(sv);
- SvIVX(sv) = I_V(SvNVX(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,
return SvNVX(sv);
if (SvPOKp(sv) && SvLEN(sv)) {
if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) &&
- !grok_number(SvPVX(sv), SvCUR(sv), NULL))
+ !grok_number(SvPVX_const(sv), SvCUR(sv), NULL))
not_a_number(sv);
return Atof(SvPVX(sv));
}
return SvNVX(sv);
}
if (SvIOKp(sv)) {
- SvNVX(sv) = SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv);
+ SvNV_set(sv, SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv));
#ifdef NV_PRESERVES_UV
SvNOK_on(sv);
#else
}
else if (SvPOKp(sv) && SvLEN(sv)) {
UV value;
- int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
+ const int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !numtype)
not_a_number(sv);
#ifdef NV_PRESERVES_UV
if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
== IS_NUMBER_IN_UV) {
/* It's definitely an integer */
- SvNVX(sv) = (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value;
+ SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value);
} else
- SvNVX(sv) = Atof(SvPVX(sv));
+ SvNV_set(sv, Atof(SvPVX(sv)));
SvNOK_on(sv);
#else
- SvNVX(sv) = Atof(SvPVX(sv));
+ SvNV_set(sv, Atof(SvPVX(sv)));
/* Only set the public NV OK flag if this NV preserves the value in
the PV at least as well as an IV/UV would.
Not sure how to do this 100% reliably. */
SvIOKp_on(sv);
if (numtype & IS_NUMBER_NEG) {
- SvIVX(sv) = -(IV)value;
+ SvIV_set(sv, -(IV)value);
} else if (value <= (UV)IV_MAX) {
- SvIVX(sv) = (IV)value;
+ SvIV_set(sv, (IV)value);
} else {
- SvUVX(sv) = value;
+ SvUV_set(sv, value);
SvIsUV_on(sv);
}
S_asUV(pTHX_ SV *sv)
{
UV value;
- int numtype = grok_number(SvPVX(sv), SvCUR(sv), &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) {
if (!sv) {
*lp = 0;
- return "";
+ return (char *)"";
}
if (SvGMAGICAL(sv)) {
if (flags & SV_GMAGIC)
report_uninit(sv);
}
*lp = 0;
- return "";
+ return (char *)"";
}
}
if (SvTHINKFIRST(sv)) {
if (SvROK(sv)) {
SV* tmpstr;
+ register const char *typestr;
if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)) &&
(!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
char *pv = SvPV(tmpstr, *lp);
origsv = sv;
sv = (SV*)SvRV(sv);
if (!sv)
- s = "NULLREF";
+ typestr = "NULLREF";
else {
MAGIC *mg;
(SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
== (SVs_OBJECT|SVs_SMG))
&& (mg = mg_find(sv, PERL_MAGIC_qr))) {
- regexp *re = (regexp *)mg->mg_obj;
+ const regexp *re = (regexp *)mg->mg_obj;
if (!mg->mg_ptr) {
- char *fptr = "msix";
+ const char *fptr = "msix";
char reflags[6];
char ch;
int left = 0;
*/
if (PMf_EXTENDED & re->reganch)
{
- char *endptr = re->precomp + re->prelen;
+ const char *endptr = re->precomp + re->prelen;
while (endptr >= re->precomp)
{
- char c = *(endptr--);
+ const char c = *(endptr--);
if (c == '\n')
break; /* don't need another */
if (c == '#') {
case SVt_PV:
case SVt_PVIV:
case SVt_PVNV:
- case SVt_PVBM: if (SvROK(sv))
- s = "REF";
- else
- s = "SCALAR"; break;
- case SVt_PVLV: s = SvROK(sv) ? "REF"
+ case SVt_PVBM: typestr = SvROK(sv) ? "REF" : "SCALAR"; break;
+ case SVt_PVLV: typestr = SvROK(sv) ? "REF"
/* tied lvalues should appear to be
* scalars for backwards compatitbility */
: (LvTYPE(sv) == 't' || LvTYPE(sv) == 'T')
? "SCALAR" : "LVALUE"; break;
- case SVt_PVAV: s = "ARRAY"; break;
- case SVt_PVHV: s = "HASH"; break;
- case SVt_PVCV: s = "CODE"; break;
- case SVt_PVGV: s = "GLOB"; break;
- case SVt_PVFM: s = "FORMAT"; break;
- case SVt_PVIO: s = "IO"; break;
- default: s = "UNKNOWN"; break;
+ case SVt_PVAV: typestr = "ARRAY"; break;
+ case SVt_PVHV: typestr = "HASH"; break;
+ case SVt_PVCV: typestr = "CODE"; break;
+ case SVt_PVGV: typestr = "GLOB"; break;
+ case SVt_PVFM: typestr = "FORMAT"; break;
+ case SVt_PVIO: typestr = "IO"; break;
+ default: typestr = "UNKNOWN"; break;
}
tsv = NEWSV(0,0);
if (SvOBJECT(sv)) {
- const char *name = HvNAME(SvSTASH(sv));
+ const char *name = HvNAME_get(SvSTASH(sv));
Perl_sv_setpvf(aTHX_ tsv, "%s=%s(0x%"UVxf")",
- name ? name : "__ANON__" , s, PTR2UV(sv));
+ name ? name : "__ANON__" , typestr, PTR2UV(sv));
}
else
- Perl_sv_setpvf(aTHX_ tsv, "%s(0x%"UVxf")", s, PTR2UV(sv));
+ Perl_sv_setpvf(aTHX_ tsv, "%s(0x%"UVxf")", typestr, PTR2UV(sv));
goto tokensaveref;
}
- *lp = strlen(s);
- return s;
+ *lp = strlen(typestr);
+ return (char *)typestr;
}
if (SvREADONLY(sv) && !SvOK(sv)) {
if (ckWARN(WARN_UNINITIALIZED))
report_uninit(sv);
*lp = 0;
- return "";
+ return (char *)"";
}
}
if (SvIOK(sv) || ((SvIOKp(sv) && !SvNOKp(sv)))) {
/* I'm assuming that if both IV and NV are equally valid then
converting the IV is going to be more efficient */
- U32 isIOK = SvIOK(sv);
- U32 isUIOK = SvIsUV(sv);
+ const U32 isIOK = SvIOK(sv);
+ const U32 isUIOK = SvIsUV(sv);
char buf[TYPE_CHARS(UV)];
char *ebuf, *ptr;
if (SvTYPE(sv) < SVt_PV)
/* Typically the caller expects that sv_any is not NULL now. */
sv_upgrade(sv, SVt_PV);
- return "";
+ return (char *)"";
}
*lp = s - SvPVX(sv);
SvCUR_set(sv, *lp);
return SvPVX(tsv);
}
else {
+ dVAR;
STRLEN len;
- char *t;
+ const char *t;
if (tsv) {
sv_2mortal(tsv);
if (SvPOKp(sv)) {
register XPV* Xpvtmp;
if ((Xpvtmp = (XPV*)SvANY(sv)) &&
- (*Xpvtmp->xpv_pv > '0' ||
+ (*sv->sv_u.svu_pv > '0' ||
Xpvtmp->xpv_cur > 1 ||
- (Xpvtmp->xpv_cur && *Xpvtmp->xpv_pv != '0')))
+ (Xpvtmp->xpv_cur && *sv->sv_u.svu_pv != '0')))
return 1;
else
return 0;
STRLEN
Perl_sv_utf8_upgrade_flags(pTHX_ register SV *sv, I32 flags)
{
- U8 *s, *t, *e;
- int hibit = 0;
-
if (sv == &PL_sv_undef)
return 0;
if (!SvPOK(sv)) {
if (PL_encoding && !(flags & SV_UTF8_NO_ENCODING))
sv_recode_to_utf8(sv, PL_encoding);
else { /* Assume Latin-1/EBCDIC */
- /* This function could be much more efficient if we
- * 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. */
- s = (U8 *) SvPVX(sv);
- e = (U8 *) SvEND(sv);
- t = s;
- while (t < e) {
- U8 ch = *t++;
- if ((hibit = !NATIVE_IS_INVARIANT(ch)))
- break;
- }
- if (hibit) {
- STRLEN len;
- (void)SvOOK_off(sv);
- s = (U8*)SvPVX(sv);
- len = SvCUR(sv) + 1; /* Plus the \0 */
- SvPVX(sv) = (char*)bytes_to_utf8((U8*)s, &len);
- SvCUR(sv) = len - 1;
- if (SvLEN(sv) != 0)
- Safefree(s); /* No longer using what was there before. */
- SvLEN(sv) = len; /* No longer know the real size. */
- }
- /* Mark as UTF-8 even if no hibit - saves scanning loop */
- SvUTF8_on(sv);
+ /* This function could be much more efficient if we
+ * 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. */
+ U8 *s = (U8 *) SvPVX(sv);
+ U8 *e = (U8 *) SvEND(sv);
+ U8 *t = s;
+ int hibit = 0;
+
+ while (t < e) {
+ U8 ch = *t++;
+ if ((hibit = !NATIVE_IS_INVARIANT(ch)))
+ break;
+ }
+ if (hibit) {
+ STRLEN len = SvCUR(sv) + 1; /* Plus the \0 */
+ s = bytes_to_utf8((U8*)s, &len);
+
+ SvPV_free(sv); /* No longer using what was there before. */
+
+ SvPV_set(sv, (char*)s);
+ SvCUR_set(sv, len - 1);
+ SvLEN_set(sv, len); /* No longer know the real size. */
+ }
+ /* Mark as UTF-8 even if no hibit - saves scanning loop */
+ SvUTF8_on(sv);
}
return SvCUR(sv);
}
Perl_croak(aTHX_ "Wide character");
}
}
- SvCUR(sv) = len;
+ SvCUR_set(sv, len);
}
}
SvUTF8_off(sv);
break;
}
(void)SvIOK_only(dstr);
- SvIVX(dstr) = SvIVX(sstr);
+ SvIV_set(dstr, SvIVX(sstr));
if (SvIsUV(sstr))
SvIsUV_on(dstr);
if (SvTAINTED(sstr))
sv_upgrade(dstr, SVt_PVNV);
break;
}
- SvNVX(dstr) = SvNVX(sstr);
+ SvNV_set(dstr, SvNVX(sstr));
(void)SvNOK_only(dstr);
if (SvTAINTED(sstr))
SvTAINT(dstr);
case SVt_PVHV:
case SVt_PVCV:
case SVt_PVIO:
+ {
+ const char * const type = sv_reftype(sstr,0);
if (PL_op)
- Perl_croak(aTHX_ "Bizarre copy of %s in %s", sv_reftype(sstr, 0),
- OP_NAME(PL_op));
+ Perl_croak(aTHX_ "Bizarre copy of %s in %s", type, OP_NAME(PL_op));
else
- Perl_croak(aTHX_ "Bizarre copy of %s", sv_reftype(sstr, 0));
+ Perl_croak(aTHX_ "Bizarre copy of %s", type);
+ }
break;
case SVt_PVGV:
if (dtype <= SVt_PVGV) {
glob_assign:
if (dtype != SVt_PVGV) {
- char *name = GvNAME(sstr);
- STRLEN len = GvNAMELEN(sstr);
+ 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);
if (dtype == SVt_PVGV) {
SV *sref = SvREFCNT_inc(SvRV(sstr));
SV *dref = 0;
- int intro = GvINTRO(dstr);
+ const int intro = GvINTRO(dstr);
#ifdef GV_UNIQUE_CHECK
if (GvUNIQUE((GV*)dstr)) {
CvCONST(cv)
? "Constant subroutine %s::%s redefined"
: "Subroutine %s::%s redefined",
- HvNAME(GvSTASH((GV*)dstr)),
+ HvNAME_get(GvSTASH((GV*)dstr)),
GvENAME((GV*)dstr));
}
}
return;
}
if (SvPVX(dstr)) {
- (void)SvOOK_off(dstr); /* backoff */
- if (SvLEN(dstr))
- Safefree(SvPVX(dstr));
- SvLEN(dstr)=SvCUR(dstr)=0;
+ SvPV_free(dstr);
+ SvLEN_set(dstr, 0);
+ SvCUR_set(dstr, 0);
}
}
(void)SvOK_off(dstr);
- SvRV(dstr) = SvREFCNT_inc(SvRV(sstr));
+ 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;
- SvNVX(dstr) = SvNVX(sstr);
+ SvNV_set(dstr, SvNVX(sstr));
}
if (sflags & SVp_IOK) {
(void)SvIOKp_on(dstr);
SvFLAGS(dstr) |= SVf_IOK;
if (sflags & SVf_IVisUV)
SvIsUV_on(dstr);
- SvIVX(dstr) = SvIVX(sstr);
+ SvIV_set(dstr, SvIVX(sstr));
}
if (SvAMAGIC(sstr)) {
SvAMAGIC_on(dstr);
SvPV_set(dstr,
sharepvn(SvPVX(sstr),
(sflags & SVf_UTF8?-cur:cur), hash));
- SvUVX(dstr) = hash;
+ SvUV_set(dstr, hash);
}
- SvLEN(dstr) = len;
- SvCUR(dstr) = cur;
+ SvLEN_set(dstr, len);
+ SvCUR_set(dstr, cur);
SvREADONLY_on(dstr);
SvFAKE_on(dstr);
/* Relesase a global SV mutex. */
SvNOKp_on(dstr);
if (sflags & SVf_NOK)
SvFLAGS(dstr) |= SVf_NOK;
- SvNVX(dstr) = SvNVX(sstr);
+ SvNV_set(dstr, SvNVX(sstr));
}
if (sflags & SVp_IOK) {
(void)SvIOKp_on(dstr);
SvFLAGS(dstr) |= SVf_IOK;
if (sflags & SVf_IVisUV)
SvIsUV_on(dstr);
- SvIVX(dstr) = SvIVX(sstr);
+ SvIV_set(dstr, SvIVX(sstr));
}
if (SvVOK(sstr)) {
MAGIC *smg = mg_find(sstr,PERL_MAGIC_vstring);
/* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
if (sflags & SVf_IVisUV)
SvIsUV_on(dstr);
- SvIVX(dstr) = SvIVX(sstr);
+ SvIV_set(dstr, SvIVX(sstr));
if (sflags & SVp_NOK) {
if (sflags & SVf_NOK)
(void)SvNOK_on(dstr);
else
(void)SvNOKp_on(dstr);
- SvNVX(dstr) = SvNVX(sstr);
+ SvNV_set(dstr, SvNVX(sstr));
}
}
else if (sflags & SVp_NOK) {
(void)SvOK_off(dstr);
SvNOKp_on(dstr);
}
- SvNVX(dstr) = SvNVX(sstr);
+ SvNV_set(dstr, SvNVX(sstr));
}
else {
if (dtype == SVt_PVGV) {
UV hash = SvUVX(sstr);
DEBUG_C(PerlIO_printf(Perl_debug_log,
"Fast copy on write: Sharing hash\n"));
- SvUVX(dstr) = hash;
+ SvUV_set(dstr, hash);
new_pv = sharepvn(SvPVX(sstr), (SvUTF8(sstr)?-cur:cur), hash);
goto common_exit;
}
SvFLAGS(dstr) = (SVt_PVIV|SVf_POK|SVp_POK|SVf_FAKE|SVf_READONLY);
if (SvUTF8(sstr))
SvUTF8_on(dstr);
- SvLEN(dstr) = len;
- SvCUR(dstr) = cur;
+ SvLEN_set(dstr, len);
+ SvCUR_set(dstr, cur);
if (DEBUG_C_TEST) {
sv_dump(dstr);
}
}
else {
/* len is STRLEN which is unsigned, need to copy to signed */
- IV iv = len;
+ const IV iv = len;
if (iv < 0)
Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen");
}
void
Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
{
+ STRLEN allocate;
SV_CHECK_THINKFIRST_COW_DROP(sv);
(void)SvUPGRADE(sv, SVt_PV);
if (!ptr) {
(void)SvOK_off(sv);
return;
}
- (void)SvOOK_off(sv);
- if (SvPVX(sv) && SvLEN(sv))
- Safefree(SvPVX(sv));
- Renew(ptr, len+1, char);
- SvPVX(sv) = ptr;
+ if (SvPVX(sv))
+ SvPV_free(sv);
+
+ allocate = PERL_STRLEN_ROUNDUP(len + 1);
+ ptr = safesysrealloc (ptr, allocate);
+ SvPV_set(sv, ptr);
SvCUR_set(sv, len);
- SvLEN_set(sv, len+1);
+ SvLEN_set(sv, allocate);
*SvEND(sv) = '\0';
(void)SvPOK_only_UTF8(sv); /* validate pointer */
SvTAINT(sv);
SvFAKE_off(sv);
SvREADONLY_off(sv);
/* This SV doesn't own the buffer, so need to New() a new one: */
- SvPVX(sv) = 0;
- SvLEN(sv) = 0;
+ SvPV_set(sv, (char*)0);
+ SvLEN_set(sv, 0);
if (flags & SV_COW_DROP_PV) {
/* OK, so we don't need to copy our buffer. */
SvPOK_off(sv);
} else {
SvGROW(sv, cur + 1);
Move(pvx,SvPVX(sv),cur,char);
- SvCUR(sv) = cur;
+ SvCUR_set(sv, cur);
*SvEND(sv) = '\0';
}
sv_release_COW(sv, pvx, cur, len, hash, next);
if (SvREADONLY(sv)) {
if (SvFAKE(sv)) {
char *pvx = SvPVX(sv);
- int is_utf8 = SvUTF8(sv);
+ const int is_utf8 = SvUTF8(sv);
STRLEN len = SvCUR(sv);
U32 hash = SvUVX(sv);
SvFAKE_off(sv);
SvREADONLY_off(sv);
- SvPVX(sv) = 0;
- SvLEN(sv) = 0;
+ SvPV_set(sv, (char*)0);
+ SvLEN_set(sv, 0);
SvGROW(sv, len + 1);
Move(pvx,SvPVX(sv),len,char);
*SvEND(sv) = '\0';
*/
void
-Perl_sv_chop(pTHX_ register SV *sv, register char *ptr)
+Perl_sv_chop(pTHX_ register SV *sv, register const char *ptr)
{
register STRLEN delta;
if (!ptr || !SvPOKp(sv))
if (!SvOOK(sv)) {
if (!SvLEN(sv)) { /* make copy of shared string */
- char *pvx = SvPVX(sv);
+ const char *pvx = SvPVX(sv);
STRLEN len = SvCUR(sv);
SvGROW(sv, len + 1);
Move(pvx,SvPVX(sv),len,char);
*SvEND(sv) = '\0';
}
- SvIVX(sv) = 0;
+ SvIV_set(sv, 0);
/* Same SvOOK_on but SvOOK_on does a SvIOK_off
and we do that anyway inside the SvNIOK_off
*/
SvFLAGS(sv) |= SVf_OOK;
}
SvNIOK_off(sv);
- SvLEN(sv) -= delta;
- SvCUR(sv) -= delta;
- SvPVX(sv) += delta;
- SvIVX(sv) += delta;
+ SvLEN_set(sv, SvLEN(sv) - delta);
+ SvCUR_set(sv, SvCUR(sv) - delta);
+ SvPV_set(sv, SvPVX(sv) + delta);
+ SvIV_set(sv, SvIVX(sv) + delta);
}
/* sv_catpvn() is now a macro using Perl_sv_catpvn_flags();
Perl_sv_catpvn_flags(pTHX_ register SV *dsv, register const char *sstr, register STRLEN slen, I32 flags)
{
STRLEN dlen;
- char *dstr;
+ const char *dstr = SvPV_force_flags(dsv, dlen, flags);
- dstr = SvPV_force_flags(dsv, dlen, flags);
SvGROW(dsv, dlen + slen + 1);
if (sstr == dstr)
sstr = SvPVX(dsv);
Move(sstr, SvPVX(dsv) + dlen, slen, char);
- SvCUR(dsv) += slen;
+ SvCUR_set(dsv, SvCUR(dsv) + slen);
*SvEND(dsv) = '\0';
(void)SvPOK_only_UTF8(dsv); /* validate pointer */
SvTAINT(dsv);
if (ptr == junk)
ptr = SvPVX(sv);
Move(ptr,SvPVX(sv)+tlen,len+1,char);
- SvCUR(sv) += len;
+ SvCUR_set(sv, SvCUR(sv) + len);
(void)SvPOK_only_UTF8(sv); /* validate pointer */
SvTAINT(sv);
}
=cut
*/
MAGIC *
-Perl_sv_magicext(pTHX_ SV* sv, SV* obj, int how, MGVTBL *vtable,
+Perl_sv_magicext(pTHX_ SV* sv, SV* obj, int how, const MGVTBL *vtable,
const char* name, I32 namlen)
{
MAGIC* mg;
}
Newz(702,mg, 1, MAGIC);
mg->mg_moremagic = SvMAGIC(sv);
- SvMAGIC(sv) = mg;
+ SvMAGIC_set(sv, mg);
/* Sometimes a magic contains a reference loop, where the sv and
object refer to each other. To prevent a reference loop that
if (!obj || obj == sv ||
how == PERL_MAGIC_arylen ||
how == PERL_MAGIC_qr ||
+ how == PERL_MAGIC_symtab ||
(SvTYPE(obj) == SVt_PVGV &&
(GvSV(obj) == sv || GvHV(obj) == (HV*)sv || GvAV(obj) == (AV*)sv ||
GvCV(obj) == (CV*)sv || GvIOp(obj) == (IO*)sv ||
void
Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
{
+ const MGVTBL *vtable = 0;
MAGIC* mg;
- MGVTBL *vtable = 0;
#ifdef PERL_COPY_ON_WRITE
if (SvIsCOW(sv))
case PERL_MAGIC_vec:
vtable = &PL_vtbl_vec;
break;
+ case PERL_MAGIC_arylen_p:
+ case PERL_MAGIC_rhash:
+ case PERL_MAGIC_symtab:
case PERL_MAGIC_vstring:
vtable = 0;
break;
}
/* Rest of work is done else where */
- mg = sv_magicext(sv,obj,how,vtable,name,namlen);
+ mg = sv_magicext(sv,obj,how,(MGVTBL*)vtable,name,namlen);
switch (how) {
case PERL_MAGIC_taint:
mgp = &SvMAGIC(sv);
for (mg = *mgp; mg; mg = *mgp) {
if (mg->mg_type == type) {
- MGVTBL* vtbl = mg->mg_virtual;
+ const MGVTBL* const vtbl = mg->mg_virtual;
*mgp = mg->mg_moremagic;
if (vtbl && vtbl->svt_free)
CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
*/
void
-Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen)
+Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, const char *little, STRLEN littlelen)
{
register char *big;
register char *mid;
while (midend > mid) /* shove everything down */
*--bigend = *--midend;
Move(little,big+offset,littlelen,char);
- SvCUR(bigstr) += i;
+ SvCUR_set(bigstr, SvCUR(bigstr) + i);
SvSETMAGIC(bigstr);
return;
}
void
Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
{
- U32 refcnt = SvREFCNT(sv);
+ const U32 refcnt = SvREFCNT(sv);
SV_CHECK_THINKFIRST_COW_DROP(sv);
if (SvREFCNT(nsv) != 1 && ckWARN_d(WARN_INTERNAL))
Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "Reference miscount in sv_replace()");
mg_free(nsv);
else
sv_upgrade(nsv, SVt_PVMG);
- SvMAGIC(nsv) = SvMAGIC(sv);
+ SvMAGIC_set(nsv, SvMAGIC(sv));
SvFLAGS(nsv) |= SvMAGICAL(sv);
SvMAGICAL_off(sv);
- SvMAGIC(sv) = 0;
+ SvMAGIC_set(sv, NULL);
}
SvREFCNT(sv) = 0;
sv_clear(sv);
assert(!SvREFCNT(sv));
+#ifdef DEBUG_LEAKING_SCALARS
+ sv->sv_flags = nsv->sv_flags;
+ sv->sv_any = nsv->sv_any;
+ sv->sv_refcnt = nsv->sv_refcnt;
+#else
StructCopy(nsv,sv,SV);
+#endif
+ /* Currently could join these into one piece of pointer arithmetic, but
+ it would be unclear. */
+ if(SvTYPE(sv) == SVt_IV)
+ SvANY(sv)
+ = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
+ else if (SvTYPE(sv) == SVt_RV) {
+ SvANY(sv) = &sv->sv_u.svu_rv;
+ }
+
+
#ifdef PERL_COPY_ON_WRITE
if (SvIsCOW_normal(nsv)) {
/* We need to follow the pointers around the loop to make the
void
Perl_sv_clear(pTHX_ register SV *sv)
{
+ dVAR;
HV* stash;
assert(sv);
assert(SvREFCNT(sv) == 0);
if(SvREFCNT(tmpref) < 2) {
/* tmpref is not kept alive! */
SvREFCNT(sv)--;
- SvRV(tmpref) = 0;
+ SvRV_set(tmpref, NULL);
SvROK_off(tmpref);
}
SvREFCNT_dec(tmpref);
if (SvREFCNT(sv)) {
if (PL_in_clean_objs)
Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
- HvNAME(stash));
+ HvNAME_get(stash));
/* DESTROY gave object new lease on life */
return;
}
if (SvTYPE(sv) >= SVt_PVMG) {
if (SvMAGIC(sv))
mg_free(sv);
- if (SvFLAGS(sv) & SVpad_TYPED)
+ if (SvTYPE(sv) == SVt_PVMG && SvFLAGS(sv) & SVpad_TYPED)
SvREFCNT_dec(SvSTASH(sv));
}
stash = NULL;
case SVt_PVNV:
case SVt_PVIV:
freescalar:
- SvOOK_off(sv);
+ /* Don't bother with SvOOK_off(sv); as we're only going to free it. */
+ if (SvOOK(sv)) {
+ SvPV_set(sv, SvPVX(sv) - SvIVX(sv));
+ /* Don't even bother with turning off the OOK flag. */
+ }
/* FALL THROUGH */
case SVt_PV:
case SVt_RV:
case SVt_NULL:
break;
case SVt_IV:
- del_XIV(SvANY(sv));
break;
case SVt_NV:
del_XNV(SvANY(sv));
break;
case SVt_RV:
- del_XRV(SvANY(sv));
break;
case SVt_PV:
del_XPV(SvANY(sv));
void
Perl_sv_free(pTHX_ SV *sv)
{
+ dVAR;
if (!sv)
return;
if (SvREFCNT(sv) == 0) {
void
Perl_sv_free2(pTHX_ SV *sv)
{
+ dVAR;
#ifdef DEBUGGING
if (SvTEMP(sv)) {
if (ckWARN_d(WARN_DEBUGGING))
else
{
STRLEN len, ulen;
- U8 *s = (U8*)SvPV(sv, len);
+ const U8 *s = (U8*)SvPV(sv, len);
MAGIC *mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : 0;
if (mg && mg->mg_len != -1 && (mg->mg_len > 0 || len == 0)) {
*
*/
STATIC bool
-S_utf8_mg_pos_init(pTHX_ SV *sv, MAGIC **mgp, STRLEN **cachep, I32 i, I32 *offsetp, U8 *s, U8 *start)
+S_utf8_mg_pos_init(pTHX_ SV *sv, MAGIC **mgp, STRLEN **cachep, I32 i, I32 offsetp, U8 *s, U8 *start)
{
bool found = FALSE;
if (SvMAGICAL(sv) && !SvREADONLY(sv)) {
if (!*mgp)
- *mgp = sv_magicext(sv, 0, PERL_MAGIC_utf8, &PL_vtbl_utf8, 0, 0);
+ *mgp = sv_magicext(sv, 0, PERL_MAGIC_utf8, (MGVTBL*)&PL_vtbl_utf8, 0, 0);
assert(*mgp);
if ((*mgp)->mg_ptr)
}
assert(*cachep);
- (*cachep)[i] = *offsetp;
+ (*cachep)[i] = offsetp;
(*cachep)[i+1] = s - start;
found = TRUE;
}
else { /* We will skip to the right spot. */
STRLEN forw = 0;
STRLEN backw = 0;
- U8* p = NULL;
+ const U8* p = NULL;
/* The assumption is that going backward is half
* the speed of going forward (that's where the
/* Try this only for the substr offset (i == 0),
* not for the substr length (i == 2). */
else if (i == 0) { /* (*cachep)[i] < uoff */
- STRLEN ulen = sv_len_utf8(sv);
+ const STRLEN ulen = sv_len_utf8(sv);
if ((STRLEN)uoff < ulen) {
forw = (STRLEN)uoff - (*cachep)[i];
s += UTF8SKIP(s);
if (s >= send)
s = send;
- if (utf8_mg_pos_init(sv, &mg, &cache, 0, offsetp, s, start))
+ if (utf8_mg_pos_init(sv, &mg, &cache, 0, *offsetp, s, start))
boffset = cache[1];
*offsetp = s - start;
}
if (lenp) {
found = FALSE;
start = s;
- if (utf8_mg_pos(sv, &mg, &cache, 2, lenp, *lenp + *offsetp, &s, start, send)) {
+ if (utf8_mg_pos(sv, &mg, &cache, 2, lenp, *lenp, &s, start, send)) {
*lenp -= boffset;
found = TRUE;
}
s += UTF8SKIP(s);
if (s >= send)
s = send;
- utf8_mg_pos_init(sv, &mg, &cache, 2, lenp, s, start);
+ utf8_mg_pos_init(sv, &mg, &cache, 2, *lenp, s, start);
}
*lenp = s - start;
}
I32
Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2)
{
- char *pv1;
+ const char *pv1;
STRLEN cur1;
- char *pv2;
+ const char *pv2;
STRLEN cur2;
I32 eq = 0;
char *tpv = Nullch;
if (SvUTF8(sv1)) {
/* sv1 is the UTF-8 one,
* if is equal it must be downgrade-able */
- char *pv = (char*)bytes_from_utf8((U8*)pv1,
+ char *pv = (char*)bytes_from_utf8((const U8*)pv1,
&cur1, &is_utf8);
if (pv != pv1)
pv1 = tpv = pv;
else {
/* sv2 is the UTF-8 one,
* if is equal it must be downgrade-able */
- char *pv = (char *)bytes_from_utf8((U8*)pv2,
+ char *pv = (char *)bytes_from_utf8((const U8*)pv2,
&cur2, &is_utf8);
if (pv != pv2)
pv2 = tpv = pv;
Perl_sv_cmp(pTHX_ register SV *sv1, register SV *sv2)
{
STRLEN cur1, cur2;
- char *pv1, *pv2, *tpv = Nullch;
+ const char *pv1, *pv2;
+ char *tpv = Nullch;
I32 cmp;
SV *svrecode = Nullsv;
pv2 = SvPV(svrecode, cur2);
}
else {
- pv2 = tpv = (char*)bytes_to_utf8((U8*)pv2, &cur2);
+ pv2 = tpv = (char*)bytes_to_utf8((const U8*)pv2, &cur2);
}
}
else {
pv1 = SvPV(svrecode, cur1);
}
else {
- pv1 = tpv = (char*)bytes_to_utf8((U8*)pv1, &cur1);
+ pv1 = tpv = (char*)bytes_to_utf8((const U8*)pv1, &cur1);
}
}
}
} else if (!cur2) {
cmp = 1;
} else {
- I32 retval = memcmp((void*)pv1, (void*)pv2, cur1 < cur2 ? cur1 : cur2);
+ const I32 retval = memcmp((const void*)pv1, (const void*)pv2, cur1 < cur2 ? cur1 : cur2);
if (retval) {
cmp = retval < 0 ? -1 : 1;
char *
Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
{
- char *rsptr;
+ const char *rsptr;
STRLEN rslen;
register STDCHAR rslast;
register STDCHAR *bp;
*/
Stat_t st;
if (!PerlLIO_fstat(PerlIO_fileno(fp), &st) && S_ISREG(st.st_mode)) {
- Off_t offset = PerlIO_tell(fp);
+ const Off_t offset = PerlIO_tell(fp);
if (offset != (Off_t) -1 && st.st_size + append > offset) {
(void) SvGROW(sv, (STRLEN)((st.st_size - offset) + append + 1));
}
else
{
/*The big, slow, and stupid way. */
-
- /* Any stack-challenged places. */
-#if defined(EPOC)
- /* EPOC: need to work around SDK features. *
- * On WINS: MS VC5 generates calls to _chkstk, *
- * if a "large" stack frame is allocated. *
- * gcc on MARM does not generate calls like these. */
-# define USEHEAPINSTEADOFSTACK
-#endif
-
-#ifdef USEHEAPINSTEADOFSTACK
+#ifdef USE_HEAP_INSTEAD_OF_STACK /* Even slower way. */
STDCHAR *buf = 0;
New(0, buf, 8192, STDCHAR);
assert(buf);
screamer2:
if (rslen) {
- register STDCHAR *bpe = buf + sizeof(buf);
+ const register STDCHAR *bpe = buf + sizeof(buf);
bp = buf;
while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = (STDCHAR)i) != rslast && bp < bpe)
; /* keep reading */
goto screamer2;
}
-#ifdef USEHEAPINSTEADOFSTACK
+#ifdef USE_HEAP_INSTEAD_OF_STACK
Safefree(buf);
#endif
}
sv_setnv(sv, UV_MAX_P1);
else
(void)SvIOK_only_UV(sv);
- ++SvUVX(sv);
+ SvUV_set(sv, SvUVX(sv) + 1);
} else {
if (SvIVX(sv) == IV_MAX)
sv_setuv(sv, (UV)IV_MAX + 1);
else {
(void)SvIOK_only(sv);
- ++SvIVX(sv);
+ SvIV_set(sv, SvIVX(sv) + 1);
}
}
return;
}
if (flags & SVp_NOK) {
(void)SvNOK_only(sv);
- SvNVX(sv) += 1.0;
+ SvNV_set(sv, SvNVX(sv) + 1.0);
return;
}
if ((flags & SVTYPEMASK) < SVt_PVIV)
sv_upgrade(sv, SVt_IV);
(void)SvIOK_only(sv);
- SvIVX(sv) = 1;
+ SvIV_set(sv, 1);
return;
}
d = SvPVX(sv);
/* Got to punt this as an integer if needs be, but we don't issue
warnings. Probably ought to make the sv_iv_please() that does
the conversion if possible, and silently. */
- int numtype = grok_number(SvPVX(sv), SvCUR(sv), NULL);
+ const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), NULL);
if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
/* Need to try really hard to see if it's an integer.
9.22337203685478e+18 is an integer.
/* sv_2iv *should* have made this an NV */
if (flags & SVp_NOK) {
(void)SvNOK_only(sv);
- SvNVX(sv) += 1.0;
+ SvNV_set(sv, SvNVX(sv) + 1.0);
return;
}
/* I don't think we can get here. Maybe I should assert this
}
/* oh,oh, the number grew */
SvGROW(sv, SvCUR(sv) + 2);
- SvCUR(sv)++;
+ SvCUR_set(sv, SvCUR(sv) + 1);
for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX(sv); d--)
*d = d[-1];
if (isDIGIT(d[1]))
if (SvIsUV(sv)) {
if (SvUVX(sv) == 0) {
(void)SvIOK_only(sv);
- SvIVX(sv) = -1;
+ SvIV_set(sv, -1);
}
else {
(void)SvIOK_only_UV(sv);
- --SvUVX(sv);
+ SvUV_set(sv, SvUVX(sv) + 1);
}
} else {
if (SvIVX(sv) == IV_MIN)
sv_setnv(sv, (NV)IV_MIN - 1.0);
else {
(void)SvIOK_only(sv);
- --SvIVX(sv);
+ SvIV_set(sv, SvIVX(sv) - 1);
}
}
return;
}
if (flags & SVp_NOK) {
- SvNVX(sv) -= 1.0;
+ SvNV_set(sv, SvNVX(sv) - 1.0);
(void)SvNOK_only(sv);
return;
}
if (!(flags & SVp_POK)) {
if ((flags & SVTYPEMASK) < SVt_PVNV)
sv_upgrade(sv, SVt_NV);
- SvNVX(sv) = -1.0;
+ SvNV_set(sv, 1.0);
(void)SvNOK_only(sv);
return;
}
#ifdef PERL_PRESERVE_IVUV
{
- int numtype = grok_number(SvPVX(sv), SvCUR(sv), NULL);
+ const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), NULL);
if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
/* Need to try really hard to see if it's an integer.
9.22337203685478e+18 is an integer.
/* sv_2iv *should* have made this an NV */
if (flags & SVp_NOK) {
(void)SvNOK_only(sv);
- SvNVX(sv) -= 1.0;
+ SvNV_set(sv, SvNVX(sv) - 1.0);
return;
}
/* I don't think we can get here. Maybe I should assert this
SV *
Perl_sv_2mortal(pTHX_ register SV *sv)
{
+ dVAR;
if (!sv)
return sv;
if (SvREADONLY(sv) && SvIMMORTAL(sv))
register SV *sv;
new_SV(sv);
- if (!len)
- len = strlen(s);
- sv_setpvn(sv,s,len);
+ sv_setpvn(sv,s,len ? len : strlen(s));
return sv;
}
STRLEN tmplen = -len;
is_utf8 = TRUE;
/* See the note in hv.c:hv_fetch() --jhi */
- src = (char*)bytes_from_utf8((U8*)src, &tmplen, &is_utf8);
+ src = (char*)bytes_from_utf8((const U8*)src, &tmplen, &is_utf8);
len = tmplen;
}
if (!hash)
PERL_HASH(hash, src, len);
new_SV(sv);
sv_upgrade(sv, SVt_PVIV);
- SvPVX(sv) = sharepvn(src, is_utf8?-len:len, hash);
- SvCUR(sv) = len;
- SvUVX(sv) = hash;
- SvLEN(sv) = 0;
+ SvPV_set(sv, sharepvn(src, is_utf8?-len:len, hash));
+ SvCUR_set(sv, len);
+ SvUV_set(sv, hash);
+ SvLEN_set(sv, 0);
SvREADONLY_on(sv);
SvFAKE_on(sv);
SvPOK_on(sv);
new_SV(sv);
sv_upgrade(sv, SVt_RV);
SvTEMP_off(tmpRef);
- SvRV(sv) = tmpRef;
+ SvRV_set(sv, tmpRef);
SvROK_on(sv);
return sv;
}
*/
void
-Perl_sv_reset(pTHX_ register char *s, HV *stash)
+Perl_sv_reset(pTHX_ register const char *s, HV *stash)
{
+ dVAR;
register HE *entry;
register GV *gv;
register SV *sv;
register I32 i;
- register PMOP *pm;
register I32 max;
char todo[PERL_UCHAR_MAX+1];
return;
if (!*s) { /* reset ?? searches */
- for (pm = HvPMROOT(stash); pm; pm = pm->op_pmnext) {
- pm->op_pmdynflags &= ~PMdf_USED;
+ MAGIC *mg = mg_find((SV *)stash, PERL_MAGIC_symtab);
+ if (mg) {
+ PMOP *pm = (PMOP *) mg->mg_obj;
+ while (pm) {
+ pm->op_pmdynflags &= ~PMdf_USED;
+ pm = pm->op_pmnext;
+ }
}
return;
}
if (GvAV(gv)) {
av_clear(GvAV(gv));
}
- if (GvHV(gv) && !HvNAME(GvHV(gv))) {
+ if (GvHV(gv) && !HvNAME_get(GvHV(gv))) {
hv_clear(GvHV(gv));
#ifndef PERL_MICRO
#ifdef USE_ENVIRON_ARRAY
CV *
Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
{
+ dVAR;
GV *gv = Nullgv;
CV *cv = Nullcv;
if (!sv)
return 0;
if (SvPOK(sv)) {
- register XPV* tXpv;
+ const register XPV* tXpv;
if ((tXpv = (XPV*)SvANY(sv)) &&
(tXpv->xpv_cur > 1 ||
- (tXpv->xpv_cur && *tXpv->xpv_pv != '0')))
+ (tXpv->xpv_cur && *sv->sv_u.svu_pv != '0')))
return 1;
else
return 0;
char *
Perl_sv_pvn_force_flags(pTHX_ SV *sv, STRLEN *lp, I32 flags)
{
- char *s = NULL;
if (SvTHINKFIRST(sv) && !SvROK(sv))
sv_force_normal_flags(sv, 0);
*lp = SvCUR(sv);
}
else {
+ char *s;
if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) {
Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
OP_NAME(PL_op));
else
s = sv_2pv_flags(sv, lp, flags);
if (s != SvPVX(sv)) { /* Almost, but not quite, sv_setpvn() */
- STRLEN len = *lp;
+ const STRLEN len = *lp;
if (SvROK(sv))
sv_unref(sv);
*/
char *
-Perl_sv_reftype(pTHX_ SV *sv, int ob)
+Perl_sv_reftype(pTHX_ const SV *sv, int ob)
{
+ /* The fact that I don't need to downcast to char * everywhere, only in ?:
+ inside return suggests a const propagation bug in g++. */
if (ob && SvOBJECT(sv)) {
- char *name = HvNAME(SvSTASH(sv));
- return name ? name : "__ANON__";
+ char *name = HvNAME_get(SvSTASH(sv));
+ return name ? name : (char *) "__ANON__";
}
else {
switch (SvTYPE(sv)) {
case SVt_PVNV:
case SVt_PVMG:
case SVt_PVBM:
- if (SvVOK(sv))
+ if (SvVOK(sv))
return "VSTRING";
if (SvROK(sv))
return "REF";
else
return "SCALAR";
-
- case SVt_PVLV: return SvROK(sv) ? "REF"
+
+ case SVt_PVLV: return (char *) (SvROK(sv) ? "REF"
/* tied lvalues should appear to be
* scalars for backwards compatitbility */
: (LvTYPE(sv) == 't' || LvTYPE(sv) == 'T')
- ? "SCALAR" : "LVALUE";
+ ? "SCALAR" : "LVALUE");
case SVt_PVAV: return "ARRAY";
case SVt_PVHV: return "HASH";
case SVt_PVCV: return "CODE";
int
Perl_sv_isa(pTHX_ SV *sv, const char *name)
{
+ const char *hvname;
if (!sv)
return 0;
if (SvGMAGICAL(sv))
sv = (SV*)SvRV(sv);
if (!SvOBJECT(sv))
return 0;
- if (!HvNAME(SvSTASH(sv)))
+ hvname = HvNAME_get(SvSTASH(sv));
+ if (!hvname)
return 0;
- return strEQ(HvNAME(SvSTASH(sv)), name);
+ return strEQ(hvname, name);
}
/*
SvAMAGIC_off(rv);
if (SvTYPE(rv) >= SVt_PVMG) {
- U32 refcnt = SvREFCNT(rv);
+ const U32 refcnt = SvREFCNT(rv);
SvREFCNT(rv) = 0;
sv_clear(rv);
SvFLAGS(rv) = 0;
if (SvTYPE(rv) < SVt_RV)
sv_upgrade(rv, SVt_RV);
else if (SvTYPE(rv) > SVt_RV) {
- SvOOK_off(rv);
- if (SvPVX(rv) && SvLEN(rv))
- Safefree(SvPVX(rv));
+ SvPV_free(rv);
SvCUR_set(rv, 0);
SvLEN_set(rv, 0);
}
SvOK_off(rv);
- SvRV(rv) = sv;
+ SvRV_set(rv, sv);
SvROK_on(rv);
if (classname) {
if (SvTYPE(tmpRef) != SVt_PVIO)
++PL_sv_objcount;
(void)SvUPGRADE(tmpRef, SVt_PVMG);
- SvSTASH(tmpRef) = (HV*)SvREFCNT_inc(stash);
+ SvSTASH_set(tmpRef, (HV*)SvREFCNT_inc(stash));
if (Gv_AMG(stash))
SvAMAGIC_on(sv);
if (SvWEAKREF(sv)) {
sv_del_backref(sv);
SvWEAKREF_off(sv);
- SvRV(sv) = 0;
+ SvRV_set(sv, NULL);
return;
}
- SvRV(sv) = 0;
+ SvRV_set(sv, NULL);
SvROK_off(sv);
/* You can't have a || SvREADONLY(rv) here, as $a = $$a, where $a was
assigned to as BEGIN {$a = \"Foo"} will fail. */
static char *
F0convert(NV nv, char *endbuf, STRLEN *len)
{
- int neg = nv < 0;
+ const int neg = nv < 0;
UV uv;
char *p = endbuf;
if (uv & 1 && uv == nv)
uv--; /* Round to even */
do {
- unsigned dig = uv % 10;
+ const unsigned dig = uv % 10;
*--p = '0' + dig;
} while (uv /= 10);
if (neg)
=cut
*/
+/* XXX maybe_tainted is never assigned to, so the doc above is lying. */
+
void
Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
{
char *p;
char *q;
- char *patend;
+ const char *patend;
STRLEN origlen;
I32 svix = 0;
- static char nullstr[] = "(null)";
+ static const char nullstr[] = "(null)";
SV *argsv = Nullsv;
bool has_utf8; /* has the result utf8? */
bool pat_utf8; /* the pattern is in utf8? */
/* no matter what, this is a string now */
(void)SvPV_force(sv, origlen);
- /* special-case "", "%s", and "%_" */
+ /* special-case "", "%s", and "%-p" (SVf) */
if (patlen == 0)
return;
- if (patlen == 2 && pat[0] == '%') {
- switch (pat[1]) {
- case 's':
+ if (patlen == 2 && pat[0] == '%' && pat[1] == 's') {
if (args) {
- char *s = va_arg(*args, char*);
+ const char *s = va_arg(*args, char*);
sv_catpv(sv, s ? s : nullstr);
}
else if (svix < svmax) {
SvUTF8_on(sv);
}
return;
- case '_':
+ }
+ if (patlen == 3 && pat[0] == '%' &&
+ pat[1] == '-' && pat[2] == 'p') {
if (args) {
argsv = va_arg(*args, SV*);
sv_catsv(sv, argsv);
SvUTF8_on(sv);
return;
}
- /* See comment on '_' below */
- break;
- }
}
#ifndef USE_LONG_DOUBLE
STRLEN have;
STRLEN need;
STRLEN gap;
- char *dotstr = ".";
+ const char *dotstr = ".";
STRLEN dotstrlen = 1;
I32 efix = 0; /* explicit format parameter index */
I32 ewix = 0; /* explicit width index */
#endif
elen = strlen(eptr);
else {
- eptr = nullstr;
+ eptr = (char *)nullstr;
elen = sizeof nullstr - 1;
}
}
is_utf8 = TRUE;
}
}
- goto string;
-
- case '_':
-#ifdef CHECK_FORMAT
- format_sv:
-#endif
- /*
- * The "%_" hack might have to be changed someday,
- * if ISO or ANSI decide to use '_' for something.
- * So we keep it hidden from users' code.
- */
- if (!args || vectorize)
- goto unknown;
- argsv = va_arg(*args, SV*);
- eptr = SvPVx(argsv, elen);
- if (DO_UTF8(argsv))
- is_utf8 = TRUE;
string:
vectorize = FALSE;
/* INTEGERS */
case 'p':
-#ifdef CHECK_FORMAT
- if (left) {
+ if (left && args) { /* SVf */
left = FALSE;
- if (!width)
- goto format_sv; /* %-p -> %_ */
- precis = width;
- has_precis = TRUE;
- width = 0;
- goto format_sv; /* %-Np -> %.N_ */
+ if (width) {
+ precis = width;
+ has_precis = TRUE;
+ width = 0;
+ }
+ if (vectorize)
+ goto unknown;
+ argsv = va_arg(*args, SV*);
+ eptr = SvPVx(argsv, elen);
+ if (DO_UTF8(argsv))
+ is_utf8 = TRUE;
+ goto string;
}
-#endif
if (alt || vectorize)
goto unknown;
uv = PTR2UV(args ? va_arg(*args, void*) : argsv);
}
break;
default: /* it had better be ten or less */
-#if defined(PERL_Y2KWARN)
- if (ckWARN(WARN_Y2K)) {
- STRLEN n;
- char *s = SvPV(sv,n);
- if (n >= 2 && s[n-2] == '1' && s[n-1] == '9'
- && (n == 2 || !isDIGIT(s[n-3])))
- {
- Perl_warner(aTHX_ packWARN(WARN_Y2K),
- "Possible Y2K bug: %%%c %s",
- c, "format string following '19'");
- }
- }
-#endif
do {
dig = uv % base;
*--eptr = '0' + dig;
Copy(eptr, p, elen, char);
p += elen;
*p = '\0';
- SvCUR(sv) = p - SvPVX(sv);
+ SvCUR_set(sv, p - SvPVX(sv));
svix = osvix;
continue; /* not "break" */
}
if (has_utf8)
SvUTF8_on(sv);
*p = '\0';
- SvCUR(sv) = p - SvPVX(sv);
+ SvCUR_set(sv, p - SvPVX(sv));
if (vectorize) {
esignlen = 0;
goto vector;
REGEXP *
Perl_re_dup(pTHX_ REGEXP *r, CLONE_PARAMS *param)
{
+ dVAR;
REGEXP *ret;
int i, len, npar;
struct reg_substr_datum *s;
ret->regstclass = NULL;
if (r->data) {
struct reg_data *d;
- int count = r->data->count;
+ const int count = r->data->count;
Newc(0, d, sizeof(struct reg_data) + count*sizeof(void *),
char, struct reg_data);
Perl_fp_dup(pTHX_ PerlIO *fp, char type, CLONE_PARAMS *param)
{
PerlIO *ret;
+ (void)type;
+
if (!fp)
return (PerlIO*)NULL;
av_push((AV*)nmg->mg_obj,sv_dup(svp[i],param));
}
}
+ else if (mg->mg_type == PERL_MAGIC_symtab) {
+ nmg->mg_obj = mg->mg_obj;
+ }
else {
nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED)
? sv_dup_inc(mg->mg_obj, param)
# define PTR_TABLE_HASH(ptr) (PTR2UV(ptr) >> 2)
#endif
+
+
+STATIC void
+S_more_pte(pTHX)
+{
+ struct ptr_tbl_ent* pte;
+ struct ptr_tbl_ent* pteend;
+ New(0, pte, PERL_ARENA_SIZE/sizeof(struct ptr_tbl_ent), struct ptr_tbl_ent);
+ pte->next = PL_pte_arenaroot;
+ PL_pte_arenaroot = pte;
+
+ pteend = &pte[PERL_ARENA_SIZE / sizeof(struct ptr_tbl_ent) - 1];
+ PL_pte_root = ++pte;
+ while (pte < pteend) {
+ pte->next = pte + 1;
+ pte++;
+ }
+ pte->next = 0;
+}
+
+STATIC struct ptr_tbl_ent*
+S_new_pte(pTHX)
+{
+ struct ptr_tbl_ent* pte;
+ if (!PL_pte_root)
+ S_more_pte(aTHX);
+ pte = PL_pte_root;
+ PL_pte_root = pte->next;
+ return pte;
+}
+
+STATIC void
+S_del_pte(pTHX_ struct ptr_tbl_ent*p)
+{
+ p->next = PL_pte_root;
+ PL_pte_root = p;
+}
+
/* map an existing pointer using a table */
void *
Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, void *sv)
{
PTR_TBL_ENT_t *tblent;
- UV hash = PTR_TABLE_HASH(sv);
+ const UV hash = PTR_TABLE_HASH(sv);
assert(tbl);
tblent = tbl->tbl_ary[hash & tbl->tbl_max];
for (; tblent; tblent = tblent->next) {
/* 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 */
- UV hash = PTR_TABLE_HASH(oldv);
+ const UV hash = PTR_TABLE_HASH(oldv);
bool empty = 1;
assert(tbl);
return;
}
}
- Newz(0, tblent, 1, PTR_TBL_ENT_t);
+ tblent = S_new_pte(aTHX);
tblent->oldval = oldv;
tblent->newval = newv;
tblent->next = *otblent;
Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl)
{
PTR_TBL_ENT_t **ary = tbl->tbl_ary;
- UV oldsize = tbl->tbl_max + 1;
+ const UV oldsize = tbl->tbl_max + 1;
UV newsize = oldsize * 2;
UV i;
{
register PTR_TBL_ENT_t **array;
register PTR_TBL_ENT_t *entry;
- register PTR_TBL_ENT_t *oentry = Null(PTR_TBL_ENT_t*);
UV riter = 0;
UV max;
for (;;) {
if (entry) {
- oentry = entry;
+ PTR_TBL_ENT_t *oentry = entry;
entry = entry->next;
- Safefree(oentry);
+ S_del_pte(aTHX_ oentry);
}
if (!entry) {
if (++riter > max) {
Safefree(tbl);
}
-#ifdef DEBUGGING
-char *PL_watch_pvx;
-#endif
-
/* attempt to make everything in the typeglob readonly */
STATIC SV *
if (!GvUNIQUE(gv)) {
#if 0
PerlIO_printf(Perl_debug_log, "gv_share: unable to share %s::%s\n",
- HvNAME(GvSTASH(gv)), GvNAME(gv));
+ HvNAME_get(GvSTASH(gv)), GvNAME(gv));
#endif
return Nullsv;
}
Perl_rvpv_dup(pTHX_ SV *dstr, SV *sstr, CLONE_PARAMS* param)
{
if (SvROK(sstr)) {
- SvRV(dstr) = SvWEAKREF(sstr)
- ? sv_dup(SvRV(sstr), param)
- : sv_dup_inc(SvRV(sstr), param);
+ SvRV_set(dstr, SvWEAKREF(sstr)
+ ? sv_dup(SvRV(sstr), param)
+ : sv_dup_inc(SvRV(sstr), param));
+
}
else if (SvPVX(sstr)) {
/* Has something there */
if (SvLEN(sstr)) {
/* Normal PV - clone whole allocated space */
- SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
+ SvPV_set(dstr, SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1));
if (SvREADONLY(sstr) && SvFAKE(sstr)) {
/* Not that normal - actually sstr is copy on write.
But we are a true, independant SV, so: */
and they should not have these flags
turned off */
- SvPVX(dstr) = sharepvn(SvPVX(sstr), SvCUR(sstr),
- SvUVX(sstr));
- SvUVX(dstr) = SvUVX(sstr);
+ SvPV_set(dstr, sharepvn(SvPVX(sstr), SvCUR(sstr),
+ SvUVX(sstr)));
+ SvUV_set(dstr, SvUVX(sstr));
} else {
- SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvCUR(sstr));
+ SvPV_set(dstr, SAVEPVN(SvPVX(sstr), SvCUR(sstr)));
SvFAKE_off(dstr);
SvREADONLY_off(dstr);
}
}
else {
/* Some other special case - random pointer */
- SvPVX(dstr) = SvPVX(sstr);
+ SvPV_set(dstr, SvPVX(sstr));
}
}
}
else {
/* Copy the Null */
- SvPVX(dstr) = SvPVX(sstr);
+ if (SvTYPE(dstr) == SVt_RV)
+ SvRV_set(dstr, NULL);
+ else
+ SvPV_set(dstr, 0);
}
}
SV *
Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param)
{
+ dVAR;
SV *dstr;
if (!sstr || SvTYPE(sstr) == SVTYPEMASK)
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(sstr)) {
+ (hvname = HvNAME_get(sstr))) {
/** don't clone stashes if they already exist **/
- HV* old_stash = gv_stashpv(HvNAME(sstr),0);
+ HV* old_stash = gv_stashpv(hvname,0);
return (SV*) old_stash;
}
}
/* create anew and remember what it is */
new_SV(dstr);
+
+#ifdef DEBUG_LEAKING_SCALARS
+ dstr->sv_debug_optype = sstr->sv_debug_optype;
+ 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);
/* clone */
PL_watch_pvx, SvPVX(sstr));
#endif
+ /* don't clone objects whose class has asked us not to */
+ if (SvOBJECT(sstr) && ! (SvFLAGS(SvSTASH(sstr)) & SVphv_CLONEABLE)) {
+ SvFLAGS(dstr) &= ~SVTYPEMASK;
+ SvOBJECT_off(dstr);
+ return dstr;
+ }
+
switch (SvTYPE(sstr)) {
case SVt_NULL:
SvANY(dstr) = NULL;
break;
case SVt_IV:
- SvANY(dstr) = new_XIV();
- SvIVX(dstr) = SvIVX(sstr);
+ SvANY(dstr) = (XPVIV*)((char*)&(dstr->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
+ SvIV_set(dstr, SvIVX(sstr));
break;
case SVt_NV:
SvANY(dstr) = new_XNV();
- SvNVX(dstr) = SvNVX(sstr);
+ SvNV_set(dstr, SvNVX(sstr));
break;
case SVt_RV:
- SvANY(dstr) = new_XRV();
+ SvANY(dstr) = &(dstr->sv_u.svu_rv);
Perl_rvpv_dup(aTHX_ dstr, sstr, param);
break;
case SVt_PV:
SvANY(dstr) = new_XPV();
- SvCUR(dstr) = SvCUR(sstr);
- SvLEN(dstr) = SvLEN(sstr);
+ SvCUR_set(dstr, SvCUR(sstr));
+ SvLEN_set(dstr, SvLEN(sstr));
Perl_rvpv_dup(aTHX_ dstr, sstr, param);
break;
case SVt_PVIV:
SvANY(dstr) = new_XPVIV();
- SvCUR(dstr) = SvCUR(sstr);
- SvLEN(dstr) = SvLEN(sstr);
- SvIVX(dstr) = SvIVX(sstr);
+ SvCUR_set(dstr, SvCUR(sstr));
+ SvLEN_set(dstr, SvLEN(sstr));
+ SvIV_set(dstr, SvIVX(sstr));
Perl_rvpv_dup(aTHX_ dstr, sstr, param);
break;
case SVt_PVNV:
SvANY(dstr) = new_XPVNV();
- SvCUR(dstr) = SvCUR(sstr);
- SvLEN(dstr) = SvLEN(sstr);
- SvIVX(dstr) = SvIVX(sstr);
- SvNVX(dstr) = SvNVX(sstr);
+ SvCUR_set(dstr, SvCUR(sstr));
+ SvLEN_set(dstr, SvLEN(sstr));
+ SvIV_set(dstr, SvIVX(sstr));
+ SvNV_set(dstr, SvNVX(sstr));
Perl_rvpv_dup(aTHX_ dstr, sstr, param);
break;
case SVt_PVMG:
SvANY(dstr) = new_XPVMG();
- SvCUR(dstr) = SvCUR(sstr);
- SvLEN(dstr) = SvLEN(sstr);
- SvIVX(dstr) = SvIVX(sstr);
- SvNVX(dstr) = SvNVX(sstr);
- SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
- SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
+ SvCUR_set(dstr, SvCUR(sstr));
+ SvLEN_set(dstr, SvLEN(sstr));
+ SvIV_set(dstr, SvIVX(sstr));
+ SvNV_set(dstr, SvNVX(sstr));
+ SvMAGIC_set(dstr, mg_dup(SvMAGIC(sstr), param));
+ SvSTASH_set(dstr, hv_dup_inc(SvSTASH(sstr), param));
Perl_rvpv_dup(aTHX_ dstr, sstr, param);
break;
case SVt_PVBM:
SvANY(dstr) = new_XPVBM();
- SvCUR(dstr) = SvCUR(sstr);
- SvLEN(dstr) = SvLEN(sstr);
- SvIVX(dstr) = SvIVX(sstr);
- SvNVX(dstr) = SvNVX(sstr);
- SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
- SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
+ SvCUR_set(dstr, SvCUR(sstr));
+ SvLEN_set(dstr, SvLEN(sstr));
+ SvIV_set(dstr, SvIVX(sstr));
+ SvNV_set(dstr, SvNVX(sstr));
+ SvMAGIC_set(dstr, mg_dup(SvMAGIC(sstr), param));
+ SvSTASH_set(dstr, hv_dup_inc(SvSTASH(sstr), param));
Perl_rvpv_dup(aTHX_ dstr, sstr, param);
BmRARE(dstr) = BmRARE(sstr);
BmUSEFUL(dstr) = BmUSEFUL(sstr);
break;
case SVt_PVLV:
SvANY(dstr) = new_XPVLV();
- SvCUR(dstr) = SvCUR(sstr);
- SvLEN(dstr) = SvLEN(sstr);
- SvIVX(dstr) = SvIVX(sstr);
- SvNVX(dstr) = SvNVX(sstr);
- SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
- SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
+ SvCUR_set(dstr, SvCUR(sstr));
+ SvLEN_set(dstr, SvLEN(sstr));
+ SvIV_set(dstr, SvIVX(sstr));
+ SvNV_set(dstr, SvNVX(sstr));
+ SvMAGIC_set(dstr, mg_dup(SvMAGIC(sstr), param));
+ SvSTASH_set(dstr, hv_dup_inc(SvSTASH(sstr), param));
Perl_rvpv_dup(aTHX_ dstr, sstr, param);
LvTARGOFF(dstr) = LvTARGOFF(sstr); /* XXX sometimes holds PMOP* when DEBUGGING */
LvTARGLEN(dstr) = LvTARGLEN(sstr);
ptr_table_store(PL_ptr_table, sstr, dstr);
#if 0
PerlIO_printf(Perl_debug_log, "sv_dup: sharing %s::%s\n",
- HvNAME(GvSTASH(share)), GvNAME(share));
+ HvNAME_get(GvSTASH(share)), GvNAME(share));
#endif
break;
}
}
SvANY(dstr) = new_XPVGV();
- SvCUR(dstr) = SvCUR(sstr);
- SvLEN(dstr) = SvLEN(sstr);
- SvIVX(dstr) = SvIVX(sstr);
- SvNVX(dstr) = SvNVX(sstr);
- SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
- SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
+ SvCUR_set(dstr, SvCUR(sstr));
+ SvLEN_set(dstr, SvLEN(sstr));
+ SvIV_set(dstr, SvIVX(sstr));
+ SvNV_set(dstr, SvNVX(sstr));
+ SvMAGIC_set(dstr, mg_dup(SvMAGIC(sstr), param));
+ SvSTASH_set(dstr, hv_dup_inc(SvSTASH(sstr), param));
Perl_rvpv_dup(aTHX_ dstr, sstr, param);
GvNAMELEN(dstr) = GvNAMELEN(sstr);
GvNAME(dstr) = SAVEPVN(GvNAME(sstr), GvNAMELEN(sstr));
break;
case SVt_PVIO:
SvANY(dstr) = new_XPVIO();
- SvCUR(dstr) = SvCUR(sstr);
- SvLEN(dstr) = SvLEN(sstr);
- SvIVX(dstr) = SvIVX(sstr);
- SvNVX(dstr) = SvNVX(sstr);
- SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
- SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
+ SvCUR_set(dstr, SvCUR(sstr));
+ SvLEN_set(dstr, SvLEN(sstr));
+ SvIV_set(dstr, SvIVX(sstr));
+ SvNV_set(dstr, SvNVX(sstr));
+ SvMAGIC_set(dstr, mg_dup(SvMAGIC(sstr), param));
+ SvSTASH_set(dstr, hv_dup_inc(SvSTASH(sstr), param));
Perl_rvpv_dup(aTHX_ dstr, sstr, param);
IoIFP(dstr) = fp_dup(IoIFP(sstr), IoTYPE(sstr), param);
if (IoOFP(sstr) == IoIFP(sstr))
break;
case SVt_PVAV:
SvANY(dstr) = new_XPVAV();
- SvCUR(dstr) = SvCUR(sstr);
- SvLEN(dstr) = SvLEN(sstr);
- SvIVX(dstr) = SvIVX(sstr);
- SvNVX(dstr) = SvNVX(sstr);
- SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
- SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
- AvARYLEN((AV*)dstr) = sv_dup_inc(AvARYLEN((AV*)sstr), param);
- AvFLAGS((AV*)dstr) = AvFLAGS((AV*)sstr);
+ SvCUR_set(dstr, SvCUR(sstr));
+ SvLEN_set(dstr, SvLEN(sstr));
+ SvMAGIC_set(dstr, mg_dup(SvMAGIC(sstr), param));
+ SvSTASH_set(dstr, hv_dup_inc(SvSTASH(sstr), param));
if (AvARRAY((AV*)sstr)) {
SV **dst_ary, **src_ary;
SSize_t items = AvFILLp((AV*)sstr) + 1;
src_ary = AvARRAY((AV*)sstr);
Newz(0, dst_ary, AvMAX((AV*)sstr)+1, SV*);
ptr_table_store(PL_ptr_table, src_ary, dst_ary);
- SvPVX(dstr) = (char*)dst_ary;
+ SvPV_set(dstr, (char*)dst_ary);
AvALLOC((AV*)dstr) = dst_ary;
if (AvREAL((AV*)sstr)) {
while (items-- > 0)
}
}
else {
- SvPVX(dstr) = Nullch;
+ SvPV_set(dstr, Nullch);
AvALLOC((AV*)dstr) = (SV**)NULL;
}
break;
case SVt_PVHV:
SvANY(dstr) = new_XPVHV();
- SvCUR(dstr) = SvCUR(sstr);
- SvLEN(dstr) = SvLEN(sstr);
- SvIVX(dstr) = SvIVX(sstr);
- SvNVX(dstr) = SvNVX(sstr);
- SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
- SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
- HvRITER((HV*)dstr) = HvRITER((HV*)sstr);
- if (HvARRAY((HV*)sstr)) {
- STRLEN i = 0;
- XPVHV *dxhv = (XPVHV*)SvANY(dstr);
- XPVHV *sxhv = (XPVHV*)SvANY(sstr);
- Newz(0, dxhv->xhv_array,
- PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1), char);
- while (i <= sxhv->xhv_max) {
- ((HE**)dxhv->xhv_array)[i] = he_dup(((HE**)sxhv->xhv_array)[i],
- (bool)!!HvSHAREKEYS(sstr),
- param);
- ++i;
+ SvCUR_set(dstr, SvCUR(sstr));
+ SvLEN_set(dstr, SvLEN(sstr));
+ HvTOTALKEYS(dstr) = HvTOTALKEYS(sstr);
+ SvMAGIC_set(dstr, mg_dup(SvMAGIC(sstr), param));
+ SvSTASH_set(dstr, hv_dup_inc(SvSTASH(sstr), param));
+ {
+ HEK *hvname = 0;
+
+ if (HvARRAY((HV*)sstr)) {
+ STRLEN i = 0;
+ const bool sharekeys = !!HvSHAREKEYS(sstr);
+ XPVHV * const dxhv = (XPVHV*)SvANY(dstr);
+ XPVHV * const sxhv = (XPVHV*)SvANY(sstr);
+ char *darray;
+ New(0, darray,
+ PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1)
+ + (SvOOK(sstr) ? sizeof(struct xpvhv_aux) : 0), char);
+ HvARRAY(dstr) = (HE**)darray;
+ while (i <= sxhv->xhv_max) {
+ HE *source = HvARRAY(sstr)[i];
+ HvARRAY(dstr)[i]
+ = source ? he_dup(source, sharekeys, param) : 0;
+ ++i;
+ }
+ if (SvOOK(sstr)) {
+ struct xpvhv_aux *saux = HvAUX(sstr);
+ struct xpvhv_aux *daux = HvAUX(dstr);
+ /* This flag isn't copied. */
+ /* SvOOK_on(hv) attacks the IV flags. */
+ SvFLAGS(dstr) |= SVf_OOK;
+
+ hvname = saux->xhv_name;
+ daux->xhv_name = hvname ? hek_dup(hvname, param) : hvname;
+
+ daux->xhv_riter = saux->xhv_riter;
+ daux->xhv_eiter = saux->xhv_eiter
+ ? he_dup(saux->xhv_eiter, (bool)!!HvSHAREKEYS(sstr),
+ param) : 0;
+ }
}
- dxhv->xhv_eiter = he_dup(sxhv->xhv_eiter,
- (bool)!!HvSHAREKEYS(sstr), param);
+ else {
+ SvPV_set(dstr, Nullch);
+ }
+ /* Record stashes for possible cloning in Perl_clone(). */
+ if(hvname)
+ av_push(param->stashes, dstr);
}
- else {
- SvPVX(dstr) = Nullch;
- HvEITER((HV*)dstr) = (HE*)NULL;
- }
- HvPMROOT((HV*)dstr) = HvPMROOT((HV*)sstr); /* XXX */
- HvNAME((HV*)dstr) = SAVEPV(HvNAME((HV*)sstr));
- /* Record stashes for possible cloning in Perl_clone(). */
- if(HvNAME((HV*)dstr))
- av_push(param->stashes, dstr);
break;
case SVt_PVFM:
SvANY(dstr) = new_XPVFM();
case SVt_PVCV:
SvANY(dstr) = new_XPVCV();
dup_pvcv:
- SvCUR(dstr) = SvCUR(sstr);
- SvLEN(dstr) = SvLEN(sstr);
- SvIVX(dstr) = SvIVX(sstr);
- SvNVX(dstr) = SvNVX(sstr);
- SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
- SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
+ SvCUR_set(dstr, SvCUR(sstr));
+ SvLEN_set(dstr, SvLEN(sstr));
+ SvIV_set(dstr, SvIVX(sstr));
+ SvNV_set(dstr, SvNVX(sstr));
+ SvMAGIC_set(dstr, mg_dup(SvMAGIC(sstr), param));
+ SvSTASH_set(dstr, hv_dup_inc(SvSTASH(sstr), param));
Perl_rvpv_dup(aTHX_ dstr, sstr, param);
CvSTASH(dstr) = hv_dup(CvSTASH(sstr), param); /* NOTE: not refcounted */
CvSTART(dstr) = CvSTART(sstr);
if (CvCONST(sstr)) {
CvXSUBANY(dstr).any_ptr = GvUNIQUE(CvGV(sstr)) ?
SvREFCNT_inc(CvXSUBANY(sstr).any_ptr) :
- sv_dup_inc(CvXSUBANY(sstr).any_ptr, param);
+ sv_dup_inc((SV *)CvXSUBANY(sstr).any_ptr, param);
}
/* don't dup if copying back - CvGV isn't refcounted, so the
* duped GV may never be freed. A bit of a hack! DAPM */
void (*dptr) (void*);
void (*dxptr) (pTHX_ void*);
OP *o;
+ /* Unions for circumventing strict ANSI C89 casting rules. */
+ union { void *vptr; void (*dptr)(void*); } u1, u2;
+ union { void *vptr; void (*dxptr)(pTHX_ void*); } u3, u4;
Newz(54, nss, max, ANY);
ptr = POPPTR(ss,ix);
TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
dptr = POPDPTR(ss,ix);
- TOPDPTR(nss,ix) = (void (*)(void*))any_dup((void *)dptr, proto_perl);
+ u1.dptr = dptr;
+ u2.vptr = any_dup(u1.vptr, proto_perl);
+ TOPDPTR(nss,ix) = u2.dptr;
break;
case SAVEt_DESTRUCTOR_X:
ptr = POPPTR(ss,ix);
TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
dxptr = POPDXPTR(ss,ix);
- TOPDXPTR(nss,ix) = (void (*)(pTHX_ void*))any_dup((void *)dxptr, proto_perl);
+ u3.dxptr = dxptr;
+ u4.vptr = any_dup(u3.vptr, proto_perl);;
+ TOPDXPTR(nss,ix) = u4.dxptr;
break;
case SAVEt_REGCONTEXT:
case SAVEt_ALLOC:
return nss;
}
+
+/* if sv is a stash, call $class->CLONE_SKIP(), and set the SVphv_CLONEABLE
+ * flag to the result. This is done for each stash before cloning starts,
+ * so we know which stashes want their objects cloned */
+
+static void
+do_mark_cloneable_stash(pTHX_ SV *sv)
+{
+ const char *hvname = HvNAME_get((HV*)sv);
+ if (hvname) {
+ GV* cloner = gv_fetchmethod_autoload((HV*)sv, "CLONE_SKIP", 0);
+ STRLEN len = HvNAMELEN_get((HV*)sv);
+ SvFLAGS(sv) |= SVphv_CLONEABLE; /* clone objects by default */
+ if (cloner && GvCV(cloner)) {
+ dSP;
+ UV status;
+
+ ENTER;
+ SAVETMPS;
+ PUSHMARK(SP);
+ XPUSHs(sv_2mortal(newSVpvn(hvname, len)));
+ PUTBACK;
+ call_sv((SV*)GvCV(cloner), G_SCALAR);
+ SPAGAIN;
+ status = POPu;
+ PUTBACK;
+ FREETMPS;
+ LEAVE;
+ if (status)
+ SvFLAGS(sv) &= ~SVphv_CLONEABLE;
+ }
+ }
+}
+
+
+
/*
=for apidoc perl_clone
PerlInterpreter *
perl_clone(PerlInterpreter *proto_perl, UV flags)
{
+ dVAR;
#ifdef PERL_IMPLICIT_SYS
/* perlhost.h so we need to call into it
CLONE_PARAMS* param = &clone_params;
PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
+ /* for each stash, determine whether its objects should be cloned */
+ S_visit(proto_perl, do_mark_cloneable_stash, SVt_PVHV, SVTYPEMASK);
PERL_SET_THX(my_perl);
# ifdef DEBUGGING
Poison(my_perl, 1, PerlInterpreter);
+ PL_op = Nullop;
+ PL_curcop = (COP *)Nullop;
PL_markstack = 0;
PL_scopestack = 0;
PL_savestack = 0;
CLONE_PARAMS clone_params;
CLONE_PARAMS* param = &clone_params;
PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
+ /* for each stash, determine whether its objects should be cloned */
+ S_visit(proto_perl, do_mark_cloneable_stash, SVt_PVHV, SVTYPEMASK);
PERL_SET_THX(my_perl);
-
-
# ifdef DEBUGGING
Poison(my_perl, 1, PerlInterpreter);
+ PL_op = Nullop;
+ PL_curcop = (COP *)Nullop;
PL_markstack = 0;
PL_scopestack = 0;
PL_savestack = 0;
param->proto_perl = proto_perl;
/* arena roots */
- PL_xiv_arenaroot = NULL;
- PL_xiv_root = NULL;
PL_xnv_arenaroot = NULL;
PL_xnv_root = NULL;
- PL_xrv_arenaroot = NULL;
- PL_xrv_root = NULL;
PL_xpv_arenaroot = NULL;
PL_xpv_root = NULL;
PL_xpviv_arenaroot = NULL;
PL_xpvhv_root = NULL;
PL_xpvmg_arenaroot = NULL;
PL_xpvmg_root = NULL;
+ PL_xpvgv_arenaroot = NULL;
+ PL_xpvgv_root = NULL;
PL_xpvlv_arenaroot = NULL;
PL_xpvlv_root = NULL;
PL_xpvbm_arenaroot = NULL;
PL_xpvbm_root = NULL;
PL_he_arenaroot = NULL;
PL_he_root = NULL;
+#if defined(USE_ITHREADS)
+ PL_pte_arenaroot = NULL;
+ PL_pte_root = NULL;
+#endif
PL_nice_chunk = NULL;
PL_nice_chunk_size = 0;
PL_sv_count = 0;
PL_debug = proto_perl->Idebug;
+ PL_hash_seed = proto_perl->Ihash_seed;
+ PL_rehash_seed = proto_perl->Irehash_seed;
+
#ifdef USE_REENTRANT_API
/* XXX: things like -Dm will segfault here in perlio, but doing
* PERL_SET_CONTEXT(proto_perl);
/* create SV map for pointer relocation */
PL_ptr_table = ptr_table_new();
+ /* and one for finding shared hash keys quickly */
+ PL_shared_hek_table = ptr_table_new();
/* initialize these special pointers as early as possible */
SvANY(&PL_sv_undef) = NULL;
SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
SvFLAGS(&PL_sv_no) = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
- SvPVX(&PL_sv_no) = SAVEPVN(PL_No, 0);
- SvCUR(&PL_sv_no) = 0;
- SvLEN(&PL_sv_no) = 1;
- SvIVX(&PL_sv_no) = 0;
- SvNVX(&PL_sv_no) = 0;
+ SvPV_set(&PL_sv_no, SAVEPVN(PL_No, 0));
+ SvCUR_set(&PL_sv_no, 0);
+ SvLEN_set(&PL_sv_no, 1);
+ SvIV_set(&PL_sv_no, 0);
+ SvNV_set(&PL_sv_no, 0);
ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
SvANY(&PL_sv_yes) = new_XPVNV();
SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
SvFLAGS(&PL_sv_yes) = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
- SvPVX(&PL_sv_yes) = SAVEPVN(PL_Yes, 1);
- SvCUR(&PL_sv_yes) = 1;
- SvLEN(&PL_sv_yes) = 2;
- SvIVX(&PL_sv_yes) = 1;
- SvNVX(&PL_sv_yes) = 1;
+ SvPV_set(&PL_sv_yes, SAVEPVN(PL_Yes, 1));
+ SvCUR_set(&PL_sv_yes, 1);
+ SvLEN_set(&PL_sv_yes, 2);
+ SvIV_set(&PL_sv_yes, 1);
+ SvNV_set(&PL_sv_yes, 1);
ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
/* create (a non-shared!) shared string table */
PL_strtab = newHV();
HvSHAREKEYS_off(PL_strtab);
- hv_ksplit(PL_strtab, 512);
+ hv_ksplit(PL_strtab, HvTOTALKEYS(proto_perl->Istrtab));
ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
PL_compiling = proto_perl->Icompiling;
/* Clone the regex array */
PL_regex_padav = newAV();
{
- I32 len = av_len((AV*)proto_perl->Iregex_padav);
+ const I32 len = av_len((AV*)proto_perl->Iregex_padav);
SV** regexen = AvARRAY((AV*)proto_perl->Iregex_padav);
av_push(PL_regex_padav,
sv_dup_inc(regexen[0],param));
PL_glob_index = proto_perl->Iglob_index;
PL_srand_called = proto_perl->Isrand_called;
- PL_hash_seed = proto_perl->Ihash_seed;
- PL_rehash_seed = proto_perl->Irehash_seed;
PL_uudmap['M'] = 0; /* reinits on demand */
PL_bitcount = Nullch; /* reinits on demand */
if (!(flags & CLONEf_KEEP_PTR_TABLE)) {
ptr_table_free(PL_ptr_table);
PL_ptr_table = NULL;
+ ptr_table_free(PL_shared_hek_table);
+ PL_shared_hek_table = NULL;
}
/* Call the ->CLONE method, if it exists, for each of the stashes
ENTER;
SAVETMPS;
PUSHMARK(SP);
- XPUSHs(sv_2mortal(newSVpv(HvNAME(stash), 0)));
+ XPUSHs(sv_2mortal(newSVpvn(HvNAME_get(stash), HvNAMELEN_get(stash))));
PUTBACK;
call_sv((SV*)GvCV(cloner), G_DISCARD);
FREETMPS;
SvREFCNT_dec(param->stashes);
+ /* orphaned? eg threads->new inside BEGIN or use */
+ if (PL_compcv && ! SvREFCNT(PL_compcv)) {
+ (void)SvREFCNT_inc(PL_compcv);
+ SAVEFREESV(PL_compcv);
+ }
+
return my_perl;
}
char *
Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding)
{
+ dVAR;
if (SvPOK(sv) && !SvUTF8(sv) && !IN_BYTES && SvROK(encoding)) {
SV *uni;
STRLEN len;
Perl_sv_cat_decode(pTHX_ SV *dsv, SV *encoding,
SV *ssv, int *offset, char *tstr, int tlen)
{
+ dVAR;
bool ret = FALSE;
if (SvPOK(ssv) && SvPOK(dsv) && SvROK(encoding) && offset) {
SV *offsv;
* indent-tabs-mode: t
* End:
*
- * vim: shiftwidth=4:
-*/
+ * ex: set ts=8 sts=4 sw=4 noet:
+ */
https://perl5.git.perl.org / perl5.git / blobdiff