is(bytes_cmp_utf8($right, $left), -$expect, "$desc reversed");
}
+# Test uft8n_to_uvuni(). These provide essentially complete code coverage.
+
+# Copied from utf8.h
+my $UTF8_ALLOW_EMPTY = 0x0001;
+my $UTF8_ALLOW_CONTINUATION = 0x0002;
+my $UTF8_ALLOW_NON_CONTINUATION = 0x0004;
+my $UTF8_ALLOW_SHORT = 0x0008;
+my $UTF8_ALLOW_LONG = 0x0010;
+my $UTF8_DISALLOW_SURROGATE = 0x0020;
+my $UTF8_WARN_SURROGATE = 0x0040;
+my $UTF8_DISALLOW_NONCHAR = 0x0080;
+my $UTF8_WARN_NONCHAR = 0x0100;
+my $UTF8_DISALLOW_SUPER = 0x0200;
+my $UTF8_WARN_SUPER = 0x0400;
+my $UTF8_DISALLOW_FE_FF = 0x0800;
+my $UTF8_WARN_FE_FF = 0x1000;
+my $UTF8_CHECK_ONLY = 0x2000;
+
+my $REPLACEMENT = 0xFFFD;
+
+my @warnings;
+
+use warnings 'utf8';
+local $SIG{__WARN__} = sub { push @warnings, @_ };
+
+# First test the malformations. All these raise category utf8 warnings.
+foreach my $test (
+ [ "zero length string malformation", "", 0,
+ $UTF8_ALLOW_EMPTY, 0, 0,
+ qr/empty string/
+ ],
+ [ "orphan continuation byte malformation", "\x80a", 2,
+ $UTF8_ALLOW_CONTINUATION, $REPLACEMENT, 1,
+ qr/unexpected continuation byte/
+ ],
+ [ "premature next character malformation (immediate)", "\xc2a", 2,
+ $UTF8_ALLOW_NON_CONTINUATION, $REPLACEMENT, 1,
+ qr/unexpected non-continuation byte.*immediately after start byte/
+ ],
+ [ "premature next character malformation (non-immediate)", "\xf0\x80a", 3,
+ $UTF8_ALLOW_NON_CONTINUATION, $REPLACEMENT, 2,
+ qr/unexpected non-continuation byte .* 2 bytes after start byte/
+ ],
+ [ "too short malformation", "\xf0\x80a", 2,
+ # Having the 'a' after this, but saying there are only 2 bytes also
+ # tests that we pay attention to the passed in length
+ $UTF8_ALLOW_SHORT, $REPLACEMENT, 2,
+ qr/2 bytes, need 4/
+ ],
+ [ "overlong malformation", "\xc1\xaf", 2,
+ $UTF8_ALLOW_LONG, ord('o'), 2,
+ qr/2 bytes, need 1/
+ ],
+ [ "overflow malformation", "\xff\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf", 13,
+ 0, # There is no way to allow this malformation
+ $REPLACEMENT, 13,
+ qr/overflow/
+ ],
+) {
+ my ($testname, $bytes, $length, $allow_flags, $allowed_uv, $expected_len, $message ) = @$test;
+
+ next if ! ok(length($bytes) >= $length, "$testname: Make sure won't read beyond buffer: " . length($bytes) . " >= $length");
+
+ # Test what happens when this malformation is not allowed
+ undef @warnings;
+ my $ret_ref = test_utf8n_to_uvuni($bytes, $length, 0);
+ is($ret_ref->[0], 0, "$testname: disallowed: Returns 0");
+ is($ret_ref->[1], $expected_len, "$testname: disallowed: Returns expected length");
+ if (is(scalar @warnings, 1, "$testname: disallowed: Got a single warning ")) {
+ like($warnings[0], $message, "$testname: disallowed: Got expected warning");
+ }
+ else {
+ if (scalar @warnings) {
+ note "The warnings were: " . join(", ", @warnings);
+ }
+ }
+
+ { # Next test when disallowed, and warnings are off.
+ undef @warnings;
+ no warnings 'utf8';
+ my $ret_ref = test_utf8n_to_uvuni($bytes, $length, 0);
+ is($ret_ref->[0], 0, "$testname: disallowed: no warnings 'utf8': Returns 0");
+ is($ret_ref->[1], $expected_len, "$testname: disallowed: no warnings 'utf8': Returns expected length");
+ if (!is(scalar @warnings, 0, "$testname: disallowed: no warnings 'utf8': no warnings generated")) {
+ note "The warnings were: " . join(", ", @warnings);
+ }
+ }
+
+ # Test with CHECK_ONLY
+ undef @warnings;
+ $ret_ref = test_utf8n_to_uvuni($bytes, $length, $UTF8_CHECK_ONLY);
+ is($ret_ref->[0], 0, "$testname: CHECK_ONLY: Returns 0");
+ is($ret_ref->[1], -1, "$testname: CHECK_ONLY: returns expected length");
+ if (! is(scalar @warnings, 0, "$testname: CHECK_ONLY: no warnings generated")) {
+ note "The warnings were: " . join(", ", @warnings);
+ }
+
+ next if $allow_flags == 0; # Skip if can't allow this malformation
+
+ # Test when the malformation is allowed
+ undef @warnings;
+ $ret_ref = test_utf8n_to_uvuni($bytes, $length, $allow_flags);
+ is($ret_ref->[0], $allowed_uv, "$testname: allowed: Returns expected uv");
+ is($ret_ref->[1], $expected_len, "$testname: allowed: Returns expected length");
+ if (!is(scalar @warnings, 0, "$testname: allowed: no warnings generated"))
+ {
+ note "The warnings were: " . join(", ", @warnings);
+ }
+}
+
+my $FF_ret;
+
+use Unicode::UCD;
+my $has_quad = ($Unicode::UCD::MAX_CP > 0xFFFF_FFFF);
+if ($has_quad) {
+ no warnings qw{portable overflow};
+ $FF_ret = 0x1000000000;
+}
+else { # The above overflows unless a quad platform
+ $FF_ret = 0;
+}
+
+# Now test the cases where a legal code point is generated, but may or may not
+# be allowed/warned on.
+foreach my $test (
+ [ "surrogate", "\xed\xa4\x8d",
+ $UTF8_WARN_SURROGATE, $UTF8_DISALLOW_SURROGATE, 'surrogate', 0xD90D, 3,
+ qr/surrogate/
+ ],
+ [ "non_unicode", "\xf4\x90\x80\x80",
+ $UTF8_WARN_SUPER, $UTF8_DISALLOW_SUPER, 'non_unicode', 0x110000, 4,
+ qr/not Unicode/
+ ],
+ [ "non-character code point", "\xEF\xB7\x90",
+ $UTF8_WARN_NONCHAR, $UTF8_DISALLOW_NONCHAR, 'nonchar', 0xFDD0, 3,
+ qr/Unicode non-character.*is illegal for open interchange/
+ ],
+ [ "begins with FE", "\xfe\x82\x80\x80\x80\x80\x80",
+
+ # This code point is chosen so that it is representable in a UV on
+ # 32-bit machines, otherwise we would have to handle it like the FF
+ # ones
+ $UTF8_WARN_FE_FF, $UTF8_DISALLOW_FE_FF, 'utf8', 0x80000000, 7,
+ qr/Code point beginning with byte .* is not Unicode, and not portable/
+ ],
+ [ "begins with FF", "\xff\x80\x80\x80\x80\x80\x81\x80\x80\x80\x80\x80\x80",
+ $UTF8_WARN_FE_FF, $UTF8_DISALLOW_FE_FF, 'utf8', $FF_ret, 13,
+ qr/Code point beginning with byte .* is not Unicode, and not portable/
+ ],
+) {
+ my ($testname, $bytes, $warn_flags, $disallow_flags, $category, $allowed_uv, $expected_len, $message ) = @$test;
+
+ my $length = length $bytes;
+
+ # This is more complicated than the malformations tested earlier, as there
+ # 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 $warn_flag (0, $warn_flags) {
+ foreach my $disallow_flag (0, $disallow_flags) {
+
+ # On 32-bit machines, anything beginning with \xff is not
+ # representable, and would overflow even if we were to allow
+ # them in this test.
+ next if ! $has_quad
+ && ! $disallow_flag
+ && substr($bytes, 0, 1) eq "\xff";
+
+ no warnings 'utf8';
+ my $eval_warn = $warning eq 0 ? "no warnings" : "use warnings '$warning'";
+ my $this_name = "$testname: " . (($disallow_flag) ? 'disallowed' : '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_uvuni('$bytes', $length, $warn_flag|$disallow_flag)";
+ my $eval_text = "$eval_warn; \$ret_ref = test_utf8n_to_uvuni('$bytes', $length, $warn_flag|$disallow_flag)";
+ eval "$eval_text";
+ if (! ok ("$@ eq ''", "$this_name: eval succeeded")) {
+ note "\$!='$!'; eval'd=\"$eval_text\"";
+ next;
+ }
+ if ($disallow_flag) {
+ 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 ($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);
+ }
+ }
+ }
+ else {
+ if (!is(scalar @warnings, 0, "$this_name: No warnings generated"))
+ {
+ note "The warnings were: " . join(", ", @warnings);
+ }
+ }
+
+ if ($disallow_flag) {
+ undef @warnings;
+ $ret_ref = test_utf8n_to_uvuni($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);
+ }
+ }
+ }
+ }
+ }
+}
+
done_testing;
Very large code points (above 0x7FFF_FFFF) are considered more problematic than
the others that are above the Unicode legal maximum. There are several
-reasons: they do not fit into a 32-bit word, are not representable on EBCDIC
-platforms, and the original UTF-8 specification never went above
-this number (the current 0x10FFFF limit was imposed later). The UTF-8 encoding
-on ASCII platforms for these large code points begins with a byte containing
-0xFE or 0xFF. The UTF8_DISALLOW_FE_FF flag will cause them to be treated as
-malformations, while allowing smaller above-Unicode code points. (Of course
-UTF8_DISALLOW_SUPER will treat all above-Unicode code points, including these,
-as malformations.) Similarly, UTF8_WARN_FE_FF acts just like the other WARN
-flags, but applies just to these code points.
+reasons: they requre at least 32 bits to represent them on ASCII platforms, are
+not representable at all on EBCDIC platforms, and the original UTF-8
+specification never went above this number (the current 0x10FFFF limit was
+imposed later). (The smaller ones, those that fit into 32 bits, are
+representable by a UV on ASCII platforms, but not by an IV, which means that
+the number of operations that can be performed on them is quite restricted.)
+The UTF-8 encoding on ASCII platforms for these large code points begins with a
+byte containing 0xFE or 0xFF. The UTF8_DISALLOW_FE_FF flag will cause them to
+be treated as malformations, while allowing smaller above-Unicode code points.
+(Of course UTF8_DISALLOW_SUPER will treat all above-Unicode code points,
+including these, as malformations.) Similarly, UTF8_WARN_FE_FF acts just like
+the other WARN flags, but applies just to these code points.
All other code points corresponding to Unicode characters, including private
use and those yet to be assigned, are never considered malformed and never
{
dVAR;
const U8 * const s0 = s;
+ U8 overflow_byte = '\0'; /* Save byte in case of overflow */
U8 * send;
- UV uv = *s, ouv = 0;
- STRLEN len = 1;
- bool dowarn = ckWARN_d(WARN_UTF8);
- const UV startbyte = *s;
- STRLEN expectlen = 0;
- U32 warning = 0;
+ UV uv = *s;
+ STRLEN expectlen;
SV* sv = NULL;
+ UV outlier_ret = 0; /* return value when input is in error or problematic
+ */
+ UV pack_warn = 0; /* Save result of packWARN() for later */
+ bool unexpected_non_continuation = FALSE;
+ bool overflowed = FALSE;
- PERL_ARGS_ASSERT_UTF8N_TO_UVUNI;
+ const char* const malformed_text = "Malformed UTF-8 character";
-/* This list is a superset of the UTF8_ALLOW_XXX. */
+ PERL_ARGS_ASSERT_UTF8N_TO_UVUNI;
-#define UTF8_WARN_EMPTY 1
-#define UTF8_WARN_CONTINUATION 2
-#define UTF8_WARN_NON_CONTINUATION 3
-#define UTF8_WARN_SHORT 4
-#define UTF8_WARN_OVERFLOW 5
-#define UTF8_WARN_LONG 6
+ /* The order of malformation tests here is important. We should consume as
+ * few bytes as possible in order to not skip any valid character. This is
+ * required by the Unicode Standard (section 3.9 of Unicode 6.0); see also
+ * http://unicode.org/reports/tr36 for more discussion as to why. For
+ * example, once we've done a UTF8SKIP, we can tell the expected number of
+ * bytes, and could fail right off the bat if the input parameters indicate
+ * that there are too few available. But it could be that just that first
+ * byte is garbled, and the intended character occupies fewer bytes. If we
+ * blindly assumed that the first byte is correct, and skipped based on
+ * that number, we could skip over a valid input character. So instead, we
+ * always examine the sequence byte-by-byte.
+ *
+ * We also should not consume too few bytes, otherwise someone could inject
+ * things. For example, an input could be deliberately designed to
+ * overflow, and if this code bailed out immediately upon discovering that,
+ * returning to the caller *retlen pointing to the very next byte (one
+ * which is actually part of of the overflowing sequence), that could look
+ * legitimate to the caller, which could discard the initial partial
+ * sequence and process the rest, inappropriately */
+
+ /* Zero length strings, if allowed, of necessity are zero */
+ if (curlen == 0) {
+ if (retlen) {
+ *retlen = 0;
+ }
- if (curlen == 0 &&
- !(flags & UTF8_ALLOW_EMPTY)) {
- warning = UTF8_WARN_EMPTY;
+ if (flags & UTF8_ALLOW_EMPTY) {
+ return 0;
+ }
+ if (! (flags & UTF8_CHECK_ONLY)) {
+ sv = sv_2mortal(Perl_newSVpvf(aTHX_ "%s (empty string)", malformed_text));
+ }
goto malformed;
}
+ expectlen = UTF8SKIP(s);
+
+ /* A well-formed UTF-8 character, as the vast majority of calls to this
+ * function will be for, has this expected length. For efficiency, set
+ * things up here to return it. It will be overriden only in those rare
+ * cases where a malformation is found */
+ if (retlen) {
+ *retlen = expectlen;
+ }
+
+ /* An invariant is trivially well-formed */
if (UTF8_IS_INVARIANT(uv)) {
- if (retlen)
- *retlen = 1;
return (UV) (NATIVE_TO_UTF(*s));
}
- if (UTF8_IS_CONTINUATION(uv) &&
- !(flags & UTF8_ALLOW_CONTINUATION)) {
- warning = UTF8_WARN_CONTINUATION;
- goto malformed;
- }
+ /* A continuation character can't start a valid sequence */
+ if (UTF8_IS_CONTINUATION(uv)) {
+ if (flags & UTF8_ALLOW_CONTINUATION) {
+ if (retlen) {
+ *retlen = 1;
+ }
+ return UNICODE_REPLACEMENT;
+ }
- if (UTF8_IS_START(uv) && curlen > 1 && !UTF8_IS_CONTINUATION(s[1]) &&
- !(flags & UTF8_ALLOW_NON_CONTINUATION)) {
- warning = UTF8_WARN_NON_CONTINUATION;
+ if (! (flags & UTF8_CHECK_ONLY)) {
+ sv = sv_2mortal(Perl_newSVpvf(aTHX_ "%s (unexpected continuation byte 0x%02x, with no preceding start byte)", malformed_text, *s0));
+ }
+ curlen = 1;
goto malformed;
}
#ifdef EBCDIC
uv = NATIVE_TO_UTF(uv);
-#else
- if (uv == 0xfe || uv == 0xff) {
- if (flags & (UTF8_WARN_SUPER|UTF8_WARN_FE_FF)) {
- sv = sv_2mortal(Perl_newSVpvf(aTHX_ "Code point beginning with byte 0x%02"UVXf" is not Unicode, and not portable", uv));
- flags &= ~UTF8_WARN_SUPER; /* Only warn once on this problem */
- }
- if (flags & (UTF8_DISALLOW_SUPER|UTF8_DISALLOW_FE_FF)) {
- goto malformed;
- }
- }
#endif
- len = UTF8SKIP(s);
- uv &= UTF_START_MASK(len);
-
- if (retlen)
- *retlen = len;
+ /* Here is not a continuation byte, nor an invariant. The only thing left
+ * is a start byte (possibly for an overlong) */
- expectlen = len;
-
- if ((curlen < expectlen) &&
- !(flags & UTF8_ALLOW_SHORT)) {
- warning = UTF8_WARN_SHORT;
- goto malformed;
- }
+ /* Remove the leading bits that indicate the number of bytes in the
+ * character's whole UTF-8 sequence, leaving just the bits that are part of
+ * the value */
+ uv &= UTF_START_MASK(expectlen);
+ /* Now, loop through the remaining bytes in the character's sequence,
+ * accumulating each into the working value as we go. Be sure to not look
+ * past the end of the input string */
send = (U8*) s0 + ((expectlen <= curlen) ? expectlen : curlen);
- ouv = uv; /* ouv is the value from the previous iteration */
-
- for (++s; s < send; s++) {
- if (!UTF8_IS_CONTINUATION(*s) &&
- !(flags & UTF8_ALLOW_NON_CONTINUATION)) {
- s--;
- warning = UTF8_WARN_NON_CONTINUATION;
- goto malformed;
- }
- else
+ for (s = s0 + 1; s < send; s++) {
+ if (UTF8_IS_CONTINUATION(*s)) {
+#ifndef EBCDIC /* Can't overflow in EBCDIC */
+ if (uv & UTF_ACCUMULATION_OVERFLOW_MASK) {
+
+ /* The original implementors viewed this malformation as more
+ * serious than the others (though I, khw, don't understand
+ * why, since other malformations also give very very wrong
+ * results), so there is no way to turn off checking for it.
+ * Set a flag, but keep going in the loop, so that we absorb
+ * the rest of the bytes that comprise the character. */
+ overflowed = TRUE;
+ overflow_byte = *s; /* Save for warning message's use */
+ }
+#endif
uv = UTF8_ACCUMULATE(uv, *s);
- if (!(uv > ouv)) { /* If the value didn't grow from the previous
- iteration, something is horribly wrong */
- /* These cannot be allowed. */
- if (uv == ouv) {
- if (expectlen != 13 && !(flags & UTF8_ALLOW_LONG)) {
- warning = UTF8_WARN_LONG;
- goto malformed;
+ }
+ else {
+ /* Here, found a non-continuation before processing all expected
+ * bytes. This byte begins a new character, so quit, even if
+ * allowing this malformation. */
+ unexpected_non_continuation = TRUE;
+ break;
+ }
+ } /* End of loop through the character's bytes */
+
+ /* Save how many bytes were actually in the character */
+ curlen = s - s0;
+
+ /* The loop above finds two types of malformations: non-continuation and/or
+ * overflow. The non-continuation malformation is really a too-short
+ * malformation, as it means that the current character ended before it was
+ * expected to (being terminated prematurely by the beginning of the next
+ * character, whereas in the too-short malformation there just are too few
+ * bytes available to hold the character. In both cases, the check below
+ * that we have found the expected number of bytes would fail if executed.)
+ * Thus the non-continuation malformation is really unnecessary, being a
+ * subset of the too-short malformation. But there may be existing
+ * applications that are expecting the non-continuation type, so we retain
+ * it, and return it in preference to the too-short malformation. (If this
+ * code were being written from scratch, the two types might be collapsed
+ * into one.) I, khw, am also giving priority to returning the
+ * non-continuation and too-short malformations over overflow when multiple
+ * ones are present. I don't know of any real reason to prefer one over
+ * the other, except that it seems to me that multiple-byte errors trumps
+ * errors from a single byte */
+ if (unexpected_non_continuation) {
+ if (!(flags & UTF8_ALLOW_NON_CONTINUATION)) {
+ if (! (flags & UTF8_CHECK_ONLY)) {
+ if (curlen == 1) {
+ sv = sv_2mortal(Perl_newSVpvf(aTHX_ "%s (unexpected non-continuation byte 0x%02x, immediately after start byte 0x%02x)", malformed_text, *s, *s0));
+ }
+ else {
+ sv = sv_2mortal(Perl_newSVpvf(aTHX_ "%s (unexpected non-continuation byte 0x%02x, %d bytes after start byte 0x%02x, expected %d bytes)", malformed_text, *s, (int) curlen, *s0, (int)expectlen));
}
}
- else { /* uv < ouv */
- /* This cannot be allowed. */
- warning = UTF8_WARN_OVERFLOW;
- goto malformed;
+ goto malformed;
+ }
+ uv = UNICODE_REPLACEMENT;
+ if (retlen) {
+ *retlen = curlen;
+ }
+ }
+ else if (curlen < expectlen) {
+ if (! (flags & UTF8_ALLOW_SHORT)) {
+ if (! (flags & UTF8_CHECK_ONLY)) {
+ sv = sv_2mortal(Perl_newSVpvf(aTHX_ "%s (%d byte%s, need %d, after start byte 0x%02x)", malformed_text, (int)curlen, curlen == 1 ? "" : "s", (int)expectlen, *s0));
}
+ goto malformed;
}
- ouv = uv;
+ uv = UNICODE_REPLACEMENT;
+ if (retlen) {
+ *retlen = curlen;
+ }
+ }
+
+#ifndef EBCDIC /* EBCDIC allows FE, FF, can't overflow */
+ else if ((*s0 & 0xFE) == 0xFE /* matches FE or FF */
+ && (flags & (UTF8_WARN_FE_FF|UTF8_DISALLOW_FE_FF)))
+ {
+ /* By adding UTF8_CHECK_ONLY to the test, we avoid unnecessary
+ * generation of the sv, since no warnings are raised under CHECK */
+ if ((flags & (UTF8_WARN_FE_FF|UTF8_CHECK_ONLY)) == UTF8_WARN_FE_FF
+ && ckWARN_d(WARN_UTF8))
+ {
+ sv = sv_2mortal(Perl_newSVpvf(aTHX_ "%s Code point beginning with byte 0x%02X is not Unicode, and not portable", malformed_text, *s0));
+ pack_warn = packWARN(WARN_UTF8);
+ }
+ if (flags & UTF8_DISALLOW_FE_FF) {
+ goto malformed;
+ }
+ }
+ else if (overflowed) {
+
+ /* If the first byte is FF, it will overflow a 32-bit word. If the
+ * first byte is FE, it will overflow a signed 32-bit word. The
+ * above preserves backward compatibility, since its message was used
+ * in earlier versions of this code in preference to overflow */
+ sv = sv_2mortal(Perl_newSVpvf(aTHX_ "%s (overflow at byte 0x%02x, after start byte 0x%02x)", malformed_text, overflow_byte, *s0));
+ goto malformed;
}
+#endif
- if ((expectlen > (STRLEN)UNISKIP(uv)) && !(flags & UTF8_ALLOW_LONG)) {
- warning = UTF8_WARN_LONG;
+ else if (expectlen > (STRLEN)UNISKIP(uv) && ! (flags & UTF8_ALLOW_LONG)) {
+ /* The overlong malformation has lower precedence than the others.
+ * Note that if this malformation is allowed, we return the actual
+ * value, instead of the replacement character. This is because this
+ * value is actually well-defined. */
+ if (! (flags & UTF8_CHECK_ONLY)) {
+ sv = sv_2mortal(Perl_newSVpvf(aTHX_ "%s (%d byte%s, need %d, after start byte 0x%02x)", malformed_text, (int)expectlen, expectlen == 1 ? "": "s", UNISKIP(uv), *s0));
+ }
goto malformed;
- } else if (flags & (UTF8_DISALLOW_ILLEGAL_INTERCHANGE|UTF8_WARN_ILLEGAL_INTERCHANGE)) {
+ }
+
+ /* Here, the input is considered to be well-formed , but 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
+ |UTF8_WARN_ILLEGAL_INTERCHANGE)))
+ {
if (UNICODE_IS_SURROGATE(uv)) {
- if ((flags & (UTF8_WARN_SURROGATE|UTF8_CHECK_ONLY)) == UTF8_WARN_SURROGATE) {
+ if ((flags & (UTF8_WARN_SURROGATE|UTF8_CHECK_ONLY)) == UTF8_WARN_SURROGATE
+ && ckWARN2_d(WARN_UTF8, WARN_SURROGATE))
+ {
sv = sv_2mortal(Perl_newSVpvf(aTHX_ "UTF-16 surrogate U+%04"UVXf"", uv));
+ pack_warn = packWARN2(WARN_UTF8, WARN_SURROGATE);
}
if (flags & UTF8_DISALLOW_SURROGATE) {
goto disallowed;
}
}
else if (UNICODE_IS_NONCHAR(uv)) {
- if ((flags & (UTF8_WARN_NONCHAR|UTF8_CHECK_ONLY)) == UTF8_WARN_NONCHAR ) {
+ if ((flags & (UTF8_WARN_NONCHAR|UTF8_CHECK_ONLY)) == UTF8_WARN_NONCHAR
+ && ckWARN2_d(WARN_UTF8, 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);
}
if (flags & UTF8_DISALLOW_NONCHAR) {
goto disallowed;
}
}
else if ((uv > PERL_UNICODE_MAX)) {
- if ((flags & (UTF8_WARN_SUPER|UTF8_CHECK_ONLY)) == UTF8_WARN_SUPER) {
+ if ((flags & (UTF8_WARN_SUPER|UTF8_CHECK_ONLY)) == UTF8_WARN_SUPER
+ && ckWARN2_d(WARN_UTF8, 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);
}
if (flags & UTF8_DISALLOW_SUPER) {
goto disallowed;
}
}
+ if (sv) {
+ outlier_ret = uv;
+ goto do_warn;
+ }
+
/* Here, this is not considered a malformed character, so drop through
* to return it */
}
return uv;
-disallowed: /* Is disallowed, but otherwise not malformed. 'sv' will have been
- set if there is to be a warning. */
- if (!sv) {
- dowarn = 0;
- }
+ /* There are three cases which get to beyond this point. In all 3 cases:
+ * <sv> if not null points to a string to print as a warning.
+ * <curlen> is what <*retlen> should be set to if UTF8_CHECK_ONLY isn't
+ * set.
+ * <outlier_ret> is what return value to use if UTF8_CHECK_ONLY isn't set.
+ * This is done by initializing it to 0, and changing it only
+ * for case 1).
+ * The 3 cases are:
+ * 1) The input is valid but problematic, and to be warned about. The
+ * return value is the resultant code point; <*retlen> is set to
+ * <curlen>, the number of bytes that comprise the code point.
+ * <pack_warn> contains the result of packWARN() for the warning
+ * types. The entry point for this case is the label <do_warn>;
+ * 2) The input is a valid code point but disallowed by the parameters to
+ * this function. The return value is 0. If UTF8_CHECK_ONLY is set,
+ * <*relen> is -1; otherwise it is <curlen>, the number of bytes that
+ * comprise the code point. <pack_warn> contains the result of
+ * packWARN() for the warning types. The entry point for this case is
+ * the label <disallowed>.
+ * 3) The input is malformed. The return value is 0. If UTF8_CHECK_ONLY
+ * is set, <*relen> is -1; otherwise it is <curlen>, the number of
+ * bytes that comprise the malformation. All such malformations are
+ * assumed to be warning type <utf8>. The entry point for this case
+ * is the label <malformed>.
+ */
malformed:
+ if (sv && ckWARN_d(WARN_UTF8)) {
+ pack_warn = packWARN(WARN_UTF8);
+ }
+
+disallowed:
+
if (flags & UTF8_CHECK_ONLY) {
if (retlen)
*retlen = ((STRLEN) -1);
return 0;
}
- if (dowarn) {
- if (! sv) {
- sv = newSVpvs_flags("Malformed UTF-8 character ", SVs_TEMP);
- }
+do_warn:
- switch (warning) {
- case 0: /* Intentionally empty. */ break;
- case UTF8_WARN_EMPTY:
- sv_catpvs(sv, "(empty string)");
- break;
- case UTF8_WARN_CONTINUATION:
- Perl_sv_catpvf(aTHX_ sv, "(unexpected continuation byte 0x%02"UVxf", with no preceding start byte)", uv);
- break;
- case UTF8_WARN_NON_CONTINUATION:
- if (s == s0)
- Perl_sv_catpvf(aTHX_ sv, "(unexpected non-continuation byte 0x%02"UVxf", immediately after start byte 0x%02"UVxf")",
- (UV)s[1], startbyte);
- else {
- const int len = (int)(s-s0);
- Perl_sv_catpvf(aTHX_ sv, "(unexpected non-continuation byte 0x%02"UVxf", %d byte%s after start byte 0x%02"UVxf", expected %d bytes)",
- (UV)s[1], len, len > 1 ? "s" : "", startbyte, (int)expectlen);
- }
-
- break;
- case UTF8_WARN_SHORT:
- Perl_sv_catpvf(aTHX_ sv, "(%d byte%s, need %d, after start byte 0x%02"UVxf")",
- (int)curlen, curlen == 1 ? "" : "s", (int)expectlen, startbyte);
- expectlen = curlen; /* distance for caller to skip */
- break;
- case UTF8_WARN_OVERFLOW:
- Perl_sv_catpvf(aTHX_ sv, "(overflow at 0x%"UVxf", byte 0x%02x, after start byte 0x%02"UVxf")",
- ouv, *s, startbyte);
- break;
- case UTF8_WARN_LONG:
- Perl_sv_catpvf(aTHX_ sv, "(%d byte%s, need %d, after start byte 0x%02"UVxf")",
- (int)expectlen, expectlen == 1 ? "": "s", UNISKIP(uv), startbyte);
- break;
- default:
- sv_catpvs(sv, "(unknown reason)");
- break;
- }
-
- if (sv) {
- const char * const s = SvPVX_const(sv);
+ if (pack_warn) { /* <pack_warn> was initialized to 0, and changed only
+ if warnings are to be raised. */
+ const char * const string = SvPVX_const(sv);
if (PL_op)
- Perl_warner(aTHX_ packWARN(WARN_UTF8),
- "%s in %s", s, OP_DESC(PL_op));
+ Perl_warner(aTHX_ pack_warn, "%s in %s", string, OP_DESC(PL_op));
else
- Perl_warner(aTHX_ packWARN(WARN_UTF8), "%s", s);
- }
+ Perl_warner(aTHX_ pack_warn, "%s", string);
}
- if (retlen)
- *retlen = expectlen ? expectlen : len;
+ if (retlen) {
+ *retlen = curlen;
+ }
- return 0;
+ return outlier_ret;
}
/*
projects / platform / upstream / perl.git / commitdiff