# 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.
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
/* 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)
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;
}
}
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);
/* 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, 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++ = '-';
- } else if (plus) {
- *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 */
}
/*
#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
}
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
+# 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
*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));
}
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)
/*
=for apidoc sv_get_backrefs
-If the sv is the target of a weakrefence then return
-the backrefs structure associated with the sv, otherwise
-return NULL.
+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 contents of the AV
-are the weakrefs which point at this item. If it is any
-other type then the item itself is the weakref.
+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()
*/
SV *
-Perl_sv_get_backrefs(pTHX_ SV *const sv)
+Perl_sv_get_backrefs(SV *const sv)
{
SV *backrefs= NULL;
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;
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
*/
/*
=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;
}
=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
-
-#ifdef HAS_LONG_DOUBLEKIND
-
-# 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
* of dynamically growing buffer might be better, start at just 16 bytes
* (for example) and grow only when necessary. Or maybe just by looking
* at the exponents of the two doubles? */
-# define DOUBLEDOUBLE_MAXBITS 2098
-# endif
-
-#endif /* HAS_LONG_DOUBLE */
+# define DOUBLEDOUBLE_MAXBITS 2098
+#endif
/* vhex will contain the values (0..15) of the hex digits ("nybbles"
* of 4 bits); 1 for the implicit 1, and the mantissa bits, four bits
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);
}
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 (vectorize) {
STRLEN ulen;
if (!veclen)
- continue;
+ goto donevalidconversion;
if (vec_utf8)
uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
UTF8_ALLOW_ANYUV);
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
}
}
else {
- elen = S_infnan_2pv(fv, PL_efloatbuf, PL_efloatsize, plus);
+ elen = S_infnan_2pv(nv, PL_efloatbuf, PL_efloatsize, plus);
if (elen) {
/* Not affecting infnan output: precision, alt, fill. */
if (elen < width) {
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;
}
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,
# 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 */
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);
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);
void
Perl_report_uninit(pTHX_ const SV *uninit_sv)
{
- if (PL_op) {
- SV* varname = NULL;
- const char *desc;
+ const char *desc = NULL;
+ SV* varname = NULL;
+ if (PL_op) {
desc = PL_op->op_type == OP_STRINGIFY && PL_op->op_folded
? "join or string"
: OP_DESC(PL_op);
if (varname)
sv_insert(varname, 0, 0, " ", 1);
}
- /* 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