[perl5.git] / dist / Devel-PPPort / parts / inc / utf8

=provides

__UNDEFINED__
utf8_to_uvchr_buf

=implementation

#define D_PPP_MIN(a,b) (((a) <= (b)) ? (a) : (b))

__UNDEFINED__ UNICODE_REPLACEMENT  0xFFFD

__UNDEFINED__  UTF8_MAXBYTES   UTF8_MAXLEN

__UNDEFINED__  UTF8_ALLOW_ANYUV                 0
__UNDEFINED__  UTF8_ALLOW_EMPTY            0x0001
__UNDEFINED__  UTF8_ALLOW_CONTINUATION     0x0002
__UNDEFINED__  UTF8_ALLOW_NON_CONTINUATION 0x0004
__UNDEFINED__  UTF8_ALLOW_SHORT            0x0008
__UNDEFINED__  UTF8_ALLOW_LONG             0x0010
__UNDEFINED__  UTF8_ALLOW_OVERFLOW         0x0080
__UNDEFINED__  UTF8_ALLOW_ANY            ( UTF8_ALLOW_CONTINUATION      \
                                          |UTF8_ALLOW_NON_CONTINUATION  \
                                          |UTF8_ALLOW_SHORT             \
                                          |UTF8_ALLOW_LONG              \
                                          |UTF8_ALLOW_OVERFLOW)

#if defined UTF8SKIP

/* Don't use official version because it uses MIN, which may not be available */
#undef UTF8_SAFE_SKIP

__UNDEFINED__  UTF8_SAFE_SKIP(s, e)  (                                          \
                                      ((((e) - (s)) <= 0)                       \
                                      ? 0                                       \
                                      : D_PPP_MIN(((e) - (s)), UTF8SKIP(s))))
#endif

#ifdef is_ascii_string
__UNDEFINED__ is_invariant_string(s,l) is_ascii_string(s,l)
__UNDEFINED__ is_utf8_invariant_string(s,l) is_ascii_string(s,l)

/* Hint: is_utf8_invariant_string
   Please use this instead of is_ascii_string or is_invariant_string
*/
#endif

#ifdef ibcmp_utf8
__UNDEFINED__ foldEQ_utf8(s1,pe1,l1,u1,s2,pe2,l2,u2)                            \
                                cBOOL(! ibcmp_utf8(s1,pe1,l1,u1,s2,pe2,l2,u2))
#endif

#if defined(is_utf8_string) && defined(UTF8SKIP)
__UNDEFINED__ isUTF8_CHAR(s0, e)    (                                           \
    (e) <= (s0) || ! is_utf8_string(s0, D_PPP_MIN(UTF8SKIP(s0), (e) - (s0)))    \
    ? 0                                                                         \
    : UTF8SKIP(s0))
#endif

#if 'A' == 65
__UNDEFINED__ BOM_UTF8                    "\xEF\xBB\xBF"
__UNDEFINED__ REPLACEMENT_CHARACTER_UTF8  "\xEF\xBF\xBD"
#elif '^' == 95
__UNDEFINED__ BOM_UTF8                    "\xDD\x73\x66\x73"
__UNDEFINED__ REPLACEMENT_CHARACTER_UTF8  "\xDD\x73\x73\x71"
#elif '^' == 176
__UNDEFINED__ BOM_UTF8                    "\xDD\x72\x65\x72"
__UNDEFINED__ REPLACEMENT_CHARACTER_UTF8  "\xDD\x72\x72\x70"
#else
#  error Unknown character set
#endif

#if { VERSION < 5.31.3 }
        /* Versions prior to this accepted things that are now considered
         * malformations, and didn't return -1 on error with warnings enabled
         * */
#  undef utf8_to_uvchr_buf
#endif

/* This implementation brings modern, generally more restricted standards to
 * utf8_to_uvchr_buf.  Some of these are security related, and clearly must
 * be done.  But its arguable that the others need not, and hence should not.
 * The reason they're here is that a module that intends to play with the
 * latest perls should be able to work the same in all releases.  An example is
 * that perl no longer accepts any UV for a code point, but limits them to
 * IV_MAX or below.  This is for future internal use of the larger code points.
 * If it turns out that some of these changes are breaking code that isn't
 * intended to work with modern perls, the tighter restrictions could be
 * relaxed.  khw thinks this is unlikely, but has been wrong in the past. */

/* 5.6.0 is the first release with UTF-8, and we don't implement this function
 * there due to its likely lack of still being in use, and the underlying
 * implementation is very different from later ones, without the later
 * safeguards, so would require extra work to deal with */
#if { VERSION >= 5.6.1 } && ! defined(utf8_to_uvchr_buf)
   /* Choose which underlying implementation to use.  At least one must be
    * present or the perl is too early to handle this function */
#  if defined(utf8n_to_uvchr) || defined(utf8_to_uv)
#    if defined(utf8n_to_uvchr)   /* This is the preferred implementation */
#      define D_PPP_utf8_to_uvchr_buf_callee utf8n_to_uvchr
#    else     /* Must be at least 5.6.1 from #if above */
#      define D_PPP_utf8_to_uvchr_buf_callee(s, curlen, retlen, flags) utf8_to_uv((U8 *)(s), (curlen), (retlen), (flags))
#    endif
#  endif

#  if { NEED utf8_to_uvchr_buf }

