/* sv.c
*
* Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
- * 2000, 2001, 2002, 2003, 2004, by Larry Wall and others
+ * 2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
#ifdef PERL_COPY_ON_WRITE
#define SV_COW_NEXT_SV(sv) INT2PTR(SV *,SvUVX(sv))
-#define SV_COW_NEXT_SV_SET(current,next) SvUVX(current) = PTR2UV(next)
+#define SV_COW_NEXT_SV_SET(current,next) SvUV_set(current, PTR2UV(next))
/* This is a pessimistic view. Scalar must be purely a read-write PV to copy-
on-write. */
#endif
pointer to the body (struct xrv, xpv, xpviv...), which contains fields
specific to each type.
-Normally, this allocation is done using arenas, which are approximately
-1K chunks of memory parcelled up into N heads or bodies. The first slot
-in each arena is reserved, and is used to hold a link to the next arena.
-In the case of heads, the unused first slot also contains some flags and
-a note of the number of slots. Snaked through each arena chain is a
+Normally, this allocation is done using arenas, which by default are
+approximately 4K chunks of memory parcelled up into N heads or bodies. The
+first slot in each arena is reserved, and is used to hold a link to the next
+arena. In the case of heads, the unused first slot also contains some flags
+and a note of the number of slots. Snaked through each arena chain is a
linked list of free items; when this becomes empty, an extra arena is
-allocated and divided up into N items which are threaded into the free
-list.
+allocated and divided up into N items which are threaded into the free list.
The following global variables are associated with arenas:
required. Also, if PURIFY is defined, arenas are abandoned altogether,
with all items individually malloc()ed. In addition, a few SV heads are
not allocated from an arena, but are instead directly created as static
-or auto variables, eg PL_sv_undef.
+or auto variables, eg PL_sv_undef. The size of arenas can be changed from
+the default by setting PERL_ARENA_SIZE appropriately at compile time.
The SV arena serves the secondary purpose of allowing still-live SVs
to be located and destroyed during final cleanup.
* "A time to plant, and a time to uproot what was planted..."
*/
+
+#ifdef DEBUG_LEAKING_SCALARS
+# ifdef NETWARE
+# define FREE_SV_DEBUG_FILE(sv) PerlMemfree((sv)->sv_debug_file)
+# else
+# define FREE_SV_DEBUG_FILE(sv) PerlMemShared_free((sv)->sv_debug_file)
+# endif
+#else
+# define FREE_SV_DEBUG_FILE(sv)
+#endif
+
#define plant_SV(p) \
STMT_START { \
+ FREE_SV_DEBUG_FILE(p); \
SvANY(p) = (void *)PL_sv_root; \
SvFLAGS(p) = SVTYPEMASK; \
PL_sv_root = (p); \
} STMT_END
+/* make some more SVs by adding another arena */
+
+/* sv_mutex must be held while calling more_sv() */
+STATIC SV*
+S_more_sv(pTHX)
+{
+ SV* sv;
+
+ if (PL_nice_chunk) {
+ sv_add_arena(PL_nice_chunk, PL_nice_chunk_size, 0);
+ PL_nice_chunk = Nullch;
+ PL_nice_chunk_size = 0;
+ }
+ else {
+ char *chunk; /* must use New here to match call to */
+ New(704,chunk,PERL_ARENA_SIZE,char); /* Safefree() in sv_free_arenas() */
+ sv_add_arena(chunk, PERL_ARENA_SIZE, 0);
+ }
+ uproot_SV(sv);
+ return sv;
+}
+
/* new_SV(): return a new, empty SV head */
#ifdef DEBUG_LEAKING_SCALARS
if (PL_sv_root)
uproot_SV(sv);
else
- sv = more_sv();
+ sv = S_more_sv(aTHX);
UNLOCK_SV_MUTEX;
SvANY(sv) = 0;
SvREFCNT(sv) = 1;
SvFLAGS(sv) = 0;
+ sv->sv_debug_optype = PL_op ? PL_op->op_type : 0;
+ sv->sv_debug_line = (U16) ((PL_copline == NOLINE) ?
+ (PL_curcop ? CopLINE(PL_curcop) : 0) : PL_copline);
+ sv->sv_debug_inpad = 0;
+ sv->sv_debug_cloned = 0;
+# ifdef NETWARE
+ sv->sv_debug_file = PL_curcop ? savepv(CopFILE(PL_curcop)): NULL;
+# else
+ sv->sv_debug_file = PL_curcop ? savesharedpv(CopFILE(PL_curcop)): NULL;
+# endif
+
return sv;
}
# define new_SV(p) (p)=S_new_SV(aTHX)
if (PL_sv_root) \
uproot_SV(p); \
else \
- (p) = more_sv(); \
+ (p) = S_more_sv(aTHX); \
UNLOCK_SV_MUTEX; \
SvANY(p) = 0; \
SvREFCNT(p) = 1; \
{
if (DEBUG_D_TEST) {
SV* sva;
- SV* sv;
- SV* svend;
- int ok = 0;
+ bool ok = 0;
for (sva = PL_sv_arenaroot; sva; sva = (SV *) SvANY(sva)) {
- sv = sva + 1;
- svend = &sva[SvREFCNT(sva)];
- if (p >= sv && p < svend)
+ SV *sv = sva + 1;
+ SV *svend = &sva[SvREFCNT(sva)];
+ if (p >= sv && p < svend) {
ok = 1;
+ break;
+ }
}
if (!ok) {
if (ckWARN_d(WARN_INTERNAL))
sv = sva + 1;
while (sv < svend) {
SvANY(sv) = (void *)(SV*)(sv + 1);
+#ifdef DEBUGGING
SvREFCNT(sv) = 0;
+#endif
+ /* Must always set typemask because it's awlays checked in on cleanup
+ when the arenas are walked looking for objects. */
SvFLAGS(sv) = SVTYPEMASK;
sv++;
}
SvANY(sv) = 0;
+#ifdef DEBUGGING
+ SvREFCNT(sv) = 0;
+#endif
SvFLAGS(sv) = SVTYPEMASK;
}
-/* make some more SVs by adding another arena */
-
-/* sv_mutex must be held while calling more_sv() */
-STATIC SV*
-S_more_sv(pTHX)
-{
- register SV* sv;
-
- if (PL_nice_chunk) {
- sv_add_arena(PL_nice_chunk, PL_nice_chunk_size, 0);
- PL_nice_chunk = Nullch;
- PL_nice_chunk_size = 0;
- }
- else {
- char *chunk; /* must use New here to match call to */
- New(704,chunk,1008,char); /* Safefree() in sv_free_arenas() */
- sv_add_arena(chunk, 1008, 0);
- }
- uproot_SV(sv);
- return sv;
-}
-
/* visit(): call the named function for each non-free SV in the arenas
* whose flags field matches the flags/mask args. */
S_visit(pTHX_ SVFUNC_t f, U32 flags, U32 mask)
{
SV* sva;
- SV* sv;
- register SV* svend;
I32 visited = 0;
for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
- svend = &sva[SvREFCNT(sva)];
+ register SV * const svend = &sva[SvREFCNT(sva)];
+ register SV* sv;
for (sv = sva + 1; sv < svend; ++sv) {
if (SvTYPE(sv) != SVTYPEMASK
&& (sv->sv_flags & mask) == flags
if (SvWEAKREF(sv)) {
sv_del_backref(sv);
SvWEAKREF_off(sv);
- SvRV(sv) = 0;
+ SvRV_set(sv, NULL);
} else {
SvROK_off(sv);
- SvRV(sv) = 0;
+ SvRV_set(sv, NULL);
SvREFCNT_dec(rv);
}
}
{
SV* sva;
SV* svanext;
- XPV *arena, *arenanext;
+ void *arena, *arenanext;
/* Free arenas here, but be careful about fake ones. (We assume
contiguity of the fake ones with the corresponding real ones.) */
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;
#define FUV_SUBSCRIPT_WITHIN 4 /* "within @foo" */
STATIC SV*
-S_varname(pTHX_ GV *gv, char *gvtype, PADOFFSET targ,
+S_varname(pTHX_ GV *gv, const char *gvtype, PADOFFSET targ,
SV* keyname, I32 aindex, int subscript_type)
{
AV *av;
+ SV *sv;
- SV *sv, *name;
-
- name = sv_newmortal();
+ SV * const name = sv_newmortal();
if (gv) {
/* simulate gv_fullname4(), but add literal '^' for $^FOO names
* XXX get rid of all this if gv_fullnameX() ever supports this
* directly */
- char *p;
+ const char *p;
HV *hv = GvSTASH(gv);
sv_setpv(name, gvtype);
if (!hv)
p = "???";
- else if (!HvNAME(hv))
+ else if (!(p=HvNAME_get(hv)))
p = "__ANON__";
- else
- p = HvNAME(hv);
if (strNE(p, "main")) {
sv_catpv(name,p);
sv_catpvn(name,"::", 2);
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);
- I32 index;
- SV *keysv;
+ 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;
if (pad) { /* @lex, %lex */
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)
gv = cGVOPx_gv(o);
if (match && GvSV(gv) != uninit_sv)
break;
- return S_varname(aTHX_ gv, "$", 0,
+ return S_varname(aTHX_ gv, "$", 0,
Nullsv, 0, FUV_SUBSCRIPT_NONE);
}
/* other possibilities not handled are:
Perl_report_uninit(pTHX_ SV* uninit_sv)
{
if (PL_op) {
- SV* varname;
+ SV* varname = Nullsv;
if (uninit_sv) {
varname = find_uninit_var(PL_op, uninit_sv,0);
if (varname)
"", "", "");
}
-/* 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;
+}
+
+/* allocate another arena's worth of struct xpv */
+
+STATIC void
+S_more_xpv(pTHX)
+{
+ 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;
}
-/* return an IV body to the free list */
+/* allocate another arena's worth of struct xpviv */
STATIC void
-S_del_xiv(pTHX_ XPVIV *p)
+S_more_xpviv(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;
+ XPVIV* xpviv;
+ XPVIV* xpvivend;
+ New(714, xpviv, PERL_ARENA_SIZE/sizeof(XPVIV), XPVIV);
+ *((XPVIV**)xpviv) = PL_xpviv_arenaroot;
+ PL_xpviv_arenaroot = xpviv;
+
+ xpvivend = &xpviv[PERL_ARENA_SIZE / sizeof(XPVIV) - 1];
+ PL_xpviv_root = ++xpviv;
+ while (xpviv < xpvivend) {
+ *((XPVIV**)xpviv) = xpviv + 1;
+ xpviv++;
+ }
+ *((XPVIV**)xpviv) = 0;
}
-/* allocate another arena's worth of IV bodies */
+/* allocate another arena's worth of struct xpvnv */
STATIC void
-S_more_xiv(pTHX)
+S_more_xpvnv(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 */
+ XPVNV* xpvnv;
+ XPVNV* xpvnvend;
+ New(715, xpvnv, PERL_ARENA_SIZE/sizeof(XPVNV), XPVNV);
+ *((XPVNV**)xpvnv) = PL_xpvnv_arenaroot;
+ PL_xpvnv_arenaroot = xpvnv;
- 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++;
+ xpvnvend = &xpvnv[PERL_ARENA_SIZE / sizeof(XPVNV) - 1];
+ PL_xpvnv_root = ++xpvnv;
+ while (xpvnv < xpvnvend) {
+ *((XPVNV**)xpvnv) = xpvnv + 1;
+ xpvnv++;
}
- *(IV**)xiv = 0;
+ *((XPVNV**)xpvnv) = 0;
}
-/* grab a new NV body from the free list, allocating more if necessary */
+/* allocate another arena's worth of struct xpvcv */
-STATIC XPVNV*
-S_new_xnv(pTHX)
+STATIC void
+S_more_xpvcv(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));
+ 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;
}
-/* return an NV body to the free list */
+/* allocate another arena's worth of struct xpvav */
STATIC void
-S_del_xnv(pTHX_ XPVNV *p)
+S_more_xpvav(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;
+ XPVAV* xpvav;
+ XPVAV* xpvavend;
+ New(717, xpvav, PERL_ARENA_SIZE/sizeof(XPVAV), XPVAV);
+ *((XPVAV**)xpvav) = PL_xpvav_arenaroot;
+ PL_xpvav_arenaroot = xpvav;
+
+ xpvavend = &xpvav[PERL_ARENA_SIZE / sizeof(XPVAV) - 1];
+ PL_xpvav_root = ++xpvav;
+ while (xpvav < xpvavend) {
+ *((XPVAV**)xpvav) = xpvav + 1;
+ xpvav++;
+ }
+ *((XPVAV**)xpvav) = 0;
}
-/* allocate another arena's worth of NV bodies */
+/* allocate another arena's worth of struct xpvhv */
STATIC void
-S_more_xnv(pTHX)
+S_more_xpvhv(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;
+ XPVHV* xpvhv;
+ XPVHV* xpvhvend;
+ New(718, xpvhv, PERL_ARENA_SIZE/sizeof(XPVHV), XPVHV);
+ *((XPVHV**)xpvhv) = PL_xpvhv_arenaroot;
+ PL_xpvhv_arenaroot = xpvhv;
- 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++;
+ xpvhvend = &xpvhv[PERL_ARENA_SIZE / sizeof(XPVHV) - 1];
+ PL_xpvhv_root = ++xpvhv;
+ while (xpvhv < xpvhvend) {
+ *((XPVHV**)xpvhv) = xpvhv + 1;
+ xpvhv++;
}
- *(NV**)xnv = 0;
+ *((XPVHV**)xpvhv) = 0;
}
-/* grab a new struct xrv from the free list, allocating more if necessary */
+/* allocate another arena's worth of struct xpvmg */
-STATIC XRV*
-S_new_xrv(pTHX)
+STATIC void
+S_more_xpvmg(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;
+ 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;
}
-/* return a struct xrv to the free list */
+/* allocate another arena's worth of struct xpvgv */
STATIC void
-S_del_xrv(pTHX_ XRV *p)
+S_more_xpvgv(pTHX)
{
- LOCK_SV_MUTEX;
- p->xrv_rv = (SV*)PL_xrv_root;
- PL_xrv_root = p;
- UNLOCK_SV_MUTEX;
+ XPVGV* xpvgv;
+ XPVGV* xpvgvend;
+ New(720, xpvgv, PERL_ARENA_SIZE/sizeof(XPVGV), XPVGV);
+ *((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**)xpvgv) = xpvgv + 1;
+ xpvgv++;
+ }
+ *((XPVGV**)xpvgv) = 0;
}
-/* allocate another arena's worth of struct xrv */
+/* allocate another arena's worth of struct xpvlv */
STATIC void
-S_more_xrv(pTHX)
+S_more_xpvlv(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;
+ XPVLV* xpvlv;
+ XPVLV* xpvlvend;
+ New(720, xpvlv, PERL_ARENA_SIZE/sizeof(XPVLV), XPVLV);
+ *((XPVLV**)xpvlv) = PL_xpvlv_arenaroot;
+ PL_xpvlv_arenaroot = xpvlv;
- 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++;
+ xpvlvend = &xpvlv[PERL_ARENA_SIZE / sizeof(XPVLV) - 1];
+ PL_xpvlv_root = ++xpvlv;
+ while (xpvlv < xpvlvend) {
+ *((XPVLV**)xpvlv) = xpvlv + 1;
+ xpvlv++;
}
- xrv->xrv_rv = 0;
+ *((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;
}
S_del_xpvav(pTHX_ XPVAV *p)
{
LOCK_SV_MUTEX;
- p->xav_array = (char*)PL_xpvav_root;
+ *(XPVAV**)p = 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;
-}
-
/* grab a new struct xpvhv from the free list, allocating more if necessary */
STATIC XPVHV*
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)
bool
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);
SvFLAGS(sv) &= ~SVTYPEMASK;
SvFLAGS(sv) |= mt;
- switch (mt) {
- case SVt_NULL:
- Perl_croak(aTHX_ "Can't upgrade to undef");
- case SVt_IV:
- SvANY(sv) = new_XIV();
- SvIVX(sv) = iv;
- break;
- case SVt_NV:
- SvANY(sv) = new_XNV();
- SvNVX(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;
+ switch (mt) {
+ case SVt_NULL:
+ Perl_croak(aTHX_ "Can't upgrade to undef");
+ case SVt_IV:
+ SvANY(sv) = (XPVIV*)((char*)&(sv->sv_u.sv_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
+ SvIV_set(sv, iv);
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;
+ case SVt_NV:
+ SvANY(sv) = new_XNV();
+ SvNV_set(sv, nv);
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) = 0;
+ case SVt_RV:
+ 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;
#endif
Renew(s,newlen,char);
}
- else {
+ else {
New(703, s, newlen, char);
if (SvPVX(sv) && SvCUR(sv)) {
Move(SvPVX(sv), s, (newlen < SvCUR(sv)) ? newlen : SvCUR(sv), char);
OP_DESC(PL_op));
}
(void)SvIOK_only(sv); /* validate number */
- SvIVX(sv) = i;
+ SvIV_set(sv, i);
SvTAINT(sv);
}
}
sv_setiv(sv, 0);
SvIsUV_on(sv);
- SvUVX(sv) = u;
+ SvUV_set(sv, u);
}
/*
Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
OP_NAME(PL_op));
}
- SvNVX(sv) = num;
+ SvNV_set(sv, num);
(void)SvNOK_only(sv); /* validate number */
SvTAINT(sv);
}
I32
Perl_looks_like_number(pTHX_ SV *sv)
{
- register char *sbegin;
+ register const char *sbegin;
STRLEN len;
if (SvPOK(sv)) {
if (SvNVX(sv) < (NV)IV_MIN) {
(void)SvIOKp_on(sv);
(void)SvNOK_on(sv);
- SvIVX(sv) = IV_MIN;
+ SvIV_set(sv, IV_MIN);
return IS_NUMBER_UNDERFLOW_IV;
}
if (SvNVX(sv) > (NV)UV_MAX) {
(void)SvIOKp_on(sv);
(void)SvNOK_on(sv);
SvIsUV_on(sv);
- SvUVX(sv) = UV_MAX;
+ SvUV_set(sv, UV_MAX);
return IS_NUMBER_OVERFLOW_UV;
}
(void)SvIOKp_on(sv);
/* Can't use strtol etc to convert this string. (See truth table in
sv_2iv */
if (SvNVX(sv) <= (UV)IV_MAX) {
- SvIVX(sv) = I_V(SvNVX(sv));
+ SvIV_set(sv, I_V(SvNVX(sv)));
if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
SvIOK_on(sv); /* Integer is precise. NOK, IOK */
} else {
return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
}
SvIsUV_on(sv);
- SvUVX(sv) = U_V(SvNVX(sv));
+ SvUV_set(sv, U_V(SvNVX(sv)));
if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
if (SvUVX(sv) == UV_MAX) {
/* As we know that NVs don't preserve UVs, UV_MAX cannot
answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary
cases go to UV */
if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
- SvIVX(sv) = I_V(SvNVX(sv));
+ SvIV_set(sv, I_V(SvNVX(sv)));
if (SvNVX(sv) == (NV) SvIVX(sv)
#ifndef NV_PRESERVES_UV
&& (((UV)1 << NV_PRESERVES_UV_BITS) >
0x8000000000000000 which will be exact. NWC */
}
else {
- SvUVX(sv) = U_V(SvNVX(sv));
+ SvUV_set(sv, U_V(SvNVX(sv)));
if (
(SvNVX(sv) == (NV) SvUVX(sv))
#ifndef NV_PRESERVES_UV
}
else if (SvPOKp(sv) && SvLEN(sv)) {
UV value;
- int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
+ const int numtype = grok_number(SvPVX(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);
}
if (!sv) {
*lp = 0;
- return "";
+ return (char *)"";
}
if (SvGMAGICAL(sv)) {
if (flags & SV_GMAGIC)
report_uninit(sv);
}
*lp = 0;
- return "";
+ return (char *)"";
}
}
if (SvTHINKFIRST(sv)) {
if (SvROK(sv)) {
SV* tmpstr;
+ register const char *typestr;
if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)) &&
(!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
char *pv = SvPV(tmpstr, *lp);
origsv = sv;
sv = (SV*)SvRV(sv);
if (!sv)
- s = "NULLREF";
+ typestr = "NULLREF";
else {
MAGIC *mg;
(SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
== (SVs_OBJECT|SVs_SMG))
&& (mg = mg_find(sv, PERL_MAGIC_qr))) {
- regexp *re = (regexp *)mg->mg_obj;
+ const regexp *re = (regexp *)mg->mg_obj;
if (!mg->mg_ptr) {
- char *fptr = "msix";
+ const char *fptr = "msix";
char reflags[6];
char ch;
int left = 0;
*/
if (PMf_EXTENDED & re->reganch)
{
- char *endptr = re->precomp + re->prelen;
+ const char *endptr = re->precomp + re->prelen;
while (endptr >= re->precomp)
{
- char c = *(endptr--);
+ const char c = *(endptr--);
if (c == '\n')
break; /* don't need another */
if (c == '#') {
case SVt_PV:
case SVt_PVIV:
case SVt_PVNV:
- case SVt_PVBM: if (SvROK(sv))
- s = "REF";
- else
- s = "SCALAR"; break;
- case SVt_PVLV: s = SvROK(sv) ? "REF"
+ case SVt_PVBM: typestr = SvROK(sv) ? "REF" : "SCALAR"; break;
+ case SVt_PVLV: typestr = SvROK(sv) ? "REF"
/* tied lvalues should appear to be
* scalars for backwards compatitbility */
: (LvTYPE(sv) == 't' || LvTYPE(sv) == 'T')
? "SCALAR" : "LVALUE"; break;
- case SVt_PVAV: s = "ARRAY"; break;
- case SVt_PVHV: s = "HASH"; break;
- case SVt_PVCV: s = "CODE"; break;
- case SVt_PVGV: s = "GLOB"; break;
- case SVt_PVFM: s = "FORMAT"; break;
- case SVt_PVIO: s = "IO"; break;
- default: s = "UNKNOWN"; break;
+ case SVt_PVAV: typestr = "ARRAY"; break;
+ case SVt_PVHV: typestr = "HASH"; break;
+ case SVt_PVCV: typestr = "CODE"; break;
+ case SVt_PVGV: typestr = "GLOB"; break;
+ case SVt_PVFM: typestr = "FORMAT"; break;
+ case SVt_PVIO: typestr = "IO"; break;
+ default: typestr = "UNKNOWN"; break;
}
tsv = NEWSV(0,0);
- if (SvOBJECT(sv))
- if (HvNAME(SvSTASH(sv)))
- Perl_sv_setpvf(aTHX_ tsv, "%s=%s", HvNAME(SvSTASH(sv)), s);
- else
- Perl_sv_setpvf(aTHX_ tsv, "__ANON__=%s", s);
+ if (SvOBJECT(sv)) {
+ const char *name = HvNAME_get(SvSTASH(sv));
+ Perl_sv_setpvf(aTHX_ tsv, "%s=%s(0x%"UVxf")",
+ name ? name : "__ANON__" , typestr, PTR2UV(sv));
+ }
else
- sv_setpv(tsv, s);
- Perl_sv_catpvf(aTHX_ tsv, "(0x%"UVxf")", PTR2UV(sv));
+ Perl_sv_setpvf(aTHX_ tsv, "%s(0x%"UVxf")", typestr, PTR2UV(sv));
goto tokensaveref;
}
- *lp = strlen(s);
- return s;
+ *lp = strlen(typestr);
+ return (char *)typestr;
}
if (SvREADONLY(sv) && !SvOK(sv)) {
if (ckWARN(WARN_UNINITIALIZED))
report_uninit(sv);
*lp = 0;
- return "";
+ return (char *)"";
}
}
if (SvIOK(sv) || ((SvIOKp(sv) && !SvNOKp(sv)))) {
/* I'm assuming that if both IV and NV are equally valid then
converting the IV is going to be more efficient */
- U32 isIOK = SvIOK(sv);
- U32 isUIOK = SvIsUV(sv);
+ const U32 isIOK = SvIOK(sv);
+ const U32 isUIOK = SvIsUV(sv);
char buf[TYPE_CHARS(UV)];
char *ebuf, *ptr;
if (SvTYPE(sv) < SVt_PV)
/* Typically the caller expects that sv_any is not NULL now. */
sv_upgrade(sv, SVt_PV);
- return "";
+ return (char *)"";
}
*lp = s - SvPVX(sv);
SvCUR_set(sv, *lp);
return SvPVX(tsv);
}
else {
+ dVAR;
STRLEN len;
- char *t;
+ const char *t;
if (tsv) {
sv_2mortal(tsv);
*lp = len;
s = SvGROW(sv, len + 1);
SvCUR_set(sv, len);
- (void)strcpy(s, t);
SvPOKp_on(sv);
- return s;
+ return strcpy(s, 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)) {
STRLEN len = 0;
- (void) SvPV_force(sv,len);
+ if (SvREADONLY(sv) && (SvPOKp(sv) || SvIOKp(sv) || SvNOKp(sv))) {
+ (void) sv_2pv_flags(sv,&len, flags);
+ if (SvUTF8(sv))
+ return len;
+ } else {
+ (void) SvPV_force(sv,len);
+ }
}
if (SvUTF8(sv)) {
- SvSETMAGIC(sv);
return SvCUR(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);
}
- SvSETMAGIC(sv);
return SvCUR(sv);
}
Perl_croak(aTHX_ "Wide character");
}
}
- SvCUR(sv) = len;
+ SvCUR_set(sv, len);
}
}
SvUTF8_off(sv);
Loosely speaking, it performs a copy-by-value, obliterating any previous
content of the destination.
If the C<flags> parameter has the C<SV_GMAGIC> bit set, will C<mg_get> on
-C<ssv> if appropriate, else not. C<sv_setsv> and C<sv_setsv_nomg> are
-implemented in terms of this function.
+C<ssv> if appropriate, else not. If the C<flags> parameter has the
+C<NOSTEAL> bit set then the buffers of temps will not be stolen. <sv_setsv>
+and C<sv_setsv_nomg> are implemented in terms of this function.
You probably want to use one of the assortment of wrappers, such as
C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
dtype = SvTYPE(dstr);
SvAMAGIC_off(dstr);
- if ( SvVOK(dstr) )
+ if ( SvVOK(dstr) )
{
/* need to nuke the magic */
mg_free(dstr);
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);
!(isSwipe =
(sflags & SVs_TEMP) && /* slated for free anyway? */
!(sflags & SVf_OOK) && /* and not involved in OOK hack? */
+ (!(flags & SV_NOSTEAL)) &&
+ /* and we're allowed to steal temps */
SvREFCNT(sstr) == 1 && /* and no other references to it? */
SvLEN(sstr) && /* and really is a string */
/* and won't be needed again, potentially */
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);
+ MAGIC *smg = mg_find(sstr,PERL_MAGIC_vstring);
sv_magic(dstr, NULL, PERL_MAGIC_vstring,
smg->mg_ptr, smg->mg_len);
SvRMAGICAL_on(dstr);
- }
+ }
}
else if (sflags & SVp_IOK) {
if (sflags & SVf_IOK)
/* 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';
if (len) { /* this SV was SvIsCOW_normal(sv) */
/* we need to find the SV pointing to us. */
SV *current = SV_COW_NEXT_SV(after);
-
+
if (current == sv) {
/* The SV we point to points back to us (there were only two of us
in the loop.)
{
if (SvIsCOW(sv))
sv_force_normal_flags(sv, 0);
- return SvOOK_off(sv);
+ SvOOK_off(sv);
+ return 0;
}
#endif
/*
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;
+ 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);
}
=for apidoc sv_magicext
Adds magic to an SV, upgrading it if necessary. Applies the
-supplied vtable and returns pointer to the magic added.
+supplied vtable and returns a pointer to the magic added.
-Note that sv_magicext will allow things that sv_magic will not.
-In particular you can add magic to SvREADONLY SVs and and more than
-one instance of the same 'how'
+Note that C<sv_magicext> will allow things that C<sv_magic> will not.
+In particular, you can add magic to SvREADONLY SVs, and add more than
+one instance of the same 'how'.
-I C<namelen> is greater then zero then a savepvn() I<copy> of C<name> is stored,
-if C<namelen> is zero then C<name> is stored as-is and - as another special
-case - if C<(name && namelen == HEf_SVKEY)> then C<name> is assumed to contain
-an C<SV*> and has its REFCNT incremented
+If C<namlen> is greater than zero then a C<savepvn> I<copy> of C<name> is
+stored, if C<namlen> is zero then C<name> is stored as-is and - as another
+special case - if C<(name && namlen == HEf_SVKEY)> then C<name> is assumed
+to contain an C<SV*> and is stored as-is with its REFCNT incremented.
-(This is now used as a subroutine by sv_magic.)
+(This is now used as a subroutine by C<sv_magic>.)
=cut
*/
MAGIC *
-Perl_sv_magicext(pTHX_ SV* sv, SV* obj, int how, MGVTBL *vtable,
+Perl_sv_magicext(pTHX_ SV* sv, SV* obj, int how, const MGVTBL *vtable,
const char* name, I32 namlen)
{
MAGIC* mg;
}
Newz(702,mg, 1, MAGIC);
mg->mg_moremagic = SvMAGIC(sv);
- SvMAGIC(sv) = mg;
+ SvMAGIC_set(sv, mg);
- /* Some magic sontains a reference loop, where the sv and object refer to
- each other. To prevent a reference loop that would prevent such
- objects being freed, we look for such loops and if we find one we
- avoid incrementing the object refcount.
+ /* Sometimes a magic contains a reference loop, where the sv and
+ object refer to each other. To prevent a reference loop that
+ would prevent such objects being freed, we look for such loops
+ and if we find one we avoid incrementing the object refcount.
Note we cannot do this to avoid self-tie loops as intervening RV must
have its REFCNT incremented to keep it in existence.
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 ||
Adds magic to an SV. First upgrades C<sv> to type C<SVt_PVMG> if necessary,
then adds a new magic item of type C<how> to the head of the magic list.
+See C<sv_magicext> (which C<sv_magic> now calls) for a description of the
+handling of the C<name> and C<namlen> arguments.
+
+You need to use C<sv_magicext> to add magic to SvREADONLY SVs and also
+to add more than one instance of the same 'how'.
+
=cut
*/
void
Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
{
+ const MGVTBL *vtable = 0;
MAGIC* mg;
- MGVTBL *vtable = 0;
#ifdef PERL_COPY_ON_WRITE
if (SvIsCOW(sv))
case PERL_MAGIC_vec:
vtable = &PL_vtbl_vec;
break;
+ case PERL_MAGIC_rhash:
+ case PERL_MAGIC_symtab:
case PERL_MAGIC_vstring:
vtable = 0;
break;
}
/* Rest of work is done else where */
- mg = sv_magicext(sv,obj,how,vtable,name,namlen);
+ mg = sv_magicext(sv,obj,how,(MGVTBL*)vtable,name,namlen);
switch (how) {
case PERL_MAGIC_taint:
mgp = &SvMAGIC(sv);
for (mg = *mgp; mg; mg = *mgp) {
if (mg->mg_type == type) {
- MGVTBL* vtbl = mg->mg_virtual;
+ const MGVTBL* const vtbl = mg->mg_virtual;
*mgp = mg->mg_moremagic;
if (vtbl && vtbl->svt_free)
CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
*/
void
-Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen)
+Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, const char *little, STRLEN littlelen)
{
register char *big;
register char *mid;
while (midend > mid) /* shove everything down */
*--bigend = *--midend;
Move(little,big+offset,littlelen,char);
- SvCUR(bigstr) += i;
+ SvCUR_set(bigstr, SvCUR(bigstr) + i);
SvSETMAGIC(bigstr);
return;
}
void
Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
{
- U32 refcnt = SvREFCNT(sv);
+ const U32 refcnt = SvREFCNT(sv);
SV_CHECK_THINKFIRST_COW_DROP(sv);
if (SvREFCNT(nsv) != 1 && ckWARN_d(WARN_INTERNAL))
Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "Reference miscount in sv_replace()");
mg_free(nsv);
else
sv_upgrade(nsv, SVt_PVMG);
- SvMAGIC(nsv) = SvMAGIC(sv);
+ SvMAGIC_set(nsv, SvMAGIC(sv));
SvFLAGS(nsv) |= SvMAGICAL(sv);
SvMAGICAL_off(sv);
- SvMAGIC(sv) = 0;
+ SvMAGIC_set(sv, NULL);
}
SvREFCNT(sv) = 0;
sv_clear(sv);
assert(!SvREFCNT(sv));
+#ifdef DEBUG_LEAKING_SCALARS
+ sv->sv_flags = nsv->sv_flags;
+ sv->sv_any = nsv->sv_any;
+ sv->sv_refcnt = nsv->sv_refcnt;
+#else
StructCopy(nsv,sv,SV);
+#endif
+ /* Currently could join these into one piece of pointer arithmetic, but
+ it would be unclear. */
+ if(SvTYPE(sv) == SVt_IV)
+ SvANY(sv)
+ = (XPVIV*)((char*)&(sv->sv_u.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)) {
/* We need to follow the pointers around the loop to make the
void
Perl_sv_clear(pTHX_ register SV *sv)
{
+ dVAR;
HV* stash;
assert(sv);
assert(SvREFCNT(sv) == 0);
PUSHs(tmpref);
PUTBACK;
call_sv((SV*)destructor, G_DISCARD|G_EVAL|G_KEEPERR|G_VOID);
-
-
+
+
POPSTACK;
SPAGAIN;
LEAVE;
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:
- (void)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))
* The length is cached in PERL_UTF8_magic, in the mg_len field. Also the
* mg_ptr is used, by sv_pos_u2b(), see the comments of S_utf8_mg_pos_init().
* (Note that the mg_len is not the length of the mg_ptr field.)
- *
+ *
*/
STRLEN
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;
+ 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;
}
*cachep = (STRLEN *) (*mgp)->mg_ptr;
ASSERT_UTF8_CACHE(*cachep);
if ((*cachep)[i] == (STRLEN)uoff) /* An exact match. */
- found = TRUE;
+ 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];
(*cachep)[2] = 0;
(*cachep)[3] = 0;
}
-
+
found = TRUE;
}
}
return found;
}
-
+
/*
=for apidoc sv_pos_u2b
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;
}
/* We already know part of the way. */
len = cache[0];
s += cache[1];
- /* Let the below loop do the rest. */
+ /* Let the below loop do the rest. */
}
else { /* cache[1] > *offsetp */
/* We already know all of the way, now we may
if (!(forw < 2 * backw)) {
U8 *p = s + cache[1];
STRLEN ubackw = 0;
-
+
cache[1] -= backw;
while (backw--) {
I32
Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2)
{
- char *pv1;
+ const char *pv1;
STRLEN cur1;
- char *pv2;
+ const char *pv2;
STRLEN cur2;
I32 eq = 0;
char *tpv = Nullch;
pv1 = SvPV(svrecode, cur1);
}
/* Now both are in UTF-8. */
- if (cur1 != cur2)
+ if (cur1 != cur2) {
+ SvREFCNT_dec(svrecode);
return FALSE;
+ }
}
else {
bool is_utf8 = TRUE;
if (SvUTF8(sv1)) {
/* sv1 is the UTF-8 one,
* if is equal it must be downgrade-able */
- char *pv = (char*)bytes_from_utf8((U8*)pv1,
+ char *pv = (char*)bytes_from_utf8((const U8*)pv1,
&cur1, &is_utf8);
if (pv != pv1)
pv1 = tpv = pv;
else {
/* sv2 is the UTF-8 one,
* if is equal it must be downgrade-able */
- char *pv = (char *)bytes_from_utf8((U8*)pv2,
+ char *pv = (char *)bytes_from_utf8((const U8*)pv2,
&cur2, &is_utf8);
if (pv != pv2)
pv2 = tpv = pv;
}
if (is_utf8) {
/* Downgrade not possible - cannot be eq */
+ assert (tpv == 0);
return FALSE;
}
}
Perl_sv_cmp(pTHX_ register SV *sv1, register SV *sv2)
{
STRLEN cur1, cur2;
- char *pv1, *pv2, *tpv = Nullch;
+ const char *pv1, *pv2;
+ char *tpv = Nullch;
I32 cmp;
SV *svrecode = Nullsv;
pv2 = SvPV(svrecode, cur2);
}
else {
- pv2 = tpv = (char*)bytes_to_utf8((U8*)pv2, &cur2);
+ pv2 = tpv = (char*)bytes_to_utf8((const U8*)pv2, &cur2);
}
}
else {
pv1 = SvPV(svrecode, cur1);
}
else {
- pv1 = tpv = (char*)bytes_to_utf8((U8*)pv1, &cur1);
+ pv1 = tpv = (char*)bytes_to_utf8((const U8*)pv1, &cur1);
}
}
}
} else if (!cur2) {
cmp = 1;
} else {
- I32 retval = memcmp((void*)pv1, (void*)pv2, cur1 < cur2 ? cur1 : cur2);
+ const I32 retval = memcmp((const void*)pv1, (const void*)pv2, cur1 < cur2 ? cur1 : cur2);
if (retval) {
cmp = retval < 0 ? -1 : 1;
char *
Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
{
- char *rsptr;
+ const char *rsptr;
STRLEN rslen;
register STDCHAR rslast;
register STDCHAR *bp;
rslen = 1;
}
else if (RsSNARF(PL_rs)) {
- /* If it is a regular disk file use size from stat() as estimate
- of amount we are going to read - may result in malloc-ing
- more memory than we realy need if layers bellow reduce
+ /* If it is a regular disk file use size from stat() as estimate
+ of amount we are going to read - may result in malloc-ing
+ more memory than we realy need if layers bellow reduce
size we read (e.g. CRLF or a gzip layer)
*/
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));
}
cnt = PerlIO_get_cnt(fp); /* get count into register */
/* make sure we have the room */
- if ((I32)(SvLEN(sv) - append) <= cnt + 1) {
+ if ((I32)(SvLEN(sv) - append) <= cnt + 1) {
/* Not room for all of it
- if we are looking for a separator and room for some
+ if we are looking for a separator and room for some
*/
if (rslen && cnt > 80 && (I32)SvLEN(sv) > append) {
- /* just process what we have room for */
+ /* just process what we have room for */
shortbuffered = cnt - SvLEN(sv) + append + 1;
cnt -= shortbuffered;
}
SvGROW(sv, (STRLEN)(append + (cnt <= 0 ? 2 : (cnt + 1))));
}
}
- else
+ else
shortbuffered = 0;
bp = (STDCHAR*)SvPVX(sv) + append; /* move these two too to registers */
ptr = (STDCHAR*)PerlIO_get_ptr(fp);
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
Marks an existing SV as mortal. The SV will be destroyed "soon", either
by an explicit call to FREETMPS, or by an implicit call at places such as
-statement boundaries. See also C<sv_newmortal> and C<sv_mortalcopy>.
+statement boundaries. SvTEMP() is turned on which means that the SV's
+string buffer can be "stolen" if this SV is copied. See also C<sv_newmortal>
+and C<sv_mortalcopy>.
=cut
*/
SV *
Perl_sv_2mortal(pTHX_ register SV *sv)
{
+ dVAR;
if (!sv)
return sv;
if (SvREADONLY(sv) && SvIMMORTAL(sv))
STRLEN tmplen = -len;
is_utf8 = TRUE;
/* See the note in hv.c:hv_fetch() --jhi */
- src = (char*)bytes_from_utf8((U8*)src, &tmplen, &is_utf8);
+ src = (char*)bytes_from_utf8((const U8*)src, &tmplen, &is_utf8);
len = tmplen;
}
if (!hash)
PERL_HASH(hash, src, len);
new_SV(sv);
sv_upgrade(sv, SVt_PVIV);
- SvPVX(sv) = sharepvn(src, is_utf8?-len:len, hash);
- SvCUR(sv) = len;
- SvUVX(sv) = hash;
- SvLEN(sv) = 0;
+ SvPV_set(sv, sharepvn(src, is_utf8?-len:len, hash));
+ SvCUR_set(sv, len);
+ SvUV_set(sv, hash);
+ SvLEN_set(sv, 0);
SvREADONLY_on(sv);
SvFAKE_on(sv);
SvPOK_on(sv);
new_SV(sv);
sv_upgrade(sv, SVt_RV);
SvTEMP_off(tmpRef);
- SvRV(sv) = tmpRef;
+ SvRV_set(sv, tmpRef);
SvROK_on(sv);
return sv;
}
return Nullsv;
}
new_SV(sv);
- if (SvTEMP(old)) {
- SvTEMP_off(old);
- sv_setsv(sv,old);
- SvTEMP_on(old);
- }
- else
- sv_setsv(sv,old);
+ /* SV_GMAGIC is the default for sv_setv()
+ SV_NOSTEAL prevents TEMP buffers being, well, stolen, and saves games
+ with SvTEMP_off and SvTEMP_on round a call to sv_setsv. */
+ sv_setsv_flags(sv, old, SV_GMAGIC | SV_NOSTEAL);
return sv;
}
*/
void
-Perl_sv_reset(pTHX_ register char *s, HV *stash)
+Perl_sv_reset(pTHX_ register const char *s, HV *stash)
{
+ dVAR;
register HE *entry;
register GV *gv;
register SV *sv;
register I32 i;
- register PMOP *pm;
register I32 max;
char todo[PERL_UCHAR_MAX+1];
return;
if (!*s) { /* reset ?? searches */
- for (pm = HvPMROOT(stash); pm; pm = pm->op_pmnext) {
- pm->op_pmdynflags &= ~PMdf_USED;
+ MAGIC *mg = mg_find((SV *)stash, PERL_MAGIC_symtab);
+ if (mg) {
+ PMOP *pm = (PMOP *) mg->mg_obj;
+ while (pm) {
+ pm->op_pmdynflags &= ~PMdf_USED;
+ pm = pm->op_pmnext;
+ }
}
return;
}
sv_unref(sv);
continue;
}
- (void)SvOK_off(sv);
+ SvOK_off(sv);
if (SvTYPE(sv) >= SVt_PV) {
SvCUR_set(sv, 0);
if (SvPVX(sv) != Nullch)
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
{
IO* io;
GV* gv;
- STRLEN n_a;
switch (SvTYPE(sv)) {
case SVt_PVIO:
Perl_croak(aTHX_ PL_no_usym, "filehandle");
if (SvROK(sv))
return sv_2io(SvRV(sv));
- gv = gv_fetchpv(SvPV(sv,n_a), FALSE, SVt_PVIO);
+ gv = gv_fetchsv(sv, FALSE, SVt_PVIO);
if (gv)
io = GvIO(gv);
else
CV *
Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
{
+ dVAR;
GV *gv = Nullgv;
CV *cv = Nullcv;
- STRLEN n_a;
if (!sv)
return *gvp = Nullgv, Nullcv;
else if (isGV(sv))
gv = (GV*)sv;
else
- gv = gv_fetchpv(SvPV(sv, n_a), lref, SVt_PVCV);
+ gv = gv_fetchsv(sv, lref, SVt_PVCV);
*gvp = gv;
if (!gv)
return Nullcv;
if (!sv)
return 0;
if (SvPOK(sv)) {
- register XPV* tXpv;
+ const register XPV* tXpv;
if ((tXpv = (XPV*)SvANY(sv)) &&
(tXpv->xpv_cur > 1 ||
- (tXpv->xpv_cur && *tXpv->xpv_pv != '0')))
+ (tXpv->xpv_cur && *sv->sv_u.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);
*/
char *
-Perl_sv_reftype(pTHX_ SV *sv, int ob)
+Perl_sv_reftype(pTHX_ const SV *sv, int ob)
{
+ /* The fact that I don't need to downcast to char * everywhere, only in ?:
+ inside return suggests a const propagation bug in g++. */
if (ob && SvOBJECT(sv)) {
- if (HvNAME(SvSTASH(sv)))
- return HvNAME(SvSTASH(sv));
- else
- return "__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) {
- (void)SvOOK_off(rv);
- if (SvPVX(rv) && SvLEN(rv))
- Safefree(SvPVX(rv));
+ SvPV_free(rv);
SvCUR_set(rv, 0);
SvLEN_set(rv, 0);
}
- (void)SvOK_off(rv);
- SvRV(rv) = sv;
+ SvOK_off(rv);
+ SvRV_set(rv, sv);
SvROK_on(rv);
if (classname) {
string must be specified with C<n>. The C<rv> argument will be upgraded to
an RV. That RV will be modified to point to the new SV. The C<classname>
argument indicates the package for the blessing. Set C<classname> to
-C<Nullch> to avoid the blessing. The new SV will have a reference count
+C<Nullch> to avoid the blessing. The new SV will have a reference count
of 1, and the RV will be returned.
Note that C<sv_setref_pv> copies the pointer while this copies the string.
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. */
/*
=for apidoc sv_setpvf
-Processes its arguments like C<sprintf> and sets an SV to the formatted
-output. Does not handle 'set' magic. See C<sv_setpvf_mg>.
+Works like C<sv_catpvf> but copies the text into the SV instead of
+appending it. Does not handle 'set' magic. See C<sv_setpvf_mg>.
=cut
*/
va_end(args);
}
-/* backend for C<sv_setpvf> and C<sv_setpvf_nocontext> */
+/*
+=for apidoc sv_vsetpvf
+
+Works like C<sv_vcatpvf> but copies the text into the SV instead of
+appending it. Does not handle 'set' magic. See C<sv_vsetpvf_mg>.
+
+Usually used via its frontend C<sv_setpvf>.
+
+=cut
+*/
void
Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args)
va_end(args);
}
-/* backend for C<sv_setpvf_mg> C<setpvf_mg_nocontext> */
+/*
+=for apidoc sv_vsetpvf_mg
+
+Like C<sv_vsetpvf>, but also handles 'set' magic.
+
+Usually used via its frontend C<sv_setpvf_mg>.
+
+=cut
+*/
void
Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
output to an SV. If the appended data contains "wide" characters
(including, but not limited to, SVs with a UTF-8 PV formatted with %s,
and characters >255 formatted with %c), the original SV might get
-upgraded to UTF-8. Handles 'get' magic, but not 'set' magic.
-C<SvSETMAGIC()> must typically be called after calling this function
-to handle 'set' magic.
+upgraded to UTF-8. Handles 'get' magic, but not 'set' magic. See
+C<sv_catpvf_mg>. If the original SV was UTF-8, the pattern should be
+valid UTF-8; if the original SV was bytes, the pattern should be too.
=cut */
va_end(args);
}
-/* backend for C<sv_catpvf> and C<catpvf_mg_nocontext> */
+/*
+=for apidoc sv_vcatpvf
+
+Processes its arguments like C<vsprintf> and appends the formatted output
+to an SV. Does not handle 'set' magic. See C<sv_vcatpvf_mg>.
+
+Usually used via its frontend C<sv_catpvf>.
+
+=cut
+*/
void
Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args)
va_end(args);
}
-/* backend for C<catpvf_mg> and C<catpvf_mg_nocontext> */
+/*
+=for apidoc sv_vcatpvf_mg
+
+Like C<sv_vcatpvf>, but also handles 'set' magic.
+
+Usually used via its frontend C<sv_catpvf_mg>.
+
+=cut
+*/
void
Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
/*
=for apidoc sv_vsetpvfn
-Works like C<vcatpvfn> but copies the text into the SV instead of
+Works like C<sv_vcatpvfn> but copies the text into the SV instead of
appending it.
-Usually used via one of its frontends C<sv_setpvf> and C<sv_setpvf_mg>.
+Usually used via one of its frontends C<sv_vsetpvf> and C<sv_vsetpvf_mg>.
=cut
*/
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)
C<maybe_tainted> if results are untrustworthy (often due to the use of
locales).
-Usually used via one of its frontends C<sv_catpvf> and C<sv_catpvf_mg>.
+Usually used via one of its frontends C<sv_vcatpvf> and C<sv_vcatpvf_mg>.
=cut
*/
+/* XXX maybe_tainted is never assigned to, so the doc above is lying. */
+
void
Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
{
char *p;
char *q;
- char *patend;
+ const char *patend;
STRLEN origlen;
I32 svix = 0;
- static char nullstr[] = "(null)";
+ static const char nullstr[] = "(null)";
SV *argsv = Nullsv;
bool has_utf8; /* has the result utf8? */
bool pat_utf8; /* the pattern is in utf8? */
/* no matter what, this is a string now */
(void)SvPV_force(sv, origlen);
- /* special-case "", "%s", and "%_" */
+ /* special-case "", "%s", and "%-p" (SVf) */
if (patlen == 0)
return;
- if (patlen == 2 && pat[0] == '%') {
- switch (pat[1]) {
- case 's':
+ if (patlen == 2 && pat[0] == '%' && pat[1] == 's') {
if (args) {
- char *s = va_arg(*args, char*);
+ const char *s = va_arg(*args, char*);
sv_catpv(sv, s ? s : nullstr);
}
else if (svix < svmax) {
SvUTF8_on(sv);
}
return;
- case '_':
+ }
+ if (patlen == 3 && pat[0] == '%' &&
+ pat[1] == '-' && pat[2] == 'p') {
if (args) {
argsv = va_arg(*args, SV*);
sv_catsv(sv, argsv);
SvUTF8_on(sv);
return;
}
- /* See comment on '_' below */
- break;
- }
}
#ifndef USE_LONG_DOUBLE
#endif
char esignbuf[4];
- U8 utf8buf[UTF8_MAXLEN+1];
+ U8 utf8buf[UTF8_MAXBYTES+1];
STRLEN esignlen = 0;
char *eptr = Nullch;
STRLEN have;
STRLEN need;
STRLEN gap;
- char *dotstr = ".";
+ const char *dotstr = ".";
STRLEN dotstrlen = 1;
I32 efix = 0; /* explicit format parameter index */
I32 ewix = 0; /* explicit width index */
}
if (!asterisk)
- if( *q == '0' )
+ if( *q == '0' )
fill = *q++;
EXPECT_NUMBER(q, width);
vecsv = svargs[efix ? efix-1 : svix++];
vecstr = (U8*)SvPVx(vecsv,veclen);
vec_utf8 = DO_UTF8(vecsv);
+ /* if this is a version object, we need to return the
+ * stringified representation (which the SvPVX has
+ * already done for us), but not vectorize the args
+ */
+ if ( *q == 'd' && sv_derived_from(vecsv,"version") )
+ {
+ q++; /* skip past the rest of the %vd format */
+ eptr = (char *) vecstr;
+ elen = strlen(eptr);
+ vectorize=FALSE;
+ goto string;
+ }
}
else {
vecstr = (U8*)"";
#endif
elen = strlen(eptr);
else {
- eptr = nullstr;
+ eptr = (char *)nullstr;
elen = sizeof nullstr - 1;
}
}
is_utf8 = TRUE;
}
}
- goto string;
-
- case '_':
- /*
- * 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':
+ if (left && args) { /* SVf */
+ left = FALSE;
+ 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;
+ }
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" */
}
p = SvEND(sv);
*p = '\0';
}
- /* Use memchr() instead of strchr(), as eptr is not guaranteed */
- /* to point to a null-terminated string. */
- if (left && ckWARN(WARN_PRINTF) && memchr(eptr, '\n', elen) &&
- (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF))
- Perl_warner(aTHX_ packWARN(WARN_PRINTF),
- "Newline in left-justified string for %sprintf",
- (PL_op->op_type == OP_PRTF) ? "" : "s");
-
+
need = (have > width ? have : width);
gap = need - have;
if (has_utf8)
SvUTF8_on(sv);
*p = '\0';
- SvCUR(sv) = p - SvPVX(sv);
+ SvCUR_set(sv, p - SvPVX(sv));
if (vectorize) {
esignlen = 0;
goto vector;
REGEXP *
Perl_re_dup(pTHX_ REGEXP *r, CLONE_PARAMS *param)
{
+ dVAR;
REGEXP *ret;
int i, len, npar;
struct reg_substr_datum *s;
ret->regstclass = NULL;
if (r->data) {
struct reg_data *d;
- int count = r->data->count;
+ const int count = r->data->count;
Newc(0, d, sizeof(struct reg_data) + count*sizeof(void *),
char, struct reg_data);
for (i = 0; i < count; i++) {
d->what[i] = r->data->what[i];
switch (d->what[i]) {
+ /* legal options are one of: sfpont
+ see also regcomp.h and pregfree() */
case 's':
d->data[i] = sv_dup_inc((SV *)r->data->data[i], param);
break;
case 'o':
/* Compiled op trees are readonly, and can thus be
shared without duplication. */
+ OP_REFCNT_LOCK;
d->data[i] = (void*)OpREFCNT_inc((OP*)r->data->data[i]);
+ OP_REFCNT_UNLOCK;
break;
case 'n':
d->data[i] = r->data->data[i];
break;
+ case 't':
+ d->data[i] = r->data->data[i];
+ OP_REFCNT_LOCK;
+ ((reg_trie_data*)d->data[i])->refcount++;
+ OP_REFCNT_UNLOCK;
+ break;
+ default:
+ Perl_croak(aTHX_ "panic: re_dup unknown data code '%c'", r->data->what[i]);
}
}
Perl_fp_dup(pTHX_ PerlIO *fp, char type, CLONE_PARAMS *param)
{
PerlIO *ret;
+ (void)type;
+
if (!fp)
return (PerlIO*)NULL;
nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj, param);
}
else if(mg->mg_type == PERL_MAGIC_backref) {
- AV *av = (AV*) mg->mg_obj;
+ const AV * const av = (AV*) mg->mg_obj;
SV **svp;
I32 i;
- SvREFCNT_inc(nmg->mg_obj = (SV*)newAV());
+ (void)SvREFCNT_inc(nmg->mg_obj = (SV*)newAV());
svp = AvARRAY(av);
for (i = AvFILLp(av); i >= 0; i--) {
if (!svp[i]) continue;
av_push((AV*)nmg->mg_obj,sv_dup(svp[i],param));
}
}
+ else if (mg->mg_type == PERL_MAGIC_symtab) {
+ nmg->mg_obj = mg->mg_obj;
+ }
else {
nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED)
? sv_dup_inc(mg->mg_obj, param)
# define PTR_TABLE_HASH(ptr) (PTR2UV(ptr) >> 2)
#endif
+
+
+STATIC void
+S_more_pte(pTHX)
+{
+ struct ptr_tbl_ent* pte;
+ struct ptr_tbl_ent* pteend;
+ New(0, pte, PERL_ARENA_SIZE/sizeof(struct ptr_tbl_ent), struct ptr_tbl_ent);
+ pte->next = PL_pte_arenaroot;
+ PL_pte_arenaroot = pte;
+
+ pteend = &pte[PERL_ARENA_SIZE / sizeof(struct ptr_tbl_ent) - 1];
+ PL_pte_root = ++pte;
+ while (pte < pteend) {
+ pte->next = pte + 1;
+ pte++;
+ }
+ pte->next = 0;
+}
+
+STATIC struct ptr_tbl_ent*
+S_new_pte(pTHX)
+{
+ struct ptr_tbl_ent* pte;
+ if (!PL_pte_root)
+ S_more_pte(aTHX);
+ pte = PL_pte_root;
+ PL_pte_root = pte->next;
+ return pte;
+}
+
+STATIC void
+S_del_pte(pTHX_ struct ptr_tbl_ent*p)
+{
+ p->next = PL_pte_root;
+ PL_pte_root = p;
+}
+
/* map an existing pointer using a table */
void *
Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, void *sv)
{
PTR_TBL_ENT_t *tblent;
- UV hash = PTR_TABLE_HASH(sv);
+ const UV hash = PTR_TABLE_HASH(sv);
assert(tbl);
tblent = tbl->tbl_ary[hash & tbl->tbl_max];
for (; tblent; tblent = tblent->next) {
/* XXX this may be pessimal on platforms where pointers aren't good
* hash values e.g. if they grow faster in the most significant
* bits */
- UV hash = PTR_TABLE_HASH(oldv);
+ const UV hash = PTR_TABLE_HASH(oldv);
bool empty = 1;
assert(tbl);
return;
}
}
- Newz(0, tblent, 1, PTR_TBL_ENT_t);
+ tblent = S_new_pte(aTHX);
tblent->oldval = oldv;
tblent->newval = newv;
tblent->next = *otblent;
Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl)
{
PTR_TBL_ENT_t **ary = tbl->tbl_ary;
- UV oldsize = tbl->tbl_max + 1;
+ const UV oldsize = tbl->tbl_max + 1;
UV newsize = oldsize * 2;
UV i;
{
register PTR_TBL_ENT_t **array;
register PTR_TBL_ENT_t *entry;
- register PTR_TBL_ENT_t *oentry = Null(PTR_TBL_ENT_t*);
UV riter = 0;
UV max;
for (;;) {
if (entry) {
- oentry = entry;
+ PTR_TBL_ENT_t *oentry = entry;
entry = entry->next;
- Safefree(oentry);
+ S_del_pte(aTHX_ oentry);
}
if (!entry) {
if (++riter > max) {
Safefree(tbl);
}
-#ifdef DEBUGGING
-char *PL_watch_pvx;
-#endif
-
/* attempt to make everything in the typeglob readonly */
STATIC SV *
if (!GvUNIQUE(gv)) {
#if 0
PerlIO_printf(Perl_debug_log, "gv_share: unable to share %s::%s\n",
- HvNAME(GvSTASH(gv)), GvNAME(gv));
+ HvNAME_get(GvSTASH(gv)), GvNAME(gv));
#endif
return Nullsv;
}
Perl_rvpv_dup(pTHX_ SV *dstr, SV *sstr, CLONE_PARAMS* param)
{
if (SvROK(sstr)) {
- SvRV(dstr) = SvWEAKREF(sstr)
- ? sv_dup(SvRV(sstr), param)
- : sv_dup_inc(SvRV(sstr), param);
+ SvRV_set(dstr, SvWEAKREF(sstr)
+ ? sv_dup(SvRV(sstr), param)
+ : sv_dup_inc(SvRV(sstr), param));
+
}
else if (SvPVX(sstr)) {
/* Has something there */
if (SvLEN(sstr)) {
/* Normal PV - clone whole allocated space */
- SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
+ SvPV_set(dstr, SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1));
if (SvREADONLY(sstr) && SvFAKE(sstr)) {
/* Not that normal - actually sstr is copy on write.
But we are a true, independant SV, so: */
and they should not have these flags
turned off */
- SvPVX(dstr) = sharepvn(SvPVX(sstr), SvCUR(sstr),
- SvUVX(sstr));
- SvUVX(dstr) = SvUVX(sstr);
+ SvPV_set(dstr, sharepvn(SvPVX(sstr), SvCUR(sstr),
+ SvUVX(sstr)));
+ SvUV_set(dstr, SvUVX(sstr));
} else {
- SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvCUR(sstr));
+ SvPV_set(dstr, SAVEPVN(SvPVX(sstr), SvCUR(sstr)));
SvFAKE_off(dstr);
SvREADONLY_off(dstr);
}
}
else {
/* Some other special case - random pointer */
- SvPVX(dstr) = SvPVX(sstr);
+ SvPV_set(dstr, SvPVX(sstr));
}
}
}
else {
/* Copy the Null */
- SvPVX(dstr) = SvPVX(sstr);
+ if (SvTYPE(dstr) == SVt_RV)
+ SvRV_set(dstr, NULL);
+ else
+ SvPV_set(dstr, 0);
}
}
SV *
Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param)
{
+ dVAR;
SV *dstr;
if (!sstr || SvTYPE(sstr) == SVTYPEMASK)
if(param->flags & CLONEf_JOIN_IN) {
/** We are joining here so we don't want do clone
something that is bad **/
+ const char *hvname;
if(SvTYPE(sstr) == SVt_PVHV &&
- HvNAME(sstr)) {
+ (hvname = HvNAME_get(sstr))) {
/** don't clone stashes if they already exist **/
- HV* old_stash = gv_stashpv(HvNAME(sstr),0);
+ HV* old_stash = gv_stashpv(hvname,0);
return (SV*) old_stash;
}
}
/* create anew and remember what it is */
new_SV(dstr);
+
+#ifdef DEBUG_LEAKING_SCALARS
+ dstr->sv_debug_optype = sstr->sv_debug_optype;
+ dstr->sv_debug_line = sstr->sv_debug_line;
+ dstr->sv_debug_inpad = sstr->sv_debug_inpad;
+ dstr->sv_debug_cloned = 1;
+# ifdef NETWARE
+ dstr->sv_debug_file = savepv(sstr->sv_debug_file);
+# else
+ dstr->sv_debug_file = savesharedpv(sstr->sv_debug_file);
+# endif
+#endif
+
ptr_table_store(PL_ptr_table, sstr, dstr);
/* clone */
PL_watch_pvx, SvPVX(sstr));
#endif
+ /* don't clone objects whose class has asked us not to */
+ if (SvOBJECT(sstr) && ! (SvFLAGS(SvSTASH(sstr)) & SVphv_CLONEABLE)) {
+ SvFLAGS(dstr) &= ~SVTYPEMASK;
+ SvOBJECT_off(dstr);
+ return dstr;
+ }
+
switch (SvTYPE(sstr)) {
case SVt_NULL:
SvANY(dstr) = NULL;
break;
case SVt_IV:
- SvANY(dstr) = new_XIV();
- SvIVX(dstr) = SvIVX(sstr);
+ SvANY(dstr) = (XPVIV*)((char*)&(dstr->sv_u.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))
IoPAGE(dstr) = IoPAGE(sstr);
IoPAGE_LEN(dstr) = IoPAGE_LEN(sstr);
IoLINES_LEFT(dstr) = IoLINES_LEFT(sstr);
- if(IoFLAGS(sstr) & IOf_FAKE_DIRP) {
+ if(IoFLAGS(sstr) & IOf_FAKE_DIRP) {
/* I have no idea why fake dirp (rsfps)
should be treaded differently but otherwise
we end up with leaks -- sky*/
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);
+ OP_REFCNT_LOCK;
CvROOT(dstr) = OpREFCNT_inc(CvROOT(sstr));
+ OP_REFCNT_UNLOCK;
CvXSUB(dstr) = CvXSUB(sstr);
CvXSUBANY(dstr) = CvXSUBANY(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 */
else {
ncx->blk_oldsp = cx->blk_oldsp;
ncx->blk_oldcop = cx->blk_oldcop;
- ncx->blk_oldretsp = cx->blk_oldretsp;
ncx->blk_oldmarksp = cx->blk_oldmarksp;
ncx->blk_oldscopesp = cx->blk_oldscopesp;
ncx->blk_oldpm = cx->blk_oldpm;
ncx->blk_sub.olddepth = cx->blk_sub.olddepth;
ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
ncx->blk_sub.lval = cx->blk_sub.lval;
+ ncx->blk_sub.retop = cx->blk_sub.retop;
break;
case CXt_EVAL:
ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval;
ncx->blk_eval.old_namesv = sv_dup_inc(cx->blk_eval.old_namesv, param);
ncx->blk_eval.old_eval_root = cx->blk_eval.old_eval_root;
ncx->blk_eval.cur_text = sv_dup(cx->blk_eval.cur_text, param);
+ ncx->blk_eval.retop = cx->blk_eval.retop;
break;
case CXt_LOOP:
ncx->blk_loop.label = cx->blk_loop.label;
ncx->blk_sub.gv = gv_dup(cx->blk_sub.gv, param);
ncx->blk_sub.dfoutgv = gv_dup_inc(cx->blk_sub.dfoutgv, param);
ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
+ ncx->blk_sub.retop = cx->blk_sub.retop;
break;
case CXt_BLOCK:
case CXt_NULL:
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
perl_clone takes these flags as parameters:
-CLONEf_COPY_STACKS - is used to, well, copy the stacks also,
-without it we only clone the data and zero the stacks,
-with it we copy the stacks and the new perl interpreter is
-ready to run at the exact same point as the previous one.
-The pseudo-fork code uses COPY_STACKS while the
+CLONEf_COPY_STACKS - is used to, well, copy the stacks also,
+without it we only clone the data and zero the stacks,
+with it we copy the stacks and the new perl interpreter is
+ready to run at the exact same point as the previous one.
+The pseudo-fork code uses COPY_STACKS while the
threads->new doesn't.
CLONEf_KEEP_PTR_TABLE
-perl_clone keeps a ptr_table with the pointer of the old
-variable as a key and the new variable as a value,
-this allows it to check if something has been cloned and not
-clone it again but rather just use the value and increase the
-refcount. If KEEP_PTR_TABLE is not set then perl_clone will kill
-the ptr_table using the function
-C<ptr_table_free(PL_ptr_table); PL_ptr_table = NULL;>,
-reason to keep it around is if you want to dup some of your own
-variable who are outside the graph perl scans, example of this
+perl_clone keeps a ptr_table with the pointer of the old
+variable as a key and the new variable as a value,
+this allows it to check if something has been cloned and not
+clone it again but rather just use the value and increase the
+refcount. If KEEP_PTR_TABLE is not set then perl_clone will kill
+the ptr_table using the function
+C<ptr_table_free(PL_ptr_table); PL_ptr_table = NULL;>,
+reason to keep it around is if you want to dup some of your own
+variable who are outside the graph perl scans, example of this
code is in threads.xs create
CLONEf_CLONE_HOST
-This is a win32 thing, it is ignored on unix, it tells perls
-win32host code (which is c++) to clone itself, this is needed on
-win32 if you want to run two threads at the same time,
-if you just want to do some stuff in a separate perl interpreter
-and then throw it away and return to the original one,
+This is a win32 thing, it is ignored on unix, it tells perls
+win32host code (which is c++) to clone itself, this is needed on
+win32 if you want to run two threads at the same time,
+if you just want to do some stuff in a separate perl interpreter
+and then throw it away and return to the original one,
you don't need to do anything.
=cut
PerlInterpreter *
perl_clone(PerlInterpreter *proto_perl, UV flags)
{
+ dVAR;
#ifdef PERL_IMPLICIT_SYS
/* perlhost.h so we need to call into it
CLONE_PARAMS* param = &clone_params;
PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
+ /* for each stash, determine whether its objects should be cloned */
+ S_visit(proto_perl, do_mark_cloneable_stash, SVt_PVHV, SVTYPEMASK);
PERL_SET_THX(my_perl);
# ifdef DEBUGGING
Poison(my_perl, 1, PerlInterpreter);
+ PL_op = Nullop;
+ PL_curcop = (COP *)Nullop;
PL_markstack = 0;
PL_scopestack = 0;
PL_savestack = 0;
PL_savestack_ix = 0;
PL_savestack_max = -1;
- PL_retstack = 0;
PL_sig_pending = 0;
Zero(&PL_debug_pad, 1, struct perl_debug_pad);
# else /* !DEBUGGING */
CLONE_PARAMS clone_params;
CLONE_PARAMS* param = &clone_params;
PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
+ /* for each stash, determine whether its objects should be cloned */
+ S_visit(proto_perl, do_mark_cloneable_stash, SVt_PVHV, SVTYPEMASK);
PERL_SET_THX(my_perl);
-
-
# ifdef DEBUGGING
Poison(my_perl, 1, PerlInterpreter);
+ PL_op = Nullop;
+ PL_curcop = (COP *)Nullop;
PL_markstack = 0;
PL_scopestack = 0;
PL_savestack = 0;
PL_savestack_ix = 0;
PL_savestack_max = -1;
- PL_retstack = 0;
PL_sig_pending = 0;
Zero(&PL_debug_pad, 1, struct perl_debug_pad);
# else /* !DEBUGGING */
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;
SvANY(&PL_sv_no) = new_XPVNV();
SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
- SvFLAGS(&PL_sv_no) = 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;
- SvNVX(&PL_sv_no) = 0;
+ SvFLAGS(&PL_sv_no) = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
+ |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
+ 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_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;
- SvNVX(&PL_sv_yes) = 1;
+ SvFLAGS(&PL_sv_yes) = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
+ |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
+ 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));
Newz(54, PL_scopestack, PL_scopestack_max, I32);
Copy(proto_perl->Tscopestack, PL_scopestack, PL_scopestack_ix, I32);
- /* next push_return() sets PL_retstack[PL_retstack_ix]
- * NOTE: unlike the others! */
- PL_retstack_ix = proto_perl->Tretstack_ix;
- PL_retstack_max = proto_perl->Tretstack_max;
- Newz(54, PL_retstack, PL_retstack_max, OP*);
- Copy(proto_perl->Tretstack, PL_retstack, PL_retstack_ix, OP*);
-
/* NOTE: si_dup() looks at PL_markstack */
PL_curstackinfo = si_dup(proto_perl->Tcurstackinfo, param);
PL_dirty = proto_perl->Tdirty;
PL_localizing = proto_perl->Tlocalizing;
-#ifdef PERL_FLEXIBLE_EXCEPTIONS
- PL_protect = proto_perl->Tprotect;
-#endif
PL_errors = sv_dup_inc(proto_perl->Terrors, param);
PL_hv_fetch_ent_mh = Nullhe;
PL_modcount = proto_perl->Tmodcount;
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;
EXTEND(SP, 3);
XPUSHs(encoding);
XPUSHs(sv);
-/*
+/*
NI-S 2002/07/09
Passing sv_yes is wrong - it needs to be or'ed set of constants
- for Encode::XS, while UTf-8 decode (currently) assumes a true value means
+ for Encode::XS, while UTf-8 decode (currently) assumes a true value means
remove converted chars from source.
Both will default the value - let them.
-
+
XPUSHs(&PL_sv_yes);
*/
PUTBACK;
FREETMPS;
LEAVE;
SvUTF8_on(sv);
+ return SvPVX(sv);
}
- return SvPVX(sv);
+ return SvPOKp(sv) ? SvPVX(sv) : NULL;
}
/*
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;
return ret;
}
+/*
+ * Local variables:
+ * c-indentation-style: bsd
+ * c-basic-offset: 4
+ * indent-tabs-mode: t
+ * End:
+ *
+ * ex: set ts=8 sts=4 sw=4 noet:
+ */