In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/626ef08910b91efb9ac7ecd5f41e991c2a4ce5dd?hp=72d14f84195b9021e7b3470e5bafac0740179a3e>
- Log ----------------------------------------------------------------- commit 626ef08910b91efb9ac7ecd5f41e991c2a4ce5dd Author: Karl Williamson <[email protected]> Date: Tue Dec 31 22:41:39 2013 -0700 numeric.c: Use macros instead of strchr() This replaces uses of strchr() (and hence its loop) with a simple array lookup, mask, and test. This causes an extra test to be needed later in the hex decoding case to get the hex value, instead of a subtract previously. However these two tests are fewer than the average number in strchr(). M numeric.c commit cb27eebd32af3dfebf46f5eb3778fe29175004b5 Author: Karl Williamson <[email protected]> Date: Tue Dec 31 22:35:46 2013 -0700 handy.h: Add two macros handy.h contains a macro that reads a hex digit and returns its value, with fewer branches than a naive implementation would use. This commit just copies and modifies it to create two macros for 1) just converting the hex value, without advancing the input; and 2) doing the same for an octal value. M handy.h commit 902008b8891cbab762cbca65291391e811857949 Author: Karl Williamson <[email protected]> Date: Tue Dec 31 22:19:45 2013 -0700 handy.h: Add debugging assertion This macro requires the input to be a hex digit, without testing. It is prudent to assert that under DEBUGGING. M handy.h commit 0f092d081073e047f09aa9ef4f1d62bf5db65747 Author: Karl Williamson <[email protected]> Date: Tue Dec 31 22:13:06 2013 -0700 Move a macro from utf8.h to handy.h for wider use. Future commits will want this available outside utf8.h M handy.h M utf8.h commit 7c08c4c54fcfe6d3c4509e5c583cbb38723f9237 Author: Karl Williamson <[email protected]> Date: Tue Dec 31 21:57:53 2013 -0700 regen/warnings.pl: Add comments These note that warnings categories should be independent in the calls to ckWARN() and packWARN() type macros. M regen/warnings.pl M warnings.h commit 13d7a909b7642a181b072c1236932573b500a779 Author: Karl Williamson <[email protected]> Date: Tue Dec 31 22:05:45 2013 -0700 ext/XS-APItest/t/utf8.t: White-space only Indent and reflow to fit into 79 columns due to a new enclosing block in the previous commit M ext/XS-APItest/t/utf8.t commit 54f4afefabe5f838538f462f1e2bb40a64b6bb77 Author: Karl Williamson <[email protected]> Date: Tue Dec 31 21:45:54 2013 -0700 utf8.c: Fix warning category and subcategory conflicts The warnings categories non_unicode, nonchar, and surrogate are all subcategories of 'utf8'. One should never call a packWARN() with both a category and a subcategory of it, as it will mean that one can't completely make the subcategory independent. For example, use warnings 'utf8'; no warnings 'surrogate'; surrogate warnings will be output if they are tested with a ckWARN2(WARN_UTF8, WARN_SURROGATE); utf8.c was guilty of this. M ext/XS-APItest/t/utf8.t M pod/perldiag.pod M utf8.c commit 0cfa64bfe0ab570e7b2ddddfdad71f8341a5e6e1 Author: Karl Williamson <[email protected]> Date: Tue Dec 31 21:41:09 2013 -0700 utf8.c: Don't do redundant test The test here for WARN_UTF8 is redundant, as only if one of the other three warning categories is enabled will anything actually be output. M utf8.c commit 1a89bb6c2ba7b1d0b44a5a627009274b3cde11a1 Author: Karl Williamson <[email protected]> Date: Tue Dec 31 21:37:52 2013 -0700 utf8.c: Typo in comment, and clarification M utf8.c commit 27f39eb8acaa22c545010301cc1183d1dc2909e5 Author: Karl Williamson <[email protected]> Date: Tue Dec 31 12:30:35 2013 -0700 Unicode::UCD::prop_aliases(): Don't generate spurious warnings Certain inputs to prop_aliases caused spurious warning. M lib/Unicode/UCD.pm M lib/Unicode/UCD.t commit ebcaaa39d45ae969948eaf6f2f92d89398649700 Author: Karl Williamson <[email protected]> Date: Wed Jan 1 12:58:05 2014 -0700 t/test.pl: Reword comment There was a typo in this comment, but looking at it closely made me realize that I didn't really understand it. This clarifies it. M t/test.pl ----------------------------------------------------------------------- Summary of changes: ext/XS-APItest/t/utf8.t | 155 ++++++++++++++++++++++++++++-------------------- handy.h | 31 ++++++++-- lib/Unicode/UCD.pm | 19 ++++-- lib/Unicode/UCD.t | 10 ++++ numeric.c | 35 +++++------ pod/perldiag.pod | 2 +- regen/warnings.pl | 8 +++ t/test.pl | 3 +- utf8.c | 16 ++--- utf8.h | 10 ---- warnings.h | 8 +++ 11 files changed, 184 insertions(+), 113 deletions(-) diff --git a/ext/XS-APItest/t/utf8.t b/ext/XS-APItest/t/utf8.t index 6a6ed9e..5f1c9c9 100644 --- a/ext/XS-APItest/t/utf8.t +++ b/ext/XS-APItest/t/utf8.t @@ -202,85 +202,114 @@ foreach my $test (@tests) { # are several orthogonal variables involved. We test all the subclasses # of utf8 warnings to verify they work with and without the utf8 class, # and don't have effects on other sublass warnings - foreach my $warning (0, 'utf8', 'surrogate', 'nonchar', 'non_unicode') { + foreach my $warning ('utf8', 'surrogate', 'nonchar', 'non_unicode') { foreach my $warn_flag (0, $warn_flags) { foreach my $disallow_flag (0, $disallow_flags) { + foreach my $do_warning (0, 1) { - no warnings 'utf8'; - my $eval_warn = $warning eq 0 ? "no warnings" : "use warnings '$warning'"; + my $eval_warn = $do_warning + ? "use warnings '$warning'" + : $warning eq "utf8" + ? "no warnings 'utf8'" + : "use warnings 'utf8'; no warnings '$warning'"; - # is effectively disallowed if will overflow, even if the flag - # indicates it is allowed, fix up test name to indicate this - # as well - my $disallowed = $disallow_flag || $will_overflow; + # is effectively disallowed if will overflow, even if the + # flag indicates it is allowed, fix up test name to + # indicate this as well + my $disallowed = $disallow_flag || $will_overflow; - my $this_name = "$testname: " . (($disallow_flag) - ? 'disallowed' - : ($disallowed) - ? 'FE_FF allowed' - : 'allowed'); - $this_name .= ", $eval_warn"; - $this_name .= ", " . (($warn_flag) ? 'with warning flag' : 'no warning flag'); + my $this_name = "$testname: " . (($disallow_flag) + ? 'disallowed' + : ($disallowed) + ? 'FE_FF allowed' + : 'allowed'); + $this_name .= ", $eval_warn"; + $this_name .= ", " . (($warn_flag) + ? 'with warning flag' + : 'no warning flag'); - undef @warnings; - my $ret_ref; - #note __LINE__ . ": $eval_warn; \$ret_ref = test_utf8n_to_uvchr('$bytes', $length, $warn_flag|$disallow_flag)"; - my $eval_text = "$eval_warn; \$ret_ref = test_utf8n_to_uvchr('$bytes', $length, $warn_flag|$disallow_flag)"; - eval "$eval_text"; - if (! ok ("$@ eq ''", "$this_name: eval succeeded")) { - note "\$!='$!'; eval'd=\"$eval_text\""; - next; - } - if ($disallowed) { - is($ret_ref->[0], 0, "$this_name: Returns 0"); - } - else { - is($ret_ref->[0], $allowed_uv, "$this_name: Returns expected uv"); - } - is($ret_ref->[1], $expected_len, "$this_name: Returns expected length"); - - if ($will_overflow && ! $disallow_flag && $warning eq 'utf8') { - - # Will get the overflow message instead of the expected - # message under these circumstances, as they would - # otherwise accept an overflowed value, which the code - # should not allow, so falls back to overflow. - if (is(scalar @warnings, 1, "$this_name: Got a single warning ")) { - like($warnings[0], qr/overflow/, "$this_name: Got overflow warning"); + undef @warnings; + my $ret_ref; + #note __LINE__ . ": $eval_warn; \$ret_ref = test_utf8n_to_uvchr('$bytes', $length, $warn_flag|$disallow_flag)"; + my $eval_text = "$eval_warn; \$ret_ref = test_utf8n_to_uvchr('$bytes', $length, $warn_flag|$disallow_flag)"; + eval "$eval_text"; + if (! ok ("$@ eq ''", "$this_name: eval succeeded")) { + note "\$!='$!'; eval'd=\"$eval_text\""; + next; + } + if ($disallowed) { + is($ret_ref->[0], 0, "$this_name: Returns 0"); } else { - if (scalar @warnings) { + is($ret_ref->[0], $allowed_uv, + "$this_name: Returns expected uv"); + } + is($ret_ref->[1], $expected_len, + "$this_name: Returns expected length"); + + if (! $do_warning + && ($warning eq 'utf8' || $warning eq $category)) + { + if (!is(scalar @warnings, 0, + "$this_name: No warnings generated")) + { note "The warnings were: " . join(", ", @warnings); } } - } - elsif ($warn_flag && ($warning eq 'utf8' || $warning eq $category)) { - if (is(scalar @warnings, 1, "$this_name: Got a single warning ")) { - like($warnings[0], $message, "$this_name: Got expected warning"); - } - else { - if (scalar @warnings) { - note "The warnings were: " . join(", ", @warnings); + elsif ($will_overflow + && ! $disallow_flag + && $warning eq 'utf8') + { + + # Will get the overflow message instead of the expected + # message under these circumstances, as they would + # otherwise accept an overflowed value, which the code + # should not allow, so falls back to overflow. + if (is(scalar @warnings, 1, + "$this_name: Got a single warning ")) + { + like($warnings[0], qr/overflow/, + "$this_name: Got overflow warning"); + } + else { + if (scalar @warnings) { + note "The warnings were: " + . join(", ", @warnings); + } } } - } - else { - if (!is(scalar @warnings, 0, "$this_name: No warnings generated")) + elsif ($warn_flag + && ($warning eq 'utf8' || $warning eq $category)) { - note "The warnings were: " . join(", ", @warnings); + if (is(scalar @warnings, 1, + "$this_name: Got a single warning ")) + { + like($warnings[0], $message, + "$this_name: Got expected warning"); + } + else { + if (scalar @warnings) { + note "The warnings were: " + . join(", ", @warnings); + } + } } - } - # Check CHECK_ONLY results when the input is disallowed. Do - # this when actually disallowed, not just when the - # $disallow_flag is set - if ($disallowed) { - undef @warnings; - $ret_ref = test_utf8n_to_uvchr($bytes, $length, $disallow_flag|$UTF8_CHECK_ONLY); - is($ret_ref->[0], 0, "$this_name, CHECK_ONLY: Returns 0"); - is($ret_ref->[1], -1, "$this_name: CHECK_ONLY: returns expected length"); - if (! is(scalar @warnings, 0, "$this_name, CHECK_ONLY: no warnings generated")) { - note "The warnings were: " . join(", ", @warnings); + # Check CHECK_ONLY results when the input is disallowed. Do + # this when actually disallowed, not just when the + # $disallow_flag is set + if ($disallowed) { + undef @warnings; + $ret_ref = test_utf8n_to_uvchr($bytes, $length, + $disallow_flag|$UTF8_CHECK_ONLY); + is($ret_ref->[0], 0, "$this_name, CHECK_ONLY: Returns 0"); + is($ret_ref->[1], -1, + "$this_name: CHECK_ONLY: returns expected length"); + if (! is(scalar @warnings, 0, + "$this_name, CHECK_ONLY: no warnings generated")) + { + note "The warnings were: " . join(", ", @warnings); + } } } } diff --git a/handy.h b/handy.h index cc6b564..6b74c87 100644 --- a/handy.h +++ b/handy.h @@ -270,6 +270,16 @@ typedef U64TYPE U64; #define Ctl(ch) ((ch) & 037) +/* This is a helper macro to avoid preprocessor issues, expanding to an + * assert followed by a comma under DEBUGGING (hence the comma operator). If + * we didn't do this, we would get a comma with nothing before it when not + * DEBUGGING */ +#ifdef DEBUGGING +# define __ASSERT_(statement) assert(statement), +#else +# define __ASSERT_(statement) +#endif + /* =head1 SV-Body Allocation @@ -1554,11 +1564,22 @@ typedef U32 line_t; } \ return a; -/* Converts a hex digit in a string to its numeric value, advancing the - * pointer. The input must be known to be 0-9, A-F, or a-f. In both ASCII and - * EBCDIC the last 4 bits of the digits are 0-9; and the last 4 bits of A-F and - * a-f are 1-6, so adding 9 yields 10-15 */ -#define READ_XDIGIT(s) (0xf & (isDIGIT(*(s)) ? (*(s)++) : (*(s)++ + 9))) +/* Converts a character known to represent a hexadecimal digit (0-9, A-F, or + * a-f) to its numeric value. READ_XDIGIT's argument is a string pointer, + * which is advanced. The input is validated only by an assert() in DEBUGGING + * builds. In both ASCII and EBCDIC the last 4 bits of the digits are 0-9; and + * the last 4 bits of A-F and a-f are 1-6, so adding 9 yields 10-15 */ +#define XDIGIT_VALUE(c) (__ASSERT_(isXDIGIT(c)) (0xf & (isDIGIT(c) \ + ? (c) \ + : ((c) + 9)))) +#define READ_XDIGIT(s) (__ASSERT_(isXDIGIT(*s)) (0xf & (isDIGIT(*(s)) \ + ? (*(s)++) \ + : (*(s)++ + 9)))) + +/* Converts a character known to represent an octal digit (0-7) to its numeric + * value. The input is validated only by an assert() in DEBUGGING builds. In + * both ASCII and EBCDIC the last 3 bits of the octal digits range from 0-7. */ +#define OCTAL_VALUE(c) (__ASSERT_(isOCTAL(c)) (7 & (c))) /* =head1 Memory Management diff --git a/lib/Unicode/UCD.pm b/lib/Unicode/UCD.pm index 8674545..a422334 100644 --- a/lib/Unicode/UCD.pm +++ b/lib/Unicode/UCD.pm @@ -5,7 +5,7 @@ use warnings; no warnings 'surrogate'; # surrogates can be inputs to this use charnames (); -our $VERSION = '0.56'; +our $VERSION = '0.57'; require Exporter; @@ -1844,12 +1844,21 @@ sub prop_aliases ($) { # there, the input is unknown. return; } - else { + elsif ($loose =~ / [:=] /x) { # Here we found the name but not its aliases, so it has to - # exist. This means it must be one of the Perl single-form - # extensions. First see if it is for a property-value - # combination in one of the following properties. + # exist. Exclude property-value combinations. (This shows up + # for something like ccc=vr which matches loosely, but is a + # synonym for ccc=9 which matches only strictly. + return; + } + else { + + # Here it has to exist, and isn't a property-value + # combination. This means it must be one of the Perl + # single-form extensions. First see if it is for a + # property-value combination in one of the following + # properties. my @list; foreach my $property ("gc", "script") { @list = prop_value_aliases($property, $loose); diff --git a/lib/Unicode/UCD.t b/lib/Unicode/UCD.t index 1c7b45c..61d1e72 100644 --- a/lib/Unicode/UCD.t +++ b/lib/Unicode/UCD.t @@ -13,6 +13,9 @@ BEGIN { } } +my @warnings; +local $SIG{__WARN__} = sub { push @warnings, @_ }; + use strict; use Unicode::UCD; use Test::More; @@ -534,6 +537,8 @@ is(prop_aliases("isgc"), undef, "prop_aliases('isgc') returns <undef> since is not covered Perl extension"); is(prop_aliases("Is_Is_Any"), undef, "prop_aliases('Is_Is_Any') returns <undef> since two is's"); +is(prop_aliases("ccc=vr"), undef, + "prop_aliases('ccc=vr') doesn't generate a warning"); require 'utf8_heavy.pl'; require "unicore/Heavy.pl"; @@ -2177,4 +2182,9 @@ my @alpha_invlist = prop_invlist("Alpha"); is(search_invlist(\@alpha_invlist, ord("\t")), undef, "search_invlist returns undef for code points before first one on the list"); ok($/ eq $input_record_separator, "The record separator didn't get overridden"); + +if (! ok(@warnings == 0, "No warnings were generated")) { + diag(join "\n", "The warnings are:", @warnings); +} + done_testing(); diff --git a/numeric.c b/numeric.c index 2725b3c..b5144f4 100644 --- a/numeric.c +++ b/numeric.c @@ -291,15 +291,14 @@ Perl_grok_hex(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result) } for (; len-- && *s; s++) { - const char *hexdigit = strchr(PL_hexdigit, *s); - if (hexdigit) { + if (isXDIGIT(*s)) { /* Write it in this wonky order with a goto to attempt to get the compiler to make the common case integer-only loop pretty tight. With gcc seems to be much straighter code than old scan_hex. */ redo: if (!overflowed) { if (value <= max_div_16) { - value = (value << 4) | ((hexdigit - PL_hexdigit) & 15); + value = (value << 4) | XDIGIT_VALUE(*s); continue; } /* Bah. We're just overflowed. */ @@ -316,11 +315,11 @@ Perl_grok_hex(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result) * the low-order bits anyway): we could just remember when * did we overflow and in the end just multiply value_nv by the * right amount of 16-tuples. */ - value_nv += (NV)((hexdigit - PL_hexdigit) & 15); + value_nv += (NV) XDIGIT_VALUE(*s); continue; } if (*s == '_' && len && allow_underscores && s[1] - && (hexdigit = strchr(PL_hexdigit, s[1]))) + && isXDIGIT(s[1])) { --len; ++s; @@ -395,17 +394,14 @@ Perl_grok_oct(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result) PERL_ARGS_ASSERT_GROK_OCT; for (; len-- && *s; s++) { - /* gcc 2.95 optimiser not smart enough to figure that this subtraction - out front allows slicker code. */ - int digit = *s - '0'; - if (digit >= 0 && digit <= 7) { + if (isOCTAL(*s)) { /* Write it in this wonky order with a goto to attempt to get the compiler to make the common case integer-only loop pretty tight. */ redo: if (!overflowed) { if (value <= max_div_8) { - value = (value << 3) | digit; + value = (value << 3) | OCTAL_VALUE(*s); continue; } /* Bah. We're just overflowed. */ @@ -422,20 +418,19 @@ Perl_grok_oct(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result) * the low-order bits anyway): we could just remember when * did we overflow and in the end just multiply value_nv by the * right amount of 8-tuples. */ - value_nv += (NV)digit; + value_nv += (NV) OCTAL_VALUE(*s); continue; } - if (digit == ('_' - '0') && len && allow_underscores - && (digit = s[1] - '0') && (digit >= 0 && digit <= 7)) - { - --len; - ++s; - goto redo; - } + if (*s == '_' && len && allow_underscores && isOCTAL(s[1])) { + --len; + ++s; + goto redo; + } /* Allow \octal to work the DWIM way (that is, stop scanning * as soon as non-octal characters are seen, complain only if - * someone seems to want to use the digits eight and nine). */ - if (digit == 8 || digit == 9) { + * someone seems to want to use the digits eight and nine. Since we + * know it is not octal, then if isDIGIT, must be an 8 or 9). */ + if (isDIGIT(*s)) { if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT)) Perl_ck_warner(aTHX_ packWARN(WARN_DIGIT), "Illegal octal digit '%c' ignored", *s); diff --git a/pod/perldiag.pod b/pod/perldiag.pod index 61d144a..207f55c 100644 --- a/pod/perldiag.pod +++ b/pod/perldiag.pod @@ -3672,7 +3672,7 @@ the C<fallback> overloading key is specified to be true. See L<overload>. =item Operation "%s" returns its argument for non-Unicode code point 0x%X -(S utf8, non_unicode) You performed an operation requiring Unicode +(S non_unicode) You performed an operation requiring Unicode semantics on a code point that is not in Unicode, so what it should do is not defined. Perl has chosen to have it do nothing, and warn you. diff --git a/regen/warnings.pl b/regen/warnings.pl index acca0d0..e8dcf4a 100644 --- a/regen/warnings.pl +++ b/regen/warnings.pl @@ -354,6 +354,10 @@ print $warn <<'EOM'; char)) #define ckWARN(w) Perl_ckwarn(aTHX_ packWARN(w)) + +/* The w1, w2 ... should be independent warnings categories; one shouldn't be + * a subcategory of any other */ + #define ckWARN2(w1,w2) Perl_ckwarn(aTHX_ packWARN2(w1,w2)) #define ckWARN3(w1,w2,w3) Perl_ckwarn(aTHX_ packWARN3(w1,w2,w3)) #define ckWARN4(w1,w2,w3,w4) Perl_ckwarn(aTHX_ packWARN4(w1,w2,w3,w4)) @@ -366,6 +370,10 @@ print $warn <<'EOM'; #define WARNshift 8 #define packWARN(a) (a ) + +/* The a, b, ... should be independent warnings categories; one shouldn't be + * a subcategory of any other */ + #define packWARN2(a,b) ((a) | ((b)<<8) ) #define packWARN3(a,b,c) ((a) | ((b)<<8) | ((c)<<16) ) #define packWARN4(a,b,c,d) ((a) | ((b)<<8) | ((c)<<16) | ((d) <<24)) diff --git a/t/test.pl b/t/test.pl index fcab07a..90963da 100644 --- a/t/test.pl +++ b/t/test.pl @@ -968,7 +968,8 @@ sub fresh_perl_like { # Many tests use the same format in __DATA__ or external files to specify a # sequence of (fresh) tests to run, extra files they may temporarily need, and -# what the expected output is. So have excatly one copy of the code to run that +# what the expected output is. Putting it here allows common code to serve +# these multiple tests. # # Each program is source code to run followed by an "EXPECT" line, followed # by the expected output. diff --git a/utf8.c b/utf8.c index 3773cea..41e2c4c 100644 --- a/utf8.c +++ b/utf8.c @@ -107,7 +107,7 @@ Perl_uvoffuni_to_utf8_flags(pTHX_ U8 *d, UV uv, UV flags) /* The first problematic code point is the first surrogate */ if (uv >= UNICODE_SURROGATE_FIRST - && ckWARN4_d(WARN_UTF8, WARN_SURROGATE, WARN_NON_UNICODE, WARN_NONCHAR)) + && ckWARN3_d(WARN_SURROGATE, WARN_NON_UNICODE, WARN_NONCHAR)) { if (UNICODE_IS_SURROGATE(uv)) { if (flags & UNICODE_WARN_SURROGATE) { @@ -823,7 +823,7 @@ Perl_utf8n_to_uvchr(pTHX_ const U8 *s, STRLEN curlen, STRLEN *retlen, U32 flags) goto malformed; } - /* Here, the input is considered to be well-formed , but could be a + /* Here, the input is considered to be well-formed, but it still could be a * problematic code point that is not allowed by the input parameters. */ if (uv >= UNICODE_SURROGATE_FIRST /* isn't problematic if < this */ && (flags & (UTF8_DISALLOW_ILLEGAL_INTERCHANGE @@ -831,10 +831,10 @@ Perl_utf8n_to_uvchr(pTHX_ const U8 *s, STRLEN curlen, STRLEN *retlen, U32 flags) { if (UNICODE_IS_SURROGATE(uv)) { if ((flags & (UTF8_WARN_SURROGATE|UTF8_CHECK_ONLY)) == UTF8_WARN_SURROGATE - && ckWARN2_d(WARN_UTF8, WARN_SURROGATE)) + && ckWARN_d(WARN_SURROGATE)) { sv = sv_2mortal(Perl_newSVpvf(aTHX_ "UTF-16 surrogate U+%04"UVXf"", uv)); - pack_warn = packWARN2(WARN_UTF8, WARN_SURROGATE); + pack_warn = packWARN(WARN_SURROGATE); } if (flags & UTF8_DISALLOW_SURROGATE) { goto disallowed; @@ -842,10 +842,10 @@ Perl_utf8n_to_uvchr(pTHX_ const U8 *s, STRLEN curlen, STRLEN *retlen, U32 flags) } else if ((uv > PERL_UNICODE_MAX)) { if ((flags & (UTF8_WARN_SUPER|UTF8_CHECK_ONLY)) == UTF8_WARN_SUPER - && ckWARN2_d(WARN_UTF8, WARN_NON_UNICODE)) + && ckWARN_d(WARN_NON_UNICODE)) { sv = sv_2mortal(Perl_newSVpvf(aTHX_ "Code point 0x%04"UVXf" is not Unicode, may not be portable", uv)); - pack_warn = packWARN2(WARN_UTF8, WARN_NON_UNICODE); + pack_warn = packWARN(WARN_NON_UNICODE); } if (flags & UTF8_DISALLOW_SUPER) { goto disallowed; @@ -853,10 +853,10 @@ Perl_utf8n_to_uvchr(pTHX_ const U8 *s, STRLEN curlen, STRLEN *retlen, U32 flags) } else if (UNICODE_IS_NONCHAR(uv)) { if ((flags & (UTF8_WARN_NONCHAR|UTF8_CHECK_ONLY)) == UTF8_WARN_NONCHAR - && ckWARN2_d(WARN_UTF8, WARN_NONCHAR)) + && ckWARN_d(WARN_NONCHAR)) { sv = sv_2mortal(Perl_newSVpvf(aTHX_ "Unicode non-character U+%04"UVXf" is illegal for open interchange", uv)); - pack_warn = packWARN2(WARN_UTF8, WARN_NONCHAR); + pack_warn = packWARN(WARN_NONCHAR); } if (flags & UTF8_DISALLOW_NONCHAR) { goto disallowed; diff --git a/utf8.h b/utf8.h index 8504207..2d48775 100644 --- a/utf8.h +++ b/utf8.h @@ -364,16 +364,6 @@ Perl's extended UTF-8 means we can have start bytes up to FF. I8_TO_NATIVE_UTF8((translate_function(c) & UTF_CONTINUATION_MASK) \ | UTF_CONTINUATION_MARK) -/* This is another helper macro to avoid preprocessor issues, expanding to an - * assert followed by a comma under DEBUGGING (hence the comma operator). If - * we didn't do this, we would get a comma with nothing before it when not - * DEBUGGING */ -#ifdef DEBUGGING -# define __ASSERT_(statement) assert(statement), -#else -# define __ASSERT_(statement) -#endif - /* The next two macros should not be used. They were designed to be usable as * the case label of a switch statement, but this doesn't work for EBCDIC. Use * regen/unicode_constants.pl instead */ diff --git a/warnings.h b/warnings.h index 7455a6c..929b94f 100644 --- a/warnings.h +++ b/warnings.h @@ -116,6 +116,10 @@ char)) #define ckWARN(w) Perl_ckwarn(aTHX_ packWARN(w)) + +/* The w1, w2 ... should be independent warnings categories; one shouldn't be + * a subcategory of any other */ + #define ckWARN2(w1,w2) Perl_ckwarn(aTHX_ packWARN2(w1,w2)) #define ckWARN3(w1,w2,w3) Perl_ckwarn(aTHX_ packWARN3(w1,w2,w3)) #define ckWARN4(w1,w2,w3,w4) Perl_ckwarn(aTHX_ packWARN4(w1,w2,w3,w4)) @@ -128,6 +132,10 @@ #define WARNshift 8 #define packWARN(a) (a ) + +/* The a, b, ... should be independent warnings categories; one shouldn't be + * a subcategory of any other */ + #define packWARN2(a,b) ((a) | ((b)<<8) ) #define packWARN3(a,b,c) ((a) | ((b)<<8) | ((c)<<16) ) #define packWARN4(a,b,c,d) ((a) | ((b)<<8) | ((c)<<16) | ((d) <<24)) -- Perl5 Master Repository