UV
utf8_to_uvchr_buf(pTHX_ const U8 *s, const U8 *send, STRLEN *retlen)
{
    UV ret;
    STRLEN curlen;
    bool overflows = 0;
    const U8 *cur_s = s;
    const bool do_warnings = ckWARN_d(WARN_UTF8);
#    if { VERSION < 5.26.0 } && ! defined(EBCDIC)
    STRLEN overflow_length = 0;
#    endif

    if (send > s) {
        curlen = send - s;
    }
    else {
        assert(0);  /* Modern perls die under this circumstance */
        curlen = 0;
        if (! do_warnings) {    /* Handle empty here if no warnings needed */
            if (retlen) *retlen = 0;
            return UNICODE_REPLACEMENT;
        }
    }

#    if { VERSION < 5.26.0 } && ! defined(EBCDIC)

    /* Perl did not properly detect overflow for much of its history on
     * non-EBCDIC platforms, often returning an overlong value which may or may
     * not have been tolerated in the call.  Also, earlier versions, when they
     * did detect overflow, may have disallowed it completely.  Modern ones can
     * replace it with the REPLACEMENT CHARACTER, depending on calling
     * parameters.  Therefore detect it ourselves in  releases it was
     * problematic in. */

    if (curlen > 0 && UNLIKELY(*s >= 0xFE)) {

        /* First, on a 32-bit machine the first byte being at least \xFE
         * automatically is overflow, as it indicates something requiring more
         * than 31 bits */
        if (sizeof(ret) < 8) {
            overflows = 1;
            overflow_length = 7;
        }
        else {
            const U8 highest[] =    /* 2*63-1 */
                        "\xFF\x80\x87\xBF\xBF\xBF\xBF\xBF\xBF\xBF\xBF\xBF\xBF";
            const U8 *cur_h = highest;

            for (cur_s = s; cur_s < send; cur_s++, cur_h++) {
                if (UNLIKELY(*cur_s == *cur_h)) {
                    continue;
                }

                /* If this byte is larger than the corresponding highest UTF-8
                 * byte, the sequence overflows; otherwise the byte is less
                 * than (as we handled the equality case above), and so the
                 * sequence doesn't overflow */
                overflows = *cur_s > *cur_h;
                break;

            }

            /* Here, either we set the bool and broke out of the loop, or got
             * to the end and all bytes are the same which indicates it doesn't
             * overflow.  If it did overflow, it would be this number of bytes
             * */
            overflow_length = 13;
        }
    }

    if (UNLIKELY(overflows)) {
        ret = 0;

        if (! do_warnings && retlen) {
            *retlen = overflow_length;
        }
    }
    else

#    endif  /* < 5.26 */

        /* Here, we are either in a release that properly detects overflow, or
         * we have checked for overflow and the next statement is executing as
         * part of the above conditional where we know we don't have overflow.
         *
         * The modern versions allow anything that evaluates to a legal UV, but
         * not overlongs nor an empty input */
        ret = D_PPP_utf8_to_uvchr_buf_callee(
                s, curlen, retlen,   (UTF8_ALLOW_ANYUV
                                  & ~(UTF8_ALLOW_LONG|UTF8_ALLOW_EMPTY)));

#    if { VERSION >= 5.26.0 } && { VERSION < 5.28.0 }

    /* But actually, more modern versions restrict the UV to being no more than
     * what * an IV can hold, so it could, so it could still have gotten it
     * wrong about overflowing. */
    if (UNLIKELY(ret > IV_MAX)) {
        overflows = 1;
    }

#    endif

    if (UNLIKELY(overflows)) {
        if (! do_warnings) {
            if (retlen) {
                *retlen = D_PPP_MIN(*retlen, UTF8SKIP(s));
                *retlen = D_PPP_MIN(*retlen, curlen);
            }
            return UNICODE_REPLACEMENT;
        }
        else {

            /* We use the error message in use from 5.8-5.26 */
            Perl_warner(aTHX_ packWARN(WARN_UTF8),
                "Malformed UTF-8 character (overflow at 0x%" UVxf
                ", byte 0x%02x, after start byte 0x%02x)",
                ret, *cur_s, *s);
            if (retlen) {
                *retlen = (STRLEN) -1;
            }
            return 0;
        }
    }

    /* Here, did not overflow, but if it failed for some other reason, and
     * warnings are off, to emulate the behavior of the real utf8_to_uvchr(),
     * try again, allowing anything.  (Note a return of 0 is ok if the input
     * was '\0') */
    if (UNLIKELY(ret == 0 && (curlen == 0 || *s != '\0'))) {

        /* If curlen is 0, we already handled the case where warnings are
         * disabled, so this 'if' will be true, and so later on, we know that
         * 's' is dereferencible */
        if (do_warnings) {
            *retlen = (STRLEN) -1;
        }
        else {
            ret = D_PPP_utf8_to_uvchr_buf_callee(
                                            s, curlen, retlen, UTF8_ALLOW_ANY);
            /* Override with the REPLACEMENT character, as that is what the
             * modern version of this function returns */
            ret = UNICODE_REPLACEMENT;

#    if { VERSION < 5.16.0 }

            /* Versions earlier than this don't necessarily return the proper
             * length.  It should not extend past the end of string, nor past
             * what the first byte indicates the length is, nor past the
             * continuation characters */
            if (retlen && *retlen >= 0) {
                unsigned int i = 1;

                *retlen = D_PPP_MIN(*retlen, curlen);
                *retlen = D_PPP_MIN(*retlen, UTF8SKIP(s));
                do {
                    if (s[i] < 0x80 || s[i] > 0xBF) {
                        *retlen = i;
                        break;
                    }
                } while (++i < *retlen);
            }

#    endif

        }
    }

    return ret;
}

