#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)
} 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;
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.) */
Safefree((void *)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;
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
sv_setpv(name, gvtype);
if (!hv)
p = "???";
- else if (!(p=HvNAME(hv)))
+ else if (!(p=HvNAME_get(hv)))
p = "__ANON__";
if (strNE(p, "main")) {
sv_catpv(name,p);
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)
"", "", "");
}
-/* 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* xpv;
+ XPV* xpvend;
+ New(713, xpv, PERL_ARENA_SIZE/sizeof(XPV), XPV);
+ *((XPV**)xpv) = PL_xpv_arenaroot;
+ PL_xpv_arenaroot = xpv;
+
+ xpvend = &xpv[PERL_ARENA_SIZE / sizeof(XPV) - 1];
+ PL_xpv_root = ++xpv;
+ while (xpv < xpvend) {
+ *((XPV**)xpv) = xpv + 1;
+ xpv++;
+ }
+ *((XPV**)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* xpviv;
+ XPVIV* xpvivend;
+ New(714, xpviv, PERL_ARENA_SIZE/sizeof(XPVIV), XPVIV);
+ *((XPVIV**)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) - 1];
+ PL_xpviv_root = ++xpviv;
+ while (xpviv < xpvivend) {
+ *((XPVIV**)xpviv) = xpviv + 1;
+ xpviv++;
}
- *(IV**)xiv = 0;
+ *((XPVIV**)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* xpvav;
+ XPVAV* xpvavend;
+ New(717, xpvav, PERL_ARENA_SIZE/sizeof(XPVAV), XPVAV);
+ *((XPVAV**)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) - 1];
+ PL_xpvav_root = ++xpvav;
+ while (xpvav < xpvavend) {
+ *((XPVAV**)xpvav) = xpvav + 1;
+ xpvav++;
}
- *(NV**)xnv = 0;
+ *((XPVAV**)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* xpvhv;
+ XPVHV* xpvhvend;
+ New(718, xpvhv, PERL_ARENA_SIZE/sizeof(XPVHV), XPVHV);
+ *((XPVHV**)xpvhv) = PL_xpvhv_arenaroot;
+ PL_xpvhv_arenaroot = xpvhv;
+
+ xpvhvend = &xpvhv[PERL_ARENA_SIZE / sizeof(XPVHV) - 1];
+ PL_xpvhv_root = ++xpvhv;
+ while (xpvhv < xpvhvend) {
+ *((XPVHV**)xpvhv) = xpvhv + 1;
+ xpvhv++;
+ }
+ *((XPVHV**)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 */
XPV* 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**)xpv;
UNLOCK_SV_MUTEX;
return xpv;
}
S_del_xpv(pTHX_ XPV *p)
{
LOCK_SV_MUTEX;
- p->xpv_pv = (char*)PL_xpv_root;
+ *(XPV**)p = PL_xpv_root;
PL_xpv_root = p;
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*
XPVIV* 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**)xpviv;
UNLOCK_SV_MUTEX;
return xpviv;
}
S_del_xpviv(pTHX_ XPVIV *p)
{
LOCK_SV_MUTEX;
- p->xpv_pv = (char*)PL_xpviv_root;
+ *(XPVIV**)p = PL_xpviv_root;
PL_xpviv_root = p;
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*
XPVAV* 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**)xpvav;
UNLOCK_SV_MUTEX;
return xpvav;
}
/* return a struct xpvav to the free list */
-STATIC void
-S_del_xpvav(pTHX_ XPVAV *p)
-{
- LOCK_SV_MUTEX;
- p->xav_array = (char*)PL_xpvav_root;
- PL_xpvav_root = p;
- 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;
+STATIC void
+S_del_xpvav(pTHX_ XPVAV *p)
+{
+ LOCK_SV_MUTEX;
+ *(XPVAV**)p = PL_xpvav_root;
+ PL_xpvav_root = p;
+ UNLOCK_SV_MUTEX;
}
/* grab a new struct xpvhv from the free list, allocating more if necessary */
XPVHV* 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**)xpvhv;
UNLOCK_SV_MUTEX;
return xpvhv;
}
S_del_xpvhv(pTHX_ XPVHV *p)
{
LOCK_SV_MUTEX;
- p->xhv_array = (char*)PL_xpvhv_root;
+ *(XPVHV**)p = PL_xpvhv_root;
PL_xpvhv_root = p;
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;
}
S_del_xpvmg(pTHX_ XPVMG *p)
{
LOCK_SV_MUTEX;
- p->xpv_pv = (char*)PL_xpvmg_root;
+ *(XPVMG**)p = PL_xpvmg_root;
PL_xpvmg_root = p;
UNLOCK_SV_MUTEX;
}
-/* allocate another arena's worth of struct xpvmg */
+/* grab a new struct xpvgv from the free list, allocating more if necessary */
-STATIC void
-S_more_xpvmg(pTHX)
+STATIC XPVGV*
+S_new_xpvgv(pTHX)
{
- register XPVMG* xpvmg;
- register XPVMG* xpvmgend;
- New(719, xpvmg, 1008/sizeof(XPVMG), XPVMG);
- xpvmg->xpv_pv = (char*)PL_xpvmg_arenaroot;
- PL_xpvmg_arenaroot = xpvmg;
+ XPVGV* xpvgv;
+ LOCK_SV_MUTEX;
+ if (!PL_xpvgv_root)
+ S_more_xpvgv(aTHX);
+ xpvgv = PL_xpvgv_root;
+ PL_xpvgv_root = *(XPVGV**)xpvgv;
+ UNLOCK_SV_MUTEX;
+ return xpvgv;
+}
- xpvmgend = &xpvmg[1008 / sizeof(XPVMG) - 1];
- PL_xpvmg_root = ++xpvmg;
- while (xpvmg < xpvmgend) {
- xpvmg->xpv_pv = (char*)(xpvmg + 1);
- xpvmg++;
- }
- xpvmg->xpv_pv = 0;
+/* return a struct xpvgv to the free list */
+
+STATIC void
+S_del_xpvgv(pTHX_ XPVGV *p)
+{
+ LOCK_SV_MUTEX;
+ *(XPVGV**)p = PL_xpvgv_root;
+ PL_xpvgv_root = p;
+ UNLOCK_SV_MUTEX;
}
/* grab a new struct xpvlv from the free list, allocating more if necessary */
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.sv_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.sv_rv;
+ SvRV_set(sv, (SV*)pv);
break;
case SVt_PVHV:
SvANY(sv) = new_XPVHV();
- if (pv)
- Safefree(pv);
- SvPVX(sv) = 0;
+ ((XPVHV*) SvANY(sv))->xhv_aux = 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;
+ AvARYLEN(sv)= 0;
+ AvREAL_only(sv);
+ SvIV_set(sv, 0);
+ SvNV_set(sv, 0.0);
+ }
+ /* 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;
assert(SvOOK(sv));
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) {
#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;
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(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(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 (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);
}
}
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__" , typestr, PTR2UV(sv));
}
return SvPVX(tsv);
}
else {
+ dVAR;
STRLEN len;
const char *t;
if (SvPOKp(sv)) {
register XPV* Xpvtmp;
if ((Xpvtmp = (XPV*)SvANY(sv)) &&
- (*Xpvtmp->xpv_pv > '0' ||
+ (*sv->sv_u.sv_pv > '0' ||
Xpvtmp->xpv_cur > 1 ||
- (Xpvtmp->xpv_cur && *Xpvtmp->xpv_pv != '0')))
+ (Xpvtmp->xpv_cur && *sv->sv_u.sv_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)SvOK_off(sv);
return;
}
- (void)SvOOK_off(sv);
- if (SvPVX(sv) && SvLEN(sv))
- Safefree(SvPVX(sv));
+ if (SvPVX(sv))
+ SvPV_free(sv);
Renew(ptr, len+1, char);
- SvPVX(sv) = ptr;
+ SvPV_set(sv, ptr);
SvCUR_set(sv, len);
SvLEN_set(sv, len+1);
*SvEND(sv) = '\0';
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);
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);
}
}
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 ||
case PERL_MAGIC_vec:
vtable = &PL_vtbl_vec;
break;
+ 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:
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);
#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.sv_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
+ else if (SvTYPE(sv) == SVt_RV) {
+ SvANY(sv) = &sv->sv_u.sv_rv;
+ }
+
#ifdef PERL_COPY_ON_WRITE
if (SvIsCOW_normal(nsv)) {
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;
}
*/
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);
/* 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;
}
/* 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))
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 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;
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.sv_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);
=cut
*/
-const char *
+char *
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)) {
- const 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)
{
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) {
const char *s = va_arg(*args, char*);
sv_catpv(sv, s ? s : nullstr);
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
#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;
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;
}
}
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.sv_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.sv_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);
+ 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));
AvARYLEN((AV*)dstr) = sv_dup_inc(AvARYLEN((AV*)sstr), param);
- AvFLAGS((AV*)dstr) = AvFLAGS((AV*)sstr);
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));
+ 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));
+ {
+ const char *hvname = HvNAME_get((HV*)sstr);
+ struct xpvhv_aux *aux = ((XPVHV *)SvANY(sstr))->xhv_aux;
+
+ if (aux) {
+ New(0, ((XPVHV *)SvANY(dstr))->xhv_aux, 1, struct xpvhv_aux);
+ HvRITER_set((HV*)dstr, HvRITER_get((HV*)sstr));
+ /* FIXME strlen HvNAME */
+ Perl_hv_name_set(aTHX_ (HV*) dstr, hvname,
+ hvname ? strlen(hvname) : 0,
+ 0);
+ } else {
+ ((XPVHV *)SvANY(dstr))->xhv_aux = 0;
+ }
+ if (HvARRAY((HV*)sstr)) {
+ STRLEN i = 0;
+ XPVHV *dxhv = (XPVHV*)SvANY(dstr);
+ XPVHV *sxhv = (XPVHV*)SvANY(sstr);
+ char *darray;
+ /* FIXME - surely this doesn't need to be zeroed? */
+ Newz(0, darray,
+ PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1), char);
+ HvARRAY(dstr) = (HE**)darray;
+ while (i <= sxhv->xhv_max) {
+ HvARRAY(dstr)[i]
+ = he_dup(HvARRAY(sstr)[i],
+ (bool)!!HvSHAREKEYS(sstr), param);
+ ++i;
+ }
+ HvEITER_set(dstr, he_dup(HvEITER_get(sstr),
+ (bool)!!HvSHAREKEYS(sstr), param));
+ }
+ else {
+ SvPV_set(dstr, Nullch);
+ HvEITER_set((HV*)dstr, (HE*)NULL);
}
- dxhv->xhv_eiter = he_dup(sxhv->xhv_eiter,
- (bool)!!HvSHAREKEYS(sstr), param);
+ /* 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 */
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);
+ SvFLAGS(sv) |= SVphv_CLONEABLE; /* clone objects by default */
+ if (cloner && GvCV(cloner)) {
+ dSP;
+ UV status;
+
+ ENTER;
+ SAVETMPS;
+ PUSHMARK(SP);
+ XPUSHs(sv_2mortal(newSVpv(hvname, 0)));
+ 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 = 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 = 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;
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 */
/* 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));
ENTER;
SAVETMPS;
PUSHMARK(SP);
- XPUSHs(sv_2mortal(newSVpv(HvNAME(stash), 0)));
+ XPUSHs(sv_2mortal(newSVpv(HvNAME_get(stash), 0)));
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:
+ */