}
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);
+ 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;
{
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)];
+ SV *sv = sva + 1;
+ SV *svend = &sva[SvREFCNT(sva)];
if (p >= sv && p < svend) {
ok = 1;
break;
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
{
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);
- }
-
- for (arena = PL_xiv_arenaroot; arena; arena = arenanext) {
- arenanext = (XPV*)arena->xpv_pv;
- Safefree(arena);
+ Safefree(sva);
}
- 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_xpvgv_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 = (XPV*)PL_xpvlv_arenaroot; arena; arena = arenanext) {
- arenanext = (XPV*)arena->xpv_pv;
+ 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;
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);
"", "", "");
}
-
-/* allocate another arena's worth of struct xrv */
-
-STATIC void
-S_more_xrv(pTHX)
-{
- XRV* xrv;
- XRV* xrvend;
- XPV *ptr;
- New(712, ptr, PERL_ARENA_SIZE/sizeof(XPV), XPV);
- ptr->xpv_pv = (char*)PL_xrv_arenaroot;
- PL_xrv_arenaroot = ptr;
-
- xrv = (XRV*) ptr;
- xrvend = &xrv[PERL_ARENA_SIZE / sizeof(XRV) - 1];
- xrv += (sizeof(XPV) - 1) / sizeof(XRV) + 1;
- PL_xrv_root = xrv;
- while (xrv < xrvend) {
- xrv->xrv_rv = (SV*)(xrv + 1);
- xrv++;
- }
- xrv->xrv_rv = 0;
-}
-
-/* allocate another arena's worth of IV bodies */
-
-STATIC void
-S_more_xiv(pTHX)
-{
- IV* xiv;
- IV* xivend;
- XPV* ptr;
- New(705, ptr, PERL_ARENA_SIZE/sizeof(XPV), XPV);
- ptr->xpv_pv = (char*)PL_xiv_arenaroot; /* linked list of xiv arenas */
- PL_xiv_arenaroot = ptr; /* to keep Purify happy */
-
- xiv = (IV*) ptr;
- xivend = &xiv[PERL_ARENA_SIZE / 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++;
- }
- *(IV**)xiv = 0;
-}
-
/* allocate another arena's worth of NV bodies */
STATIC void
{
NV* xnv;
NV* xnvend;
- XPV *ptr;
- New(711, ptr, PERL_ARENA_SIZE/sizeof(XPV), XPV);
- ptr->xpv_pv = (char*)PL_xnv_arenaroot;
+ void *ptr;
+ New(711, ptr, PERL_ARENA_SIZE/sizeof(NV), NV);
+ *((void **) ptr) = (void *)PL_xnv_arenaroot;
PL_xnv_arenaroot = ptr;
xnv = (NV*) ptr;
STATIC void
S_more_xpv(pTHX)
{
- XPV* xpv;
- XPV* xpvend;
- New(713, xpv, PERL_ARENA_SIZE/sizeof(XPV), XPV);
- xpv->xpv_pv = (char*)PL_xpv_arenaroot;
+ 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) - 1];
+ xpvend = &xpv[PERL_ARENA_SIZE / sizeof(xpv_allocated) - 1];
PL_xpv_root = ++xpv;
while (xpv < xpvend) {
- xpv->xpv_pv = (char*)(xpv + 1);
+ *((xpv_allocated**)xpv) = xpv + 1;
xpv++;
}
- xpv->xpv_pv = 0;
+ *((xpv_allocated**)xpv) = 0;
}
/* allocate another arena's worth of struct xpviv */
STATIC void
S_more_xpviv(pTHX)
{
- XPVIV* xpviv;
- XPVIV* xpvivend;
- New(714, xpviv, PERL_ARENA_SIZE/sizeof(XPVIV), XPVIV);
- xpviv->xpv_pv = (char*)PL_xpviv_arenaroot;
+ 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;
- xpvivend = &xpviv[PERL_ARENA_SIZE / sizeof(XPVIV) - 1];
+ xpvivend = &xpviv[PERL_ARENA_SIZE / sizeof(xpviv_allocated) - 1];
PL_xpviv_root = ++xpviv;
while (xpviv < xpvivend) {
- xpviv->xpv_pv = (char*)(xpviv + 1);
+ *((xpviv_allocated**)xpviv) = xpviv + 1;
xpviv++;
}
- xpviv->xpv_pv = 0;
+ *((xpviv_allocated**)xpviv) = 0;
}
/* allocate another arena's worth of struct xpvnv */
XPVNV* xpvnv;
XPVNV* xpvnvend;
New(715, xpvnv, PERL_ARENA_SIZE/sizeof(XPVNV), XPVNV);
- xpvnv->xpv_pv = (char*)PL_xpvnv_arenaroot;
+ *((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->xpv_pv = (char*)(xpvnv + 1);
+ *((XPVNV**)xpvnv) = xpvnv + 1;
xpvnv++;
}
- xpvnv->xpv_pv = 0;
+ *((XPVNV**)xpvnv) = 0;
}
/* allocate another arena's worth of struct xpvcv */
XPVCV* xpvcv;
XPVCV* xpvcvend;
New(716, xpvcv, PERL_ARENA_SIZE/sizeof(XPVCV), XPVCV);
- xpvcv->xpv_pv = (char*)PL_xpvcv_arenaroot;
+ *((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->xpv_pv = (char*)(xpvcv + 1);
+ *((XPVCV**)xpvcv) = xpvcv + 1;
xpvcv++;
}
- xpvcv->xpv_pv = 0;
+ *((XPVCV**)xpvcv) = 0;
}
/* allocate another arena's worth of struct xpvav */
STATIC void
S_more_xpvav(pTHX)
{
- XPVAV* xpvav;
- XPVAV* xpvavend;
- New(717, xpvav, PERL_ARENA_SIZE/sizeof(XPVAV), XPVAV);
- xpvav->xav_array = (char*)PL_xpvav_arenaroot;
+ 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;
- xpvavend = &xpvav[PERL_ARENA_SIZE / sizeof(XPVAV) - 1];
+ xpvavend = &xpvav[PERL_ARENA_SIZE / sizeof(xpvav_allocated) - 1];
PL_xpvav_root = ++xpvav;
while (xpvav < xpvavend) {
- xpvav->xav_array = (char*)(xpvav + 1);
+ *((xpvav_allocated**)xpvav) = xpvav + 1;
xpvav++;
}
- xpvav->xav_array = 0;
+ *((xpvav_allocated**)xpvav) = 0;
}
/* allocate another arena's worth of struct xpvhv */
STATIC void
S_more_xpvhv(pTHX)
{
- XPVHV* xpvhv;
- XPVHV* xpvhvend;
- New(718, xpvhv, PERL_ARENA_SIZE/sizeof(XPVHV), XPVHV);
- xpvhv->xhv_array = (char*)PL_xpvhv_arenaroot;
+ 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) - 1];
+ xpvhvend = &xpvhv[PERL_ARENA_SIZE / sizeof(xpvhv_allocated) - 1];
PL_xpvhv_root = ++xpvhv;
while (xpvhv < xpvhvend) {
- xpvhv->xhv_array = (char*)(xpvhv + 1);
+ *((xpvhv_allocated**)xpvhv) = xpvhv + 1;
xpvhv++;
}
- xpvhv->xhv_array = 0;
+ *((xpvhv_allocated**)xpvhv) = 0;
}
/* allocate another arena's worth of struct xpvmg */
XPVMG* xpvmg;
XPVMG* xpvmgend;
New(719, xpvmg, PERL_ARENA_SIZE/sizeof(XPVMG), XPVMG);
- xpvmg->xpv_pv = (char*)PL_xpvmg_arenaroot;
+ *((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->xpv_pv = (char*)(xpvmg + 1);
+ *((XPVMG**)xpvmg) = xpvmg + 1;
xpvmg++;
}
- xpvmg->xpv_pv = 0;
+ *((XPVMG**)xpvmg) = 0;
}
/* allocate another arena's worth of struct xpvgv */
XPVGV* xpvgv;
XPVGV* xpvgvend;
New(720, xpvgv, PERL_ARENA_SIZE/sizeof(XPVGV), XPVGV);
- xpvgv->xpv_pv = (char*)PL_xpvgv_arenaroot;
+ *((XPVGV**)xpvgv) = PL_xpvgv_arenaroot;
PL_xpvgv_arenaroot = xpvgv;
xpvgvend = &xpvgv[PERL_ARENA_SIZE / sizeof(XPVGV) - 1];
PL_xpvgv_root = ++xpvgv;
while (xpvgv < xpvgvend) {
- xpvgv->xpv_pv = (char*)(xpvgv + 1);
+ *((XPVGV**)xpvgv) = xpvgv + 1;
xpvgv++;
}
- xpvgv->xpv_pv = 0;
+ *((XPVGV**)xpvgv) = 0;
}
/* allocate another arena's worth of struct xpvlv */
XPVLV* xpvlv;
XPVLV* xpvlvend;
New(720, xpvlv, PERL_ARENA_SIZE/sizeof(XPVLV), XPVLV);
- xpvlv->xpv_pv = (char*)PL_xpvlv_arenaroot;
+ *((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->xpv_pv = (char*)(xpvlv + 1);
+ *((XPVLV**)xpvlv) = xpvlv + 1;
xpvlv++;
}
- xpvlv->xpv_pv = 0;
+ *((XPVLV**)xpvlv) = 0;
}
/* allocate another arena's worth of struct xpvbm */
XPVBM* xpvbm;
XPVBM* xpvbmend;
New(721, xpvbm, PERL_ARENA_SIZE/sizeof(XPVBM), XPVBM);
- xpvbm->xpv_pv = (char*)PL_xpvbm_arenaroot;
+ *((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->xpv_pv = (char*)(xpvbm + 1);
+ *((XPVBM**)xpvbm) = xpvbm + 1;
xpvbm++;
}
- xpvbm->xpv_pv = 0;
-}
-
-/* grab a new struct xrv from the free list, allocating more if necessary */
-
-STATIC XRV*
-S_new_xrv(pTHX)
-{
- XRV* xrv;
- LOCK_SV_MUTEX;
- if (!PL_xrv_root)
- S_more_xrv(aTHX);
- xrv = PL_xrv_root;
- PL_xrv_root = (XRV*)xrv->xrv_rv;
- UNLOCK_SV_MUTEX;
- return xrv;
-}
-
-/* return a struct xrv to the free list */
-
-STATIC void
-S_del_xrv(pTHX_ XRV *p)
-{
- LOCK_SV_MUTEX;
- p->xrv_rv = (SV*)PL_xrv_root;
- PL_xrv_root = p;
- UNLOCK_SV_MUTEX;
-}
-
-/* grab a new IV body from the free list, allocating more if necessary */
-
-STATIC XPVIV*
-S_new_xiv(pTHX)
-{
- IV* xiv;
- LOCK_SV_MUTEX;
- if (!PL_xiv_root)
- S_more_xiv(aTHX);
- 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));
-}
-
-/* return an IV body to the free list */
-
-STATIC void
-S_del_xiv(pTHX_ XPVIV *p)
-{
- 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;
+ *((XPVBM**)xpvbm) = 0;
}
/* grab a new NV body 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)
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;
}
STATIC XPVIV*
S_new_xpviv(pTHX)
{
- XPVIV* xpviv;
+ xpviv_allocated* xpviv;
LOCK_SV_MUTEX;
if (!PL_xpviv_root)
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;
}
if (!PL_xpvnv_root)
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;
}
if (!PL_xpvcv_root)
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;
}
STATIC XPVAV*
S_new_xpvav(pTHX)
{
- XPVAV* xpvav;
+ xpvav_allocated* xpvav;
LOCK_SV_MUTEX;
if (!PL_xpvav_root)
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;
}
STATIC XPVHV*
S_new_xpvhv(pTHX)
{
- XPVHV* xpvhv;
+ xpvhv_allocated* xpvhv;
LOCK_SV_MUTEX;
if (!PL_xpvhv_root)
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;
}
if (!PL_xpvmg_root)
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;
}
if (!PL_xpvgv_root)
S_more_xpvgv(aTHX);
xpvgv = PL_xpvgv_root;
- PL_xpvgv_root = (XPVGV*)xpvgv->xpv_pv;
+ PL_xpvgv_root = *(XPVGV**)xpvgv;
UNLOCK_SV_MUTEX;
return xpvgv;
}
S_del_xpvgv(pTHX_ XPVGV *p)
{
LOCK_SV_MUTEX;
- p->xpv_pv = (char*)PL_xpvgv_root;
+ *(XPVGV**)p = PL_xpvgv_root;
PL_xpvgv_root = p;
UNLOCK_SV_MUTEX;
}
if (!PL_xpvlv_root)
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;
}
if (!PL_xpvbm_root)
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;
}
#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)
#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)
break;
case SVt_IV:
iv = SvIVX(sv);
- del_XIV(SvANY(sv));
if (mt == SVt_NV)
mt = SVt_PVNV;
else if (mt < SVt_PVIV)
break;
case SVt_RV:
pv = (char*)SvRV(sv);
- del_XRV(SvANY(sv));
break;
case SVt_PV:
pv = SvPVX(sv);
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();
+ SvANY(sv) = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
SvIV_set(sv, iv);
break;
case SVt_NV:
SvNV_set(sv, nv);
break;
case SVt_RV:
- SvANY(sv) = new_XRV();
+ SvANY(sv) = &sv->sv_u.svu_rv;
SvRV_set(sv, (SV*)pv);
break;
case SVt_PVHV:
SvANY(sv) = new_XPVHV();
- HvRITER(sv) = 0;
- HvEITER(sv) = 0;
- HvPMROOT(sv) = 0;
- HvNAME(sv) = 0;
+ ((XPVHV*) SvANY(sv))->xhv_aux = 0;
HvFILL(sv) = 0;
HvMAX(sv) = 0;
HvTOTALKEYS(sv) = 0;
- HvPLACEHOLDERS(sv) = 0;
/* Fall through... */
if (0) {
AvMAX(sv) = -1;
AvFILLp(sv) = -1;
AvALLOC(sv) = 0;
- AvARYLEN(sv)= 0;
- AvFLAGS(sv) = AVf_REAL;
- SvIV_set(sv, 0);
- SvNV_set(sv, 0.0);
+ AvREAL_only(sv);
}
/* to here. */
/* XXX? Only SVt_NULL is ever upgraded to AV or HV? */
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;
I32
Perl_looks_like_number(pTHX_ SV *sv)
{
- register char *sbegin;
+ register const char *sbegin;
STRLEN len;
if (SvPOK(sv)) {
}
else if (SvPOKp(sv) && SvLEN(sv)) {
UV value;
- const 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
}
else if (SvPOKp(sv) && SvLEN(sv)) {
UV value;
- const 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
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));
}
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) {
}
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));
}
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;
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));
}
}
}
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");
}
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);
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_arylen_p:
+ case PERL_MAGIC_rhash:
+ case PERL_MAGIC_symtab:
case PERL_MAGIC_vstring:
vtable = 0;
break;
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()");
#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)) {
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_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));
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;
}
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;
}
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;
}
/* 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.
}
#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.
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
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);
/* 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));
+ char *name = HvNAME_get(SvSTASH(sv));
return name ? name : (char *) "__ANON__";
}
else {
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;
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 const char nullstr[] = "(null)";
/* 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
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);
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)
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;
}
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;
}
}
SvANY(dstr) = NULL;
break;
case SVt_IV:
- SvANY(dstr) = new_XIV();
+ SvANY(dstr) = (XPVIV*)((char*)&(dstr->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
SvIV_set(dstr, SvIVX(sstr));
break;
case SVt_NV:
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:
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_XPVAV();
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;
SvANY(dstr) = new_XPVHV();
SvCUR_set(dstr, SvCUR(sstr));
SvLEN_set(dstr, SvLEN(sstr));
- SvIV_set(dstr, SvIVX(sstr));
- SvNV_set(dstr, SvNVX(sstr));
+ HvTOTALKEYS(dstr) = HvTOTALKEYS(sstr);
SvMAGIC_set(dstr, mg_dup(SvMAGIC(sstr), param));
SvSTASH_set(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;
+ {
+ struct xpvhv_aux *aux = ((XPVHV *)SvANY(sstr))->xhv_aux;
+ HEK *hvname = 0;
+
+ if (aux) {
+ I32 riter = aux->xhv_riter;
+
+ hvname = aux->xhv_name;
+ if (hvname || riter != -1) {
+ struct xpvhv_aux *d_aux;
+
+ New(0, d_aux, 1, struct xpvhv_aux);
+
+ d_aux->xhv_riter = riter;
+ d_aux->xhv_eiter = 0;
+ d_aux->xhv_name = hvname ? hek_dup(hvname, param) : hvname;
+
+ ((XPVHV *)SvANY(dstr))->xhv_aux = d_aux;
+ } else {
+ ((XPVHV *)SvANY(dstr))->xhv_aux = 0;
+ }
}
- dxhv->xhv_eiter = he_dup(sxhv->xhv_eiter,
- (bool)!!HvSHAREKEYS(sstr), param);
- }
- else {
- SvPV_set(dstr, Nullch);
- HvEITER((HV*)dstr) = (HE*)NULL;
+ 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);
+ }
+ /* Record stashes for possible cloning in Perl_clone(). */
+ if(hvname)
+ av_push(param->stashes, dstr);
}
- 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();
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:
static void
do_mark_cloneable_stash(pTHX_ SV *sv)
{
- if (HvNAME((HV*)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;
ENTER;
SAVETMPS;
PUSHMARK(SP);
- XPUSHs(sv_2mortal(newSVpv(HvNAME((HV*)sv), 0)));
+ XPUSHs(sv_2mortal(newSVpvn(hvname, len)));
PUTBACK;
call_sv((SV*)GvCV(cloner), G_SCALAR);
SPAGAIN;
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_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;
/* 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;
}
projects / p5sagit/p5-mst-13.2.git / blobdiff