#  endif
#endif

#if defined(UTF8SKIP) && defined(utf8_to_uvchr_buf)
#undef utf8_to_uvchr /* Always redefine this unsafe function so that it refuses
                        to read past a NUL, making it much less likely to read
                        off the end of the buffer.  A NUL indicates the start
                        of the next character anyway.  If the input isn't
                        NUL-terminated, the function remains unsafe, as it
                        always has been. */

__UNDEFINED__  utf8_to_uvchr(s, lp)                                             \
    ((*(s) == '\0')                                                             \
    ? utf8_to_uvchr_buf(s,((s)+1), lp) /* Handle single NUL specially */        \
    : utf8_to_uvchr_buf(s, (s) + my_strnlen((char *) (s), UTF8SKIP(s)), (lp)))

#endif

=xsinit

#define NEED_utf8_to_uvchr_buf

=xsubs

#if defined(UTF8_SAFE_SKIP) && defined(UTF8SKIP)

STRLEN
UTF8_SAFE_SKIP(s, adjustment)
        char * s
        int adjustment
        PREINIT:
            const char *const_s;
        CODE:
            const_s = s;
            /* Instead of passing in an 'e' ptr, use the real end, adjusted */
            RETVAL = UTF8_SAFE_SKIP(const_s, s + UTF8SKIP(s) + adjustment);
        OUTPUT:
            RETVAL

#endif

#ifdef isUTF8_CHAR

STRLEN
isUTF8_CHAR(s, adjustment)
        unsigned char * s
        int adjustment
        PREINIT:
            const unsigned char *const_s;
            const unsigned char *const_e;
        CODE:
            const_s = s;
            /* Instead of passing in an 'e' ptr, use the real end, adjusted */
            const_e = const_s + UTF8SKIP(const_s) + adjustment;
            RETVAL = isUTF8_CHAR(const_s, const_e);
        OUTPUT:
            RETVAL

#endif


#ifdef foldEQ_utf8

STRLEN
foldEQ_utf8(s1, l1, u1, s2, l2, u2)
        char *s1
        UV l1
        bool u1
        char *s2
        UV l2
        bool u2
        PREINIT:
            const char *const_s1;
            const char *const_s2;
        CODE:
            const_s1 = s1;
            const_s2 = s2;
            RETVAL = foldEQ_utf8(const_s1, NULL, l1, u1, const_s2, NULL, l2, u2);
        OUTPUT:
            RETVAL

#endif

#ifdef utf8_to_uvchr_buf

AV *
utf8_to_uvchr_buf(s, adjustment)
        unsigned char *s
        int adjustment
        PREINIT:
            AV *av;
            STRLEN len;
            const unsigned char *const_s;
        CODE:
            av = newAV();
            const_s = s;
            av_push(av, newSVuv(utf8_to_uvchr_buf(const_s,
                                                  s + UTF8SKIP(s) + adjustment,
                                                  &len)));
            if (len == (STRLEN) -1) {
                av_push(av, newSViv(-1));
            }
            else {
                av_push(av, newSVuv(len));
            }
            RETVAL = av;
        OUTPUT:
                RETVAL

#endif

#ifdef utf8_to_uvchr

AV *
utf8_to_uvchr(s)
        unsigned char *s
        PREINIT:
            AV *av;
            STRLEN len;
            const unsigned char *const_s;
        CODE:
            av = newAV();
            const_s = s;
            av_push(av, newSVuv(utf8_to_uvchr(const_s, &len)));
            if (len == (STRLEN) -1) {
                av_push(av, newSViv(-1));
            }
            else {
                av_push(av, newSVuv(len));
            }
            RETVAL = av;
        OUTPUT:
                RETVAL

#endif

=tests plan => 58

BEGIN { require warnings if "$]" gt '5.006' }

# skip tests on 5.6.0 and earlier
if ("$]" le '5.006') {
    skip 'skip: broken utf8 support', 0 for 1..58;
    exit;
}

ok(&Devel::PPPort::UTF8_SAFE_SKIP("A", 0), 1);
ok(&Devel::PPPort::UTF8_SAFE_SKIP("A", -1), 0);

ok(&Devel::PPPort::isUTF8_CHAR("A", -1), 0);
ok(&Devel::PPPort::isUTF8_CHAR("A",  0), 1);
ok(&Devel::PPPort::isUTF8_CHAR("\x{100}",  -1), 0);
ok(&Devel::PPPort::isUTF8_CHAR("\x{100}",  0), 2);

if ("$]" lt '5.008') {
    ok(1, 1) for 1 ..3
}
else {
    ok(&Devel::PPPort::foldEQ_utf8("A\x{100}", 3, 1, "a\x{101}", 3, 1), 1);
    ok(&Devel::PPPort::foldEQ_utf8("A\x{100}", 3, 1, "a\x{102}", 3, 1), 0);
    ok(&Devel::PPPort::foldEQ_utf8("A\x{100}", 3, 1, "b\x{101}", 3, 1), 0);
}

my $ret = &Devel::PPPort::utf8_to_uvchr("A");
ok($ret->[0], ord("A"));
ok($ret->[1], 1);

$ret = &Devel::PPPort::utf8_to_uvchr("\0");
ok($ret->[0], 0);
ok($ret->[1], 1);

