In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/c1521c2084bc5cbe818891777547f7d3e204146c?hp=0c5a1073d3e8debefdaa5b534337acb1b0c060ef>
- Log ----------------------------------------------------------------- commit c1521c2084bc5cbe818891777547f7d3e204146c Author: Jarkko Hietaniemi <[email protected]> Date: Wed Jan 28 06:43:51 2015 -0500 infnan: comment tweaks M numeric.c commit b8974fcb73beb08c16950ee035dee9611a4a4d57 Author: Jarkko Hietaniemi <[email protected]> Date: Tue Jan 27 09:40:03 2015 -0500 infnan: restore 'Infinity' since lln.t expects it. M numeric.c M t/op/infnan.t commit ea2485eb6738364ac1f04cce3e790052f4751864 Author: Jarkko Hietaniemi <[email protected]> Date: Tue Jan 27 09:11:39 2015 -0500 infnan: if trailing stuff, fail in looks_like_number() M sv.c commit 62bdc035a5e7c21aaad9d15f723b95821982af30 Author: Jarkko Hietaniemi <[email protected]> Date: Tue Jan 27 08:32:39 2015 -0500 infnan: comment tweaks M numeric.c commit a3c662ac54618d9fcd721623abfb9b4b35b07967 Author: Jarkko Hietaniemi <[email protected]> Date: Mon Jan 26 22:20:04 2015 -0500 infnan: grok flag expectation fixes M ext/XS-APItest/t/grok.t commit 5563f4573c9a18a83c4aa768343985e14f06e1b4 Author: Jarkko Hietaniemi <[email protected]> Date: Mon Jan 26 22:13:56 2015 -0500 infnan: grok_infnan now needs context M embed.fnc M embed.h M numeric.c M proto.h commit bf8c8f7f2000866d6e5e9e29cb9acdef10025521 Author: Jarkko Hietaniemi <[email protected]> Date: Mon Jan 26 20:52:41 2015 -0500 infnan: actually use grok_hex() for nan payload And grok_bin() while we are at it. The payload is still unused, but we now at least parse the syntax. M numeric.c commit 13393a5ecffaadc319ca5f8a99d3ca491686fef7 Author: Jarkko Hietaniemi <[email protected]> Date: Mon Jan 26 19:36:25 2015 -0500 infnan: move grok_infnan before the grok_number M numeric.c commit 98a44ad297c913ce24475f2dd43b65ddff81aa6c Author: Jarkko Hietaniemi <[email protected]> Date: Sun Jan 25 21:08:13 2015 -0500 infnan: mention the unusual semantics of "numeric". M pod/perldiag.pod commit b489e20f5bc292b1e257500b577944b52ec6c7d5 Author: Jarkko Hietaniemi <[email protected]> Date: Sun Jan 25 21:01:07 2015 -0500 infnan: allow (silently) trailing whitespace. (Leading whitespace is handled in grok_number_flags.) M numeric.c M t/op/infnan.t commit 75a57a380101eae68ead055d5951db492491701d Author: Jarkko Hietaniemi <[email protected]> Date: Sun Jan 25 18:36:18 2015 -0500 infnan: numify warning testing. M sv.c M t/op/infnan.t commit 3396ed3031889b7a6890cbcb14149feb7f1ed41f Author: Jarkko Hietaniemi <[email protected]> Date: Sun Jan 25 12:27:44 2015 -0500 infnan: Simplify inf parsing. Accept anything beginning with /^inf/i, but warn if there's trailing stuff. M numeric.c M t/op/infnan.t commit 1e9aa12fc5bed36eadfa398b85d0a5168b0bc635 Author: Jarkko Hietaniemi <[email protected]> Date: Sun Jan 25 12:19:03 2015 -0500 infnan: More elaborate nan parsing for C99-y nan(...) M numeric.c M t/op/infnan.t commit fae4db12fe48a8d53b803281652815abd8bc98c0 Author: Jarkko Hietaniemi <[email protected]> Date: Sun Jan 25 09:42:19 2015 -0500 infnan: Allow 1.#INF00 and 1.#IND00 Windowese for inf and nan. The exact number of trailing zeros seems to vary, maybe controlled by printf precision? Or RTL dependent? M numeric.c M t/op/infnan.t ----------------------------------------------------------------------- Summary of changes: embed.fnc | 2 +- embed.h | 2 +- ext/XS-APItest/t/grok.t | 6 +- numeric.c | 264 +++++++++++++++++++++++++++++++++++++----------- pod/perldiag.pod | 5 + proto.h | 6 +- sv.c | 6 +- t/op/infnan.t | 107 +++++++++++++++----- 8 files changed, 302 insertions(+), 96 deletions(-) diff --git a/embed.fnc b/embed.fnc index 61049a9..41b0087 100644 --- a/embed.fnc +++ b/embed.fnc @@ -813,7 +813,7 @@ EMsPR |char*|form_short_octal_warning|NN const char * const s \ |const STRLEN len #endif Apd |UV |grok_hex |NN const char* start|NN STRLEN* len_p|NN I32* flags|NULLOK NV *result -Apdn |int |grok_infnan |NN const char** sp|NN const char *send +Apd |int |grok_infnan |NN const char** sp|NN const char *send Apd |int |grok_number |NN const char *pv|STRLEN len|NULLOK UV *valuep Apd |int |grok_number_flags|NN const char *pv|STRLEN len|NULLOK UV *valuep|U32 flags ApdR |bool |grok_numeric_radix|NN const char **sp|NN const char *send diff --git a/embed.h b/embed.h index 76a3029..15fa37e 100644 --- a/embed.h +++ b/embed.h @@ -182,7 +182,7 @@ #define grok_atou Perl_grok_atou #define grok_bin(a,b,c,d) Perl_grok_bin(aTHX_ a,b,c,d) #define grok_hex(a,b,c,d) Perl_grok_hex(aTHX_ a,b,c,d) -#define grok_infnan Perl_grok_infnan +#define grok_infnan(a,b) Perl_grok_infnan(aTHX_ a,b) #define grok_number(a,b,c) Perl_grok_number(aTHX_ a,b,c) #define grok_number_flags(a,b,c,d) Perl_grok_number_flags(aTHX_ a,b,c,d) #define grok_numeric_radix(a,b) Perl_grok_numeric_radix(aTHX_ a,b) diff --git a/ext/XS-APItest/t/grok.t b/ext/XS-APItest/t/grok.t index e6093f2..f66717b 100644 --- a/ext/XS-APItest/t/grok.t +++ b/ext/XS-APItest/t/grok.t @@ -93,14 +93,14 @@ my @groks = [ "Inf", 0, undef, IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT ], [ "In", 0, undef, 0 ], - [ "Infin",0, undef, 0 ], + [ "Infin",0, undef, IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT | IS_NUMBER_TRAILING ], # this doesn't work and hasn't been needed yet #[ "Infin",PERL_SCAN_TRAILING, undef, # IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT | IS_NUMBER_TRAILING ], [ "nan", 0, undef, IS_NUMBER_NAN | IS_NUMBER_NOT_INT ], # even without PERL_SCAN_TRAILING nan can have weird stuff trailing - [ "nanx", 0, undef, IS_NUMBER_NAN | IS_NUMBER_NOT_INT ], - [ "nanx", PERL_SCAN_TRAILING, undef, IS_NUMBER_NAN | IS_NUMBER_NOT_INT ], + [ "nanx", 0, undef, IS_NUMBER_NAN | IS_NUMBER_NOT_INT | IS_NUMBER_TRAILING ], + [ "nanx", PERL_SCAN_TRAILING, undef, IS_NUMBER_NAN | IS_NUMBER_NOT_INT | IS_NUMBER_TRAILING ], ); for my $grok (@groks) { diff --git a/numeric.c b/numeric.c index 9e05d55..72676a4 100644 --- a/numeric.c +++ b/numeric.c @@ -548,45 +548,6 @@ Perl_grok_numeric_radix(pTHX_ const char **sp, const char *send) } /* -=for apidoc grok_number_flags - -Recognise (or not) a number. The type of the number is returned -(0 if unrecognised), otherwise it is a bit-ORed combination of -IS_NUMBER_IN_UV, IS_NUMBER_GREATER_THAN_UV_MAX, IS_NUMBER_NOT_INT, -IS_NUMBER_NEG, IS_NUMBER_INFINITY, IS_NUMBER_NAN (defined in perl.h). - -If the value of the number can fit in a UV, it is returned in the *valuep -IS_NUMBER_IN_UV will be set to indicate that *valuep is valid, IS_NUMBER_IN_UV -will never be set unless *valuep is valid, but *valuep may have been assigned -to during processing even though IS_NUMBER_IN_UV is not set on return. -If valuep is NULL, IS_NUMBER_IN_UV will be set for the same cases as when -valuep is non-NULL, but no actual assignment (or SEGV) will occur. - -IS_NUMBER_NOT_INT will be set with IS_NUMBER_IN_UV if trailing decimals were -seen (in which case *valuep gives the true value truncated to an integer), and -IS_NUMBER_NEG if the number is negative (in which case *valuep holds the -absolute value). IS_NUMBER_IN_UV is not set if e notation was used or the -number is larger than a UV. - -C<flags> allows only C<PERL_SCAN_TRAILING>, which allows for trailing -non-numeric text on an otherwise successful I<grok>, setting -C<IS_NUMBER_TRAILING> on the result. - -=for apidoc grok_number - -Identical to grok_number_flags() with flags set to zero. - -=cut - */ -int -Perl_grok_number(pTHX_ const char *pv, STRLEN len, UV *valuep) -{ - PERL_ARGS_ASSERT_GROK_NUMBER; - - return grok_number_flags(pv, len, valuep, 0); -} - -/* =for apidoc grok_infnan Helper for grok_number(), accepts various ways of spelling "infinity" @@ -598,19 +559,21 @@ or "not a number", and returns one of the following flag combinations: IS_NUMBER_NAN | IS_NUMBER_NEG 0 -If an infinity or not-a-number is recognized, the *sp will point to -one past the end of the recognized string. If the recognition fails, +possibly |-ed with IS_NUMBER_TRAILING. + +If an infinity or a not-a-number is recognized, the *sp will point to +one byte past the end of the recognized string. If the recognition fails, zero is returned, and the *sp will not move. =cut */ int -Perl_grok_infnan(const char** sp, const char* send) +Perl_grok_infnan(pTHX_ const char** sp, const char* send) { const char* s = *sp; int flags = 0; - bool odh = FALSE; /* one dot hash: 1.#INF */ + bool odh = FALSE; /* one-dot-hash: 1.#INF */ PERL_ARGS_ASSERT_GROK_INFNAN; @@ -623,7 +586,8 @@ Perl_grok_infnan(const char** sp, const char* send) } if (*s == '1') { - /* Visual C: 1.#SNAN, -1.#QNAN, 1#INF, 1#.IND (maybe also 1.#NAN) */ + /* Visual C: 1.#SNAN, -1.#QNAN, 1#INF, 1.#IND (maybe also 1.#NAN) + * Let's keep the dot optional. */ s++; if (s == send) return 0; if (*s == '.') { s++; if (s == send) return 0; @@ -636,32 +600,47 @@ Perl_grok_infnan(const char** sp, const char* send) } if (isALPHA_FOLD_EQ(*s, 'I')) { - /* INF or IND (1.#IND is indeterminate, a certain type of NAN) */ + /* INF or IND (1.#IND is "indeterminate", a certain type of NAN) */ + s++; if (s == send || isALPHA_FOLD_NE(*s, 'N')) return 0; s++; if (s == send) return 0; if (isALPHA_FOLD_EQ(*s, 'F')) { s++; if (s < send && (isALPHA_FOLD_EQ(*s, 'I'))) { - s++; if (s == send || isALPHA_FOLD_NE(*s, 'N')) return 0; - s++; if (s == send || isALPHA_FOLD_NE(*s, 'I')) return 0; - s++; if (s == send || isALPHA_FOLD_NE(*s, 'T')) return 0; - s++; if (s == send || - /* allow either Infinity or Infinite */ - !(isALPHA_FOLD_EQ(*s, 'Y') || - isALPHA_FOLD_EQ(*s, 'E'))) return 0; - s++; if (s < send) return 0; - } else if (*s) - return 0; + int fail = + flags | IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT | IS_NUMBER_TRAILING; + s++; if (s == send || isALPHA_FOLD_NE(*s, 'N')) return fail; + s++; if (s == send || isALPHA_FOLD_NE(*s, 'I')) return fail; + s++; if (s == send || isALPHA_FOLD_NE(*s, 'T')) return fail; + s++; if (s == send || isALPHA_FOLD_NE(*s, 'Y')) return fail; + s++; + } else if (odh) { + while (*s == '0') { /* 1.#INF00 */ + s++; + } + } + while (s < send && isSPACE(*s)) + s++; + if (s < send && *s) { + flags |= IS_NUMBER_TRAILING; + } flags |= IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT; } else if (isALPHA_FOLD_EQ(*s, 'D') && odh) { /* 1.#IND */ s++; flags |= IS_NUMBER_NAN | IS_NUMBER_NOT_INT; + while (*s == '0') { /* 1.#IND00 */ + s++; + } + if (*s) { + flags |= IS_NUMBER_TRAILING; + } } else return 0; } else { - /* NAN */ + /* Maybe NAN of some sort */ + if (isALPHA_FOLD_EQ(*s, 'S') || isALPHA_FOLD_EQ(*s, 'Q')) { /* snan, qNaN */ /* XXX do something with the snan/qnan difference */ @@ -678,18 +657,183 @@ Perl_grok_infnan(const char** sp, const char* send) /* NaN can be followed by various stuff (NaNQ, NaNS), but * there are also multiple different NaN values, and some * implementations output the "payload" values, - * e.g. NaN123, NAN(abc), while some implementations just + * e.g. NaN123, NAN(abc), while some legacy implementations * have weird stuff like NaN%. */ + if (isALPHA_FOLD_EQ(*s, 'q') || + isALPHA_FOLD_EQ(*s, 's')) { + /* "nanq" or "nans" are ok, though generating + * these portably is tricky. */ + s++; + } + if (*s == '(') { + /* C99 style "nan(123)" or Perlish equivalent "nan($uv)". */ + const char *t; + s++; + if (s == send) { + return flags | IS_NUMBER_TRAILING; + } + t = s + 1; + while (t < send && *t && *t != ')') { + t++; + } + if (t == send) { + return flags | IS_NUMBER_TRAILING; + } + if (*t == ')') { + int nantype; + UV nanval; + if (s[0] == '0' && s + 2 < t && + isALPHA_FOLD_EQ(s[1], 'x') && + isXDIGIT(s[2])) { + STRLEN len = t - s; + I32 flags = PERL_SCAN_ALLOW_UNDERSCORES; + nanval = grok_hex(s, &len, &flags, NULL); + if ((flags & PERL_SCAN_GREATER_THAN_UV_MAX)) { + nantype = 0; + } else { + nantype = IS_NUMBER_IN_UV; + } + s += len; + } else if (s[0] == '0' && s + 2 < t && + isALPHA_FOLD_EQ(s[1], 'b') && + (s[2] == '0' || s[2] == '1')) { + STRLEN len = t - s; + I32 flags = PERL_SCAN_ALLOW_UNDERSCORES; + nanval = grok_bin(s, &len, &flags, NULL); + if ((flags & PERL_SCAN_GREATER_THAN_UV_MAX)) { + nantype = 0; + } else { + nantype = IS_NUMBER_IN_UV; + } + s += len; + } else { + const char *u; + nantype = + grok_number_flags(s, t - s, &nanval, + PERL_SCAN_TRAILING | + PERL_SCAN_ALLOW_UNDERSCORES); + /* Unfortunately grok_number_flags() doesn't + * tell how far we got and the ')' will always + * be "trailing", so we need to double-check + * whether we had something dubious. */ + for (u = s; u < t; u++) { + if (!isDIGIT(*u)) { + flags |= IS_NUMBER_TRAILING; + break; + } + } + s = u; + } + + /* XXX Doesn't do octal: nan("0123"). + * Probably not a big loss. */ + + if ((nantype & IS_NUMBER_NOT_INT) || + !(nantype && IS_NUMBER_IN_UV)) { + /* XXX the nanval is currently unused, that is, + * not inserted as the NaN payload of the NV. + * But the above code already parses the C99 + * nan(...) format. See below, and see also + * the nan() in POSIX.xs. + * + * Certain configuration combinations where + * NVSIZE is greater than UVSIZE mean that + * a single UV cannot contain all the possible + * NaN payload bits. There would need to be + * some more generic syntax than "nan($uv)". + * Issues to keep in mind: + * + * (1) In most common cases there would + * not be an integral number of bytes that + * could be set, only a certain number of bits. + * For example for the common NVSIZE == UVSIZE + * there is room for 52 bits in the payload, + * but one bit is commonly reserved for the + * signal/quiet bit, so 51 bits. For the + * x86 80-bit doubles there would be 62 bits, + * and so forth. + * + * (2) Endianness of the payload bits. If the + * payload is specified as an UV, the low-order + * bits of the UV are naturally little-endianed + * (rightmost) bits of the payload. The endianness + * of UVs and NVs can be different. */ + return 0; + } + if (s < t) { + flags |= IS_NUMBER_TRAILING; + } + } else { + /* Looked like nan(...), but no close paren. */ + flags |= IS_NUMBER_TRAILING; + } + } else { + while (s < send && isSPACE(*s)) + s++; + if (s < send && *s) { + /* Note that we here implicitly accept (parse as + * "nan", but with warnings) also any other weird + * trailing stuff for "nan". In the above we just + * check that if we got the C99-style "nan(...)", + * the "..." looks sane. + * If in future we accept more ways of specifying + * the nan payload, the accepting would happen around + * here. */ + flags |= IS_NUMBER_TRAILING; + } + } s = send; } else return 0; } + while (s < send && isSPACE(*s)) + s++; + *sp = s; return flags; } +/* +=for apidoc grok_number_flags + +Recognise (or not) a number. The type of the number is returned +(0 if unrecognised), otherwise it is a bit-ORed combination of +IS_NUMBER_IN_UV, IS_NUMBER_GREATER_THAN_UV_MAX, IS_NUMBER_NOT_INT, +IS_NUMBER_NEG, IS_NUMBER_INFINITY, IS_NUMBER_NAN (defined in perl.h). + +If the value of the number can fit in a UV, it is returned in the *valuep +IS_NUMBER_IN_UV will be set to indicate that *valuep is valid, IS_NUMBER_IN_UV +will never be set unless *valuep is valid, but *valuep may have been assigned +to during processing even though IS_NUMBER_IN_UV is not set on return. +If valuep is NULL, IS_NUMBER_IN_UV will be set for the same cases as when +valuep is non-NULL, but no actual assignment (or SEGV) will occur. + +IS_NUMBER_NOT_INT will be set with IS_NUMBER_IN_UV if trailing decimals were +seen (in which case *valuep gives the true value truncated to an integer), and +IS_NUMBER_NEG if the number is negative (in which case *valuep holds the +absolute value). IS_NUMBER_IN_UV is not set if e notation was used or the +number is larger than a UV. + +C<flags> allows only C<PERL_SCAN_TRAILING>, which allows for trailing +non-numeric text on an otherwise successful I<grok>, setting +C<IS_NUMBER_TRAILING> on the result. + +=for apidoc grok_number + +Identical to grok_number_flags() with flags set to zero. + +=cut + */ +int +Perl_grok_number(pTHX_ const char *pv, STRLEN len, UV *valuep) +{ + PERL_ARGS_ASSERT_GROK_NUMBER; + + return grok_number_flags(pv, len, valuep, 0); +} + static const UV uv_max_div_10 = UV_MAX / 10; static const U8 uv_max_mod_10 = UV_MAX % 10; @@ -867,7 +1011,7 @@ Perl_grok_number_flags(pTHX_ const char *pv, STRLEN len, UV *valuep, U32 flags) if ((s + 2 < send) && strchr("inqs#", toFOLD(*s))) { /* Really detect inf/nan. Start at d, not s, since the above * code might have already consumed the "1." or "1". */ - int infnan = Perl_grok_infnan(&d, send); + int infnan = Perl_grok_infnan(aTHX_ &d, send); if ((infnan & IS_NUMBER_INFINITY)) { return (numtype | infnan); /* Keep sign for infinity. */ } @@ -1110,7 +1254,7 @@ Perl_my_atof(pTHX_ const char* s) } static char* -S_my_atof_infnan(const char* s, bool negative, const char* send, NV* value) +S_my_atof_infnan(pTHX_ const char* s, bool negative, const char* send, NV* value) { const char *p0 = negative ? s - 1 : s; const char *p = p0; @@ -1265,7 +1409,7 @@ Perl_my_atof2(pTHX_ const char* orig, NV* value) { const char* endp; - if ((endp = S_my_atof_infnan(s, negative, send, value))) + if ((endp = S_my_atof_infnan(aTHX_ s, negative, send, value))) return (char*)endp; } diff --git a/pod/perldiag.pod b/pod/perldiag.pod index 3ceb747..ab621a1 100644 --- a/pod/perldiag.pod +++ b/pod/perldiag.pod @@ -189,6 +189,11 @@ alternatives. that expected a numeric value instead. If you're fortunate the message will identify which operator was so unfortunate. +Note that for the C<Inf> and C<NaN> (infinity and not-a-number) the +definition of "numeric" is somewhat unusual: the strings themselves +(like "Inf") are considered numeric, and anything following them is +considered non-numeric. + =item Argument list not closed for PerlIO layer "%s" (W layer) When pushing a layer with arguments onto the Perl I/O diff --git a/proto.h b/proto.h index 9f68fac..ca280b5 100644 --- a/proto.h +++ b/proto.h @@ -1359,9 +1359,9 @@ PERL_CALLCONV UV Perl_grok_hex(pTHX_ const char* start, STRLEN* len_p, I32* flag #define PERL_ARGS_ASSERT_GROK_HEX \ assert(start); assert(len_p); assert(flags) -PERL_CALLCONV int Perl_grok_infnan(const char** sp, const char *send) - __attribute__nonnull__(1) - __attribute__nonnull__(2); +PERL_CALLCONV int Perl_grok_infnan(pTHX_ const char** sp, const char *send) + __attribute__nonnull__(pTHX_1) + __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_GROK_INFNAN \ assert(sp); assert(send) diff --git a/sv.c b/sv.c index 1e85a72..3f0344b 100644 --- a/sv.c +++ b/sv.c @@ -1936,6 +1936,7 @@ Perl_looks_like_number(pTHX_ SV *const sv) { const char *sbegin; STRLEN len; + int numtype; PERL_ARGS_ASSERT_LOOKS_LIKE_NUMBER; @@ -1944,7 +1945,8 @@ Perl_looks_like_number(pTHX_ SV *const sv) } 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 @@ -2249,7 +2251,7 @@ 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_NAN))) + if (ckWARN(WARN_NUMERIC) && ((numtype & IS_NUMBER_TRAILING))) not_a_number(sv); S_sv_setnv(aTHX_ sv, numtype); return FALSE; diff --git a/t/op/infnan.t b/t/op/infnan.t index ef8ee4b..70f0a7d 100644 --- a/t/op/infnan.t +++ b/t/op/infnan.t @@ -27,14 +27,13 @@ my $NaN; } my @PInf = ("Inf", "inf", "INF", "+Inf", - "Infinity", "INFINITE", - "1.#INF", "1#INF"); + "Infinity", + "1.#INF", "1#INF", "1.#INF00"); my @NInf = map { "-$_" } grep { ! /^\+/ } @PInf; my @NaN = ("NAN", "nan", "qnan", "SNAN", "NanQ", "NANS", - "1.#QNAN", "+1#SNAN", "-1.#NAN", "1#IND", - "NaN123", "NAN(123)", "nan%", - "nanonano"); # RIP, Robin Williams. + "1.#QNAN", "+1#SNAN", "-1.#NAN", "1#IND", "1.#IND00", + "NAN(123)"); my @printf_fmt = qw(e f g a d u o i b x p); my @packi_fmt = qw(c C s S l L i I n N v V j J w W U); @@ -246,14 +245,14 @@ TODO: { } SKIP: { - my @FInf = qw(Info Infiniti Infinityz); + my @FInf = qw(Infinite Info Inf123 Infiniti Infinityz); if ($Config{usequadmath}) { skip "quadmath strtoflt128() accepts false infinities", scalar @FInf; } - # Silence "isn't numeric in addition", that's kind of the point. - local $^W = 0; for my $i (@FInf) { - cmp_ok("$i" + 0, '==', 0, "false infinity $i"); + # Silence "isn't numeric in addition", that's kind of the point. + local $^W = 0; + cmp_ok("$i" + 0, '==', $PInf, "false infinity $i"); } } @@ -343,7 +342,6 @@ is eval { unpack "p", pack 'p', $NaN }, "NaN", "pack p +NaN"; is eval { unpack "P3", pack 'P', $NaN }, "NaN", "pack P +NaN"; for my $i (@NaN) { - local $^W = 0; # warning-ness tested later. cmp_ok($i + 0, '!=', $i + 0, "$i is NaN numerically (by not being NaN)"); is("@{[$i+0]}", "NaN", "$i value stringifies as NaN"); } @@ -407,22 +405,6 @@ SKIP: { is("a" x $NaN, "", "x NaN"); } -{ - my $w; - local $SIG{__WARN__} = sub { $w = shift }; - local $^W = 1; - my $a; - eval '$a = "nancy" + 1'; - is($a, "$NaN", "nancy plus one is $NaN"); - like($w, qr/^Argument "nancy" isn't numeric/, "nancy numify (compile time)"); - - my $n = "nanana"; - my $b; - eval '$b = $n + 1'; - is($b, "$NaN", "$n plus one is $NaN"); - like($w, qr/^Argument "$n" isn't numeric/, "$n numify (runtime)"); -} - # === Tests combining Inf and NaN === # is() okay with $NaN because it uses eq. @@ -465,4 +447,77 @@ cmp_ok('1e-9999', '==', 0, "underflow to 0 (runtime) from pos"); cmp_ok(-1e-9999, '==', 0, "underflow to 0 (compile time) from neg"); cmp_ok('-1e-9999', '==', 0, "underflow to 0 (runtime) from neg"); +# === Warnings triggered when and only when appropriate === +{ + my $w; + local $SIG{__WARN__} = sub { $w = shift }; + local $^W = 1; + + my $T = + [ + [ "inf", 0, $PInf ], + [ "infinity", 0, $PInf ], + [ "infxy", 1, $PInf ], + [ "inf34", 1, $PInf ], + [ "1.#INF", 0, $PInf ], + [ "1.#INFx", 1, $PInf ], + [ "1.#INF00", 0, $PInf ], + [ "1.#INFxy", 1, $PInf ], + [ " inf", 0, $PInf ], + [ "inf ", 0, $PInf ], + [ " inf ", 0, $PInf ], + + [ "nan", 0, $NaN ], + [ "nanxy", 1, $NaN ], + [ "nan34", 1, $NaN ], + [ "nanq", 0, $NaN ], + [ "nans", 0, $NaN ], + [ "nanx", 1, $NaN ], + [ "nanqy", 1, $NaN ], + [ "nan(123)", 0, $NaN ], + [ "nan(0x123)", 0, $NaN ], + [ "nan(123xy)", 1, $NaN ], + [ "nan(0x123xy)", 1, $NaN ], + [ "nanq(123)", 0, $NaN ], + [ "nan(123", 1, $NaN ], + [ "nan(", 1, $NaN ], + [ "1.#NANQ", 0, $NaN ], + [ "1.#QNAN", 0, $NaN ], + [ "1.#NANQx", 1, $NaN ], + [ "1.#QNANx", 1, $NaN ], + [ "1.#IND", 0, $NaN ], + [ "1.#IND00", 0, $NaN ], + [ "1.#INDxy", 1, $NaN ], + [ " nan", 0, $NaN ], + [ "nan ", 0, $NaN ], + [ " nan ", 0, $NaN ], + ]; + + for my $t (@$T) { + print "# '$t->[0]' compile time\n"; + my $a; + $w = ''; + eval '$a = "'.$t->[0].'" + 1'; + is("$a", "$t->[2]", "$t->[0] plus one is $t->[2]"); + if ($t->[1]) { + like($w, qr/^Argument \Q"$t->[0]"\E isn't numeric/, + "$t->[2] numify warn"); + } else { + is($w, "", "no warning expected"); + } + print "# '$t->[0]' runtime\n"; + my $n = $t->[0]; + my $b; + $w = ''; + eval '$b = $n + 1'; + is("$b", "$t->[2]", "$n plus one is $t->[2]"); + if ($t->[1]) { + like($w, qr/^Argument \Q"$n"\E isn't numeric/, + "$n numify warn"); + } else { + is($w, "", "no warning expected"); + } + } +} + done_testing(); -- Perl5 Master Repository
