struct arena_desc {
char *arena; /* the raw storage, allocated aligned */
size_t size; /* its size ~4k typ */
- U32 misc; /* type, and in future other things. */
+ svtype utype; /* bodytype stored in arena */
};
struct arena_set;
TBD: export properly for hv.c: S_more_he().
*/
void*
-Perl_get_arena(pTHX_ const size_t arena_size, const U32 misc)
+Perl_get_arena(pTHX_ const size_t arena_size, const svtype bodytype)
{
dVAR;
struct arena_desc* adesc;
Newx(adesc->arena, arena_size, char);
adesc->size = arena_size;
- adesc->misc = misc;
+ adesc->utype = bodytype;
DEBUG_m(PerlIO_printf(Perl_debug_log, "arena %d added: %p size %"UVuf"\n",
curr, (void*)adesc->arena, (UV)arena_size));
if (new_type == SVt_PVIO) {
IO * const io = MUTABLE_IO(sv);
- GV *iogv = gv_fetchpvs("FileHandle::", 0, SVt_PVHV);
+ GV *iogv = gv_fetchpvs("IO::Handle::", GV_ADD, SVt_PVHV);
SvOBJECT_on(io);
/* Clear the stashcache because a new IO could overrule a package
name */
hv_clear(PL_stashcache);
- /* unless exists($main::{FileHandle}) and
- defined(%main::FileHandle::) */
- if (!(iogv && GvHV(iogv) && HvARRAY(GvHV(iogv))))
- iogv = gv_fetchpvs("IO::Handle::", GV_ADD, SVt_PVHV);
SvSTASH_set(io, MUTABLE_HV(SvREFCNT_inc(GvHV(iogv))));
IoPAGE_LEN(sv) = 60;
}
(unsigned long)new_type);
}
- if (old_type_details->arena) {
- /* If there was an old body, then we need to free it.
- Note that there is an assumption that all bodies of types that
- can be upgraded came from arenas. Only the more complex non-
- upgradable types are allowed to be directly malloc()ed. */
+ if (old_type > SVt_IV) { /* SVt_IVs are overloaded for PTEs */
#ifdef PURIFY
my_safefree(old_body);
#else
+ /* Note that there is an assumption that all bodies of types that
+ can be upgraded came from arenas. Only the more complex non-
+ upgradable types are allowed to be directly malloc()ed. */
+ assert(old_type_details->arena);
del_body((void*)((char*)old_body + old_type_details->offset),
&PL_body_roots[old_type]);
#endif
gv_efullname3(buffer, gv, "*");
SvFLAGS(gv) |= wasfake;
- assert(SvPOK(buffer));
- if (lp) {
- *lp = SvCUR(buffer);
+ if (SvPOK(buffer)) {
+ if (lp) {
+ *lp = SvCUR(buffer);
+ }
+ return SvPVX(buffer);
+ }
+ else {
+ if (lp)
+ *lp = 0;
+ return (char *)"";
}
- return SvPVX(buffer);
}
if (lp)
return SvCUR(sv);
}
- if (SvCUR(sv) > 0) { /* Assume Latin-1/EBCDIC */
+ if (SvCUR(sv) == 0) {
+ if (extra) SvGROW(sv, extra);
+ } else { /* Assume Latin-1/EBCDIC */
/* This function could be much more efficient if we
* had a FLAG in SVs to signal if there are any variant
* chars in the PV. Given that there isn't such a flag
}
/* Fall through */
#endif
- case SVt_REGEXP:
case SVt_PV:
if (dtype < SVt_PV)
sv_upgrade(dstr, SVt_PV);
}
break;
+ case SVt_REGEXP:
+ if (dtype < SVt_REGEXP)
+ sv_upgrade(dstr, SVt_REGEXP);
+ break;
+
/* case SVt_BIND: */
case SVt_PVLV:
case SVt_PVGV:
}
}
}
+ else if (dtype == SVt_REGEXP && stype == SVt_REGEXP) {
+ reg_temp_copy((REGEXP*)dstr, (REGEXP*)sstr);
+ }
else if (sflags & SVp_POK) {
bool isSwipe = 0;
else
mgp = &mg->mg_moremagic;
}
- if (!SvMAGIC(sv)) {
+ if (SvMAGIC(sv)) {
+ if (SvMAGICAL(sv)) /* if we're under save_magic, wait for restore_magic; */
+ mg_magical(sv); /* else fix the flags now */
+ }
+ else {
SvMAGICAL_off(sv);
SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
- SvMAGIC_set(sv, NULL);
}
-
return 0;
}
&& !CvCONST(destructor)
/* Don't bother calling an empty destructor */
&& (CvISXSUB(destructor)
- || CvSTART(destructor)->op_next->op_type != OP_LEAVESUB))
+ || (CvSTART(destructor)
+ && (CvSTART(destructor)->op_next->op_type != OP_LEAVESUB))))
{
SV* const tmpref = newRV(sv);
SvREADONLY_on(tmpref); /* DESTROY() could be naughty */
else {
ulen = Perl_utf8_length(aTHX_ s, s + len);
if (!SvREADONLY(sv)) {
- if (!mg) {
+ if (!mg && (SvTYPE(sv) < SVt_PVMG ||
+ !(mg = mg_find(sv, PERL_MAGIC_utf8)))) {
mg = sv_magicext(sv, 0, PERL_MAGIC_utf8,
&PL_vtbl_utf8, 0, 0);
}
assert (uoffset >= uoffset0);
- if (SvMAGICAL(sv) && !SvREADONLY(sv) && PL_utf8cache
- && (*mgp || (*mgp = mg_find(sv, PERL_MAGIC_utf8)))) {
+ if (!SvREADONLY(sv)
+ && PL_utf8cache
+ && (*mgp || (SvTYPE(sv) >= SVt_PVMG &&
+ (*mgp = mg_find(sv, PERL_MAGIC_utf8))))) {
if ((*mgp)->mg_ptr) {
STRLEN *cache = (STRLEN *) (*mgp)->mg_ptr;
if (cache[0] == uoffset) {
if (SvREADONLY(sv))
return;
- if (!*mgp) {
+ if (!*mgp && (SvTYPE(sv) < SVt_PVMG ||
+ !(*mgp = mg_find(sv, PERL_MAGIC_utf8)))) {
*mgp = sv_magicext(sv, 0, PERL_MAGIC_utf8, (MGVTBL*)&PL_vtbl_utf8, 0,
0);
(*mgp)->mg_len = -1;
send = s + byte;
- if (SvMAGICAL(sv) && !SvREADONLY(sv) && PL_utf8cache
- && (mg = mg_find(sv, PERL_MAGIC_utf8))) {
+ if (!SvREADONLY(sv)
+ && PL_utf8cache
+ && SvTYPE(sv) >= SVt_PVMG
+ && (mg = mg_find(sv, PERL_MAGIC_utf8)))
+ {
if (mg->mg_ptr) {
STRLEN * const cache = (STRLEN *) mg->mg_ptr;
if (cache[1] == byte) {
sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
}
+
+/*
+ * Warn of missing argument to sprintf, and then return a defined value
+ * to avoid inappropriate "use of uninit" warnings [perl #71000].
+ */
+#define WARN_MISSING WARN_UNINITIALIZED /* Not sure we want a new category */
+STATIC SV*
+S_vcatpvfn_missing_argument(pTHX) {
+ if (ckWARN(WARN_MISSING)) {
+ Perl_warner(aTHX_ packWARN(WARN_MISSING), "Missing argument in %s",
+ PL_op ? OP_DESC(PL_op) : "sv_vcatpvfn()");
+ }
+ return &PL_sv_no;
+}
+
+
STATIC I32
S_expect_number(pTHX_ char **const pattern)
{
vecsv = va_arg(*args, SV*);
else if (evix) {
vecsv = (evix > 0 && evix <= svmax)
- ? svargs[evix-1] : &PL_sv_undef;
+ ? svargs[evix-1] : S_vcatpvfn_missing_argument(aTHX);
} else {
- vecsv = svix < svmax ? svargs[svix++] : &PL_sv_undef;
+ vecsv = svix < svmax
+ ? svargs[svix++] : S_vcatpvfn_missing_argument(aTHX);
}
dotstr = SvPV_const(vecsv, dotstrlen);
/* Keep the DO_UTF8 test *after* the SvPV call, else things go
if (!vectorize && !args) {
if (efix) {
const I32 i = efix-1;
- argsv = (i >= 0 && i < svmax) ? svargs[i] : &PL_sv_undef;
+ argsv = (i >= 0 && i < svmax)
+ ? svargs[i] : S_vcatpvfn_missing_argument(aTHX);
} else {
argsv = (svix >= 0 && svix < svmax)
- ? svargs[svix++] : &PL_sv_undef;
+ ? svargs[svix++] : S_vcatpvfn_missing_argument(aTHX);
}
}
GvNAME_HEK(dstr) = hek_dup(GvNAME_HEK(dstr), param);
/* Don't call sv_add_backref here as it's going to be
created as part of the magic cloning of the symbol
- table. */
+ table--unless this is during a join and the stash
+ is not actually being cloned. */
/* Danger Will Robinson - GvGP(dstr) isn't initialised
at the point of this comment. */
GvSTASH(dstr) = hv_dup(GvSTASH(dstr), param);
+ if(param->flags & CLONEf_JOIN_IN) {
+ const HEK * const hvname
+ = HvNAME_HEK(GvSTASH(dstr));
+ if( hvname
+ && GvSTASH(dstr) == gv_stashpvn(
+ HEK_KEY(hvname), HEK_LEN(hvname), 0
+ )
+ )
+ Perl_sv_add_backref(
+ aTHX_ MUTABLE_SV(GvSTASH(dstr)), dstr
+ );
+ }
GvGP(dstr) = gp_dup(GvGP(sstr), param);
(void)GpREFCNT_inc(GvGP(dstr));
} else
else {
while (items-- > 0)
*dst_ary++ = sv_dup(*src_ary++, param);
+ if (!(param->flags & CLONEf_COPY_STACKS)
+ && AvREIFY(sstr))
+ {
+ av_reify(MUTABLE_AV(dstr)); /* #41138 */
+ }
}
items = AvMAX((const AV *)sstr) - AvFILLp((const AV *)sstr);
while (items-- > 0) {
PerlInterpreter * const my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
PERL_ARGS_ASSERT_PERL_CLONE_USING;
+#else /* !PERL_IMPLICIT_SYS */
+ IV i;
+ CLONE_PARAMS clone_params;
+ CLONE_PARAMS* param = &clone_params;
+ PerlInterpreter * const my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
+
+ PERL_ARGS_ASSERT_PERL_CLONE;
+#endif /* PERL_IMPLICIT_SYS */
/* for each stash, determine whether its objects should be cloned */
S_visit(proto_perl, do_mark_cloneable_stash, SVt_PVHV, SVTYPEMASK);
PERL_SET_THX(my_perl);
-# ifdef DEBUGGING
+#ifdef DEBUGGING
PoisonNew(my_perl, 1, PerlInterpreter);
PL_op = NULL;
PL_curcop = NULL;
PL_markstack = 0;
PL_scopestack = 0;
+ PL_scopestack_name = 0;
PL_savestack = 0;
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 */
+# ifdef DEBUG_LEAKING_SCALARS
+ PL_sv_serial = (((U32)my_perl >> 2) & 0xfff) * 1000000;
+# endif
+#else /* !DEBUGGING */
Zero(my_perl, 1, PerlInterpreter);
-# endif /* DEBUGGING */
+#endif /* DEBUGGING */
+#ifdef PERL_IMPLICIT_SYS
/* host pointers */
PL_Mem = ipM;
PL_MemShared = ipMS;
PL_Dir = ipD;
PL_Sock = ipS;
PL_Proc = ipP;
-#else /* !PERL_IMPLICIT_SYS */
- IV i;
- 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);
-
-# ifdef DEBUGGING
- PoisonNew(my_perl, 1, PerlInterpreter);
- PL_op = NULL;
- PL_curcop = NULL;
- PL_markstack = 0;
- PL_scopestack = 0;
- PL_savestack = 0;
- 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);
-# endif /* DEBUGGING */
#endif /* PERL_IMPLICIT_SYS */
+
param->flags = flags;
param->proto_perl = proto_perl;
SvNV_set(&PL_sv_yes, 1);
ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
+ /* dbargs array probably holds garbage; give the child a clean array */
+ PL_dbargs = newAV();
+ ptr_table_store(PL_ptr_table, proto_perl->Idbargs, PL_dbargs);
+
/* create (a non-shared!) shared string table */
PL_strtab = newHV();
HvSHAREKEYS_off(PL_strtab);
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_dbargs = av_dup(proto_perl->Idbargs, param);
/* symbol tables */
PL_defstash = hv_dup_inc(proto_perl->Idefstash, param);
PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct, param);
PL_utf8_xdigit = sv_dup_inc(proto_perl->Iutf8_xdigit, param);
PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark, param);
+ PL_utf8_X_begin = sv_dup_inc(proto_perl->Iutf8_X_begin, param);
+ PL_utf8_X_extend = sv_dup_inc(proto_perl->Iutf8_X_extend, param);
+ PL_utf8_X_prepend = sv_dup_inc(proto_perl->Iutf8_X_prepend, param);
+ PL_utf8_X_non_hangul = sv_dup_inc(proto_perl->Iutf8_X_non_hangul, param);
+ PL_utf8_X_L = sv_dup_inc(proto_perl->Iutf8_X_L, param);
+ PL_utf8_X_LV = sv_dup_inc(proto_perl->Iutf8_X_LV, param);
+ PL_utf8_X_LVT = sv_dup_inc(proto_perl->Iutf8_X_LVT, param);
+ PL_utf8_X_T = sv_dup_inc(proto_perl->Iutf8_X_T, param);
+ PL_utf8_X_V = sv_dup_inc(proto_perl->Iutf8_X_V, param);
+ PL_utf8_X_LV_LVT_V = sv_dup_inc(proto_perl->Iutf8_X_LV_LVT_V, param);
PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper, param);
PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle, param);
PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower, param);
PL_tmps_max = proto_perl->Itmps_max;
PL_tmps_floor = proto_perl->Itmps_floor;
Newx(PL_tmps_stack, PL_tmps_max, SV*);
- sv_dup_inc_multiple(proto_perl->Itmps_stack, PL_tmps_stack, PL_tmps_ix,
- param);
+ sv_dup_inc_multiple(proto_perl->Itmps_stack, PL_tmps_stack,
+ PL_tmps_ix+1, param);
/* next PUSHMARK() sets *(PL_markstack_ptr+1) */
i = proto_perl->Imarkstack_max - proto_perl->Imarkstack;
Newxz(PL_scopestack, PL_scopestack_max, I32);
Copy(proto_perl->Iscopestack, PL_scopestack, PL_scopestack_ix, I32);
+#ifdef DEBUGGING
+ Newxz(PL_scopestack_name, PL_scopestack_max, const char *);
+ Copy(proto_perl->Iscopestack_name, PL_scopestack_name, PL_scopestack_ix, const char *);
+#endif
/* NOTE: si_dup() looks at PL_markstack */
PL_curstackinfo = si_dup(proto_perl->Icurstackinfo, param);
projects / p5sagit/p5-mst-13.2.git / blobdiff