$ret = &Devel::PPPort::utf8_to_uvchr_buf("A", 0);
ok($ret->[0], ord("A"));
ok($ret->[1], 1);

$ret = &Devel::PPPort::utf8_to_uvchr_buf("\0", 0);
ok($ret->[0], 0);
ok($ret->[1], 1);

if (ord("A") != 65) {   # tests not valid for EBCDIC
    ok(1, 1) for 1 .. (2 + 4 + (7 * 5));
}
else {
    $ret = &Devel::PPPort::utf8_to_uvchr_buf("\xc4\x80", 0);
    ok($ret->[0], 0x100);
    ok($ret->[1], 2);

    my @warnings;
    local $SIG{__WARN__} = sub { push @warnings, @_; };

    {
        BEGIN { 'warnings'->import('utf8') if "$]" gt '5.006' }
        $ret = &Devel::PPPort::utf8_to_uvchr("\xe0\0\x80");
        ok($ret->[0], 0);
        ok($ret->[1], -1);

        BEGIN { 'warnings'->unimport() if "$]" gt '5.006' }
        $ret = &Devel::PPPort::utf8_to_uvchr("\xe0\0\x80");
        ok($ret->[0], 0xFFFD);
        ok($ret->[1], 1);
    }

    my @buf_tests = (
        {
            input      => "A",
            adjustment => -1,
            warning    => qr/empty/,
            no_warnings_returned_length => 0,
        },
        {
            input      => "\xc4\xc5",
            adjustment => 0,
            warning    => qr/non-continuation/,
            no_warnings_returned_length => 1,
        },
        {
            input      => "\xc4\x80",
            adjustment => -1,
            warning    => qr/short|1 byte, need 2/,
            no_warnings_returned_length => 1,
        },
        {
            input      => "\xc0\x81",
            adjustment => 0,
            warning    => qr/overlong|2 bytes, need 1/,
            no_warnings_returned_length => 2,
        },
        {
            input      => "\xe0\x80\x81",
            adjustment => 0,
            warning    => qr/overlong|3 bytes, need 1/,
            no_warnings_returned_length => 3,
        },
        {
            input      => "\xf0\x80\x80\x81",
            adjustment => 0,
            warning    => qr/overlong|4 bytes, need 1/,
            no_warnings_returned_length => 4,
        },
        {                 # Old algorithm failed to detect this
            input      => "\xff\x80\x90\x90\x90\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf",
            adjustment => 0,
            warning    => qr/overflow/,
            no_warnings_returned_length => 13,
        },
    );

    # An empty input is an assertion failure on debugging builds.  It is
    # deliberately the first test.
    require Config; import Config;
    use vars '%Config';
    if ($Config{ccflags} =~ /-DDEBUGGING/) {
        shift @buf_tests;
        ok(1, 1) for 1..5;
    }

    for my $test (@buf_tests) {
        my $input = $test->{'input'};
        my $adjustment = $test->{'adjustment'};
        my $display = 'utf8_to_uvchr_buf("';
        for (my $i = 0; $i < length($input) + $adjustment; $i++) {
            $display .= sprintf "\\x%02x", ord substr($input, $i, 1);
        }

        $display .= '")';
        my $warning = $test->{'warning'};

        undef @warnings;
        BEGIN { 'warnings'->import('utf8') if "$]" gt '5.006' }
        $ret = &Devel::PPPort::utf8_to_uvchr_buf($input, $adjustment);
        ok($ret->[0], 0,  "returned value $display; warnings enabled");
        ok($ret->[1], -1, "returned length $display; warnings enabled");
        my $all_warnings = join "; ", @warnings;
        my $contains = grep { $_ =~ $warning } $all_warnings;
        ok($contains, 1, $display
                    . "; Got: '$all_warnings', which should contain '$warning'");

        undef @warnings;
        BEGIN { 'warnings'->unimport('utf8') if "$]" gt '5.006' }
        $ret = &Devel::PPPort::utf8_to_uvchr_buf($input, $adjustment);
        ok($ret->[0], 0xFFFD,  "returned value $display; warnings disabled");
        ok($ret->[1], $test->{'no_warnings_returned_length'},
                      "returned length $display; warnings disabled");
    }
}
Commit	Line	Data
7899b636 KW	1	=provides
	2
	3	__UNDEFINED__
	4	utf8_to_uvchr_buf
	5
	6	=implementation
	7
	8	#define D_PPP_MIN(a,b) (((a) <= (b)) ? (a) : (b))
	9
	10	__UNDEFINED__ UNICODE_REPLACEMENT 0xFFFD
	11
	12	__UNDEFINED__ UTF8_MAXBYTES UTF8_MAXLEN
	13
	14	__UNDEFINED__ UTF8_ALLOW_ANYUV 0
	15	__UNDEFINED__ UTF8_ALLOW_EMPTY 0x0001
	16	__UNDEFINED__ UTF8_ALLOW_CONTINUATION 0x0002
	17	__UNDEFINED__ UTF8_ALLOW_NON_CONTINUATION 0x0004
	18	__UNDEFINED__ UTF8_ALLOW_SHORT 0x0008
	19	__UNDEFINED__ UTF8_ALLOW_LONG 0x0010
	20	__UNDEFINED__ UTF8_ALLOW_OVERFLOW 0x0080
	21	__UNDEFINED__ UTF8_ALLOW_ANY ( UTF8_ALLOW_CONTINUATION \
	22	\|UTF8_ALLOW_NON_CONTINUATION \
	23	\|UTF8_ALLOW_SHORT \
	24	\|UTF8_ALLOW_LONG \
	25	\|UTF8_ALLOW_OVERFLOW)
	26
	27	#if defined UTF8SKIP
	28
	29	/* Don't use official version because it uses MIN, which may not be available */
	30	#undef UTF8_SAFE_SKIP
	31
	32	__UNDEFINED__ UTF8_SAFE_SKIP(s, e) ( \
	33	((((e) - (s)) <= 0) \
	34	? 0 \
	35	: D_PPP_MIN(((e) - (s)), UTF8SKIP(s))))
	36	#endif
	37
