break;
+ case SVt_REGEXP:
+ /* This ensures that SvTHINKFIRST(sv) is true, and hence that
+ sv_force_normal_flags(sv) is called. */
+ SvFAKE_on(sv);
case SVt_PVIV:
/* XXX Is this still needed? Was it ever needed? Surely as there is
no route from NV to PVIV, NOK can never be true */
case SVt_PVGV:
case SVt_PVCV:
case SVt_PVLV:
- case SVt_REGEXP:
case SVt_PVMG:
case SVt_PVNV:
case SVt_PV:
if (new_type == SVt_PVIO) {
IO * const io = MUTABLE_IO(sv);
- GV *iogv = gv_fetchpvs("IO::Handle::", GV_ADD, SVt_PVHV);
+ GV *iogv = gv_fetchpvs("IO::File::", GV_ADD, SVt_PVHV);
SvOBJECT_on(io);
/* Clear the stashcache because a new IO could overrule a package
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)
if (SvAMAGIC(sv)) {
SV * const tmpsv = AMG_CALLun(sv,bool_);
if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
- return (bool)SvTRUE(tmpsv);
+ return cBOOL(SvTRUE(tmpsv));
}
return SvRV(sv) != 0;
}
SV **location;
U8 import_flag = 0;
const U32 stype = SvTYPE(sref);
- bool mro_changes = FALSE;
PERL_ARGS_ASSERT_GLOB_ASSIGN_REF;
goto common;
case SVt_PVAV:
location = (SV **) &GvAV(dstr);
- if (strEQ(GvNAME((GV*)dstr), "ISA"))
- mro_changes = TRUE;
import_flag = GVf_IMPORTED_AV;
goto common;
case SVt_PVIO:
&& CopSTASH_ne(PL_curcop, GvSTASH(dstr))) {
GvFLAGS(dstr) |= import_flag;
}
+ if (stype == SVt_PVAV && strEQ(GvNAME((GV*)dstr), "ISA")) {
+ sv_magic(sref, dstr, PERL_MAGIC_isa, NULL, 0);
+ mro_isa_changed_in(GvSTASH(dstr));
+ }
break;
}
SvREFCNT_dec(dref);
if (SvTAINTED(sstr))
SvTAINT(dstr);
- if (mro_changes) mro_isa_changed_in(GvSTASH(dstr));
return;
}
sv_unref_flags(sv, flags);
else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
sv_unglob(sv);
+ else if (SvFAKE(sv) && SvTYPE(sv) == SVt_REGEXP) {
+ /* Need to downgrade the REGEXP to a simple(r) scalar. This is analagous
+ to sv_unglob. We only need it here, so inline it. */
+ const svtype new_type = SvMAGIC(sv) || SvSTASH(sv) ? SVt_PVMG : SVt_PV;
+ SV *const temp = newSV_type(new_type);
+ void *const temp_p = SvANY(sv);
+
+ if (new_type == SVt_PVMG) {
+ SvMAGIC_set(temp, SvMAGIC(sv));
+ SvMAGIC_set(sv, NULL);
+ SvSTASH_set(temp, SvSTASH(sv));
+ SvSTASH_set(sv, NULL);
+ }
+ SvCUR_set(temp, SvCUR(sv));
+ /* Remember that SvPVX is in the head, not the body. */
+ if (SvLEN(temp)) {
+ SvLEN_set(temp, SvLEN(sv));
+ /* This signals "buffer is owned by someone else" in sv_clear,
+ which is the least effort way to stop it freeing the buffer.
+ */
+ SvLEN_set(sv, SvLEN(sv)+1);
+ } else {
+ /* Their buffer is already owned by someone else. */
+ SvPVX(sv) = savepvn(SvPVX(sv), SvCUR(sv));
+ SvLEN_set(temp, SvCUR(sv)+1);
+ }
+
+ /* Now swap the rest of the bodies. */
+
+ SvFLAGS(sv) &= ~(SVf_FAKE|SVTYPEMASK);
+ SvFLAGS(sv) |= new_type;
+ SvANY(sv) = SvANY(temp);
+
+ SvFLAGS(temp) &= ~(SVTYPEMASK);
+ SvFLAGS(temp) |= SVt_REGEXP|SVf_FAKE;
+ SvANY(temp) = temp_p;
+
+ SvREFCNT_dec(temp);
+ }
}
/*
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(mg);
mg->mg_len = ulen;
+ /* For now, treat "overflowed" as "still unknown".
+ See RT #72924. */
+ if (ulen != (STRLEN) mg->mg_len)
+ mg->mg_len = -1;
}
}
return ulen;
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) {
/*
-=for apidoc sv_pos_u2b
+=for apidoc sv_pos_u2b_flags
Converts the value pointed to by offsetp from a count of UTF-8 chars from
the start of the string, to a count of the equivalent number of bytes; if
lenp is non-zero, it does the same to lenp, but this time starting from
-the offset, rather than from the start of the string. Handles magic and
-type coercion.
+the offset, rather than from the start of the string. Handles type coercion.
+I<flags> is passed to C<SvPV_flags>, and usually should be
+C<SV_GMAGIC|SV_CONST_RETURN> to handle magic.
=cut
*/
/*
- * sv_pos_u2b() uses, like sv_pos_b2u(), the mg_ptr of the potential
+ * sv_pos_u2b_flags() uses, like sv_pos_b2u(), the mg_ptr of the potential
* PERL_MAGIC_utf8 of the sv to store the mapping between UTF-8 and
* byte offsets. See also the comments of S_utf8_mg_pos_cache_update().
*
*/
-void
-Perl_sv_pos_u2b(pTHX_ register SV *const sv, I32 *const offsetp, I32 *const lenp)
+STRLEN
+Perl_sv_pos_u2b_flags(pTHX_ SV *const sv, STRLEN uoffset, STRLEN *const lenp,
+ U32 flags)
{
const U8 *start;
STRLEN len;
+ STRLEN boffset;
- PERL_ARGS_ASSERT_SV_POS_U2B;
-
- if (!sv)
- return;
+ PERL_ARGS_ASSERT_SV_POS_U2B_FLAGS;
- start = (U8*)SvPV_const(sv, len);
+ start = (U8*)SvPV_flags(sv, len, flags);
if (len) {
- STRLEN uoffset = (STRLEN) *offsetp;
const U8 * const send = start + len;
MAGIC *mg = NULL;
- const STRLEN boffset = sv_pos_u2b_cached(sv, &mg, start, send,
- uoffset, 0, 0);
-
- *offsetp = (I32) boffset;
+ boffset = sv_pos_u2b_cached(sv, &mg, start, send, uoffset, 0, 0);
if (lenp) {
/* Convert the relative offset to absolute. */
- const STRLEN uoffset2 = uoffset + (STRLEN) *lenp;
+ const STRLEN uoffset2 = uoffset + *lenp;
const STRLEN boffset2
= sv_pos_u2b_cached(sv, &mg, start, send, uoffset2,
uoffset, boffset) - boffset;
*lenp = boffset2;
}
- }
- else {
- *offsetp = 0;
- if (lenp)
- *lenp = 0;
+ } else {
+ if (lenp)
+ *lenp = 0;
+ boffset = 0;
}
- return;
+ return boffset;
+}
+
+/*
+=for apidoc sv_pos_u2b
+
+Converts the value pointed to by offsetp from a count of UTF-8 chars from
+the start of the string, to a count of the equivalent number of bytes; if
+lenp is non-zero, it does the same to lenp, but this time starting from
+the offset, rather than from the start of the string. Handles magic and
+type coercion.
+
+Use C<sv_pos_u2b_flags> in preference, which correctly handles strings longer
+than 2Gb.
+
+=cut
+*/
+
+/*
+ * sv_pos_u2b() uses, like sv_pos_b2u(), the mg_ptr of the potential
+ * PERL_MAGIC_utf8 of the sv to store the mapping between UTF-8 and
+ * byte offsets. See also the comments of S_utf8_mg_pos_cache_update().
+ *
+ */
+
+/* This function is subject to size and sign problems */
+
+void
+Perl_sv_pos_u2b(pTHX_ register SV *const sv, I32 *const offsetp, I32 *const lenp)
+{
+ PERL_ARGS_ASSERT_SV_POS_U2B;
+
+ if (lenp) {
+ STRLEN ulen = (STRLEN)*lenp;
+ *offsetp = (I32)sv_pos_u2b_flags(sv, (STRLEN)*offsetp, &ulen,
+ SV_GMAGIC|SV_CONST_RETURN);
+ *lenp = (I32)ulen;
+ } else {
+ *offsetp = (I32)sv_pos_u2b_flags(sv, (STRLEN)*offsetp, NULL,
+ SV_GMAGIC|SV_CONST_RETURN);
+ }
}
/* Create and update the UTF8 magic offset cache, with the proffered utf8/
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) {
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.
+returning. If C<SVf_UTF8> is set, C<s> is considered to be in UTF-8 and the
+C<SVf_UTF8> flag 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) \
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);
}
}
goto vector;
}
}
+ SvTAINT(sv);
}
/* =========================================================================
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) {
daux->xhv_riter = saux->xhv_riter;
daux->xhv_eiter = saux->xhv_eiter
? he_dup(saux->xhv_eiter,
- (bool)!!HvSHAREKEYS(sstr), param) : 0;
+ cBOOL(HvSHAREKEYS(sstr)), param) : 0;
/* backref array needs refcnt=2; see sv_add_backref */
daux->xhv_backreferences =
saux->xhv_backreferences
ptr = POPPTR(ss,ix);
TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
longval = (long)POPBOOL(ss,ix);
- TOPBOOL(nss,ix) = (bool)longval;
+ TOPBOOL(nss,ix) = cBOOL(longval);
break;
case SAVEt_SET_SVFLAGS:
i = POPINT(ss,ix);
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 */
+# 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_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 */
+ PL_dbargs = NULL;
+
/* 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);
projects / p5sagit/p5-mst-13.2.git / blobdiff