static const char unees[] =
"Malformed UTF-8 character (unexpected end of string)";
static const char cp_above_legal_max[] =
- "Use of code point 0x%" UVXf " is deprecated; the permissible max is 0x%" UVXf ". This will be fatal in Perl 5.28";
+ "Use of code point 0x%" UVXf " is not allowed; "
+ "the permissible max is 0x%" UVXf;
#define MAX_NON_DEPRECATED_CP ((UV) (IV_MAX))
* performance hit on these high EBCDIC code points. */
if (UNLIKELY(UNICODE_IS_SUPER(uv))) {
- if ( UNLIKELY(uv > MAX_NON_DEPRECATED_CP)
- && ckWARN_d(WARN_DEPRECATED))
- {
- Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
- cp_above_legal_max, uv, MAX_NON_DEPRECATED_CP);
+ if (UNLIKELY(uv > MAX_NON_DEPRECATED_CP)) {
+ Perl_croak(aTHX_ cp_above_legal_max, uv, MAX_NON_DEPRECATED_CP);
}
if ( (flags & UNICODE_WARN_SUPER)
|| ( UNICODE_IS_ABOVE_31_BIT(uv)
return UTF8SKIP(s);
}
-STATIC char *
-S__byte_dump_string(pTHX_ const U8 * s, const STRLEN len)
+char *
+Perl__byte_dump_string(pTHX_ const U8 * s, const STRLEN len, const bool format)
{
/* Returns a mortalized C string that is a displayable copy of the 'len'
- * bytes starting at 's', each in a \xXY format. */
+ * bytes starting at 's'. 'format' gives how to display each byte.
+ * Currently, there are only two formats, so it is currently a bool:
+ * 0 \xab
+ * 1 ab (that is a space between two hex digit bytes)
+ */
const STRLEN output_len = 4 * len + 1; /* 4 bytes per each input, plus a
trailing NUL */
const unsigned high_nibble = (*s & 0xF0) >> 4;
const unsigned low_nibble = (*s & 0x0F);
- *d++ = '\\';
- *d++ = 'x';
+ if (format) {
+ *d++ = ' ';
+ }
+ else {
+ *d++ = '\\';
+ *d++ = 'x';
+ }
if (high_nibble < 10) {
*d++ = high_nibble + '0';
return Perl_form(aTHX_ "%s: %s (unexpected non-continuation byte 0x%02x,"
" %s after start byte 0x%02x; need %d bytes, got %d)",
malformed_text,
- _byte_dump_string(s, print_len),
+ _byte_dump_string(s, print_len, 0),
*(s + non_cont_byte_pos),
where,
*s,
U8 * adjusted_s0 = (U8 *) s0;
U8 * adjusted_send = NULL; /* (Initialized to silence compilers' wrong
warning) */
+ U8 temp_char_buf[UTF8_MAXBYTES + 1]; /* Used to avoid a Newx in this
+ routine; see [perl #130921] */
UV uv_so_far = 0; /* (Initialized to silence compilers' wrong warning) */
PERL_ARGS_ASSERT_UTF8N_TO_UVCHR_ERROR;
/* Save how many bytes were actually in the character */
curlen = s - s0;
- /* A convenience macro that matches either of the too-short conditions. */
-# define UTF8_GOT_TOO_SHORT (UTF8_GOT_SHORT|UTF8_GOT_NON_CONTINUATION)
-
- if (UNLIKELY(possible_problems & UTF8_GOT_TOO_SHORT)) {
- uv_so_far = uv;
- uv = UNICODE_REPLACEMENT;
- }
-
/* Note that there are two types of too-short malformation. One is when
* there is actual wrong data before the normal termination of the
* sequence. The other is that the sequence wasn't complete before the end
* This means that we were passed data for a partial character, but it is
* valid as far as we saw. The other is definitely invalid. This
* distinction could be important to a caller, so the two types are kept
- * separate. */
+ * separate.
+ *
+ * A convenience macro that matches either of the too-short conditions. */
+# define UTF8_GOT_TOO_SHORT (UTF8_GOT_SHORT|UTF8_GOT_NON_CONTINUATION)
+
+ if (UNLIKELY(possible_problems & UTF8_GOT_TOO_SHORT)) {
+ uv_so_far = uv;
+ uv = UNICODE_REPLACEMENT;
+ }
/* Check for overflow */
if (UNLIKELY(does_utf8_overflow(s0, send))) {
I8_TO_NATIVE_UTF8(UTF_CONTINUATION_MARK));
}
- Newx(adjusted_s0, OFFUNISKIP(min_uv) + 1, U8);
- SAVEFREEPV((U8 *) adjusted_s0); /* Needed because we may not get
- to free it ourselves if
- warnings are made fatal */
+ adjusted_s0 = temp_char_buf;
adjusted_send = uvoffuni_to_utf8_flags(adjusted_s0, min_uv, 0);
}
}
if (pack_warn) {
message = Perl_form(aTHX_ "%s: %s (overflows)",
malformed_text,
- _byte_dump_string(s0, send - s0));
+ _byte_dump_string(s0, send - s0, 0));
}
}
}
"%s: %s (unexpected continuation byte 0x%02x,"
" with no preceding start byte)",
malformed_text,
- _byte_dump_string(s0, 1), *s0);
+ _byte_dump_string(s0, 1, 0), *s0);
}
}
}
message = Perl_form(aTHX_
"%s: %s (too short; %d byte%s available, need %d)",
malformed_text,
- _byte_dump_string(s0, send - s0),
+ _byte_dump_string(s0, send - s0, 0),
(int)avail_len,
avail_len == 1 ? "" : "s",
(int)expectlen);
" should be represented with a"
" different, shorter sequence)",
malformed_text,
- _byte_dump_string(s0, send - s0),
- _byte_dump_string(s0, curlen));
+ _byte_dump_string(s0, send - s0, 0),
+ _byte_dump_string(s0, curlen, 0));
}
else {
U8 tmpbuf[UTF8_MAXBYTES+1];
"%s: %s (overlong; instead use %s to represent"
" U+%0*" UVXf ")",
malformed_text,
- _byte_dump_string(s0, send - s0),
- _byte_dump_string(tmpbuf, e - tmpbuf),
+ _byte_dump_string(s0, send - s0, 0),
+ _byte_dump_string(tmpbuf, e - tmpbuf, 0),
((uv < 256) ? 2 : 4), /* Field width of 2 for
small code points */
uv);
message = Perl_form(aTHX_
"UTF-16 surrogate (any UTF-8 sequence that"
" starts with \"%s\" is for a surrogate)",
- _byte_dump_string(s0, curlen));
+ _byte_dump_string(s0, curlen, 0));
}
else {
message = Perl_form(aTHX_
"Any UTF-8 sequence that starts with"
" \"%s\" is for a non-Unicode code point,"
" may not be portable",
- _byte_dump_string(s0, curlen));
+ _byte_dump_string(s0, curlen, 0));
}
else {
message = Perl_form(aTHX_
"Any UTF-8 sequence that starts with"
" \"%s\" is for a non-Unicode code"
" point, and is not portable",
- _byte_dump_string(s0, curlen));
+ _byte_dump_string(s0, curlen, 0));
}
else {
message = Perl_form(aTHX_
* where 'uv' is not valid. */
if ( ! (orig_problems
& (UTF8_GOT_TOO_SHORT|UTF8_GOT_OVERFLOW))
- && UNLIKELY(uv > MAX_NON_DEPRECATED_CP)
- && ckWARN_d(WARN_DEPRECATED))
- {
- message = Perl_form(aTHX_ cp_above_legal_max,
- uv, MAX_NON_DEPRECATED_CP);
- pack_warn = packWARN(WARN_DEPRECATED);
+ && UNLIKELY(uv > MAX_NON_DEPRECATED_CP)) {
+ Perl_croak(aTHX_ cp_above_legal_max, uv,
+ MAX_NON_DEPRECATED_CP);
}
}
else if (possible_problems & UTF8_GOT_NONCHAR) {
UV
Perl_utf8_to_uvchr_buf(pTHX_ const U8 *s, const U8 *send, STRLEN *retlen)
{
+ PERL_ARGS_ASSERT_UTF8_TO_UVCHR_BUF;
+
assert(s < send);
return utf8n_to_uvchr(s, send - s, retlen,
/*
=for apidoc bytes_from_utf8
-Converts a string C<s> of length C<len> from UTF-8 into native byte encoding.
-Unlike L</utf8_to_bytes> but like L</bytes_to_utf8>, returns a pointer to
-the newly-created string, and updates C<len> to contain the new
-length. Returns the original string if no conversion occurs, C<len>
-is unchanged. Do nothing if C<is_utf8> points to 0. Sets C<is_utf8> to
-0 if C<s> is converted or consisted entirely of characters that are invariant
-in UTF-8 (i.e., US-ASCII on non-EBCDIC machines).
+Converts a potentially UTF-8 encoded string C<s> of length C<len> into native
+byte encoding. On input, the boolean C<*is_utf8> gives whether or not C<s> is
+actually encoded in UTF-8.
+
+Unlike L</utf8_to_bytes> but like L</bytes_to_utf8>, this is non-destructive of
+the input string.
+
+Do nothing if C<*is_utf8> is 0, or if there are code points in the string
+not expressible in native byte encoding. In these cases, C<*is_utf8> and
+C<*len> are unchanged, and the return value is the original C<s>.
+
+Otherwise, C<*is_utf8> is set to 0, and the return value is a pointer to a
+newly created string containing a downgraded copy of C<s>, and whose length is
+returned in C<*len>, updated.
=cut
*/
U8 *d;
const U8 *start = s;
const U8 *send;
- I32 count = 0;
+ Size_t count = 0;
PERL_ARGS_ASSERT_BYTES_FROM_UTF8;
PERL_UNUSED_CONTEXT;
return is_utf8_common(p, &PL_utf8_mark, "IsM", NULL);
}
-/*
-=for apidoc to_utf8_case
-
-Instead use the appropriate one of L</toUPPER_utf8_safe>,
-L</toTITLE_utf8_safe>,
-L</toLOWER_utf8_safe>,
-or L</toFOLD_utf8_safe>.
-
-This function will be removed in Perl v5.28.
-
-C<p> contains the pointer to the UTF-8 string encoding
-the character that is being converted. This routine assumes that the character
-at C<p> is well-formed.
-
-C<ustrp> is a pointer to the character buffer to put the
-conversion result to. C<lenp> is a pointer to the length
-of the result.
-
-C<swashp> is a pointer to the swash to use.
-
-Both the special and normal mappings are stored in F<lib/unicore/To/Foo.pl>,
-and loaded by C<SWASHNEW>, using F<lib/utf8_heavy.pl>. C<special> (usually,
-but not always, a multicharacter mapping), is tried first.
-
-C<special> is a string, normally C<NULL> or C<"">. C<NULL> means to not use
-any special mappings; C<""> means to use the special mappings. Values other
-than these two are treated as the name of the hash containing the special
-mappings, like C<"utf8::ToSpecLower">.
-
-C<normal> is a string like C<"ToLower"> which means the swash
-C<%utf8::ToLower>.
-
-Code points above the platform's C<IV_MAX> will raise a deprecation warning,
-unless those are turned off.
-
-=cut */
-
-UV
-Perl_to_utf8_case(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp,
- SV **swashp, const char *normal, const char *special)
-{
- STRLEN len_cp;
- UV cp;
- const U8 * e = p + UTF8SKIP(p);
-
- PERL_ARGS_ASSERT_TO_UTF8_CASE;
-
- cp = utf8n_to_uvchr(p, e - p, &len_cp, UTF8_CHECK_ONLY);
- if (len_cp == (STRLEN) -1) {
- _force_out_malformed_utf8_message(p, e,
- _UTF8_NO_CONFIDENCE_IN_CURLEN, 1 /* Die */ );
- }
-
- return _to_utf8_case(cp, p, ustrp, lenp, swashp, normal, special);
-}
-
/* change namve uv1 to 'from' */
STATIC UV
S__to_utf8_case(pTHX_ const UV uv1, const U8 *p, U8* ustrp, STRLEN *lenp,
}
if (UNLIKELY(UNICODE_IS_SUPER(uv1))) {
- if ( UNLIKELY(uv1 > MAX_NON_DEPRECATED_CP)
- && ckWARN_d(WARN_DEPRECATED))
- {
- Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
- cp_above_legal_max, uv1, MAX_NON_DEPRECATED_CP);
+ if (UNLIKELY(uv1 > MAX_NON_DEPRECATED_CP)) {
+ Perl_croak(aTHX_ cp_above_legal_max, uv1,
+ MAX_NON_DEPRECATED_CP);
}
if (ckWARN_d(WARN_NON_UNICODE)) {
const char* desc = (PL_op) ? OP_DESC(PL_op) : normal;
while ((from_list = (AV *) hv_iternextsv(specials_inverse,
&char_to, &to_len)))
{
- if (av_tindex_nomg(from_list) > 0) {
+ if (av_tindex_skip_len_mg(from_list) > 0) {
SSize_t i;
/* We iterate over all combinations of i,j to place each code
* point on each list */
- for (i = 0; i <= av_tindex_nomg(from_list); i++) {
+ for (i = 0; i <= av_tindex_skip_len_mg(from_list); i++) {
SSize_t j;
AV* i_list = newAV();
SV** entryp = av_fetch(from_list, i, FALSE);
}
/* For DEBUG_U: UV u = valid_utf8_to_uvchr((U8*) SvPVX(*entryp), 0);*/
- for (j = 0; j <= av_tindex_nomg(from_list); j++) {
+ for (j = 0; j <= av_tindex_skip_len_mg(from_list); j++) {
entryp = av_fetch(from_list, j, FALSE);
if (entryp == NULL) {
Perl_croak(aTHX_ "panic: av_fetch() unexpectedly failed");
/* Look through list to see if this inverse mapping already is
* listed, or if there is a mapping to itself already */
- for (i = 0; i <= av_tindex_nomg(list); i++) {
+ for (i = 0; i <= av_tindex_skip_len_mg(list); i++) {
SV** entryp = av_fetch(list, i, FALSE);
SV* entry;
UV uv;
https://perl5.git.perl.org / perl5.git / blobdiff