d2b44e2b KW	38	#ifdef is_ascii_string
	39	__UNDEFINED__ is_invariant_string(s,l) is_ascii_string(s,l)
	40	__UNDEFINED__ is_utf8_invariant_string(s,l) is_ascii_string(s,l)
	41
	42	/* Hint: is_utf8_invariant_string
	43	Please use this instead of is_ascii_string or is_invariant_string
	44	*/
	45	#endif
	46
2ff9e5e8 KW	47	#ifdef ibcmp_utf8
	48	__UNDEFINED__ foldEQ_utf8(s1,pe1,l1,u1,s2,pe2,l2,u2) \
	49	cBOOL(! ibcmp_utf8(s1,pe1,l1,u1,s2,pe2,l2,u2))
	50	#endif
	51
7899b636 KW	52	#if defined(is_utf8_string) && defined(UTF8SKIP)
	53	__UNDEFINED__ isUTF8_CHAR(s0, e) ( \
	54	(e) <= (s0) \|\| ! is_utf8_string(s0, D_PPP_MIN(UTF8SKIP(s0), (e) - (s0))) \
	55	? 0 \
	56	: UTF8SKIP(s0))
	57	#endif
	58
8fc7db65 KW	59	#if 'A' == 65
	60	__UNDEFINED__ BOM_UTF8 "\xEF\xBB\xBF"
	61	__UNDEFINED__ REPLACEMENT_CHARACTER_UTF8 "\xEF\xBF\xBD"
	62	#elif '^' == 95
	63	__UNDEFINED__ BOM_UTF8 "\xDD\x73\x66\x73"
	64	__UNDEFINED__ REPLACEMENT_CHARACTER_UTF8 "\xDD\x73\x73\x71"
	65	#elif '^' == 176
	66	__UNDEFINED__ BOM_UTF8 "\xDD\x72\x65\x72"
	67	__UNDEFINED__ REPLACEMENT_CHARACTER_UTF8 "\xDD\x72\x72\x70"
	68	#else
	69	# error Unknown character set
	70	#endif
	71
