*/
void
-Perl_offer_nice_chunk(pTHX_ void *chunk, U32 chunk_size)
+Perl_offer_nice_chunk(pTHX_ void *const chunk, const U32 chunk_size)
{
dVAR;
void *new_chunk;
U32 new_chunk_size;
+
+ PERL_ARGS_ASSERT_OFFER_NICE_CHUNK;
+
new_chunk = (void *)(chunk);
new_chunk_size = (chunk_size);
if (new_chunk_size > PL_nice_chunk_size) {
# define POSION_SV_HEAD(sv)
#endif
+/* Mark an SV head as unused, and add to free list.
+ *
+ * If SVf_BREAK is set, skip adding it to the free list, as this SV had
+ * its refcount artificially decremented during global destruction, so
+ * there may be dangling pointers to it. The last thing we want in that
+ * case is for it to be reused. */
+
#define plant_SV(p) \
STMT_START { \
+ const U32 old_flags = SvFLAGS(p); \
FREE_SV_DEBUG_FILE(p); \
POSION_SV_HEAD(p); \
- SvARENA_CHAIN(p) = (void *)PL_sv_root; \
SvFLAGS(p) = SVTYPEMASK; \
- PL_sv_root = (p); \
+ if (!(old_flags & SVf_BREAK)) { \
+ SvARENA_CHAIN(p) = (void *)PL_sv_root; \
+ PL_sv_root = (p); \
+ } \
--PL_sv_count; \
} STMT_END
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_line = (U16) (PL_parser && PL_parser->copline != NOLINE
+ ? PL_parser->copline
+ : PL_curcop
+ ? CopLINE(PL_curcop)
+ : 0
+ );
sv->sv_debug_inpad = 0;
sv->sv_debug_cloned = 0;
sv->sv_debug_file = PL_curcop ? savepv(CopFILE(PL_curcop)): NULL;
S_del_sv(pTHX_ SV *p)
{
dVAR;
+
+ PERL_ARGS_ASSERT_DEL_SV;
+
if (DEBUG_D_TEST) {
SV* sva;
bool ok = 0;
*/
void
-Perl_sv_add_arena(pTHX_ char *ptr, U32 size, U32 flags)
+Perl_sv_add_arena(pTHX_ char *const ptr, const U32 size, const U32 flags)
{
dVAR;
SV* const sva = (SV*)ptr;
register SV* sv;
register SV* svend;
+ PERL_ARGS_ASSERT_SV_ADD_ARENA;
+
/* The first SV in an arena isn't an SV. */
SvANY(sva) = (void *) PL_sv_arenaroot; /* ptr to next arena */
SvREFCNT(sva) = size / sizeof(SV); /* number of SV slots */
#ifdef DEBUGGING
SvREFCNT(sv) = 0;
#endif
- /* Must always set typemask because it's awlays checked in on cleanup
+ /* Must always set typemask because it's always checked in on cleanup
when the arenas are walked looking for objects. */
SvFLAGS(sv) = SVTYPEMASK;
sv++;
* whose flags field matches the flags/mask args. */
STATIC I32
-S_visit(pTHX_ SVFUNC_t f, U32 flags, U32 mask)
+S_visit(pTHX_ SVFUNC_t f, const U32 flags, const U32 mask)
{
dVAR;
SV* sva;
I32 visited = 0;
+ PERL_ARGS_ASSERT_VISIT;
+
for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
register const SV * const svend = &sva[SvREFCNT(sva)];
register SV* sv;
/* called by sv_report_used() for each live SV */
static void
-do_report_used(pTHX_ SV *sv)
+do_report_used(pTHX_ SV *const sv)
{
if (SvTYPE(sv) != SVTYPEMASK) {
PerlIO_printf(Perl_debug_log, "****\n");
/* called by sv_clean_objs() for each live SV */
static void
-do_clean_objs(pTHX_ SV *ref)
+do_clean_objs(pTHX_ SV *const ref)
{
dVAR;
assert (SvROK(ref));
#ifndef DISABLE_DESTRUCTOR_KLUDGE
static void
-do_clean_named_objs(pTHX_ SV *sv)
+do_clean_named_objs(pTHX_ SV *const sv)
{
dVAR;
assert(SvTYPE(sv) == SVt_PVGV);
SvOBJECT(GvSV(sv))) ||
(GvAV(sv) && SvOBJECT(GvAV(sv))) ||
(GvHV(sv) && SvOBJECT(GvHV(sv))) ||
- (GvIO(sv) && SvOBJECT(GvIO(sv))) ||
+ /* In certain rare cases GvIOp(sv) can be NULL, which would make SvOBJECT(GvIO(sv)) dereference NULL. */
+ (GvIO(sv) ? (SvFLAGS(GvIOp(sv)) & SVs_OBJECT) : 0) ||
(GvCV(sv) && SvOBJECT(GvCV(sv))) )
{
DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv)));
/* called by sv_clean_all() for each live SV */
static void
-do_clean_all(pTHX_ SV *sv)
+do_clean_all(pTHX_ SV *const sv)
{
dVAR;
+ if (sv == (SV*) PL_fdpid || sv == (SV *)PL_strtab) {
+ /* don't clean pid table and strtab */
+ return;
+ }
DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) ));
SvFLAGS(sv) |= SVf_BREAK;
- if (PL_comppad == (AV*)sv) {
- PL_comppad = NULL;
- PL_curpad = NULL;
- }
SvREFCNT_dec(sv);
}
memory in the last arena-set (1/2 on average). In trade, we get
back the 1st slot in each arena (ie 1.7% of a CV-arena, less for
smaller types). The recovery of the wasted space allows use of
- small arenas for large, rare body types,
+ small arenas for large, rare body types, by changing array* fields
+ in body_details_by_type[] below.
*/
struct arena_desc {
char *arena; /* the raw storage, allocated aligned */
struct arena_set;
/* Get the maximum number of elements in set[] such that struct arena_set
- will fit within PERL_ARENA_SIZE, which is probabably just under 4K, and
+ will fit within PERL_ARENA_SIZE, which is probably just under 4K, and
therefore likely to be 1 aligned memory page. */
#define ARENAS_PER_SET ((PERL_ARENA_SIZE - sizeof(struct arena_set*) \
TBD: export properly for hv.c: S_more_he().
*/
void*
-Perl_get_arena(pTHX_ size_t arena_size, U32 misc)
+Perl_get_arena(pTHX_ const size_t arena_size, const U32 misc)
{
dVAR;
struct arena_desc* adesc;
Newx(adesc->arena, arena_size, char);
adesc->size = arena_size;
adesc->misc = misc;
- DEBUG_m(PerlIO_printf(Perl_debug_log, "arena %d added: %p size %d\n",
- curr, (void*)adesc->arena, arena_size));
+ DEBUG_m(PerlIO_printf(Perl_debug_log, "arena %d added: %p size %"UVuf"\n",
+ curr, (void*)adesc->arena, (UV)arena_size));
return adesc->arena;
}
For the sv-types that have no bodies, arenas are not used, so those
PL_body_roots[sv_type] are unused, and can be overloaded. In
something of a special case, SVt_NULL is borrowed for HE arenas;
-PL_body_roots[SVt_NULL] is filled by S_more_he, but the
+PL_body_roots[HE_SVSLOT=SVt_NULL] is filled by S_more_he, but the
bodies_by_type[SVt_NULL] slot is not used, as the table is not
-available in hv.c,
+available in hv.c.
-PTEs also use arenas, but are never seen in Perl_sv_upgrade.
-Nonetheless, they get their own slot in bodies_by_type[SVt_NULL], so
-they can just use the same allocation semantics. At first, PTEs were
-also overloaded to a non-body sv-type, but this yielded hard-to-find
-malloc bugs, so was simplified by claiming a new slot. This choice
-has no consequence at this time.
+PTEs also use arenas, but are never seen in Perl_sv_upgrade. Nonetheless,
+they get their own slot in bodies_by_type[PTE_SVSLOT =SVt_IV], so they can
+just use the same allocation semantics. At first, PTEs were also
+overloaded to a non-body sv-type, but this yielded hard-to-find malloc
+bugs, so was simplified by claiming a new slot. This choice has no
+consequence at this time.
*/
FALSE, NONV, NOARENA, FIT_ARENA(0, sizeof(HE)) },
/* The bind placeholder pretends to be an RV for now.
- Also it's marked as "can't upgrade" top stop anyone using it before it's
+ Also it's marked as "can't upgrade" to stop anyone using it before it's
implemented. */
{ 0, 0, 0, SVt_BIND, TRUE, NONV, NOARENA, 0 },
{ sizeof(NV), sizeof(NV), 0, SVt_NV, FALSE, HADNV, HASARENA,
FIT_ARENA(0, sizeof(NV)) },
- /* RVs are in the head now. */
- { 0, 0, 0, SVt_RV, FALSE, NONV, NOARENA, 0 },
-
/* 8 bytes on most ILP32 with IEEE doubles */
{ sizeof(xpv_allocated),
copy_length(XPV, xpv_len)
/* 28 */
{ sizeof(XPVMG), copy_length(XPVMG, xmg_stash), 0, SVt_PVMG, FALSE, HADNV,
HASARENA, FIT_ARENA(0, sizeof(XPVMG)) },
-
+
+ /* something big */
+ { sizeof(struct regexp_allocated), sizeof(struct regexp_allocated),
+ + relative_STRUCT_OFFSET(struct regexp_allocated, regexp, xpv_cur),
+ SVt_REGEXP, FALSE, NONV, HASARENA,
+ FIT_ARENA(0, sizeof(struct regexp_allocated))
+ },
+
/* 48 */
{ sizeof(XPVGV), sizeof(XPVGV), 0, SVt_PVGV, TRUE, HADNV,
HASARENA, FIT_ARENA(0, sizeof(XPVGV)) },
copy_length(XPVAV, xmg_stash)
- relative_STRUCT_OFFSET(xpvav_allocated, XPVAV, xav_fill),
+ relative_STRUCT_OFFSET(xpvav_allocated, XPVAV, xav_fill),
- SVt_PVAV, TRUE, HADNV, HASARENA, FIT_ARENA(0, sizeof(xpvav_allocated)) },
+ SVt_PVAV, TRUE, NONV, HASARENA, FIT_ARENA(0, sizeof(xpvav_allocated)) },
{ sizeof(xpvhv_allocated),
copy_length(XPVHV, xmg_stash)
- relative_STRUCT_OFFSET(xpvhv_allocated, XPVHV, xhv_fill),
+ relative_STRUCT_OFFSET(xpvhv_allocated, XPVHV, xhv_fill),
- SVt_PVHV, TRUE, HADNV, HASARENA, FIT_ARENA(0, sizeof(xpvhv_allocated)) },
+ SVt_PVHV, TRUE, NONV, HASARENA, FIT_ARENA(0, sizeof(xpvhv_allocated)) },
/* 56 */
{ sizeof(xpvcv_allocated), sizeof(xpvcv_allocated),
SVt_PVFM, TRUE, NONV, NOARENA, FIT_ARENA(20, sizeof(xpvfm_allocated)) },
/* XPVIO is 84 bytes, fits 48x */
- { sizeof(XPVIO), sizeof(XPVIO), 0, SVt_PVIO, TRUE, HADNV,
- HASARENA, FIT_ARENA(24, sizeof(XPVIO)) },
+ { sizeof(xpvio_allocated), sizeof(xpvio_allocated),
+ + relative_STRUCT_OFFSET(xpvio_allocated, XPVIO, xpv_cur),
+ SVt_PVIO, TRUE, NONV, HASARENA, FIT_ARENA(24, sizeof(xpvio_allocated)) },
};
#define new_body_type(sv_type) \
my_safecalloc((details)->body_size + (details)->offset)
STATIC void *
-S_more_bodies (pTHX_ svtype sv_type)
+S_more_bodies (pTHX_ const svtype sv_type)
{
dVAR;
void ** const root = &PL_body_roots[sv_type];
const size_t body_size = bdp->body_size;
char *start;
const char *end;
+ const size_t arena_size = Perl_malloc_good_size(bdp->arena_size);
#if defined(DEBUGGING) && !defined(PERL_GLOBAL_STRUCT_PRIVATE)
static bool done_sanity_check;
assert(bdp->arena_size);
- start = (char*) Perl_get_arena(aTHX_ bdp->arena_size, sv_type);
+ start = (char*) Perl_get_arena(aTHX_ arena_size, sv_type);
- end = start + bdp->arena_size - body_size;
+ end = start + arena_size - 2 * body_size;
/* computed count doesnt reflect the 1st slot reservation */
+#if defined(MYMALLOC) || defined(HAS_MALLOC_GOOD_SIZE)
+ DEBUG_m(PerlIO_printf(Perl_debug_log,
+ "arena %p end %p arena-size %d (from %d) type %d "
+ "size %d ct %d\n",
+ (void*)start, (void*)end, (int)arena_size,
+ (int)bdp->arena_size, sv_type, (int)body_size,
+ (int)arena_size / (int)body_size));
+#else
DEBUG_m(PerlIO_printf(Perl_debug_log,
"arena %p end %p arena-size %d type %d size %d ct %d\n",
(void*)start, (void*)end,
(int)bdp->arena_size, sv_type, (int)body_size,
(int)bdp->arena_size / (int)body_size));
-
+#endif
*root = (void *)start;
- while (start < end) {
+ while (start <= end) {
char * const next = start + body_size;
*(void**) start = (void *)next;
start = next;
#ifndef PURIFY
STATIC void *
-S_new_body(pTHX_ svtype sv_type)
+S_new_body(pTHX_ const svtype sv_type)
{
dVAR;
void *xpv;
#endif
+static const struct body_details fake_rv =
+ { 0, 0, 0, SVt_IV, FALSE, NONV, NOARENA, 0 };
+
/*
=for apidoc sv_upgrade
*/
void
-Perl_sv_upgrade(pTHX_ register SV *sv, svtype new_type)
+Perl_sv_upgrade(pTHX_ register SV *const sv, svtype new_type)
{
dVAR;
void* old_body;
void* new_body;
const svtype old_type = SvTYPE(sv);
const struct body_details *new_type_details;
- const struct body_details *const old_type_details
+ const struct body_details *old_type_details
= bodies_by_type + old_type;
+ SV *referant = NULL;
+
+ PERL_ARGS_ASSERT_SV_UPGRADE;
if (new_type != SVt_PV && SvIsCOW(sv)) {
sv_force_normal_flags(sv, 0);
if (old_type == new_type)
return;
- if (old_type > new_type)
- Perl_croak(aTHX_ "sv_upgrade from type %d down to type %d",
- (int)old_type, (int)new_type);
-
-
old_body = SvANY(sv);
/* Copying structures onto other structures that have been neatly zeroed
case SVt_NULL:
break;
case SVt_IV:
- if (new_type < SVt_PVIV) {
- new_type = (new_type == SVt_NV)
- ? SVt_PVNV : SVt_PVIV;
+ if (SvROK(sv)) {
+ referant = SvRV(sv);
+ old_type_details = &fake_rv;
+ if (new_type == SVt_NV)
+ new_type = SVt_PVNV;
+ } else {
+ if (new_type < SVt_PVIV) {
+ new_type = (new_type == SVt_NV)
+ ? SVt_PVNV : SVt_PVIV;
+ }
}
break;
case SVt_NV:
new_type = SVt_PVNV;
}
break;
- case SVt_RV:
- break;
case SVt_PV:
assert(new_type > SVt_PV);
assert(SVt_IV < SVt_PV);
Perl_croak(aTHX_ "Can't upgrade %s (%" UVuf ") to %" UVuf,
sv_reftype(sv, 0), (UV) old_type, (UV) new_type);
}
+
+ if (old_type > new_type)
+ Perl_croak(aTHX_ "sv_upgrade from type %d down to type %d",
+ (int)old_type, (int)new_type);
+
new_type_details = bodies_by_type + new_type;
SvFLAGS(sv) &= ~SVTYPEMASK;
SvANY(sv) = new_XNV();
SvNV_set(sv, 0);
return;
- case SVt_RV:
- assert(old_type == SVt_NULL);
- SvANY(sv) = &sv->sv_u.svu_rv;
- SvRV_set(sv, 0);
- return;
case SVt_PVHV:
case SVt_PVAV:
assert(new_type_details->body_size);
AvMAX(sv) = -1;
AvFILLp(sv) = -1;
AvREAL_only(sv);
+ if (old_type_details->body_size) {
+ AvALLOC(sv) = 0;
+ } else {
+ /* It will have been zeroed when the new body was allocated.
+ Lets not write to it, in case it confuses a write-back
+ cache. */
+ }
+ } else {
+ assert(!SvOK(sv));
+ SvOK_off(sv);
+#ifndef NODEFAULT_SHAREKEYS
+ HvSHAREKEYS_on(sv); /* key-sharing on by default */
+#endif
+ HvMAX(sv) = 7; /* (start with 8 buckets) */
+ if (old_type_details->body_size) {
+ HvFILL(sv) = 0;
+ } else {
+ /* It will have been zeroed when the new body was allocated.
+ Lets not write to it, in case it confuses a write-back
+ cache. */
+ }
}
/* SVt_NULL isn't the only thing upgraded to AV or HV.
The target created by newSVrv also is, and it can have magic.
However, it never has SvPVX set.
*/
- if (old_type >= SVt_RV) {
+ if (old_type == SVt_IV) {
+ assert(!SvROK(sv));
+ } else if (old_type >= SVt_PV) {
assert(SvPVX_const(sv) == 0);
}
case SVt_PVGV:
case SVt_PVCV:
case SVt_PVLV:
+ case SVt_REGEXP:
case SVt_PVMG:
case SVt_PVNV:
case SVt_PV:
* NV slot, but the new one does, then we need to initialise the
* freshly created NV slot with whatever the correct bit pattern is
* for 0.0 */
- if (old_type_details->zero_nv && !new_type_details->zero_nv)
+ if (old_type_details->zero_nv && !new_type_details->zero_nv
+ && !isGV_with_GP(sv))
SvNV_set(sv, 0);
#endif
if (new_type == SVt_PVIO)
IoPAGE_LEN(sv) = 60;
- if (old_type < SVt_RV)
- SvPV_set(sv, NULL);
+ if (old_type < SVt_PV) {
+ /* referant will be NULL unless the old type was SVt_IV emulating
+ SVt_RV */
+ sv->sv_u.svu_rv = referant;
+ }
break;
default:
Perl_croak(aTHX_ "panic: sv_upgrade to unknown type %lu",
*/
int
-Perl_sv_backoff(pTHX_ register SV *sv)
+Perl_sv_backoff(pTHX_ register SV *const sv)
{
+ STRLEN delta;
+ const char * const s = SvPVX_const(sv);
+
+ PERL_ARGS_ASSERT_SV_BACKOFF;
PERL_UNUSED_CONTEXT;
+
assert(SvOOK(sv));
assert(SvTYPE(sv) != SVt_PVHV);
assert(SvTYPE(sv) != SVt_PVAV);
- if (SvIVX(sv)) {
- const char * const s = SvPVX_const(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);
- }
+
+ SvOOK_offset(sv, delta);
+
+ SvLEN_set(sv, SvLEN(sv) + delta);
+ SvPV_set(sv, SvPVX(sv) - delta);
+ Move(s, SvPVX(sv), SvCUR(sv)+1, char);
SvFLAGS(sv) &= ~SVf_OOK;
return 0;
}
*/
char *
-Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen)
+Perl_sv_grow(pTHX_ register SV *const sv, register STRLEN newlen)
{
register char *s;
+ PERL_ARGS_ASSERT_SV_GROW;
+
if (PL_madskills && newlen >= 0x100000) {
PerlIO_printf(Perl_debug_log,
"Allocation too large: %"UVxf"\n", (UV)newlen);
s = SvPVX_mutable(sv);
if (newlen > SvLEN(sv)) { /* need more room? */
+#ifndef Perl_safesysmalloc_size
newlen = PERL_STRLEN_ROUNDUP(newlen);
- if (SvLEN(sv) && s) {
-#ifdef MYMALLOC
- const STRLEN l = malloced_size((void*)SvPVX_const(sv));
- if (newlen <= l) {
- SvLEN_set(sv, l);
- return s;
- } else
#endif
+ if (SvLEN(sv) && s) {
s = (char*)saferealloc(s, newlen);
}
else {
}
}
SvPV_set(sv, s);
+#ifdef Perl_safesysmalloc_size
+ /* Do this here, do it once, do it right, and then we will never get
+ called back into sv_grow() unless there really is some growing
+ needed. */
+ SvLEN_set(sv, Perl_safesysmalloc_size(s));
+#else
SvLEN_set(sv, newlen);
+#endif
}
return s;
}
*/
void
-Perl_sv_setiv(pTHX_ register SV *sv, IV i)
+Perl_sv_setiv(pTHX_ register SV *const sv, const IV i)
{
dVAR;
+
+ PERL_ARGS_ASSERT_SV_SETIV;
+
SV_CHECK_THINKFIRST_COW_DROP(sv);
switch (SvTYPE(sv)) {
case SVt_NULL:
- sv_upgrade(sv, SVt_IV);
- break;
case SVt_NV:
- sv_upgrade(sv, SVt_PVNV);
+ sv_upgrade(sv, SVt_IV);
break;
- case SVt_RV:
case SVt_PV:
sv_upgrade(sv, SVt_PVIV);
break;
case SVt_PVGV:
+ if (!isGV_with_GP(sv))
+ break;
case SVt_PVAV:
case SVt_PVHV:
case SVt_PVCV:
*/
void
-Perl_sv_setiv_mg(pTHX_ register SV *sv, IV i)
+Perl_sv_setiv_mg(pTHX_ register SV *const sv, const IV i)
{
+ PERL_ARGS_ASSERT_SV_SETIV_MG;
+
sv_setiv(sv,i);
SvSETMAGIC(sv);
}
*/
void
-Perl_sv_setuv(pTHX_ register SV *sv, UV u)
+Perl_sv_setuv(pTHX_ register SV *const sv, const UV u)
{
+ PERL_ARGS_ASSERT_SV_SETUV;
+
/* With these two if statements:
u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865
*/
void
-Perl_sv_setuv_mg(pTHX_ register SV *sv, UV u)
+Perl_sv_setuv_mg(pTHX_ register SV *const sv, const UV u)
{
+ PERL_ARGS_ASSERT_SV_SETUV_MG;
+
sv_setuv(sv,u);
SvSETMAGIC(sv);
}
*/
void
-Perl_sv_setnv(pTHX_ register SV *sv, NV num)
+Perl_sv_setnv(pTHX_ register SV *const sv, const NV num)
{
dVAR;
+
+ PERL_ARGS_ASSERT_SV_SETNV;
+
SV_CHECK_THINKFIRST_COW_DROP(sv);
switch (SvTYPE(sv)) {
case SVt_NULL:
case SVt_IV:
sv_upgrade(sv, SVt_NV);
break;
- case SVt_RV:
case SVt_PV:
case SVt_PVIV:
sv_upgrade(sv, SVt_PVNV);
break;
case SVt_PVGV:
+ if (!isGV_with_GP(sv))
+ break;
case SVt_PVAV:
case SVt_PVHV:
case SVt_PVCV:
*/
void
-Perl_sv_setnv_mg(pTHX_ register SV *sv, NV num)
+Perl_sv_setnv_mg(pTHX_ register SV *const sv, const NV num)
{
+ PERL_ARGS_ASSERT_SV_SETNV_MG;
+
sv_setnv(sv,num);
SvSETMAGIC(sv);
}
*/
STATIC void
-S_not_a_number(pTHX_ SV *sv)
+S_not_a_number(pTHX_ SV *const sv)
{
dVAR;
SV *dsv;
char tmpbuf[64];
const char *pv;
+ PERL_ARGS_ASSERT_NOT_A_NUMBER;
+
if (DO_UTF8(sv)) {
- dsv = sv_2mortal(newSVpvs(""));
+ dsv = newSVpvs_flags("", SVs_TEMP);
pv = sv_uni_display(dsv, sv, 10, 0);
} else {
char *d = tmpbuf;
*/
I32
-Perl_looks_like_number(pTHX_ SV *sv)
+Perl_looks_like_number(pTHX_ SV *const sv)
{
register const char *sbegin;
STRLEN len;
+ PERL_ARGS_ASSERT_LOOKS_LIKE_NUMBER;
+
if (SvPOK(sv)) {
sbegin = SvPVX_const(sv);
len = SvCUR(sv);
const U32 wasfake = SvFLAGS(gv) & SVf_FAKE;
SV *const buffer = sv_newmortal();
+ PERL_ARGS_ASSERT_GLOB_2NUMBER;
+
/* FAKE globs can get coerced, so need to turn this off temporarily if it
is on. */
SvFAKE_off(gv);
const U32 wasfake = SvFLAGS(gv) & SVf_FAKE;
SV *const buffer = sv_newmortal();
+ PERL_ARGS_ASSERT_GLOB_2PV;
+
/* FAKE globs can get coerced, so need to turn this off temporarily if it
is on. */
SvFAKE_off(gv);
/* For sv_2nv these three cases are "SvNOK and don't bother casting" */
STATIC int
-S_sv_2iuv_non_preserve(pTHX_ register SV *sv, I32 numtype)
+S_sv_2iuv_non_preserve(pTHX_ register SV *const sv
+# ifdef DEBUGGING
+ , I32 numtype
+# endif
+ )
{
dVAR;
- PERL_UNUSED_ARG(numtype); /* Used only under DEBUGGING? */
+
+ PERL_ARGS_ASSERT_SV_2IUV_NON_PRESERVE;
+
DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_2iuv_non '%s', IV=0x%"UVxf" NV=%"NVgf" inttype=%"UVXf"\n", SvPVX_const(sv), SvIVX(sv), SvNVX(sv), (UV)numtype));
if (SvNVX(sv) < (NV)IV_MIN) {
(void)SvIOKp_on(sv);
#endif /* !NV_PRESERVES_UV*/
STATIC bool
-S_sv_2iuv_common(pTHX_ SV *sv) {
+S_sv_2iuv_common(pTHX_ SV *const sv)
+{
dVAR;
+
+ PERL_ARGS_ASSERT_SV_2IUV_COMMON;
+
if (SvNOKp(sv)) {
/* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
* without also getting a cached IV/UV from it at the same time
we're outside the range of NV integer precision */
#endif
) {
- SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
+ if (SvNOK(sv))
+ SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
+ else {
+ /* scalar has trailing garbage, eg "42a" */
+ }
DEBUG_c(PerlIO_printf(Perl_debug_log,
"0x%"UVxf" iv(%"NVgf" => %"IVdf") (precise)\n",
PTR2UV(sv),
came from a (by definition imprecise) NV operation, and
we're outside the range of NV integer precision */
#endif
+ && SvNOK(sv)
)
SvIOK_on(sv);
SvIsUV_on(sv);
1 1 already read UV.
so there's no point in sv_2iuv_non_preserve() attempting
to use atol, strtol, strtoul etc. */
+# ifdef DEBUGGING
sv_2iuv_non_preserve (sv, numtype);
+# else
+ sv_2iuv_non_preserve (sv);
+# endif
}
}
#endif /* NV_PRESERVES_UV */
+ /* It might be more code efficient to go through the entire logic above
+ and conditionally set with SvIOKp_on() rather than SvIOK(), but it
+ gets complex and potentially buggy, so more programmer efficient
+ to do it this way, by turning off the public flags: */
+ if (!numtype)
+ SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK);
}
}
else {
*/
IV
-Perl_sv_2iv_flags(pTHX_ register SV *sv, I32 flags)
+Perl_sv_2iv_flags(pTHX_ register SV *const sv, const I32 flags)
{
dVAR;
if (!sv)
*/
UV
-Perl_sv_2uv_flags(pTHX_ register SV *sv, I32 flags)
+Perl_sv_2uv_flags(pTHX_ register SV *const sv, const I32 flags)
{
dVAR;
if (!sv)
*/
NV
-Perl_sv_2nv(pTHX_ register SV *sv)
+Perl_sv_2nv(pTHX_ register SV *const sv)
{
dVAR;
if (!sv)
if (SvIOKp(sv)) {
SvNV_set(sv, SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv));
#ifdef NV_PRESERVES_UV
- SvNOK_on(sv);
+ if (SvIOK(sv))
+ SvNOK_on(sv);
+ else
+ SvNOKp_on(sv);
#else
/* Only set the public NV OK flag if this NV preserves the IV */
/* Check it's not 0xFFFFFFFFFFFFFFFF */
- if (SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv))))
+ if (SvIOK(sv) &&
+ SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv))))
: (SvIVX(sv) == I_V(SvNVX(sv))))
SvNOK_on(sv);
else
SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value);
} else
SvNV_set(sv, Atof(SvPVX_const(sv)));
- SvNOK_on(sv);
+ if (numtype)
+ SvNOK_on(sv);
+ else
+ SvNOKp_on(sv);
#else
SvNV_set(sv, Atof(SvPVX_const(sv)));
/* Only set the public NV OK flag if this NV preserves the value in
}
}
}
+ /* It might be more code efficient to go through the entire logic above
+ and conditionally set with SvNOKp_on() rather than SvNOK(), but it
+ gets complex and potentially buggy, so more programmer efficient
+ to do it this way, by turning off the public flags: */
+ if (!numtype)
+ SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK);
#endif /* NV_PRESERVES_UV */
}
else {
return SvNVX(sv);
}
+/*
+=for apidoc sv_2num
+
+Return an SV with the numeric value of the source SV, doing any necessary
+reference or overload conversion. You must use the C<SvNUM(sv)> macro to
+access this function.
+
+=cut
+*/
+
+SV *
+Perl_sv_2num(pTHX_ register SV *const sv)
+{
+ PERL_ARGS_ASSERT_SV_2NUM;
+
+ if (!SvROK(sv))
+ return sv;
+ if (SvAMAGIC(sv)) {
+ SV * const tmpsv = AMG_CALLun(sv,numer);
+ if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
+ return sv_2num(tmpsv);
+ }
+ return sv_2mortal(newSVuv(PTR2UV(SvRV(sv))));
+}
+
/* uiv_2buf(): private routine for use by sv_2pv_flags(): print an IV or
* UV as a string towards the end of buf, and return pointers to start and
* end of it.
*/
static char *
-S_uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
+S_uiv_2buf(char *const buf, const IV iv, UV uv, const int is_uv, char **const peob)
{
char *ptr = buf + TYPE_CHARS(UV);
char * const ebuf = ptr;
int sign;
+ PERL_ARGS_ASSERT_UIV_2BUF;
+
if (is_uv)
sign = 0;
else if (iv >= 0) {
*/
char *
-Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags)
+Perl_sv_2pv_flags(pTHX_ register SV *const sv, STRLEN *const lp, const I32 flags)
{
dVAR;
register char *s;
STRLEN len;
char *retval;
char *buffer;
- MAGIC *mg;
const SV *const referent = (SV*)SvRV(sv);
if (!referent) {
len = 7;
retval = buffer = savepvn("NULLREF", len);
- } else if (SvTYPE(referent) == SVt_PVMG
- && ((SvFLAGS(referent) &
- (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
- == (SVs_OBJECT|SVs_SMG))
- && (mg = mg_find(referent, PERL_MAGIC_qr)))
- {
- char *str = NULL;
- I32 haseval = 0;
- U32 flags = 0;
- (str) = CALLREG_AS_STR(mg,lp,&flags,&haseval);
- if (flags & 1)
- SvUTF8_on(sv);
- else
- SvUTF8_off(sv);
- PL_reginterp_cnt += haseval;
- return str;
+ } else if (SvTYPE(referent) == SVt_REGEXP) {
+ const REGEXP * const re = (REGEXP *)referent;
+ I32 seen_evals = 0;
+
+ assert(re);
+
+ /* If the regex is UTF-8 we want the containing scalar to
+ have an UTF-8 flag too */
+ if (RX_UTF8(re))
+ SvUTF8_on(sv);
+ else
+ SvUTF8_off(sv);
+
+ if ((seen_evals = RX_SEEN_EVALS(re)))
+ PL_reginterp_cnt += seen_evals;
+
+ if (lp)
+ *lp = RX_WRAPLEN(re);
+
+ return RX_WRAPPED(re);
} else {
const char *const typestr = sv_reftype(referent, 0);
const STRLEN typelen = strlen(typestr);
}
}
if (SvREADONLY(sv) && !SvOK(sv)) {
- if (ckWARN(WARN_UNINITIALIZED))
- report_uninit(sv);
if (lp)
*lp = 0;
+ if (flags & SV_UNDEF_RETURNS_NULL)
+ return NULL;
+ if (ckWARN(WARN_UNINITIALIZED))
+ report_uninit(sv);
return (char *)"";
}
}
const U32 isUIOK = SvIsUV(sv);
char buf[TYPE_CHARS(UV)];
char *ebuf, *ptr;
+ STRLEN len;
if (SvTYPE(sv) < SVt_PVIV)
sv_upgrade(sv, SVt_PVIV);
ptr = uiv_2buf(buf, SvIVX(sv), SvUVX(sv), isUIOK, &ebuf);
+ len = ebuf - ptr;
/* inlined from sv_setpvn */
- SvGROW_mutable(sv, (STRLEN)(ebuf - ptr + 1));
- Move(ptr,SvPVX_mutable(sv),ebuf - ptr,char);
- SvCUR_set(sv, ebuf - ptr);
- s = SvEND(sv);
+ s = SvGROW_mutable(sv, len + 1);
+ Move(ptr, s, len, char);
+ s += len;
*s = '\0';
}
else if (SvNOKp(sv)) {
}
errno = olderrno;
#ifdef FIXNEGATIVEZERO
- if (*s == '-' && s[1] == '0' && !s[2])
- my_strlcpy(s, "0", SvLEN(s));
+ if (*s == '-' && s[1] == '0' && !s[2]) {
+ s[0] = '0';
+ s[1] = 0;
+ }
#endif
while (*s) s++;
#ifdef hcx
if (isGV_with_GP(sv))
return glob_2pv((GV *)sv, lp);
- if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED))
- report_uninit(sv);
if (lp)
*lp = 0;
+ if (flags & SV_UNDEF_RETURNS_NULL)
+ return NULL;
+ if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED))
+ report_uninit(sv);
if (SvTYPE(sv) < SVt_PV)
/* Typically the caller expects that sv_any is not NULL now. */
sv_upgrade(sv, SVt_PV);
Copies a stringified representation of the source SV into the
destination SV. Automatically performs any necessary mg_get and
coercion of numeric values into strings. Guaranteed to preserve
-UTF-8 flag even from overloaded objects. Similar in nature to
+UTF8 flag even from overloaded objects. Similar in nature to
sv_2pv[_flags] but operates directly on an SV instead of just the
string. Mostly uses sv_2pv_flags to do its work, except when that
would lose the UTF-8'ness of the PV.
*/
void
-Perl_sv_copypv(pTHX_ SV *dsv, register SV *ssv)
+Perl_sv_copypv(pTHX_ SV *const dsv, register SV *const ssv)
{
STRLEN len;
const char * const s = SvPV_const(ssv,len);
+
+ PERL_ARGS_ASSERT_SV_COPYPV;
+
sv_setpvn(dsv,s,len);
if (SvUTF8(ssv))
SvUTF8_on(dsv);
*/
char *
-Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp)
+Perl_sv_2pvbyte(pTHX_ register SV *const sv, STRLEN *const lp)
{
+ PERL_ARGS_ASSERT_SV_2PVBYTE;
+
sv_utf8_downgrade(sv,0);
return lp ? SvPV(sv,*lp) : SvPV_nolen(sv);
}
*/
char *
-Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp)
+Perl_sv_2pvutf8(pTHX_ register SV *const sv, STRLEN *const lp)
{
+ PERL_ARGS_ASSERT_SV_2PVUTF8;
+
sv_utf8_upgrade(sv);
return lp ? SvPV(sv,*lp) : SvPV_nolen(sv);
}
*/
bool
-Perl_sv_2bool(pTHX_ register SV *sv)
+Perl_sv_2bool(pTHX_ register SV *const sv)
{
dVAR;
+
+ PERL_ARGS_ASSERT_SV_2BOOL;
+
SvGETMAGIC(sv);
if (!SvOK(sv))
*/
STRLEN
-Perl_sv_utf8_upgrade_flags(pTHX_ register SV *sv, I32 flags)
+Perl_sv_utf8_upgrade_flags(pTHX_ register SV *const sv, const I32 flags)
{
dVAR;
+
+ PERL_ARGS_ASSERT_SV_UTF8_UPGRADE_FLAGS;
+
if (sv == &PL_sv_undef)
return 0;
if (!SvPOK(sv)) {
const U8 ch = *t++;
/* Check for hi bit */
if (!NATIVE_IS_INVARIANT(ch)) {
- STRLEN len = SvCUR(sv) + 1; /* Plus the \0 */
+ STRLEN len = SvCUR(sv);
+ /* *Currently* bytes_to_utf8() adds a '\0' after every string
+ it converts. This isn't documented. It's not clear if it's
+ a bad thing to be doing, and should be changed to do exactly
+ what the documentation says. If so, this code will have to
+ be changed.
+ As is, we mustn't rely on our incoming SV being well formed
+ and having a trailing '\0', as certain code in pp_formline
+ can send us partially built SVs. */
U8 * const recoded = bytes_to_utf8((U8*)s, &len);
SvPV_free(sv); /* No longer using what was there before. */
SvPV_set(sv, (char*)recoded);
- SvCUR_set(sv, len - 1);
- SvLEN_set(sv, len); /* No longer know the real size. */
+ SvCUR_set(sv, len);
+ SvLEN_set(sv, len + 1); /* No longer know the real size. */
break;
}
}
*/
bool
-Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok)
+Perl_sv_utf8_downgrade(pTHX_ register SV *const sv, const bool fail_ok)
{
dVAR;
+
+ PERL_ARGS_ASSERT_SV_UTF8_DOWNGRADE;
+
if (SvPOKp(sv) && SvUTF8(sv)) {
if (SvCUR(sv)) {
U8 *s;
*/
void
-Perl_sv_utf8_encode(pTHX_ register SV *sv)
+Perl_sv_utf8_encode(pTHX_ register SV *const sv)
{
+ PERL_ARGS_ASSERT_SV_UTF8_ENCODE;
+
if (SvIsCOW(sv)) {
sv_force_normal_flags(sv, 0);
}
*/
bool
-Perl_sv_utf8_decode(pTHX_ register SV *sv)
+Perl_sv_utf8_decode(pTHX_ register SV *const sv)
{
+ PERL_ARGS_ASSERT_SV_UTF8_DECODE;
+
if (SvPOKp(sv)) {
const U8 *c;
const U8 *e;
*/
static void
-S_glob_assign_glob(pTHX_ SV *dstr, SV *sstr, const int dtype)
+S_glob_assign_glob(pTHX_ SV *const dstr, SV *const sstr, const int dtype)
{
+ I32 mro_changes = 0; /* 1 = method, 2 = isa */
+
+ PERL_ARGS_ASSERT_GLOB_ASSIGN_GLOB;
+
if (dtype != SVt_PVGV) {
const char * const name = GvNAME(sstr);
const STRLEN len = GvNAMELEN(sstr);
}
#endif
+ if(GvGP((GV*)sstr)) {
+ /* If source has method cache entry, clear it */
+ if(GvCVGEN(sstr)) {
+ SvREFCNT_dec(GvCV(sstr));
+ GvCV(sstr) = NULL;
+ GvCVGEN(sstr) = 0;
+ }
+ /* If source has a real method, then a method is
+ going to change */
+ else if(GvCV((GV*)sstr)) {
+ mro_changes = 1;
+ }
+ }
+
+ /* If dest already had a real method, that's a change as well */
+ if(!mro_changes && GvGP((GV*)dstr) && GvCVu((GV*)dstr)) {
+ mro_changes = 1;
+ }
+
+ if(strEQ(GvNAME((GV*)dstr),"ISA"))
+ mro_changes = 2;
+
gp_free((GV*)dstr);
isGV_with_GP_off(dstr);
(void)SvOK_off(dstr);
GvIMPORTED_on(dstr);
}
GvMULTI_on(dstr);
+ if(mro_changes == 2) mro_isa_changed_in(GvSTASH(dstr));
+ else if(mro_changes) mro_method_changed_in(GvSTASH(dstr));
return;
}
static void
-S_glob_assign_ref(pTHX_ SV *dstr, SV *sstr) {
+S_glob_assign_ref(pTHX_ SV *const dstr, SV *const sstr)
+{
SV * const sref = SvREFCNT_inc(SvRV(sstr));
SV *dref = NULL;
const int intro = GvINTRO(dstr);
U8 import_flag = 0;
const U32 stype = SvTYPE(sref);
+ PERL_ARGS_ASSERT_GLOB_ASSIGN_REF;
#ifdef GV_UNIQUE_CHECK
if (GvUNIQUE((GV*)dstr)) {
common:
if (intro) {
if (stype == SVt_PVCV) {
- if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
+ /*if (GvCVGEN(dstr) && (GvCV(dstr) != (CV*)sref || GvCVGEN(dstr))) {*/
+ if (GvCVGEN(dstr)) {
SvREFCNT_dec(GvCV(dstr));
GvCV(dstr) = NULL;
GvCVGEN(dstr) = 0; /* Switch off cacheness. */
- PL_sub_generation++;
}
}
SAVEGENERICSV(*location);
}
else
dref = *location;
- if (stype == SVt_PVCV && *location != sref) {
+ if (stype == SVt_PVCV && (*location != sref || GvCVGEN(dstr))) {
CV* const cv = (CV*)*location;
if (cv) {
if (!GvCVGEN((GV*)dstr) &&
}
GvCVGEN(dstr) = 0; /* Switch off cacheness. */
GvASSUMECV_on(dstr);
- PL_sub_generation++;
+ if(GvSTASH(dstr)) mro_method_changed_in(GvSTASH(dstr)); /* sub foo { 1 } sub bar { 2 } *bar = \&foo */
}
*location = sref;
if (import_flag && !(GvFLAGS(dstr) & import_flag)
}
void
-Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
+Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV* sstr, const I32 flags)
{
dVAR;
register U32 sflags;
register int dtype;
register svtype stype;
+ PERL_ARGS_ASSERT_SV_SETSV_FLAGS;
+
if (sstr == dstr)
return;
{
/* need to nuke the magic */
mg_free(dstr);
- SvRMAGICAL_off(dstr);
}
/* There's a lot of redundancy below but we're going for speed here */
sv_upgrade(dstr, SVt_IV);
break;
case SVt_NV:
- case SVt_RV:
case SVt_PV:
sv_upgrade(dstr, SVt_PVIV);
break;
assert(!SvTAINTED(sstr));
return;
}
- goto undef_sstr;
+ if (!SvROK(sstr))
+ goto undef_sstr;
+ if (dtype < SVt_PV && dtype != SVt_IV)
+ sv_upgrade(dstr, SVt_IV);
+ break;
case SVt_NV:
if (SvNOK(sstr)) {
case SVt_IV:
sv_upgrade(dstr, SVt_NV);
break;
- case SVt_RV:
case SVt_PV:
case SVt_PVIV:
sv_upgrade(dstr, SVt_PVNV);
}
goto undef_sstr;
- case SVt_RV:
- if (dtype < SVt_RV)
- sv_upgrade(dstr, SVt_RV);
- break;
case SVt_PVFM:
#ifdef PERL_OLD_COPY_ON_WRITE
if ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS) {
}
/* Fall through */
#endif
+ case SVt_REGEXP:
case SVt_PV:
if (dtype < SVt_PV)
sv_upgrade(dstr, SVt_PV);
Perl_croak(aTHX_ "Cannot copy to %s", type);
} else if (sflags & SVf_ROK) {
if (isGV_with_GP(dstr) && dtype == SVt_PVGV
- && SvTYPE(SvRV(sstr)) == SVt_PVGV) {
+ && SvTYPE(SvRV(sstr)) == SVt_PVGV && isGV_with_GP(SvRV(sstr))) {
sstr = SvRV(sstr);
if (sstr == dstr) {
if (GvIMPORTED(dstr) != GVf_IMPORTED
}
if (dtype >= SVt_PV) {
- if (dtype == SVt_PVGV) {
+ if (dtype == SVt_PVGV && isGV_with_GP(dstr)) {
glob_assign_ref(dstr, sstr);
return;
}
/* and won't be needed again, potentially */
!(PL_op && PL_op->op_type == OP_AASSIGN))
#ifdef PERL_OLD_COPY_ON_WRITE
- && !((sflags & CAN_COW_MASK) == CAN_COW_FLAGS
- && (SvFLAGS(dstr) & CAN_COW_MASK) == CAN_COW_FLAGS
- && SvTYPE(sstr) >= SVt_PVIV)
+ && ((flags & SV_COW_SHARED_HASH_KEYS)
+ ? (!((sflags & CAN_COW_MASK) == CAN_COW_FLAGS
+ && (SvFLAGS(dstr) & CAN_COW_MASK) == CAN_COW_FLAGS
+ && SvTYPE(sstr) >= SVt_PVIV))
+ : 1)
#endif
) {
/* Failed the swipe test, and it's not a shared hash key either.
SvNV_set(dstr, SvNVX(sstr));
}
if (sflags & SVp_IOK) {
- SvOOK_off(dstr);
SvIV_set(dstr, SvIVX(sstr));
/* Must do this otherwise some other overloaded use of 0x80000000
gets confused. I guess SVpbm_VALID */
*/
void
-Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr)
+Perl_sv_setsv_mg(pTHX_ SV *const dstr, register SV *const sstr)
{
+ PERL_ARGS_ASSERT_SV_SETSV_MG;
+
sv_setsv(dstr,sstr);
SvSETMAGIC(dstr);
}
STRLEN len = SvLEN(sstr);
register char *new_pv;
+ PERL_ARGS_ASSERT_SV_SETSV_COW;
+
if (DEBUG_C_TEST) {
PerlIO_printf(Perl_debug_log, "Fast copy on write: %p -> %p\n",
(void*)sstr, (void*)dstr);
*/
void
-Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
+Perl_sv_setpvn(pTHX_ register SV *const sv, register const char *const ptr, register const STRLEN len)
{
dVAR;
register char *dptr;
+ PERL_ARGS_ASSERT_SV_SETPVN;
+
SV_CHECK_THINKFIRST_COW_DROP(sv);
if (!ptr) {
(void)SvOK_off(sv);
*/
void
-Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
+Perl_sv_setpvn_mg(pTHX_ register SV *const sv, register const char *const ptr, register const STRLEN len)
{
+ PERL_ARGS_ASSERT_SV_SETPVN_MG;
+
sv_setpvn(sv,ptr,len);
SvSETMAGIC(sv);
}
*/
void
-Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr)
+Perl_sv_setpv(pTHX_ register SV *const sv, register const char *const ptr)
{
dVAR;
register STRLEN len;
+ PERL_ARGS_ASSERT_SV_SETPV;
+
SV_CHECK_THINKFIRST_COW_DROP(sv);
if (!ptr) {
(void)SvOK_off(sv);
*/
void
-Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr)
+Perl_sv_setpv_mg(pTHX_ register SV *const sv, register const char *const ptr)
{
+ PERL_ARGS_ASSERT_SV_SETPV_MG;
+
sv_setpv(sv,ptr);
SvSETMAGIC(sv);
}
*/
void
-Perl_sv_usepvn_flags(pTHX_ SV *sv, char *ptr, STRLEN len, U32 flags)
+Perl_sv_usepvn_flags(pTHX_ SV *const sv, char *ptr, const STRLEN len, const U32 flags)
{
dVAR;
STRLEN allocate;
+
+ PERL_ARGS_ASSERT_SV_USEPVN_FLAGS;
+
SV_CHECK_THINKFIRST_COW_DROP(sv);
SvUPGRADE(sv, SVt_PV);
if (!ptr) {
#endif
allocate = (flags & SV_HAS_TRAILING_NUL)
- ? len + 1: PERL_STRLEN_ROUNDUP(len + 1);
+ ? len + 1 :
+#ifdef Perl_safesysmalloc_size
+ len + 1;
+#else
+ PERL_STRLEN_ROUNDUP(len + 1);
+#endif
if (flags & SV_HAS_TRAILING_NUL) {
/* It's long enough - do nothing.
Specfically Perl_newCONSTSUB is relying on this. */
ptr = (char*) saferealloc (ptr, allocate);
#endif
}
- SvPV_set(sv, ptr);
- SvCUR_set(sv, len);
+#ifdef Perl_safesysmalloc_size
+ SvLEN_set(sv, Perl_safesysmalloc_size(ptr));
+#else
SvLEN_set(sv, allocate);
+#endif
+ SvCUR_set(sv, len);
+ SvPV_set(sv, ptr);
if (!(flags & SV_HAS_TRAILING_NUL)) {
- *SvEND(sv) = '\0';
+ ptr[len] = '\0';
}
(void)SvPOK_only_UTF8(sv); /* validate pointer */
SvTAINT(sv);
STATIC void
S_sv_release_COW(pTHX_ register SV *sv, const char *pvx, SV *after)
{
+ PERL_ARGS_ASSERT_SV_RELEASE_COW;
+
{ /* this SV was SvIsCOW_normal(sv) */
/* we need to find the SV pointing to us. */
SV *current = SV_COW_NEXT_SV(after);
*/
void
-Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags)
+Perl_sv_force_normal_flags(pTHX_ register SV *const sv, const U32 flags)
{
dVAR;
+
+ PERL_ARGS_ASSERT_SV_FORCE_NORMAL_FLAGS;
+
#ifdef PERL_OLD_COPY_ON_WRITE
if (SvREADONLY(sv)) {
/* At this point I believe I should acquire a global SV mutex. */
*/
void
-Perl_sv_chop(pTHX_ register SV *sv, register const char *ptr)
+Perl_sv_chop(pTHX_ register SV *const sv, register const char *const ptr)
{
- register STRLEN delta;
+ STRLEN delta;
+ STRLEN old_delta;
+ U8 *p;
+#ifdef DEBUGGING
+ const U8 *real_start;
+#endif
+ STRLEN max_delta;
+
+ PERL_ARGS_ASSERT_SV_CHOP;
+
if (!ptr || !SvPOKp(sv))
return;
delta = ptr - SvPVX_const(sv);
+ if (!delta) {
+ /* Nothing to do. */
+ return;
+ }
+ /* SvPVX(sv) may move in SV_CHECK_THINKFIRST(sv), but after this line,
+ nothing uses the value of ptr any more. */
+ max_delta = SvLEN(sv) ? SvLEN(sv) : SvCUR(sv);
+ if (ptr <= SvPVX_const(sv))
+ Perl_croak(aTHX_ "panic: sv_chop ptr=%p, start=%p, end=%p",
+ ptr, SvPVX_const(sv), SvPVX_const(sv) + max_delta);
SV_CHECK_THINKFIRST(sv);
- if (SvTYPE(sv) < SVt_PVIV)
- sv_upgrade(sv,SVt_PVIV);
+ if (delta > max_delta)
+ Perl_croak(aTHX_ "panic: sv_chop ptr=%p (was %p), start=%p, end=%p",
+ SvPVX_const(sv) + delta, ptr, SvPVX_const(sv),
+ SvPVX_const(sv) + max_delta);
if (!SvOOK(sv)) {
if (!SvLEN(sv)) { /* make copy of shared string */
Move(pvx,SvPVX(sv),len,char);
*SvEND(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;
+ old_delta = 0;
+ } else {
+ SvOOK_offset(sv, old_delta);
}
- SvNIOK_off(sv);
SvLEN_set(sv, SvLEN(sv) - delta);
SvCUR_set(sv, SvCUR(sv) - delta);
SvPV_set(sv, SvPVX(sv) + delta);
- SvIV_set(sv, SvIVX(sv) + delta);
+
+ p = (U8 *)SvPVX_const(sv);
+
+ delta += old_delta;
+
+#ifdef DEBUGGING
+ real_start = p - delta;
+#endif
+
+ assert(delta);
+ if (delta < 0x100) {
+ *--p = (U8) delta;
+ } else {
+ *--p = 0;
+ p -= sizeof(STRLEN);
+ Copy((U8*)&delta, p, sizeof(STRLEN), U8);
+ }
+
+#ifdef DEBUGGING
+ /* Fill the preceding buffer with sentinals to verify that no-one is
+ using it. */
+ while (p > real_start) {
+ --p;
+ *p = (U8)PTR2UV(p);
+ }
+#endif
}
/*
*/
void
-Perl_sv_catpvn_flags(pTHX_ register SV *dsv, register const char *sstr, register STRLEN slen, I32 flags)
+Perl_sv_catpvn_flags(pTHX_ register SV *const dsv, register const char *sstr, register const STRLEN slen, const I32 flags)
{
dVAR;
STRLEN dlen;
const char * const dstr = SvPV_force_flags(dsv, dlen, flags);
+ PERL_ARGS_ASSERT_SV_CATPVN_FLAGS;
+
SvGROW(dsv, dlen + slen + 1);
if (sstr == dstr)
sstr = SvPVX_const(dsv);
=cut */
void
-Perl_sv_catsv_flags(pTHX_ SV *dsv, register SV *ssv, I32 flags)
+Perl_sv_catsv_flags(pTHX_ SV *const dsv, register SV *const ssv, const I32 flags)
{
dVAR;
- if (ssv) {
+
+ PERL_ARGS_ASSERT_SV_CATSV_FLAGS;
+
+ if (ssv) {
STRLEN slen;
const char *spv = SvPV_const(ssv, slen);
if (spv) {
if (dutf8 != sutf8) {
if (dutf8) {
/* Not modifying source SV, so taking a temporary copy. */
- SV* const csv = sv_2mortal(newSVpvn(spv, slen));
+ SV* const csv = newSVpvn_flags(spv, slen, SVs_TEMP);
sv_utf8_upgrade(csv);
spv = SvPV_const(csv, slen);
=cut */
void
-Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr)
+Perl_sv_catpv(pTHX_ register SV *const sv, register const char *ptr)
{
dVAR;
register STRLEN len;
STRLEN tlen;
char *junk;
+ PERL_ARGS_ASSERT_SV_CATPV;
+
if (!ptr)
return;
junk = SvPV_force(sv, tlen);
*/
void
-Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr)
+Perl_sv_catpv_mg(pTHX_ register SV *const sv, register const char *const ptr)
{
+ PERL_ARGS_ASSERT_SV_CATPV_MG;
+
sv_catpv(sv,ptr);
SvSETMAGIC(sv);
}
*/
SV *
-Perl_newSV(pTHX_ STRLEN len)
+Perl_newSV(pTHX_ const STRLEN len)
{
dVAR;
register SV *sv;
=cut
*/
MAGIC *
-Perl_sv_magicext(pTHX_ SV* sv, SV* obj, int how, const MGVTBL *vtable,
- const char* name, I32 namlen)
+Perl_sv_magicext(pTHX_ SV *const sv, SV *const obj, const int how,
+ const MGVTBL *const vtable, const char *const name, const I32 namlen)
{
dVAR;
MAGIC* mg;
- if (SvTYPE(sv) < SVt_PVMG) {
- SvUPGRADE(sv, SVt_PVMG);
- }
+ PERL_ARGS_ASSERT_SV_MAGICEXT;
+
+ SvUPGRADE(sv, SVt_PVMG);
Newxz(mg, 1, MAGIC);
mg->mg_moremagic = SvMAGIC(sv);
SvMAGIC_set(sv, mg);
*/
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 ||
*/
void
-Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
+Perl_sv_magic(pTHX_ register SV *const sv, SV *const obj, const int how,
+ const char *const name, const I32 namlen)
{
dVAR;
const MGVTBL *vtable;
MAGIC* mg;
+ PERL_ARGS_ASSERT_SV_MAGIC;
+
#ifdef PERL_OLD_COPY_ON_WRITE
if (SvIsCOW(sv))
sv_force_normal_flags(sv, 0);
*/
int
-Perl_sv_unmagic(pTHX_ SV *sv, int type)
+Perl_sv_unmagic(pTHX_ SV *const sv, const int type)
{
MAGIC* mg;
MAGIC** mgp;
+
+ PERL_ARGS_ASSERT_SV_UNMAGIC;
+
if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
return 0;
mgp = &(((XPVMG*) SvANY(sv))->xmg_u.xmg_magic);
*/
SV *
-Perl_sv_rvweaken(pTHX_ SV *sv)
+Perl_sv_rvweaken(pTHX_ SV *const sv)
{
SV *tsv;
+
+ PERL_ARGS_ASSERT_SV_RVWEAKEN;
+
if (!SvOK(sv)) /* let undefs pass */
return sv;
if (!SvROK(sv))
* back-reference to sv onto the array associated with the backref magic.
*/
+/* A discussion about the backreferences array and its refcount:
+ *
+ * The AV holding the backreferences is pointed to either as the mg_obj of
+ * PERL_MAGIC_backref, or in the specific case of a HV that has the hv_aux
+ * structure, from the xhv_backreferences field. (A HV without hv_aux will
+ * have the standard magic instead.) The array is created with a refcount
+ * of 2. This means that if during global destruction the array gets
+ * picked on first to have its refcount decremented by the random zapper,
+ * it won't actually be freed, meaning it's still theere for when its
+ * parent gets freed.
+ * When the parent SV is freed, in the case of magic, the magic is freed,
+ * Perl_magic_killbackrefs is called which decrements one refcount, then
+ * mg_obj is freed which kills the second count.
+ * In the vase of a HV being freed, one ref is removed by
+ * Perl_hv_kill_backrefs, the other by Perl_sv_kill_backrefs, which it
+ * calls.
+ */
+
void
-Perl_sv_add_backref(pTHX_ SV *tsv, SV *sv)
+Perl_sv_add_backref(pTHX_ SV *const tsv, SV *const sv)
{
dVAR;
AV *av;
+ PERL_ARGS_ASSERT_SV_ADD_BACKREF;
+
if (SvTYPE(tsv) == SVt_PVHV) {
AV **const avp = Perl_hv_backreferences_p(aTHX_ (HV*)tsv);
} else {
av = newAV();
AvREAL_off(av);
- SvREFCNT_inc_simple_void(av);
+ SvREFCNT_inc_simple_void(av); /* see discussion above */
}
*avp = av;
}
av = newAV();
AvREAL_off(av);
sv_magic(tsv, (SV*)av, PERL_MAGIC_backref, NULL, 0);
- /* av now has a refcnt of 2, which avoids it getting freed
- * before us during global cleanup. The extra ref is removed
- * by magic_killbackrefs() when tsv is being freed */
+ /* av now has a refcnt of 2; see discussion above */
}
}
if (AvFILLp(av) >= AvMAX(av)) {
*/
STATIC void
-S_sv_del_backref(pTHX_ SV *tsv, SV *sv)
+S_sv_del_backref(pTHX_ SV *const tsv, SV *const sv)
{
dVAR;
AV *av = NULL;
SV **svp;
I32 i;
+ PERL_ARGS_ASSERT_SV_DEL_BACKREF;
+
if (SvTYPE(tsv) == SVt_PVHV && SvOOK(tsv)) {
av = *Perl_hv_backreferences_p(aTHX_ (HV*)tsv);
/* We mustn't attempt to "fix up" the hash here by moving the
if (mg)
av = (AV *)mg->mg_obj;
}
- if (!av) {
- if (PL_in_clean_all)
- return;
+
+ if (!av)
Perl_croak(aTHX_ "panic: del_backref");
- }
- if (SvIS_FREED(av))
- return;
+ assert(!SvIS_FREED(av));
svp = AvARRAY(av);
/* We shouldn't be in here more than once, but for paranoia reasons lets
}
int
-Perl_sv_kill_backrefs(pTHX_ SV *sv, AV *av)
+Perl_sv_kill_backrefs(pTHX_ SV *const sv, AV *const av)
{
SV **svp = AvARRAY(av);
+ PERL_ARGS_ASSERT_SV_KILL_BACKREFS;
PERL_UNUSED_ARG(sv);
- /* Not sure why the av can get freed ahead of its sv, but somehow it does
- in ext/B/t/bytecode.t test 15 (involving print <DATA>) */
- if (svp && !SvIS_FREED(av)) {
+ assert(!svp || !SvIS_FREED(av));
+ if (svp) {
SV *const *const last = svp + AvFILLp(av);
while (svp <= last) {
=for apidoc sv_insert
Inserts a string at the specified offset/length within the SV. Similar to
-the Perl substr() function.
+the Perl substr() function. Handles get magic.
+
+=for apidoc sv_insert_flags
+
+Same as C<sv_insert>, but the extra C<flags> are passed the C<SvPV_force_flags> that applies to C<bigstr>.
=cut
*/
void
-Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, const char *little, STRLEN littlelen)
+Perl_sv_insert_flags(pTHX_ SV *const bigstr, const STRLEN offset, const STRLEN len, const char *const little, const STRLEN littlelen, const U32 flags)
{
dVAR;
register char *big;
register I32 i;
STRLEN curlen;
+ PERL_ARGS_ASSERT_SV_INSERT_FLAGS;
if (!bigstr)
Perl_croak(aTHX_ "Can't modify non-existent substring");
- SvPV_force(bigstr, curlen);
+ SvPV_force_flags(bigstr, curlen, flags);
(void)SvPOK_only_UTF8(bigstr);
if (offset + len > curlen) {
SvGROW(bigstr, offset+len+1);
else if ((i = mid - big)) { /* faster from front */
midend -= littlelen;
mid = midend;
+ Move(big, midend - i, i, char);
sv_chop(bigstr,midend-i);
- big += i;
- while (i--)
- *--midend = *--big;
if (littlelen)
Move(little, mid, littlelen,char);
}
*/
void
-Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
+Perl_sv_replace(pTHX_ register SV *const sv, register SV *const nsv)
{
dVAR;
const U32 refcnt = SvREFCNT(sv);
+
+ PERL_ARGS_ASSERT_SV_REPLACE;
+
SV_CHECK_THINKFIRST_COW_DROP(sv);
if (SvREFCNT(nsv) != 1) {
Perl_croak(aTHX_ "panic: reference miscount on nsv in sv_replace() (%"
#else
StructCopy(nsv,sv,SV);
#endif
- /* Currently could join these into one piece of pointer arithmetic, but
- it would be unclear. */
- if(SvTYPE(sv) == SVt_IV)
+ if(SvTYPE(sv) == SVt_IV) {
SvANY(sv)
= (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
- else if (SvTYPE(sv) == SVt_RV) {
- SvANY(sv) = &sv->sv_u.svu_rv;
}
*/
void
-Perl_sv_clear(pTHX_ register SV *sv)
+Perl_sv_clear(pTHX_ register SV *const sv)
{
dVAR;
const U32 type = SvTYPE(sv);
const struct body_details *const sv_type_details
= bodies_by_type + type;
+ HV *stash;
- assert(sv);
+ PERL_ARGS_ASSERT_SV_CLEAR;
assert(SvREFCNT(sv) == 0);
+ assert(SvTYPE(sv) != SVTYPEMASK);
if (type <= SVt_IV) {
/* See the comment in sv.h about the collusion between this early
return and the overloading of the NULL and IV slots in the size
table. */
+ if (SvROK(sv)) {
+ SV * const target = SvRV(sv);
+ if (SvWEAKREF(sv))
+ sv_del_backref(target, sv);
+ else
+ SvREFCNT_dec(target);
+ }
+ SvFLAGS(sv) &= SVf_BREAK;
+ SvFLAGS(sv) |= SVTYPEMASK;
return;
}
if (SvOBJECT(sv)) {
- if (PL_defstash) { /* Still have a symbol table? */
+ if (PL_defstash && /* Still have a symbol table? */
+ SvDESTROYABLE(sv))
+ {
dSP;
HV* stash;
do {
Safefree(IoFMT_NAME(sv));
Safefree(IoBOTTOM_NAME(sv));
goto freescalar;
+ case SVt_REGEXP:
+ /* FIXME for plugins */
+ pregfree2((REGEXP*) sv);
+ goto freescalar;
case SVt_PVCV:
case SVt_PVFM:
cv_undef((CV*)sv);
hv_undef((HV*)sv);
break;
case SVt_PVAV:
+ if (PL_comppad == (AV*)sv) {
+ PL_comppad = NULL;
+ PL_curpad = NULL;
+ }
av_undef((AV*)sv);
break;
case SVt_PVLV:
SvREFCNT_dec(LvTARG(sv));
case SVt_PVGV:
if (isGV_with_GP(sv)) {
+ if(GvCVu((GV*)sv) && (stash = GvSTASH((GV*)sv)) && HvNAME_get(stash))
+ mro_method_changed_in(stash);
gp_free((GV*)sv);
if (GvNAME_HEK(sv))
unshare_hek(GvNAME_HEK(sv));
- /* If we're in a stash, we don't own a reference to it. However it does
- have a back reference to us, which needs to be cleared. */
- if (!SvVALID(sv) && GvSTASH(sv))
- sv_del_backref((SV*)GvSTASH(sv), sv);
- }
+ /* If we're in a stash, we don't own a reference to it. However it does
+ have a back reference to us, which needs to be cleared. */
+ if (!SvVALID(sv) && (stash = GvSTASH(sv)))
+ sv_del_backref((SV*)stash, sv);
+ }
+ /* FIXME. There are probably more unreferenced pointers to SVs in the
+ interpreter struct that we should check and tidy in a similar
+ fashion to this: */
+ if ((GV*)sv == PL_last_in_gv)
+ PL_last_in_gv = NULL;
case SVt_PVMG:
case SVt_PVNV:
case SVt_PVIV:
+ case SVt_PV:
freescalar:
/* Don't bother with SvOOK_off(sv); as we're only going to free it. */
if (SvOOK(sv)) {
- SvPV_set(sv, SvPVX_mutable(sv) - SvIVX(sv));
+ STRLEN offset;
+ SvOOK_offset(sv, offset);
+ SvPV_set(sv, SvPVX_mutable(sv) - offset);
/* Don't even bother with turning off the OOK flag. */
}
- case SVt_PV:
- case SVt_RV:
if (SvROK(sv)) {
SV * const target = SvRV(sv);
if (SvWEAKREF(sv))
*/
SV *
-Perl_sv_newref(pTHX_ SV *sv)
+Perl_sv_newref(pTHX_ SV *const sv)
{
PERL_UNUSED_CONTEXT;
if (sv)
*/
void
-Perl_sv_free(pTHX_ SV *sv)
+Perl_sv_free(pTHX_ SV *const sv)
{
dVAR;
if (!sv)
return;
}
if (ckWARN_d(WARN_INTERNAL)) {
+#ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
+ Perl_dump_sv_child(aTHX_ sv);
+#else
+ #ifdef DEBUG_LEAKING_SCALARS
+ sv_dump(sv);
+ #endif
+#ifdef DEBUG_LEAKING_SCALARS_ABORT
+ if (PL_warnhook == PERL_WARNHOOK_FATAL
+ || ckDEAD(packWARN(WARN_INTERNAL))) {
+ /* Don't let Perl_warner cause us to escape our fate: */
+ abort();
+ }
+#endif
+ /* This may not return: */
Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
"Attempt to free unreferenced scalar: SV 0x%"UVxf
pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
-#ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
- Perl_dump_sv_child(aTHX_ sv);
#endif
}
+#ifdef DEBUG_LEAKING_SCALARS_ABORT
+ abort();
+#endif
return;
}
if (--(SvREFCNT(sv)) > 0)
}
void
-Perl_sv_free2(pTHX_ SV *sv)
+Perl_sv_free2(pTHX_ SV *const sv)
{
dVAR;
+
+ PERL_ARGS_ASSERT_SV_FREE2;
+
#ifdef DEBUGGING
if (SvTEMP(sv)) {
if (ckWARN_d(WARN_DEBUGGING))
*/
STRLEN
-Perl_sv_len(pTHX_ register SV *sv)
+Perl_sv_len(pTHX_ register SV *const sv)
{
STRLEN len;
*/
STRLEN
-Perl_sv_len_utf8(pTHX_ register SV *sv)
+Perl_sv_len_utf8(pTHX_ register SV *const sv)
{
if (!sv)
return 0;
if (PL_utf8cache) {
STRLEN ulen;
- MAGIC *mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : 0;
+ MAGIC *mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL;
if (mg && mg->mg_len != -1) {
ulen = mg->mg_len;
{
const U8 *s = start;
+ PERL_ARGS_ASSERT_SV_POS_U2B_FORWARDS;
+
while (s < send && uoffset--)
s += UTF8SKIP(s);
if (s > send) {
the passed in UTF-8 offset. */
static STRLEN
S_sv_pos_u2b_midway(const U8 *const start, const U8 *send,
- STRLEN uoffset, STRLEN uend)
+ const STRLEN uoffset, const STRLEN uend)
{
STRLEN backw = uend - uoffset;
+
+ PERL_ARGS_ASSERT_SV_POS_U2B_MIDWAY;
+
if (uoffset < 2 * backw) {
/* The assumption is that going forwards is twice the speed of going
forward (that's where the 2 * backw comes from).
will be used to reduce the amount of linear searching. The cache will be
created if necessary, and the found value offered to it for update. */
static STRLEN
-S_sv_pos_u2b_cached(pTHX_ SV *sv, MAGIC **mgp, const U8 *const start,
- const U8 *const send, STRLEN uoffset,
- STRLEN uoffset0, STRLEN boffset0) {
+S_sv_pos_u2b_cached(pTHX_ SV *const sv, MAGIC **const mgp, const U8 *const start,
+ const U8 *const send, const STRLEN uoffset,
+ STRLEN uoffset0, STRLEN boffset0)
+{
STRLEN boffset = 0; /* Actually always set, but let's keep gcc happy. */
bool found = FALSE;
+ PERL_ARGS_ASSERT_SV_POS_U2B_CACHED;
+
assert (uoffset >= uoffset0);
if (SvMAGICAL(sv) && !SvREADONLY(sv) && PL_utf8cache
boffset = real_boffset;
}
- S_utf8_mg_pos_cache_update(aTHX_ sv, mgp, boffset, uoffset, send - start);
+ if (PL_utf8cache)
+ utf8_mg_pos_cache_update(sv, mgp, boffset, uoffset, send - start);
return boffset;
}
*/
void
-Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp)
+Perl_sv_pos_u2b(pTHX_ register SV *const sv, I32 *const offsetp, I32 *const lenp)
{
const U8 *start;
STRLEN len;
+ PERL_ARGS_ASSERT_SV_POS_U2B;
+
if (!sv)
return;
from.
*/
static void
-S_utf8_mg_pos_cache_update(pTHX_ SV *sv, MAGIC **mgp, STRLEN byte, STRLEN utf8,
- STRLEN blen)
+S_utf8_mg_pos_cache_update(pTHX_ SV *const sv, MAGIC **const mgp, const STRLEN byte,
+ const STRLEN utf8, const STRLEN blen)
{
STRLEN *cache;
+
+ PERL_ARGS_ASSERT_UTF8_MG_POS_CACHE_UPDATE;
+
if (SvREADONLY(sv))
return;
assumption is made as in S_sv_pos_u2b_midway(), namely that walking
backward is half the speed of walking forward. */
static STRLEN
-S_sv_pos_b2u_midway(pTHX_ const U8 *s, const U8 *const target, const U8 *end,
- STRLEN endu)
+S_sv_pos_b2u_midway(pTHX_ const U8 *const s, const U8 *const target,
+ const U8 *end, STRLEN endu)
{
const STRLEN forw = target - s;
STRLEN backw = end - target;
+ PERL_ARGS_ASSERT_SV_POS_B2U_MIDWAY;
+
if (forw < 2 * backw) {
return utf8_length(s, target);
}
*
*/
void
-Perl_sv_pos_b2u(pTHX_ register SV* sv, I32* offsetp)
+Perl_sv_pos_b2u(pTHX_ register SV *const sv, I32 *const offsetp)
{
const U8* s;
const STRLEN byte = *offsetp;
const U8* send;
bool found = FALSE;
+ PERL_ARGS_ASSERT_SV_POS_B2U;
+
if (!sv)
return;
}
*offsetp = len;
- S_utf8_mg_pos_cache_update(aTHX_ sv, &mg, byte, len, blen);
+ if (PL_utf8cache)
+ utf8_mg_pos_cache_update(sv, &mg, byte, len, blen);
}
/*
* invalidate pv1, so we may need to make a copy */
if (sv1 == sv2 && (SvTHINKFIRST(sv1) || SvGMAGICAL(sv1))) {
pv1 = SvPV_const(sv1, cur1);
- sv1 = sv_2mortal(newSVpvn(pv1, cur1));
- if (SvUTF8(sv2)) SvUTF8_on(sv1);
+ sv1 = newSVpvn_flags(pv1, cur1, SVs_TEMP | SvUTF8(sv2));
}
pv1 = SvPV_const(sv1, cur1);
}
*/
I32
-Perl_sv_cmp(pTHX_ register SV *sv1, register SV *sv2)
+Perl_sv_cmp(pTHX_ register SV *const sv1, register SV *const sv2)
{
dVAR;
STRLEN cur1, cur2;
Compares the strings in two SVs in a locale-aware manner. Is UTF-8 and
'use bytes' aware, handles get magic, and will coerce its args to strings
-if necessary. See also C<sv_cmp_locale>. See also C<sv_cmp>.
+if necessary. See also C<sv_cmp>.
=cut
*/
I32
-Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2)
+Perl_sv_cmp_locale(pTHX_ register SV *const sv1, register SV *const sv2)
{
dVAR;
#ifdef USE_LOCALE_COLLATE
*/
char *
-Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp)
+Perl_sv_collxfrm(pTHX_ SV *const sv, STRLEN *const nxp)
{
dVAR;
MAGIC *mg;
+ PERL_ARGS_ASSERT_SV_COLLXFRM;
+
mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_collxfrm) : (MAGIC *) NULL;
if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
const char *s;
Safefree(mg->mg_ptr);
s = SvPV_const(sv, len);
if ((xf = mem_collxfrm(s, len, &xlen))) {
- if (SvREADONLY(sv)) {
- SAVEFREEPV(xf);
- *nxp = xlen;
- return xf + sizeof(PL_collation_ix);
- }
if (! mg) {
#ifdef PERL_OLD_COPY_ON_WRITE
if (SvIsCOW(sv))
*/
char *
-Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
+Perl_sv_gets(pTHX_ register SV *const sv, register PerlIO *const fp, I32 append)
{
dVAR;
const char *rsptr;
I32 i = 0;
I32 rspara = 0;
+ PERL_ARGS_ASSERT_SV_GETS;
+
if (SvTHINKFIRST(sv))
sv_force_normal_flags(sv, append ? 0 : SV_COW_DROP_PV);
/* XXX. If you make this PVIV, then copy on write can copy scalars read
I32 bytesread;
char *buffer;
U32 recsize;
+#ifdef VMS
+ int fd;
+#endif
/* Grab the size of the record we're getting */
recsize = SvUV(SvRV(PL_rs)); /* RsRECORD() guarantees > 0. */
/* doing, but we've got no other real choice - except avoid stdio
as implementation - perhaps write a :vms layer ?
*/
- bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize);
+ fd = PerlIO_fileno(fp);
+ if (fd == -1) { /* in-memory file from PerlIO::Scalar */
+ bytesread = PerlIO_read(fp, buffer, recsize);
+ }
+ else {
+ bytesread = PerlLIO_read(fd, buffer, recsize);
+ }
#else
bytesread = PerlIO_read(fp, buffer, recsize);
#endif
if (bytesread < 0)
bytesread = 0;
- SvCUR_set(sv, bytesread += append);
+ SvCUR_set(sv, bytesread + append);
buffer[bytesread] = '\0';
goto return_string_or_null;
}
*/
void
-Perl_sv_inc(pTHX_ register SV *sv)
+Perl_sv_inc(pTHX_ register SV *const sv)
{
dVAR;
register char *d;
return;
}
if (flags & SVp_NOK) {
+ const NV was = SvNVX(sv);
+ if (NV_OVERFLOWS_INTEGERS_AT &&
+ was >= NV_OVERFLOWS_INTEGERS_AT && ckWARN(WARN_IMPRECISION)) {
+ Perl_warner(aTHX_ packWARN(WARN_IMPRECISION),
+ "Lost precision when incrementing %" NVff " by 1",
+ was);
+ }
(void)SvNOK_only(sv);
- SvNV_set(sv, SvNVX(sv) + 1.0);
+ SvNV_set(sv, was + 1.0);
return;
}
*/
void
-Perl_sv_dec(pTHX_ register SV *sv)
+Perl_sv_dec(pTHX_ register SV *const sv)
{
dVAR;
int flags;
SvUV_set(sv, SvUVX(sv) - 1);
}
} else {
- if (SvIVX(sv) == IV_MIN)
- sv_setnv(sv, (NV)IV_MIN - 1.0);
+ if (SvIVX(sv) == IV_MIN) {
+ sv_setnv(sv, (NV)IV_MIN);
+ goto oops_its_num;
+ }
else {
(void)SvIOK_only(sv);
SvIV_set(sv, SvIVX(sv) - 1);
return;
}
if (flags & SVp_NOK) {
- SvNV_set(sv, SvNVX(sv) - 1.0);
- (void)SvNOK_only(sv);
- return;
+ oops_its_num:
+ {
+ const NV was = SvNVX(sv);
+ if (NV_OVERFLOWS_INTEGERS_AT &&
+ was <= -NV_OVERFLOWS_INTEGERS_AT && ckWARN(WARN_IMPRECISION)) {
+ Perl_warner(aTHX_ packWARN(WARN_IMPRECISION),
+ "Lost precision when decrementing %" NVff " by 1",
+ was);
+ }
+ (void)SvNOK_only(sv);
+ SvNV_set(sv, was - 1.0);
+ return;
+ }
}
if (!(flags & SVp_POK)) {
if ((flags & SVTYPEMASK) < SVt_PVIV)
* permanent location. */
SV *
-Perl_sv_mortalcopy(pTHX_ SV *oldstr)
+Perl_sv_mortalcopy(pTHX_ SV *const oldstr)
{
dVAR;
register SV *sv;
return sv;
}
+
+/*
+=for apidoc newSVpvn_flags
+
+Creates a new SV and copies a string into it. The reference count for the
+SV is set to 1. Note that if C<len> is zero, Perl will create a zero length
+string. You are responsible for ensuring that the source string is at least
+C<len> bytes long. If the C<s> argument is NULL the new SV will be undefined.
+Currently the only flag bits accepted are C<SVf_UTF8> and C<SVs_TEMP>.
+If C<SVs_TEMP> is set, then C<sv2mortal()> is called on the result before
+returning. If C<SVf_UTF8> is set, then it will be set on the new SV.
+C<newSVpvn_utf8()> is a convenience wrapper for this function, defined as
+
+ #define newSVpvn_utf8(s, len, u) \
+ newSVpvn_flags((s), (len), (u) ? SVf_UTF8 : 0)
+
+=cut
+*/
+
+SV *
+Perl_newSVpvn_flags(pTHX_ const char *const s, const STRLEN len, const U32 flags)
+{
+ dVAR;
+ register SV *sv;
+
+ /* All the flags we don't support must be zero.
+ And we're new code so I'm going to assert this from the start. */
+ assert(!(flags & ~(SVf_UTF8|SVs_TEMP)));
+ new_SV(sv);
+ sv_setpvn(sv,s,len);
+ SvFLAGS(sv) |= (flags & SVf_UTF8);
+ return (flags & SVs_TEMP) ? sv_2mortal(sv) : sv;
+}
+
/*
=for apidoc sv_2mortal
*/
SV *
-Perl_sv_2mortal(pTHX_ register SV *sv)
+Perl_sv_2mortal(pTHX_ register SV *const sv)
{
dVAR;
if (!sv)
*/
SV *
-Perl_newSVpv(pTHX_ const char *s, STRLEN len)
+Perl_newSVpv(pTHX_ const char *const s, const STRLEN len)
{
dVAR;
register SV *sv;
*/
SV *
-Perl_newSVpvn(pTHX_ const char *s, STRLEN len)
+Perl_newSVpvn(pTHX_ const char *const s, const STRLEN len)
{
dVAR;
register SV *sv;
return sv;
}
-
/*
=for apidoc newSVhek
*/
SV *
-Perl_newSVhek(pTHX_ const HEK *hek)
+Perl_newSVhek(pTHX_ const HEK *const hek)
{
dVAR;
if (!hek) {
Creates a new SV with its SvPVX_const pointing to a shared string in the string
table. If the string does not already exist in the table, it is created
-first. Turns on READONLY and FAKE. The string's hash is stored in the UV
-slot of the SV; if the C<hash> parameter is non-zero, that value is used;
-otherwise the hash is computed. The idea here is that as the string table
-is used for shared hash keys these strings will have SvPVX_const == HeKEY and
-hash lookup will avoid string compare.
+first. Turns on READONLY and FAKE. If the C<hash> parameter is non-zero, that
+value is used; otherwise the hash is computed. The string's hash can be later
+be retrieved from the SV with the C<SvSHARED_HASH()> macro. The idea here is
+that as the string table is used for shared hash keys these strings will have
+SvPVX_const == HeKEY and hash lookup will avoid string compare.
=cut
*/
if (!hash)
PERL_HASH(hash, src, len);
new_SV(sv);
+ /* The logic for this is inlined in S_mro_get_linear_isa_dfs(), so if it
+ changes here, update it there too. */
sv_upgrade(sv, SVt_PV);
SvPV_set(sv, sharepvn(src, is_utf8?-len:len, hash));
SvCUR_set(sv, len);
*/
SV *
-Perl_newSVpvf_nocontext(const char* pat, ...)
+Perl_newSVpvf_nocontext(const char *const pat, ...)
{
dTHX;
register SV *sv;
va_list args;
+
+ PERL_ARGS_ASSERT_NEWSVPVF_NOCONTEXT;
+
va_start(args, pat);
sv = vnewSVpvf(pat, &args);
va_end(args);
*/
SV *
-Perl_newSVpvf(pTHX_ const char* pat, ...)
+Perl_newSVpvf(pTHX_ const char *const pat, ...)
{
register SV *sv;
va_list args;
+
+ PERL_ARGS_ASSERT_NEWSVPVF;
+
va_start(args, pat);
sv = vnewSVpvf(pat, &args);
va_end(args);
/* backend for newSVpvf() and newSVpvf_nocontext() */
SV *
-Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args)
+Perl_vnewSVpvf(pTHX_ const char *const pat, va_list *const args)
{
dVAR;
register SV *sv;
+
+ PERL_ARGS_ASSERT_VNEWSVPVF;
+
new_SV(sv);
sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
return sv;
*/
SV *
-Perl_newSVnv(pTHX_ NV n)
+Perl_newSVnv(pTHX_ const NV n)
{
dVAR;
register SV *sv;
*/
SV *
-Perl_newSViv(pTHX_ IV i)
+Perl_newSViv(pTHX_ const IV i)
{
dVAR;
register SV *sv;
*/
SV *
-Perl_newSVuv(pTHX_ UV u)
+Perl_newSVuv(pTHX_ const UV u)
{
dVAR;
register SV *sv;
}
/*
+=for apidoc newSV_type
+
+Creates a new SV, of the type specified. The reference count for the new SV
+is set to 1.
+
+=cut
+*/
+
+SV *
+Perl_newSV_type(pTHX_ const svtype type)
+{
+ register SV *sv;
+
+ new_SV(sv);
+ sv_upgrade(sv, type);
+ return sv;
+}
+
+/*
=for apidoc newRV_noinc
Creates an RV wrapper for an SV. The reference count for the original
*/
SV *
-Perl_newRV_noinc(pTHX_ SV *tmpRef)
+Perl_newRV_noinc(pTHX_ SV *const tmpRef)
{
dVAR;
- register SV *sv;
+ register SV *sv = newSV_type(SVt_IV);
+
+ PERL_ARGS_ASSERT_NEWRV_NOINC;
- new_SV(sv);
- sv_upgrade(sv, SVt_RV);
SvTEMP_off(tmpRef);
SvRV_set(sv, tmpRef);
SvROK_on(sv);
*/
SV *
-Perl_newRV(pTHX_ SV *sv)
+Perl_newRV(pTHX_ SV *const sv)
{
dVAR;
+
+ PERL_ARGS_ASSERT_NEWRV;
+
return newRV_noinc(SvREFCNT_inc_simple_NN(sv));
}
*/
SV *
-Perl_newSVsv(pTHX_ register SV *old)
+Perl_newSVsv(pTHX_ register SV *const old)
{
dVAR;
register SV *sv;
*/
void
-Perl_sv_reset(pTHX_ register const char *s, HV *stash)
+Perl_sv_reset(pTHX_ register const char *s, HV *const stash)
{
dVAR;
char todo[PERL_UCHAR_MAX+1];
+ PERL_ARGS_ASSERT_SV_RESET;
+
if (!stash)
return;
if (!*s) { /* reset ?? searches */
MAGIC * const 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;
+ const U32 count = mg->mg_len / sizeof(PMOP**);
+ PMOP **pmp = (PMOP**) mg->mg_ptr;
+ PMOP *const *const end = pmp + count;
+
+ while (pmp < end) {
+#ifdef USE_ITHREADS
+ SvREADONLY_off(PL_regex_pad[(*pmp)->op_pmoffset]);
+#else
+ (*pmp)->op_pmflags &= ~PMf_USED;
+#endif
+ ++pmp;
}
}
return;
*/
IO*
-Perl_sv_2io(pTHX_ SV *sv)
+Perl_sv_2io(pTHX_ SV *const sv)
{
IO* io;
GV* gv;
+ PERL_ARGS_ASSERT_SV_2IO;
+
switch (SvTYPE(sv)) {
case SVt_PVIO:
io = (IO*)sv;
break;
case SVt_PVGV:
- gv = (GV*)sv;
- io = GvIO(gv);
- if (!io)
- Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
- break;
+ if (isGV_with_GP(sv)) {
+ gv = (GV*)sv;
+ io = GvIO(gv);
+ if (!io)
+ Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
+ break;
+ }
+ /* FALL THROUGH */
default:
if (!SvOK(sv))
Perl_croak(aTHX_ PL_no_usym, "filehandle");
*/
CV *
-Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
+Perl_sv_2cv(pTHX_ SV *sv, HV **const st, GV **const gvp, const I32 lref)
{
dVAR;
GV *gv = NULL;
CV *cv = NULL;
+ PERL_ARGS_ASSERT_SV_2CV;
+
if (!sv) {
*st = NULL;
*gvp = NULL;
*gvp = NULL;
return NULL;
case SVt_PVGV:
- gv = (GV*)sv;
- *gvp = gv;
- *st = GvESTASH(gv);
- goto fix_gv;
+ if (isGV_with_GP(sv)) {
+ gv = (GV*)sv;
+ *gvp = gv;
+ *st = GvESTASH(gv);
+ goto fix_gv;
+ }
+ /* FALL THROUGH */
default:
- SvGETMAGIC(sv);
if (SvROK(sv)) {
SV * const *sp = &sv; /* Used in tryAMAGICunDEREF macro. */
+ SvGETMAGIC(sv);
tryAMAGICunDEREF(to_cv);
sv = SvRV(sv);
*st = CvSTASH(cv);
return cv;
}
- else if(isGV(sv))
+ else if(isGV_with_GP(sv))
gv = (GV*)sv;
else
Perl_croak(aTHX_ "Not a subroutine reference");
}
- else if (isGV(sv))
+ else if (isGV_with_GP(sv)) {
+ SvGETMAGIC(sv);
gv = (GV*)sv;
+ }
else
- gv = gv_fetchsv(sv, lref, SVt_PVCV);
+ gv = gv_fetchsv(sv, lref, SVt_PVCV); /* Calls get magic */
*gvp = gv;
if (!gv) {
*st = NULL;
return NULL;
}
/* Some flags to gv_fetchsv mean don't really create the GV */
- if (SvTYPE(gv) != SVt_PVGV) {
+ if (!isGV_with_GP(gv)) {
*st = NULL;
return NULL;
}
LEAVE;
if (!GvCVu(gv))
Perl_croak(aTHX_ "Unable to create sub named \"%"SVf"\"",
- SVfARG(sv));
+ SVfARG(SvOK(sv) ? sv : &PL_sv_no));
}
return GvCVu(gv);
}
*/
I32
-Perl_sv_true(pTHX_ register SV *sv)
+Perl_sv_true(pTHX_ register SV *const sv)
{
if (!sv)
return 0;
*/
char *
-Perl_sv_pvn_force_flags(pTHX_ SV *sv, STRLEN *lp, I32 flags)
+Perl_sv_pvn_force_flags(pTHX_ SV *const sv, STRLEN *const lp, const I32 flags)
{
dVAR;
+
+ PERL_ARGS_ASSERT_SV_PVN_FORCE_FLAGS;
+
if (SvTHINKFIRST(sv) && !SvROK(sv))
sv_force_normal_flags(sv, 0);
else
Perl_croak(aTHX_ "Can't coerce readonly %s to string", ref);
}
- if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM)
+ if ((SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM)
+ || isGV_with_GP(sv))
Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
OP_NAME(PL_op));
s = sv_2pv_flags(sv, &len, flags);
SvGROW(sv, len + 1);
Move(s,SvPVX(sv),len,char);
SvCUR_set(sv, len);
- *SvEND(sv) = '\0';
+ SvPVX(sv)[len] = '\0';
}
if (!SvPOK(sv)) {
SvPOK_on(sv); /* validate pointer */
*/
char *
-Perl_sv_pvbyten_force(pTHX_ SV *sv, STRLEN *lp)
+Perl_sv_pvbyten_force(pTHX_ SV *const sv, STRLEN *const lp)
{
+ PERL_ARGS_ASSERT_SV_PVBYTEN_FORCE;
+
sv_pvn_force(sv,lp);
sv_utf8_downgrade(sv,0);
*lp = SvCUR(sv);
*/
char *
-Perl_sv_pvutf8n_force(pTHX_ SV *sv, STRLEN *lp)
+Perl_sv_pvutf8n_force(pTHX_ SV *const sv, STRLEN *const lp)
{
+ PERL_ARGS_ASSERT_SV_PVUTF8N_FORCE;
+
sv_pvn_force(sv,lp);
sv_utf8_upgrade(sv);
*lp = SvCUR(sv);
*/
const char *
-Perl_sv_reftype(pTHX_ const SV *sv, int ob)
+Perl_sv_reftype(pTHX_ const SV *const sv, const int ob)
{
+ PERL_ARGS_ASSERT_SV_REFTYPE;
+
/* 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)) {
case SVt_NULL:
case SVt_IV:
case SVt_NV:
- case SVt_RV:
case SVt_PV:
case SVt_PVIV:
case SVt_PVNV:
case SVt_PVAV: return "ARRAY";
case SVt_PVHV: return "HASH";
case SVt_PVCV: return "CODE";
- case SVt_PVGV: return "GLOB";
+ case SVt_PVGV: return (char *) (isGV_with_GP(sv)
+ ? "GLOB" : "SCALAR");
case SVt_PVFM: return "FORMAT";
case SVt_PVIO: return "IO";
case SVt_BIND: return "BIND";
+ case SVt_REGEXP: return "REGEXP";
default: return "UNKNOWN";
}
}
*/
int
-Perl_sv_isa(pTHX_ SV *sv, const char *name)
+Perl_sv_isa(pTHX_ SV *sv, const char *const name)
{
const char *hvname;
+
+ PERL_ARGS_ASSERT_SV_ISA;
+
if (!sv)
return 0;
SvGETMAGIC(sv);
*/
SV*
-Perl_newSVrv(pTHX_ SV *rv, const char *classname)
+Perl_newSVrv(pTHX_ SV *const rv, const char *const classname)
{
dVAR;
SV *sv;
+ PERL_ARGS_ASSERT_NEWSVRV;
+
new_SV(sv);
SV_CHECK_THINKFIRST_COW_DROP(rv);
SvFLAGS(rv) = 0;
SvREFCNT(rv) = refcnt;
- sv_upgrade(rv, SVt_RV);
+ sv_upgrade(rv, SVt_IV);
} else if (SvROK(rv)) {
SvREFCNT_dec(SvRV(rv));
- } else if (SvTYPE(rv) < SVt_RV)
- sv_upgrade(rv, SVt_RV);
- else if (SvTYPE(rv) > SVt_RV) {
- SvPV_free(rv);
- SvCUR_set(rv, 0);
- SvLEN_set(rv, 0);
+ } else {
+ prepare_SV_for_RV(rv);
}
SvOK_off(rv);
*/
SV*
-Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv)
+Perl_sv_setref_pv(pTHX_ SV *const rv, const char *const classname, void *const pv)
{
dVAR;
+
+ PERL_ARGS_ASSERT_SV_SETREF_PV;
+
if (!pv) {
sv_setsv(rv, &PL_sv_undef);
SvSETMAGIC(rv);
*/
SV*
-Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv)
+Perl_sv_setref_iv(pTHX_ SV *const rv, const char *const classname, const IV iv)
{
+ PERL_ARGS_ASSERT_SV_SETREF_IV;
+
sv_setiv(newSVrv(rv,classname), iv);
return rv;
}
*/
SV*
-Perl_sv_setref_uv(pTHX_ SV *rv, const char *classname, UV uv)
+Perl_sv_setref_uv(pTHX_ SV *const rv, const char *const classname, const UV uv)
{
+ PERL_ARGS_ASSERT_SV_SETREF_UV;
+
sv_setuv(newSVrv(rv,classname), uv);
return rv;
}
*/
SV*
-Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv)
+Perl_sv_setref_nv(pTHX_ SV *const rv, const char *const classname, const NV nv)
{
+ PERL_ARGS_ASSERT_SV_SETREF_NV;
+
sv_setnv(newSVrv(rv,classname), nv);
return rv;
}
*/
SV*
-Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, const char *pv, STRLEN n)
+Perl_sv_setref_pvn(pTHX_ SV *const rv, const char *const classname,
+ const char *const pv, const STRLEN n)
{
+ PERL_ARGS_ASSERT_SV_SETREF_PVN;
+
sv_setpvn(newSVrv(rv,classname), pv, n);
return rv;
}
*/
SV*
-Perl_sv_bless(pTHX_ SV *sv, HV *stash)
+Perl_sv_bless(pTHX_ SV *const sv, HV *const stash)
{
dVAR;
SV *tmpRef;
+
+ PERL_ARGS_ASSERT_SV_BLESS;
+
if (!SvROK(sv))
Perl_croak(aTHX_ "Can't bless non-reference value");
tmpRef = SvRV(sv);
if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
+ if (SvIsCOW(tmpRef))
+ sv_force_normal_flags(tmpRef, 0);
if (SvREADONLY(tmpRef))
Perl_croak(aTHX_ PL_no_modify);
if (SvOBJECT(tmpRef)) {
*/
STATIC void
-S_sv_unglob(pTHX_ SV *sv)
+S_sv_unglob(pTHX_ SV *const sv)
{
dVAR;
void *xpvmg;
+ HV *stash;
SV * const temp = sv_newmortal();
+ PERL_ARGS_ASSERT_SV_UNGLOB;
+
assert(SvTYPE(sv) == SVt_PVGV);
SvFAKE_off(sv);
gv_efullname3(temp, (GV *) sv, "*");
if (GvGP(sv)) {
+ if(GvCVu((GV*)sv) && (stash = GvSTASH((GV*)sv)) && HvNAME_get(stash))
+ mro_method_changed_in(stash);
gp_free((GV*)sv);
}
if (GvSTASH(sv)) {
*/
void
-Perl_sv_unref_flags(pTHX_ SV *ref, U32 flags)
+Perl_sv_unref_flags(pTHX_ SV *const ref, const U32 flags)
{
SV* const target = SvRV(ref);
+ PERL_ARGS_ASSERT_SV_UNREF_FLAGS;
+
if (SvWEAKREF(ref)) {
sv_del_backref(target, ref);
SvWEAKREF_off(ref);
*/
void
-Perl_sv_untaint(pTHX_ SV *sv)
+Perl_sv_untaint(pTHX_ SV *const sv)
{
+ PERL_ARGS_ASSERT_SV_UNTAINT;
+
if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint);
if (mg)
*/
bool
-Perl_sv_tainted(pTHX_ SV *sv)
+Perl_sv_tainted(pTHX_ SV *const sv)
{
+ PERL_ARGS_ASSERT_SV_TAINTED;
+
if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
const MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint);
if (mg && (mg->mg_len & 1) )
*/
void
-Perl_sv_setpviv(pTHX_ SV *sv, IV iv)
+Perl_sv_setpviv(pTHX_ SV *const sv, const IV iv)
{
char buf[TYPE_CHARS(UV)];
char *ebuf;
char * const ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
+ PERL_ARGS_ASSERT_SV_SETPVIV;
+
sv_setpvn(sv, ptr, ebuf - ptr);
}
*/
void
-Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv)
+Perl_sv_setpviv_mg(pTHX_ SV *const sv, const IV iv)
{
+ PERL_ARGS_ASSERT_SV_SETPVIV_MG;
+
sv_setpviv(sv, iv);
SvSETMAGIC(sv);
}
*/
void
-Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...)
+Perl_sv_setpvf_nocontext(SV *const sv, const char *const pat, ...)
{
dTHX;
va_list args;
+
+ PERL_ARGS_ASSERT_SV_SETPVF_NOCONTEXT;
+
va_start(args, pat);
sv_vsetpvf(sv, pat, &args);
va_end(args);
*/
void
-Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...)
+Perl_sv_setpvf_mg_nocontext(SV *const sv, const char *const pat, ...)
{
dTHX;
va_list args;
+
+ PERL_ARGS_ASSERT_SV_SETPVF_MG_NOCONTEXT;
+
va_start(args, pat);
sv_vsetpvf_mg(sv, pat, &args);
va_end(args);
*/
void
-Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...)
+Perl_sv_setpvf(pTHX_ SV *const sv, const char *const pat, ...)
{
va_list args;
+
+ PERL_ARGS_ASSERT_SV_SETPVF;
+
va_start(args, pat);
sv_vsetpvf(sv, pat, &args);
va_end(args);
*/
void
-Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args)
+Perl_sv_vsetpvf(pTHX_ SV *const sv, const char *const pat, va_list *const args)
{
+ PERL_ARGS_ASSERT_SV_VSETPVF;
+
sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
}
*/
void
-Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...)
+Perl_sv_setpvf_mg(pTHX_ SV *const sv, const char *const pat, ...)
{
va_list args;
+
+ PERL_ARGS_ASSERT_SV_SETPVF_MG;
+
va_start(args, pat);
sv_vsetpvf_mg(sv, pat, &args);
va_end(args);
*/
void
-Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
+Perl_sv_vsetpvf_mg(pTHX_ SV *const sv, const char *const pat, va_list *const args)
{
+ PERL_ARGS_ASSERT_SV_VSETPVF_MG;
+
sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
SvSETMAGIC(sv);
}
*/
void
-Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...)
+Perl_sv_catpvf_nocontext(SV *const sv, const char *const pat, ...)
{
dTHX;
va_list args;
+
+ PERL_ARGS_ASSERT_SV_CATPVF_NOCONTEXT;
+
va_start(args, pat);
sv_vcatpvf(sv, pat, &args);
va_end(args);
*/
void
-Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...)
+Perl_sv_catpvf_mg_nocontext(SV *const sv, const char *const pat, ...)
{
dTHX;
va_list args;
+
+ PERL_ARGS_ASSERT_SV_CATPVF_MG_NOCONTEXT;
+
va_start(args, pat);
sv_vcatpvf_mg(sv, pat, &args);
va_end(args);
=cut */
void
-Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...)
+Perl_sv_catpvf(pTHX_ SV *const sv, const char *const pat, ...)
{
va_list args;
+
+ PERL_ARGS_ASSERT_SV_CATPVF;
+
va_start(args, pat);
sv_vcatpvf(sv, pat, &args);
va_end(args);
*/
void
-Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args)
+Perl_sv_vcatpvf(pTHX_ SV *const sv, const char *const pat, va_list *const args)
{
+ PERL_ARGS_ASSERT_SV_VCATPVF;
+
sv_vcatpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
}
*/
void
-Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...)
+Perl_sv_catpvf_mg(pTHX_ SV *const sv, const char *const pat, ...)
{
va_list args;
+
+ PERL_ARGS_ASSERT_SV_CATPVF_MG;
+
va_start(args, pat);
sv_vcatpvf_mg(sv, pat, &args);
va_end(args);
*/
void
-Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
+Perl_sv_vcatpvf_mg(pTHX_ SV *const sv, const char *const pat, va_list *const args)
{
+ PERL_ARGS_ASSERT_SV_VCATPVF_MG;
+
sv_vcatpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
SvSETMAGIC(sv);
}
*/
void
-Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
+Perl_sv_vsetpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen,
+ va_list *const args, SV **const svargs, const I32 svmax, bool *const maybe_tainted)
{
+ PERL_ARGS_ASSERT_SV_VSETPVFN;
+
sv_setpvn(sv, "", 0);
sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
}
STATIC I32
-S_expect_number(pTHX_ char** pattern)
+S_expect_number(pTHX_ char **const pattern)
{
dVAR;
I32 var = 0;
+
+ PERL_ARGS_ASSERT_EXPECT_NUMBER;
+
switch (**pattern) {
case '1': case '2': case '3':
case '4': case '5': case '6':
}
STATIC char *
-S_F0convert(NV nv, char *endbuf, STRLEN *len)
+S_F0convert(NV nv, char *const endbuf, STRLEN *const len)
{
const int neg = nv < 0;
UV uv;
+ PERL_ARGS_ASSERT_F0CONVERT;
+
if (neg)
nv = -nv;
if (nv < UV_MAX) {
/* 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)
+Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen,
+ va_list *const args, SV **const svargs, const I32 svmax, bool *const maybe_tainted)
{
dVAR;
char *p;
/* large enough for "%#.#f" --chip */
/* what about long double NVs? --jhi */
+ PERL_ARGS_ASSERT_SV_VCATPVFN;
PERL_UNUSED_ARG(maybe_tainted);
/* no matter what, this is a string now */
%p include pointer address (standard)
%-p (SVf) include an SV (previously %_)
%-<num>p include an SV with precision <num>
- %1p (VDf) include a v-string (as %vd)
%<num>p reserved for future extensions
Robin Barker 2005-07-14
+
+ %1p (VDf) removed. RMB 2007-10-19
*/
char* r = q;
bool sv = FALSE;
has_precis = TRUE;
}
argsv = (SV*)va_arg(*args, void*);
- eptr = SvPVx_const(argsv, elen);
+ eptr = SvPV_const(argsv, elen);
if (DO_UTF8(argsv))
is_utf8 = TRUE;
goto string;
}
-#if vdNUMBER
- else if (n == vdNUMBER) { /* VDf */
- vectorize = TRUE;
- VECTORIZE_ARGS
- goto format_vd;
- }
-#endif
else if (n) {
if (ckWARN_d(WARN_INTERNAL))
Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
goto unknown;
}
vecsv = sv_newmortal();
- /* scan_vstring is expected to be called during
- * tokenization, so we need to fake up the end
- * of the buffer for it
- */
- PL_bufend = version + veclen;
- scan_vstring(version, vecsv);
+ scan_vstring(version, version + veclen, vecsv);
vecstr = (U8*)SvPV_const(vecsv, veclen);
vec_utf8 = DO_UTF8(vecsv);
Safefree(version);
case 'c':
if (vectorize)
goto unknown;
- uv = (args) ? va_arg(*args, int) : SvIVx(argsv);
+ uv = (args) ? va_arg(*args, int) : SvIV(argsv);
if ((uv > 255 ||
(!UNI_IS_INVARIANT(uv) && SvUTF8(sv)))
&& !IN_BYTES) {
}
}
else {
- eptr = SvPVx_const(argsv, elen);
+ eptr = SvPV_const(argsv, elen);
if (DO_UTF8(argsv)) {
I32 old_precis = precis;
if (has_precis && precis < elen) {
}
}
else {
- IV tiv = SvIVx(argsv); /* work around GCC bug #13488 */
+ IV tiv = SvIV(argsv); /* work around GCC bug #13488 */
switch (intsize) {
case 'h': iv = (short)tiv; break;
case 'l': iv = (long)tiv; break;
}
}
else {
- UV tuv = SvUVx(argsv); /* work around GCC bug #13488 */
+ UV tuv = SvUV(argsv); /* work around GCC bug #13488 */
switch (intsize) {
case 'h': uv = (unsigned short)tuv; break;
case 'l': uv = (unsigned long)tuv; break;
#else
va_arg(*args, double)
#endif
- : SvNVx(argsv);
+ : SvNV(argsv);
need = 0;
- if (c != 'e' && c != 'E') {
+ /* nv * 0 will be NaN for NaN, +Inf and -Inf, and 0 for anything
+ else. frexp() has some unspecified behaviour for those three */
+ if (c != 'e' && c != 'E' && (nv * 0) == 0) {
i = PERL_INT_MIN;
/* FIXME: if HAS_LONG_DOUBLE but not USE_LONG_DOUBLE this
will cast our (long double) to (double) */
}
else {
const STRLEN old_elen = elen;
- SV * const nsv = sv_2mortal(newSVpvn(eptr, elen));
+ SV * const nsv = newSVpvn_flags(eptr, elen, SVs_TEMP);
sv_utf8_upgrade(nsv);
eptr = SvPVX_const(nsv);
elen = SvCUR(nsv);
All the macros and functions in this section are for the private use of
the main function, perl_clone().
-The foo_dup() functions make an exact copy of an existing foo thinngy.
+The foo_dup() functions make an exact copy of an existing foo thingy.
During the course of a cloning, a hash table is used to map old addresses
to new addresses. The table is created and manipulated with the
ptr_table_* functions.
/* clone a parser */
yy_parser *
-Perl_parser_dup(pTHX_ const yy_parser *proto, CLONE_PARAMS* param)
+Perl_parser_dup(pTHX_ const yy_parser *const proto, CLONE_PARAMS *const param)
{
yy_parser *parser;
+ PERL_ARGS_ASSERT_PARSER_DUP;
+
if (!proto)
return NULL;
parser->multi_close = proto->multi_close;
parser->multi_open = proto->multi_open;
parser->multi_start = proto->multi_start;
+ parser->multi_end = proto->multi_end;
parser->pending_ident = proto->pending_ident;
parser->preambled = proto->preambled;
parser->sublex_info = proto->sublex_info; /* XXX not quite right */
+ parser->linestr = sv_dup_inc(proto->linestr, param);
+ parser->expect = proto->expect;
+ parser->copline = proto->copline;
+ parser->last_lop_op = proto->last_lop_op;
+ parser->lex_state = proto->lex_state;
+ parser->rsfp = fp_dup(proto->rsfp, '<', param);
+ /* rsfp_filters entries have fake IoDIRP() */
+ parser->rsfp_filters= av_dup_inc(proto->rsfp_filters, param);
+ parser->in_my = proto->in_my;
+ parser->in_my_stash = hv_dup(proto->in_my_stash, param);
+ parser->error_count = proto->error_count;
+
+
+ parser->linestr = sv_dup_inc(proto->linestr, param);
+
+ {
+ char * const ols = SvPVX(proto->linestr);
+ char * const ls = SvPVX(parser->linestr);
+
+ parser->bufptr = ls + (proto->bufptr >= ols ?
+ proto->bufptr - ols : 0);
+ parser->oldbufptr = ls + (proto->oldbufptr >= ols ?
+ proto->oldbufptr - ols : 0);
+ parser->oldoldbufptr= ls + (proto->oldoldbufptr >= ols ?
+ proto->oldoldbufptr - ols : 0);
+ parser->linestart = ls + (proto->linestart >= ols ?
+ proto->linestart - ols : 0);
+ parser->last_uni = ls + (proto->last_uni >= ols ?
+ proto->last_uni - ols : 0);
+ parser->last_lop = ls + (proto->last_lop >= ols ?
+ proto->last_lop - ols : 0);
+
+ parser->bufend = ls + SvCUR(parser->linestr);
+ }
+
+ Copy(proto->tokenbuf, parser->tokenbuf, 256, char);
+
#ifdef PERL_MAD
parser->endwhite = proto->endwhite;
parser->thisstuff = proto->thisstuff;
parser->thistoken = proto->thistoken;
parser->thiswhite = proto->thiswhite;
+
+ Copy(proto->nexttoke, parser->nexttoke, 5, NEXTTOKE);
+ parser->curforce = proto->curforce;
+#else
+ Copy(proto->nextval, parser->nextval, 5, YYSTYPE);
+ Copy(proto->nexttype, parser->nexttype, 5, I32);
+ parser->nexttoke = proto->nexttoke;
#endif
return parser;
}
/* duplicate a file handle */
PerlIO *
-Perl_fp_dup(pTHX_ PerlIO *fp, char type, CLONE_PARAMS *param)
+Perl_fp_dup(pTHX_ PerlIO *const fp, const char type, CLONE_PARAMS *const param)
{
PerlIO *ret;
+ PERL_ARGS_ASSERT_FP_DUP;
PERL_UNUSED_ARG(type);
if (!fp)
/* duplicate a directory handle */
DIR *
-Perl_dirp_dup(pTHX_ DIR *dp)
+Perl_dirp_dup(pTHX_ DIR *const dp)
{
PERL_UNUSED_CONTEXT;
if (!dp)
/* duplicate a typeglob */
GP *
-Perl_gp_dup(pTHX_ GP *gp, CLONE_PARAMS* param)
+Perl_gp_dup(pTHX_ GP *const gp, CLONE_PARAMS *const param)
{
GP *ret;
+ PERL_ARGS_ASSERT_GP_DUP;
+
if (!gp)
return (GP*)NULL;
/* look for it in the table first */
/* duplicate a chain of magic */
MAGIC *
-Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS* param)
+Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *const param)
{
MAGIC *mgprev = (MAGIC*)NULL;
MAGIC *mgret;
+
+ PERL_ARGS_ASSERT_MG_DUP;
+
if (!mg)
return (MAGIC*)NULL;
/* look for it in the table first */
nmg->mg_private = mg->mg_private;
nmg->mg_type = mg->mg_type;
nmg->mg_flags = mg->mg_flags;
+ /* FIXME for plugins
if (mg->mg_type == PERL_MAGIC_qr) {
nmg->mg_obj = (SV*)CALLREGDUPE((REGEXP*)mg->mg_obj, param);
}
- else if(mg->mg_type == PERL_MAGIC_backref) {
+ else
+ */
+ if(mg->mg_type == PERL_MAGIC_backref) {
/* The backref AV has its reference count deliberately bumped by
1. */
nmg->mg_obj = SvREFCNT_inc(av_dup_inc((AV*) mg->mg_obj, param));
}
- else if (mg->mg_type == PERL_MAGIC_symtab) {
- nmg->mg_obj = mg->mg_obj;
- }
else {
nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED)
? sv_dup_inc(mg->mg_obj, param)
/* map an existing pointer using a table */
STATIC PTR_TBL_ENT_t *
-S_ptr_table_find(PTR_TBL_t *tbl, const void *sv) {
+S_ptr_table_find(PTR_TBL_t *const tbl, const void *const sv)
+{
PTR_TBL_ENT_t *tblent;
const UV hash = PTR_TABLE_HASH(sv);
- assert(tbl);
+
+ PERL_ARGS_ASSERT_PTR_TABLE_FIND;
+
tblent = tbl->tbl_ary[hash & tbl->tbl_max];
for (; tblent; tblent = tblent->next) {
if (tblent->oldval == sv)
}
void *
-Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, const void *sv)
+Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *const tbl, const void *const sv)
{
PTR_TBL_ENT_t const *const tblent = ptr_table_find(tbl, sv);
+
+ PERL_ARGS_ASSERT_PTR_TABLE_FETCH;
PERL_UNUSED_CONTEXT;
+
return tblent ? tblent->newval : NULL;
}
/* add a new entry to a pointer-mapping table */
void
-Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, const void *oldsv, void *newsv)
+Perl_ptr_table_store(pTHX_ PTR_TBL_t *const tbl, const void *const oldsv, void *const newsv)
{
PTR_TBL_ENT_t *tblent = ptr_table_find(tbl, oldsv);
+
+ PERL_ARGS_ASSERT_PTR_TABLE_STORE;
PERL_UNUSED_CONTEXT;
if (tblent) {
/* double the hash bucket size of an existing ptr table */
void
-Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl)
+Perl_ptr_table_split(pTHX_ PTR_TBL_t *const tbl)
{
PTR_TBL_ENT_t **ary = tbl->tbl_ary;
const UV oldsize = tbl->tbl_max + 1;
UV newsize = oldsize * 2;
UV i;
+
+ PERL_ARGS_ASSERT_PTR_TABLE_SPLIT;
PERL_UNUSED_CONTEXT;
Renew(ary, newsize, PTR_TBL_ENT_t*);
/* remove all the entries from a ptr table */
void
-Perl_ptr_table_clear(pTHX_ PTR_TBL_t *tbl)
+Perl_ptr_table_clear(pTHX_ PTR_TBL_t *const tbl)
{
if (tbl && tbl->tbl_items) {
register PTR_TBL_ENT_t * const * const array = tbl->tbl_ary;
/* clear and free a ptr table */
void
-Perl_ptr_table_free(pTHX_ PTR_TBL_t *tbl)
+Perl_ptr_table_free(pTHX_ PTR_TBL_t *const tbl)
{
if (!tbl) {
return;
#if defined(USE_ITHREADS)
void
-Perl_rvpv_dup(pTHX_ SV *dstr, const SV *sstr, CLONE_PARAMS* param)
+Perl_rvpv_dup(pTHX_ SV *const dstr, const SV *const sstr, CLONE_PARAMS *const param)
{
+ PERL_ARGS_ASSERT_RVPV_DUP;
+
if (SvROK(sstr)) {
SvRV_set(dstr, SvWEAKREF(sstr)
? sv_dup(SvRV(sstr), param)
}
else {
/* Copy the NULL */
- if (SvTYPE(dstr) == SVt_RV)
- SvRV_set(dstr, NULL);
- else
- SvPV_set(dstr, NULL);
+ SvPV_set(dstr, NULL);
}
}
/* duplicate an SV of any type (including AV, HV etc) */
SV *
-Perl_sv_dup(pTHX_ const SV *sstr, CLONE_PARAMS* param)
+Perl_sv_dup(pTHX_ const SV *const sstr, CLONE_PARAMS *const param)
{
dVAR;
SV *dstr;
- if (!sstr || SvTYPE(sstr) == SVTYPEMASK)
+ PERL_ARGS_ASSERT_SV_DUP;
+
+ if (!sstr)
+ return NULL;
+ if (SvTYPE(sstr) == SVTYPEMASK) {
+#ifdef DEBUG_LEAKING_SCALARS_ABORT
+ abort();
+#endif
return NULL;
+ }
/* look for it in the table first */
dstr = (SV*)ptr_table_fetch(PL_ptr_table, sstr);
if (dstr)
/** We are joining here so we don't want do clone
something that is bad **/
if (SvTYPE(sstr) == SVt_PVHV) {
- const char * const hvname = HvNAME_get(sstr);
+ const HEK * const hvname = HvNAME_HEK(sstr);
if (hvname)
/** don't clone stashes if they already exist **/
- return (SV*)gv_stashpv(hvname,0);
+ return (SV*)gv_stashpvn(HEK_KEY(hvname), HEK_LEN(hvname), 0);
}
}
/* 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);
+ SvFLAGS(dstr) = 0;
return dstr;
}
break;
case SVt_IV:
SvANY(dstr) = (XPVIV*)((char*)&(dstr->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
- SvIV_set(dstr, SvIVX(sstr));
+ if(SvROK(sstr)) {
+ Perl_rvpv_dup(aTHX_ dstr, sstr, param);
+ } else {
+ SvIV_set(dstr, SvIVX(sstr));
+ }
break;
case SVt_NV:
SvANY(dstr) = new_XNV();
SvNV_set(dstr, SvNVX(sstr));
break;
- case SVt_RV:
- SvANY(dstr) = &(dstr->sv_u.svu_rv);
- Perl_rvpv_dup(aTHX_ dstr, sstr, param);
- break;
/* case SVt_BIND: */
default:
{
case SVt_PVAV:
case SVt_PVCV:
case SVt_PVLV:
+ case SVt_REGEXP:
case SVt_PVMG:
case SVt_PVNV:
case SVt_PVIV:
break;
case SVt_PVMG:
break;
+ case SVt_REGEXP:
+ /* FIXME for plugins */
+ re_dup_guts((REGEXP*) sstr, (REGEXP*) dstr, param);
+ break;
case SVt_PVLV:
/* XXX LvTARGOFF sometimes holds PMOP* when DEBUGGING */
if (LvTYPE(dstr) == 't') /* for tie: unrefcnted fake (SV**) */
IoOFP(dstr) = IoIFP(dstr);
else
IoOFP(dstr) = fp_dup(IoOFP(dstr), IoTYPE(dstr), param);
- /* PL_rsfp_filters entries have fake IoDIRP() */
+ /* PL_parser->rsfp_filters entries have fake IoDIRP() */
if(IoFLAGS(dstr) & IOf_FAKE_DIRP) {
/* I have no idea why fake dirp (rsfps)
should be treated differently but otherwise
daux->xhv_eiter = saux->xhv_eiter
? he_dup(saux->xhv_eiter,
(bool)!!HvSHAREKEYS(sstr), param) : 0;
+ /* backref array needs refcnt=2; see sv_add_backref */
daux->xhv_backreferences =
saux->xhv_backreferences
? (AV*) SvREFCNT_inc(
- sv_dup((SV*)saux->xhv_backreferences, param))
+ sv_dup_inc((SV*)saux->xhv_backreferences, param))
: 0;
+
+ daux->xhv_mro_meta = saux->xhv_mro_meta
+ ? mro_meta_dup(saux->xhv_mro_meta, param)
+ : 0;
+
/* Record stashes for possible cloning in Perl_clone(). */
if (hvname)
av_push(param->stashes, dstr);
{
PERL_CONTEXT *ncxs;
+ PERL_ARGS_ASSERT_CX_DUP;
+
if (!cxs)
return (PERL_CONTEXT*)NULL;
return ncxs;
/* create anew and remember what it is */
- Newxz(ncxs, max + 1, PERL_CONTEXT);
+ Newx(ncxs, max + 1, PERL_CONTEXT);
ptr_table_store(PL_ptr_table, cxs, ncxs);
+ Copy(cxs, ncxs, max + 1, PERL_CONTEXT);
while (ix >= 0) {
- PERL_CONTEXT * const cx = &cxs[ix];
PERL_CONTEXT * const ncx = &ncxs[ix];
- ncx->cx_type = cx->cx_type;
- if (CxTYPE(cx) == CXt_SUBST) {
+ if (CxTYPE(ncx) == CXt_SUBST) {
Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
}
else {
- ncx->blk_oldsp = cx->blk_oldsp;
- ncx->blk_oldcop = cx->blk_oldcop;
- ncx->blk_oldmarksp = cx->blk_oldmarksp;
- ncx->blk_oldscopesp = cx->blk_oldscopesp;
- ncx->blk_oldpm = cx->blk_oldpm;
- ncx->blk_gimme = cx->blk_gimme;
- switch (CxTYPE(cx)) {
+ switch (CxTYPE(ncx)) {
case CXt_SUB:
- ncx->blk_sub.cv = (cx->blk_sub.olddepth == 0
- ? cv_dup_inc(cx->blk_sub.cv, param)
- : cv_dup(cx->blk_sub.cv,param));
- ncx->blk_sub.argarray = (cx->blk_sub.hasargs
- ? av_dup_inc(cx->blk_sub.argarray, param)
+ ncx->blk_sub.cv = (ncx->blk_sub.olddepth == 0
+ ? cv_dup_inc(ncx->blk_sub.cv, param)
+ : cv_dup(ncx->blk_sub.cv,param));
+ ncx->blk_sub.argarray = (CxHASARGS(ncx)
+ ? av_dup_inc(ncx->blk_sub.argarray,
+ param)
: NULL);
- ncx->blk_sub.savearray = av_dup_inc(cx->blk_sub.savearray, param);
- ncx->blk_sub.olddepth = cx->blk_sub.olddepth;
- ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
- ncx->blk_sub.lval = cx->blk_sub.lval;
- ncx->blk_sub.retop = cx->blk_sub.retop;
+ ncx->blk_sub.savearray = av_dup_inc(ncx->blk_sub.savearray,
+ param);
ncx->blk_sub.oldcomppad = (PAD*)ptr_table_fetch(PL_ptr_table,
- cx->blk_sub.oldcomppad);
+ ncx->blk_sub.oldcomppad);
break;
case CXt_EVAL:
- ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval;
- ncx->blk_eval.old_op_type = cx->blk_eval.old_op_type;
- 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;
+ ncx->blk_eval.old_namesv = sv_dup_inc(ncx->blk_eval.old_namesv,
+ param);
+ ncx->blk_eval.cur_text = sv_dup(ncx->blk_eval.cur_text, param);
break;
- case CXt_LOOP:
- ncx->blk_loop.label = cx->blk_loop.label;
- ncx->blk_loop.resetsp = cx->blk_loop.resetsp;
- ncx->blk_loop.my_op = cx->blk_loop.my_op;
- ncx->blk_loop.iterdata = (CxPADLOOP(cx)
- ? cx->blk_loop.iterdata
- : gv_dup((GV*)cx->blk_loop.iterdata, param));
- ncx->blk_loop.oldcomppad
- = (PAD*)ptr_table_fetch(PL_ptr_table,
- cx->blk_loop.oldcomppad);
- ncx->blk_loop.itersave = sv_dup_inc(cx->blk_loop.itersave, param);
- ncx->blk_loop.iterlval = sv_dup_inc(cx->blk_loop.iterlval, param);
- ncx->blk_loop.iterary = av_dup_inc(cx->blk_loop.iterary, param);
- ncx->blk_loop.iterix = cx->blk_loop.iterix;
- ncx->blk_loop.itermax = cx->blk_loop.itermax;
+ case CXt_LOOP_LAZYSV:
+ ncx->blk_loop.state_u.lazysv.end
+ = sv_dup_inc(ncx->blk_loop.state_u.lazysv.end, param);
+ /* We are taking advantage of av_dup_inc and sv_dup_inc
+ actually being the same function, and order equivalance of
+ the two unions.
+ We can assert the later [but only at run time :-(] */
+ assert ((void *) &ncx->blk_loop.state_u.ary.ary ==
+ (void *) &ncx->blk_loop.state_u.lazysv.cur);
+ case CXt_LOOP_FOR:
+ ncx->blk_loop.state_u.ary.ary
+ = av_dup_inc(ncx->blk_loop.state_u.ary.ary, param);
+ case CXt_LOOP_LAZYIV:
+ case CXt_LOOP_PLAIN:
+ if (CxPADLOOP(ncx)) {
+ ncx->blk_loop.oldcomppad
+ = (PAD*)ptr_table_fetch(PL_ptr_table,
+ ncx->blk_loop.oldcomppad);
+ } else {
+ ncx->blk_loop.oldcomppad
+ = (PAD*)gv_dup((GV*)ncx->blk_loop.oldcomppad, param);
+ }
break;
case CXt_FORMAT:
- ncx->blk_sub.cv = cv_dup(cx->blk_sub.cv, param);
- 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;
+ ncx->blk_format.cv = cv_dup(ncx->blk_format.cv, param);
+ ncx->blk_format.gv = gv_dup(ncx->blk_format.gv, param);
+ ncx->blk_format.dfoutgv = gv_dup_inc(ncx->blk_format.dfoutgv,
+ param);
break;
case CXt_BLOCK:
case CXt_NULL:
{
PERL_SI *nsi;
+ PERL_ARGS_ASSERT_SI_DUP;
+
if (!si)
return (PERL_SI*)NULL;
{
void *ret;
+ PERL_ARGS_ASSERT_ANY_DUP;
+
if (!v)
return (void*)NULL;
Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param)
{
dVAR;
- ANY * const ss = proto_perl->Tsavestack;
- const I32 max = proto_perl->Tsavestack_max;
- I32 ix = proto_perl->Tsavestack_ix;
+ ANY * const ss = proto_perl->Isavestack;
+ const I32 max = proto_perl->Isavestack_max;
+ I32 ix = proto_perl->Isavestack_ix;
ANY *nss;
SV *sv;
GV *gv;
void (*dptr) (void*);
void (*dxptr) (pTHX_ void*);
+ PERL_ARGS_ASSERT_SS_DUP;
+
Newxz(nss, max, ANY);
while (ix > 0) {
TOPPTR(nss,ix) = ptr;
o = (OP*)ptr;
OP_REFCNT_LOCK;
- OpREFCNT_inc(o);
+ (void) OpREFCNT_inc(o);
OP_REFCNT_UNLOCK;
break;
default:
TOPPTR(nss,ix) = hv_dup_inc(hv, param);
}
break;
- case SAVEt_PADSV:
+ case SAVEt_PADSV_AND_MORTALIZE:
longval = (long)POPLONG(ss,ix);
TOPLONG(nss,ix) = longval;
ptr = POPPTR(ss,ix);
TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
sv = (SV*)POPPTR(ss,ix);
- TOPPTR(nss,ix) = sv_dup(sv, param);
+ TOPPTR(nss,ix) = sv_dup_inc(sv, param);
break;
case SAVEt_BOOL:
ptr = POPPTR(ss,ix);
= pv_dup(old_state->re_state_reginput);
new_state->re_state_regeol
= pv_dup(old_state->re_state_regeol);
- new_state->re_state_regstartp
- = (I32*) any_dup(old_state->re_state_regstartp, proto_perl);
- new_state->re_state_regendp
- = (I32*) any_dup(old_state->re_state_regendp, proto_perl);
+ new_state->re_state_regoffs
+ = (regexp_paren_pair*)
+ any_dup(old_state->re_state_regoffs, proto_perl);
new_state->re_state_reglastparen
= (U32*) any_dup(old_state->re_state_reglastparen,
proto_perl);
* so we know which stashes want their objects cloned */
static void
-do_mark_cloneable_stash(pTHX_ SV *sv)
+do_mark_cloneable_stash(pTHX_ SV *const sv)
{
const HEK * const hvname = HvNAME_HEK((HV*)sv);
if (hvname) {
ENTER;
SAVETMPS;
PUSHMARK(SP);
- XPUSHs(sv_2mortal(newSVhek(hvname)));
+ mXPUSHs(newSVhek(hvname));
PUTBACK;
call_sv((SV*)GvCV(cloner), G_SCALAR);
SPAGAIN;
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.
+threads->create doesn't.
CLONEf_KEEP_PTR_TABLE
perl_clone keeps a ptr_table with the pointer of the old
dVAR;
#ifdef PERL_IMPLICIT_SYS
+ PERL_ARGS_ASSERT_PERL_CLONE;
+
/* perlhost.h so we need to call into it
to clone the host, CPerlHost should have a c interface, sky */
CLONE_PARAMS* const param = &clone_params;
PerlInterpreter * const my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
+
+ PERL_ARGS_ASSERT_PERL_CLONE_USING;
+
/* 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);
PL_savestack_ix = 0;
PL_savestack_max = -1;
PL_sig_pending = 0;
+ PL_parser = NULL;
Zero(&PL_debug_pad, 1, struct perl_debug_pad);
# else /* !DEBUGGING */
Zero(my_perl, 1, PerlInterpreter);
CLONE_PARAMS clone_params;
CLONE_PARAMS* param = &clone_params;
PerlInterpreter * const my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
+
+ PERL_ARGS_ASSERT_PERL_CLONE;
+
/* 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);
PL_savestack_ix = 0;
PL_savestack_max = -1;
PL_sig_pending = 0;
+ PL_parser = NULL;
Zero(&PL_debug_pad, 1, struct perl_debug_pad);
# else /* !DEBUGGING */
Zero(my_perl, 1, PerlInterpreter);
PL_compiling.cop_hints_hash->refcounted_he_refcnt++;
HINTS_REFCNT_UNLOCK;
}
- PL_curcop = (COP*)any_dup(proto_perl->Tcurcop, proto_perl);
+ PL_curcop = (COP*)any_dup(proto_perl->Icurcop, proto_perl);
+#ifdef PERL_DEBUG_READONLY_OPS
+ PL_slabs = NULL;
+ PL_slab_count = 0;
+#endif
/* pseudo environmental stuff */
PL_origargc = proto_perl->Iorigargc;
PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel, param);
PL_localpatches = proto_perl->Ilocalpatches;
PL_splitstr = proto_perl->Isplitstr;
- PL_preprocess = proto_perl->Ipreprocess;
PL_minus_n = proto_perl->Iminus_n;
PL_minus_p = proto_perl->Iminus_p;
PL_minus_l = proto_perl->Iminus_l;
PL_regmatch_slab = NULL;
/* Clone the regex array */
- PL_regex_padav = newAV();
- {
- const I32 len = av_len((AV*)proto_perl->Iregex_padav);
- SV* const * const regexen = AvARRAY((AV*)proto_perl->Iregex_padav);
- IV i;
- av_push(PL_regex_padav, sv_dup_inc_NN(regexen[0],param));
- for(i = 1; i <= len; i++) {
- const SV * const regex = regexen[i];
- SV * const sv =
- SvREPADTMP(regex)
- ? sv_dup_inc(regex, param)
- : SvREFCNT_inc(
- newSViv(PTR2IV(CALLREGDUPE(
- INT2PTR(REGEXP *, SvIVX(regex)), param))))
- ;
- if (SvFLAGS(regex) & SVf_BREAK)
- SvFLAGS(sv) |= SVf_BREAK; /* unrefcnted PL_curpm */
- av_push(PL_regex_padav, sv);
- }
- }
+ /* ORANGE FIXME for plugins, probably in the SV dup code.
+ newSViv(PTR2IV(CALLREGDUPE(
+ INT2PTR(REGEXP *, SvIVX(regex)), param))))
+ */
+ PL_regex_padav = av_dup_inc(proto_perl->Iregex_padav, param);
PL_regex_pad = AvARRAY(PL_regex_padav);
/* shortcuts to various I/O objects */
PL_DBsingle = sv_dup(proto_perl->IDBsingle, param);
PL_DBtrace = sv_dup(proto_perl->IDBtrace, param);
PL_DBsignal = sv_dup(proto_perl->IDBsignal, param);
- PL_DBassertion = sv_dup(proto_perl->IDBassertion, param);
- PL_lineary = av_dup(proto_perl->Ilineary, param);
PL_dbargs = av_dup(proto_perl->Idbargs, param);
/* symbol tables */
- PL_defstash = hv_dup_inc(proto_perl->Tdefstash, param);
- PL_curstash = hv_dup(proto_perl->Tcurstash, param);
+ PL_defstash = hv_dup_inc(proto_perl->Idefstash, param);
+ PL_curstash = hv_dup(proto_perl->Icurstash, param);
PL_debstash = hv_dup(proto_perl->Idebstash, param);
PL_globalstash = hv_dup(proto_perl->Iglobalstash, param);
PL_curstname = sv_dup_inc(proto_perl->Icurstname, param);
PL_initav = av_dup_inc(proto_perl->Iinitav, param);
PL_sub_generation = proto_perl->Isub_generation;
+ PL_isarev = hv_dup_inc(proto_perl->Iisarev, param);
/* funky return mechanisms */
PL_forkprocess = proto_perl->Iforkprocess;
/* runtime control stuff */
PL_curcopdb = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
- PL_copline = proto_perl->Icopline;
PL_filemode = proto_perl->Ifilemode;
PL_lastfd = proto_perl->Ilastfd;
Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
Copy(proto_perl->Imy_cxt_list, PL_my_cxt_list, PL_my_cxt_size, void *);
#ifdef PERL_GLOBAL_STRUCT_PRIVATE
- Newx(PL_my_cxt_keys, PL_my_cxt_size, char *);
+ Newx(PL_my_cxt_keys, PL_my_cxt_size, const char *);
Copy(proto_perl->Imy_cxt_keys, PL_my_cxt_keys, PL_my_cxt_size, char *);
#endif
}
else {
PL_my_cxt_list = (void**)NULL;
#ifdef PERL_GLOBAL_STRUCT_PRIVATE
- PL_my_cxt_keys = (void**)NULL;
+ PL_my_cxt_keys = (const char**)NULL;
#endif
}
PL_modglobal = hv_dup_inc(proto_perl->Imodglobal, param);
PL_custom_op_descs = hv_dup_inc(proto_perl->Icustom_op_descs,param);
PL_profiledata = NULL;
- PL_rsfp = fp_dup(proto_perl->Irsfp, '<', param);
- /* PL_rsfp_filters entries have fake IoDIRP() */
- PL_rsfp_filters = av_dup_inc(proto_perl->Irsfp_filters, param);
PL_compcv = cv_dup(proto_perl->Icompcv, param);
PL_runops = proto_perl->Irunops;
- Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char);
-
-#ifdef CSH
- PL_cshlen = proto_perl->Icshlen;
- PL_cshname = proto_perl->Icshname; /* XXX never deallocated */
-#endif
-
PL_parser = parser_dup(proto_perl->Iparser, param);
- PL_lex_state = proto_perl->Ilex_state;
-
-#ifdef PERL_MAD
- Copy(proto_perl->Inexttoke, PL_nexttoke, 5, NEXTTOKE);
- PL_curforce = proto_perl->Icurforce;
-#else
- Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE);
- Copy(proto_perl->Inexttype, PL_nexttype, 5, I32);
- PL_nexttoke = proto_perl->Inexttoke;
-#endif
-
- PL_linestr = sv_dup_inc(proto_perl->Ilinestr, param);
- i = proto_perl->Ibufptr - SvPVX_const(proto_perl->Ilinestr);
- PL_bufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
- i = proto_perl->Ioldbufptr - SvPVX_const(proto_perl->Ilinestr);
- PL_oldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
- i = proto_perl->Ioldoldbufptr - SvPVX_const(proto_perl->Ilinestr);
- PL_oldoldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
- i = proto_perl->Ilinestart - SvPVX_const(proto_perl->Ilinestr);
- PL_linestart = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
- PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
-
- PL_expect = proto_perl->Iexpect;
-
- PL_multi_end = proto_perl->Imulti_end;
-
- PL_error_count = proto_perl->Ierror_count;
PL_subline = proto_perl->Isubline;
PL_subname = sv_dup_inc(proto_perl->Isubname, param);
- i = proto_perl->Ilast_uni - SvPVX_const(proto_perl->Ilinestr);
- PL_last_uni = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
- i = proto_perl->Ilast_lop - SvPVX_const(proto_perl->Ilinestr);
- PL_last_lop = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
- PL_last_lop_op = proto_perl->Ilast_lop_op;
- PL_in_my = proto_perl->Iin_my;
- PL_in_my_stash = hv_dup(proto_perl->Iin_my_stash, param);
#ifdef FCRYPT
PL_cryptseen = proto_perl->Icryptseen;
#endif
PL_lockhook = proto_perl->Ilockhook;
PL_unlockhook = proto_perl->Iunlockhook;
PL_threadhook = proto_perl->Ithreadhook;
-
- PL_runops_std = proto_perl->Irunops_std;
- PL_runops_dbg = proto_perl->Irunops_dbg;
+ PL_destroyhook = proto_perl->Idestroyhook;
#ifdef THREADS_HAVE_PIDS
PL_ppid = proto_perl->Ippid;
PL_glob_index = proto_perl->Iglob_index;
PL_srand_called = proto_perl->Isrand_called;
- PL_uudmap[(U32) 'M'] = 0; /* reinits on demand */
PL_bitcount = NULL; /* reinits on demand */
if (proto_perl->Ipsig_pend) {
PL_psig_name = (SV**)NULL;
}
- /* thrdvar.h stuff */
+ /* intrpvar.h stuff */
if (flags & CLONEf_COPY_STACKS) {
/* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
- PL_tmps_ix = proto_perl->Ttmps_ix;
- PL_tmps_max = proto_perl->Ttmps_max;
- PL_tmps_floor = proto_perl->Ttmps_floor;
+ PL_tmps_ix = proto_perl->Itmps_ix;
+ PL_tmps_max = proto_perl->Itmps_max;
+ PL_tmps_floor = proto_perl->Itmps_floor;
Newxz(PL_tmps_stack, PL_tmps_max, SV*);
i = 0;
while (i <= PL_tmps_ix) {
- PL_tmps_stack[i] = sv_dup_inc(proto_perl->Ttmps_stack[i], param);
+ PL_tmps_stack[i] = sv_dup_inc(proto_perl->Itmps_stack[i], param);
++i;
}
/* next PUSHMARK() sets *(PL_markstack_ptr+1) */
- i = proto_perl->Tmarkstack_max - proto_perl->Tmarkstack;
+ i = proto_perl->Imarkstack_max - proto_perl->Imarkstack;
Newxz(PL_markstack, i, I32);
- PL_markstack_max = PL_markstack + (proto_perl->Tmarkstack_max
- - proto_perl->Tmarkstack);
- PL_markstack_ptr = PL_markstack + (proto_perl->Tmarkstack_ptr
- - proto_perl->Tmarkstack);
- Copy(proto_perl->Tmarkstack, PL_markstack,
+ PL_markstack_max = PL_markstack + (proto_perl->Imarkstack_max
+ - proto_perl->Imarkstack);
+ PL_markstack_ptr = PL_markstack + (proto_perl->Imarkstack_ptr
+ - proto_perl->Imarkstack);
+ Copy(proto_perl->Imarkstack, PL_markstack,
PL_markstack_ptr - PL_markstack + 1, I32);
/* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
* NOTE: unlike the others! */
- PL_scopestack_ix = proto_perl->Tscopestack_ix;
- PL_scopestack_max = proto_perl->Tscopestack_max;
+ PL_scopestack_ix = proto_perl->Iscopestack_ix;
+ PL_scopestack_max = proto_perl->Iscopestack_max;
Newxz(PL_scopestack, PL_scopestack_max, I32);
- Copy(proto_perl->Tscopestack, PL_scopestack, PL_scopestack_ix, I32);
+ Copy(proto_perl->Iscopestack, PL_scopestack, PL_scopestack_ix, I32);
/* NOTE: si_dup() looks at PL_markstack */
- PL_curstackinfo = si_dup(proto_perl->Tcurstackinfo, param);
+ PL_curstackinfo = si_dup(proto_perl->Icurstackinfo, param);
/* PL_curstack = PL_curstackinfo->si_stack; */
- PL_curstack = av_dup(proto_perl->Tcurstack, param);
- PL_mainstack = av_dup(proto_perl->Tmainstack, param);
+ PL_curstack = av_dup(proto_perl->Icurstack, param);
+ PL_mainstack = av_dup(proto_perl->Imainstack, param);
/* next PUSHs() etc. set *(PL_stack_sp+1) */
PL_stack_base = AvARRAY(PL_curstack);
- PL_stack_sp = PL_stack_base + (proto_perl->Tstack_sp
- - proto_perl->Tstack_base);
+ PL_stack_sp = PL_stack_base + (proto_perl->Istack_sp
+ - proto_perl->Istack_base);
PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
/* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
* NOTE: unlike the others! */
- PL_savestack_ix = proto_perl->Tsavestack_ix;
- PL_savestack_max = proto_perl->Tsavestack_max;
+ PL_savestack_ix = proto_perl->Isavestack_ix;
+ PL_savestack_max = proto_perl->Isavestack_max;
/*Newxz(PL_savestack, PL_savestack_max, ANY);*/
PL_savestack = ss_dup(proto_perl, param);
}
* non-refcount means (eg a temp in @_); otherwise they will be
* orphaned
*/
- for (i = 0; i<= proto_perl->Ttmps_ix; i++) {
+ for (i = 0; i<= proto_perl->Itmps_ix; i++) {
SV * const nsv = (SV*)ptr_table_fetch(PL_ptr_table,
- proto_perl->Ttmps_stack[i]);
+ proto_perl->Itmps_stack[i]);
if (nsv && !SvREFCNT(nsv)) {
EXTEND_MORTAL(1);
PL_tmps_stack[++PL_tmps_ix] = SvREFCNT_inc_simple(nsv);
}
}
- PL_start_env = proto_perl->Tstart_env; /* XXXXXX */
+ PL_start_env = proto_perl->Istart_env; /* XXXXXX */
PL_top_env = &PL_start_env;
- PL_op = proto_perl->Top;
+ PL_op = proto_perl->Iop;
PL_Sv = NULL;
PL_Xpv = (XPV*)NULL;
- PL_na = proto_perl->Tna;
+ my_perl->Ina = proto_perl->Ina;
- PL_statbuf = proto_perl->Tstatbuf;
- PL_statcache = proto_perl->Tstatcache;
- PL_statgv = gv_dup(proto_perl->Tstatgv, param);
- PL_statname = sv_dup_inc(proto_perl->Tstatname, param);
+ PL_statbuf = proto_perl->Istatbuf;
+ PL_statcache = proto_perl->Istatcache;
+ PL_statgv = gv_dup(proto_perl->Istatgv, param);
+ PL_statname = sv_dup_inc(proto_perl->Istatname, param);
#ifdef HAS_TIMES
- PL_timesbuf = proto_perl->Ttimesbuf;
+ PL_timesbuf = proto_perl->Itimesbuf;
#endif
- PL_tainted = proto_perl->Ttainted;
- PL_curpm = proto_perl->Tcurpm; /* XXX No PMOP ref count */
- PL_rs = sv_dup_inc(proto_perl->Trs, param);
- PL_last_in_gv = gv_dup(proto_perl->Tlast_in_gv, param);
- PL_ofs_sv = sv_dup_inc(proto_perl->Tofs_sv, param);
- PL_defoutgv = gv_dup_inc(proto_perl->Tdefoutgv, param);
- PL_chopset = proto_perl->Tchopset; /* XXX never deallocated */
- PL_toptarget = sv_dup_inc(proto_perl->Ttoptarget, param);
- PL_bodytarget = sv_dup_inc(proto_perl->Tbodytarget, param);
- PL_formtarget = sv_dup(proto_perl->Tformtarget, param);
-
- PL_restartop = proto_perl->Trestartop;
- PL_in_eval = proto_perl->Tin_eval;
- PL_delaymagic = proto_perl->Tdelaymagic;
- PL_dirty = proto_perl->Tdirty;
- PL_localizing = proto_perl->Tlocalizing;
-
- PL_errors = sv_dup_inc(proto_perl->Terrors, param);
+ PL_tainted = proto_perl->Itainted;
+ PL_curpm = proto_perl->Icurpm; /* XXX No PMOP ref count */
+ PL_rs = sv_dup_inc(proto_perl->Irs, param);
+ PL_last_in_gv = gv_dup(proto_perl->Ilast_in_gv, param);
+ PL_ofs_sv = sv_dup_inc(proto_perl->Iofs_sv, param);
+ PL_defoutgv = gv_dup_inc(proto_perl->Idefoutgv, param);
+ PL_chopset = proto_perl->Ichopset; /* XXX never deallocated */
+ PL_toptarget = sv_dup_inc(proto_perl->Itoptarget, param);
+ PL_bodytarget = sv_dup_inc(proto_perl->Ibodytarget, param);
+ PL_formtarget = sv_dup(proto_perl->Iformtarget, param);
+
+ PL_restartop = proto_perl->Irestartop;
+ PL_in_eval = proto_perl->Iin_eval;
+ PL_delaymagic = proto_perl->Idelaymagic;
+ PL_dirty = proto_perl->Idirty;
+ PL_localizing = proto_perl->Ilocalizing;
+
+ PL_errors = sv_dup_inc(proto_perl->Ierrors, param);
PL_hv_fetch_ent_mh = NULL;
- PL_modcount = proto_perl->Tmodcount;
+ PL_modcount = proto_perl->Imodcount;
PL_lastgotoprobe = NULL;
- PL_dumpindent = proto_perl->Tdumpindent;
+ PL_dumpindent = proto_perl->Idumpindent;
- PL_sortcop = (OP*)any_dup(proto_perl->Tsortcop, proto_perl);
- PL_sortstash = hv_dup(proto_perl->Tsortstash, param);
- PL_firstgv = gv_dup(proto_perl->Tfirstgv, param);
- PL_secondgv = gv_dup(proto_perl->Tsecondgv, param);
+ PL_sortcop = (OP*)any_dup(proto_perl->Isortcop, proto_perl);
+ PL_sortstash = hv_dup(proto_perl->Isortstash, param);
+ PL_firstgv = gv_dup(proto_perl->Ifirstgv, param);
+ PL_secondgv = gv_dup(proto_perl->Isecondgv, param);
PL_efloatbuf = NULL; /* reinits on demand */
PL_efloatsize = 0; /* reinits on demand */
PL_maxscream = -1; /* reinits on demand */
PL_lastscream = NULL;
- PL_watchaddr = NULL;
- PL_watchok = NULL;
- PL_regdummy = proto_perl->Tregdummy;
+ PL_regdummy = proto_perl->Iregdummy;
PL_colorset = 0; /* reinits PL_colors[] */
/*PL_colors[6] = {0,0,0,0,0,0};*/
/* Pluggable optimizer */
- PL_peepp = proto_perl->Tpeepp;
+ PL_peepp = proto_perl->Ipeepp;
PL_stashcache = newHV();
+ PL_watchaddr = (char **) ptr_table_fetch(PL_ptr_table,
+ proto_perl->Iwatchaddr);
+ PL_watchok = PL_watchaddr ? * PL_watchaddr : NULL;
+ if (PL_debug && PL_watchaddr) {
+ PerlIO_printf(Perl_debug_log,
+ "WATCHING: %"UVxf" cloned as %"UVxf" with value %"UVxf"\n",
+ PTR2UV(proto_perl->Iwatchaddr), PTR2UV(PL_watchaddr),
+ PTR2UV(PL_watchok));
+ }
+
if (!(flags & CLONEf_KEEP_PTR_TABLE)) {
ptr_table_free(PL_ptr_table);
PL_ptr_table = NULL;
ENTER;
SAVETMPS;
PUSHMARK(SP);
- XPUSHs(sv_2mortal(newSVhek(HvNAME_HEK(stash))));
+ mXPUSHs(newSVhek(HvNAME_HEK(stash)));
PUTBACK;
call_sv((SV*)GvCV(cloner), G_DISCARD);
FREETMPS;
Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding)
{
dVAR;
+
+ PERL_ARGS_ASSERT_SV_RECODE_TO_UTF8;
+
if (SvPOK(sv) && !SvUTF8(sv) && !IN_BYTES && SvROK(encoding)) {
SV *uni;
STRLEN len;
{
dVAR;
bool ret = FALSE;
+
+ PERL_ARGS_ASSERT_SV_CAT_DECODE;
+
if (SvPOK(ssv) && SvPOK(dsv) && SvROK(encoding) && offset) {
SV *offsv;
dSP;
XPUSHs(encoding);
XPUSHs(dsv);
XPUSHs(ssv);
- XPUSHs(offsv = sv_2mortal(newSViv(*offset)));
- XPUSHs(sv_2mortal(newSVpvn(tstr, tlen)));
+ offsv = newSViv(*offset);
+ mXPUSHs(offsv);
+ mXPUSHp(tstr, tlen);
PUTBACK;
call_method("cat_decode", G_SCALAR);
SPAGAIN;
register HE **array;
I32 i;
+ PERL_ARGS_ASSERT_FIND_HASH_SUBSCRIPT;
+
if (!hv || SvMAGICAL(hv) || !HvARRAY(hv) ||
(HvTOTALKEYS(hv) > FUV_MAX_SEARCH_SIZE))
return NULL;
return NULL;
if (HeKLEN(entry) == HEf_SVKEY)
return sv_mortalcopy(HeKEY_sv(entry));
- return sv_2mortal(newSVpvn(HeKEY(entry), HeKLEN(entry)));
+ return sv_2mortal(newSVhek(HeKEY_hek(entry)));
}
}
return NULL;
S_find_array_subscript(pTHX_ AV *av, SV* val)
{
dVAR;
+
+ PERL_ARGS_ASSERT_FIND_ARRAY_SUBSCRIPT;
+
if (!av || SvMAGICAL(av) || !AvARRAY(av) ||
(AvFILLp(av) > FUV_MAX_SEARCH_SIZE))
return -1;
}
}
else {
- U32 unused;
- CV * const cv = find_runcv(&unused);
+ CV * const cv = find_runcv(NULL);
SV *sv;
AV *av;
*SvPVX(name) = '$';
Perl_sv_catpvf(aTHX_ name, "[%"IVdf"]", (IV)aindex);
}
- else if (subscript_type == FUV_SUBSCRIPT_WITHIN)
- Perl_sv_insert(aTHX_ name, 0, 0, STR_WITH_LEN("within "));
+ else if (subscript_type == FUV_SUBSCRIPT_WITHIN) {
+ /* We know that name has no magic, so can use 0 instead of SV_GMAGIC */
+ Perl_sv_insert_flags(aTHX_ name, 0, 0, STR_WITH_LEN("within "), 0);
+ }
return name;
}
case OP_PRTF:
case OP_PRINT:
+ case OP_SAY:
+ match = 1; /* print etc can return undef on defined args */
/* skip filehandle as it can't produce 'undef' warning */
o = cUNOPx(obase)->op_first;
if ((obase->op_flags & OPf_STACKED) && o->op_type == OP_PUSHMARK)
goto do_op2;
+ case OP_ENTEREVAL: /* could be eval $undef or $x='$undef'; eval $x */
case OP_RV2SV:
- case OP_CUSTOM:
- case OP_ENTERSUB:
- match = 1; /* XS or custom code could trigger random warnings */
+ case OP_CUSTOM: /* XS or custom code could trigger random warnings */
+
+ /* the following ops are capable of returning PL_sv_undef even for
+ * defined arg(s) */
+
+ case OP_BACKTICK:
+ case OP_PIPE_OP:
+ case OP_FILENO:
+ case OP_BINMODE:
+ case OP_TIED:
+ case OP_GETC:
+ case OP_SYSREAD:
+ case OP_SEND:
+ case OP_IOCTL:
+ case OP_SOCKET:
+ case OP_SOCKPAIR:
+ case OP_BIND:
+ case OP_CONNECT:
+ case OP_LISTEN:
+ case OP_ACCEPT:
+ case OP_SHUTDOWN:
+ case OP_SSOCKOPT:
+ case OP_GETPEERNAME:
+ case OP_FTRREAD:
+ case OP_FTRWRITE:
+ case OP_FTREXEC:
+ case OP_FTROWNED:
+ case OP_FTEREAD:
+ case OP_FTEWRITE:
+ case OP_FTEEXEC:
+ case OP_FTEOWNED:
+ case OP_FTIS:
+ case OP_FTZERO:
+ case OP_FTSIZE:
+ case OP_FTFILE:
+ case OP_FTDIR:
+ case OP_FTLINK:
+ case OP_FTPIPE:
+ case OP_FTSOCK:
+ case OP_FTBLK:
+ case OP_FTCHR:
+ case OP_FTTTY:
+ case OP_FTSUID:
+ case OP_FTSGID:
+ case OP_FTSVTX:
+ case OP_FTTEXT:
+ case OP_FTBINARY:
+ case OP_FTMTIME:
+ case OP_FTATIME:
+ case OP_FTCTIME:
+ case OP_READLINK:
+ case OP_OPEN_DIR:
+ case OP_READDIR:
+ case OP_TELLDIR:
+ case OP_SEEKDIR:
+ case OP_REWINDDIR:
+ case OP_CLOSEDIR:
+ case OP_GMTIME:
+ case OP_ALARM:
+ case OP_SEMGET:
+ case OP_GETLOGIN:
+ case OP_UNDEF:
+ case OP_SUBSTR:
+ case OP_AEACH:
+ case OP_EACH:
+ case OP_SORT:
+ case OP_CALLER:
+ case OP_DOFILE:
+ case OP_PROTOTYPE:
+ case OP_NCMP:
+ case OP_SMARTMATCH:
+ case OP_UNPACK:
+ case OP_SYSOPEN:
+ case OP_SYSSEEK:
+ match = 1;
goto do_op;
+ case OP_ENTERSUB:
+ case OP_GOTO:
+ /* XXX tmp hack: these two may call an XS sub, and currently
+ XS subs don't have a SUB entry on the context stack, so CV and
+ pad determination goes wrong, and BAD things happen. So, just
+ don't try to determine the value under those circumstances.
+ Need a better fix at dome point. DAPM 11/2007 */
+ break;
+
+
+ case OP_POS:
+ /* def-ness of rval pos() is independent of the def-ness of its arg */
+ if ( !(obase->op_flags & OPf_MOD))
+ break;
+
case OP_SCHOMP:
case OP_CHOMP:
if (SvROK(PL_rs) && uninit_sv == SvRV(PL_rs))
- return sv_2mortal(newSVpvs("${$/}"));
+ return newSVpvs_flags("${$/}", SVs_TEMP);
/*FALLTHROUGH*/
default:
https://perl5.git.perl.org / perl5.git / blobdiff