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;
}
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
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_sig_pending = 0;
PL_parser = NULL;
Zero(&PL_debug_pad, 1, struct perl_debug_pad);
-# else /* !DEBUGGING */
+ PL_sv_serial = (((U32)my_perl >> 2) & 0xfff) * 1000000;
+#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_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 */
- 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);
https://perl5.git.perl.org / perl5.git / blobdiff