7899b636 KW	72	#if { VERSION < 5.31.3 }
	73	/* Versions prior to this accepted things that are now considered
	74	* malformations, and didn't return -1 on error with warnings enabled
	75	* */
	76	# undef utf8_to_uvchr_buf
	77	#endif
	78
	79	/* This implementation brings modern, generally more restricted standards to
	80	* utf8_to_uvchr_buf. Some of these are security related, and clearly must
	81	* be done. But its arguable that the others need not, and hence should not.
	82	* The reason they're here is that a module that intends to play with the
	83	* latest perls should be able to work the same in all releases. An example is
	84	* that perl no longer accepts any UV for a code point, but limits them to
	85	* IV_MAX or below. This is for future internal use of the larger code points.
	86	* If it turns out that some of these changes are breaking code that isn't
	87	* intended to work with modern perls, the tighter restrictions could be
	88	* relaxed. khw thinks this is unlikely, but has been wrong in the past. */
	89
	90	/* 5.6.0 is the first release with UTF-8, and we don't implement this function
	91	* there due to its likely lack of still being in use, and the underlying
	92	* implementation is very different from later ones, without the later
	93	* safeguards, so would require extra work to deal with */
	94	#if { VERSION >= 5.6.1 } && ! defined(utf8_to_uvchr_buf)
	95	/* Choose which underlying implementation to use. At least one must be
	96	* present or the perl is too early to handle this function */
	97	# if defined(utf8n_to_uvchr) \|\| defined(utf8_to_uv)
	98	# if defined(utf8n_to_uvchr) /* This is the preferred implementation */
	99	# define D_PPP_utf8_to_uvchr_buf_callee utf8n_to_uvchr
	100	# else /* Must be at least 5.6.1 from #if above */
	101	# define D_PPP_utf8_to_uvchr_buf_callee(s, curlen, retlen, flags) utf8_to_uv((U8 *)(s), (curlen), (retlen), (flags))
	102	# endif
	103	# endif
	104
	105	# if { NEED utf8_to_uvchr_buf }
	106
	107	UV
	108	utf8_to_uvchr_buf(pTHX_ const U8 s, const U8 send, STRLEN *retlen)
	109	{
	110	UV ret;
	111	STRLEN curlen;
	112	bool overflows = 0;
	113	const U8 *cur_s = s;
	114	const bool do_warnings = ckWARN_d(WARN_UTF8);
	115	# if { VERSION < 5.26.0 } && ! defined(EBCDIC)
	116	STRLEN overflow_length = 0;
	117	# endif
	118
	119	if (send > s) {
	120	curlen = send - s;
	121	}
	122	else {
	123	assert(0); /* Modern perls die under this circumstance */
	124	curlen = 0;
	125	if (! do_warnings) { /* Handle empty here if no warnings needed */
	126	if (retlen) *retlen = 0;
	127	return UNICODE_REPLACEMENT;
	128	}
	129	}
	130
	131	# if { VERSION < 5.26.0 } && ! defined(EBCDIC)
	132
	133	/* Perl did not properly detect overflow for much of its history on
	134	* non-EBCDIC platforms, often returning an overlong value which may or may
	135	* not have been tolerated in the call. Also, earlier versions, when they
136	* did detect overflow, may have disallowed it completely. Modern ones can
137	* replace it with the REPLACEMENT CHARACTER, depending on calling
138	* parameters. Therefore detect it ourselves in releases it was
139	* problematic in. */
140
141	if (curlen > 0 && UNLIKELY(*s >= 0xFE)) {
142
143	/* First, on a 32-bit machine the first byte being at least \xFE
144	* automatically is overflow, as it indicates something requiring more
145	* than 31 bits */
146	if (sizeof(ret) < 8) {
147	overflows = 1;
148	overflow_length = 7;
149	}
150	else {
151	const U8 highest[] = /* 263-1 /
152	"\xFF\x80\x87\xBF\xBF\xBF\xBF\xBF\xBF\xBF\xBF\xBF\xBF";
153	const U8 *cur_h = highest;
154
155	for (cur_s = s; cur_s < send; cur_s++, cur_h++) {
156	if (UNLIKELY(cur_s == cur_h)) {
157	continue;
158	}
159
160	/* If this byte is larger than the corresponding highest UTF-8
161	* byte, the sequence overflows; otherwise the byte is less
162	* than (as we handled the equality case above), and so the
163	* sequence doesn't overflow */
164	overflows = cur_s > cur_h;
165	break;
166
167	}
168
169	/* Here, either we set the bool and broke out of the loop, or got
170	* to the end and all bytes are the same which indicates it doesn't
171	* overflow. If it did overflow, it would be this number of bytes
172	* */
173	overflow_length = 13;
174	}
175	}
176
177	if (UNLIKELY(overflows)) {
178	ret = 0;
179
180	if (! do_warnings && retlen) {
181	*retlen = overflow_length;
182	}
183	}
184	else
185
186	# endif /* < 5.26 */
187
188	/* Here, we are either in a release that properly detects overflow, or
189	* we have checked for overflow and the next statement is executing as
190	* part of the above conditional where we know we don't have overflow.
191	*
192	* The modern versions allow anything that evaluates to a legal UV, but
193	* not overlongs nor an empty input */
194	ret = D_PPP_utf8_to_uvchr_buf_callee(
195	s, curlen, retlen, (UTF8_ALLOW_ANYUV
196	& ~(UTF8_ALLOW_LONG\|UTF8_ALLOW_EMPTY)));
197
198	# if { VERSION >= 5.26.0 } && { VERSION < 5.28.0 }
199
200	/* But actually, more modern versions restrict the UV to being no more than
201	* what * an IV can hold, so it could, so it could still have gotten it
202	* wrong about overflowing. */
203	if (UNLIKELY(ret > IV_MAX)) {
204	overflows = 1;
205	}
206
207	# endif
208
209	if (UNLIKELY(overflows)) {
210	if (! do_warnings) {
211	if (retlen) {
212	retlen = D_PPP_MIN(retlen, UTF8SKIP(s));
213	retlen = D_PPP_MIN(retlen, curlen);
214	}
215	return UNICODE_REPLACEMENT;
216	}
217	else {
218
219	/* We use the error message in use from 5.8-5.26 */
220	Perl_warner(aTHX_ packWARN(WARN_UTF8),
221	"Malformed UTF-8 character (overflow at 0x%" UVxf
222	", byte 0x%02x, after start byte 0x%02x)",
223	ret, cur_s, s);
224	if (retlen) {
225	*retlen = (STRLEN) -1;
226	}
227	return 0;
228	}
229	}
230
231	/* Here, did not overflow, but if it failed for some other reason, and
232	* warnings are off, to emulate the behavior of the real utf8_to_uvchr(),
233	* try again, allowing anything. (Note a return of 0 is ok if the input
234	* was '\0') */
235	if (UNLIKELY(ret == 0 && (curlen == 0 \|\| *s != '\0'))) {
236
237	/* If curlen is 0, we already handled the case where warnings are
238	* disabled, so this 'if' will be true, and so later on, we know that
239	* 's' is dereferencible */
240	if (do_warnings) {
241	*retlen = (STRLEN) -1;
242	}
243	else {
244	ret = D_PPP_utf8_to_uvchr_buf_callee(
245	s, curlen, retlen, UTF8_ALLOW_ANY);
246	/* Override with the REPLACEMENT character, as that is what the
247	* modern version of this function returns */
248	ret = UNICODE_REPLACEMENT;
249
250	# if { VERSION < 5.16.0 }
251
252	/* Versions earlier than this don't necessarily return the proper
253	* length. It should not extend past the end of string, nor past
254	* what the first byte indicates the length is, nor past the
255	* continuation characters */
256	if (retlen && *retlen >= 0) {
257	unsigned int i = 1;
258
259	retlen = D_PPP_MIN(retlen, curlen);
260	retlen = D_PPP_MIN(retlen, UTF8SKIP(s));
261	do {
262	if (s[i] < 0x80 \|\| s[i] > 0xBF) {
263	*retlen = i;
264	break;
265	}
266	} while (++i < *retlen);
267	}
268
269	# endif
270
271	}
272	}
273
274	return ret;
275	}
276
277	# endif
278	#endif
279
280	#if defined(UTF8SKIP) && defined(utf8_to_uvchr_buf)
281	#undef utf8_to_uvchr /* Always redefine this unsafe function so that it refuses
282	to read past a NUL, making it much less likely to read
283	off the end of the buffer. A NUL indicates the start
284	of the next character anyway. If the input isn't
285	NUL-terminated, the function remains unsafe, as it
286	always has been. */
287
288	__UNDEFINED__ utf8_to_uvchr(s, lp) \
289	((*(s) == '\0') \
290	? utf8_to_uvchr_buf(s,((s)+1), lp) /* Handle single NUL specially */ \
291	: utf8_to_uvchr_buf(s, (s) + my_strnlen((char *) (s), UTF8SKIP(s)), (lp)))
292
293	#endif
294
295	=xsinit
296
297	#define NEED_utf8_to_uvchr_buf
298
299	=xsubs
300
301	#if defined(UTF8_SAFE_SKIP) && defined(UTF8SKIP)
302
303	STRLEN
304	UTF8_SAFE_SKIP(s, adjustment)
305	char * s
306	int adjustment
307	PREINIT:
308	const char *const_s;
309	CODE:
310	const_s = s;
311	/* Instead of passing in an 'e' ptr, use the real end, adjusted */
312	RETVAL = UTF8_SAFE_SKIP(const_s, s + UTF8SKIP(s) + adjustment);
313	OUTPUT:
314	RETVAL
315
316	#endif
317
318	#ifdef isUTF8_CHAR
319
320	STRLEN
321	isUTF8_CHAR(s, adjustment)
322	unsigned char * s
323	int adjustment
324	PREINIT:
325	const unsigned char *const_s;
326	const unsigned char *const_e;
327	CODE:
328	const_s = s;
329	/* Instead of passing in an 'e' ptr, use the real end, adjusted */
330	const_e = const_s + UTF8SKIP(const_s) + adjustment;
331	RETVAL = isUTF8_CHAR(const_s, const_e);
332	OUTPUT:
333	RETVAL
334
335	#endif
336
2ff9e5e8 KW	337
	338	#ifdef foldEQ_utf8
	339
	340	STRLEN
	341	foldEQ_utf8(s1, l1, u1, s2, l2, u2)
	342	char *s1
	343	UV l1
	344	bool u1
	345	char *s2
	346	UV l2
	347	bool u2
	348	PREINIT:
	349	const char *const_s1;
	350	const char *const_s2;
	351	CODE:
	352	const_s1 = s1;
	353	const_s2 = s2;
	354	RETVAL = foldEQ_utf8(const_s1, NULL, l1, u1, const_s2, NULL, l2, u2);
	355	OUTPUT:
	356	RETVAL
	357
	358	#endif
	359
