# define ASSERT_UTF8_CACHE(cache) NOOP
#endif
-#ifdef PERL_OLD_COPY_ON_WRITE
-#define SV_COW_NEXT_SV(sv) INT2PTR(SV *,SvUVX(sv))
-#define SV_COW_NEXT_SV_SET(current,next) SvUV_set(current, PTR2UV(next))
-#endif
-
/* ============================================================================
=head1 Allocation and deallocation of SVs.
if ((PL_stderrgv && GvGP(PL_stderrgv) && (SV*)GvIO(PL_stderrgv) == sv)
|| (PL_defoutgv && GvGP(PL_defoutgv) && (SV*)GvIO(PL_defoutgv) == sv))
return;
- if (SvPAD_NAME(sv))
- return;
(void)curse(sv, 0);
}
break;
case SVt_PV:
assert(new_type > SVt_PV);
- assert(SVt_IV < SVt_PV);
- assert(SVt_NV < SVt_PV);
+ STATIC_ASSERT_STMT(SVt_IV < SVt_PV);
+ STATIC_ASSERT_STMT(SVt_NV < SVt_PV);
break;
case SVt_PVIV:
break;
there's no way that it can be safely upgraded, because perl.c
expects to Safefree(SvANY(PL_mess_sv)) */
assert(sv != PL_mess_sv);
- /* This flag bit is used to mean other things in other scalar types.
- Given that it only has meaning inside the pad, it shouldn't be set
- on anything that can get upgraded. */
- assert(!SvPAD_TYPED(sv));
break;
default:
if (UNLIKELY(old_type_details->cant_upgrade))
no route from NV to PVIV, NOK can never be true */
assert(!SvNOKp(sv));
assert(!SvNOK(sv));
+ /* FALLTHROUGH */
case SVt_PVIO:
case SVt_PVFM:
case SVt_PVGV:
s = SvPVX_mutable(sv);
}
-#ifdef PERL_NEW_COPY_ON_WRITE
+#ifdef PERL_COPY_ON_WRITE
/* the new COW scheme uses SvPVX(sv)[SvLEN(sv)-1] (if spare)
* to store the COW count. So in general, allocate one more byte than
* asked for, to make it likely this byte is always spare: and thus
* make more strings COW-able.
* If the new size is a big power of two, don't bother: we assume the
* caller wanted a nice 2^N sized block and will be annoyed at getting
- * 2^N+1 */
- if (newlen & 0xff)
+ * 2^N+1.
+ * Only increment if the allocation isn't MEM_SIZE_MAX,
+ * otherwise it will wrap to 0.
+ */
+ if (newlen & 0xff && newlen != MEM_SIZE_MAX)
newlen++;
#endif
/* Don't round up on the first allocation, as odds are pretty good that
* the initial request is accurate as to what is really needed */
if (SvLEN(sv)) {
- newlen = PERL_STRLEN_ROUNDUP(newlen);
+ STRLEN rounded = PERL_STRLEN_ROUNDUP(newlen);
+ if (rounded > newlen)
+ newlen = rounded;
}
#endif
if (SvLEN(sv) && s) {
/* diag_listed_as: Can't coerce %s to %s in %s */
Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
OP_DESC(PL_op));
+ break;
default: NOOP;
}
(void)SvIOK_only(sv); /* validate number */
/* diag_listed_as: Can't coerce %s to %s in %s */
Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
OP_DESC(PL_op));
+ break;
default: NOOP;
}
SvNV_set(sv, num);
if (DO_UTF8(sv)) {
SV *dsv = newSVpvs_flags("", SVs_TEMP);
- pv = sv_uni_display(dsv, sv, 10, UNI_DISPLAY_ISPRINT);
+ pv = sv_uni_display(dsv, sv, 32, UNI_DISPLAY_ISPRINT);
} else {
char *d = tmpbuf;
const char * const limit = tmpbuf + tmpbuf_size - 8;
{
const char *sbegin;
STRLEN len;
+ int numtype;
PERL_ARGS_ASSERT_LOOKS_LIKE_NUMBER;
}
else
return SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK);
- return grok_number(sbegin, len, NULL);
+ numtype = grok_number(sbegin, len, NULL);
+ return ((numtype & IS_NUMBER_TRAILING)) ? 0 : numtype;
}
STATIC bool
/* If numtype is infnan, set the NV of the sv accordingly.
* If numtype is anything else, try setting the NV using Atof(PV). */
+#ifdef USING_MSVC6
+# pragma warning(push)
+# pragma warning(disable:4756;disable:4056)
+#endif
static void
S_sv_setnv(pTHX_ SV* sv, int numtype)
{
SvPOK_on(sv); /* PV is okay, though. */
}
}
+#ifdef USING_MSVC6
+# pragma warning(pop)
+#endif
STATIC bool
S_sv_2iuv_common(pTHX_ SV *const sv)
SvIV_set(sv, I_V(SvNVX(sv)));
if (SvNVX(sv) == (NV) SvIVX(sv)
#ifndef NV_PRESERVES_UV
+ && SvIVX(sv) != IV_MIN /* avoid negating IV_MIN below */
&& (((UV)1 << NV_PRESERVES_UV_BITS) >
(UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
/* Don't flag it as "accurately an integer" if the number
sv_upgrade(sv, SVt_PVNV);
if ((numtype & (IS_NUMBER_INFINITY | IS_NUMBER_NAN))) {
+ if (ckWARN(WARN_NUMERIC) && ((numtype & IS_NUMBER_TRAILING)))
+ not_a_number(sv);
S_sv_setnv(aTHX_ sv, numtype);
return FALSE;
}
} else {
/* 2s complement assumption */
if (value <= (UV)IV_MIN) {
- SvIV_set(sv, -(IV)value);
+ SvIV_set(sv, value == (UV)IV_MIN
+ ? IV_MIN : -(IV)value);
} else {
/* Too negative for an IV. This is a double upgrade, but
I'm assuming it will be rare. */
}
if (SvTHINKFIRST(sv)) {
-#ifdef PERL_OLD_COPY_ON_WRITE
- if (SvIsCOW(sv)) {
- sv_force_normal_flags(sv, 0);
- }
-#endif
if (SvREADONLY(sv) && !SvOK(sv)) {
if (ckWARN(WARN_UNINITIALIZED))
report_uninit(sv);
}
if (SvTHINKFIRST(sv)) {
-#ifdef PERL_OLD_COPY_ON_WRITE
- if (SvIsCOW(sv)) {
- sv_force_normal_flags(sv, 0);
- }
-#endif
if (SvREADONLY(sv) && !SvOK(sv)) {
if (ckWARN(WARN_UNINITIALIZED))
report_uninit(sv);
}
return PTR2NV(SvRV(sv));
}
-#ifdef PERL_OLD_COPY_ON_WRITE
- if (SvIsCOW(sv)) {
- sv_force_normal_flags(sv, 0);
- }
-#endif
if (SvREADONLY(sv) && !SvOK(sv)) {
if (ckWARN(WARN_UNINITIALIZED))
report_uninit(sv);
SvNOK_on(sv);
} else {
/* value has been set. It may not be precise. */
- if ((numtype & IS_NUMBER_NEG) && (value > (UV)IV_MIN)) {
+ if ((numtype & IS_NUMBER_NEG) && (value >= (UV)IV_MIN)) {
/* 2s complement assumption for (UV)IV_MIN */
SvNOK_on(sv); /* Integer is too negative. */
} else {
SvIOKp_on(sv);
if (numtype & IS_NUMBER_NEG) {
+ /* -IV_MIN is undefined, but we should never reach
+ * this point with both IS_NUMBER_NEG and value ==
+ * (UV)IV_MIN */
+ assert(value != (UV)IV_MIN);
SvIV_set(sv, -(IV)value);
} else if (value <= (UV)IV_MAX) {
SvIV_set(sv, (IV)value);
=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.
+reference or overload conversion. The caller is expected to have handled
+get-magic already.
=cut
*/
uv = iv;
sign = 0;
} else {
- uv = -iv;
+ uv = (iv == IV_MIN) ? (UV)iv : (UV)(-iv);
sign = 1;
}
do {
/* Helper for sv_2pv_flags and sv_vcatpvfn_flags. If the NV is an
* infinity or a not-a-number, writes the appropriate strings to the
* buffer, including a zero byte. On success returns the written length,
- * excluding the zero byte, on failure (not an infinity, not a nan, or the
- * maxlen too small) returns zero.
+ * excluding the zero byte, on failure (not an infinity, not a nan)
+ * returns zero, assert-fails on maxlen being too short.
*
* XXX for "Inf", "-Inf", and "NaN", we could have three read-only
* shared string constants we point to, instead of generating a new
* string for each instance. */
STATIC size_t
-S_infnan_2pv(NV nv, char* buffer, size_t maxlen) {
+S_infnan_2pv(NV nv, char* buffer, size_t maxlen, char plus) {
+ char* s = buffer;
assert(maxlen >= 4);
- if (maxlen < 4) /* "Inf\0", "NaN\0" */
- return 0;
- else {
- char* s = buffer;
- if (Perl_isinf(nv)) {
- if (nv < 0) {
- if (maxlen < 5) /* "-Inf\0" */
- return 0;
- *s++ = '-';
- }
- *s++ = 'I';
- *s++ = 'n';
- *s++ = 'f';
- } else if (Perl_isnan(nv)) {
- *s++ = 'N';
- *s++ = 'a';
- *s++ = 'N';
- /* XXX optionally output the payload mantissa bits as
- * "(unsigned)" (to match the nan("...") C99 function,
- * or maybe as "(0xhhh...)" would make more sense...
- * provide a format string so that the user can decide?
- * NOTE: would affect the maxlen and assert() logic.*/
+ if (Perl_isinf(nv)) {
+ if (nv < 0) {
+ if (maxlen < 5) /* "-Inf\0" */
+ return 0;
+ *s++ = '-';
+ } else if (plus) {
+ *s++ = '+';
}
-
- else
- return 0;
- assert((s == buffer + 3) || (s == buffer + 4));
- *s++ = 0;
- return s - buffer - 1; /* -1: excluding the zero byte */
+ *s++ = 'I';
+ *s++ = 'n';
+ *s++ = 'f';
+ }
+ else if (Perl_isnan(nv)) {
+ *s++ = 'N';
+ *s++ = 'a';
+ *s++ = 'N';
+ /* XXX optionally output the payload mantissa bits as
+ * "(unsigned)" (to match the nan("...") C99 function,
+ * or maybe as "(0xhhh...)" would make more sense...
+ * provide a format string so that the user can decide?
+ * NOTE: would affect the maxlen and assert() logic.*/
+ }
+ else {
+ return 0;
}
+ assert((s == buffer + 3) || (s == buffer + 4));
+ *s++ = 0;
+ return s - buffer - 1; /* -1: excluding the zero byte */
}
/*
STRLEN size = 5; /* "-Inf\0" */
s = SvGROW_mutable(sv, size);
- len = S_infnan_2pv(SvNVX(sv), s, size);
+ len = S_infnan_2pv(SvNVX(sv), s, size, 0);
if (len > 0) {
s += len;
SvPOK_on(sv);
#else
{
bool local_radix;
- DECLARE_STORE_LC_NUMERIC_SET_TO_NEEDED();
+ DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
+ STORE_LC_NUMERIC_SET_TO_NEEDED();
local_radix =
PL_numeric_local &&
*/
void
-Perl_sv_copypv(pTHX_ SV *const dsv, SV *const ssv)
-{
- PERL_ARGS_ASSERT_SV_COPYPV;
-
- sv_copypv_flags(dsv, ssv, 0);
-}
-
-void
Perl_sv_copypv_flags(pTHX_ SV *const dsv, SV *const ssv, const I32 flags)
{
STRLEN len;
if (extra) SvGROW(sv, SvCUR(sv) + extra);
return SvCUR(sv);
-must_be_utf8:
+ must_be_utf8:
/* Here, the string should be converted to utf8, either because of an
* input flag (two_byte_count = 0), or because a character that
PERL_ARGS_ASSERT_SV_SETSV_FLAGS;
- if (sstr == dstr)
+ if (UNLIKELY( sstr == dstr ))
return;
if (SvIS_FREED(dstr)) {
" to a freed scalar %p", SVfARG(sstr), (void *)dstr);
}
SV_CHECK_THINKFIRST_COW_DROP(dstr);
- if (!sstr)
+ if (UNLIKELY( !sstr ))
sstr = &PL_sv_undef;
if (SvIS_FREED(sstr)) {
Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p to %p",
switch (stype) {
case SVt_NULL:
undef_sstr:
- if (dtype != SVt_PVGV && dtype != SVt_PVLV) {
+ if (LIKELY( dtype != SVt_PVGV && dtype != SVt_PVLV )) {
(void)SvOK_off(dstr);
return;
}
if (SvIOK(sstr)) {
switch (dtype) {
case SVt_NULL:
- sv_upgrade(dstr, SVt_IV);
+ /* For performance, we inline promoting to type SVt_IV. */
+ /* We're starting from SVt_NULL, so provided that define is
+ * actual 0, we don't have to unset any SV type flags
+ * to promote to SVt_IV. */
+ STATIC_ASSERT_STMT(SVt_NULL == 0);
+ SET_SVANY_FOR_BODYLESS_IV(dstr);
+ SvFLAGS(dstr) |= SVt_IV;
break;
case SVt_NV:
case SVt_PV:
break;
case SVt_NV:
- if (SvNOK(sstr)) {
+ if (LIKELY( SvNOK(sstr) )) {
switch (dtype) {
case SVt_NULL:
case SVt_IV:
dtype = SvTYPE(dstr);
sflags = SvFLAGS(sstr);
- if (dtype == SVt_PVCV) {
+ if (UNLIKELY( dtype == SVt_PVCV )) {
/* Assigning to a subroutine sets the prototype. */
if (SvOK(sstr)) {
STRLEN len;
SvOK_off(dstr);
}
}
- else if (dtype == SVt_PVAV || dtype == SVt_PVHV || dtype == SVt_PVFM) {
+ else if (UNLIKELY(dtype == SVt_PVAV || dtype == SVt_PVHV
+ || dtype == SVt_PVFM))
+ {
const char * const type = sv_reftype(dstr,0);
if (PL_op)
/* diag_listed_as: Cannot copy to %s */
}
else if (flags & SV_COW_SHARED_HASH_KEYS
&&
-#ifdef PERL_OLD_COPY_ON_WRITE
- ( sflags & SVf_IsCOW
- || ( (sflags & CAN_COW_MASK) == CAN_COW_FLAGS
- && (SvFLAGS(dstr) & CAN_COW_MASK) == CAN_COW_FLAGS
- && SvTYPE(sstr) >= SVt_PVIV && len
- )
- )
-#elif defined(PERL_NEW_COPY_ON_WRITE)
+#ifdef PERL_COPY_ON_WRITE
(sflags & SVf_IsCOW
? (!len ||
( (CHECK_COWBUF_THRESHOLD(cur,len) || SvLEN(dstr) < cur+1)
#ifdef PERL_ANY_COW
if (!(sflags & SVf_IsCOW)) {
SvIsCOW_on(sstr);
-# ifdef PERL_OLD_COPY_ON_WRITE
- /* Make the source SV into a loop of 1.
- (about to become 2) */
- SV_COW_NEXT_SV_SET(sstr, sstr);
-# else
CowREFCNT(sstr) = 0;
-# endif
}
#endif
if (SvPVX_const(dstr)) { /* we know that dtype >= SVt_PV */
#ifdef PERL_ANY_COW
if (len) {
-# ifdef PERL_OLD_COPY_ON_WRITE
- assert (SvTYPE(dstr) >= SVt_PVIV);
- /* SvIsCOW_normal */
- /* splice us in between source and next-after-source. */
- SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
- SV_COW_NEXT_SV_SET(sstr, dstr);
-# else
if (sflags & SVf_IsCOW) {
sv_buf_to_rw(sstr);
}
CowREFCNT(sstr)++;
-# endif
SvPV_set(dstr, SvPVX_mutable(sstr));
sv_buf_to_ro(sstr);
} else
}
#ifdef PERL_ANY_COW
-# ifdef PERL_OLD_COPY_ON_WRITE
-# define SVt_COW SVt_PVIV
-# else
# define SVt_COW SVt_PV
-# endif
SV *
Perl_sv_setsv_cow(pTHX_ SV *dstr, SV *sstr)
{
STRLEN cur = SvCUR(sstr);
STRLEN len = SvLEN(sstr);
char *new_pv;
-#if defined(PERL_DEBUG_READONLY_COW) && defined(PERL_NEW_COPY_ON_WRITE)
+#if defined(PERL_DEBUG_READONLY_COW) && defined(PERL_COPY_ON_WRITE)
const bool already = cBOOL(SvIsCOW(sstr));
#endif
assert (SvPOK(sstr));
assert (SvPOKp(sstr));
-# ifdef PERL_OLD_COPY_ON_WRITE
- assert (!SvIOK(sstr));
- assert (!SvIOKp(sstr));
- assert (!SvNOK(sstr));
- assert (!SvNOKp(sstr));
-# endif
if (SvIsCOW(sstr)) {
new_pv = HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr))));
goto common_exit;
}
-# ifdef PERL_OLD_COPY_ON_WRITE
- SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
-# else
assert(SvCUR(sstr)+1 < SvLEN(sstr));
assert(CowREFCNT(sstr) < SV_COW_REFCNT_MAX);
-# endif
} else {
assert ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS);
SvUPGRADE(sstr, SVt_COW);
SvIsCOW_on(sstr);
DEBUG_C(PerlIO_printf(Perl_debug_log,
"Fast copy on write: Converting sstr to COW\n"));
-# ifdef PERL_OLD_COPY_ON_WRITE
- SV_COW_NEXT_SV_SET(dstr, sstr);
-# else
CowREFCNT(sstr) = 0;
-# endif
}
-# ifdef PERL_OLD_COPY_ON_WRITE
- SV_COW_NEXT_SV_SET(sstr, dstr);
-# else
# ifdef PERL_DEBUG_READONLY_COW
if (already) sv_buf_to_rw(sstr);
# endif
CowREFCNT(sstr)++;
-# endif
new_pv = SvPVX_mutable(sstr);
sv_buf_to_ro(sstr);
SvSETMAGIC(sv);
}
-#ifdef PERL_OLD_COPY_ON_WRITE
-/* Need to do this *after* making the SV normal, as we need the buffer
- pointer to remain valid until after we've copied it. If we let go too early,
- another thread could invalidate it by unsharing last of the same hash key
- (which it can do by means other than releasing copy-on-write Svs)
- or by changing the other copy-on-write SVs in the loop. */
-STATIC void
-S_sv_release_COW(pTHX_ 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);
-
- if (current == sv) {
- /* The SV we point to points back to us (there were only two of us
- in the loop.)
- Hence other SV is no longer copy on write either. */
- SvIsCOW_off(after);
- sv_buf_to_rw(after);
- } else {
- /* We need to follow the pointers around the loop. */
- SV *next;
- while ((next = SV_COW_NEXT_SV(current)) != sv) {
- assert (next);
- current = next;
- /* don't loop forever if the structure is bust, and we have
- a pointer into a closed loop. */
- assert (current != after);
- assert (SvPVX_const(current) == pvx);
- }
- /* Make the SV before us point to the SV after us. */
- SV_COW_NEXT_SV_SET(current, after);
- }
- }
-}
-#endif
/*
=for apidoc sv_force_normal_flags
const char * const pvx = SvPVX_const(sv);
const STRLEN len = SvLEN(sv);
const STRLEN cur = SvCUR(sv);
-# ifdef PERL_OLD_COPY_ON_WRITE
- /* next COW sv in the loop. If len is 0 then this is a shared-hash
- key scalar, so we mustn't attempt to call SV_COW_NEXT_SV(), as
- we'll fail an assertion. */
- SV * const next = len ? SV_COW_NEXT_SV(sv) : 0;
-# endif
if (DEBUG_C_TEST) {
PerlIO_printf(Perl_debug_log,
sv_dump(sv);
}
SvIsCOW_off(sv);
-# ifdef PERL_NEW_COPY_ON_WRITE
- if (len && CowREFCNT(sv) == 0)
- /* We own the buffer ourselves. */
- sv_buf_to_rw(sv);
+# ifdef PERL_COPY_ON_WRITE
+ if (len) {
+ /* Must do this first, since the CowREFCNT uses SvPVX and
+ we need to write to CowREFCNT, or de-RO the whole buffer if we are
+ the only owner left of the buffer. */
+ sv_buf_to_rw(sv); /* NOOP if RO-ing not supported */
+ {
+ U8 cowrefcnt = CowREFCNT(sv);
+ if(cowrefcnt != 0) {
+ cowrefcnt--;
+ CowREFCNT(sv) = cowrefcnt;
+ sv_buf_to_ro(sv);
+ goto copy_over;
+ }
+ }
+ /* Else we are the only owner of the buffer. */
+ }
else
# endif
{
-
/* This SV doesn't own the buffer, so need to Newx() a new one: */
-# ifdef PERL_NEW_COPY_ON_WRITE
- /* Must do this first, since the macro uses SvPVX. */
- if (len) {
- sv_buf_to_rw(sv);
- CowREFCNT(sv)--;
- sv_buf_to_ro(sv);
- }
-# endif
+ copy_over:
SvPV_set(sv, NULL);
SvCUR_set(sv, 0);
SvLEN_set(sv, 0);
*SvEND(sv) = '\0';
}
if (len) {
-# ifdef PERL_OLD_COPY_ON_WRITE
- sv_release_COW(sv, pvx, next);
-# endif
} else {
unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
}
PERL_ARGS_ASSERT_SV_MAGICEXT;
- if (SvTYPE(sv)==SVt_PVAV) { assert (!AvPAD_NAMELIST(sv)); }
-
SvUPGRADE(sv, SVt_PVMG);
Newxz(mg, 1, MAGIC);
mg->mg_moremagic = SvMAGIC(sv);
vivify_defelem(sv);
sv = LvTARG(sv);
}
-#ifdef PERL_OLD_COPY_ON_WRITE
- if (SvIsCOW(sv))
- sv_force_normal_flags(sv, 0);
-#endif
return sv_magicext(sv, NULL, PERL_MAGIC_regex_global,
&PL_vtbl_mglob, 0, 0);
}
vtable = (vtable_index == magic_vtable_max)
? NULL : PL_magic_vtables + vtable_index;
-#ifdef PERL_OLD_COPY_ON_WRITE
- if (SvIsCOW(sv))
- sv_force_normal_flags(sv, 0);
-#endif
if (SvREADONLY(sv)) {
if (
!PERL_MAGIC_TYPE_READONLY_ACCEPTABLE(how)
return sv;
}
+/*
+=for apidoc sv_get_backrefs
+
+If the sv is the target of a weak reference then it returns the back
+references structure associated with the sv; otherwise return NULL.
+
+When returning a non-null result the type of the return is relevant. If it
+is an AV then the elements of the AV are the weak reference RVs which
+point at this item. If it is any other type then the item itself is the
+weak reference.
+
+See also Perl_sv_add_backref(), Perl_sv_del_backref(),
+Perl_sv_kill_backrefs()
+
+=cut
+*/
+
+SV *
+Perl_sv_get_backrefs(SV *const sv)
+{
+ SV *backrefs= NULL;
+
+ PERL_ARGS_ASSERT_SV_GET_BACKREFS;
+
+ /* find slot to store array or singleton backref */
+
+ if (SvTYPE(sv) == SVt_PVHV) {
+ if (SvOOK(sv)) {
+ struct xpvhv_aux * const iter = HvAUX((HV *)sv);
+ backrefs = (SV *)iter->xhv_backreferences;
+ }
+ } else if (SvMAGICAL(sv)) {
+ MAGIC *mg = mg_find(sv, PERL_MAGIC_backref);
+ if (mg)
+ backrefs = mg->mg_obj;
+ }
+ return backrefs;
+}
+
/* Give tsv backref magic if it hasn't already got it, then push a
* back-reference to sv onto the array associated with the backref magic.
*
PERL_ARGS_ASSERT_SV_INSERT_FLAGS;
- if (!bigstr)
- Perl_croak(aTHX_ "Can't modify nonexistent substring");
SvPV_force_flags(bigstr, curlen, flags);
(void)SvPOK_only_UTF8(bigstr);
if (offset + len > curlen) {
}
-#ifdef PERL_OLD_COPY_ON_WRITE
- if (SvIsCOW_normal(nsv)) {
- /* We need to follow the pointers around the loop to make the
- previous SV point to sv, rather than nsv. */
- SV *next;
- SV *current = nsv;
- while ((next = SV_COW_NEXT_SV(current)) != nsv) {
- assert(next);
- current = next;
- assert(SvPVX_const(current) == SvPVX_const(nsv));
- }
- /* Make the SV before us point to the SV after us. */
- if (DEBUG_C_TEST) {
- PerlIO_printf(Perl_debug_log, "previous is\n");
- sv_dump(current);
- PerlIO_printf(Perl_debug_log,
- "move it from 0x%"UVxf" to 0x%"UVxf"\n",
- (UV) SV_COW_NEXT_SV(current), (UV) sv);
- }
- SV_COW_NEXT_SV_SET(current, sv);
- }
-#endif
SvREFCNT(sv) = refcnt;
SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
SvREFCNT(nsv) = 0;
SV* iter_sv = NULL;
SV* next_sv = NULL;
SV *sv = orig_sv;
- STRLEN hash_index;
+ STRLEN hash_index = 0; /* initialise to make Coverity et al happy.
+ Not strictly necessary */
PERL_ARGS_ASSERT_SV_CLEAR;
/* objs are always >= MG, but pad names use the SVs_OBJECT flag
for another purpose */
- assert(!SvOBJECT(sv) || type >= SVt_PVMG || SvPAD_NAME(sv));
+ assert(!SvOBJECT(sv) || type >= SVt_PVMG);
if (type >= SVt_PVMG) {
- if (SvOBJECT(sv) && !SvPAD_NAME(sv)) {
+ if (SvOBJECT(sv)) {
if (!curse(sv, 1)) goto get_next_sv;
type = SvTYPE(sv); /* destructor may have changed it */
}
if (SvMAGIC(sv))
mg_free(sv);
}
- else if (type == SVt_PVMG && SvPAD_OUR(sv)) {
- SvREFCNT_dec(SvOURSTASH(sv));
- }
- else if (type == SVt_PVAV && AvPAD_NAMELIST(sv)) {
- assert(!SvMAGICAL(sv));
- } else if (SvMAGIC(sv)) {
+ else if (SvMAGIC(sv)) {
/* Free back-references before other types of magic. */
sv_unmagic(sv, PERL_MAGIC_backref);
mg_free(sv);
}
SvMAGICAL_off(sv);
- if (type == SVt_PVMG && SvPAD_TYPED(sv))
- SvREFCNT_dec(SvSTASH(sv));
}
switch (type) {
/* case SVt_INVLIST: */
PL_last_swash_hv = NULL;
}
if (HvTOTALKEYS((HV*)sv) > 0) {
- const char *name;
+ const HEK *hek;
/* this statement should match the one at the beginning of
* hv_undef_flags() */
if ( PL_phase != PERL_PHASE_DESTRUCT
- && (name = HvNAME((HV*)sv)))
+ && (hek = HvNAME_HEK((HV*)sv)))
{
if (PL_stashcache) {
- DEBUG_o(Perl_deb(aTHX_ "sv_clear clearing PL_stashcache for '%"SVf"'\n",
- SVfARG(sv)));
+ DEBUG_o(Perl_deb(aTHX_
+ "sv_clear clearing PL_stashcache for '%"HEKf
+ "'\n",
+ HEKfARG(hek)));
(void)hv_deletehek(PL_stashcache,
- HvNAME_HEK((HV*)sv), G_DISCARD);
+ hek, G_DISCARD);
}
hv_name_set((HV*)sv, NULL, 0, 0);
}
else if (LvTYPE(sv) != 't') /* unless tie: unrefcnted fake SV** */
SvREFCNT_dec(LvTARG(sv));
if (isREGEXP(sv)) goto freeregexp;
+ /* FALLTHROUGH */
case SVt_PVGV:
if (isGV_with_GP(sv)) {
if(GvCVu((const GV *)sv) && (stash = GvSTASH(MUTABLE_GV(sv)))
PL_statgv = NULL;
else if ((const GV *)sv == PL_stderrgv)
PL_stderrgv = NULL;
+ /* FALLTHROUGH */
case SVt_PVMG:
case SVt_PVNV:
case SVt_PVIV:
sv_dump(sv);
}
if (SvLEN(sv)) {
-# ifdef PERL_OLD_COPY_ON_WRITE
- sv_release_COW(sv, SvPVX_const(sv), SV_COW_NEXT_SV(sv));
-# else
if (CowREFCNT(sv)) {
sv_buf_to_rw(sv);
CowREFCNT(sv)--;
sv_buf_to_ro(sv);
SvLEN_set(sv, 0);
}
-# endif
} else {
unshare_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sv)));
}
}
-# ifdef PERL_OLD_COPY_ON_WRITE
- else
-# endif
if (SvLEN(sv)) {
Safefree(SvPVX_mutable(sv));
}
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 type coercion.
-I<flags> is passed to C<SvPV_flags>, and usually should be
+C<flags> is passed to C<SvPV_flags>, and usually should be
C<SV_GMAGIC|SV_CONST_RETURN> to handle magic.
=cut
Converts the offset from a count of bytes from the start of the string, to
a count of the equivalent number of UTF-8 chars. Handles type coercion.
-I<flags> is passed to C<SvPV_flags>, and usually should be
+C<flags> is passed to C<SvPV_flags>, and usually should be
C<SV_GMAGIC|SV_CONST_RETURN> to handle magic.
=cut
s = SvPV_flags_const(sv, len, flags);
if ((xf = mem_collxfrm(s, len, &xlen))) {
if (! mg) {
-#ifdef PERL_OLD_COPY_ON_WRITE
- if (SvIsCOW(sv))
- sv_force_normal_flags(sv, 0);
-#endif
mg = sv_magicext(sv, 0, PERL_MAGIC_collxfrm, &PL_vtbl_collxfrm,
0, 0);
assert(mg);
the size we read (e.g. CRLF or a gzip layer).
*/
Stat_t st;
- if (!PerlLIO_fstat(PerlIO_fileno(fp), &st) && S_ISREG(st.st_mode)) {
+ int fd = PerlIO_fileno(fp);
+ if (fd >= 0 && (PerlLIO_fstat(fd, &st) == 0) && S_ISREG(st.st_mode)) {
const Off_t offset = PerlIO_tell(fp);
if (offset != (Off_t) -1 && st.st_size + append > offset) {
-#ifdef PERL_NEW_COPY_ON_WRITE
+#ifdef PERL_COPY_ON_WRITE
/* Add an extra byte for the sake of copy-on-write's
* buffer reference count. */
(void) SvGROW(sv, (STRLEN)((st.st_size - offset) + append + 2));
amount left, otherwise this is the amount it
can hold. */
-#if defined(__VMS) && defined(PERLIO_IS_STDIO)
- /* An ungetc()d char is handled separately from the regular
- * buffer, so we getc() it back out and stuff it in the buffer.
- */
- i = PerlIO_getc(fp);
- if (i == EOF) return 0;
- *(--((*fp)->_ptr)) = (unsigned char) i;
- (*fp)->_cnt++;
-#endif
-
/* Here is some breathtakingly efficient cheating */
/* When you read the following logic resist the urge to think
goto thats_all_folks;
}
-thats_all_folks:
+ thats_all_folks:
/* check if we have actually found the separator - only really applies
* when rslen > 1 */
if ((rslen > 1 && (STRLEN)(bp - (STDCHAR*)SvPVX_const(sv)) < rslen) ||
memNE((char*)bp - rslen, rsptr, rslen))
goto screamer; /* go back to the fray */
-thats_really_all_folks:
+ thats_really_all_folks:
if (shortbuffered)
cnt += shortbuffered;
DEBUG_P(PerlIO_printf(Perl_debug_log,
STDCHAR buf[8192];
#endif
-screamer2:
+ screamer2:
if (rslen) {
const STDCHAR * const bpe = buf + sizeof(buf);
bp = buf;
=for apidoc newSVpvf
Creates a new SV and initializes it with the string formatted like
-C<sprintf>.
+C<sv_catpvf>.
=cut
*/
SV *sv;
new_SV(sv);
- sv_setiv(sv,i);
+
+ /* Inlining ONLY the small relevant subset of sv_setiv here
+ * for performance. Makes a significant difference. */
+
+ /* We're starting from SVt_FIRST, so provided that's
+ * actual 0, we don't have to unset any SV type flags
+ * to promote to SVt_IV. */
+ STATIC_ASSERT_STMT(SVt_FIRST == 0);
+
+ SET_SVANY_FOR_BODYLESS_IV(sv);
+ SvFLAGS(sv) |= SVt_IV;
+ (void)SvIOK_on(sv);
+
+ SvIV_set(sv, i);
+ SvTAINT(sv);
+
return sv;
}
{
SV *sv;
+ /* Inlining ONLY the small relevant subset of sv_setuv here
+ * for performance. Makes a significant difference. */
+
+ /* Using ivs is more efficient than using uvs - see sv_setuv */
+ if (u <= (UV)IV_MAX) {
+ return newSViv((IV)u);
+ }
+
new_SV(sv);
- sv_setuv(sv,u);
+
+ /* We're starting from SVt_FIRST, so provided that's
+ * actual 0, we don't have to unset any SV type flags
+ * to promote to SVt_IV. */
+ STATIC_ASSERT_STMT(SVt_FIRST == 0);
+
+ SET_SVANY_FOR_BODYLESS_IV(sv);
+ SvFLAGS(sv) |= SVt_IV;
+ (void)SvIOK_on(sv);
+ (void)SvIsUV_on(sv);
+
+ SvUV_set(sv, u);
+ SvTAINT(sv);
+
return sv;
}
SV *
Perl_newRV_noinc(pTHX_ SV *const tmpRef)
{
- SV *sv = newSV_type(SVt_IV);
+ SV *sv;
PERL_ARGS_ASSERT_NEWRV_NOINC;
+ new_SV(sv);
+
+ /* We're starting from SVt_FIRST, so provided that's
+ * actual 0, we don't have to unset any SV type flags
+ * to promote to SVt_IV. */
+ STATIC_ASSERT_STMT(SVt_FIRST == 0);
+
+ SET_SVANY_FOR_BODYLESS_IV(sv);
+ SvFLAGS(sv) |= SVt_IV;
+ SvROK_on(sv);
+ SvIV_set(sv, 0);
+
SvTEMP_off(tmpRef);
SvRV_set(sv, tmpRef);
- SvROK_on(sv);
+
return sv;
}
SV_CHECK_THINKFIRST_COW_DROP(rv);
- if (SvTYPE(rv) >= SVt_PVMG) {
+ if (UNLIKELY( SvTYPE(rv) >= SVt_PVMG )) {
const U32 refcnt = SvREFCNT(rv);
SvREFCNT(rv) = 0;
sv_clear(rv);
/*
=for apidoc sv_catpvf
-Processes its arguments like C<sprintf> and appends the formatted
-output to an SV. If the appended data contains "wide" characters
+Processes its arguments like C<sv_catpvfn>, and appends the formatted
+output to an SV. As with C<sv_catpvfn> called with a non-null C-style
+variable argument list, argument reordering is not supported.
+If the appended data contains "wide" characters
(including, but not limited to, SVs with a UTF-8 PV formatted with %s,
and characters >255 formatted with %c), the original SV might get
upgraded to UTF-8. Handles 'get' magic, but not 'set' magic. See
/*
=for apidoc sv_vcatpvf
-Processes its arguments like C<vsprintf> and appends the formatted output
+Processes its arguments like C<sv_catpvfn> called with a non-null C-style
+variable argument list, and appends the formatted
to an SV. Does not handle 'set' magic. See C<sv_vcatpvf_mg>.
Usually used via its frontend C<sv_catpvf>.
/*
- * Warn of missing argument to sprintf, and then return a defined value
- * to avoid inappropriate "use of uninit" warnings [perl #71000].
+ * Warn of missing argument to sprintf. The value used in place of such
+ * arguments should be &PL_sv_no; an undefined value would yield
+ * inappropriate "use of uninit" warnings [perl #71000].
*/
-STATIC SV*
-S_vcatpvfn_missing_argument(pTHX) {
+STATIC void
+S_warn_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;
}
PERL_ARGS_ASSERT_F0CONVERT;
if (UNLIKELY(Perl_isinfnan(nv))) {
- STRLEN n = S_infnan_2pv(nv, endbuf - *len, *len);
+ STRLEN n = S_infnan_2pv(nv, endbuf - *len, *len, 0);
*len = n;
return endbuf - n;
}
=for apidoc sv_vcatpvfn_flags
Processes its arguments like C<vsprintf> and appends the formatted output
-to an SV. Uses an array of SVs if the C style variable argument list is
-missing (NULL). When running with taint checks enabled, indicates via
+to an SV. Uses an array of SVs if the C-style variable argument list is
+missing (NULL). Argument reordering (using format specifiers like C<%2$d>
+or C<%*2$d>) is supported only when using an array of SVs; using a C-style
+C<va_list> argument list with a format string that uses argument reordering
+will yield an exception.
+
+When running with taint checks enabled, indicates via
C<maybe_tainted> if results are untrustworthy (often due to the use of
locales).
sv_vcatpvfn_flags(sv, pat, patlen, args, svargs, svmax, maybe_tainted, SV_GMAGIC|SV_SMAGIC);
}
-#if DOUBLEKIND == DOUBLE_IS_IEEE_754_32_BIT_LITTLE_ENDIAN || \
- DOUBLEKIND == DOUBLE_IS_IEEE_754_64_BIT_LITTLE_ENDIAN || \
- DOUBLEKIND == DOUBLE_IS_IEEE_754_128_BIT_LITTLE_ENDIAN
-# define DOUBLE_LITTLE_ENDIAN
-#endif
-
-#if LONG_DOUBLEKIND == LONG_DOUBLE_IS_IEEE_754_128_BIT_LITTLE_ENDIAN || \
- LONG_DOUBLEKIND == LONG_DOUBLE_IS_X86_80_BIT_LITTLE_ENDIAN || \
- LONG_DOUBLEKIND == LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_LITTLE_ENDIAN
-# define LONGDOUBLE_LITTLE_ENDIAN
-#endif
-
-#if LONG_DOUBLEKIND == LONG_DOUBLE_IS_IEEE_754_128_BIT_BIG_ENDIAN || \
- LONG_DOUBLEKIND == LONG_DOUBLE_IS_X86_80_BIT_BIG_ENDIAN || \
- LONG_DOUBLEKIND == LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_BIG_ENDIAN
-# define LONGDOUBLE_BIG_ENDIAN
-#endif
-
-#if LONG_DOUBLEKIND == LONG_DOUBLE_IS_X86_80_BIT_LITTLE_ENDIAN || \
- LONG_DOUBLEKIND == LONG_DOUBLE_IS_X86_80_BIT_BIG_ENDIAN
-# define LONGDOUBLE_X86_80_BIT
-#endif
-
-#if LONG_DOUBLEKIND == LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_LITTLE_ENDIAN || \
- LONG_DOUBLEKIND == LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_BIG_ENDIAN
-# define LONGDOUBLE_DOUBLEDOUBLE
+#ifdef LONGDOUBLE_DOUBLEDOUBLE
/* The first double can be as large as 2**1023, or '1' x '0' x 1023.
* The second double can be as small as 2**-1074, or '0' x 1073 . '1'.
* The sum of them can be '1' . '0' x 2096 . '1', with implied radix point
return v;
}
+/* Helper for sv_vcatpvfn_flags(). */
+#define FETCH_VCATPVFN_ARGUMENT(var, in_range, expr) \
+ STMT_START { \
+ if (in_range) \
+ (var) = (expr); \
+ else { \
+ (var) = &PL_sv_no; /* [perl #71000] */ \
+ arg_missing = TRUE; \
+ } \
+ } STMT_END
+
void
Perl_sv_vcatpvfn_flags(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,
bool no_redundant_warning = FALSE; /* did we use any explicit format parameter index? */
bool hexfp = FALSE; /* hexadecimal floating point? */
- DECLARATION_FOR_STORE_LC_NUMERIC_SET_TO_NEEDED;
+ DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
PERL_ARGS_ASSERT_SV_VCATPVFN_FLAGS;
PERL_UNUSED_ARG(maybe_tainted);
sv_catsv_nomg(sv, *svargs);
}
else
- S_vcatpvfn_missing_argument(aTHX);
+ S_warn_vcatpvfn_missing_argument(aTHX);
return;
}
if (args && patlen == 3 && pat[0] == '%' &&
STRLEN precis = 0;
const I32 osvix = svix;
bool is_utf8 = FALSE; /* is this item utf8? */
+ bool used_explicit_ix = FALSE;
+ bool arg_missing = FALSE;
#ifdef HAS_LDBL_SPRINTF_BUG
/* This is to try to fix a bug with irix/nonstop-ux/powerux and
with sfio - Allen <allens@cpan.org> */
#ifndef FV_ISFINITE
# define FV_ISFINITE(x) Perl_isfinite((NV)(x))
#endif
+ NV nv;
STRLEN have;
STRLEN need;
STRLEN gap;
if ( (width = expect_number(&q)) ) {
if (*q == '$') {
+ if (args)
+ Perl_croak_nocontext(
+ "Cannot yet reorder sv_catpvfn() arguments from va_list");
++q;
efix = width;
- if (!no_redundant_warning)
- /* I've forgotten if it's a better
- micro-optimization to always set this or to
- only set it if it's unset */
- no_redundant_warning = TRUE;
+ used_explicit_ix = TRUE;
} else {
goto gotwidth;
}
tryasterisk:
if (*q == '*') {
q++;
- if ( (ewix = expect_number(&q)) )
- if (*q++ != '$')
+ if ( (ewix = expect_number(&q)) ) {
+ if (*q++ == '$') {
+ if (args)
+ Perl_croak_nocontext(
+ "Cannot yet reorder sv_catpvfn() arguments from va_list");
+ used_explicit_ix = TRUE;
+ } else
goto unknown;
+ }
asterisk = TRUE;
}
if (*q == 'v') {
if (args)
vecsv = va_arg(*args, SV*);
else if (evix) {
- vecsv = (evix > 0 && evix <= svmax)
- ? svargs[evix-1] : S_vcatpvfn_missing_argument(aTHX);
+ FETCH_VCATPVFN_ARGUMENT(
+ vecsv, evix > 0 && evix <= svmax, svargs[evix-1]);
} else {
- vecsv = svix < svmax
- ? svargs[svix++] : S_vcatpvfn_missing_argument(aTHX);
+ FETCH_VCATPVFN_ARGUMENT(
+ vecsv, svix < svmax, svargs[svix++]);
}
dotstr = SvPV_const(vecsv, dotstrlen);
/* Keep the DO_UTF8 test *after* the SvPV call, else things go
q++;
if (*q == '*') {
q++;
- if ( ((epix = expect_number(&q))) && (*q++ != '$') )
- goto unknown;
- /* XXX: todo, support specified precision parameter */
- if (epix)
- goto unknown;
+ if ( (epix = expect_number(&q)) ) {
+ if (*q++ == '$') {
+ if (args)
+ Perl_croak_nocontext(
+ "Cannot yet reorder sv_catpvfn() arguments from va_list");
+ used_explicit_ix = TRUE;
+ } else
+ goto unknown;
+ }
if (args)
- i = va_arg(*args, int);
- else
- i = (ewix ? ewix <= svmax : svix < svmax)
- ? SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
+ i = va_arg(*args, int);
+ else {
+ SV *precsv;
+ if (epix)
+ FETCH_VCATPVFN_ARGUMENT(
+ precsv, epix > 0 && epix <= svmax, svargs[epix-1]);
+ else
+ FETCH_VCATPVFN_ARGUMENT(
+ precsv, svix < svmax, svargs[svix++]);
+ i = precsv == &PL_sv_no ? 0 : SvIVx(precsv);
+ }
precis = i;
has_precis = !(i < 0);
}
q++;
break;
#endif
-#if IVSIZE >= 8 || defined(HAS_LONG_DOUBLE)
+#if (IVSIZE >= 8 || defined(HAS_LONG_DOUBLE)) || \
+ (IVSIZE == 4 && !defined(HAS_LONG_DOUBLE))
case 'L': /* Ld */
/* FALLTHROUGH */
-#ifdef USE_QUADMATH
+# ifdef USE_QUADMATH
case 'Q':
/* FALLTHROUGH */
-#endif
-#if IVSIZE >= 8
+# endif
+# if IVSIZE >= 8
case 'q': /* qd */
-#endif
+# endif
intsize = 'q';
q++;
break;
#endif
case 'l':
++q;
-#if IVSIZE >= 8 || defined(HAS_LONG_DOUBLE)
+#if (IVSIZE >= 8 || defined(HAS_LONG_DOUBLE)) || \
+ (IVSIZE == 4 && !defined(HAS_LONG_DOUBLE))
if (*q == 'l') { /* lld, llf */
intsize = 'q';
++q;
if (!vectorize && !args) {
if (efix) {
const I32 i = efix-1;
- argsv = (i >= 0 && i < svmax)
- ? svargs[i] : S_vcatpvfn_missing_argument(aTHX);
+ FETCH_VCATPVFN_ARGUMENT(argsv, i >= 0 && i < svmax, svargs[i]);
} else {
- argsv = (svix >= 0 && svix < svmax)
- ? svargs[svix++] : S_vcatpvfn_missing_argument(aTHX);
+ FETCH_VCATPVFN_ARGUMENT(argsv, svix >= 0 && svix < svmax,
+ svargs[svix++]);
}
}
if (argsv && strchr("BbcDdiOopuUXx",*q)) {
/* XXX va_arg(*args) case? need peek, use va_copy? */
SvGETMAGIC(argsv);
+ if (UNLIKELY(SvAMAGIC(argsv)))
+ argsv = sv_2num(argsv);
infnan = UNLIKELY(isinfnansv(argsv));
}
if (vectorize) {
STRLEN ulen;
if (!veclen)
- continue;
+ goto donevalidconversion;
if (vec_utf8)
uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
UTF8_ALLOW_ANYUV);
esignbuf[esignlen++] = plus;
}
else {
- uv = -iv;
+ uv = (iv == IV_MIN) ? (UV)iv : (UV)(-iv);
esignbuf[esignlen++] = '-';
}
}
STRLEN ulen;
vector:
if (!veclen)
- continue;
+ goto donevalidconversion;
if (vec_utf8)
uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
UTF8_ALLOW_ANYUV);
#ifdef USE_QUADMATH
fv = intsize == 'q' ?
va_arg(*args, NV) : va_arg(*args, double);
+ nv = fv;
#elif LONG_DOUBLESIZE > DOUBLESIZE
- if (intsize == 'q')
+ if (intsize == 'q') {
fv = va_arg(*args, long double);
- else
- NV_TO_FV(va_arg(*args, double), fv);
+ nv = fv;
+ } else {
+ nv = va_arg(*args, double);
+ NV_TO_FV(nv, fv);
+ }
#else
- fv = va_arg(*args, double);
+ nv = va_arg(*args, double);
+ fv = nv;
#endif
}
else
{
if (!infnan) SvGETMAGIC(argsv);
- NV_TO_FV(SvNV_nomg(argsv), fv);
+ nv = SvNV_nomg(argsv);
+ NV_TO_FV(nv, fv);
}
need = 0;
goto float_converted;
}
} else if ( c == 'f' && !precis ) {
- if ((eptr = F0convert(fv, ebuf + sizeof ebuf, &elen)))
+ if ((eptr = F0convert(nv, ebuf + sizeof ebuf, &elen)))
break;
}
}
* should be output as 0x0.0000000000001p-1022 to
* match its internal structure. */
- /* Note: fv can be (and often is) long double.
- * Here it is explicitly cast to NV. */
- vend = S_hextract(aTHX_ (NV)fv, &exponent, vhex, NULL);
- S_hextract(aTHX_ (NV)fv, &exponent, vhex, vend);
+ vend = S_hextract(aTHX_ nv, &exponent, vhex, NULL);
+ S_hextract(aTHX_ nv, &exponent, vhex, vend);
#if NVSIZE > DOUBLESIZE
# ifdef HEXTRACT_HAS_IMPLICIT_BIT
#endif
if (precis > 0) {
- v = vhex + precis + 1;
- if (v < vend) {
+ if ((SSize_t)(precis + 1) < vend - vhex) {
+ bool round;
+
+ v = vhex + precis + 1;
/* Round away from zero: if the tail
* beyond the precis xdigits is equal to
* or greater than 0x8000... */
- bool round = *v > 0x8;
+ round = *v > 0x8;
if (!round && *v == 0x8) {
for (v++; v < vend; v++) {
if (*v) {
elen = width;
}
}
- else
- elen = S_infnan_2pv(fv, PL_efloatbuf, PL_efloatsize);
+ else {
+ elen = S_infnan_2pv(nv, PL_efloatbuf, PL_efloatsize, plus);
+ if (elen) {
+ /* Not affecting infnan output: precision, alt, fill. */
+ if (elen < width) {
+ if (left) {
+ /* Pack the back with spaces. */
+ memset(PL_efloatbuf + elen, ' ', width - elen);
+ } else {
+ /* Move it to the right. */
+ Move(PL_efloatbuf, PL_efloatbuf + width - elen,
+ elen, char);
+ /* Pad the front with spaces. */
+ memset(PL_efloatbuf, ' ', width - elen);
+ }
+ elen = width;
+ }
+ }
+ }
if (elen == 0) {
char *ptr = ebuf + sizeof ebuf;
if (!qfmt)
Perl_croak_nocontext("panic: quadmath invalid format \"%s\"", ptr);
elen = quadmath_snprintf(PL_efloatbuf, PL_efloatsize,
- qfmt, fv);
+ qfmt, nv);
if ((IV)elen == -1)
Perl_croak_nocontext("panic: quadmath_snprintf failed, format \"%s|'", qfmt);
if (qfmt != ptr)
}
else
sv_setuv_mg(argsv, has_utf8 ? (UV)sv_len_utf8(sv) : (UV)i);
- continue; /* not "break" */
+ goto donevalidconversion;
/* UNKNOWN */
esignlen = 0;
goto vector;
}
+
+ donevalidconversion:
+ if (used_explicit_ix)
+ no_redundant_warning = TRUE;
+ if (arg_missing)
+ S_warn_vcatpvfn_missing_argument(aTHX);
}
/* Now that we've consumed all our printf format arguments (svix)
if (tbl && tbl->tbl_items) {
struct ptr_tbl_arena *arena = tbl->tbl_arena;
- Zero(tbl->tbl_ary, tbl->tbl_max + 1, struct ptr_tbl_ent **);
+ Zero(tbl->tbl_ary, tbl->tbl_max + 1, struct ptr_tbl_ent *);
while (arena) {
struct ptr_tbl_arena *next = arena->next;
#endif
/* don't clone objects whose class has asked us not to */
- if (SvOBJECT(sstr) && !SvPAD_NAME(sstr)
+ if (SvOBJECT(sstr)
&& ! (SvFLAGS(SvSTASH(sstr)) & SVphv_CLONEABLE))
{
SvFLAGS(dstr) = 0;
missing by always going for the destination.
FIXME - instrument and check that assumption */
if (sv_type >= SVt_PVMG) {
- if ((sv_type == SVt_PVMG) && SvPAD_OUR(dstr)) {
- SvOURSTASH_set(dstr, hv_dup_inc(SvOURSTASH(dstr), param));
- } else if (sv_type == SVt_PVAV && AvPAD_NAMELIST(dstr)) {
- NOOP;
- } else if (SvMAGIC(dstr))
+ if (SvMAGIC(dstr))
SvMAGIC_set(dstr, mg_dup(SvMAGIC(dstr), param));
- if (SvOBJECT(dstr) && !SvPAD_NAME(dstr) && SvSTASH(dstr))
+ if (SvOBJECT(dstr) && SvSTASH(dstr))
SvSTASH_set(dstr, hv_dup_inc(SvSTASH(dstr), param));
else SvSTASH_set(dstr, 0); /* don't copy DESTROY cache */
}
}
items = AvMAX((const AV *)sstr) - AvFILLp((const AV *)sstr);
while (items-- > 0) {
- *dst_ary++ = &PL_sv_undef;
+ *dst_ary++ = NULL;
}
}
else {
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 equivalence of
- the two unions.
+ /* Fallthrough: duplicate lazysv.cur by using the ary.ary
+ duplication code instead.
+ We are taking advantage of (1) av_dup_inc and sv_dup_inc
+ actually being the same function, and (2) order
+ equivalence 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);
+ /* FALLTHROUGH */
case CXt_LOOP_FOR:
ncx->blk_loop.state_u.ary.ary
= av_dup_inc(ncx->blk_loop.state_u.ary.ary, param);
+ /* FALLTHROUGH */
case CXt_LOOP_LAZYIV:
case CXt_LOOP_PLAIN:
+ /* code common to all CXt_LOOP_* types */
if (CxPADLOOP(ncx)) {
ncx->blk_loop.itervar_u.oldcomppad
= (PAD*)ptr_table_fetch(PL_ptr_table,
case SAVEt_CLEARPADRANGE:
break;
case SAVEt_HELEM: /* hash element */
+ case SAVEt_SV: /* scalar reference */
sv = (const SV *)POPPTR(ss,ix);
- TOPPTR(nss,ix) = sv_dup_inc(sv, param);
+ TOPPTR(nss,ix) = SvREFCNT_inc(sv_dup_inc(sv, param));
/* FALLTHROUGH */
case SAVEt_ITEM: /* normal string */
case SAVEt_GVSV: /* scalar slot in GV */
- case SAVEt_SV: /* scalar reference */
sv = (const SV *)POPPTR(ss,ix);
TOPPTR(nss,ix) = sv_dup_inc(sv, param);
+ if (type == SAVEt_SV)
+ break;
/* FALLTHROUGH */
case SAVEt_FREESV:
case SAVEt_MORTALIZESV:
sv = (const SV *)POPPTR(ss,ix);
TOPPTR(nss,ix) = sv_dup_inc(sv, param);
break;
+ case SAVEt_FREEPADNAME:
+ ptr = POPPTR(ss,ix);
+ TOPPTR(nss,ix) = padname_dup((PADNAME *)ptr, param);
+ PadnameREFCNT((PADNAME *)TOPPTR(nss,ix))++;
+ break;
case SAVEt_SHARED_PVREF: /* char* in shared space */
c = (char*)POPPTR(ss,ix);
TOPPTR(nss,ix) = savesharedpv(c);
case SAVEt_SVREF: /* scalar reference */
sv = (const SV *)POPPTR(ss,ix);
TOPPTR(nss,ix) = sv_dup_inc(sv, param);
+ if (type == SAVEt_SVREF)
+ SvREFCNT_inc_simple_void((SV *)TOPPTR(nss,ix));
ptr = POPPTR(ss,ix);
TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
break;
break;
case SAVEt_AELEM: /* array element */
sv = (const SV *)POPPTR(ss,ix);
- TOPPTR(nss,ix) = sv_dup_inc(sv, param);
+ TOPPTR(nss,ix) = SvREFCNT_inc(sv_dup_inc(sv, param));
i = POPINT(ss,ix);
TOPINT(nss,ix) = i;
av = (const AV *)POPPTR(ss,ix);
ptr = POPPTR(ss,ix);
TOPPTR(nss,ix) = parser_dup((const yy_parser*)ptr, param);
break;
- case SAVEt_GP_ALIASED_SV:
- ptr = POPPTR(ss,ix);
- TOPPTR(nss,ix) = gp_dup((GP *)ptr, param);
- ((GP *)ptr)->gp_refcnt++;
+ case SAVEt_GP_ALIASED_SV: {
+ GP * gp_ptr = (GP *)POPPTR(ss,ix);
+ GP * new_gp_ptr = gp_dup(gp_ptr, param);
+ TOPPTR(nss,ix) = new_gp_ptr;
+ new_gp_ptr->gp_refcnt++;
break;
+ }
default:
Perl_croak(aTHX_
"panic: ss_dup inconsistency (%"IVdf")", (IV) type);
PL_sig_pending = 0;
PL_parser = NULL;
Zero(&PL_debug_pad, 1, struct perl_debug_pad);
+ Zero(&PL_padname_undef, 1, PADNAME);
+ Zero(&PL_padname_const, 1, PADNAME);
# ifdef DEBUG_LEAKING_SCALARS
PL_sv_serial = (((UV)my_perl >> 2) & 0xfff) * 1000000;
# endif
+# ifdef PERL_TRACE_OPS
+ Zero(PL_op_exec_cnt, OP_max+2, UV);
+# endif
#else /* !DEBUGGING */
Zero(my_perl, 1, PerlInterpreter);
#endif /* DEBUGGING */
PL_subline = proto_perl->Isubline;
+ PL_cv_has_eval = proto_perl->Icv_has_eval;
+
#ifdef FCRYPT
PL_cryptseen = proto_perl->Icryptseen;
#endif
ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
+ ptr_table_store(PL_ptr_table, &proto_perl->Ipadname_const,
+ &PL_padname_const);
/* create (a non-shared!) shared string table */
PL_strtab = newHV();
PL_endav = av_dup_inc(proto_perl->Iendav, param);
PL_checkav = av_dup_inc(proto_perl->Icheckav, param);
PL_initav = av_dup_inc(proto_perl->Iinitav, param);
+ PL_savebegin = proto_perl->Isavebegin;
PL_isarev = hv_dup_inc(proto_perl->Iisarev, param);
PL_subname = sv_dup_inc(proto_perl->Isubname, param);
+#ifdef USE_LOCALE_CTYPE
+ /* Should we warn if uses locale? */
+ PL_warn_locale = sv_dup_inc(proto_perl->Iwarn_locale, param);
+#endif
+
#ifdef USE_LOCALE_COLLATE
PL_collation_name = SAVEPV(proto_perl->Icollation_name);
#endif /* USE_LOCALE_COLLATE */
for (i = 0; i < POSIX_CC_COUNT; i++) {
PL_XPosix_ptrs[i] = sv_dup_inc(proto_perl->IXPosix_ptrs[i], param);
}
+ PL_GCB_invlist = sv_dup_inc(proto_perl->IGCB_invlist, param);
+ PL_SB_invlist = sv_dup_inc(proto_perl->ISB_invlist, param);
+ PL_WB_invlist = sv_dup_inc(proto_perl->IWB_invlist, param);
PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark, param);
- PL_utf8_X_regular_begin = sv_dup_inc(proto_perl->Iutf8_X_regular_begin, param);
- PL_utf8_X_extend = sv_dup_inc(proto_perl->Iutf8_X_extend, 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);
SvLEN_set(&PL_sv_yes, 0);
SvIV_set(&PL_sv_yes, 1);
SvNV_set(&PL_sv_yes, 1);
+
+ PadnamePV(&PL_padname_const) = (char *)PL_No;
}
/*
nsv = sv_newmortal();
SvSetSV_nosteal(nsv, sv);
}
+ save_re_context();
PUSHMARK(sp);
EXTEND(SP, 3);
PUSHs(encoding);
PERL_ARGS_ASSERT_SV_CAT_DECODE;
- if (SvPOK(ssv) && SvPOK(dsv) && SvROK(encoding) && offset) {
+ if (SvPOK(ssv) && SvPOK(dsv) && SvROK(encoding)) {
SV *offsv;
dSP;
ENTER;
SAVETMPS;
+ save_re_context();
PUSHMARK(sp);
EXTEND(SP, 6);
PUSHs(encoding);
}
else {
CV * const cv = gv ? ((CV *)gv) : find_runcv(NULL);
- SV *sv;
- AV *av;
+ PADNAME *sv;
assert(!cv || SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM);
if (!cv || !CvPADLIST(cv))
return NULL;
- av = *PadlistARRAY(CvPADLIST(cv));
- sv = *av_fetch(av, targ, FALSE);
- sv_setsv_flags(name, sv, 0);
+ sv = padnamelist_fetch(PadlistNAMES(CvPADLIST(cv)), targ);
+ sv_setpvn(name, PadnamePV(sv), PadnameLEN(sv));
+ SvUTF8_on(name);
}
if (subscript_type == FUV_SUBSCRIPT_HASH) {
OP_PADSV or OP_GV that gives the name of the undefined variable. On the
other hand, with OP_ADD there are two branches to follow, so we only print
the variable name if we get an exact match.
+desc_p points to a string pointer holding the description of the op.
+This may be updated if needed.
The name is returned as a mortal SV.
STATIC SV *
S_find_uninit_var(pTHX_ const OP *const obase, const SV *const uninit_sv,
- bool match)
+ bool match, const char **desc_p)
{
dVAR;
SV *sv;
const GV *gv;
const OP *o, *o2, *kid;
+ PERL_ARGS_ASSERT_FIND_UNINIT_VAR;
+
if (!obase || (match && (!uninit_sv || uninit_sv == &PL_sv_undef ||
uninit_sv == &PL_sv_placeholder)))
return NULL;
}
else if (obase == PL_op) /* @{expr}, %{expr} */
return find_uninit_var(cUNOPx(obase)->op_first,
- uninit_sv, match);
+ uninit_sv, match, desc_p);
else /* @{expr}, %{expr} as a sub-expression */
return NULL;
}
return varname(gv, '$', 0, NULL, 0, FUV_SUBSCRIPT_NONE);
}
/* ${expr} */
- return find_uninit_var(cUNOPx(obase)->op_first, uninit_sv, 1);
+ return find_uninit_var(cUNOPx(obase)->op_first, uninit_sv, 1, desc_p);
case OP_PADSV:
if (match && PAD_SVl(obase->op_targ) != uninit_sv)
if (!o || o->op_type != OP_NULL ||
! (o->op_targ == OP_AELEM || o->op_targ == OP_HELEM))
break;
- return find_uninit_var(cBINOPo->op_last, uninit_sv, match);
+ return find_uninit_var(cBINOPo->op_last, uninit_sv, match, desc_p);
case OP_AELEM:
case OP_HELEM:
if (PL_op == obase)
/* $a[uninit_expr] or $h{uninit_expr} */
- return find_uninit_var(cBINOPx(obase)->op_last, uninit_sv, match);
+ return find_uninit_var(cBINOPx(obase)->op_last,
+ uninit_sv, match, desc_p);
gv = NULL;
o = cBINOPx(obase)->op_first;
NOT_REACHED; /* NOTREACHED */
}
+ case OP_MULTIDEREF: {
+ /* If we were executing OP_MULTIDEREF when the undef warning
+ * triggered, then it must be one of the index values within
+ * that triggered it. If not, then the only possibility is that
+ * the value retrieved by the last aggregate lookup might be the
+ * culprit. For the former, we set PL_multideref_pc each time before
+ * using an index, so work though the item list until we reach
+ * that point. For the latter, just work through the entire item
+ * list; the last aggregate retrieved will be the candidate.
+ */
+
+ /* the named aggregate, if any */
+ PADOFFSET agg_targ = 0;
+ GV *agg_gv = NULL;
+ /* the last-seen index */
+ UV index_type;
+ PADOFFSET index_targ;
+ GV *index_gv;
+ IV index_const_iv = 0; /* init for spurious compiler warn */
+ SV *index_const_sv;
+ int depth = 0; /* how many array/hash lookups we've done */
+
+ UNOP_AUX_item *items = cUNOP_AUXx(obase)->op_aux;
+ UNOP_AUX_item *last = NULL;
+ UV actions = items->uv;
+ bool is_hv;
+
+ if (PL_op == obase) {
+ last = PL_multideref_pc;
+ assert(last >= items && last <= items + items[-1].uv);
+ }
+
+ assert(actions);
+
+ while (1) {
+ is_hv = FALSE;
+ switch (actions & MDEREF_ACTION_MASK) {
+
+ case MDEREF_reload:
+ actions = (++items)->uv;
+ continue;
+
+ case MDEREF_HV_padhv_helem: /* $lex{...} */
+ is_hv = TRUE;
+ /* FALLTHROUGH */
+ case MDEREF_AV_padav_aelem: /* $lex[...] */
+ agg_targ = (++items)->pad_offset;
+ agg_gv = NULL;
+ break;
+
+ case MDEREF_HV_gvhv_helem: /* $pkg{...} */
+ is_hv = TRUE;
+ /* FALLTHROUGH */
+ case MDEREF_AV_gvav_aelem: /* $pkg[...] */
+ agg_targ = 0;
+ agg_gv = (GV*)UNOP_AUX_item_sv(++items);
+ assert(isGV_with_GP(agg_gv));
+ break;
+
+ case MDEREF_HV_gvsv_vivify_rv2hv_helem: /* $pkg->{...} */
+ case MDEREF_HV_padsv_vivify_rv2hv_helem: /* $lex->{...} */
+ ++items;
+ /* FALLTHROUGH */
+ case MDEREF_HV_pop_rv2hv_helem: /* expr->{...} */
+ case MDEREF_HV_vivify_rv2hv_helem: /* vivify, ->{...} */
+ agg_targ = 0;
+ agg_gv = NULL;
+ is_hv = TRUE;
+ break;
+
+ case MDEREF_AV_gvsv_vivify_rv2av_aelem: /* $pkg->[...] */
+ case MDEREF_AV_padsv_vivify_rv2av_aelem: /* $lex->[...] */
+ ++items;
+ /* FALLTHROUGH */
+ case MDEREF_AV_pop_rv2av_aelem: /* expr->[...] */
+ case MDEREF_AV_vivify_rv2av_aelem: /* vivify, ->[...] */
+ agg_targ = 0;
+ agg_gv = NULL;
+ } /* switch */
+
+ index_targ = 0;
+ index_gv = NULL;
+ index_const_sv = NULL;
+
+ index_type = (actions & MDEREF_INDEX_MASK);
+ switch (index_type) {
+ case MDEREF_INDEX_none:
+ break;
+ case MDEREF_INDEX_const:
+ if (is_hv)
+ index_const_sv = UNOP_AUX_item_sv(++items)
+ else
+ index_const_iv = (++items)->iv;
+ break;
+ case MDEREF_INDEX_padsv:
+ index_targ = (++items)->pad_offset;
+ break;
+ case MDEREF_INDEX_gvsv:
+ index_gv = (GV*)UNOP_AUX_item_sv(++items);
+ assert(isGV_with_GP(index_gv));
+ break;
+ }
+
+ if (index_type != MDEREF_INDEX_none)
+ depth++;
+
+ if ( index_type == MDEREF_INDEX_none
+ || (actions & MDEREF_FLAG_last)
+ || (last && items == last)
+ )
+ break;
+
+ actions >>= MDEREF_SHIFT;
+ } /* while */
+
+ if (PL_op == obase) {
+ /* index was undef */
+
+ *desc_p = ( (actions & MDEREF_FLAG_last)
+ && (obase->op_private
+ & (OPpMULTIDEREF_EXISTS|OPpMULTIDEREF_DELETE)))
+ ?
+ (obase->op_private & OPpMULTIDEREF_EXISTS)
+ ? "exists"
+ : "delete"
+ : is_hv ? "hash element" : "array element";
+ assert(index_type != MDEREF_INDEX_none);
+ if (index_gv)
+ return varname(index_gv, '$', 0, NULL, 0, FUV_SUBSCRIPT_NONE);
+ if (index_targ)
+ return varname(NULL, '$', index_targ,
+ NULL, 0, FUV_SUBSCRIPT_NONE);
+ assert(is_hv); /* AV index is an IV and can't be undef */
+ /* can a const HV index ever be undef? */
+ return NULL;
+ }
+
+ /* the SV returned by pp_multideref() was undef, if anything was */
+
+ if (depth != 1)
+ break;
+
+ if (agg_targ)
+ sv = PAD_SV(agg_targ);
+ else if (agg_gv)
+ sv = is_hv ? MUTABLE_SV(GvHV(agg_gv)) : MUTABLE_SV(GvAV(agg_gv));
+ else
+ break;
+
+ if (index_type == MDEREF_INDEX_const) {
+ if (match) {
+ if (SvMAGICAL(sv))
+ break;
+ if (is_hv) {
+ HE* he = hv_fetch_ent(MUTABLE_HV(sv), index_const_sv, 0, 0);
+ if (!he || HeVAL(he) != uninit_sv)
+ break;
+ }
+ else {
+ SV * const * const svp =
+ av_fetch(MUTABLE_AV(sv), index_const_iv, FALSE);
+ if (!svp || *svp != uninit_sv)
+ break;
+ }
+ }
+ return is_hv
+ ? varname(agg_gv, '%', agg_targ,
+ index_const_sv, 0, FUV_SUBSCRIPT_HASH)
+ : varname(agg_gv, '@', agg_targ,
+ NULL, index_const_iv, FUV_SUBSCRIPT_ARRAY);
+ }
+ else {
+ /* index is an var */
+ if (is_hv) {
+ SV * const keysv = find_hash_subscript((const HV*)sv, uninit_sv);
+ if (keysv)
+ return varname(agg_gv, '%', agg_targ,
+ keysv, 0, FUV_SUBSCRIPT_HASH);
+ }
+ else {
+ const I32 index
+ = find_array_subscript((const AV *)sv, uninit_sv);
+ if (index >= 0)
+ return varname(agg_gv, '@', agg_targ,
+ NULL, index, FUV_SUBSCRIPT_ARRAY);
+ }
+ if (match)
+ break;
+ return varname(agg_gv,
+ is_hv ? '%' : '@',
+ agg_targ, NULL, 0, FUV_SUBSCRIPT_WITHIN);
+ }
+ NOT_REACHED; /* NOTREACHED */
+ }
+
case OP_AASSIGN:
/* only examine RHS */
- return find_uninit_var(cBINOPx(obase)->op_first, uninit_sv, match);
+ return find_uninit_var(cBINOPx(obase)->op_first, uninit_sv,
+ match, desc_p);
case OP_OPEN:
o = cUNOPx(obase)->op_first;
if ( o->op_type == OP_PUSHMARK
|| (o->op_type == OP_NULL && o->op_targ == OP_PUSHMARK)
)
- o = OP_SIBLING(o);
+ o = OpSIBLING(o);
- if (!OP_HAS_SIBLING(o)) {
+ if (!OpHAS_SIBLING(o)) {
/* one-arg version of open is highly magical */
if (o->op_type == OP_GV) { /* open FOO; */
&&
( o->op_type == OP_PUSHMARK
|| (o->op_type == OP_NULL && o->op_targ == OP_PUSHMARK)))
- o = OP_SIBLING(OP_SIBLING(o));
+ o = OpSIBLING(OpSIBLING(o));
goto do_op2;
* it replaced are still in the tree, so we work on them instead.
*/
o2 = NULL;
- for (kid=o; kid; kid = OP_SIBLING(kid)) {
+ for (kid=o; kid; kid = OpSIBLING(kid)) {
const OPCODE type = kid->op_type;
if ( (type == OP_CONST && SvOK(cSVOPx_sv(kid)))
|| (type == OP_NULL && ! (kid->op_flags & OPf_KIDS))
o2 = kid;
}
if (o2)
- return find_uninit_var(o2, uninit_sv, match);
+ return find_uninit_var(o2, uninit_sv, match, desc_p);
/* scan all args */
while (o) {
- sv = find_uninit_var(o, uninit_sv, 1);
+ sv = find_uninit_var(o, uninit_sv, 1, desc_p);
if (sv)
return sv;
- o = OP_SIBLING(o);
+ o = OpSIBLING(o);
}
break;
}
void
Perl_report_uninit(pTHX_ const SV *uninit_sv)
{
+ const char *desc = NULL;
+ SV* varname = NULL;
+
if (PL_op) {
- SV* varname = NULL;
- const char *desc;
+ desc = PL_op->op_type == OP_STRINGIFY && PL_op->op_folded
+ ? "join or string"
+ : OP_DESC(PL_op);
if (uninit_sv && PL_curpad) {
- varname = find_uninit_var(PL_op, uninit_sv,0);
+ varname = find_uninit_var(PL_op, uninit_sv, 0, &desc);
if (varname)
sv_insert(varname, 0, 0, " ", 1);
}
- desc = PL_op->op_type == OP_STRINGIFY && PL_op->op_folded
- ? "join or string"
- : OP_DESC(PL_op);
- /* PL_warn_uninit_sv is constant */
- GCC_DIAG_IGNORE(-Wformat-nonliteral);
- /* diag_listed_as: Use of uninitialized value%s */
- Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit_sv,
- SVfARG(varname ? varname : &PL_sv_no),
- " in ", desc);
- GCC_DIAG_RESTORE;
- }
- else {
- /* PL_warn_uninit is constant */
- GCC_DIAG_IGNORE(-Wformat-nonliteral);
- Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
- "", "", "");
- GCC_DIAG_RESTORE;
}
+ else if (PL_curstackinfo->si_type == PERLSI_SORT
+ && CxMULTICALL(&cxstack[cxstack_ix]))
+ {
+ /* we've reached the end of a sort block or sub,
+ * and the uninit value is probably what that code returned */
+ desc = "sort";
+ }
+
+ /* PL_warn_uninit_sv is constant */
+ GCC_DIAG_IGNORE(-Wformat-nonliteral);
+ if (desc)
+ /* diag_listed_as: Use of uninitialized value%s */
+ Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit_sv,
+ SVfARG(varname ? varname : &PL_sv_no),
+ " in ", desc);
+ else
+ Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
+ "", "", "");
+ GCC_DIAG_RESTORE;
}
/*
- * Local variables:
- * c-indentation-style: bsd
- * c-basic-offset: 4
- * indent-tabs-mode: nil
- * End:
- *
* ex: set ts=8 sts=4 sw=4 et:
*/
https://perl5.git.perl.org / perl5.git / blobdiff