HASARENA, FIT_ARENA(0, sizeof(XPVMG)) },
/* something big */
- { sizeof(struct regexp), sizeof(struct regexp), 0,
- SVt_REGEXP, FALSE, HADNV, HASARENA, FIT_ARENA(0, sizeof(struct regexp))
+ { 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 */
int
Perl_sv_backoff(pTHX_ register SV *sv)
{
+ STRLEN delta;
+ const char * const s = SvPVX_const(sv);
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);
-#ifdef DEBUGGING
- /* Validate the preceding buffer's sentinels to verify that no-one is
- using it. */
- const U8 *p = (const U8*) s;
- const U8 *const real_start = p - SvIVX(sv);
- while (p > real_start) {
- --p;
- assert (*p == (U8)PTR2UV(p));
- }
-#endif
- 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;
}
/* 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 *sv
+# ifdef DEBUGGING
+ , I32 numtype
+# endif
+ )
{
dVAR;
- PERL_UNUSED_ARG(numtype); /* Used only under DEBUGGING? */
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);
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 {
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 {
len = 7;
retval = buffer = savepvn("NULLREF", len);
} else if (SvTYPE(referent) == SVt_REGEXP) {
- char *str = NULL;
- I32 haseval = 0;
- U32 flags = 0;
- struct magic temp;
- /* FIXME - get rid of this cast away of const, or work out
- how to do it better. */
- temp.mg_obj = (SV *)referent;
- assert(temp.mg_obj);
- (str) = CALLREG_AS_STR(&temp,lp,&flags,&haseval);
- if (flags & 1)
- SvUTF8_on(sv);
- else
- SvUTF8_off(sv);
- PL_reginterp_cnt += haseval;
- return str;
+ 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 *)"";
}
}
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);
}
/* Fall through */
#endif
+ case SVt_REGEXP:
case SVt_PV:
if (dtype < SVt_PV)
sv_upgrade(dstr, SVt_PV);
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_chop(pTHX_ register SV *sv, register const char *ptr)
{
- register STRLEN delta;
+ STRLEN delta;
+ STRLEN old_delta;
+ U8 *p;
+#ifdef DEBUGGING
+ const U8 *real_start;
+#endif
+
if (!ptr || !SvPOKp(sv))
return;
delta = ptr - SvPVX_const(sv);
}
assert(ptr > SvPVX_const(sv));
SV_CHECK_THINKFIRST(sv);
- if (SvTYPE(sv) < SVt_PVIV)
- sv_upgrade(sv,SVt_PVIV);
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
- {
- /* Fill the preceding buffer with sentinals to verify that no-one is
- using it. */
- U8 *p = (U8*) SvPVX(sv);
- const U8 *const real_start = p - SvIVX(sv);
- while (p > real_start) {
- --p;
- *p = (U8)PTR2UV(p);
- }
+ 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
}
goto freescalar;
case SVt_REGEXP:
/* FIXME for plugins */
- pregfree2(sv);
+ pregfree2((REGEXP*) sv);
goto freescalar;
case SVt_PVCV:
case SVt_PVFM:
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:
if (SvROK(sv)) {
SV * const target = SvRV(sv);
if (SvWEAKREF(sv))
return;
}
if (ckWARN_d(WARN_INTERNAL)) {
- 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);
#else
#ifdef DEBUG_LEAKING_SCALARS
- sv_dump(sv);
+ 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);
#endif
}
+#ifdef DEBUG_LEAKING_SCALARS_ABORT
+ abort();
+#endif
return;
}
if (--(SvREFCNT(sv)) > 0)
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
*/
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;
}
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)
case SVt_PVFM: return "FORMAT";
case SVt_PVIO: return "IO";
case SVt_BIND: return "BIND";
- case SVt_REGEXP: return "Regexp"; /* FIXME? to "REGEXP" */
+ case SVt_REGEXP: return "REGEXP";
default: return "UNKNOWN";
}
}
dVAR;
SV *dstr;
- if (!sstr || SvTYPE(sstr) == SVTYPEMASK)
+ 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)
break;
case SVt_REGEXP:
/* FIXME for plugins */
- re_dup_guts(sstr, dstr, param);
+ re_dup_guts((REGEXP*) sstr, (REGEXP*) dstr, param);
break;
case SVt_PVLV:
/* XXX LvTARGOFF sometimes holds PMOP* when DEBUGGING */
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.iterdata = (CxPADLOOP(ncx)
+ ? ncx->blk_loop.iterdata
+ : gv_dup((GV*)ncx->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;
+ ncx->blk_loop.oldcomppad);
+ ncx->blk_loop.itersave = sv_dup_inc(ncx->blk_loop.itersave,
+ param);
+ ncx->blk_loop.iterlval = sv_dup_inc(ncx->blk_loop.iterlval,
+ param);
+ ncx->blk_loop.iterary = av_dup_inc(ncx->blk_loop.iterary,
+ 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:
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];
- /* FIXME for plugins
- newSViv(PTR2IV(CALLREGDUPE(
- INT2PTR(REGEXP *, SvIVX(regex)), param))))
- */
- /* And while we're at it, can we FIXME on the whole hiding
- pointer inside an IV hack? */
- SV * const sv =
- SvREPADTMP(regex)
- ? sv_dup_inc(regex, param)
- : SvREFCNT_inc(
- newSViv(PTR2IV(sv_dup_inc(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 */
projects / p5sagit/p5-mst-13.2.git / blobdiff