7899b636 KW	360	#ifdef utf8_to_uvchr_buf
	361
	362	AV *
	363	utf8_to_uvchr_buf(s, adjustment)
	364	unsigned char *s
	365	int adjustment
	366	PREINIT:
	367	AV *av;
	368	STRLEN len;
	369	const unsigned char *const_s;
	370	CODE:
	371	av = newAV();
	372	const_s = s;
	373	av_push(av, newSVuv(utf8_to_uvchr_buf(const_s,
	374	s + UTF8SKIP(s) + adjustment,
	375	&len)));
	376	if (len == (STRLEN) -1) {
	377	av_push(av, newSViv(-1));
	378	}
	379	else {
	380	av_push(av, newSVuv(len));
	381	}
	382	RETVAL = av;
	383	OUTPUT:
	384	RETVAL
	385
	386	#endif
	387
	388	#ifdef utf8_to_uvchr
	389
	390	AV *
	391	utf8_to_uvchr(s)
	392	unsigned char *s
	393	PREINIT:
	394	AV *av;
	395	STRLEN len;
	396	const unsigned char *const_s;
	397	CODE:
	398	av = newAV();
	399	const_s = s;
	400	av_push(av, newSVuv(utf8_to_uvchr(const_s, &len)));
	401	if (len == (STRLEN) -1) {
	402	av_push(av, newSViv(-1));
	403	}
	404	else {
	405	av_push(av, newSVuv(len));
	406	}
	407	RETVAL = av;
	408	OUTPUT:
	409	RETVAL
	410
	411	#endif
	412
2ff9e5e8	413	=tests plan => 58
7899b636 KW	414
	415	BEGIN { require warnings if "$]" gt '5.006' }
	416
	417	# skip tests on 5.6.0 and earlier
	418	if ("$]" le '5.006') {
2ff9e5e8	419	skip 'skip: broken utf8 support', 0 for 1..58;
7899b636 KW	420	exit;
	421	}
	422
	423	ok(&Devel::PPPort::UTF8_SAFE_SKIP("A", 0), 1);
	424	ok(&Devel::PPPort::UTF8_SAFE_SKIP("A", -1), 0);
	425
	426	ok(&Devel::PPPort::isUTF8_CHAR("A", -1), 0);
	427	ok(&Devel::PPPort::isUTF8_CHAR("A", 0), 1);
	428	ok(&Devel::PPPort::isUTF8_CHAR("\x{100}", -1), 0);
	429	ok(&Devel::PPPort::isUTF8_CHAR("\x{100}", 0), 2);
	430
