}
-/*
-=for apidoc sv_vcatpvfn
-
-=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 (C<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).
-
-If called as C<sv_vcatpvfn> or flags has the C<SV_GMAGIC> bit set, calls get magic.
-
-Usually used via one of its frontends C<sv_vcatpvf> and C<sv_vcatpvf_mg>.
-
-=cut
-*/
-
#define VECTORIZE_ARGS vecsv = va_arg(*args, SV*);\
vecstr = (U8*)SvPV_const(vecsv,veclen);\
vec_utf8 = DO_UTF8(vecsv);
* string.
* The rest of the args have the same meaning as the local vars of the
* same name within Perl_sv_vcatpvfn_flags().
+ *
+ * It assumes the caller has already done STORE_LC_NUMERIC_SET_TO_NEEDED();
*/
static STRLEN
S_format_hexfp(pTHX_ char * const buf, const STRLEN bufsize, const char c,
const NV nv, const vcatpvfn_long_double_t fv,
bool has_precis, STRLEN precis, STRLEN width,
- bool alt, char plus, bool left, char fill)
+ bool alt, char plus, bool left, bool fill)
{
/* Hexadecimal floating point. */
char* p = buf;
bool subnormal = FALSE; /* IEEE 754 subnormal/denormal */
bool negative = FALSE;
STRLEN elen;
- DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
/* XXX: NaN, Inf -- though they are printed as "NaN" and "Inf".
*
#ifndef USE_LOCALE_NUMERIC
*p++ = '.';
#else
- STORE_LC_NUMERIC_SET_TO_NEEDED();
- if (PL_numeric_radix_sv && IN_LC(LC_NUMERIC)) {
+ if (PL_numeric_radix_sv) {
STRLEN n;
const char* r = SvPV(PL_numeric_radix_sv, n);
+ assert(IN_LC(LC_NUMERIC));
Copy(r, p, n, char);
p += n;
}
else {
*p++ = '.';
}
- RESTORE_LC_NUMERIC();
#endif
}
/* Pad the back with spaces. */
memset(buf + elen, ' ', gap);
}
- else if (fill == '0') {
+ else if (fill) {
/* Insert the zeros after the "0x" and the
* the potential sign, but before the digits,
* otherwise we end up with "0000xH.HHH...",
nmove--;
}
Move(zerox, zerox + nzero, nmove, char);
- memset(zerox, fill, nzero);
+ memset(zerox, fill ? '0' : ' ', nzero);
}
else {
/* Move it to the right. */
void
-/* This function assumes that pat has the same utf8-ness as sv.
- * It's the caller's responsibility to ensure that this is so.
- */
+/*
+=for apidoc sv_vcatpvfn
+
+=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 (C<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).
+
+If called as C<sv_vcatpvfn> or flags has the C<SV_GMAGIC> bit set, calls get magic.
+
+It assumes that pat has the same utf8-ness as sv. It's the caller's
+responsibility to ensure that this is so.
+
+Usually used via one of its frontends C<sv_vcatpvf> and C<sv_vcatpvf_mg>.
+
+=cut
+*/
+
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,
* Plus 32: Playing safe. */
char ebuf[IV_DIG * 4 + NV_DIG + 32];
bool no_redundant_warning = FALSE; /* did we use any explicit format parameter index? */
- bool hexfp = FALSE; /* hexadecimal floating point? */
-
+#ifdef USE_LOCALE_NUMERIC
DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
+ bool lc_numeric_set = FALSE; /* called STORE_LC_NUMERIC_SET_TO_NEEDED? */
+#endif
PERL_ARGS_ASSERT_SV_VCATPVFN_FLAGS;
PERL_UNUSED_ARG(maybe_tainted);
/* no matter what, this is a string now */
(void)SvPV_force_nomg(sv, origlen);
+ /* the code that scans for flags etc following a % relies on
+ * a '\0' being present to avoid falling off the end. Ideally that
+ * should be fixed */
+ assert(pat[patlen] == '\0');
+
/* special-case "", "%s", and "%-p" (SVf - see below) */
if (patlen == 0) {
if (svmax && ckWARN(WARN_REDUNDANT))
}
#if !defined(USE_LONG_DOUBLE) && !defined(USE_QUADMATH)
- /* special-case "%.0f" and "%.<number>g" */
- if ( !args && patlen <= 5 && pat[0] == '%' && pat[1] == '.'
- && (pat[patlen-1] == 'g' || pat[patlen-1] == 'f') ) {
- unsigned digits = 0;
- const char *pp;
-
- 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 + 1 == pat + patlen && svix < svmax) {
- const NV nv = SvNV(*svargs);
- if (LIKELY(!Perl_isinfnan(nv))) {
- if (*pp == 'g') {
- /* Add check for digits != 0 because it seems that some
- gconverts are buggy in this case, and we don't yet have
- a Configure test for this. */
- if (digits && digits < sizeof(ebuf) - NV_DIG - 10) {
- /* 0, point, slack */
- STORE_LC_NUMERIC_SET_TO_NEEDED();
- SNPRINTF_G(nv, ebuf, sizeof(ebuf), digits);
- sv_catpv_nomg(sv, ebuf);
- if (*ebuf) /* May return an empty string for digits==0 */
- return;
- }
- } else if (!digits) {
- STRLEN l;
+ /* special-case "%.0f" */
+ if ( !args
+ && patlen == 4
+ && pat[0] == '%' && pat[1] == '.' && pat[2] == '0' && pat[3] == 'f'
+ && svmax > 0)
+ {
+ const NV nv = SvNV(*svargs);
+ if (LIKELY(!Perl_isinfnan(nv))) {
+ STRLEN l;
+ char *p;
- if ((p = F0convert(nv, ebuf + sizeof ebuf, &l))) {
- sv_catpvn_nomg(sv, p, l);
- return;
- }
- }
+ if ((p = F0convert(nv, ebuf + sizeof ebuf, &l))) {
+ sv_catpvn_nomg(sv, p, l);
+ return;
}
}
}
#endif /* !USE_LONG_DOUBLE */
- if (!args && svix < svmax && DO_UTF8(*svargs))
- has_utf8 = TRUE;
-
patend = (char*)pat + patlen;
for (p = (char*)pat; p < patend; p = q) {
char intsize = 0; /* size qualifier in "%hi..." etc */
bool alt = FALSE; /* has "%#..." */
bool left = FALSE; /* has "%-..." */
- char fill = ' '; /* has "%0..." */
+ bool fill = FALSE; /* has "%0..." */
char plus = 0; /* has "%+..." */
STRLEN width = 0; /* value of "%NNN..." */
bool has_precis = FALSE; /* has "%.NNN..." */
[%bcdefginopsuxDFOUX] format (mandatory)
*/
- if (args) {
-/*
- As of perl5.9.3, printf format checking is on by default.
- Internally, perl uses %p formats to provide an escape to
- some extended formatting. This block deals with those
- extensions: if it does not match, (char*)q is reset and
- the normal format processing code is used.
-
- Currently defined extensions are:
- %p include pointer address (standard)
- %-p (SVf) include an SV (previously %_)
- %-<num>p include an SV with precision <num>
- %2p include a HEK
- %3p include a HEK with precision of 256
- %4p char* preceded by utf8 flag and length
- %<num>p (where num is 1 or > 4) reserved for future
- extensions
-
- Robin Barker 2005-07-14 (but modified since)
-
- %1p (VDf) removed. RMB 2007-10-19
-*/
- char* r = q;
- bool sv = FALSE;
- STRLEN n = 0;
- if (*q == '-')
- sv = *q++;
- else if (strnEQ(q, UTF8f, sizeof(UTF8f)-1)) { /* UTF8f */
- /* The argument has already gone through cBOOL, so the cast
- is safe. */
- is_utf8 = (bool)va_arg(*args, int);
- elen = va_arg(*args, UV);
- /* if utf8 length is larger than 0x7ffff..., then it might
- * have been a signed value that wrapped */
- if (elen > ((~(STRLEN)0) >> 1)) {
- assert(0); /* in DEBUGGING build we want to crash */
- elen= 0; /* otherwise we want to treat this as an empty string */
- }
- eptr = va_arg(*args, char *);
- q += sizeof(UTF8f)-1;
- goto string;
- }
- n = expect_number(&q);
- if (*q++ == 'p') {
- if (sv) { /* SVf */
- if (n) {
- precis = n;
- has_precis = TRUE;
- }
- argsv = MUTABLE_SV(va_arg(*args, void*));
- eptr = SvPV_const(argsv, elen);
- if (DO_UTF8(argsv))
- is_utf8 = TRUE;
- goto string;
- }
- else if (n==2 || n==3) { /* HEKf */
- HEK * const hek = va_arg(*args, HEK *);
- eptr = HEK_KEY(hek);
- elen = HEK_LEN(hek);
- if (HEK_UTF8(hek)) is_utf8 = TRUE;
- if (n==3) precis = 256, has_precis = TRUE;
- goto string;
- }
- else if (n) {
- Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
- "internal %%<num>p might conflict with future printf extensions");
- }
- }
- q = r;
- }
-
if ( (width = expect_number(&q)) ) {
if (*q == '$') {
if (args)
continue;
case '0':
- fill = *q++;
+ fill = TRUE;
+ q++;
continue;
case '#':
if (!asterisk)
{
- if( *q == '0' )
- fill = *q++;
+ if(*q == '0') {
+ fill = TRUE;
+ q++;
+ }
width = expect_number(&q);
}
c = *q++; /* c now holds the conversion type */
- if (argsv && strchr("BbcDdiOopuUXx", c)) {
+ if (argsv && strchr("BbcDdiOouUXx", c)) {
/* XXX va_arg(*args) case? need peek, use va_copy? */
SvGETMAGIC(argsv);
if (UNLIKELY(SvAMAGIC(argsv)))
case 'p':
if (alt || vectorize)
goto unknown;
+
+ /* %p extensions:
+ *
+ * "%...p" is normally treated like "%...x", except that the
+ * number to print is the SV's address (or a pointer address
+ * for C-ish sprintf).
+ *
+ * However, the C-ish sprintf variant allows a few special
+ * extensions. These are currently:
+ *
+ * %-p (SVf) Like %s, but gets the string from an SV*
+ * arg rather than a char* arg.
+ * (This was previously %_).
+ *
+ * %-<num>p Ditto but like %.<num>s (i.e. num is max width)
+ *
+ * %2p (HEKf) Like %s, but using the key string in a HEK
+ *
+ * %3p (HEKf256) Ditto but like %.256s
+ *
+ * %d%lu%4p (UTF8f) A utf8 string. Consumes 3 args:
+ * (cBOOL(utf8), len, string_buf).
+ * It's handled by the "case 'd'" branch
+ * rather than here.
+ *
+ * %<num>p where num is 1 or > 4: reserved for future
+ * extensions. Warns, but then is treated as a
+ * general %p (print hex address) format.
+ */
+
+ if ( args
+ && !intsize
+ && !fill
+ && !plus
+ && !has_precis
+ && !asterisk
+ && !used_explicit_ix
+ ) {
+ if (left) { /* %-p (SVf), %-NNNp */
+ if (width) {
+ precis = width;
+ has_precis = TRUE;
+ }
+ argsv = MUTABLE_SV(va_arg(*args, void*));
+ eptr = SvPV_const(argsv, elen);
+ if (DO_UTF8(argsv))
+ is_utf8 = TRUE;
+ width = 0;
+ goto string;
+ }
+ else if (width == 2 || width == 3) { /* HEKf, HEKf256 */
+ HEK * const hek = va_arg(*args, HEK *);
+ eptr = HEK_KEY(hek);
+ elen = HEK_LEN(hek);
+ if (HEK_UTF8(hek))
+ is_utf8 = TRUE;
+ if (width == 3) {
+ precis = 256;
+ has_precis = TRUE;
+ }
+ width = 0;
+ goto string;
+ }
+ else if (width) {
+ Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
+ "internal %%<num>p might conflict with future printf extensions");
+ }
+ }
+
+ /* treat as normal %...p */
+
uv = PTR2UV(args ? va_arg(*args, void*) : argsv);
base = 16;
goto integer;
#else
intsize = 'l';
#endif
- /* FALLTHROUGH */
+ goto do_i;
+
case 'd':
+ /* probably just a plain %d, but it might be the start of the
+ * special UTF8f format, which usually looks something like
+ * "%d%lu%4p" (the lu may vary by platform)
+ */
+ assert((UTF8f)[0] == 'd');
+ assert((UTF8f)[1] == '%');
+
+ if ( args /* UTF8f only valid for C-ish sprintf */
+ && q == fmtstart + 1 /* plain %d, not %....d */
+ && patend >= fmtstart + sizeof(UTF8f) - 1 /* long enough */
+ && *q == '%'
+ && strnEQ(q + 1, UTF8f + 2, sizeof(UTF8f) - 3))
+ {
+ /* The argument has already gone through cBOOL, so the cast
+ is safe. */
+ is_utf8 = (bool)va_arg(*args, int);
+ elen = va_arg(*args, UV);
+ /* if utf8 length is larger than 0x7ffff..., then it might
+ * have been a signed value that wrapped */
+ if (elen > ((~(STRLEN)0) >> 1)) {
+ assert(0); /* in DEBUGGING build we want to crash */
+ elen = 0; /* otherwise we want to treat this as an empty string */
+ }
+ eptr = va_arg(*args, char *);
+ q += sizeof(UTF8f) - 2;
+ goto string;
+ }
+
+ /* FALLTHROUGH */
case 'i':
+ do_i:
if (vectorize) {
STRLEN ulen;
if (!veclen)
&& !(base == 8 && alt)) /* "%#.0o" prints "0" */
elen = 0;
- /* a precision nullifies the 0 flag. */
- if (fill == '0')
- fill = ' ';
+ /* a precision nullifies the 0 flag. */
+ fill = FALSE;
}
}
break;
case 'a': case 'A':
{
- bool is_simple; /* no fancy qualifiers */
STRLEN radix_len; /* SvCUR(PL_numeric_radix_sv) */
STRLEN float_need; /* what PL_efloatsize needs to become */
+ bool hexfp; /* hexadecimal floating point? */
vcatpvfn_long_double_t fv;
NV nv;
}
/* special-case "%.0f" */
- is_simple = ( !(width || left || plus || alt)
- && fill != '0'
- && has_precis
- && intsize != 'q');
-
- if (is_simple && c == 'f' && !precis) {
- if ((eptr = F0convert(nv, ebuf + sizeof ebuf, &elen)))
- break;
- }
+ if ( c == 'f'
+ && !precis
+ && has_precis
+ && !(width || left || plus || alt)
+ && !fill
+ && intsize != 'q'
+ && ((eptr = F0convert(nv, ebuf + sizeof ebuf, &elen)))
+ )
+ goto float_concat_no_utf8;
/* Determine the buffer size needed for the various
* floating-point formats.
* below, or implicitly, via an snprintf() variant.
* Note also things like ps_AF.utf8 which has
* "\N{ARABIC DECIMAL SEPARATOR} as a radix point */
- STORE_LC_NUMERIC_SET_TO_NEEDED();
- if (PL_numeric_radix_sv && IN_LC(LC_NUMERIC)) {
+ if (!lc_numeric_set) {
+ /* only set once and reuse in-locale value on subsequent
+ * iterations.
+ * XXX what happens if we die in an eval?
+ */
+ STORE_LC_NUMERIC_SET_TO_NEEDED();
+ lc_numeric_set = TRUE;
+ }
+
+ if (PL_numeric_radix_sv) {
+ assert(IN_LC(LC_NUMERIC));
radix_len = SvCUR(PL_numeric_radix_sv);
/* note that this will convert the output to utf8 even if
* if the radix point didn't get output */
is_utf8 = SvUTF8(PL_numeric_radix_sv);
}
- RESTORE_LC_NUMERIC();
#endif
/* this can't wrap unless PL_numeric_radix_sv is a string
* consuming virtually all the 32-bit or 64-bit address space
*/
float_need += radix_len;
+ hexfp = FALSE;
+
if (isALPHA_FOLD_EQ(c, 'f')) {
/* Determine how many digits before the radix point
* might be emitted. frexp() (or frexpl) has some
float_need += digits;
}
}
+ /* special-case "%.<number>g" if it will fit in ebuf */
+ else if (c == 'g'
+ && precis /* See earlier comment about buggy Gconvert
+ when digits, aka precis, is 0 */
+ && has_precis
+ /* check, in manner not involving wrapping, that it will
+ * fit in ebuf */
+ && float_need < sizeof(ebuf)
+ && sizeof(ebuf) - float_need > precis
+ && !(width || left || plus || alt)
+ && !fill
+ && intsize != 'q'
+ ) {
+ SNPRINTF_G(fv, ebuf, sizeof(ebuf), precis);
+ elen = strlen(ebuf);
+ eptr = ebuf;
+ goto float_concat;
+ }
+
{
STRLEN pr = has_precis ? precis : 6; /* known default */
PL_efloatbuf[0] = '\0';
}
- /* special-case "%.<number>g" */
- if (is_simple) {
- /* See earlier comment about buggy Gconvert when digits,
- aka precis is 0 */
- if ( c == 'g' && precis ) {
- STORE_LC_NUMERIC_SET_TO_NEEDED();
- SNPRINTF_G(fv, PL_efloatbuf, PL_efloatsize, precis);
- /* May return an empty string for digits==0 */
- if (*PL_efloatbuf) {
- elen = strlen(PL_efloatbuf);
- goto float_converted;
- }
- }
- }
-
if (UNLIKELY(hexfp)) {
elen = S_format_hexfp(aTHX_ PL_efloatbuf, PL_efloatsize, c,
nv, fv, has_precis, precis, width,
base = width;
do { *--ptr = '0' + (base % 10); } while (base /= 10);
}
- if (fill == '0')
- *--ptr = fill;
+ if (fill)
+ *--ptr = '0';
if (left)
*--ptr = '-';
if (plus)
* where printf() taints but print($float) doesn't.
* --jhi */
- STORE_LC_NUMERIC_SET_TO_NEEDED();
-
/* hopefully the above makes ptr a very constrained format
* that is safe to use, even though it's not literal */
GCC_DIAG_IGNORE(-Wformat-nonliteral);
GCC_DIAG_RESTORE;
}
- float_converted:
eptr = PL_efloatbuf;
- assert((IV)elen > 0); /* here zero elen is bad */
+ float_concat:
- break;
+ /* Since floating-point formats do their own formatting and
+ * padding, we skip the main block of code at the end of this
+ * loop which handles appending eptr to sv, and do our own
+ * stripped-down version */
+
+ /* floating-point formats only get is_utf8 if the radix point
+ * is utf8. All other characters in the string are < 128
+ * and so can be safely appended to both a non-utf8 and utf8
+ * string as-is.
+ */
+ if (is_utf8 && !has_utf8) {
+ sv_utf8_upgrade(sv);
+ has_utf8 = TRUE;
+ }
+
+ float_concat_no_utf8:
+
+ assert(!zeros);
+ assert(!esignlen);
+ assert(!vectorize);
+ assert(elen);
+ assert(elen >= width);
+
+
+ {
+ /* unrolled Perl_sv_catpvn */
+ STRLEN need = elen + SvCUR(sv) + 1;
+ char *end;
+ /* can't wrap as both elen and SvCUR() are allocated in
+ * memory and together can't consume all the address space
+ */
+ assert(need > elen);
+ SvGROW(sv, need);
+ end = SvEND(sv);
+ Copy(eptr, end, elen, char);
+ end += elen;
+ *end = '\0';
+ SvCUR_set(sv, need - 1);
+ }
+
+ goto donevalidconversion;
}
/* SPECIAL */
int i;
if (vectorize)
goto unknown;
+ /* XXX ideally we should warn if any flags etc have been
+ * set, e.g. "%-4.5n" */
+ /* XXX if sv was originally non-utf8 with a char in the
+ * range 0x80-0xff, then if it got upgraded, we should
+ * calculate char len rather than byte len here */
i = SvCUR(sv) - origlen;
if (args) {
switch (intsize) {
#endif
}
}
- else
+ else {
+ if (arg_missing)
+ Perl_croak_nocontext(
+ "Missing argument for %%n in %s",
+ PL_op ? OP_DESC(PL_op) : "sv_vcatpvfn()");
sv_setuv_mg(argsv, has_utf8 ? (UV)sv_len_utf8(sv) : (UV)i);
+ }
goto donevalidconversion;
}
SvGROW(sv, need);
p = SvEND(sv);
- if (esignlen && fill == '0') {
+ if (esignlen && fill) {
int i;
for (i = 0; i < (int)esignlen; i++)
*p++ = esignbuf[i];
}
if (gap && !left) {
- memset(p, fill, gap);
+ memset(p, (fill ? '0' : ' '), gap);
p += gap;
}
- if (esignlen && fill != '0') {
+ if (esignlen && !fill) {
int i;
for (i = 0; i < (int)esignlen; i++)
*p++ = esignbuf[i];
https://perl5.git.perl.org / perl5.git / blobdiff