/* utf8.c
*
- * Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006,
+ * Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
* by Larry Wall and others
*
* You may distribute under the terms of either the GNU General Public
*/
/*
- * 'What a fix!' said Sam. 'That's the one place in all the lands we've ever
- * heard of that we don't want to see any closer; and that's the one place
- * we're trying to get to! And that's just where we can't get, nohow.'
+ * 'What a fix!' said Sam. 'That's the one place in all the lands we've ever
+ * heard of that we don't want to see any closer; and that's the one place
+ * we're trying to get to! And that's just where we can't get, nohow.'
+ *
+ * [p.603 of _The Lord of the Rings_, IV/I: "The Taming of Sméagol"]
*
* 'Well do I understand your speech,' he answered in the same language;
* 'yet few strangers do so. Why then do you not speak in the Common Tongue,
- * as is the custom in the West, if you wish to be answered?'
+ * as is the custom in the West, if you wish to be answered?'
+ * --Gandalf, addressing Théoden's door wardens
+ *
+ * [p.508 of _The Lord of the Rings_, III/vi: "The King of the Golden Hall"]
*
* ...the travellers perceived that the floor was paved with stones of many
* hues; branching runes and strange devices intertwined beneath their feet.
+ *
+ * [p.512 of _The Lord of the Rings_, III/vi: "The King of the Golden Hall"]
*/
#include "EXTERN.h"
characters in the ASCII range are unmodified, and a zero byte never appears
within non-zero characters.
-=for apidoc A|U8 *|uvuni_to_utf8_flags|U8 *d|UV uv|UV flags
+=cut
+*/
+
+/*
+=for apidoc is_ascii_string
+
+Returns true if first C<len> bytes of the given string are ASCII (i.e. none
+of them even raise the question of UTF-8-ness).
+
+See also is_utf8_string(), is_utf8_string_loclen(), and is_utf8_string_loc().
+
+=cut
+*/
+
+bool
+Perl_is_ascii_string(const U8 *s, STRLEN len)
+{
+ const U8* const send = s + (len ? len : strlen((const char *)s));
+ const U8* x = s;
+
+ PERL_ARGS_ASSERT_IS_ASCII_STRING;
+
+ for (; x < send; ++x) {
+ if (!UTF8_IS_INVARIANT(*x))
+ break;
+ }
+
+ return x == send;
+}
+
+/*
+=for apidoc uvuni_to_utf8_flags
Adds the UTF-8 representation of the Unicode codepoint C<uv> to the end
of the string C<d>; C<d> should be have at least C<UTF8_MAXBYTES+1> free
U8 *
Perl_uvuni_to_utf8_flags(pTHX_ U8 *d, UV uv, UV flags)
{
+ PERL_ARGS_ASSERT_UVUNI_TO_UTF8_FLAGS;
+
if (ckWARN(WARN_UTF8)) {
if (UNICODE_IS_SURROGATE(uv) &&
!(flags & UNICODE_ALLOW_SURROGATE))
STRLEN slen;
UV uv, ouv;
+ PERL_ARGS_ASSERT_IS_UTF8_CHAR_SLOW;
+
if (UTF8_IS_INVARIANT(u))
return 1;
}
/*
-=for apidoc A|STRLEN|is_utf8_char|const U8 *s
+=for apidoc is_utf8_char
Tests if some arbitrary number of bytes begins in a valid UTF-8
-character. Note that an INVARIANT (i.e. ASCII) character is a valid
-UTF-8 character. The actual number of bytes in the UTF-8 character
-will be returned if it is valid, otherwise 0.
+character. Note that an INVARIANT (i.e. ASCII on non-EBCDIC machines)
+character is a valid UTF-8 character. The actual number of bytes in the UTF-8
+character will be returned if it is valid, otherwise 0.
=cut */
STRLEN
-Perl_is_utf8_char(pTHX_ const U8 *s)
+Perl_is_utf8_char(const U8 *s)
{
const STRLEN len = UTF8SKIP(s);
- PERL_UNUSED_CONTEXT;
+
+ PERL_ARGS_ASSERT_IS_UTF8_CHAR;
#ifdef IS_UTF8_CHAR
if (IS_UTF8_CHAR_FAST(len))
return IS_UTF8_CHAR(s, len) ? len : 0;
return is_utf8_char_slow(s, len);
}
+
/*
-=for apidoc A|bool|is_utf8_string|const U8 *s|STRLEN len
+=for apidoc is_utf8_string
Returns true if first C<len> bytes of the given string form a valid
UTF-8 string, false otherwise. Note that 'a valid UTF-8 string' does
not mean 'a string that contains code points above 0x7F encoded in UTF-8'
because a valid ASCII string is a valid UTF-8 string.
-See also is_utf8_string_loclen() and is_utf8_string_loc().
+See also is_ascii_string(), is_utf8_string_loclen(), and is_utf8_string_loc().
=cut
*/
bool
-Perl_is_utf8_string(pTHX_ const U8 *s, STRLEN len)
+Perl_is_utf8_string(const U8 *s, STRLEN len)
{
const U8* const send = s + (len ? len : strlen((const char *)s));
const U8* x = s;
- PERL_UNUSED_CONTEXT;
+ PERL_ARGS_ASSERT_IS_UTF8_STRING;
while (x < send) {
STRLEN c;
/*
Implemented as a macro in utf8.h
-=for apidoc A|bool|is_utf8_string_loc|const U8 *s|STRLEN len|const U8 **ep
+=for apidoc is_utf8_string_loc
Like is_utf8_string() but stores the location of the failure (in the
case of "utf8ness failure") or the location s+len (in the case of
See also is_utf8_string_loclen() and is_utf8_string().
-=for apidoc A|bool|is_utf8_string_loclen|const U8 *s|STRLEN len|const U8 **ep|const STRLEN *el
+=for apidoc is_utf8_string_loclen
Like is_utf8_string() but stores the location of the failure (in the
case of "utf8ness failure") or the location s+len (in the case of
*/
bool
-Perl_is_utf8_string_loclen(pTHX_ const U8 *s, STRLEN len, const U8 **ep, STRLEN *el)
+Perl_is_utf8_string_loclen(const U8 *s, STRLEN len, const U8 **ep, STRLEN *el)
{
const U8* const send = s + (len ? len : strlen((const char *)s));
const U8* x = s;
STRLEN c;
STRLEN outlen = 0;
- PERL_UNUSED_CONTEXT;
+
+ PERL_ARGS_ASSERT_IS_UTF8_STRING_LOCLEN;
while (x < send) {
/* Inline the easy bits of is_utf8_char() here for speed... */
/*
-=for apidoc A|UV|utf8n_to_uvuni|const U8 *s|STRLEN curlen|STRLEN *retlen|U32 flags
+=for apidoc utf8n_to_uvuni
Bottom level UTF-8 decode routine.
-Returns the unicode code point value of the first character in the string C<s>
+Returns the Unicode code point value of the first character in the string C<s>
which is assumed to be in UTF-8 encoding and no longer than C<curlen>;
C<retlen> will be set to the length, in bytes, of that character.
STRLEN expectlen = 0;
U32 warning = 0;
+ PERL_ARGS_ASSERT_UTF8N_TO_UVUNI;
+
/* This list is a superset of the UTF8_ALLOW_XXX. */
#define UTF8_WARN_EMPTY 1
}
if (dowarn) {
- SV* const sv = sv_2mortal(newSVpvs("Malformed UTF-8 character "));
+ SV* const sv = newSVpvs_flags("Malformed UTF-8 character ", SVs_TEMP);
switch (warning) {
case 0: /* Intentionally empty. */ break;
}
/*
-=for apidoc A|UV|utf8_to_uvchr|const U8 *s|STRLEN *retlen
+=for apidoc utf8_to_uvchr
Returns the native character value of the first character in the string C<s>
which is assumed to be in UTF-8 encoding; C<retlen> will be set to the
UV
Perl_utf8_to_uvchr(pTHX_ const U8 *s, STRLEN *retlen)
{
+ PERL_ARGS_ASSERT_UTF8_TO_UVCHR;
+
return utf8n_to_uvchr(s, UTF8_MAXBYTES, retlen,
ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY);
}
/*
-=for apidoc A|UV|utf8_to_uvuni|const U8 *s|STRLEN *retlen
+=for apidoc utf8_to_uvuni
Returns the Unicode code point of the first character in the string C<s>
which is assumed to be in UTF-8 encoding; C<retlen> will be set to the
length, in bytes, of that character.
-This function should only be used when returned UV is considered
+This function should only be used when the returned UV is considered
an index into the Unicode semantic tables (e.g. swashes).
If C<s> does not point to a well-formed UTF-8 character, zero is
UV
Perl_utf8_to_uvuni(pTHX_ const U8 *s, STRLEN *retlen)
{
+ PERL_ARGS_ASSERT_UTF8_TO_UVUNI;
+
/* Call the low level routine asking for checks */
return Perl_utf8n_to_uvuni(aTHX_ s, UTF8_MAXBYTES, retlen,
ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY);
}
/*
-=for apidoc A|STRLEN|utf8_length|const U8 *s|const U8 *e
+=for apidoc utf8_length
Return the length of the UTF-8 char encoded string C<s> in characters.
Stops at C<e> (inclusive). If C<e E<lt> s> or if the scan would end
{
dVAR;
STRLEN len = 0;
- U8 t = 0;
+
+ PERL_ARGS_ASSERT_UTF8_LENGTH;
/* Note: cannot use UTF8_IS_...() too eagerly here since e.g.
* the bitops (especially ~) can create illegal UTF-8.
if (e < s)
goto warn_and_return;
while (s < e) {
- t = UTF8SKIP(s);
- if (e - s < t) {
- warn_and_return:
- if (ckWARN_d(WARN_UTF8)) {
- if (PL_op)
- Perl_warner(aTHX_ packWARN(WARN_UTF8),
+ if (!UTF8_IS_INVARIANT(*s))
+ s += UTF8SKIP(s);
+ else
+ s++;
+ len++;
+ }
+
+ if (e != s) {
+ len--;
+ warn_and_return:
+ if (ckWARN_d(WARN_UTF8)) {
+ if (PL_op)
+ Perl_warner(aTHX_ packWARN(WARN_UTF8),
"%s in %s", unees, OP_DESC(PL_op));
- else
- Perl_warner(aTHX_ packWARN(WARN_UTF8), unees);
- }
- return len;
+ else
+ Perl_warner(aTHX_ packWARN(WARN_UTF8), unees);
}
- s += t;
- len++;
}
return len;
}
/*
-=for apidoc A|IV|utf8_distance|const U8 *a|const U8 *b
+=for apidoc utf8_distance
Returns the number of UTF-8 characters between the UTF-8 pointers C<a>
and C<b>.
IV
Perl_utf8_distance(pTHX_ const U8 *a, const U8 *b)
{
+ PERL_ARGS_ASSERT_UTF8_DISTANCE;
+
return (a < b) ? -1 * (IV) utf8_length(a, b) : (IV) utf8_length(b, a);
}
/*
-=for apidoc A|U8 *|utf8_hop|U8 *s|I32 off
+=for apidoc utf8_hop
Return the UTF-8 pointer C<s> displaced by C<off> characters, either
forward or backward.
U8 *
Perl_utf8_hop(pTHX_ const U8 *s, I32 off)
{
+ PERL_ARGS_ASSERT_UTF8_HOP;
+
PERL_UNUSED_CONTEXT;
/* Note: cannot use UTF8_IS_...() too eagerly here since e.g
* the bitops (especially ~) can create illegal UTF-8.
}
/*
-=for apidoc A|U8 *|utf8_to_bytes|U8 *s|STRLEN *len
+=for apidoc utf8_to_bytes
-Converts a string C<s> of length C<len> from UTF-8 into byte encoding.
+Converts a string C<s> of length C<len> from UTF-8 into native byte encoding.
Unlike C<bytes_to_utf8>, this over-writes the original string, and
updates len to contain the new length.
Returns zero on failure, setting C<len> to -1.
U8 * const send = s + *len;
U8 *d;
+ PERL_ARGS_ASSERT_UTF8_TO_BYTES;
+
/* ensure valid UTF-8 and chars < 256 before updating string */
while (s < send) {
U8 c = *s++;
}
/*
-=for apidoc A|U8 *|bytes_from_utf8|const U8 *s|STRLEN *len|bool *is_utf8
+=for apidoc bytes_from_utf8
-Converts a string C<s> of length C<len> from UTF-8 into byte encoding.
+Converts a string C<s> of length C<len> from UTF-8 into native byte encoding.
Unlike C<utf8_to_bytes> but like C<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 contains all 7bit characters.
+0 if C<s> is converted or consisted entirely of characters that are invariant
+in utf8 (i.e., US-ASCII on non-EBCDIC machines).
=cut
*/
const U8 *send;
I32 count = 0;
+ PERL_ARGS_ASSERT_BYTES_FROM_UTF8;
+
PERL_UNUSED_CONTEXT;
if (!*is_utf8)
return (U8 *)start;
}
/*
-=for apidoc A|U8 *|bytes_to_utf8|const U8 *s|STRLEN *len
+=for apidoc bytes_to_utf8
-Converts a string C<s> of length C<len> from ASCII into UTF-8 encoding.
+Converts a string C<s> of length C<len> from the native encoding into UTF-8.
Returns a pointer to the newly-created string, and sets C<len> to
reflect the new length.
-If you want to convert to UTF-8 from other encodings than ASCII,
+A NUL character will be written after the end of the string.
+
+If you want to convert to UTF-8 from encodings other than
+the native (Latin1 or EBCDIC),
see sv_recode_to_utf8().
=cut
const U8 * const send = s + (*len);
U8 *d;
U8 *dst;
+
+ PERL_ARGS_ASSERT_BYTES_TO_UTF8;
PERL_UNUSED_CONTEXT;
Newx(d, (*len) * 2 + 1, U8);
U8* pend;
U8* dstart = d;
+ PERL_ARGS_ASSERT_UTF16_TO_UTF8;
+
if (bytelen == 1 && p[0] == 0) { /* Be understanding. */
d[0] = 0;
*newlen = 1;
{
U8* s = (U8*)p;
U8* const send = s + bytelen;
+
+ PERL_ARGS_ASSERT_UTF16_TO_UTF8_REVERSED;
+
while (s < send) {
const U8 tmp = s[0];
s[0] = s[1];
}
bool
-Perl_is_uni_alnumc(pTHX_ UV c)
-{
- U8 tmpbuf[UTF8_MAXBYTES+1];
- uvchr_to_utf8(tmpbuf, c);
- return is_utf8_alnumc(tmpbuf);
-}
-
-bool
Perl_is_uni_idfirst(pTHX_ UV c)
{
U8 tmpbuf[UTF8_MAXBYTES+1];
UV
Perl_to_uni_upper(pTHX_ UV c, U8* p, STRLEN *lenp)
{
+ PERL_ARGS_ASSERT_TO_UNI_UPPER;
+
uvchr_to_utf8(p, c);
return to_utf8_upper(p, p, lenp);
}
UV
Perl_to_uni_title(pTHX_ UV c, U8* p, STRLEN *lenp)
{
+ PERL_ARGS_ASSERT_TO_UNI_TITLE;
+
uvchr_to_utf8(p, c);
return to_utf8_title(p, p, lenp);
}
UV
Perl_to_uni_lower(pTHX_ UV c, U8* p, STRLEN *lenp)
{
+ PERL_ARGS_ASSERT_TO_UNI_LOWER;
+
uvchr_to_utf8(p, c);
return to_utf8_lower(p, p, lenp);
}
UV
Perl_to_uni_fold(pTHX_ UV c, U8* p, STRLEN *lenp)
{
+ PERL_ARGS_ASSERT_TO_UNI_FOLD;
+
uvchr_to_utf8(p, c);
return to_utf8_fold(p, p, lenp);
}
}
bool
-Perl_is_uni_alnumc_lc(pTHX_ UV c)
-{
- return is_uni_alnumc(c); /* XXX no locale support yet */
-}
-
-bool
Perl_is_uni_idfirst_lc(pTHX_ UV c)
{
return is_uni_idfirst(c); /* XXX no locale support yet */
const char *const swashname)
{
dVAR;
+
+ PERL_ARGS_ASSERT_IS_UTF8_COMMON;
+
if (!is_utf8_char(p))
return FALSE;
if (!*swash)
Perl_is_utf8_alnum(pTHX_ const U8 *p)
{
dVAR;
+
+ PERL_ARGS_ASSERT_IS_UTF8_ALNUM;
+
/* NOTE: "IsWord", not "IsAlnum", since Alnum is a true
* descendant of isalnum(3), in other words, it doesn't
* contain the '_'. --jhi */
}
bool
-Perl_is_utf8_alnumc(pTHX_ const U8 *p)
-{
- dVAR;
- return is_utf8_common(p, &PL_utf8_alnumc, "IsAlnumC");
-}
-
-bool
Perl_is_utf8_idfirst(pTHX_ const U8 *p) /* The naming is historical. */
{
dVAR;
+
+ PERL_ARGS_ASSERT_IS_UTF8_IDFIRST;
+
if (*p == '_')
return TRUE;
/* is_utf8_idstart would be more logical. */
Perl_is_utf8_idcont(pTHX_ const U8 *p)
{
dVAR;
+
+ PERL_ARGS_ASSERT_IS_UTF8_IDCONT;
+
if (*p == '_')
return TRUE;
return is_utf8_common(p, &PL_utf8_idcont, "IdContinue");
Perl_is_utf8_alpha(pTHX_ const U8 *p)
{
dVAR;
+
+ PERL_ARGS_ASSERT_IS_UTF8_ALPHA;
+
return is_utf8_common(p, &PL_utf8_alpha, "IsAlpha");
}
Perl_is_utf8_ascii(pTHX_ const U8 *p)
{
dVAR;
+
+ PERL_ARGS_ASSERT_IS_UTF8_ASCII;
+
return is_utf8_common(p, &PL_utf8_ascii, "IsAscii");
}
Perl_is_utf8_space(pTHX_ const U8 *p)
{
dVAR;
+
+ PERL_ARGS_ASSERT_IS_UTF8_SPACE;
+
return is_utf8_common(p, &PL_utf8_space, "IsSpacePerl");
}
Perl_is_utf8_digit(pTHX_ const U8 *p)
{
dVAR;
+
+ PERL_ARGS_ASSERT_IS_UTF8_DIGIT;
+
return is_utf8_common(p, &PL_utf8_digit, "IsDigit");
}
Perl_is_utf8_upper(pTHX_ const U8 *p)
{
dVAR;
+
+ PERL_ARGS_ASSERT_IS_UTF8_UPPER;
+
return is_utf8_common(p, &PL_utf8_upper, "IsUppercase");
}
Perl_is_utf8_lower(pTHX_ const U8 *p)
{
dVAR;
+
+ PERL_ARGS_ASSERT_IS_UTF8_LOWER;
+
return is_utf8_common(p, &PL_utf8_lower, "IsLowercase");
}
Perl_is_utf8_cntrl(pTHX_ const U8 *p)
{
dVAR;
+
+ PERL_ARGS_ASSERT_IS_UTF8_CNTRL;
+
return is_utf8_common(p, &PL_utf8_cntrl, "IsCntrl");
}
Perl_is_utf8_graph(pTHX_ const U8 *p)
{
dVAR;
+
+ PERL_ARGS_ASSERT_IS_UTF8_GRAPH;
+
return is_utf8_common(p, &PL_utf8_graph, "IsGraph");
}
Perl_is_utf8_print(pTHX_ const U8 *p)
{
dVAR;
+
+ PERL_ARGS_ASSERT_IS_UTF8_PRINT;
+
return is_utf8_common(p, &PL_utf8_print, "IsPrint");
}
Perl_is_utf8_punct(pTHX_ const U8 *p)
{
dVAR;
+
+ PERL_ARGS_ASSERT_IS_UTF8_PUNCT;
+
return is_utf8_common(p, &PL_utf8_punct, "IsPunct");
}
Perl_is_utf8_xdigit(pTHX_ const U8 *p)
{
dVAR;
+
+ PERL_ARGS_ASSERT_IS_UTF8_XDIGIT;
+
return is_utf8_common(p, &PL_utf8_xdigit, "Isxdigit");
}
Perl_is_utf8_mark(pTHX_ const U8 *p)
{
dVAR;
+
+ PERL_ARGS_ASSERT_IS_UTF8_MARK;
+
return is_utf8_common(p, &PL_utf8_mark, "IsM");
}
/*
-=for apidoc A|UV|to_utf8_case|U8 *p|U8* ustrp|STRLEN *lenp|SV **swash|char *normal|char *special
+=for apidoc to_utf8_case
The "p" contains the pointer to the UTF-8 string encoding
the character that is being converted.
dVAR;
U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
STRLEN len = 0;
-
const UV uv0 = utf8_to_uvchr(p, NULL);
/* The NATIVE_TO_UNI() and UNI_TO_NATIVE() mappings
* are necessary in EBCDIC, they are redundant no-ops
* in ASCII-ish platforms, and hopefully optimized away. */
const UV uv1 = NATIVE_TO_UNI(uv0);
+
+ PERL_ARGS_ASSERT_TO_UTF8_CASE;
+
uvuni_to_utf8(tmpbuf, uv1);
if (!*swashp) /* load on-demand */
if (special && (uv1 == 0xDF || uv1 > 0xFF)) {
/* It might be "special" (sometimes, but not always,
* a multicharacter mapping) */
- HV * const hv = get_hv(special, FALSE);
+ HV * const hv = get_hv(special, 0);
SV **svp;
if (hv &&
}
/*
-=for apidoc A|UV|to_utf8_upper|const U8 *p|U8 *ustrp|STRLEN *lenp
+=for apidoc to_utf8_upper
Convert the UTF-8 encoded character at p to its uppercase version and
store that in UTF-8 in ustrp and its length in bytes in lenp. Note
Perl_to_utf8_upper(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp)
{
dVAR;
+
+ PERL_ARGS_ASSERT_TO_UTF8_UPPER;
+
return Perl_to_utf8_case(aTHX_ p, ustrp, lenp,
&PL_utf8_toupper, "ToUpper", "utf8::ToSpecUpper");
}
/*
-=for apidoc A|UV|to_utf8_title|const U8 *p|U8 *ustrp|STRLEN *lenp
+=for apidoc to_utf8_title
Convert the UTF-8 encoded character at p to its titlecase version and
store that in UTF-8 in ustrp and its length in bytes in lenp. Note
Perl_to_utf8_title(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp)
{
dVAR;
+
+ PERL_ARGS_ASSERT_TO_UTF8_TITLE;
+
return Perl_to_utf8_case(aTHX_ p, ustrp, lenp,
&PL_utf8_totitle, "ToTitle", "utf8::ToSpecTitle");
}
/*
-=for apidoc A|UV|to_utf8_lower|const U8 *p|U8 *ustrp|STRLEN *lenp
+=for apidoc to_utf8_lower
Convert the UTF-8 encoded character at p to its lowercase version and
store that in UTF-8 in ustrp and its length in bytes in lenp. Note
Perl_to_utf8_lower(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp)
{
dVAR;
+
+ PERL_ARGS_ASSERT_TO_UTF8_LOWER;
+
return Perl_to_utf8_case(aTHX_ p, ustrp, lenp,
&PL_utf8_tolower, "ToLower", "utf8::ToSpecLower");
}
/*
-=for apidoc A|UV|to_utf8_fold|const U8 *p|U8 *ustrp|STRLEN *lenp
+=for apidoc to_utf8_fold
Convert the UTF-8 encoded character at p to its foldcase version and
store that in UTF-8 in ustrp and its length in bytes in lenp. Note
Perl_to_utf8_fold(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp)
{
dVAR;
+
+ PERL_ARGS_ASSERT_TO_UTF8_FOLD;
+
return Perl_to_utf8_case(aTHX_ p, ustrp, lenp,
&PL_utf8_tofold, "ToFold", "utf8::ToSpecFold");
}
{
dVAR;
SV* retval;
- SV* const tokenbufsv = sv_newmortal();
dSP;
const size_t pkg_len = strlen(pkg);
const size_t name_len = strlen(name);
- HV * const stash = gv_stashpvn(pkg, pkg_len, FALSE);
+ HV * const stash = gv_stashpvn(pkg, pkg_len, 0);
SV* errsv_save;
+ PERL_ARGS_ASSERT_SWASH_INIT;
+
PUSHSTACKi(PERLSI_MAGIC);
ENTER;
SAVEI32(PL_hints);
SPAGAIN;
PUSHMARK(SP);
EXTEND(SP,5);
- PUSHs(sv_2mortal(newSVpvn(pkg, pkg_len)));
- PUSHs(sv_2mortal(newSVpvn(name, name_len)));
+ mPUSHp(pkg, pkg_len);
+ mPUSHp(name, name_len);
PUSHs(listsv);
- PUSHs(sv_2mortal(newSViv(minbits)));
- PUSHs(sv_2mortal(newSViv(none)));
+ mPUSHi(minbits);
+ mPUSHi(none);
PUTBACK;
- if (IN_PERL_COMPILETIME) {
- /* XXX ought to be handled by lex_start */
- SAVEI32(PL_in_my);
- PL_in_my = 0;
- sv_setpv(tokenbufsv, PL_tokenbuf);
- }
errsv_save = newSVsv(ERRSV);
if (call_method("SWASHNEW", G_SCALAR))
retval = newSVsv(*PL_stack_sp--);
LEAVE;
POPSTACK;
if (IN_PERL_COMPILETIME) {
- STRLEN len;
- const char* const pv = SvPV_const(tokenbufsv, len);
-
- Copy(pv, PL_tokenbuf, len+1, char);
CopHINTS_set(PL_curcop, PL_hints);
}
if (!SvROK(retval) || SvTYPE(SvRV(retval)) != SVt_PVHV) {
if (SvPOK(retval))
Perl_croak(aTHX_ "Can't find Unicode property definition \"%"SVf"\"",
- (void*)retval);
+ SVfARG(retval));
Perl_croak(aTHX_ "SWASHNEW didn't return an HV ref");
}
return retval;
Perl_swash_fetch(pTHX_ SV *swash, const U8 *ptr, bool do_utf8)
{
dVAR;
- HV* const hv = (HV*)SvRV(swash);
+ HV *const hv = MUTABLE_HV(SvRV(swash));
U32 klen;
U32 off;
STRLEN slen;
U8 tmputf8[2];
const UV c = NATIVE_TO_ASCII(*ptr);
+ PERL_ARGS_ASSERT_SWASH_FETCH;
+
if (!do_utf8 && !UNI_IS_INVARIANT(c)) {
tmputf8[0] = (U8)UTF8_EIGHT_BIT_HI(c);
tmputf8[1] = (U8)UTF8_EIGHT_BIT_LO(c);
}
PL_last_swash_hv = hv;
- PL_last_swash_klen = klen;
+ assert(klen <= sizeof(PL_last_swash_key));
+ PL_last_swash_klen = (U8)klen;
/* FIXME change interpvar.h? */
PL_last_swash_tmps = (U8 *) tmps;
PL_last_swash_slen = slen;
SV *swatch;
U8 *l, *lend, *x, *xend, *s;
STRLEN lcur, xcur, scur;
-
- HV* const hv = (HV*)SvRV(swash);
+ HV *const hv = MUTABLE_HV(SvRV(swash));
SV** const listsvp = hv_fetchs(hv, "LIST", FALSE);
SV** const typesvp = hv_fetchs(hv, "TYPE", FALSE);
SV** const bitssvp = hv_fetchs(hv, "BITS", FALSE);
const UV none = SvUV(*nonesvp);
const UV end = start + span;
+ PERL_ARGS_ASSERT_SWASH_GET;
+
if (bits != 1 && bits != 8 && bits != 16 && bits != 32) {
Perl_croak(aTHX_ "panic: swash_get doesn't expect bits %"UVuf,
(UV)bits);
}
/* create and initialize $swatch */
- swatch = newSVpvs("");
scur = octets ? (span * octets) : (span + 7) / 8;
- SvGROW(swatch, scur + 1);
+ swatch = newSV(scur);
+ SvPOK_on(swatch);
s = (U8*)SvPVX(swatch);
if (octets && none) {
const U8* const e = s + scur;
}
othersvp = hv_fetch(hv, (char *)namestr, namelen, FALSE);
- otherhv = (HV*)SvRV(*othersvp);
+ otherhv = MUTABLE_HV(SvRV(*othersvp));
otherbitssvp = hv_fetchs(otherhv, "BITS", FALSE);
otherbits = (STRLEN)SvUV(*otherbitssvp);
if (bits < otherbits)
}
/*
-=for apidoc A|U8 *|uvchr_to_utf8|U8 *d|UV uv
+=for apidoc uvchr_to_utf8
Adds the UTF-8 representation of the Native codepoint C<uv> to the end
of the string C<d>; C<d> should be have at least C<UTF8_MAXBYTES+1> free
U8 *
Perl_uvchr_to_utf8(pTHX_ U8 *d, UV uv)
{
+ PERL_ARGS_ASSERT_UVCHR_TO_UTF8;
+
return Perl_uvuni_to_utf8_flags(aTHX_ d, NATIVE_TO_UNI(uv), 0);
}
U8 *
Perl_uvchr_to_utf8_flags(pTHX_ U8 *d, UV uv, UV flags)
{
+ PERL_ARGS_ASSERT_UVCHR_TO_UTF8_FLAGS;
+
return Perl_uvuni_to_utf8_flags(aTHX_ d, NATIVE_TO_UNI(uv), flags);
}
/*
-=for apidoc A|UV|utf8n_to_uvchr|U8 *s|STRLEN curlen|STRLEN *retlen|U32
+=for apidoc utf8n_to_uvchr
flags
Returns the native character value of the first character in the string
U32 flags)
{
const UV uv = Perl_utf8n_to_uvuni(aTHX_ s, curlen, retlen, flags);
+
+ PERL_ARGS_ASSERT_UTF8N_TO_UVCHR;
+
return UNI_TO_NATIVE(uv);
}
/*
-=for apidoc A|char *|pv_uni_display|SV *dsv|U8 *spv|STRLEN len|STRLEN pvlim|UV flags
+=for apidoc pv_uni_display
Build to the scalar dsv a displayable version of the string spv,
length len, the displayable version being at most pvlim bytes long
int truncated = 0;
const char *s, *e;
- sv_setpvn(dsv, "", 0);
+ PERL_ARGS_ASSERT_PV_UNI_DISPLAY;
+
+ sv_setpvs(dsv, "");
+ SvUTF8_off(dsv);
for (s = (const char *)spv, e = s + len; s < e; s += UTF8SKIP(s)) {
UV u;
/* This serves double duty as a flag and a character to print after
default: break;
}
if (ok) {
- Perl_sv_catpvf(aTHX_ dsv, "\\%c", ok);
+ const char string = ok;
+ sv_catpvs(dsv, "\\");
+ sv_catpvn(dsv, &string, 1);
}
}
/* isPRINT() is the locale-blind version. */
if (!ok && (flags & UNI_DISPLAY_ISPRINT) && isPRINT(c)) {
- Perl_sv_catpvf(aTHX_ dsv, "%c", c);
+ const char string = c;
+ sv_catpvn(dsv, &string, 1);
ok = 1;
}
}
}
/*
-=for apidoc A|char *|sv_uni_display|SV *dsv|SV *ssv|STRLEN pvlim|UV flags
+=for apidoc sv_uni_display
Build to the scalar dsv a displayable version of the scalar sv,
the displayable version being at most pvlim bytes long
char *
Perl_sv_uni_display(pTHX_ SV *dsv, SV *ssv, STRLEN pvlim, UV flags)
{
+ PERL_ARGS_ASSERT_SV_UNI_DISPLAY;
+
return Perl_pv_uni_display(aTHX_ dsv, (const U8*)SvPVX_const(ssv),
SvCUR(ssv), pvlim, flags);
}
/*
-=for apidoc A|I32|ibcmp_utf8|const char *s1|char **pe1|register UV l1|bool u1|const char *s2|char **pe2|register UV l2|bool u2
+=for apidoc ibcmp_utf8
Return true if the strings s1 and s2 differ case-insensitively, false
if not (if they are equal case-insensitively). If u1 is true, the
U8 natbuf[1+1];
STRLEN foldlen1, foldlen2;
bool match;
+
+ PERL_ARGS_ASSERT_IBCMP_UTF8;
if (pe1)
e1 = *(U8**)pe1;
+ /* assert(e1 || l1); */
if (e1 == 0 || (l1 && l1 < (UV)(e1 - (const U8*)s1)))
f1 = (const U8*)s1 + l1;
if (pe2)
e2 = *(U8**)pe2;
+ /* assert(e2 || l2); */
if (e2 == 0 || (l2 && l2 < (UV)(e2 - (const U8*)s2)))
f2 = (const U8*)s2 + l2;
+ /* This shouldn't happen. However, putting an assert() there makes some
+ * tests fail. */
+ /* assert((e1 == 0 && f1 == 0) || (e2 == 0 && f2 == 0) || (f1 == 0 && f2 == 0)); */
if ((e1 == 0 && f1 == 0) || (e2 == 0 && f2 == 0) || (f1 == 0 && f2 == 0))
return 1; /* mismatch; possible infinite loop or false positive */
https://perl5.git.perl.org / perl5.git / blobdiff