1N/A/* utf8.c
1N/A *
1N/A * Copyright (C) 2000, 2001, 2002, 2003, 2004, by Larry Wall and others
1N/A *
1N/A * You may distribute under the terms of either the GNU General Public
1N/A * License or the Artistic License, as specified in the README file.
1N/A *
1N/A */
1N/A
1N/A/*
1N/A * 'What a fix!' said Sam. 'That's the one place in all the lands we've ever
1N/A * heard of that we don't want to see any closer; and that's the one place
1N/A * we're trying to get to! And that's just where we can't get, nohow.'
1N/A *
1N/A * 'Well do I understand your speech,' he answered in the same language;
1N/A * 'yet few strangers do so. Why then do you not speak in the Common Tongue,
1N/A * as is the custom in the West, if you wish to be answered?'
1N/A *
1N/A * ...the travellers perceived that the floor was paved with stones of many
1N/A * hues; branching runes and strange devices intertwined beneath their feet.
1N/A */
1N/A
1N/A#include "EXTERN.h"
1N/A#define PERL_IN_UTF8_C
1N/A#include "perl.h"
1N/A
1N/Astatic char unees[] = "Malformed UTF-8 character (unexpected end of string)";
1N/A
1N/A/*
1N/A=head1 Unicode Support
1N/A
1N/A=for apidoc A|U8 *|uvuni_to_utf8_flags|U8 *d|UV uv|UV flags
1N/A
1N/AAdds the UTF-8 representation of the Unicode codepoint C<uv> to the end
1N/Aof the string C<d>; C<d> should be have at least C<UTF8_MAXLEN+1> free
1N/Abytes available. The return value is the pointer to the byte after the
1N/Aend of the new character. In other words,
1N/A
1N/A d = uvuni_to_utf8_flags(d, uv, flags);
1N/A
1N/Aor, in most cases,
1N/A
1N/A d = uvuni_to_utf8(d, uv);
1N/A
1N/A(which is equivalent to)
1N/A
1N/A d = uvuni_to_utf8_flags(d, uv, 0);
1N/A
1N/Ais the recommended Unicode-aware way of saying
1N/A
1N/A *(d++) = uv;
1N/A
1N/A=cut
1N/A*/
1N/A
1N/AU8 *
1N/APerl_uvuni_to_utf8_flags(pTHX_ U8 *d, UV uv, UV flags)
1N/A{
1N/A if (ckWARN(WARN_UTF8)) {
1N/A if (UNICODE_IS_SURROGATE(uv) &&
1N/A !(flags & UNICODE_ALLOW_SURROGATE))
1N/A Perl_warner(aTHX_ packWARN(WARN_UTF8), "UTF-16 surrogate 0x%04"UVxf, uv);
1N/A else if (
1N/A ((uv >= 0xFDD0 && uv <= 0xFDEF &&
1N/A !(flags & UNICODE_ALLOW_FDD0))
1N/A ||
1N/A ((uv & 0xFFFE) == 0xFFFE && /* Either FFFE or FFFF. */
1N/A !(flags & UNICODE_ALLOW_FFFF))) &&
1N/A /* UNICODE_ALLOW_SUPER includes
1N/A * FFFEs and FFFFs beyond 0x10FFFF. */
1N/A ((uv <= PERL_UNICODE_MAX) ||
1N/A !(flags & UNICODE_ALLOW_SUPER))
1N/A )
1N/A Perl_warner(aTHX_ packWARN(WARN_UTF8),
1N/A "Unicode character 0x%04"UVxf" is illegal", uv);
1N/A }
1N/A if (UNI_IS_INVARIANT(uv)) {
1N/A *d++ = (U8)UTF_TO_NATIVE(uv);
1N/A return d;
1N/A }
1N/A#if defined(EBCDIC)
1N/A else {
1N/A STRLEN len = UNISKIP(uv);
1N/A U8 *p = d+len-1;
1N/A while (p > d) {
1N/A *p-- = (U8)UTF_TO_NATIVE((uv & UTF_CONTINUATION_MASK) | UTF_CONTINUATION_MARK);
1N/A uv >>= UTF_ACCUMULATION_SHIFT;
1N/A }
1N/A *p = (U8)UTF_TO_NATIVE((uv & UTF_START_MASK(len)) | UTF_START_MARK(len));
1N/A return d+len;
1N/A }
1N/A#else /* Non loop style */
1N/A if (uv < 0x800) {
1N/A *d++ = (U8)(( uv >> 6) | 0xc0);
1N/A *d++ = (U8)(( uv & 0x3f) | 0x80);
1N/A return d;
1N/A }
1N/A if (uv < 0x10000) {
1N/A *d++ = (U8)(( uv >> 12) | 0xe0);
1N/A *d++ = (U8)(((uv >> 6) & 0x3f) | 0x80);
1N/A *d++ = (U8)(( uv & 0x3f) | 0x80);
1N/A return d;
1N/A }
1N/A if (uv < 0x200000) {
1N/A *d++ = (U8)(( uv >> 18) | 0xf0);
1N/A *d++ = (U8)(((uv >> 12) & 0x3f) | 0x80);
1N/A *d++ = (U8)(((uv >> 6) & 0x3f) | 0x80);
1N/A *d++ = (U8)(( uv & 0x3f) | 0x80);
1N/A return d;
1N/A }
1N/A if (uv < 0x4000000) {
1N/A *d++ = (U8)(( uv >> 24) | 0xf8);
1N/A *d++ = (U8)(((uv >> 18) & 0x3f) | 0x80);
1N/A *d++ = (U8)(((uv >> 12) & 0x3f) | 0x80);
1N/A *d++ = (U8)(((uv >> 6) & 0x3f) | 0x80);
1N/A *d++ = (U8)(( uv & 0x3f) | 0x80);
1N/A return d;
1N/A }
1N/A if (uv < 0x80000000) {
1N/A *d++ = (U8)(( uv >> 30) | 0xfc);
1N/A *d++ = (U8)(((uv >> 24) & 0x3f) | 0x80);
1N/A *d++ = (U8)(((uv >> 18) & 0x3f) | 0x80);
1N/A *d++ = (U8)(((uv >> 12) & 0x3f) | 0x80);
1N/A *d++ = (U8)(((uv >> 6) & 0x3f) | 0x80);
1N/A *d++ = (U8)(( uv & 0x3f) | 0x80);
1N/A return d;
1N/A }
1N/A#ifdef HAS_QUAD
1N/A if (uv < UTF8_QUAD_MAX)
1N/A#endif
1N/A {
1N/A *d++ = 0xfe; /* Can't match U+FEFF! */
1N/A *d++ = (U8)(((uv >> 30) & 0x3f) | 0x80);
1N/A *d++ = (U8)(((uv >> 24) & 0x3f) | 0x80);
1N/A *d++ = (U8)(((uv >> 18) & 0x3f) | 0x80);
1N/A *d++ = (U8)(((uv >> 12) & 0x3f) | 0x80);
1N/A *d++ = (U8)(((uv >> 6) & 0x3f) | 0x80);
1N/A *d++ = (U8)(( uv & 0x3f) | 0x80);
1N/A return d;
1N/A }
1N/A#ifdef HAS_QUAD
1N/A {
1N/A *d++ = 0xff; /* Can't match U+FFFE! */
1N/A *d++ = 0x80; /* 6 Reserved bits */
1N/A *d++ = (U8)(((uv >> 60) & 0x0f) | 0x80); /* 2 Reserved bits */
1N/A *d++ = (U8)(((uv >> 54) & 0x3f) | 0x80);
1N/A *d++ = (U8)(((uv >> 48) & 0x3f) | 0x80);
1N/A *d++ = (U8)(((uv >> 42) & 0x3f) | 0x80);
1N/A *d++ = (U8)(((uv >> 36) & 0x3f) | 0x80);
1N/A *d++ = (U8)(((uv >> 30) & 0x3f) | 0x80);
1N/A *d++ = (U8)(((uv >> 24) & 0x3f) | 0x80);
1N/A *d++ = (U8)(((uv >> 18) & 0x3f) | 0x80);
1N/A *d++ = (U8)(((uv >> 12) & 0x3f) | 0x80);
1N/A *d++ = (U8)(((uv >> 6) & 0x3f) | 0x80);
1N/A *d++ = (U8)(( uv & 0x3f) | 0x80);
1N/A return d;
1N/A }
1N/A#endif
1N/A#endif /* Loop style */
1N/A}
1N/A
1N/AU8 *
1N/APerl_uvuni_to_utf8(pTHX_ U8 *d, UV uv)
1N/A{
1N/A return Perl_uvuni_to_utf8_flags(aTHX_ d, uv, 0);
1N/A}
1N/A
1N/A
1N/A/*
1N/A=for apidoc A|STRLEN|is_utf8_char|U8 *s
1N/A
1N/ATests if some arbitrary number of bytes begins in a valid UTF-8
1N/Acharacter. Note that an INVARIANT (i.e. ASCII) character is a valid
1N/AUTF-8 character. The actual number of bytes in the UTF-8 character
1N/Awill be returned if it is valid, otherwise 0.
1N/A
1N/A=cut */
1N/ASTRLEN
1N/APerl_is_utf8_char(pTHX_ U8 *s)
1N/A{
1N/A U8 u = *s;
1N/A STRLEN slen, len;
1N/A UV uv, ouv;
1N/A
1N/A if (UTF8_IS_INVARIANT(u))
1N/A return 1;
1N/A
1N/A if (!UTF8_IS_START(u))
1N/A return 0;
1N/A
1N/A len = UTF8SKIP(s);
1N/A
1N/A if (len < 2 || !UTF8_IS_CONTINUATION(s[1]))
1N/A return 0;
1N/A
1N/A slen = len - 1;
1N/A s++;
1N/A u &= UTF_START_MASK(len);
1N/A uv = u;
1N/A ouv = uv;
1N/A while (slen--) {
1N/A if (!UTF8_IS_CONTINUATION(*s))
1N/A return 0;
1N/A uv = UTF8_ACCUMULATE(uv, *s);
1N/A if (uv < ouv)
1N/A return 0;
1N/A ouv = uv;
1N/A s++;
1N/A }
1N/A
1N/A if ((STRLEN)UNISKIP(uv) < len)
1N/A return 0;
1N/A
1N/A return len;
1N/A}
1N/A
1N/A/*
1N/A=for apidoc A|bool|is_utf8_string|U8 *s|STRLEN len
1N/A
1N/AReturns true if first C<len> bytes of the given string form a valid
1N/AUTF-8 string, false otherwise. Note that 'a valid UTF-8 string' does
1N/Anot mean 'a string that contains code points above 0x7F encoded in UTF-8'
1N/Abecause a valid ASCII string is a valid UTF-8 string.
1N/A
1N/A=cut
1N/A*/
1N/A
1N/Abool
1N/APerl_is_utf8_string(pTHX_ U8 *s, STRLEN len)
1N/A{
1N/A U8* x = s;
1N/A U8* send;
1N/A STRLEN c;
1N/A
1N/A if (!len)
1N/A len = strlen((char *)s);
1N/A send = s + len;
1N/A
1N/A while (x < send) {
1N/A /* Inline the easy bits of is_utf8_char() here for speed... */
1N/A if (UTF8_IS_INVARIANT(*x))
1N/A c = 1;
1N/A else if (!UTF8_IS_START(*x))
1N/A return FALSE;
1N/A else {
1N/A /* ... and call is_utf8_char() only if really needed. */
1N/A c = is_utf8_char(x);
1N/A if (!c)
1N/A return FALSE;
1N/A }
1N/A x += c;
1N/A }
1N/A if (x != send)
1N/A return FALSE;
1N/A
1N/A return TRUE;
1N/A}
1N/A
1N/A/*
1N/A=for apidoc A|bool|is_utf8_string_loc|U8 *s|STRLEN len|U8 **p
1N/A
1N/ALike is_ut8_string but store the location of the failure in
1N/Athe last argument.
1N/A
1N/A=cut
1N/A*/
1N/A
1N/Abool
1N/APerl_is_utf8_string_loc(pTHX_ U8 *s, STRLEN len, U8 **p)
1N/A{
1N/A U8* x = s;
1N/A U8* send;
1N/A STRLEN c;
1N/A
1N/A if (!len)
1N/A len = strlen((char *)s);
1N/A send = s + len;
1N/A
1N/A while (x < send) {
1N/A /* Inline the easy bits of is_utf8_char() here for speed... */
1N/A if (UTF8_IS_INVARIANT(*x))
1N/A c = 1;
1N/A else if (!UTF8_IS_START(*x)) {
1N/A if (p)
1N/A *p = x;
1N/A return FALSE;
1N/A }
1N/A else {
1N/A /* ... and call is_utf8_char() only if really needed. */
1N/A c = is_utf8_char(x);
1N/A if (!c) {
1N/A if (p)
1N/A *p = x;
1N/A return FALSE;
1N/A }
1N/A }
1N/A x += c;
1N/A }
1N/A if (x != send) {
1N/A if (p)
1N/A *p = x;
1N/A return FALSE;
1N/A }
1N/A
1N/A return TRUE;
1N/A}
1N/A
1N/A/*
1N/A=for apidoc A|UV|utf8n_to_uvuni|U8 *s|STRLEN curlen|STRLEN *retlen|U32 flags
1N/A
1N/ABottom level UTF-8 decode routine.
1N/AReturns the unicode code point value of the first character in the string C<s>
1N/Awhich is assumed to be in UTF-8 encoding and no longer than C<curlen>;
1N/AC<retlen> will be set to the length, in bytes, of that character.
1N/A
1N/AIf C<s> does not point to a well-formed UTF-8 character, the behaviour
1N/Ais dependent on the value of C<flags>: if it contains UTF8_CHECK_ONLY,
1N/Ait is assumed that the caller will raise a warning, and this function
1N/Awill silently just set C<retlen> to C<-1> and return zero. If the
1N/AC<flags> does not contain UTF8_CHECK_ONLY, warnings about
1N/Amalformations will be given, C<retlen> will be set to the expected
1N/Alength of the UTF-8 character in bytes, and zero will be returned.
1N/A
1N/AThe C<flags> can also contain various flags to allow deviations from
1N/Athe strict UTF-8 encoding (see F<utf8.h>).
1N/A
1N/AMost code should use utf8_to_uvchr() rather than call this directly.
1N/A
1N/A=cut
1N/A*/
1N/A
1N/AUV
1N/APerl_utf8n_to_uvuni(pTHX_ U8 *s, STRLEN curlen, STRLEN *retlen, U32 flags)
1N/A{
1N/A U8 *s0 = s;
1N/A UV uv = *s, ouv = 0;
1N/A STRLEN len = 1;
1N/A bool dowarn = ckWARN_d(WARN_UTF8);
1N/A UV startbyte = *s;
1N/A STRLEN expectlen = 0;
1N/A U32 warning = 0;
1N/A
1N/A/* This list is a superset of the UTF8_ALLOW_XXX. */
1N/A
1N/A#define UTF8_WARN_EMPTY 1
1N/A#define UTF8_WARN_CONTINUATION 2
1N/A#define UTF8_WARN_NON_CONTINUATION 3
1N/A#define UTF8_WARN_FE_FF 4
1N/A#define UTF8_WARN_SHORT 5
1N/A#define UTF8_WARN_OVERFLOW 6
1N/A#define UTF8_WARN_SURROGATE 7
1N/A#define UTF8_WARN_LONG 8
1N/A#define UTF8_WARN_FFFF 9 /* Also FFFE. */
1N/A
1N/A if (curlen == 0 &&
1N/A !(flags & UTF8_ALLOW_EMPTY)) {
1N/A warning = UTF8_WARN_EMPTY;
1N/A goto malformed;
1N/A }
1N/A
1N/A if (UTF8_IS_INVARIANT(uv)) {
1N/A if (retlen)
1N/A *retlen = 1;
1N/A return (UV) (NATIVE_TO_UTF(*s));
1N/A }
1N/A
1N/A if (UTF8_IS_CONTINUATION(uv) &&
1N/A !(flags & UTF8_ALLOW_CONTINUATION)) {
1N/A warning = UTF8_WARN_CONTINUATION;
1N/A goto malformed;
1N/A }
1N/A
1N/A if (UTF8_IS_START(uv) && curlen > 1 && !UTF8_IS_CONTINUATION(s[1]) &&
1N/A !(flags & UTF8_ALLOW_NON_CONTINUATION)) {
1N/A warning = UTF8_WARN_NON_CONTINUATION;
1N/A goto malformed;
1N/A }
1N/A
1N/A#ifdef EBCDIC
1N/A uv = NATIVE_TO_UTF(uv);
1N/A#else
1N/A if ((uv == 0xfe || uv == 0xff) &&
1N/A !(flags & UTF8_ALLOW_FE_FF)) {
1N/A warning = UTF8_WARN_FE_FF;
1N/A goto malformed;
1N/A }
1N/A#endif
1N/A
1N/A if (!(uv & 0x20)) { len = 2; uv &= 0x1f; }
1N/A else if (!(uv & 0x10)) { len = 3; uv &= 0x0f; }
1N/A else if (!(uv & 0x08)) { len = 4; uv &= 0x07; }
1N/A else if (!(uv & 0x04)) { len = 5; uv &= 0x03; }
1N/A#ifdef EBCDIC
1N/A else if (!(uv & 0x02)) { len = 6; uv &= 0x01; }
1N/A else { len = 7; uv &= 0x01; }
1N/A#else
1N/A else if (!(uv & 0x02)) { len = 6; uv &= 0x01; }
1N/A else if (!(uv & 0x01)) { len = 7; uv = 0; }
1N/A else { len = 13; uv = 0; } /* whoa! */
1N/A#endif
1N/A
1N/A if (retlen)
1N/A *retlen = len;
1N/A
1N/A expectlen = len;
1N/A
1N/A if ((curlen < expectlen) &&
1N/A !(flags & UTF8_ALLOW_SHORT)) {
1N/A warning = UTF8_WARN_SHORT;
1N/A goto malformed;
1N/A }
1N/A
1N/A len--;
1N/A s++;
1N/A ouv = uv;
1N/A
1N/A while (len--) {
1N/A if (!UTF8_IS_CONTINUATION(*s) &&
1N/A !(flags & UTF8_ALLOW_NON_CONTINUATION)) {
1N/A s--;
1N/A warning = UTF8_WARN_NON_CONTINUATION;
1N/A goto malformed;
1N/A }
1N/A else
1N/A uv = UTF8_ACCUMULATE(uv, *s);
1N/A if (!(uv > ouv)) {
1N/A /* These cannot be allowed. */
1N/A if (uv == ouv) {
1N/A if (!(flags & UTF8_ALLOW_LONG)) {
1N/A warning = UTF8_WARN_LONG;
1N/A goto malformed;
1N/A }
1N/A }
1N/A else { /* uv < ouv */
1N/A /* This cannot be allowed. */
1N/A warning = UTF8_WARN_OVERFLOW;
1N/A goto malformed;
1N/A }
1N/A }
1N/A s++;
1N/A ouv = uv;
1N/A }
1N/A
1N/A if (UNICODE_IS_SURROGATE(uv) &&
1N/A !(flags & UTF8_ALLOW_SURROGATE)) {
1N/A warning = UTF8_WARN_SURROGATE;
1N/A goto malformed;
1N/A } else if ((expectlen > (STRLEN)UNISKIP(uv)) &&
1N/A !(flags & UTF8_ALLOW_LONG)) {
1N/A warning = UTF8_WARN_LONG;
1N/A goto malformed;
1N/A } else if (UNICODE_IS_ILLEGAL(uv) &&
1N/A !(flags & UTF8_ALLOW_FFFF)) {
1N/A warning = UTF8_WARN_FFFF;
1N/A goto malformed;
1N/A }
1N/A
1N/A return uv;
1N/A
1N/Amalformed:
1N/A
1N/A if (flags & UTF8_CHECK_ONLY) {
1N/A if (retlen)
1N/A *retlen = -1;
1N/A return 0;
1N/A }
1N/A
1N/A if (dowarn) {
1N/A SV* sv = sv_2mortal(newSVpv("Malformed UTF-8 character ", 0));
1N/A
1N/A switch (warning) {
1N/A case 0: /* Intentionally empty. */ break;
1N/A case UTF8_WARN_EMPTY:
1N/A Perl_sv_catpvf(aTHX_ sv, "(empty string)");
1N/A break;
1N/A case UTF8_WARN_CONTINUATION:
1N/A Perl_sv_catpvf(aTHX_ sv, "(unexpected continuation byte 0x%02"UVxf", with no preceding start byte)", uv);
1N/A break;
1N/A case UTF8_WARN_NON_CONTINUATION:
1N/A if (s == s0)
1N/A Perl_sv_catpvf(aTHX_ sv, "(unexpected non-continuation byte 0x%02"UVxf", immediately after start byte 0x%02"UVxf")",
1N/A (UV)s[1], startbyte);
1N/A else
1N/A Perl_sv_catpvf(aTHX_ sv, "(unexpected non-continuation byte 0x%02"UVxf", %d byte%s after start byte 0x%02"UVxf", expected %d bytes)",
1N/A (UV)s[1], s - s0, s - s0 > 1 ? "s" : "", startbyte, expectlen);
1N/A
1N/A break;
1N/A case UTF8_WARN_FE_FF:
1N/A Perl_sv_catpvf(aTHX_ sv, "(byte 0x%02"UVxf")", uv);
1N/A break;
1N/A case UTF8_WARN_SHORT:
1N/A Perl_sv_catpvf(aTHX_ sv, "(%d byte%s, need %d, after start byte 0x%02"UVxf")",
1N/A curlen, curlen == 1 ? "" : "s", expectlen, startbyte);
1N/A expectlen = curlen; /* distance for caller to skip */
1N/A break;
1N/A case UTF8_WARN_OVERFLOW:
1N/A Perl_sv_catpvf(aTHX_ sv, "(overflow at 0x%"UVxf", byte 0x%02x, after start byte 0x%02"UVxf")",
1N/A ouv, *s, startbyte);
1N/A break;
1N/A case UTF8_WARN_SURROGATE:
1N/A Perl_sv_catpvf(aTHX_ sv, "(UTF-16 surrogate 0x%04"UVxf")", uv);
1N/A break;
1N/A case UTF8_WARN_LONG:
1N/A Perl_sv_catpvf(aTHX_ sv, "(%d byte%s, need %d, after start byte 0x%02"UVxf")",
1N/A expectlen, expectlen == 1 ? "": "s", UNISKIP(uv), startbyte);
1N/A break;
1N/A case UTF8_WARN_FFFF:
1N/A Perl_sv_catpvf(aTHX_ sv, "(character 0x%04"UVxf")", uv);
1N/A break;
1N/A default:
1N/A Perl_sv_catpvf(aTHX_ sv, "(unknown reason)");
1N/A break;
1N/A }
1N/A
1N/A if (warning) {
1N/A char *s = SvPVX(sv);
1N/A
1N/A if (PL_op)
1N/A Perl_warner(aTHX_ packWARN(WARN_UTF8),
1N/A "%s in %s", s, OP_DESC(PL_op));
1N/A else
1N/A Perl_warner(aTHX_ packWARN(WARN_UTF8), "%s", s);
1N/A }
1N/A }
1N/A
1N/A if (retlen)
1N/A *retlen = expectlen ? expectlen : len;
1N/A
1N/A return 0;
1N/A}
1N/A
1N/A/*
1N/A=for apidoc A|UV|utf8_to_uvchr|U8 *s|STRLEN *retlen
1N/A
1N/AReturns the native character value of the first character in the string C<s>
1N/Awhich is assumed to be in UTF-8 encoding; C<retlen> will be set to the
1N/Alength, in bytes, of that character.
1N/A
1N/AIf C<s> does not point to a well-formed UTF-8 character, zero is
1N/Areturned and retlen is set, if possible, to -1.
1N/A
1N/A=cut
1N/A*/
1N/A
1N/AUV
1N/APerl_utf8_to_uvchr(pTHX_ U8 *s, STRLEN *retlen)
1N/A{
1N/A return Perl_utf8n_to_uvchr(aTHX_ s, UTF8_MAXLEN, retlen,
1N/A ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY);
1N/A}
1N/A
1N/A/*
1N/A=for apidoc A|UV|utf8_to_uvuni|U8 *s|STRLEN *retlen
1N/A
1N/AReturns the Unicode code point of the first character in the string C<s>
1N/Awhich is assumed to be in UTF-8 encoding; C<retlen> will be set to the
1N/Alength, in bytes, of that character.
1N/A
1N/AThis function should only be used when returned UV is considered
1N/Aan index into the Unicode semantic tables (e.g. swashes).
1N/A
1N/AIf C<s> does not point to a well-formed UTF-8 character, zero is
1N/Areturned and retlen is set, if possible, to -1.
1N/A
1N/A=cut
1N/A*/
1N/A
1N/AUV
1N/APerl_utf8_to_uvuni(pTHX_ U8 *s, STRLEN *retlen)
1N/A{
1N/A /* Call the low level routine asking for checks */
1N/A return Perl_utf8n_to_uvuni(aTHX_ s, UTF8_MAXLEN, retlen,
1N/A ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY);
1N/A}
1N/A
1N/A/*
1N/A=for apidoc A|STRLEN|utf8_length|U8 *s|U8 *e
1N/A
1N/AReturn the length of the UTF-8 char encoded string C<s> in characters.
1N/AStops at C<e> (inclusive). If C<e E<lt> s> or if the scan would end
1N/Aup past C<e>, croaks.
1N/A
1N/A=cut
1N/A*/
1N/A
1N/ASTRLEN
1N/APerl_utf8_length(pTHX_ U8 *s, U8 *e)
1N/A{
1N/A STRLEN len = 0;
1N/A
1N/A /* Note: cannot use UTF8_IS_...() too eagerly here since e.g.
1N/A * the bitops (especially ~) can create illegal UTF-8.
1N/A * In other words: in Perl UTF-8 is not just for Unicode. */
1N/A
1N/A if (e < s) {
1N/A if (ckWARN_d(WARN_UTF8)) {
1N/A if (PL_op)
1N/A Perl_warner(aTHX_ packWARN(WARN_UTF8),
1N/A "%s in %s", unees, OP_DESC(PL_op));
1N/A else
1N/A Perl_warner(aTHX_ packWARN(WARN_UTF8), unees);
1N/A }
1N/A return 0;
1N/A }
1N/A while (s < e) {
1N/A U8 t = UTF8SKIP(s);
1N/A
1N/A if (e - s < t) {
1N/A if (ckWARN_d(WARN_UTF8)) {
1N/A if (PL_op)
1N/A Perl_warner(aTHX_ packWARN(WARN_UTF8),
1N/A unees, OP_DESC(PL_op));
1N/A else
1N/A Perl_warner(aTHX_ packWARN(WARN_UTF8), unees);
1N/A }
1N/A return len;
1N/A }
1N/A s += t;
1N/A len++;
1N/A }
1N/A
1N/A return len;
1N/A}
1N/A
1N/A/*
1N/A=for apidoc A|IV|utf8_distance|U8 *a|U8 *b
1N/A
1N/AReturns the number of UTF-8 characters between the UTF-8 pointers C<a>
1N/Aand C<b>.
1N/A
1N/AWARNING: use only if you *know* that the pointers point inside the
1N/Asame UTF-8 buffer.
1N/A
1N/A=cut
1N/A*/
1N/A
1N/AIV
1N/APerl_utf8_distance(pTHX_ U8 *a, U8 *b)
1N/A{
1N/A IV off = 0;
1N/A
1N/A /* Note: cannot use UTF8_IS_...() too eagerly here since e.g.
1N/A * the bitops (especially ~) can create illegal UTF-8.
1N/A * In other words: in Perl UTF-8 is not just for Unicode. */
1N/A
1N/A if (a < b) {
1N/A while (a < b) {
1N/A U8 c = UTF8SKIP(a);
1N/A
1N/A if (b - a < c) {
1N/A if (ckWARN_d(WARN_UTF8)) {
1N/A if (PL_op)
1N/A Perl_warner(aTHX_ packWARN(WARN_UTF8),
1N/A "%s in %s", unees, OP_DESC(PL_op));
1N/A else
1N/A Perl_warner(aTHX_ packWARN(WARN_UTF8), unees);
1N/A }
1N/A return off;
1N/A }
1N/A a += c;
1N/A off--;
1N/A }
1N/A }
1N/A else {
1N/A while (b < a) {
1N/A U8 c = UTF8SKIP(b);
1N/A
1N/A if (a - b < c) {
1N/A if (ckWARN_d(WARN_UTF8)) {
1N/A if (PL_op)
1N/A Perl_warner(aTHX_ packWARN(WARN_UTF8),
1N/A "%s in %s", unees, OP_DESC(PL_op));
1N/A else
1N/A Perl_warner(aTHX_ packWARN(WARN_UTF8), unees);
1N/A }
1N/A return off;
1N/A }
1N/A b += c;
1N/A off++;
1N/A }
1N/A }
1N/A
1N/A return off;
1N/A}
1N/A
1N/A/*
1N/A=for apidoc A|U8 *|utf8_hop|U8 *s|I32 off
1N/A
1N/AReturn the UTF-8 pointer C<s> displaced by C<off> characters, either
1N/Aforward or backward.
1N/A
1N/AWARNING: do not use the following unless you *know* C<off> is within
1N/Athe UTF-8 data pointed to by C<s> *and* that on entry C<s> is aligned
1N/Aon the first byte of character or just after the last byte of a character.
1N/A
1N/A=cut
1N/A*/
1N/A
1N/AU8 *
1N/APerl_utf8_hop(pTHX_ U8 *s, I32 off)
1N/A{
1N/A /* Note: cannot use UTF8_IS_...() too eagerly here since e.g
1N/A * the bitops (especially ~) can create illegal UTF-8.
1N/A * In other words: in Perl UTF-8 is not just for Unicode. */
1N/A
1N/A if (off >= 0) {
1N/A while (off--)
1N/A s += UTF8SKIP(s);
1N/A }
1N/A else {
1N/A while (off++) {
1N/A s--;
1N/A while (UTF8_IS_CONTINUATION(*s))
1N/A s--;
1N/A }
1N/A }
1N/A return s;
1N/A}
1N/A
1N/A/*
1N/A=for apidoc A|U8 *|utf8_to_bytes|U8 *s|STRLEN *len
1N/A
1N/AConverts a string C<s> of length C<len> from UTF-8 into byte encoding.
1N/AUnlike C<bytes_to_utf8>, this over-writes the original string, and
1N/Aupdates len to contain the new length.
1N/AReturns zero on failure, setting C<len> to -1.
1N/A
1N/A=cut
1N/A*/
1N/A
1N/AU8 *
1N/APerl_utf8_to_bytes(pTHX_ U8 *s, STRLEN *len)
1N/A{
1N/A U8 *send;
1N/A U8 *d;
1N/A U8 *save = s;
1N/A
1N/A /* ensure valid UTF-8 and chars < 256 before updating string */
1N/A for (send = s + *len; s < send; ) {
1N/A U8 c = *s++;
1N/A
1N/A if (!UTF8_IS_INVARIANT(c) &&
1N/A (!UTF8_IS_DOWNGRADEABLE_START(c) || (s >= send)
1N/A || !(c = *s++) || !UTF8_IS_CONTINUATION(c))) {
1N/A *len = -1;
1N/A return 0;
1N/A }
1N/A }
1N/A
1N/A d = s = save;
1N/A while (s < send) {
1N/A STRLEN ulen;
1N/A *d++ = (U8)utf8_to_uvchr(s, &ulen);
1N/A s += ulen;
1N/A }
1N/A *d = '\0';
1N/A *len = d - save;
1N/A return save;
1N/A}
1N/A
1N/A/*
1N/A=for apidoc A|U8 *|bytes_from_utf8|U8 *s|STRLEN *len|bool *is_utf8
1N/A
1N/AConverts a string C<s> of length C<len> from UTF-8 into byte encoding.
1N/AUnlike <utf8_to_bytes> but like C<bytes_to_utf8>, returns a pointer to
1N/Athe newly-created string, and updates C<len> to contain the new
1N/Alength. Returns the original string if no conversion occurs, C<len>
1N/Ais unchanged. Do nothing if C<is_utf8> points to 0. Sets C<is_utf8> to
1N/A0 if C<s> is converted or contains all 7bit characters.
1N/A
1N/A=cut
1N/A*/
1N/A
1N/AU8 *
1N/APerl_bytes_from_utf8(pTHX_ U8 *s, STRLEN *len, bool *is_utf8)
1N/A{
1N/A U8 *d;
1N/A U8 *start = s;
1N/A U8 *send;
1N/A I32 count = 0;
1N/A
1N/A if (!*is_utf8)
1N/A return start;
1N/A
1N/A /* ensure valid UTF-8 and chars < 256 before converting string */
1N/A for (send = s + *len; s < send;) {
1N/A U8 c = *s++;
1N/A if (!UTF8_IS_INVARIANT(c)) {
1N/A if (UTF8_IS_DOWNGRADEABLE_START(c) && s < send &&
1N/A (c = *s++) && UTF8_IS_CONTINUATION(c))
1N/A count++;
1N/A else
1N/A return start;
1N/A }
1N/A }
1N/A
1N/A *is_utf8 = 0;
1N/A
1N/A Newz(801, d, (*len) - count + 1, U8);
1N/A s = start; start = d;
1N/A while (s < send) {
1N/A U8 c = *s++;
1N/A if (!UTF8_IS_INVARIANT(c)) {
1N/A /* Then it is two-byte encoded */
1N/A c = UTF8_ACCUMULATE(NATIVE_TO_UTF(c), *s++);
1N/A c = ASCII_TO_NATIVE(c);
1N/A }
1N/A *d++ = c;
1N/A }
1N/A *d = '\0';
1N/A *len = d - start;
1N/A return start;
1N/A}
1N/A
1N/A/*
1N/A=for apidoc A|U8 *|bytes_to_utf8|U8 *s|STRLEN *len
1N/A
1N/AConverts a string C<s> of length C<len> from ASCII into UTF-8 encoding.
1N/AReturns a pointer to the newly-created string, and sets C<len> to
1N/Areflect the new length.
1N/A
1N/AIf you want to convert to UTF-8 from other encodings than ASCII,
1N/Asee sv_recode_to_utf8().
1N/A
1N/A=cut
1N/A*/
1N/A
1N/AU8*
1N/APerl_bytes_to_utf8(pTHX_ U8 *s, STRLEN *len)
1N/A{
1N/A U8 *send;
1N/A U8 *d;
1N/A U8 *dst;
1N/A send = s + (*len);
1N/A
1N/A Newz(801, d, (*len) * 2 + 1, U8);
1N/A dst = d;
1N/A
1N/A while (s < send) {
1N/A UV uv = NATIVE_TO_ASCII(*s++);
1N/A if (UNI_IS_INVARIANT(uv))
1N/A *d++ = (U8)UTF_TO_NATIVE(uv);
1N/A else {
1N/A *d++ = (U8)UTF8_EIGHT_BIT_HI(uv);
1N/A *d++ = (U8)UTF8_EIGHT_BIT_LO(uv);
1N/A }
1N/A }
1N/A *d = '\0';
1N/A *len = d-dst;
1N/A return dst;
1N/A}
1N/A
1N/A/*
1N/A * Convert native (big-endian) or reversed (little-endian) UTF-16 to UTF-8.
1N/A *
1N/A * Destination must be pre-extended to 3/2 source. Do not use in-place.
1N/A * We optimize for native, for obvious reasons. */
1N/A
1N/AU8*
1N/APerl_utf16_to_utf8(pTHX_ U8* p, U8* d, I32 bytelen, I32 *newlen)
1N/A{
1N/A U8* pend;
1N/A U8* dstart = d;
1N/A
1N/A if (bytelen & 1)
1N/A Perl_croak(aTHX_ "panic: utf16_to_utf8: odd bytelen");
1N/A
1N/A pend = p + bytelen;
1N/A
1N/A while (p < pend) {
1N/A UV uv = (p[0] << 8) + p[1]; /* UTF-16BE */
1N/A p += 2;
1N/A if (uv < 0x80) {
1N/A *d++ = (U8)uv;
1N/A continue;
1N/A }
1N/A if (uv < 0x800) {
1N/A *d++ = (U8)(( uv >> 6) | 0xc0);
1N/A *d++ = (U8)(( uv & 0x3f) | 0x80);
1N/A continue;
1N/A }
1N/A if (uv >= 0xd800 && uv < 0xdbff) { /* surrogates */
1N/A UV low = (p[0] << 8) + p[1];
1N/A p += 2;
1N/A if (low < 0xdc00 || low >= 0xdfff)
1N/A Perl_croak(aTHX_ "Malformed UTF-16 surrogate");
1N/A uv = ((uv - 0xd800) << 10) + (low - 0xdc00) + 0x10000;
1N/A }
1N/A if (uv < 0x10000) {
1N/A *d++ = (U8)(( uv >> 12) | 0xe0);
1N/A *d++ = (U8)(((uv >> 6) & 0x3f) | 0x80);
1N/A *d++ = (U8)(( uv & 0x3f) | 0x80);
1N/A continue;
1N/A }
1N/A else {
1N/A *d++ = (U8)(( uv >> 18) | 0xf0);
1N/A *d++ = (U8)(((uv >> 12) & 0x3f) | 0x80);
1N/A *d++ = (U8)(((uv >> 6) & 0x3f) | 0x80);
1N/A *d++ = (U8)(( uv & 0x3f) | 0x80);
1N/A continue;
1N/A }
1N/A }
1N/A *newlen = d - dstart;
1N/A return d;
1N/A}
1N/A
1N/A/* Note: this one is slightly destructive of the source. */
1N/A
1N/AU8*
1N/APerl_utf16_to_utf8_reversed(pTHX_ U8* p, U8* d, I32 bytelen, I32 *newlen)
1N/A{
1N/A U8* s = (U8*)p;
1N/A U8* send = s + bytelen;
1N/A while (s < send) {
1N/A U8 tmp = s[0];
1N/A s[0] = s[1];
1N/A s[1] = tmp;
1N/A s += 2;
1N/A }
1N/A return utf16_to_utf8(p, d, bytelen, newlen);
1N/A}
1N/A
1N/A/* for now these are all defined (inefficiently) in terms of the utf8 versions */
1N/A
1N/Abool
1N/APerl_is_uni_alnum(pTHX_ UV c)
1N/A{
1N/A U8 tmpbuf[UTF8_MAXLEN+1];
1N/A uvchr_to_utf8(tmpbuf, c);
1N/A return is_utf8_alnum(tmpbuf);
1N/A}
1N/A
1N/Abool
1N/APerl_is_uni_alnumc(pTHX_ UV c)
1N/A{
1N/A U8 tmpbuf[UTF8_MAXLEN+1];
1N/A uvchr_to_utf8(tmpbuf, c);
1N/A return is_utf8_alnumc(tmpbuf);
1N/A}
1N/A
1N/Abool
1N/APerl_is_uni_idfirst(pTHX_ UV c)
1N/A{
1N/A U8 tmpbuf[UTF8_MAXLEN+1];
1N/A uvchr_to_utf8(tmpbuf, c);
1N/A return is_utf8_idfirst(tmpbuf);
1N/A}
1N/A
1N/Abool
1N/APerl_is_uni_alpha(pTHX_ UV c)
1N/A{
1N/A U8 tmpbuf[UTF8_MAXLEN+1];
1N/A uvchr_to_utf8(tmpbuf, c);
1N/A return is_utf8_alpha(tmpbuf);
1N/A}
1N/A
1N/Abool
1N/APerl_is_uni_ascii(pTHX_ UV c)
1N/A{
1N/A U8 tmpbuf[UTF8_MAXLEN+1];
1N/A uvchr_to_utf8(tmpbuf, c);
1N/A return is_utf8_ascii(tmpbuf);
1N/A}
1N/A
1N/Abool
1N/APerl_is_uni_space(pTHX_ UV c)
1N/A{
1N/A U8 tmpbuf[UTF8_MAXLEN+1];
1N/A uvchr_to_utf8(tmpbuf, c);
1N/A return is_utf8_space(tmpbuf);
1N/A}
1N/A
1N/Abool
1N/APerl_is_uni_digit(pTHX_ UV c)
1N/A{
1N/A U8 tmpbuf[UTF8_MAXLEN+1];
1N/A uvchr_to_utf8(tmpbuf, c);
1N/A return is_utf8_digit(tmpbuf);
1N/A}
1N/A
1N/Abool
1N/APerl_is_uni_upper(pTHX_ UV c)
1N/A{
1N/A U8 tmpbuf[UTF8_MAXLEN+1];
1N/A uvchr_to_utf8(tmpbuf, c);
1N/A return is_utf8_upper(tmpbuf);
1N/A}
1N/A
1N/Abool
1N/APerl_is_uni_lower(pTHX_ UV c)
1N/A{
1N/A U8 tmpbuf[UTF8_MAXLEN+1];
1N/A uvchr_to_utf8(tmpbuf, c);
1N/A return is_utf8_lower(tmpbuf);
1N/A}
1N/A
1N/Abool
1N/APerl_is_uni_cntrl(pTHX_ UV c)
1N/A{
1N/A U8 tmpbuf[UTF8_MAXLEN+1];
1N/A uvchr_to_utf8(tmpbuf, c);
1N/A return is_utf8_cntrl(tmpbuf);
1N/A}
1N/A
1N/Abool
1N/APerl_is_uni_graph(pTHX_ UV c)
1N/A{
1N/A U8 tmpbuf[UTF8_MAXLEN+1];
1N/A uvchr_to_utf8(tmpbuf, c);
1N/A return is_utf8_graph(tmpbuf);
1N/A}
1N/A
1N/Abool
1N/APerl_is_uni_print(pTHX_ UV c)
1N/A{
1N/A U8 tmpbuf[UTF8_MAXLEN+1];
1N/A uvchr_to_utf8(tmpbuf, c);
1N/A return is_utf8_print(tmpbuf);
1N/A}
1N/A
1N/Abool
1N/APerl_is_uni_punct(pTHX_ UV c)
1N/A{
1N/A U8 tmpbuf[UTF8_MAXLEN+1];
1N/A uvchr_to_utf8(tmpbuf, c);
1N/A return is_utf8_punct(tmpbuf);
1N/A}
1N/A
1N/Abool
1N/APerl_is_uni_xdigit(pTHX_ UV c)
1N/A{
1N/A U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
1N/A uvchr_to_utf8(tmpbuf, c);
1N/A return is_utf8_xdigit(tmpbuf);
1N/A}
1N/A
1N/AUV
1N/APerl_to_uni_upper(pTHX_ UV c, U8* p, STRLEN *lenp)
1N/A{
1N/A uvchr_to_utf8(p, c);
1N/A return to_utf8_upper(p, p, lenp);
1N/A}
1N/A
1N/AUV
1N/APerl_to_uni_title(pTHX_ UV c, U8* p, STRLEN *lenp)
1N/A{
1N/A uvchr_to_utf8(p, c);
1N/A return to_utf8_title(p, p, lenp);
1N/A}
1N/A
1N/AUV
1N/APerl_to_uni_lower(pTHX_ UV c, U8* p, STRLEN *lenp)
1N/A{
1N/A uvchr_to_utf8(p, c);
1N/A return to_utf8_lower(p, p, lenp);
1N/A}
1N/A
1N/AUV
1N/APerl_to_uni_fold(pTHX_ UV c, U8* p, STRLEN *lenp)
1N/A{
1N/A uvchr_to_utf8(p, c);
1N/A return to_utf8_fold(p, p, lenp);
1N/A}
1N/A
1N/A/* for now these all assume no locale info available for Unicode > 255 */
1N/A
1N/Abool
1N/APerl_is_uni_alnum_lc(pTHX_ UV c)
1N/A{
1N/A return is_uni_alnum(c); /* XXX no locale support yet */
1N/A}
1N/A
1N/Abool
1N/APerl_is_uni_alnumc_lc(pTHX_ UV c)
1N/A{
1N/A return is_uni_alnumc(c); /* XXX no locale support yet */
1N/A}
1N/A
1N/Abool
1N/APerl_is_uni_idfirst_lc(pTHX_ UV c)
1N/A{
1N/A return is_uni_idfirst(c); /* XXX no locale support yet */
1N/A}
1N/A
1N/Abool
1N/APerl_is_uni_alpha_lc(pTHX_ UV c)
1N/A{
1N/A return is_uni_alpha(c); /* XXX no locale support yet */
1N/A}
1N/A
1N/Abool
1N/APerl_is_uni_ascii_lc(pTHX_ UV c)
1N/A{
1N/A return is_uni_ascii(c); /* XXX no locale support yet */
1N/A}
1N/A
1N/Abool
1N/APerl_is_uni_space_lc(pTHX_ UV c)
1N/A{
1N/A return is_uni_space(c); /* XXX no locale support yet */
1N/A}
1N/A
1N/Abool
1N/APerl_is_uni_digit_lc(pTHX_ UV c)
1N/A{
1N/A return is_uni_digit(c); /* XXX no locale support yet */
1N/A}
1N/A
1N/Abool
1N/APerl_is_uni_upper_lc(pTHX_ UV c)
1N/A{
1N/A return is_uni_upper(c); /* XXX no locale support yet */
1N/A}
1N/A
1N/Abool
1N/APerl_is_uni_lower_lc(pTHX_ UV c)
1N/A{
1N/A return is_uni_lower(c); /* XXX no locale support yet */
1N/A}
1N/A
1N/Abool
1N/APerl_is_uni_cntrl_lc(pTHX_ UV c)
1N/A{
1N/A return is_uni_cntrl(c); /* XXX no locale support yet */
1N/A}
1N/A
1N/Abool
1N/APerl_is_uni_graph_lc(pTHX_ UV c)
1N/A{
1N/A return is_uni_graph(c); /* XXX no locale support yet */
1N/A}
1N/A
1N/Abool
1N/APerl_is_uni_print_lc(pTHX_ UV c)
1N/A{
1N/A return is_uni_print(c); /* XXX no locale support yet */
1N/A}
1N/A
1N/Abool
1N/APerl_is_uni_punct_lc(pTHX_ UV c)
1N/A{
1N/A return is_uni_punct(c); /* XXX no locale support yet */
1N/A}
1N/A
1N/Abool
1N/APerl_is_uni_xdigit_lc(pTHX_ UV c)
1N/A{
1N/A return is_uni_xdigit(c); /* XXX no locale support yet */
1N/A}
1N/A
1N/AU32
1N/APerl_to_uni_upper_lc(pTHX_ U32 c)
1N/A{
1N/A /* XXX returns only the first character -- do not use XXX */
1N/A /* XXX no locale support yet */
1N/A STRLEN len;
1N/A U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
1N/A return (U32)to_uni_upper(c, tmpbuf, &len);
1N/A}
1N/A
1N/AU32
1N/APerl_to_uni_title_lc(pTHX_ U32 c)
1N/A{
1N/A /* XXX returns only the first character XXX -- do not use XXX */
1N/A /* XXX no locale support yet */
1N/A STRLEN len;
1N/A U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
1N/A return (U32)to_uni_title(c, tmpbuf, &len);
1N/A}
1N/A
1N/AU32
1N/APerl_to_uni_lower_lc(pTHX_ U32 c)
1N/A{
1N/A /* XXX returns only the first character -- do not use XXX */
1N/A /* XXX no locale support yet */
1N/A STRLEN len;
1N/A U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
1N/A return (U32)to_uni_lower(c, tmpbuf, &len);
1N/A}
1N/A
1N/Abool
1N/APerl_is_utf8_alnum(pTHX_ U8 *p)
1N/A{
1N/A if (!is_utf8_char(p))
1N/A return FALSE;
1N/A if (!PL_utf8_alnum)
1N/A /* NOTE: "IsWord", not "IsAlnum", since Alnum is a true
1N/A * descendant of isalnum(3), in other words, it doesn't
1N/A * contain the '_'. --jhi */
1N/A PL_utf8_alnum = swash_init("utf8", "IsWord", &PL_sv_undef, 0, 0);
1N/A return swash_fetch(PL_utf8_alnum, p, TRUE) != 0;
1N/A/* return *p == '_' || is_utf8_alpha(p) || is_utf8_digit(p); */
1N/A#ifdef SURPRISINGLY_SLOWER /* probably because alpha is usually true */
1N/A if (!PL_utf8_alnum)
1N/A PL_utf8_alnum = swash_init("utf8", "",
1N/A sv_2mortal(newSVpv("+utf8::IsAlpha\n+utf8::IsDigit\n005F\n",0)), 0, 0);
1N/A return swash_fetch(PL_utf8_alnum, p, TRUE) != 0;
1N/A#endif
1N/A}
1N/A
1N/Abool
1N/APerl_is_utf8_alnumc(pTHX_ U8 *p)
1N/A{
1N/A if (!is_utf8_char(p))
1N/A return FALSE;
1N/A if (!PL_utf8_alnum)
1N/A PL_utf8_alnum = swash_init("utf8", "IsAlnumC", &PL_sv_undef, 0, 0);
1N/A return swash_fetch(PL_utf8_alnum, p, TRUE) != 0;
1N/A/* return is_utf8_alpha(p) || is_utf8_digit(p); */
1N/A#ifdef SURPRISINGLY_SLOWER /* probably because alpha is usually true */
1N/A if (!PL_utf8_alnum)
1N/A PL_utf8_alnum = swash_init("utf8", "",
1N/A sv_2mortal(newSVpv("+utf8::IsAlpha\n+utf8::IsDigit\n005F\n",0)), 0, 0);
1N/A return swash_fetch(PL_utf8_alnum, p, TRUE) != 0;
1N/A#endif
1N/A}
1N/A
1N/Abool
1N/APerl_is_utf8_idfirst(pTHX_ U8 *p) /* The naming is historical. */
1N/A{
1N/A if (*p == '_')
1N/A return TRUE;
1N/A if (!is_utf8_char(p))
1N/A return FALSE;
1N/A if (!PL_utf8_idstart) /* is_utf8_idstart would be more logical. */
1N/A PL_utf8_idstart = swash_init("utf8", "IdStart", &PL_sv_undef, 0, 0);
1N/A return swash_fetch(PL_utf8_idstart, p, TRUE) != 0;
1N/A}
1N/A
1N/Abool
1N/APerl_is_utf8_idcont(pTHX_ U8 *p)
1N/A{
1N/A if (*p == '_')
1N/A return TRUE;
1N/A if (!is_utf8_char(p))
1N/A return FALSE;
1N/A if (!PL_utf8_idcont)
1N/A PL_utf8_idcont = swash_init("utf8", "IdContinue", &PL_sv_undef, 0, 0);
1N/A return swash_fetch(PL_utf8_idcont, p, TRUE) != 0;
1N/A}
1N/A
1N/Abool
1N/APerl_is_utf8_alpha(pTHX_ U8 *p)
1N/A{
1N/A if (!is_utf8_char(p))
1N/A return FALSE;
1N/A if (!PL_utf8_alpha)
1N/A PL_utf8_alpha = swash_init("utf8", "IsAlpha", &PL_sv_undef, 0, 0);
1N/A return swash_fetch(PL_utf8_alpha, p, TRUE) != 0;
1N/A}
1N/A
1N/Abool
1N/APerl_is_utf8_ascii(pTHX_ U8 *p)
1N/A{
1N/A if (!is_utf8_char(p))
1N/A return FALSE;
1N/A if (!PL_utf8_ascii)
1N/A PL_utf8_ascii = swash_init("utf8", "IsAscii", &PL_sv_undef, 0, 0);
1N/A return swash_fetch(PL_utf8_ascii, p, TRUE) != 0;
1N/A}
1N/A
1N/Abool
1N/APerl_is_utf8_space(pTHX_ U8 *p)
1N/A{
1N/A if (!is_utf8_char(p))
1N/A return FALSE;
1N/A if (!PL_utf8_space)
1N/A PL_utf8_space = swash_init("utf8", "IsSpacePerl", &PL_sv_undef, 0, 0);
1N/A return swash_fetch(PL_utf8_space, p, TRUE) != 0;
1N/A}
1N/A
1N/Abool
1N/APerl_is_utf8_digit(pTHX_ U8 *p)
1N/A{
1N/A if (!is_utf8_char(p))
1N/A return FALSE;
1N/A if (!PL_utf8_digit)
1N/A PL_utf8_digit = swash_init("utf8", "IsDigit", &PL_sv_undef, 0, 0);
1N/A return swash_fetch(PL_utf8_digit, p, TRUE) != 0;
1N/A}
1N/A
1N/Abool
1N/APerl_is_utf8_upper(pTHX_ U8 *p)
1N/A{
1N/A if (!is_utf8_char(p))
1N/A return FALSE;
1N/A if (!PL_utf8_upper)
1N/A PL_utf8_upper = swash_init("utf8", "IsUppercase", &PL_sv_undef, 0, 0);
1N/A return swash_fetch(PL_utf8_upper, p, TRUE) != 0;
1N/A}
1N/A
1N/Abool
1N/APerl_is_utf8_lower(pTHX_ U8 *p)
1N/A{
1N/A if (!is_utf8_char(p))
1N/A return FALSE;
1N/A if (!PL_utf8_lower)
1N/A PL_utf8_lower = swash_init("utf8", "IsLowercase", &PL_sv_undef, 0, 0);
1N/A return swash_fetch(PL_utf8_lower, p, TRUE) != 0;
1N/A}
1N/A
1N/Abool
1N/APerl_is_utf8_cntrl(pTHX_ U8 *p)
1N/A{
1N/A if (!is_utf8_char(p))
1N/A return FALSE;
1N/A if (!PL_utf8_cntrl)
1N/A PL_utf8_cntrl = swash_init("utf8", "IsCntrl", &PL_sv_undef, 0, 0);
1N/A return swash_fetch(PL_utf8_cntrl, p, TRUE) != 0;
1N/A}
1N/A
1N/Abool
1N/APerl_is_utf8_graph(pTHX_ U8 *p)
1N/A{
1N/A if (!is_utf8_char(p))
1N/A return FALSE;
1N/A if (!PL_utf8_graph)
1N/A PL_utf8_graph = swash_init("utf8", "IsGraph", &PL_sv_undef, 0, 0);
1N/A return swash_fetch(PL_utf8_graph, p, TRUE) != 0;
1N/A}
1N/A
1N/Abool
1N/APerl_is_utf8_print(pTHX_ U8 *p)
1N/A{
1N/A if (!is_utf8_char(p))
1N/A return FALSE;
1N/A if (!PL_utf8_print)
1N/A PL_utf8_print = swash_init("utf8", "IsPrint", &PL_sv_undef, 0, 0);
1N/A return swash_fetch(PL_utf8_print, p, TRUE) != 0;
1N/A}
1N/A
1N/Abool
1N/APerl_is_utf8_punct(pTHX_ U8 *p)
1N/A{
1N/A if (!is_utf8_char(p))
1N/A return FALSE;
1N/A if (!PL_utf8_punct)
1N/A PL_utf8_punct = swash_init("utf8", "IsPunct", &PL_sv_undef, 0, 0);
1N/A return swash_fetch(PL_utf8_punct, p, TRUE) != 0;
1N/A}
1N/A
1N/Abool
1N/APerl_is_utf8_xdigit(pTHX_ U8 *p)
1N/A{
1N/A if (!is_utf8_char(p))
1N/A return FALSE;
1N/A if (!PL_utf8_xdigit)
1N/A PL_utf8_xdigit = swash_init("utf8", "IsXDigit", &PL_sv_undef, 0, 0);
1N/A return swash_fetch(PL_utf8_xdigit, p, TRUE) != 0;
1N/A}
1N/A
1N/Abool
1N/APerl_is_utf8_mark(pTHX_ U8 *p)
1N/A{
1N/A if (!is_utf8_char(p))
1N/A return FALSE;
1N/A if (!PL_utf8_mark)
1N/A PL_utf8_mark = swash_init("utf8", "IsM", &PL_sv_undef, 0, 0);
1N/A return swash_fetch(PL_utf8_mark, p, TRUE) != 0;
1N/A}
1N/A
1N/A/*
1N/A=for apidoc A|UV|to_utf8_case|U8 *p|U8* ustrp|STRLEN *lenp|SV **swash|char *normal|char *special
1N/A
1N/AThe "p" contains the pointer to the UTF-8 string encoding
1N/Athe character that is being converted.
1N/A
1N/AThe "ustrp" is a pointer to the character buffer to put the
1N/Aconversion result to. The "lenp" is a pointer to the length
1N/Aof the result.
1N/A
1N/AThe "swashp" is a pointer to the swash to use.
1N/A
1N/ABoth the special and normal mappings are stored lib/unicore/To/Foo.pl,
1N/Aand loaded by SWASHGET, using lib/utf8_heavy.pl. The special (usually,
1N/Abut not always, a multicharacter mapping), is tried first.
1N/A
1N/AThe "special" is a string like "utf8::ToSpecLower", which means the
1N/Ahash %utf8::ToSpecLower. The access to the hash is through
1N/APerl_to_utf8_case().
1N/A
1N/AThe "normal" is a string like "ToLower" which means the swash
1N/A%utf8::ToLower.
1N/A
1N/A=cut */
1N/A
1N/AUV
1N/APerl_to_utf8_case(pTHX_ U8 *p, U8* ustrp, STRLEN *lenp, SV **swashp, char *normal, char *special)
1N/A{
1N/A UV uv0, uv1;
1N/A U8 tmpbuf[UTF8_MAXLEN_FOLD+1];
1N/A STRLEN len = 0;
1N/A
1N/A uv0 = utf8_to_uvchr(p, 0);
1N/A /* The NATIVE_TO_UNI() and UNI_TO_NATIVE() mappings
1N/A * are necessary in EBCDIC, they are redundant no-ops
1N/A * in ASCII-ish platforms, and hopefully optimized away. */
1N/A uv1 = NATIVE_TO_UNI(uv0);
1N/A uvuni_to_utf8(tmpbuf, uv1);
1N/A
1N/A if (!*swashp) /* load on-demand */
1N/A *swashp = swash_init("utf8", normal, &PL_sv_undef, 4, 0);
1N/A
1N/A /* The 0xDF is the only special casing Unicode code point below 0x100. */
1N/A if (special && (uv1 == 0xDF || uv1 > 0xFF)) {
1N/A /* It might be "special" (sometimes, but not always,
1N/A * a multicharacter mapping) */
1N/A HV *hv;
1N/A SV **svp;
1N/A
1N/A if ((hv = get_hv(special, FALSE)) &&
1N/A (svp = hv_fetch(hv, (const char*)tmpbuf, UNISKIP(uv1), FALSE)) &&
1N/A (*svp)) {
1N/A char *s;
1N/A
1N/A s = SvPV(*svp, len);
1N/A if (len == 1)
1N/A len = uvuni_to_utf8(ustrp, NATIVE_TO_UNI(*(U8*)s)) - ustrp;
1N/A else {
1N/A#ifdef EBCDIC
1N/A /* If we have EBCDIC we need to remap the characters
1N/A * since any characters in the low 256 are Unicode
1N/A * code points, not EBCDIC. */
1N/A U8 *t = (U8*)s, *tend = t + len, *d;
1N/A
1N/A d = tmpbuf;
1N/A if (SvUTF8(*svp)) {
1N/A STRLEN tlen = 0;
1N/A
1N/A while (t < tend) {
1N/A UV c = utf8_to_uvchr(t, &tlen);
1N/A if (tlen > 0) {
1N/A d = uvchr_to_utf8(d, UNI_TO_NATIVE(c));
1N/A t += tlen;
1N/A }
1N/A else
1N/A break;
1N/A }
1N/A }
1N/A else {
1N/A while (t < tend) {
1N/A d = uvchr_to_utf8(d, UNI_TO_NATIVE(*t));
1N/A t++;
1N/A }
1N/A }
1N/A len = d - tmpbuf;
1N/A Copy(tmpbuf, ustrp, len, U8);
1N/A#else
1N/A Copy(s, ustrp, len, U8);
1N/A#endif
1N/A }
1N/A }
1N/A }
1N/A
1N/A if (!len && *swashp) {
1N/A UV uv2 = swash_fetch(*swashp, tmpbuf, TRUE);
1N/A
1N/A if (uv2) {
1N/A /* It was "normal" (a single character mapping). */
1N/A UV uv3 = UNI_TO_NATIVE(uv2);
1N/A
1N/A len = uvchr_to_utf8(ustrp, uv3) - ustrp;
1N/A }
1N/A }
1N/A
1N/A if (!len) /* Neither: just copy. */
1N/A len = uvchr_to_utf8(ustrp, uv0) - ustrp;
1N/A
1N/A if (lenp)
1N/A *lenp = len;
1N/A
1N/A return len ? utf8_to_uvchr(ustrp, 0) : 0;
1N/A}
1N/A
1N/A/*
1N/A=for apidoc A|UV|to_utf8_upper|U8 *p|U8 *ustrp|STRLEN *lenp
1N/A
1N/AConvert the UTF-8 encoded character at p to its uppercase version and
1N/Astore that in UTF-8 in ustrp and its length in bytes in lenp. Note
1N/Athat the ustrp needs to be at least UTF8_MAXLEN_UCLC+1 bytes since the
1N/Auppercase version may be longer than the original character (up to two
1N/Acharacters).
1N/A
1N/AThe first character of the uppercased version is returned
1N/A(but note, as explained above, that there may be more.)
1N/A
1N/A=cut */
1N/A
1N/AUV
1N/APerl_to_utf8_upper(pTHX_ U8 *p, U8* ustrp, STRLEN *lenp)
1N/A{
1N/A return Perl_to_utf8_case(aTHX_ p, ustrp, lenp,
1N/A &PL_utf8_toupper, "ToUpper", "utf8::ToSpecUpper");
1N/A}
1N/A
1N/A/*
1N/A=for apidoc A|UV|to_utf8_title|U8 *p|U8 *ustrp|STRLEN *lenp
1N/A
1N/AConvert the UTF-8 encoded character at p to its titlecase version and
1N/Astore that in UTF-8 in ustrp and its length in bytes in lenp. Note
1N/Athat the ustrp needs to be at least UTF8_MAXLEN_UCLC+1 bytes since the
1N/Atitlecase version may be longer than the original character (up to two
1N/Acharacters).
1N/A
1N/AThe first character of the titlecased version is returned
1N/A(but note, as explained above, that there may be more.)
1N/A
1N/A=cut */
1N/A
1N/AUV
1N/APerl_to_utf8_title(pTHX_ U8 *p, U8* ustrp, STRLEN *lenp)
1N/A{
1N/A return Perl_to_utf8_case(aTHX_ p, ustrp, lenp,
1N/A &PL_utf8_totitle, "ToTitle", "utf8::ToSpecTitle");
1N/A}
1N/A
1N/A/*
1N/A=for apidoc A|UV|to_utf8_lower|U8 *p|U8 *ustrp|STRLEN *lenp
1N/A
1N/AConvert the UTF-8 encoded character at p to its lowercase version and
1N/Astore that in UTF-8 in ustrp and its length in bytes in lenp. Note
1N/Athat the ustrp needs to be at least UTF8_MAXLEN_UCLC+1 bytes since the
1N/Alowercase version may be longer than the original character (up to two
1N/Acharacters).
1N/A
1N/AThe first character of the lowercased version is returned
1N/A(but note, as explained above, that there may be more.)
1N/A
1N/A=cut */
1N/A
1N/AUV
1N/APerl_to_utf8_lower(pTHX_ U8 *p, U8* ustrp, STRLEN *lenp)
1N/A{
1N/A return Perl_to_utf8_case(aTHX_ p, ustrp, lenp,
1N/A &PL_utf8_tolower, "ToLower", "utf8::ToSpecLower");
1N/A}
1N/A
1N/A/*
1N/A=for apidoc A|UV|to_utf8_fold|U8 *p|U8 *ustrp|STRLEN *lenp
1N/A
1N/AConvert the UTF-8 encoded character at p to its foldcase version and
1N/Astore that in UTF-8 in ustrp and its length in bytes in lenp. Note
1N/Athat the ustrp needs to be at least UTF8_MAXLEN_FOLD+1 bytes since the
1N/Afoldcase version may be longer than the original character (up to
1N/Athree characters).
1N/A
1N/AThe first character of the foldcased version is returned
1N/A(but note, as explained above, that there may be more.)
1N/A
1N/A=cut */
1N/A
1N/AUV
1N/APerl_to_utf8_fold(pTHX_ U8 *p, U8* ustrp, STRLEN *lenp)
1N/A{
1N/A return Perl_to_utf8_case(aTHX_ p, ustrp, lenp,
1N/A &PL_utf8_tofold, "ToFold", "utf8::ToSpecFold");
1N/A}
1N/A
1N/A/* a "swash" is a swatch hash */
1N/A
1N/ASV*
1N/APerl_swash_init(pTHX_ char* pkg, char* name, SV *listsv, I32 minbits, I32 none)
1N/A{
1N/A SV* retval;
1N/A SV* tokenbufsv = sv_2mortal(NEWSV(0,0));
1N/A dSP;
1N/A HV *stash = gv_stashpvn(pkg, strlen(pkg), FALSE);
1N/A SV* errsv_save;
1N/A
1N/A if (!gv_fetchmeth(stash, "SWASHNEW", 8, -1)) { /* demand load utf8 */
1N/A ENTER;
1N/A errsv_save = newSVsv(ERRSV);
1N/A Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpv(pkg,0), Nullsv);
1N/A if (!SvTRUE(ERRSV))
1N/A sv_setsv(ERRSV, errsv_save);
1N/A SvREFCNT_dec(errsv_save);
1N/A LEAVE;
1N/A }
1N/A SPAGAIN;
1N/A PUSHSTACKi(PERLSI_MAGIC);
1N/A PUSHMARK(SP);
1N/A EXTEND(SP,5);
1N/A PUSHs(sv_2mortal(newSVpvn(pkg, strlen(pkg))));
1N/A PUSHs(sv_2mortal(newSVpvn(name, strlen(name))));
1N/A PUSHs(listsv);
1N/A PUSHs(sv_2mortal(newSViv(minbits)));
1N/A PUSHs(sv_2mortal(newSViv(none)));
1N/A PUTBACK;
1N/A ENTER;
1N/A SAVEI32(PL_hints);
1N/A PL_hints = 0;
1N/A save_re_context();
1N/A if (IN_PERL_COMPILETIME) {
1N/A /* XXX ought to be handled by lex_start */
1N/A SAVEI32(PL_in_my);
1N/A PL_in_my = 0;
1N/A sv_setpv(tokenbufsv, PL_tokenbuf);
1N/A }
1N/A errsv_save = newSVsv(ERRSV);
1N/A if (call_method("SWASHNEW", G_SCALAR))
1N/A retval = newSVsv(*PL_stack_sp--);
1N/A else
1N/A retval = &PL_sv_undef;
1N/A if (!SvTRUE(ERRSV))
1N/A sv_setsv(ERRSV, errsv_save);
1N/A SvREFCNT_dec(errsv_save);
1N/A LEAVE;
1N/A POPSTACK;
1N/A if (IN_PERL_COMPILETIME) {
1N/A STRLEN len;
1N/A char* pv = SvPV(tokenbufsv, len);
1N/A
1N/A Copy(pv, PL_tokenbuf, len+1, char);
1N/A PL_curcop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
1N/A }
1N/A if (!SvROK(retval) || SvTYPE(SvRV(retval)) != SVt_PVHV) {
1N/A if (SvPOK(retval))
1N/A Perl_croak(aTHX_ "Can't find Unicode property definition \"%"SVf"\"",
1N/A retval);
1N/A Perl_croak(aTHX_ "SWASHNEW didn't return an HV ref");
1N/A }
1N/A return retval;
1N/A}
1N/A
1N/A
1N/A/* This API is wrong for special case conversions since we may need to
1N/A * return several Unicode characters for a single Unicode character
1N/A * (see lib/unicore/SpecCase.txt) The SWASHGET in lib/utf8_heavy.pl is
1N/A * the lower-level routine, and it is similarly broken for returning
1N/A * multiple values. --jhi */
1N/AUV
1N/APerl_swash_fetch(pTHX_ SV *sv, U8 *ptr, bool do_utf8)
1N/A{
1N/A HV* hv = (HV*)SvRV(sv);
1N/A U32 klen;
1N/A U32 off;
1N/A STRLEN slen;
1N/A STRLEN needents;
1N/A U8 *tmps = NULL;
1N/A U32 bit;
1N/A SV *retval;
1N/A U8 tmputf8[2];
1N/A UV c = NATIVE_TO_ASCII(*ptr);
1N/A
1N/A if (!do_utf8 && !UNI_IS_INVARIANT(c)) {
1N/A tmputf8[0] = (U8)UTF8_EIGHT_BIT_HI(c);
1N/A tmputf8[1] = (U8)UTF8_EIGHT_BIT_LO(c);
1N/A ptr = tmputf8;
1N/A }
1N/A /* Given a UTF-X encoded char 0xAA..0xYY,0xZZ
1N/A * then the "swatch" is a vec() for al the chars which start
1N/A * with 0xAA..0xYY
1N/A * So the key in the hash (klen) is length of encoded char -1
1N/A */
1N/A klen = UTF8SKIP(ptr) - 1;
1N/A off = ptr[klen];
1N/A
1N/A if (klen == 0)
1N/A {
1N/A /* If char in invariant then swatch is for all the invariant chars
1N/A * In both UTF-8 and UTF-8-MOD that happens to be UTF_CONTINUATION_MARK
1N/A */
1N/A needents = UTF_CONTINUATION_MARK;
1N/A off = NATIVE_TO_UTF(ptr[klen]);
1N/A }
1N/A else
1N/A {
1N/A /* If char is encoded then swatch is for the prefix */
1N/A needents = (1 << UTF_ACCUMULATION_SHIFT);
1N/A off = NATIVE_TO_UTF(ptr[klen]) & UTF_CONTINUATION_MASK;
1N/A }
1N/A
1N/A /*
1N/A * This single-entry cache saves about 1/3 of the utf8 overhead in test
1N/A * suite. (That is, only 7-8% overall over just a hash cache. Still,
1N/A * it's nothing to sniff at.) Pity we usually come through at least
1N/A * two function calls to get here...
1N/A *
1N/A * NB: this code assumes that swatches are never modified, once generated!
1N/A */
1N/A
1N/A if (hv == PL_last_swash_hv &&
1N/A klen == PL_last_swash_klen &&
1N/A (!klen || memEQ((char *)ptr, (char *)PL_last_swash_key, klen)) )
1N/A {
1N/A tmps = PL_last_swash_tmps;
1N/A slen = PL_last_swash_slen;
1N/A }
1N/A else {
1N/A /* Try our second-level swatch cache, kept in a hash. */
1N/A SV** svp = hv_fetch(hv, (char*)ptr, klen, FALSE);
1N/A
1N/A /* If not cached, generate it via utf8::SWASHGET */
1N/A if (!svp || !SvPOK(*svp) || !(tmps = (U8*)SvPV(*svp, slen))) {
1N/A dSP;
1N/A /* We use utf8n_to_uvuni() as we want an index into
1N/A Unicode tables, not a native character number.
1N/A */
1N/A UV code_point = utf8n_to_uvuni(ptr, UTF8_MAXLEN, 0,
1N/A ckWARN(WARN_UTF8) ?
1N/A 0 : UTF8_ALLOW_ANY);
1N/A SV *errsv_save;
1N/A ENTER;
1N/A SAVETMPS;
1N/A save_re_context();
1N/A PUSHSTACKi(PERLSI_MAGIC);
1N/A PUSHMARK(SP);
1N/A EXTEND(SP,3);
1N/A PUSHs((SV*)sv);
1N/A /* On EBCDIC & ~(0xA0-1) isn't a useful thing to do */
1N/A PUSHs(sv_2mortal(newSViv((klen) ?
1N/A (code_point & ~(needents - 1)) : 0)));
1N/A PUSHs(sv_2mortal(newSViv(needents)));
1N/A PUTBACK;
1N/A errsv_save = newSVsv(ERRSV);
1N/A if (call_method("SWASHGET", G_SCALAR))
1N/A retval = newSVsv(*PL_stack_sp--);
1N/A else
1N/A retval = &PL_sv_undef;
1N/A if (!SvTRUE(ERRSV))
1N/A sv_setsv(ERRSV, errsv_save);
1N/A SvREFCNT_dec(errsv_save);
1N/A POPSTACK;
1N/A FREETMPS;
1N/A LEAVE;
1N/A if (IN_PERL_COMPILETIME)
1N/A PL_curcop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
1N/A
1N/A svp = hv_store(hv, (char*)ptr, klen, retval, 0);
1N/A
1N/A if (!svp || !(tmps = (U8*)SvPV(*svp, slen)) || (slen << 3) < needents)
1N/A Perl_croak(aTHX_ "SWASHGET didn't return result of proper length");
1N/A }
1N/A
1N/A PL_last_swash_hv = hv;
1N/A PL_last_swash_klen = klen;
1N/A PL_last_swash_tmps = tmps;
1N/A PL_last_swash_slen = slen;
1N/A if (klen)
1N/A Copy(ptr, PL_last_swash_key, klen, U8);
1N/A }
1N/A
1N/A switch ((int)((slen << 3) / needents)) {
1N/A case 1:
1N/A bit = 1 << (off & 7);
1N/A off >>= 3;
1N/A return (tmps[off] & bit) != 0;
1N/A case 8:
1N/A return tmps[off];
1N/A case 16:
1N/A off <<= 1;
1N/A return (tmps[off] << 8) + tmps[off + 1] ;
1N/A case 32:
1N/A off <<= 2;
1N/A return (tmps[off] << 24) + (tmps[off+1] << 16) + (tmps[off+2] << 8) + tmps[off + 3] ;
1N/A }
1N/A Perl_croak(aTHX_ "panic: swash_fetch");
1N/A return 0;
1N/A}
1N/A
1N/A
1N/A/*
1N/A=for apidoc A|U8 *|uvchr_to_utf8|U8 *d|UV uv
1N/A
1N/AAdds the UTF-8 representation of the Native codepoint C<uv> to the end
1N/Aof the string C<d>; C<d> should be have at least C<UTF8_MAXLEN+1> free
1N/Abytes available. The return value is the pointer to the byte after the
1N/Aend of the new character. In other words,
1N/A
1N/A d = uvchr_to_utf8(d, uv);
1N/A
1N/Ais the recommended wide native character-aware way of saying
1N/A
1N/A *(d++) = uv;
1N/A
1N/A=cut
1N/A*/
1N/A
1N/A/* On ASCII machines this is normally a macro but we want a
1N/A real function in case XS code wants it
1N/A*/
1N/A#undef Perl_uvchr_to_utf8
1N/AU8 *
1N/APerl_uvchr_to_utf8(pTHX_ U8 *d, UV uv)
1N/A{
1N/A return Perl_uvuni_to_utf8_flags(aTHX_ d, NATIVE_TO_UNI(uv), 0);
1N/A}
1N/A
1N/AU8 *
1N/APerl_uvchr_to_utf8_flags(pTHX_ U8 *d, UV uv, UV flags)
1N/A{
1N/A return Perl_uvuni_to_utf8_flags(aTHX_ d, NATIVE_TO_UNI(uv), flags);
1N/A}
1N/A
1N/A/*
1N/A=for apidoc A|UV|utf8n_to_uvchr|U8 *s|STRLEN curlen|STRLEN *retlen|U32 flags
1N/A
1N/AReturns the native character value of the first character in the string C<s>
1N/Awhich is assumed to be in UTF-8 encoding; C<retlen> will be set to the
1N/Alength, in bytes, of that character.
1N/A
1N/AAllows length and flags to be passed to low level routine.
1N/A
1N/A=cut
1N/A*/
1N/A/* On ASCII machines this is normally a macro but we want
1N/A a real function in case XS code wants it
1N/A*/
1N/A#undef Perl_utf8n_to_uvchr
1N/AUV
1N/APerl_utf8n_to_uvchr(pTHX_ U8 *s, STRLEN curlen, STRLEN *retlen, U32 flags)
1N/A{
1N/A UV uv = Perl_utf8n_to_uvuni(aTHX_ s, curlen, retlen, flags);
1N/A return UNI_TO_NATIVE(uv);
1N/A}
1N/A
1N/A/*
1N/A=for apidoc A|char *|pv_uni_display|SV *dsv|U8 *spv|STRLEN len|STRLEN pvlim|UV flags
1N/A
1N/ABuild to the scalar dsv a displayable version of the string spv,
1N/Alength len, the displayable version being at most pvlim bytes long
1N/A(if longer, the rest is truncated and "..." will be appended).
1N/A
1N/AThe flags argument can have UNI_DISPLAY_ISPRINT set to display
1N/AisPRINT()able characters as themselves, UNI_DISPLAY_BACKSLASH
1N/Ato display the \\[nrfta\\] as the backslashed versions (like '\n')
1N/A(UNI_DISPLAY_BACKSLASH is preferred over UNI_DISPLAY_ISPRINT for \\).
1N/AUNI_DISPLAY_QQ (and its alias UNI_DISPLAY_REGEX) have both
1N/AUNI_DISPLAY_BACKSLASH and UNI_DISPLAY_ISPRINT turned on.
1N/A
1N/AThe pointer to the PV of the dsv is returned.
1N/A
1N/A=cut */
1N/Achar *
1N/APerl_pv_uni_display(pTHX_ SV *dsv, U8 *spv, STRLEN len, STRLEN pvlim, UV flags)
1N/A{
1N/A int truncated = 0;
1N/A char *s, *e;
1N/A
1N/A sv_setpvn(dsv, "", 0);
1N/A for (s = (char *)spv, e = s + len; s < e; s += UTF8SKIP(s)) {
1N/A UV u;
1N/A bool ok = FALSE;
1N/A
1N/A if (pvlim && SvCUR(dsv) >= pvlim) {
1N/A truncated++;
1N/A break;
1N/A }
1N/A u = utf8_to_uvchr((U8*)s, 0);
1N/A if (u < 256) {
1N/A if (!ok && (flags & UNI_DISPLAY_BACKSLASH)) {
1N/A switch (u & 0xFF) {
1N/A case '\n':
1N/A Perl_sv_catpvf(aTHX_ dsv, "\\n"); ok = TRUE; break;
1N/A case '\r':
1N/A Perl_sv_catpvf(aTHX_ dsv, "\\r"); ok = TRUE; break;
1N/A case '\t':
1N/A Perl_sv_catpvf(aTHX_ dsv, "\\t"); ok = TRUE; break;
1N/A case '\f':
1N/A Perl_sv_catpvf(aTHX_ dsv, "\\f"); ok = TRUE; break;
1N/A case '\a':
1N/A Perl_sv_catpvf(aTHX_ dsv, "\\a"); ok = TRUE; break;
1N/A case '\\':
1N/A Perl_sv_catpvf(aTHX_ dsv, "\\\\" ); ok = TRUE; break;
1N/A default: break;
1N/A }
1N/A }
1N/A /* isPRINT() is the locale-blind version. */
1N/A if (!ok && (flags & UNI_DISPLAY_ISPRINT) && isPRINT(u & 0xFF)) {
1N/A Perl_sv_catpvf(aTHX_ dsv, "%c", (char)(u & 0xFF));
1N/A ok = TRUE;
1N/A }
1N/A }
1N/A if (!ok)
1N/A Perl_sv_catpvf(aTHX_ dsv, "\\x{%"UVxf"}", u);
1N/A }
1N/A if (truncated)
1N/A sv_catpvn(dsv, "...", 3);
1N/A
1N/A return SvPVX(dsv);
1N/A}
1N/A
1N/A/*
1N/A=for apidoc A|char *|sv_uni_display|SV *dsv|SV *ssv|STRLEN pvlim|UV flags
1N/A
1N/ABuild to the scalar dsv a displayable version of the scalar sv,
1N/Athe displayable version being at most pvlim bytes long
1N/A(if longer, the rest is truncated and "..." will be appended).
1N/A
1N/AThe flags argument is as in pv_uni_display().
1N/A
1N/AThe pointer to the PV of the dsv is returned.
1N/A
1N/A=cut */
1N/Achar *
1N/APerl_sv_uni_display(pTHX_ SV *dsv, SV *ssv, STRLEN pvlim, UV flags)
1N/A{
1N/A return Perl_pv_uni_display(aTHX_ dsv, (U8*)SvPVX(ssv), SvCUR(ssv),
1N/A pvlim, flags);
1N/A}
1N/A
1N/A/*
1N/A=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
1N/A
1N/AReturn true if the strings s1 and s2 differ case-insensitively, false
1N/Aif not (if they are equal case-insensitively). If u1 is true, the
1N/Astring s1 is assumed to be in UTF-8-encoded Unicode. If u2 is true,
1N/Athe string s2 is assumed to be in UTF-8-encoded Unicode. If u1 or u2
1N/Aare false, the respective string is assumed to be in native 8-bit
1N/Aencoding.
1N/A
1N/AIf the pe1 and pe2 are non-NULL, the scanning pointers will be copied
1N/Ain there (they will point at the beginning of the I<next> character).
1N/AIf the pointers behind pe1 or pe2 are non-NULL, they are the end
1N/Apointers beyond which scanning will not continue under any
1N/Acircustances. If the byte lengths l1 and l2 are non-zero, s1+l1 and
1N/As2+l2 will be used as goal end pointers that will also stop the scan,
1N/Aand which qualify towards defining a successful match: all the scans
1N/Athat define an explicit length must reach their goal pointers for
1N/Aa match to succeed).
1N/A
1N/AFor case-insensitiveness, the "casefolding" of Unicode is used
1N/Ainstead of upper/lowercasing both the characters, see
1N/Ahttp://www.unicode.org/unicode/reports/tr21/ (Case Mappings).
1N/A
1N/A=cut */
1N/AI32
1N/APerl_ibcmp_utf8(pTHX_ const char *s1, char **pe1, register UV l1, bool u1, const char *s2, char **pe2, register UV l2, bool u2)
1N/A{
1N/A register U8 *p1 = (U8*)s1;
1N/A register U8 *p2 = (U8*)s2;
1N/A register U8 *e1 = 0, *f1 = 0, *q1 = 0;
1N/A register U8 *e2 = 0, *f2 = 0, *q2 = 0;
1N/A STRLEN n1 = 0, n2 = 0;
1N/A U8 foldbuf1[UTF8_MAXLEN_FOLD+1];
1N/A U8 foldbuf2[UTF8_MAXLEN_FOLD+1];
1N/A U8 natbuf[1+1];
1N/A STRLEN foldlen1, foldlen2;
1N/A bool match;
1N/A
1N/A if (pe1)
1N/A e1 = *(U8**)pe1;
1N/A if (e1 == 0 || (l1 && l1 < (UV)(e1 - (U8*)s1)))
1N/A f1 = (U8*)s1 + l1;
1N/A if (pe2)
1N/A e2 = *(U8**)pe2;
1N/A if (e2 == 0 || (l2 && l2 < (UV)(e2 - (U8*)s2)))
1N/A f2 = (U8*)s2 + l2;
1N/A
1N/A if ((e1 == 0 && f1 == 0) || (e2 == 0 && f2 == 0) || (f1 == 0 && f2 == 0))
1N/A return 1; /* mismatch; possible infinite loop or false positive */
1N/A
1N/A if (!u1 || !u2)
1N/A natbuf[1] = 0; /* Need to terminate the buffer. */
1N/A
1N/A while ((e1 == 0 || p1 < e1) &&
1N/A (f1 == 0 || p1 < f1) &&
1N/A (e2 == 0 || p2 < e2) &&
1N/A (f2 == 0 || p2 < f2)) {
1N/A if (n1 == 0) {
1N/A if (u1)
1N/A to_utf8_fold(p1, foldbuf1, &foldlen1);
1N/A else {
1N/A natbuf[0] = *p1;
1N/A to_utf8_fold(natbuf, foldbuf1, &foldlen1);
1N/A }
1N/A q1 = foldbuf1;
1N/A n1 = foldlen1;
1N/A }
1N/A if (n2 == 0) {
1N/A if (u2)
1N/A to_utf8_fold(p2, foldbuf2, &foldlen2);
1N/A else {
1N/A natbuf[0] = *p2;
1N/A to_utf8_fold(natbuf, foldbuf2, &foldlen2);
1N/A }
1N/A q2 = foldbuf2;
1N/A n2 = foldlen2;
1N/A }
1N/A while (n1 && n2) {
1N/A if ( UTF8SKIP(q1) != UTF8SKIP(q2) ||
1N/A (UTF8SKIP(q1) == 1 && *q1 != *q2) ||
1N/A memNE((char*)q1, (char*)q2, UTF8SKIP(q1)) )
1N/A return 1; /* mismatch */
1N/A n1 -= UTF8SKIP(q1);
1N/A q1 += UTF8SKIP(q1);
1N/A n2 -= UTF8SKIP(q2);
1N/A q2 += UTF8SKIP(q2);
1N/A }
1N/A if (n1 == 0)
1N/A p1 += u1 ? UTF8SKIP(p1) : 1;
1N/A if (n2 == 0)
1N/A p2 += u2 ? UTF8SKIP(p2) : 1;
1N/A
1N/A }
1N/A
1N/A /* A match is defined by all the scans that specified
1N/A * an explicit length reaching their final goals. */
1N/A match = (f1 == 0 || p1 == f1) && (f2 == 0 || p2 == f2);
1N/A
1N/A if (match) {
1N/A if (pe1)
1N/A *pe1 = (char*)p1;
1N/A if (pe2)
1N/A *pe2 = (char*)p2;
1N/A }
1N/A
1N/A return match ? 0 : 1; /* 0 match, 1 mismatch */
1N/A}
1N/A