# include <rms.h>
#endif
-#ifndef HAS_C99
-# if defined(__STDC_VERSION__) && __STDC_VERSION__ >= 199901L && !defined(__VMS)
-# define HAS_C99 1
-# endif
-#endif
-#ifdef HAS_C99
-# include <stdint.h>
-#endif
-
#ifdef __Lynx__
/* Missing proto on LynxOS */
char *gconvert(double, int, int, char *);
GE_COWBUF_WASTE_THRESHOLD((cur),(len)) && \
GE_COWBUF_WASTE_FACTOR_THRESHOLD((cur),(len)) \
)
-/* void Gconvert: on Linux at least, gcvt (which Gconvert gets deffed to),
- * has a mandatory return value, even though that value is just the same
- * as the buf arg */
#ifdef PERL_UTF8_CACHE_ASSERT
/* if adding more checks watch out for the following tests:
STATIC SV*
S_more_sv(pTHX)
{
- dVAR;
SV* sv;
char *chunk; /* must use New here to match call to */
Newx(chunk,PERL_ARENA_SIZE,char); /* Safefree() in sv_free_arenas() */
STATIC void
S_del_sv(pTHX_ SV *p)
{
- dVAR;
-
PERL_ARGS_ASSERT_DEL_SV;
if (DEBUG_D_TEST) {
static void
S_sv_add_arena(pTHX_ char *const ptr, const U32 size, const U32 flags)
{
- dVAR;
SV *const sva = MUTABLE_SV(ptr);
SV* sv;
SV* svend;
STATIC I32
S_visit(pTHX_ SVFUNC_t f, const U32 flags, const U32 mask)
{
- dVAR;
SV* sva;
I32 visited = 0;
static void
do_clean_objs(pTHX_ SV *const ref)
{
- dVAR;
assert (SvROK(ref));
{
SV * const target = SvRV(ref);
static void
do_clean_named_objs(pTHX_ SV *const sv)
{
- dVAR;
SV *obj;
assert(SvTYPE(sv) == SVt_PVGV);
assert(isGV_with_GP(sv));
static void
do_clean_named_io_objs(pTHX_ SV *const sv)
{
- dVAR;
SV *obj;
assert(SvTYPE(sv) == SVt_PVGV);
assert(isGV_with_GP(sv));
void
Perl_sv_clean_objs(pTHX)
{
- dVAR;
GV *olddef, *olderr;
PL_in_clean_objs = TRUE;
visit(do_clean_objs, SVf_ROK, SVf_ROK);
static void
do_clean_all(pTHX_ SV *const sv)
{
- dVAR;
if (sv == (const SV *) PL_fdpid || sv == (const SV *)PL_strtab) {
/* don't clean pid table and strtab */
return;
I32
Perl_sv_clean_all(pTHX)
{
- dVAR;
I32 cleaned;
PL_in_clean_all = TRUE;
cleaned = visit(do_clean_all, 0,0);
void
Perl_sv_free_arenas(pTHX)
{
- dVAR;
SV* sva;
SV* svanext;
unsigned int i;
=head1 SV-Body Allocation
+=cut
+
Allocation of SV-bodies is similar to SV-heads, differing as follows;
the allocation mechanism is used for many body types, so is somewhat
more complicated, it uses arena-sets, and has no need for still-live
Perl_more_bodies (pTHX_ const svtype sv_type, const size_t body_size,
const size_t arena_size)
{
- dVAR;
void ** const root = &PL_body_roots[sv_type];
struct arena_desc *adesc;
struct arena_set *aroot = (struct arena_set *) PL_body_arenas;
char *start;
const char *end;
const size_t good_arena_size = Perl_malloc_good_size(arena_size);
+#if defined(DEBUGGING) && defined(PERL_GLOBAL_STRUCT)
+ dVAR;
+#endif
#if defined(DEBUGGING) && !defined(PERL_GLOBAL_STRUCT_PRIVATE)
static bool done_sanity_check;
STATIC void *
S_new_body(pTHX_ const svtype sv_type)
{
- dVAR;
void *xpv;
new_body_inline(xpv, sv_type);
return xpv;
void
Perl_sv_upgrade(pTHX_ SV *const sv, svtype new_type)
{
- dVAR;
void* old_body;
void* new_body;
const svtype old_type = SvTYPE(sv);
*/
int
-Perl_sv_backoff(pTHX_ SV *const sv)
+Perl_sv_backoff(SV *const sv)
{
STRLEN delta;
const char * const s = SvPVX_const(sv);
PERL_ARGS_ASSERT_SV_BACKOFF;
- PERL_UNUSED_CONTEXT;
assert(SvOOK(sv));
assert(SvTYPE(sv) != SVt_PVHV);
void
Perl_sv_setiv(pTHX_ SV *const sv, const IV i)
{
- dVAR;
-
PERL_ARGS_ASSERT_SV_SETIV;
SV_CHECK_THINKFIRST_COW_DROP(sv);
void
Perl_sv_setnv(pTHX_ SV *const sv, const NV num)
{
- dVAR;
-
PERL_ARGS_ASSERT_SV_SETNV;
SV_CHECK_THINKFIRST_COW_DROP(sv);
SvSETMAGIC(sv);
}
-/* Print an "isn't numeric" warning, using a cleaned-up,
- * printable version of the offending string
+/* Return a cleaned-up, printable version of sv, for non-numeric, or
+ * not incrementable warning display.
+ * Originally part of S_not_a_number().
+ * The return value may be != tmpbuf.
*/
-STATIC void
-S_not_a_number(pTHX_ SV *const sv)
-{
- dVAR;
- SV *dsv;
- char tmpbuf[64];
- const char *pv;
+STATIC const char *
+S_sv_display(pTHX_ SV *const sv, char *tmpbuf, STRLEN tmpbuf_size) {
+ const char *pv;
- PERL_ARGS_ASSERT_NOT_A_NUMBER;
+ PERL_ARGS_ASSERT_SV_DISPLAY;
if (DO_UTF8(sv)) {
- dsv = newSVpvs_flags("", SVs_TEMP);
+ SV *dsv = newSVpvs_flags("", SVs_TEMP);
pv = sv_uni_display(dsv, sv, 10, UNI_DISPLAY_ISPRINT);
} else {
char *d = tmpbuf;
- const char * const limit = tmpbuf + sizeof(tmpbuf) - 8;
+ const char * const limit = tmpbuf + tmpbuf_size - 8;
/* each *s can expand to 4 chars + "...\0",
i.e. need room for 8 chars */
pv = tmpbuf;
}
+ return pv;
+}
+
+/* Print an "isn't numeric" warning, using a cleaned-up,
+ * printable version of the offending string
+ */
+
+STATIC void
+S_not_a_number(pTHX_ SV *const sv)
+{
+ char tmpbuf[64];
+ const char *pv;
+
+ PERL_ARGS_ASSERT_NOT_A_NUMBER;
+
+ pv = sv_display(sv, tmpbuf, sizeof(tmpbuf));
+
if (PL_op)
Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
/* diag_listed_as: Argument "%s" isn't numeric%s */
"Argument \"%s\" isn't numeric", pv);
}
+STATIC void
+S_not_incrementable(pTHX_ SV *const sv) {
+ char tmpbuf[64];
+ const char *pv;
+
+ PERL_ARGS_ASSERT_NOT_INCREMENTABLE;
+
+ pv = sv_display(sv, tmpbuf, sizeof(tmpbuf));
+
+ Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
+ "Argument \"%s\" treated as 0 in increment (++)", pv);
+}
+
/*
=for apidoc looks_like_number
# endif
)
{
- dVAR;
-
PERL_ARGS_ASSERT_SV_2IUV_NON_PRESERVE;
+ PERL_UNUSED_CONTEXT;
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) {
STATIC bool
S_sv_2iuv_common(pTHX_ SV *const sv)
{
- dVAR;
-
PERL_ARGS_ASSERT_SV_2IUV_COMMON;
if (SvNOKp(sv)) {
if (! numtype && ckWARN(WARN_NUMERIC))
not_a_number(sv);
-#if defined(USE_LONG_DOUBLE)
- DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" PERL_PRIgldbl ")\n",
+ DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" NVgf ")\n",
PTR2UV(sv), SvNVX(sv)));
-#else
- DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"NVgf")\n",
- PTR2UV(sv), SvNVX(sv)));
-#endif
#ifdef NV_PRESERVES_UV
(void)SvIOKp_on(sv);
(void)SvNOK_on(sv);
+#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
+ if (Perl_isnan(SvNVX(sv))) {
+ SvUV_set(sv, 0);
+ SvIsUV_on(sv);
+ return FALSE;
+ }
+#endif
if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
SvIV_set(sv, I_V(SvNVX(sv)));
if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
IV
Perl_sv_2iv_flags(pTHX_ SV *const sv, const I32 flags)
{
- dVAR;
-
PERL_ARGS_ASSERT_SV_2IV_FLAGS;
assert (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVHV
return (IV)value;
}
}
+
+ /* Quite wrong but no good choices. */
+ if ((numtype & IS_NUMBER_INFINITY)) {
+ return (numtype & IS_NUMBER_NEG) ? IV_MIN : IV_MAX;
+ } else if ((numtype & IS_NUMBER_NAN)) {
+ return 0; /* So wrong. */
+ }
+
if (!numtype) {
if (ckWARN(WARN_NUMERIC))
not_a_number(sv);
UV
Perl_sv_2uv_flags(pTHX_ SV *const sv, const I32 flags)
{
- dVAR;
-
PERL_ARGS_ASSERT_SV_2UV_FLAGS;
if (SvGMAGICAL(sv) && (flags & SV_GMAGIC))
if (!(numtype & IS_NUMBER_NEG))
return value;
}
+
+ /* Quite wrong but no good choices. */
+ if ((numtype & IS_NUMBER_INFINITY)) {
+ return UV_MAX; /* So wrong. */
+ } else if ((numtype & IS_NUMBER_NAN)) {
+ return 0; /* So wrong. */
+ }
+
if (!numtype) {
if (ckWARN(WARN_NUMERIC))
not_a_number(sv);
NV
Perl_sv_2nv_flags(pTHX_ SV *const sv, const I32 flags)
{
- dVAR;
-
PERL_ARGS_ASSERT_SV_2NV_FLAGS;
assert (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVHV
if (SvTYPE(sv) < SVt_NV) {
/* The logic to use SVt_PVNV if necessary is in sv_upgrade. */
sv_upgrade(sv, SVt_NV);
-#ifdef USE_LONG_DOUBLE
DEBUG_c({
STORE_NUMERIC_LOCAL_SET_STANDARD();
PerlIO_printf(Perl_debug_log,
- "0x%"UVxf" num(%" PERL_PRIgldbl ")\n",
- PTR2UV(sv), SvNVX(sv));
- RESTORE_NUMERIC_LOCAL();
- });
-#else
- DEBUG_c({
- STORE_NUMERIC_LOCAL_SET_STANDARD();
- PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%"NVgf")\n",
+ "0x%"UVxf" num(%" NVgf ")\n",
PTR2UV(sv), SvNVX(sv));
RESTORE_NUMERIC_LOCAL();
});
-#endif
}
else if (SvTYPE(sv) < SVt_PVNV)
sv_upgrade(sv, SVt_PVNV);
== IS_NUMBER_IN_UV) {
/* It's definitely an integer */
SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value);
- } else
- SvNV_set(sv, Atof(SvPVX_const(sv)));
+ } else {
+ if ((numtype & IS_NUMBER_INFINITY)) {
+ SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -NV_INF : NV_INF);
+ } else if ((numtype & IS_NUMBER_NAN)) {
+ SvNV_set(sv, NV_NAN);
+ } else
+ SvNV_set(sv, Atof(SvPVX_const(sv)));
+ }
if (numtype)
SvNOK_on(sv);
else
/* Both already have p flags, so do nothing */
} else {
const NV nv = SvNVX(sv);
+ /* XXX should this spot have NAN_COMPARE_BROKEN, too? */
if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
if (SvIVX(sv) == I_V(nv)) {
SvNOK_on(sv);
and ideally should be fixed. */
return 0.0;
}
-#if defined(USE_LONG_DOUBLE)
- DEBUG_c({
- STORE_NUMERIC_LOCAL_SET_STANDARD();
- PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
- PTR2UV(sv), SvNVX(sv));
- RESTORE_NUMERIC_LOCAL();
- });
-#else
DEBUG_c({
STORE_NUMERIC_LOCAL_SET_STANDARD();
- PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%"NVgf")\n",
+ PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" NVgf ")\n",
PTR2UV(sv), SvNVX(sv));
RESTORE_NUMERIC_LOCAL();
});
-#endif
return SvNVX(sv);
}
return ptr;
}
+/* 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. */
+STATIC size_t
+S_infnan_2pv(NV nv, char* buffer, size_t maxlen) {
+ /* XXX this should be an assert */
+ if (maxlen < 4) /* "Inf\0", "NaN\0" */
+ return 0;
+ else {
+ char* s = buffer;
+ /* isnan must be first due to NAN_COMPARE_BROKEN builds, since NAN might
+ use the broken for NAN >/< ops in the inf check, and then the inf
+ check returns true for NAN on NAN_COMPARE_BROKEN compilers */
+ 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 if (Perl_isinf(nv)) {
+ if (nv < 0) {
+ if (maxlen < 5) /* "-Inf\0" */
+ return 0;
+ *s++ = '-';
+ }
+ *s++ = 'I';
+ *s++ = 'n';
+ *s++ = 'f';
+ }
+
+ else
+ return 0;
+ assert((s == buffer + 3) || (s == buffer + 4));
+ *s++ = 0;
+ return s - buffer - 1; /* -1: excluding the zero byte */
+ }
+}
+
/*
=for apidoc sv_2pv_flags
char *
Perl_sv_2pv_flags(pTHX_ SV *const sv, STRLEN *const lp, const I32 flags)
{
- dVAR;
char *s;
PERL_ARGS_ASSERT_SV_2PV_FLAGS;
else if (SvNOK(sv)) {
if (SvTYPE(sv) < SVt_PVNV)
sv_upgrade(sv, SVt_PVNV);
- if (SvNVX(sv) == 0.0) {
+ if (SvNVX(sv) == 0.0
+#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
+ && !Perl_isnan(SvNVX(sv))
+#endif
+ ) {
s = SvGROW_mutable(sv, 2);
*s++ = '0';
*s = '\0';
} else {
- dSAVE_ERRNO;
/* The +20 is pure guesswork. Configure test needed. --jhi */
- s = SvGROW_mutable(sv, NV_DIG + 20);
- /* some Xenix systems wipe out errno here */
+ STRLEN size = NV_DIG + 20;
+ STRLEN len;
+ s = SvGROW_mutable(sv, size);
+
+ len = S_infnan_2pv(SvNVX(sv), s, size);
+ if (len > 0)
+ s += len;
+ else {
+ dSAVE_ERRNO;
+ /* some Xenix systems wipe out errno here */
#ifndef USE_LOCALE_NUMERIC
- PERL_UNUSED_RESULT(Gconvert(SvNVX(sv), NV_DIG, 0, s));
- SvPOK_on(sv);
-#else
- {
- DECLARE_STORE_LC_NUMERIC_SET_TO_NEEDED();
PERL_UNUSED_RESULT(Gconvert(SvNVX(sv), NV_DIG, 0, s));
-
- /* If the radix character is UTF-8, and actually is in the
- * output, turn on the UTF-8 flag for the scalar */
- if (PL_numeric_local
- && PL_numeric_radix_sv && SvUTF8(PL_numeric_radix_sv)
- && instr(s, SvPVX_const(PL_numeric_radix_sv)))
+ SvPOK_on(sv);
+#else
{
- SvUTF8_on(sv);
+ DECLARE_STORE_LC_NUMERIC_SET_TO_NEEDED();
+ PERL_UNUSED_RESULT(Gconvert(SvNVX(sv), NV_DIG, 0, s));
+
+ /* If the radix character is UTF-8, and actually is in the
+ * output, turn on the UTF-8 flag for the scalar */
+ if (PL_numeric_local
+ && PL_numeric_radix_sv && SvUTF8(PL_numeric_radix_sv)
+ && instr(s, SvPVX_const(PL_numeric_radix_sv)))
+ {
+ SvUTF8_on(sv);
+ }
+ RESTORE_LC_NUMERIC();
}
- RESTORE_LC_NUMERIC();
- }
- /* We don't call SvPOK_on(), because it may come to pass that the
- * locale changes so that the stringification we just did is no
- * longer correct. We will have to re-stringify every time it is
- * needed */
+ /* We don't call SvPOK_on(), because it may come to
+ * pass that the locale changes so that the
+ * stringification we just did is no longer correct. We
+ * will have to re-stringify every time it is needed */
#endif
- RESTORE_ERRNO;
- while (*s) s++;
+ RESTORE_ERRNO;
+ }
+ while (*s) s++;
}
}
else if (isGV_with_GP(sv)) {
PERL_ARGS_ASSERT_SV_COPYPV_FLAGS;
- if ((flags & SV_GMAGIC) && SvGMAGICAL(ssv))
- mg_get(ssv);
- s = SvPV_nomg_const(ssv,len);
+ s = SvPV_flags_const(ssv,len,flags & SV_GMAGIC);
sv_setpvn(dsv,s,len);
if (SvUTF8(ssv))
SvUTF8_on(dsv);
bool
Perl_sv_2bool_flags(pTHX_ SV *sv, I32 flags)
{
- dVAR;
-
PERL_ARGS_ASSERT_SV_2BOOL_FLAGS;
restart:
STRLEN
Perl_sv_utf8_upgrade_flags_grow(pTHX_ SV *const sv, const I32 flags, STRLEN extra)
{
- dVAR;
-
PERL_ARGS_ASSERT_SV_UTF8_UPGRADE_FLAGS_GROW;
if (sv == &PL_sv_undef)
* set so starts from there. Otherwise, can use memory copy to
* get up to where we are now, and then start from here */
- if (invariant_head <= 0) {
+ if (invariant_head == 0) {
d = dst;
} else {
Copy(s, dst, invariant_head, char);
bool
Perl_sv_utf8_downgrade(pTHX_ SV *const sv, const bool fail_ok)
{
- dVAR;
-
PERL_ARGS_ASSERT_SV_UTF8_DOWNGRADE;
if (SvPOKp(sv) && SvUTF8(sv)) {
}
GvCVGEN(dstr) = 0; /* Switch off cacheness. */
GvASSUMECV_on(dstr);
- if(GvSTASH(dstr)) gv_method_changed(dstr); /* sub foo { 1 } sub bar { 2 } *bar = \&foo */
+ if(GvSTASH(dstr)) { /* sub foo { 1 } sub bar { 2 } *bar = \&foo */
+ if (intro && GvREFCNT(dstr) > 1) {
+ /* temporary remove extra savestack's ref */
+ --GvREFCNT(dstr);
+ gv_method_changed(dstr);
+ ++GvREFCNT(dstr);
+ }
+ else gv_method_changed(dstr);
+ }
}
*location = SvREFCNT_inc_simple_NN(sref);
if (import_flag && !(GvFLAGS(dstr) & import_flag)
&& CopSTASH_ne(PL_curcop, GvSTASH(dstr))) {
GvFLAGS(dstr) |= import_flag;
}
+ if (import_flag == GVf_IMPORTED_SV) {
+ if (intro) {
+ dSS_ADD;
+ SS_ADD_PTR(gp_ref(GvGP(dstr)));
+ SS_ADD_UV(SAVEt_GP_ALIASED_SV
+ | cBOOL(GvALIASED_SV(dstr)) << 8);
+ SS_ADD_END(2);
+ }
+ /* Turn off the flag if sref is not referenced elsewhere,
+ even by weak refs. (SvRMAGICAL is a pessimistic check for
+ back refs.) */
+ if (SvREFCNT(sref) <= 2 && !SvRMAGICAL(sref))
+ GvALIASED_SV_off(dstr);
+ else
+ GvALIASED_SV_on(dstr);
+ }
if (stype == SVt_PVHV) {
const char * const name = GvNAME((GV*)dstr);
const STRLEN len = GvNAMELEN(dstr);
void
Perl_sv_setsv_flags(pTHX_ SV *dstr, SV* sstr, const I32 flags)
{
- dVAR;
U32 sflags;
int dtype;
svtype stype;
else
Perl_croak(aTHX_ "Bizarre copy of %s", type);
}
- break;
+ NOT_REACHED; /* NOTREACHED */
case SVt_REGEXP:
upgregexp:
void
Perl_sv_setpvn(pTHX_ SV *const sv, const char *const ptr, const STRLEN len)
{
- dVAR;
char *dptr;
PERL_ARGS_ASSERT_SV_SETPVN;
void
Perl_sv_setpv(pTHX_ SV *const sv, const char *const ptr)
{
- dVAR;
STRLEN len;
PERL_ARGS_ASSERT_SV_SETPV;
void
Perl_sv_sethek(pTHX_ SV *const sv, const HEK *const hek)
{
- dVAR;
-
PERL_ARGS_ASSERT_SV_SETHEK;
if (!hek) {
void
Perl_sv_usepvn_flags(pTHX_ SV *const sv, char *ptr, const STRLEN len, const U32 flags)
{
- dVAR;
STRLEN allocate;
PERL_ARGS_ASSERT_SV_USEPVN_FLAGS;
static void
S_sv_uncow(pTHX_ SV * const sv, const U32 flags)
{
- dVAR;
-
assert(SvIsCOW(sv));
{
#ifdef PERL_ANY_COW
void
Perl_sv_catpvn_flags(pTHX_ SV *const dsv, const char *sstr, const STRLEN slen, const I32 flags)
{
- dVAR;
STRLEN dlen;
const char * const dstr = SvPV_force_flags(dsv, dlen, flags);
void
Perl_sv_catsv_flags(pTHX_ SV *const dsv, SV *const ssv, const I32 flags)
{
- dVAR;
-
PERL_ARGS_ASSERT_SV_CATSV_FLAGS;
if (ssv) {
void
Perl_sv_catpv(pTHX_ SV *const sv, const char *ptr)
{
- dVAR;
STRLEN len;
STRLEN tlen;
char *junk;
SV *
Perl_newSV(pTHX_ const STRLEN len)
{
- dVAR;
SV *sv;
new_SV(sv);
Perl_sv_magicext(pTHX_ SV *const sv, SV *const obj, const int how,
const MGVTBL *const vtable, const char *const name, const I32 namlen)
{
- dVAR;
MAGIC* mg;
PERL_ARGS_ASSERT_SV_MAGICEXT;
Perl_sv_magic(pTHX_ SV *const sv, SV *const obj, const int how,
const char *const name, const I32 namlen)
{
- dVAR;
const MGVTBL *vtable;
MAGIC* mg;
unsigned int flags;
void
Perl_sv_add_backref(pTHX_ SV *const tsv, SV *const sv)
{
- dVAR;
SV **svp;
AV *av = NULL;
MAGIC *mg = NULL;
void
Perl_sv_del_backref(pTHX_ SV *const tsv, SV *const sv)
{
- dVAR;
SV **svp = NULL;
PERL_ARGS_ASSERT_SV_DEL_BACKREF;
if (PL_phase == PERL_PHASE_DESTRUCT && SvREFCNT(tsv) == 0)
return;
Perl_croak(aTHX_ "panic: del_backref, *svp=%p phase=%s refcnt=%" UVuf,
- *svp, PL_phase_names[PL_phase], (UV)SvREFCNT(tsv));
+ (void*)*svp, PL_phase_names[PL_phase], (UV)SvREFCNT(tsv));
}
if (SvTYPE(*svp) == SVt_PVAV) {
else {
/* optimisation: only a single backref, stored directly */
if (*svp != sv)
- Perl_croak(aTHX_ "panic: del_backref, *svp=%p, sv=%p", *svp, sv);
+ Perl_croak(aTHX_ "panic: del_backref, *svp=%p, sv=%p",
+ (void*)*svp, (void*)sv);
*svp = NULL;
}
void
Perl_sv_insert_flags(pTHX_ SV *const bigstr, const STRLEN offset, const STRLEN len, const char *const little, const STRLEN littlelen, const U32 flags)
{
- dVAR;
char *big;
char *mid;
char *midend;
void
Perl_sv_replace(pTHX_ SV *const sv, SV *const nsv)
{
- dVAR;
const U32 refcnt = SvREFCNT(sv);
PERL_ARGS_ASSERT_SV_REPLACE;
{
if (PL_stashcache) {
DEBUG_o(Perl_deb(aTHX_ "sv_clear clearing PL_stashcache for '%"SVf"'\n",
- sv));
+ SVfARG(sv)));
(void)hv_deletehek(PL_stashcache,
HvNAME_HEK((HV*)sv), G_DISCARD);
}
static bool
S_curse(pTHX_ SV * const sv, const bool check_refcnt) {
- dVAR;
-
PERL_ARGS_ASSERT_CURSE;
assert(SvOBJECT(sv));
STRLEN
Perl_sv_len_utf8_nomg(pTHX_ SV * const sv)
{
- dVAR;
STRLEN len;
const U8 *s = (U8*)SvPV_nomg_const(sv, len);
assert(cache);
if (PL_utf8cache < 0 && SvPOKp(sv)) {
- /* SvPOKp() because it's possible that sv has string overloading, and
- therefore is a reference, hence SvPVX() is actually a pointer.
- This cures the (very real) symptoms of RT 69422, but I'm not actually
- sure whether we should even be caching the results of UTF-8
- operations on overloading, given that nothing stops overloading
- returning a different value every time it's called. */
+ /* SvPOKp() because, if sv is a reference, then SvPVX() is actually
+ a pointer. Note that we no longer cache utf8 offsets on refer-
+ ences, but this check is still a good idea, for robustness. */
const U8 *start = (const U8 *) SvPVX_const(sv);
const STRLEN realutf8 = utf8_length(start, start + byte);
I32
Perl_sv_eq_flags(pTHX_ SV *sv1, SV *sv2, const U32 flags)
{
- dVAR;
const char *pv1;
STRLEN cur1;
const char *pv2;
Perl_sv_cmp_flags(pTHX_ SV *const sv1, SV *const sv2,
const U32 flags)
{
- dVAR;
STRLEN cur1, cur2;
const char *pv1, *pv2;
I32 cmp;
Perl_sv_cmp_locale_flags(pTHX_ SV *const sv1, SV *const sv2,
const U32 flags)
{
- dVAR;
#ifdef USE_LOCALE_COLLATE
char *pv1, *pv2;
char *
Perl_sv_collxfrm_flags(pTHX_ SV *const sv, STRLEN *const nxp, const I32 flags)
{
- dVAR;
MAGIC *mg;
PERL_ARGS_ASSERT_SV_COLLXFRM_FLAGS;
char *
Perl_sv_gets(pTHX_ SV *const sv, PerlIO *const fp, I32 append)
{
- dVAR;
const char *rsptr;
STRLEN rslen;
STDCHAR rslast;
DEBUG_P(PerlIO_printf(Perl_debug_log,
"Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
DEBUG_P(PerlIO_printf(Perl_debug_log,
- "Screamer: entering: PerlIO * thinks ptr=%"UVuf", cnt=%zd, base=%"
+ "Screamer: entering: PerlIO * thinks ptr=%"UVuf", cnt=%"IVdf", base=%"
UVuf"\n",
- PTR2UV(PerlIO_get_ptr(fp)), PerlIO_get_cnt(fp),
+ PTR2UV(PerlIO_get_ptr(fp)), (IV)PerlIO_get_cnt(fp),
PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
for (;;) {
/* we need to refill the read-ahead buffer if possible */
DEBUG_P(PerlIO_printf(Perl_debug_log,
- "Screamer: going to getc, ptr=%"UVuf", cnt=%zd\n",
- PTR2UV(ptr),cnt));
+ "Screamer: going to getc, ptr=%"UVuf", cnt=%"IVdf"\n",
+ PTR2UV(ptr),(IV)cnt));
PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* deregisterize cnt and ptr */
DEBUG_Pv(PerlIO_printf(Perl_debug_log,
- "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%zd, base=%"UVuf"\n",
- PTR2UV(PerlIO_get_ptr(fp)), PerlIO_get_cnt(fp),
+ "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%"IVdf", base=%"UVuf"\n",
+ PTR2UV(PerlIO_get_ptr(fp)), (IV)PerlIO_get_cnt(fp),
PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
/*
i = PerlIO_getc(fp); /* get more characters */
DEBUG_Pv(PerlIO_printf(Perl_debug_log,
- "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%zd, base=%"UVuf"\n",
- PTR2UV(PerlIO_get_ptr(fp)), PerlIO_get_cnt(fp),
+ "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%"IVdf", base=%"UVuf"\n",
+ PTR2UV(PerlIO_get_ptr(fp)), (IV)PerlIO_get_cnt(fp),
PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
/* find out how much is left in the read-ahead buffer, and rextract its pointer */
cnt = PerlIO_get_cnt(fp);
ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
DEBUG_P(PerlIO_printf(Perl_debug_log,
- "Screamer: after getc, ptr=%"UVuf", cnt=%zd\n",
- PTR2UV(ptr),cnt));
+ "Screamer: after getc, ptr=%"UVuf", cnt=%"IVdf"\n",
+ PTR2UV(ptr),(IV)cnt));
if (i == EOF) /* all done for ever? */
goto thats_really_all_folks;
if (shortbuffered)
cnt += shortbuffered;
DEBUG_P(PerlIO_printf(Perl_debug_log,
- "Screamer: quitting, ptr=%"UVuf", cnt=%zd\n",PTR2UV(ptr),cnt));
+ "Screamer: quitting, ptr=%"UVuf", cnt=%"IVdf"\n",PTR2UV(ptr),(IV)cnt));
PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* put these back or we're in trouble */
DEBUG_P(PerlIO_printf(Perl_debug_log,
- "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%zd, base=%"UVuf
+ "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%"IVdf", base=%"UVuf
"\n",
- PTR2UV(PerlIO_get_ptr(fp)), PerlIO_get_cnt(fp),
+ PTR2UV(PerlIO_get_ptr(fp)), (IV)PerlIO_get_cnt(fp),
PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
*bp = '\0';
SvCUR_set(sv, bp - (STDCHAR*)SvPVX_const(sv)); /* set length */
void
Perl_sv_inc_nomg(pTHX_ SV *const sv)
{
- dVAR;
char *d;
int flags;
while (isALPHA(*d)) d++;
while (isDIGIT(*d)) d++;
if (d < SvEND(sv)) {
+ const int numtype = grok_number_flags(SvPVX_const(sv), SvCUR(sv), NULL, PERL_SCAN_TRAILING);
#ifdef PERL_PRESERVE_IVUV
/* Got to punt this as an integer if needs be, but we don't issue
warnings. Probably ought to make the sv_iv_please() that does
the conversion if possible, and silently. */
- const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), NULL);
if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
/* Need to try really hard to see if it's an integer.
9.22337203685478e+18 is an integer.
/* I don't think we can get here. Maybe I should assert this
And if we do get here I suspect that sv_setnv will croak. NWC
Fall through. */
-#if defined(USE_LONG_DOUBLE)
- DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"PERL_PRIgldbl"\n",
- SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
-#else
DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
-#endif
}
#endif /* PERL_PRESERVE_IVUV */
+ if (!numtype && ckWARN(WARN_NUMERIC))
+ not_incrementable(sv);
sv_setnv(sv,Atof(SvPVX_const(sv)) + 1.0);
return;
}
* arranged in order (although not consecutively) and that only
* [A-Za-z] are accepted by isALPHA in the C locale.
*/
- if (*d != 'z' && *d != 'Z') {
+ if (isALPHA_FOLD_NE(*d, 'z')) {
do { ++*d; } while (!isALPHA(*d));
return;
}
void
Perl_sv_dec(pTHX_ SV *const sv)
{
- dVAR;
if (!sv)
return;
SvGETMAGIC(sv);
void
Perl_sv_dec_nomg(pTHX_ SV *const sv)
{
- dVAR;
int flags;
if (!sv)
/* I don't think we can get here. Maybe I should assert this
And if we do get here I suspect that sv_setnv will croak. NWC
Fall through. */
-#if defined(USE_LONG_DOUBLE)
- DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"PERL_PRIgldbl"\n",
- SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
-#else
DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
-#endif
}
}
#endif /* PERL_PRESERVE_IVUV */
SV *
Perl_sv_mortalcopy_flags(pTHX_ SV *const oldstr, U32 flags)
{
- dVAR;
SV *sv;
if (flags & SV_GMAGIC)
SV *
Perl_sv_newmortal(pTHX)
{
- dVAR;
SV *sv;
new_SV(sv);
SV *
Perl_newSVpvn_flags(pTHX_ const char *const s, const STRLEN len, const U32 flags)
{
- dVAR;
SV *sv;
/* All the flags we don't support must be zero.
SV *
Perl_newSVpv(pTHX_ const char *const s, const STRLEN len)
{
- dVAR;
SV *sv;
new_SV(sv);
SV *
Perl_newSVpvn(pTHX_ const char *const buffer, const STRLEN len)
{
- dVAR;
SV *sv;
-
new_SV(sv);
sv_setpvn(sv,buffer,len);
return sv;
SV *
Perl_newSVhek(pTHX_ const HEK *const hek)
{
- dVAR;
if (!hek) {
SV *sv;
SV *
Perl_vnewSVpvf(pTHX_ const char *const pat, va_list *const args)
{
- dVAR;
SV *sv;
PERL_ARGS_ASSERT_VNEWSVPVF;
SV *
Perl_newSVnv(pTHX_ const NV n)
{
- dVAR;
SV *sv;
new_SV(sv);
SV *
Perl_newSViv(pTHX_ const IV i)
{
- dVAR;
SV *sv;
new_SV(sv);
SV *
Perl_newSVuv(pTHX_ const UV u)
{
- dVAR;
SV *sv;
new_SV(sv);
SV *
Perl_newRV_noinc(pTHX_ SV *const tmpRef)
{
- dVAR;
SV *sv = newSV_type(SVt_IV);
PERL_ARGS_ASSERT_NEWRV_NOINC;
SV *
Perl_newRV(pTHX_ SV *const sv)
{
- dVAR;
-
PERL_ARGS_ASSERT_NEWRV;
return newRV_noinc(SvREFCNT_inc_simple_NN(sv));
SV *
Perl_newSVsv(pTHX_ SV *const old)
{
- dVAR;
SV *sv;
if (!old)
void
Perl_sv_resetpvn(pTHX_ const char *s, STRLEN len, HV * const stash)
{
- dVAR;
char todo[PERL_UCHAR_MAX+1];
const char *send;
CV *
Perl_sv_2cv(pTHX_ SV *sv, HV **const st, GV **const gvp, const I32 lref)
{
- dVAR;
GV *gv = NULL;
CV *cv = NULL;
char *
Perl_sv_pvn_force_flags(pTHX_ SV *const sv, STRLEN *const lp, const I32 flags)
{
- dVAR;
-
PERL_ARGS_ASSERT_SV_PVN_FORCE_FLAGS;
if (flags & SV_GMAGIC) SvGETMAGIC(sv);
case SVt_PVLV: return (char *) (SvROK(sv) ? "REF"
/* tied lvalues should appear to be
* scalars for backwards compatibility */
- : (LvTYPE(sv) == 't' || LvTYPE(sv) == 'T')
+ : (isALPHA_FOLD_EQ(LvTYPE(sv), 't'))
? "SCALAR" : "LVALUE");
case SVt_PVAV: return "ARRAY";
case SVt_PVHV: return "HASH";
SV*
Perl_newSVrv(pTHX_ SV *const rv, const char *const classname)
{
- dVAR;
SV *sv;
PERL_ARGS_ASSERT_NEWSVRV;
SV*
Perl_sv_setref_pv(pTHX_ SV *const rv, const char *const classname, void *const pv)
{
- dVAR;
-
PERL_ARGS_ASSERT_SV_SETREF_PV;
if (!pv) {
SV*
Perl_sv_bless(pTHX_ SV *const sv, HV *const stash)
{
- dVAR;
SV *tmpRef;
HV *oldstash = NULL;
PERL_STATIC_INLINE void
S_sv_unglob(pTHX_ SV *const sv, U32 flags)
{
- dVAR;
void *xpvmg;
HV *stash;
SV * const temp = flags & SV_COW_DROP_PV ? NULL : sv_newmortal();
Perl_sv_untaint(pTHX_ SV *const sv)
{
PERL_ARGS_ASSERT_SV_UNTAINT;
+ PERL_UNUSED_CONTEXT;
if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint);
Perl_sv_tainted(pTHX_ SV *const sv)
{
PERL_ARGS_ASSERT_SV_TAINTED;
+ PERL_UNUSED_CONTEXT;
if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
const MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint);
* Warn of missing argument to sprintf, and then return a defined value
* to avoid inappropriate "use of uninit" warnings [perl #71000].
*/
-#define WARN_MISSING WARN_UNINITIALIZED /* Not sure we want a new category */
STATIC SV*
S_vcatpvfn_missing_argument(pTHX) {
if (ckWARN(WARN_MISSING)) {
STATIC I32
S_expect_number(pTHX_ char **const pattern)
{
- dVAR;
I32 var = 0;
PERL_ARGS_ASSERT_EXPECT_NUMBER;
sv_vcatpvfn_flags(sv, pat, patlen, args, svargs, svmax, maybe_tainted, SV_GMAGIC|SV_SMAGIC);
}
+#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
+# define DOUBLEDOUBLE_MAXBITS 1028
+#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
+ * per xdigit. */
+#ifdef LONGDOUBLE_DOUBLEDOUBLE
+# define VHEX_SIZE (1+DOUBLEDOUBLE_MAXBITS/4)
+#else
+# define VHEX_SIZE (1+128/4)
+#endif
+
+/* If we do not have a known long double format, (including not using
+ * long doubles, or long doubles being equal to doubles) then we will
+ * fall back to the ldexp/frexp route, with which we can retrieve at
+ * most as many bits as our widest unsigned integer type is. We try
+ * to get a 64-bit unsigned integer even if we are not using a 64-bit UV.
+ *
+ * (If you want to test the case of UVSIZE == 4, NVSIZE == 8,
+ * set the MANTISSATYPE to int and the MANTISSASIZE to 4.)
+ */
+#if defined(HAS_QUAD) && defined(Uquad_t)
+# define MANTISSATYPE Uquad_t
+# define MANTISSASIZE 8
+#else
+# define MANTISSATYPE UV
+# define MANTISSASIZE UVSIZE
+#endif
+
+/* We make here the wild assumption that the endianness of doubles
+ * is similar to the endianness of integers, and that there is no
+ * middle-endianness. This may come back to haunt us (the rumor
+ * has it that ARM can be quite haunted). */
+#if BYTEORDER == 0x12345678 || BYTEORDER == 0x1234 || \
+ defined(DOUBLEKIND_LITTLE_ENDIAN)
+# define HEXTRACT_LITTLE_ENDIAN
+#else
+# define HEXTRACT_BIG_ENDIAN
+#endif
+
+/* S_hextract() is a helper for Perl_sv_vcatpvfn_flags, for extracting
+ * the hexadecimal values (for %a/%A). The nv is the NV where the value
+ * are being extracted from (either directly from the long double in-memory
+ * presentation, or from the uquad computed via frexp+ldexp). frexp also
+ * is used to update the exponent. vhex is the pointer to the beginning
+ * of the output buffer (of VHEX_SIZE).
+ *
+ * The tricky part is that S_hextract() needs to be called twice:
+ * the first time with vend as NULL, and the second time with vend as
+ * the pointer returned by the first call. What happens is that on
+ * the first round the output size is computed, and the intended
+ * extraction sanity checked. On the second round the actual output
+ * (the extraction of the hexadecimal values) takes place.
+ * Sanity failures cause fatal failures during both rounds. */
+STATIC U8*
+S_hextract(pTHX_ const NV nv, int* exponent, U8* vhex, U8* vend)
+{
+ U8* v = vhex;
+ int ix;
+ int ixmin = 0, ixmax = 0;
+
+ /* XXX Inf/NaN/denormal handling in the HEXTRACT_IMPLICIT_BIT,
+ * and elsewhere. */
+
+ /* These macros are just to reduce typos, they have multiple
+ * repetitions below, but usually only one (or sometimes two)
+ * of them is really being used. */
+ /* HEXTRACT_OUTPUT() extracts the high nybble first. */
+#define HEXTRACT_OUTPUT_HI(ix) (*v++ = nvp[ix] >> 4)
+#define HEXTRACT_OUTPUT_LO(ix) (*v++ = nvp[ix] & 0xF)
+#define HEXTRACT_OUTPUT(ix) \
+ STMT_START { \
+ HEXTRACT_OUTPUT_HI(ix); HEXTRACT_OUTPUT_LO(ix); \
+ } STMT_END
+#define HEXTRACT_COUNT(ix, c) \
+ STMT_START { \
+ v += c; if (ix < ixmin) ixmin = ix; else if (ix > ixmax) ixmax = ix; \
+ } STMT_END
+#define HEXTRACT_BYTE(ix) \
+ STMT_START { \
+ if (vend) HEXTRACT_OUTPUT(ix); else HEXTRACT_COUNT(ix, 2); \
+ } STMT_END
+#define HEXTRACT_LO_NYBBLE(ix) \
+ STMT_START { \
+ if (vend) HEXTRACT_OUTPUT_LO(ix); else HEXTRACT_COUNT(ix, 1); \
+ } STMT_END
+# define HEXTRACT_IMPLICIT_BIT(nv) \
+ STMT_START { \
+ if (vend) *v++ = ((nv) == 0.0) ? 0 : 1; else v++; \
+ } STMT_END
+
+#ifdef LONGDOUBLE_DOUBLEDOUBLE
+# define HEXTRACTSIZE (DOUBLEDOUBLE_MAXBITS/8)
+#else
+# define HEXTRACTSIZE NVSIZE
+#endif
+
+ const U8* nvp = (const U8*)(&nv);
+ const U8* vmaxend = vhex + 2 * HEXTRACTSIZE + 1;
+ (void)Perl_frexp(PERL_ABS(nv), exponent);
+ if (vend && (vend <= vhex || vend > vmaxend))
+ Perl_croak(aTHX_ "Hexadecimal float: internal error");
+
+ /* First check if using long doubles. */
+#if NVSIZE > DOUBLESIZE
+# if LONG_DOUBLEKIND == LONG_DOUBLE_IS_IEEE_754_128_BIT_LITTLE_ENDIAN
+ /* Used in e.g. VMS and HP-UX IA-64, e.g. -0.1L:
+ * 9a 99 99 99 99 99 99 99 99 99 99 99 99 99 fb 3f */
+ /* The bytes 13..0 are the mantissa/fraction,
+ * the 15,14 are the sign+exponent. */
+ HEXTRACT_IMPLICIT_BIT(nv);
+ for (ix = 13; ix >= 0; ix--) {
+ HEXTRACT_BYTE(ix);
+ }
+# elif LONG_DOUBLEKIND == LONG_DOUBLE_IS_IEEE_754_128_BIT_BIG_ENDIAN
+ /* Used in e.g. Solaris Sparc and HP-UX PA-RISC, e.g. -0.1L:
+ * bf fb 99 99 99 99 99 99 99 99 99 99 99 99 99 9a */
+ /* The bytes 2..15 are the mantissa/fraction,
+ * the 0,1 are the sign+exponent. */
+ HEXTRACT_IMPLICIT_BIT(nv);
+ for (ix = 2; ix <= 15; ix++) {
+ HEXTRACT_BYTE(ix);
+ }
+# elif LONG_DOUBLEKIND == LONG_DOUBLE_IS_X86_80_BIT_LITTLE_ENDIAN
+ /* x86 80-bit "extended precision", 64 bits of mantissa / fraction /
+ * significand, 15 bits of exponent, 1 bit of sign. NVSIZE can
+ * be either 12 (ILP32, Solaris x86) or 16 (LP64, Linux and OS X),
+ * meaning that 2 or 6 bytes are empty padding. */
+ /* The bytes 7..0 are the mantissa/fraction */
+
+ /* Intentionally NO HEXTRACT_IMPLICIT_BIT here. */
+ for (ix = 7; ix >= 0; ix--) {
+ HEXTRACT_BYTE(ix);
+ }
+# elif LONG_DOUBLEKIND == LONG_DOUBLE_IS_X86_80_BIT_BIG_ENDIAN
+ /* Does this format ever happen? (Wikipedia says the Motorola
+ * 6888x math coprocessors used format _like_ this but padded
+ * to 96 bits with 16 unused bits between the exponent and the
+ * mantissa.) */
+
+ /* Intentionally NO HEXTRACT_IMPLICIT_BIT here. */
+ for (ix = 0; ix < 8; ix++) {
+ HEXTRACT_BYTE(ix);
+ }
+# elif defined(LONGDOUBLE_DOUBLEDOUBLE)
+ /* Double-double format: two doubles next to each other.
+ * The first double is the high-order one, exactly like
+ * it would be for a "lone" double. The second double
+ * is shifted down using the exponent so that that there
+ * are no common bits. The tricky part is that the value
+ * of the double-double is the SUM of the two doubles and
+ * the second one can be also NEGATIVE.
+ *
+ * Because of this tricky construction the bytewise extraction we
+ * use for the other long double formats doesn't work, we must
+ * extract the values bit by bit.
+ *
+ * The little-endian double-double is used .. somewhere?
+ *
+ * The big endian double-double is used in e.g. PPC/Power (AIX)
+ * and MIPS (SGI).
+ *
+ * The mantissa bits are in two separate stretches, e.g. for -0.1L:
+ * 9a 99 99 99 99 99 59 bc 9a 99 99 99 99 99 b9 3f (LE)
+ * 3f b9 99 99 99 99 99 9a bc 59 99 99 99 99 99 9a (BE)
+ */
+
+ if (nv == (NV)0.0) {
+ if (vend)
+ *v++ = 0;
+ else
+ v++;
+ *exponent = 0;
+ }
+ else {
+ NV d = nv < 0 ? -nv : nv;
+ NV e = (NV)1.0;
+ U8 ha = 0x0; /* hexvalue accumulator */
+ U8 hd = 0x8; /* hexvalue digit */
+
+ /* Shift d and e (and update exponent) so that e <= d < 2*e,
+ * this is essentially manual frexp(). Multiplying by 0.5 and
+ * doubling should be lossless in binary floating point. */
+
+ *exponent = 1;
+
+ while (e > d) {
+ e *= (NV)0.5;
+ (*exponent)--;
+ }
+ /* Now d >= e */
+
+ while (d >= e + e) {
+ e += e;
+ (*exponent)++;
+ }
+ /* Now e <= d < 2*e */
+
+ /* First extract the leading hexdigit (the implicit bit). */
+ if (d >= e) {
+ d -= e;
+ if (vend)
+ *v++ = 1;
+ else
+ v++;
+ }
+ else {
+ if (vend)
+ *v++ = 0;
+ else
+ v++;
+ }
+ e *= (NV)0.5;
+
+ /* Then extract the remaining hexdigits. */
+ while (d > (NV)0.0) {
+ if (d >= e) {
+ ha |= hd;
+ d -= e;
+ }
+ if (hd == 1) {
+ /* Output or count in groups of four bits,
+ * that is, when the hexdigit is down to one. */
+ if (vend)
+ *v++ = ha;
+ else
+ v++;
+ /* Reset the hexvalue. */
+ ha = 0x0;
+ hd = 0x8;
+ }
+ else
+ hd >>= 1;
+ e *= (NV)0.5;
+ }
+
+ /* Flush possible pending hexvalue. */
+ if (ha) {
+ if (vend)
+ *v++ = ha;
+ else
+ v++;
+ }
+ }
+# else
+ Perl_croak(aTHX_
+ "Hexadecimal float: unsupported long double format");
+# endif
+#else
+ /* Using normal doubles, not long doubles.
+ *
+ * We generate 4-bit xdigits (nybble/nibble) instead of 8-bit
+ * bytes, since we might need to handle printf precision, and
+ * also need to insert the radix. */
+ HEXTRACT_IMPLICIT_BIT(nv);
+# ifdef HEXTRACT_LITTLE_ENDIAN
+ HEXTRACT_LO_NYBBLE(6);
+ for (ix = 5; ix >= 0; ix--) {
+ HEXTRACT_BYTE(ix);
+ }
+# else
+ HEXTRACT_LO_NYBBLE(1);
+ for (ix = 2; ix < HEXTRACTSIZE; ix++) {
+ HEXTRACT_BYTE(ix);
+ }
+# endif
+#endif
+ /* Croak for various reasons: if the output pointer escaped the
+ * output buffer, if the extraction index escaped the extraction
+ * buffer, or if the ending output pointer didn't match the
+ * previously computed value. */
+ if (v <= vhex || v - vhex >= VHEX_SIZE ||
+ /* For double-double the ixmin and ixmax stay at zero,
+ * which is convenient since the HEXTRACTSIZE is tricky
+ * for double-double. */
+ ixmin < 0 || ixmax >= HEXTRACTSIZE ||
+ (vend && v != vend))
+ Perl_croak(aTHX_ "Hexadecimal float: internal error");
+ return v;
+}
+
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,
const U32 flags)
{
- dVAR;
char *p;
char *q;
const char *patend;
* NV_DIG: mantissa takes than many decimal digits.
* Plus 32: Playing safe. */
char ebuf[IV_DIG * 4 + NV_DIG + 32];
- /* large enough for "%#.#f" --chip */
- /* what about long double NVs? --jhi */
+ 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;
(void)SvPV_force_nomg(sv, origlen);
/* special-case "", "%s", and "%-p" (SVf - see below) */
- if (patlen == 0)
+ if (patlen == 0) {
+ if (svmax && ckWARN(WARN_REDUNDANT))
+ Perl_warner(aTHX_ packWARN(WARN_REDUNDANT), "Redundant argument in %s",
+ PL_op ? OP_DESC(PL_op) : "sv_vcatpvfn()");
return;
+ }
if (patlen == 2 && pat[0] == '%' && pat[1] == 's') {
+ if (svmax > 1 && ckWARN(WARN_REDUNDANT))
+ Perl_warner(aTHX_ packWARN(WARN_REDUNDANT), "Redundant argument in %s",
+ PL_op ? OP_DESC(PL_op) : "sv_vcatpvfn()");
+
if (args) {
const char * const s = va_arg(*args, char*);
sv_catpv_nomg(sv, s ? s : nullstr);
}
if (args && patlen == 3 && pat[0] == '%' &&
pat[1] == '-' && pat[2] == 'p') {
+ if (svmax > 1 && ckWARN(WARN_REDUNDANT))
+ Perl_warner(aTHX_ packWARN(WARN_REDUNDANT), "Redundant argument in %s",
+ PL_op ? OP_DESC(PL_op) : "sv_vcatpvfn()");
argsv = MUTABLE_SV(va_arg(*args, void*));
sv_catsv_nomg(sv, argsv);
return;
pp = pat + 2;
while (*pp >= '0' && *pp <= '9')
digits = 10 * digits + (*pp++ - '0');
+
+ /* XXX: Why do this `svix < svmax` test? Couldn't we just
+ format the first argument and WARN_REDUNDANT if svmax > 1?
+ Munged by Nicholas Clark in v5.13.0-209-g95ea86d */
if (pp - pat == (int)patlen - 1 && svix < svmax) {
const NV nv = SvNV(*svargs);
if (*pp == 'g') {
unsigned base = 0;
IV iv = 0;
UV uv = 0;
- /* we need a long double target in case HAS_LONG_DOUBLE but
- not USE_LONG_DOUBLE
+ /* We need a long double target in case HAS_LONG_DOUBLE,
+ * even without USE_LONG_DOUBLE, so that we can printf with
+ * long double formats, even without NV being long double.
+ * But we call the target 'fv' instead of 'nv', since most of
+ * the time it is not (most compilers these days recognize
+ * "long double", even if only as a synonym for "double").
*/
-#if defined(HAS_LONG_DOUBLE) && LONG_DOUBLESIZE > DOUBLESIZE
- long double nv;
+#if defined(HAS_LONG_DOUBLE) && LONG_DOUBLESIZE > DOUBLESIZE && defined(PERL_PRIgldbl)
+ long double fv;
+# define FV_ISFINITE(x) Perl_isfinitel(x)
+# define FV_GF PERL_PRIgldbl
#else
- NV nv;
+ NV fv;
+# define FV_ISFINITE(x) Perl_isfinite((NV)(x))
+# define FV_GF NVgf
#endif
STRLEN have;
STRLEN need;
I32 epix = 0; /* explicit precision index */
I32 evix = 0; /* explicit vector index */
bool asterisk = FALSE;
+ bool infnan = FALSE;
/* echo everything up to the next format specification */
for (q = p; q < patend && *q != '%'; ++q) ;
if (*q == '$') {
++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;
} else {
goto gotwidth;
}
case 'V':
case 'z':
case 't':
-#ifdef HAS_C99
+#ifdef I_STDINT
case 'j':
#endif
intsize = *q++;
}
}
+ if (argsv && SvNOK(argsv)) {
+ /* XXX va_arg(*args) case? */
+ infnan = Perl_isinfnan(SvNV(argsv));
+ }
+
switch (c = *q++) {
/* STRINGS */
case 'c':
if (vectorize)
goto unknown;
- uv = (args) ? va_arg(*args, int) : SvIV(argsv);
+ uv = (args) ? va_arg(*args, int) :
+ infnan ? UNICODE_REPLACEMENT : SvIV(argsv);
if ((uv > 255 ||
(!UVCHR_IS_INVARIANT(uv) && SvUTF8(sv)))
&& !IN_BYTES) {
/* INTEGERS */
case 'p':
+ if (infnan) {
+ c = 'g';
+ goto floating_point;
+ }
if (alt || vectorize)
goto unknown;
uv = PTR2UV(args ? va_arg(*args, void*) : argsv);
/* FALLTHROUGH */
case 'd':
case 'i':
+ if (infnan) {
+ c = 'g';
+ goto floating_point;
+ }
if (vectorize) {
STRLEN ulen;
if (!veclen)
case 'l': iv = va_arg(*args, long); break;
case 'V': iv = va_arg(*args, IV); break;
case 'z': iv = va_arg(*args, SSize_t); break;
+#ifdef HAS_PTRDIFF_T
case 't': iv = va_arg(*args, ptrdiff_t); break;
+#endif
default: iv = va_arg(*args, int); break;
-#ifdef HAS_C99
+#ifdef I_STDINT
case 'j': iv = va_arg(*args, intmax_t); break;
#endif
case 'q':
base = 16;
uns_integer:
+ if (infnan) {
+ c = 'g';
+ goto floating_point;
+ }
if (vectorize) {
STRLEN ulen;
vector:
case 'l': uv = va_arg(*args, unsigned long); break;
case 'V': uv = va_arg(*args, UV); break;
case 'z': uv = va_arg(*args, Size_t); break;
+#ifdef HAS_PTRDIFF_T
case 't': uv = va_arg(*args, ptrdiff_t); break; /* will sign extend, but there is no uptrdiff_t, so oh well */
-#ifdef HAS_C99
+#endif
+#ifdef I_STDINT
case 'j': uv = va_arg(*args, uintmax_t); break;
#endif
default: uv = va_arg(*args, unsigned); break;
{
char *ptr = ebuf + sizeof ebuf;
bool tempalt = uv ? alt : FALSE; /* Vectors can't change alt */
+ unsigned dig;
zeros = 0;
switch (base) {
- unsigned dig;
case 16:
p = (char *)((c == 'X') ? PL_hexdigit + 16 : PL_hexdigit);
do {
/* FLOATING POINT */
+ floating_point:
+
case 'F':
c = 'f'; /* maybe %F isn't supported here */
/* FALLTHROUGH */
case 'e': case 'E':
case 'f':
case 'g': case 'G':
+ case 'a': case 'A':
if (vectorize)
goto unknown;
goto unknown;
}
- /* now we need (long double) if intsize == 'q', else (double) */
- nv = (args) ?
+ /* Now we need (long double) if intsize == 'q', else (double). */
+ if (args) {
+ /* Note: do not pull NVs off the va_list with va_arg()
+ * (pull doubles instead) because if you have a build
+ * with long doubles, you would always be pulling long
+ * doubles, which would badly break anyone using only
+ * doubles (i.e. the majority of builds). In other
+ * words, you cannot mix doubles and long doubles.
+ * The only case where you can pull off long doubles
+ * is when the format specifier explicitly asks so with
+ * e.g. "%Lg". */
#if LONG_DOUBLESIZE > DOUBLESIZE
- intsize == 'q' ?
- va_arg(*args, long double) :
- va_arg(*args, double)
+ fv = intsize == 'q' ?
+ va_arg(*args, long double) : va_arg(*args, double);
#else
- va_arg(*args, double)
+ fv = va_arg(*args, double);
#endif
- : SvNV(argsv);
+ }
+ else
+ fv = SvNV(argsv);
need = 0;
- /* nv * 0 will be NaN for NaN, +Inf and -Inf, and 0 for anything
- else. frexp() has some unspecified behaviour for those three */
- if (c != 'e' && c != 'E' && (nv * 0) == 0) {
- i = PERL_INT_MIN;
- /* FIXME: if HAS_LONG_DOUBLE but not USE_LONG_DOUBLE this
- will cast our (long double) to (double) */
- (void)Perl_frexp(nv, &i);
- if (i == PERL_INT_MIN)
- Perl_die(aTHX_ "panic: frexp");
- if (i > 0)
- need = BIT_DIGITS(i);
+ /* frexp() (or frexpl) has some unspecified behaviour for
+ * nan/inf/-inf, so let's avoid calling that on non-finites. */
+ if (isALPHA_FOLD_NE(c, 'e') && FV_ISFINITE(fv)) {
+ i = PERL_INT_MIN;
+ (void)Perl_frexp((NV)fv, &i);
+ if (i == PERL_INT_MIN)
+ Perl_die(aTHX_ "panic: frexp: %"FV_GF, fv);
+ /* Do not set hexfp earlier since we want to printf
+ * Inf/NaN for Inf/NaN, not their hexfp. */
+ hexfp = isALPHA_FOLD_EQ(c, 'a');
+ if (UNLIKELY(hexfp)) {
+ /* This seriously overshoots in most cases, but
+ * better the undershooting. Firstly, all bytes
+ * of the NV are not mantissa, some of them are
+ * exponent. Secondly, for the reasonably common
+ * long doubles case, the "80-bit extended", two
+ * or six bytes of the NV are unused. */
+ need +=
+ (fv < 0) ? 1 : 0 + /* possible unary minus */
+ 2 + /* "0x" */
+ 1 + /* the very unlikely carry */
+ 1 + /* "1" */
+ 1 + /* "." */
+ 2 * NVSIZE + /* 2 hexdigits for each byte */
+ 2 + /* "p+" */
+ 6 + /* exponent: sign, plus up to 16383 (quad fp) */
+ 1; /* \0 */
+#ifdef LONGDOUBLE_DOUBLEDOUBLE
+ /* However, for the "double double", we need more.
+ * Since each double has their own exponent, the
+ * doubles may float (haha) rather far from each
+ * other, and the number of required bits is much
+ * larger, up to total of 1028 bits. (NOTE: this
+ * is not actually implemented properly yet,
+ * we are using just the first double, see
+ * S_hextract() for details. But let's prepare
+ * for the future.) */
+
+ /* 2 hexdigits for each byte. */
+ need += (DOUBLEDOUBLE_MAXBITS/8 + 1) * 2;
+ /* the size for the exponent already added */
+#endif
+#ifdef USE_LOCALE_NUMERIC
+ STORE_LC_NUMERIC_SET_TO_NEEDED();
+ if (PL_numeric_radix_sv && IN_LC(LC_NUMERIC))
+ need += SvLEN(PL_numeric_radix_sv);
+ RESTORE_LC_NUMERIC();
+#endif
+ }
+ else if (i > 0) {
+ need = BIT_DIGITS(i);
+ } /* if i < 0, the number of digits is hard to predict. */
}
need += has_precis ? precis : 6; /* known default */
# endif
if ((intsize == 'q') && (c == 'f') &&
- ((nv < MY_DBL_MAX_BUG) && (nv > -MY_DBL_MAX_BUG)) &&
+ ((fv < MY_DBL_MAX_BUG) && (fv > -MY_DBL_MAX_BUG)) &&
(need < DBL_DIG)) {
/* it's going to be short enough that
* long double precision is not needed */
- if ((nv <= 0L) && (nv >= -0L))
+ if ((fv <= 0L) && (fv >= -0L))
fix_ldbl_sprintf_bug = TRUE; /* 0 is 0 - easiest */
else {
/* would use Perl_fp_class as a double-check but not
* functional on IRIX - see perl.h comments */
- if ((nv >= MY_DBL_MIN) || (nv <= -MY_DBL_MIN)) {
+ if ((fv >= MY_DBL_MIN) || (fv <= -MY_DBL_MIN)) {
/* It's within the range that a double can represent */
#if defined(DBL_MAX) && !defined(DBL_MIN)
- if ((nv >= ((long double)1/DBL_MAX)) ||
- (nv <= (-(long double)1/DBL_MAX)))
+ if ((fv >= ((long double)1/DBL_MAX)) ||
+ (fv <= (-(long double)1/DBL_MAX)))
#endif
fix_ldbl_sprintf_bug = TRUE;
}
double temp;
intsize = 0;
- temp = (double)nv;
- nv = (NV)temp;
+ temp = (double)fv;
+ fv = (NV)temp;
}
}
&& has_precis && intsize != 'q' ) { /* Shortcuts */
/* See earlier comment about buggy Gconvert when digits,
aka precis is 0 */
- if ( c == 'g' && precis) {
+ if ( c == 'g' && precis ) {
STORE_LC_NUMERIC_SET_TO_NEEDED();
- PERL_UNUSED_RESULT(Gconvert((NV)nv, (int)precis, 0, PL_efloatbuf));
+ PERL_UNUSED_RESULT(Gconvert((NV)fv, (int)precis, 0, PL_efloatbuf));
/* May return an empty string for digits==0 */
if (*PL_efloatbuf) {
elen = strlen(PL_efloatbuf);
goto float_converted;
}
- } else if ( c == 'f' && !precis) {
- if ((eptr = F0convert(nv, ebuf + sizeof ebuf, &elen)))
+ } else if ( c == 'f' && !precis ) {
+ if ((eptr = F0convert(fv, ebuf + sizeof ebuf, &elen)))
break;
}
}
- {
- char *ptr = ebuf + sizeof ebuf;
- *--ptr = '\0';
- *--ptr = c;
- /* FIXME: what to do if HAS_LONG_DOUBLE but not PERL_PRIfldbl? */
+
+ if (UNLIKELY(hexfp)) {
+ /* Hexadecimal floating point. */
+ char* p = PL_efloatbuf;
+ U8 vhex[VHEX_SIZE];
+ U8* v = vhex; /* working pointer to vhex */
+ U8* vend; /* pointer to one beyond last digit of vhex */
+ U8* vfnz = NULL; /* first non-zero */
+ const bool lower = (c == 'a');
+ /* At output the values of vhex (up to vend) will
+ * be mapped through the xdig to get the actual
+ * human-readable xdigits. */
+ const char* xdig = PL_hexdigit;
+ int zerotail = 0; /* how many extra zeros to append */
+ int exponent = 0; /* exponent of the floating point input */
+
+ /* XXX: denormals, NaN, Inf.
+ *
+ * For example with denormals, (assuming the vanilla
+ * 64-bit double): the exponent is zero. 1xp-1074 is
+ * the smallest denormal and the smallest double, it
+ * 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);
+
+#if NVSIZE > DOUBLESIZE
+# ifdef LONGDOUBLE_X86_80_BIT
+ exponent -= 4;
+# else
+ exponent--;
+# endif
+#endif
+
+ if (fv < 0)
+ *p++ = '-';
+ else if (plus)
+ *p++ = plus;
+ *p++ = '0';
+ if (lower) {
+ *p++ = 'x';
+ }
+ else {
+ *p++ = 'X';
+ xdig += 16; /* Use uppercase hex. */
+ }
+
+ /* Find the first non-zero xdigit. */
+ for (v = vhex; v < vend; v++) {
+ if (*v) {
+ vfnz = v;
+ break;
+ }
+ }
+
+ if (vfnz) {
+ U8* vlnz = NULL; /* The last non-zero. */
+
+ /* Find the last non-zero xdigit. */
+ for (v = vend - 1; v >= vhex; v--) {
+ if (*v) {
+ vlnz = v;
+ break;
+ }
+ }
+
+#if NVSIZE == DOUBLESIZE
+ if (fv != 0.0)
+ exponent--;
+#endif
+
+ if (precis > 0) {
+ v = vhex + precis + 1;
+ if (v < vend) {
+ /* Round away from zero: if the tail
+ * beyond the precis xdigits is equal to
+ * or greater than 0x8000... */
+ bool round = *v > 0x8;
+ if (!round && *v == 0x8) {
+ for (v++; v < vend; v++) {
+ if (*v) {
+ round = TRUE;
+ break;
+ }
+ }
+ }
+ if (round) {
+ for (v = vhex + precis; v >= vhex; v--) {
+ if (*v < 0xF) {
+ (*v)++;
+ break;
+ }
+ *v = 0;
+ if (v == vhex) {
+ /* If the carry goes all the way to
+ * the front, we need to output
+ * a single '1'. This goes against
+ * the "xdigit and then radix"
+ * but since this is "cannot happen"
+ * category, that is probably good. */
+ *p++ = xdig[1];
+ }
+ }
+ }
+ /* The new effective "last non zero". */
+ vlnz = vhex + precis;
+ }
+ else {
+ zerotail = precis - (vlnz - vhex);
+ }
+ }
+
+ v = vhex;
+ *p++ = xdig[*v++];
+
+ /* The radix is always output after the first
+ * non-zero xdigit, or if alt. */
+ if (vfnz < vlnz || alt) {
+#ifndef USE_LOCALE_NUMERIC
+ *p++ = '.';
+#else
+ STORE_LC_NUMERIC_SET_TO_NEEDED();
+ if (PL_numeric_radix_sv && IN_LC(LC_NUMERIC)) {
+ STRLEN n;
+ const char* r = SvPV(PL_numeric_radix_sv, n);
+ Copy(r, p, n, char);
+ p += n;
+ }
+ else {
+ *p++ = '.';
+ }
+ RESTORE_LC_NUMERIC();
+#endif
+ }
+
+ while (v <= vlnz)
+ *p++ = xdig[*v++];
+
+ while (zerotail--)
+ *p++ = '0';
+ }
+ else {
+ *p++ = '0';
+ exponent = 0;
+ }
+
+ elen = p - PL_efloatbuf;
+ elen += my_snprintf(p, PL_efloatsize - elen,
+ "%c%+d", lower ? 'p' : 'P',
+ exponent);
+
+ if (elen < width) {
+ if (left) {
+ /* Pad the back with spaces. */
+ memset(PL_efloatbuf + elen, ' ', width - elen);
+ }
+ else if (fill == '0') {
+ /* Insert the zeros between the "0x" and
+ * the digits, otherwise we end up with
+ * "0000xHHH..." */
+ STRLEN nzero = width - elen;
+ char* zerox = PL_efloatbuf + 2;
+ Move(zerox, zerox + nzero, elen - 2, char);
+ memset(zerox, fill, nzero);
+ }
+ 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;
+ }
+ }
+ else
+ elen = S_infnan_2pv(fv, PL_efloatbuf, PL_efloatsize);
+ if (elen == 0) {
+ char *ptr = ebuf + sizeof ebuf;
+ *--ptr = '\0';
+ *--ptr = c;
+ /* FIXME: what to do if HAS_LONG_DOUBLE but not PERL_PRIfldbl? */
#if defined(HAS_LONG_DOUBLE) && defined(PERL_PRIfldbl)
+ /* Note that this is HAS_LONG_DOUBLE and PERL_PRIfldbl,
+ * not USE_LONG_DOUBLE and NVff. In other words,
+ * this needs to work without USE_LONG_DOUBLE. */
if (intsize == 'q') {
/* Copy the one or more characters in a long double
* format before the 'base' ([efgEFG]) character to
* the format string. */
- static char const prifldbl[] = PERL_PRIfldbl;
- char const *p = prifldbl + sizeof(prifldbl) - 3;
- while (p >= prifldbl) { *--ptr = *p--; }
+ static char const ldblf[] = PERL_PRIfldbl;
+ char const *p = ldblf + sizeof(ldblf) - 3;
+ while (p >= ldblf) { *--ptr = *p--; }
}
#endif
if (has_precis) {
* that is safe to use, even though it's not literal */
GCC_DIAG_IGNORE(-Wformat-nonliteral);
#if defined(HAS_LONG_DOUBLE)
- elen = ((intsize == 'q')
- ? my_snprintf(PL_efloatbuf, PL_efloatsize, ptr, nv)
- : my_snprintf(PL_efloatbuf, PL_efloatsize, ptr, (double)nv));
+ elen = ((intsize == 'q')
+ ? my_snprintf(PL_efloatbuf, PL_efloatsize, ptr, fv)
+ : my_snprintf(PL_efloatbuf, PL_efloatsize, ptr, (double)fv));
#else
- elen = my_sprintf(PL_efloatbuf, ptr, nv);
+ elen = my_sprintf(PL_efloatbuf, ptr, fv);
#endif
GCC_DIAG_RESTORE;
}
+
float_converted:
eptr = PL_efloatbuf;
+ assert((IV)elen > 0); /* here zero elen is bad */
#ifdef USE_LOCALE_NUMERIC
/* If the decimal point character in the string is UTF-8, make the
case 'l': *(va_arg(*args, long*)) = i; break;
case 'V': *(va_arg(*args, IV*)) = i; break;
case 'z': *(va_arg(*args, SSize_t*)) = i; break;
+#ifdef HAS_PTRDIFF_T
case 't': *(va_arg(*args, ptrdiff_t*)) = i; break;
-#ifdef HAS_C99
+#endif
+#ifdef I_STDINT
case 'j': *(va_arg(*args, intmax_t*)) = i; break;
#endif
case 'q':
}
}
+ assert((IV)elen >= 0); /* here zero elen is fine */
have = esignlen + zeros + elen;
if (have < zeros)
croak_memory_wrap();
goto vector;
}
}
+
+ /* Now that we've consumed all our printf format arguments (svix)
+ * do we have things left on the stack that we didn't use?
+ */
+ if (!no_redundant_warning && svmax >= svix + 1 && ckWARN(WARN_REDUNDANT)) {
+ Perl_warner(aTHX_ packWARN(WARN_REDUNDANT), "Redundant argument in %s",
+ PL_op ? OP_DESC(PL_op) : "sv_vcatpvfn()");
+ }
+
SvTAINT(sv);
RESTORE_LC_NUMERIC(); /* Done outside loop, so don't have to save/restore
(proto->lex_casemods < 12 ? 12 : proto->lex_casemods));
parser->lex_defer = proto->lex_defer;
parser->lex_dojoin = proto->lex_dojoin;
- parser->lex_expect = proto->lex_expect;
parser->lex_formbrack = proto->lex_formbrack;
parser->lex_inpat = proto->lex_inpat;
parser->lex_inwhat = proto->lex_inwhat;
Copy(proto->tokenbuf, parser->tokenbuf, 256, char);
-#ifdef PERL_MAD
- parser->endwhite = proto->endwhite;
- parser->faketokens = proto->faketokens;
- parser->lasttoke = proto->lasttoke;
- parser->nextwhite = proto->nextwhite;
- parser->realtokenstart = proto->realtokenstart;
- parser->skipwhite = proto->skipwhite;
- parser->thisclose = proto->thisclose;
- parser->thismad = proto->thismad;
- parser->thisopen = proto->thisopen;
- parser->thisstuff = proto->thisstuff;
- parser->thistoken = proto->thistoken;
- parser->thiswhite = proto->thiswhite;
-
- Copy(proto->nexttoke, parser->nexttoke, 5, NEXTTOKE);
- parser->curforce = proto->curforce;
-#else
Copy(proto->nextval, parser->nextval, 5, YYSTYPE);
Copy(proto->nexttype, parser->nexttype, 5, I32);
parser->nexttoke = proto->nexttoke;
-#endif
/* XXX should clone saved_curcop here, but we aren't passed
* proto_perl; so do it in perl_clone_using instead */
for(;;) {
pos = PerlDir_tell(ret);
if ((dirent = PerlDir_read(ret))) {
- if (len == d_namlen(dirent)
- && memEQ(name, dirent->d_name, len)) {
+ if (len == (STRLEN)d_namlen(dirent)
+ && memEQ(name, dirent->d_name, len)) {
/* found it */
PerlDir_seek(ret, pos); /* step back */
break;
void
Perl_ptr_table_clear(pTHX_ PTR_TBL_t *const tbl)
{
+ PERL_UNUSED_CONTEXT;
if (tbl && tbl->tbl_items) {
struct ptr_tbl_arena *arena = tbl->tbl_arena;
{
struct ptr_tbl_arena *arena;
+ PERL_UNUSED_CONTEXT;
+
if (!tbl) {
return;
}
if (CvDYNFILE(dstr)) CvFILE(dstr) = SAVEPV(CvFILE(dstr));
if (CvNAMED(dstr))
SvANY((CV *)dstr)->xcv_gv_u.xcv_hek =
- share_hek_hek(CvNAME_HEK((CV *)sstr));
+ hek_dup(CvNAME_HEK((CV *)sstr), param);
/* don't dup if copying back - CvGV isn't refcounted, so the
* duped GV may never be freed. A bit of a hack! DAPM */
else
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++;
+ break;
default:
Perl_croak(aTHX_
"panic: ss_dup inconsistency (%"IVdf")", (IV) type);
PL_minus_F = proto_perl->Iminus_F;
PL_doswitches = proto_perl->Idoswitches;
PL_dowarn = proto_perl->Idowarn;
+ PL_sawalias = proto_perl->Isawalias;
#ifdef PERL_SAWAMPERSAND
PL_sawampersand = proto_perl->Isawampersand;
#endif
PL_Latin1 = sv_dup_inc(proto_perl->ILatin1, param);
PL_UpperLatin1 = sv_dup_inc(proto_perl->IUpperLatin1, param);
PL_AboveLatin1 = sv_dup_inc(proto_perl->IAboveLatin1, param);
+ PL_InBitmap = sv_dup_inc(proto_perl->IInBitmap, param);
PL_NonL1NonFinalFold = sv_dup_inc(proto_perl->INonL1NonFinalFold, param);
PL_HasMultiCharFold = sv_dup_inc(proto_perl->IHasMultiCharFold, param);
char *
Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding)
{
- dVAR;
-
PERL_ARGS_ASSERT_SV_RECODE_TO_UTF8;
if (SvPOK(sv) && !SvUTF8(sv) && !IN_BYTES && SvROK(encoding)) {
nsv = sv_newmortal();
SvSetSV_nosteal(nsv, sv);
}
- save_re_context();
PUSHMARK(sp);
EXTEND(SP, 3);
PUSHs(encoding);
Perl_sv_cat_decode(pTHX_ SV *dsv, SV *encoding,
SV *ssv, int *offset, char *tstr, int tlen)
{
- dVAR;
bool ret = FALSE;
PERL_ARGS_ASSERT_SV_CAT_DECODE;
dSP;
ENTER;
SAVETMPS;
- save_re_context();
PUSHMARK(sp);
EXTEND(SP, 6);
PUSHs(encoding);
STATIC I32
S_find_array_subscript(pTHX_ const AV *const av, const SV *const val)
{
- dVAR;
-
PERL_ARGS_ASSERT_FIND_ARRAY_SUBSCRIPT;
if (!av || SvMAGICAL(av) || !AvARRAY(av) ||
return varname(gv, '$', 0,
NULL, (I8)obase->op_private, FUV_SUBSCRIPT_ARRAY);
}
- break;
+ NOT_REACHED; /* NOTREACHED */
case OP_EXISTS:
o = cUNOPx(obase)->op_first;
? '@' : '%',
o->op_targ, NULL, 0, FUV_SUBSCRIPT_WITHIN);
}
- break;
+ NOT_REACHED; /* NOTREACHED */
}
case OP_AASSIGN:
if ( o->op_type == OP_PUSHMARK
|| (o->op_type == OP_NULL && o->op_targ == OP_PUSHMARK)
)
- o = o->op_sibling;
+ o = OP_SIBLING(o);
- if (!o->op_sibling) {
+ if (!OP_HAS_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 = o->op_sibling->op_sibling;
+ o = OP_SIBLING(OP_SIBLING(o));
goto do_op2;
* it replaced are still in the tree, so we work on them instead.
*/
o2 = NULL;
- for (kid=o; kid; kid = kid->op_sibling) {
+ for (kid=o; kid; kid = OP_SIBLING(kid)) {
const OPCODE type = kid->op_type;
if ( (type == OP_CONST && SvOK(cSVOPx_sv(kid)))
|| (type == OP_NULL && ! (kid->op_flags & OPf_KIDS))
sv = find_uninit_var(o, uninit_sv, 1);
if (sv)
return sv;
- o = o->op_sibling;
+ o = OP_SIBLING(o);
}
break;
}
void
Perl_report_uninit(pTHX_ const SV *uninit_sv)
{
- dVAR;
if (PL_op) {
SV* varname = NULL;
if (uninit_sv && PL_curpad) {
https://perl5.git.perl.org / perl5.git / blobdiff