2ff9e5e8 KW	431	if ("$]" lt '5.008') {
	432	ok(1, 1) for 1 ..3
	433	}
	434	else {
	435	ok(&Devel::PPPort::foldEQ_utf8("A\x{100}", 3, 1, "a\x{101}", 3, 1), 1);
	436	ok(&Devel::PPPort::foldEQ_utf8("A\x{100}", 3, 1, "a\x{102}", 3, 1), 0);
	437	ok(&Devel::PPPort::foldEQ_utf8("A\x{100}", 3, 1, "b\x{101}", 3, 1), 0);
	438	}
	439
7899b636 KW	440	my $ret = &Devel::PPPort::utf8_to_uvchr("A");
	441	ok($ret->[0], ord("A"));
	442	ok($ret->[1], 1);
	443
	444	$ret = &Devel::PPPort::utf8_to_uvchr("\0");
	445	ok($ret->[0], 0);
	446	ok($ret->[1], 1);
	447
	448	$ret = &Devel::PPPort::utf8_to_uvchr_buf("A", 0);
	449	ok($ret->[0], ord("A"));
	450	ok($ret->[1], 1);
	451
	452	$ret = &Devel::PPPort::utf8_to_uvchr_buf("\0", 0);
	453	ok($ret->[0], 0);
	454	ok($ret->[1], 1);
	455
	456	if (ord("A") != 65) { # tests not valid for EBCDIC
	457	ok(1, 1) for 1 .. (2 + 4 + (7 * 5));
	458	}
	459	else {
	460	$ret = &Devel::PPPort::utf8_to_uvchr_buf("\xc4\x80", 0);
	461	ok($ret->[0], 0x100);
	462	ok($ret->[1], 2);
	463
	464	my @warnings;
	465	local $SIG{__WARN__} = sub { push @warnings, @_; };
	466
	467	{
	468	BEGIN { 'warnings'->import('utf8') if "$]" gt '5.006' }
	469	$ret = &Devel::PPPort::utf8_to_uvchr("\xe0\0\x80");
	470	ok($ret->[0], 0);
	471	ok($ret->[1], -1);
	472
	473	BEGIN { 'warnings'->unimport() if "$]" gt '5.006' }
	474	$ret = &Devel::PPPort::utf8_to_uvchr("\xe0\0\x80");
	475	ok($ret->[0], 0xFFFD);
	476	ok($ret->[1], 1);
	477	}
	478
	479	my @buf_tests = (
	480	{
	481	input => "A",
	482	adjustment => -1,
	483	warning => qr/empty/,
	484	no_warnings_returned_length => 0,
	485	},
	486	{
	487	input => "\xc4\xc5",
	488	adjustment => 0,
	489	warning => qr/non-continuation/,
	490	no_warnings_returned_length => 1,
	491	},
	492	{
	493	input => "\xc4\x80",
	494	adjustment => -1,
	495	warning => qr/short\|1 byte, need 2/,
	496	no_warnings_returned_length => 1,
	497	},
	498	{
	499	input => "\xc0\x81",
	500	adjustment => 0,
	501	warning => qr/overlong\|2 bytes, need 1/,
	502	no_warnings_returned_length => 2,
	503	},
504	{
505	input => "\xe0\x80\x81",
506	adjustment => 0,
507	warning => qr/overlong\|3 bytes, need 1/,
508	no_warnings_returned_length => 3,
509	},
510	{
511	input => "\xf0\x80\x80\x81",
512	adjustment => 0,
513	warning => qr/overlong\|4 bytes, need 1/,
514	no_warnings_returned_length => 4,
515	},
516	{ # Old algorithm failed to detect this
517	input => "\xff\x80\x90\x90\x90\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf",
518	adjustment => 0,
519	warning => qr/overflow/,
520	no_warnings_returned_length => 13,
521	},
522	);
523
524	# An empty input is an assertion failure on debugging builds. It is
525	# deliberately the first test.
526	require Config; import Config;
527	use vars '%Config';
528	if ($Config{ccflags} =~ /-DDEBUGGING/) {
529	shift @buf_tests;
530	ok(1, 1) for 1..5;
531	}
532
533	for my $test (@buf_tests) {
534	my $input = $test->{'input'};
535	my $adjustment = $test->{'adjustment'};
536	my $display = 'utf8_to_uvchr_buf("';
537	for (my $i = 0; $i < length($input) + $adjustment; $i++) {
538	$display .= sprintf "\\x%02x", ord substr($input, $i, 1);
539	}
540
541	$display .= '")';
542	my $warning = $test->{'warning'};
543
544	undef @warnings;
545	BEGIN { 'warnings'->import('utf8') if "$]" gt '5.006' }
546	$ret = &Devel::PPPort::utf8_to_uvchr_buf($input, $adjustment);
547	ok($ret->[0], 0, "returned value $display; warnings enabled");
548	ok($ret->[1], -1, "returned length $display; warnings enabled");
549	my $all_warnings = join "; ", @warnings;
550	my $contains = grep { $_ =~ $warning } $all_warnings;
551	ok($contains, 1, $display
552	. "; Got: '$all_warnings', which should contain '$warning'");
553
554	undef @warnings;
555	BEGIN { 'warnings'->unimport('utf8') if "$]" gt '5.006' }
556	$ret = &Devel::PPPort::utf8_to_uvchr_buf($input, $adjustment);
557	ok($ret->[0], 0xFFFD, "returned value $display; warnings disabled");
558	ok($ret->[1], $test->{'no_warnings_returned_length'},
559	"returned length $display; warnings disabled");
560	}
561	}