This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Backport UTF8_IS_INVARIANT, UVCHR_IS_INVARIANT
[perl5.git] / dist / Devel-PPPort / parts / inc / utf8
1 =provides
2
3 __UNDEFINED__
4 utf8_to_uvchr_buf
5 sv_len_utf8
6 sv_len_utf8_nomg
7
8 =implementation
9
10 #define D_PPP_MIN(a,b) (((a) <= (b)) ? (a) : (b))
11
12 __UNDEFINED__ UNICODE_REPLACEMENT  0xFFFD
13
14 #ifdef UTF8_MAXLEN
15 __UNDEFINED__  UTF8_MAXBYTES   UTF8_MAXLEN
16 #endif
17
18 __UNDEF_NOT_PROVIDED__ UTF8_ALLOW_ANYUV                 0
19 __UNDEF_NOT_PROVIDED__ UTF8_ALLOW_EMPTY            0x0001
20 __UNDEF_NOT_PROVIDED__ UTF8_ALLOW_CONTINUATION     0x0002
21 __UNDEF_NOT_PROVIDED__ UTF8_ALLOW_NON_CONTINUATION 0x0004
22 __UNDEF_NOT_PROVIDED__ UTF8_ALLOW_SHORT            0x0008
23 __UNDEF_NOT_PROVIDED__ UTF8_ALLOW_LONG             0x0010
24 __UNDEF_NOT_PROVIDED__ UTF8_ALLOW_OVERFLOW         0x0080
25 __UNDEF_NOT_PROVIDED__ UTF8_ALLOW_ANY  ( UTF8_ALLOW_CONTINUATION      \
26                                         |UTF8_ALLOW_NON_CONTINUATION  \
27                                         |UTF8_ALLOW_SHORT             \
28                                         |UTF8_ALLOW_LONG              \
29                                         |UTF8_ALLOW_OVERFLOW)
30
31 #if defined UTF8SKIP
32
33 /* Don't use official version because it uses MIN, which may not be available */
34 #undef UTF8_SAFE_SKIP
35
36 __UNDEFINED__  UTF8_SAFE_SKIP(s, e)  (                                          \
37                                       ((((e) - (s)) <= 0)                       \
38                                       ? 0                                       \
39                                       : D_PPP_MIN(((e) - (s)), UTF8SKIP(s))))
40 #endif
41
42 #if 'A' == 65
43 __UNDEFINED__ UTF8_IS_INVARIANT(c)   isASCII(c)
44 #else
45 __UNDEFINED__ UTF8_IS_INVARIANT(c)  (isASCII(c) || isCNTRL_L1(c))
46 #endif
47
48 __UNDEFINED__ UVCHR_IS_INVARIANT(c)  UTF8_IS_INVARIANT(c)
49
50 #ifdef is_ascii_string
51 __UNDEFINED__ is_invariant_string(s,l) is_ascii_string(s,l)
52 __UNDEFINED__ is_utf8_invariant_string(s,l) is_ascii_string(s,l)
53
54 /* Hint: is_ascii_string, is_invariant_string
55    is_utf8_invariant_string() does the same thing and is preferred because its
56    name is more accurate as to what it does */
57 #endif
58
59 #ifdef ibcmp_utf8
60 __UNDEFINED__ foldEQ_utf8(s1,pe1,l1,u1,s2,pe2,l2,u2)                            \
61                                 cBOOL(! ibcmp_utf8(s1,pe1,l1,u1,s2,pe2,l2,u2))
62 #endif
63
64 #if defined(is_utf8_string) && defined(UTF8SKIP)
65 __UNDEFINED__ isUTF8_CHAR(s0, e)    (                                           \
66     (e) <= (s0) || ! is_utf8_string(s0, D_PPP_MIN(UTF8SKIP(s0), (e) - (s0)))    \
67     ? 0                                                                         \
68     : UTF8SKIP(s0))
69 #endif
70
71 #if 'A' == 65
72 __UNDEFINED__ BOM_UTF8                    "\xEF\xBB\xBF"
73 __UNDEFINED__ REPLACEMENT_CHARACTER_UTF8  "\xEF\xBF\xBD"
74 #elif '^' == 95
75 __UNDEFINED__ BOM_UTF8                    "\xDD\x73\x66\x73"
76 __UNDEFINED__ REPLACEMENT_CHARACTER_UTF8  "\xDD\x73\x73\x71"
77 #elif '^' == 176
78 __UNDEFINED__ BOM_UTF8                    "\xDD\x72\x65\x72"
79 __UNDEFINED__ REPLACEMENT_CHARACTER_UTF8  "\xDD\x72\x72\x70"
80 #else
81 #  error Unknown character set
82 #endif
83
84 #if { VERSION < 5.31.4 }
85         /* Versions prior to this accepted things that are now considered
86          * malformations, and didn't return -1 on error with warnings enabled
87          * */
88 #  undef utf8_to_uvchr_buf
89 #endif
90
91 /* This implementation brings modern, generally more restricted standards to
92  * utf8_to_uvchr_buf.  Some of these are security related, and clearly must
93  * be done.  But its arguable that the others need not, and hence should not.
94  * The reason they're here is that a module that intends to play with the
95  * latest perls should be able to work the same in all releases.  An example is
96  * that perl no longer accepts any UV for a code point, but limits them to
97  * IV_MAX or below.  This is for future internal use of the larger code points.
98  * If it turns out that some of these changes are breaking code that isn't
99  * intended to work with modern perls, the tighter restrictions could be
100  * relaxed.  khw thinks this is unlikely, but has been wrong in the past. */
101
102 /* 5.6.0 is the first release with UTF-8, and we don't implement this function
103  * there due to its likely lack of still being in use, and the underlying
104  * implementation is very different from later ones, without the later
105  * safeguards, so would require extra work to deal with */
106 #if { VERSION >= 5.6.1 } && ! defined(utf8_to_uvchr_buf)
107    /* Choose which underlying implementation to use.  At least one must be
108     * present or the perl is too early to handle this function */
109 #  if defined(utf8n_to_uvchr) || defined(utf8_to_uvchr) || defined(utf8_to_uv)
110 #    if defined(utf8n_to_uvchr)   /* This is the preferred implementation */
111 #      define D_PPP_utf8_to_uvchr_buf_callee utf8n_to_uvchr
112 #    elif /* Must be at least 5.6.1 from #if above;                             \
113              If have both regular and _simple, regular has all args */          \
114           defined(utf8_to_uv) && defined(utf8_to_uv_simple)
115 #      define D_PPP_utf8_to_uvchr_buf_callee utf8_to_uv
116 #    elif defined(utf8_to_uvchr)  /* The below won't work well on error input */
117 #      define D_PPP_utf8_to_uvchr_buf_callee(s, curlen, retlen, flags)          \
118                                             utf8_to_uvchr((U8 *)(s), (retlen))
119 #    else
120 #      define D_PPP_utf8_to_uvchr_buf_callee(s, curlen, retlen, flags)          \
121                                             utf8_to_uv((U8 *)(s), (retlen))
122 #    endif
123 #  endif
124
125 #  if { NEED utf8_to_uvchr_buf }
126
127 UV
128 utf8_to_uvchr_buf(pTHX_ const U8 *s, const U8 *send, STRLEN *retlen)
129 {
130     UV ret;
131     STRLEN curlen;
132     bool overflows = 0;
133     const U8 *cur_s = s;
134     const bool do_warnings = ckWARN_d(WARN_UTF8);
135 #    if { VERSION < 5.26.0 } && ! defined(EBCDIC)
136     STRLEN overflow_length = 0;
137 #    endif
138
139     if (send > s) {
140         curlen = send - s;
141     }
142     else {
143         assert(0);  /* Modern perls die under this circumstance */
144         curlen = 0;
145         if (! do_warnings) {    /* Handle empty here if no warnings needed */
146             if (retlen) *retlen = 0;
147             return UNICODE_REPLACEMENT;
148         }
149     }
150
151 #    if { VERSION < 5.26.0 } && ! defined(EBCDIC)
152
153     /* Perl did not properly detect overflow for much of its history on
154      * non-EBCDIC platforms, often returning an overlong value which may or may
155      * not have been tolerated in the call.  Also, earlier versions, when they
156      * did detect overflow, may have disallowed it completely.  Modern ones can
157      * replace it with the REPLACEMENT CHARACTER, depending on calling
158      * parameters.  Therefore detect it ourselves in  releases it was
159      * problematic in. */
160
161     if (curlen > 0 && UNLIKELY(*s >= 0xFE)) {
162
163         /* First, on a 32-bit machine the first byte being at least \xFE
164          * automatically is overflow, as it indicates something requiring more
165          * than 31 bits */
166         if (sizeof(ret) < 8) {
167             overflows = 1;
168             overflow_length = 7;
169         }
170         else {
171             const U8 highest[] =    /* 2*63-1 */
172                         "\xFF\x80\x87\xBF\xBF\xBF\xBF\xBF\xBF\xBF\xBF\xBF\xBF";
173             const U8 *cur_h = highest;
174
175             for (cur_s = s; cur_s < send; cur_s++, cur_h++) {
176                 if (UNLIKELY(*cur_s == *cur_h)) {
177                     continue;
178                 }
179
180                 /* If this byte is larger than the corresponding highest UTF-8
181                  * byte, the sequence overflows; otherwise the byte is less
182                  * than (as we handled the equality case above), and so the
183                  * sequence doesn't overflow */
184                 overflows = *cur_s > *cur_h;
185                 break;
186
187             }
188
189             /* Here, either we set the bool and broke out of the loop, or got
190              * to the end and all bytes are the same which indicates it doesn't
191              * overflow.  If it did overflow, it would be this number of bytes
192              * */
193             overflow_length = 13;
194         }
195     }
196
197     if (UNLIKELY(overflows)) {
198         ret = 0;
199
200         if (! do_warnings && retlen) {
201             *retlen = overflow_length;
202         }
203     }
204     else
205
206 #    endif  /* < 5.26 */
207
208         /* Here, we are either in a release that properly detects overflow, or
209          * we have checked for overflow and the next statement is executing as
210          * part of the above conditional where we know we don't have overflow.
211          *
212          * The modern versions allow anything that evaluates to a legal UV, but
213          * not overlongs nor an empty input */
214         ret = D_PPP_utf8_to_uvchr_buf_callee(
215                 s, curlen, retlen,   (UTF8_ALLOW_ANYUV
216                                   & ~(UTF8_ALLOW_LONG|UTF8_ALLOW_EMPTY)));
217
218 #    if { VERSION >= 5.26.0 } && { VERSION < 5.28.0 }
219
220     /* But actually, more modern versions restrict the UV to being no more than
221      * what an IV can hold, so it could still have gotten it wrong about
222      * overflowing. */
223     if (UNLIKELY(ret > IV_MAX)) {
224         overflows = 1;
225     }
226
227 #    endif
228
229     if (UNLIKELY(overflows)) {
230         if (! do_warnings) {
231             if (retlen) {
232                 *retlen = D_PPP_MIN(*retlen, UTF8SKIP(s));
233                 *retlen = D_PPP_MIN(*retlen, curlen);
234             }
235             return UNICODE_REPLACEMENT;
236         }
237         else {
238
239             /* We use the error message in use from 5.8-5.26 */
240             Perl_warner(aTHX_ packWARN(WARN_UTF8),
241                 "Malformed UTF-8 character (overflow at 0x%" UVxf
242                 ", byte 0x%02x, after start byte 0x%02x)",
243                 ret, *cur_s, *s);
244             if (retlen) {
245                 *retlen = (STRLEN) -1;
246             }
247             return 0;
248         }
249     }
250
251     /* Here, did not overflow, but if it failed for some other reason, and
252      * warnings are off, to emulate the behavior of the real utf8_to_uvchr(),
253      * try again, allowing anything.  (Note a return of 0 is ok if the input
254      * was '\0') */
255     if (UNLIKELY(ret == 0 && (curlen == 0 || *s != '\0'))) {
256
257         /* If curlen is 0, we already handled the case where warnings are
258          * disabled, so this 'if' will be true, and so later on, we know that
259          * 's' is dereferencible */
260         if (do_warnings) {
261             *retlen = (STRLEN) -1;
262         }
263         else {
264             ret = D_PPP_utf8_to_uvchr_buf_callee(
265                                             s, curlen, retlen, UTF8_ALLOW_ANY);
266             /* Override with the REPLACEMENT character, as that is what the
267              * modern version of this function returns */
268             ret = UNICODE_REPLACEMENT;
269
270 #    if { VERSION < 5.16.0 }
271
272             /* Versions earlier than this don't necessarily return the proper
273              * length.  It should not extend past the end of string, nor past
274              * what the first byte indicates the length is, nor past the
275              * continuation characters */
276             if (retlen && *retlen >= 0) {
277                 unsigned int i = 1;
278
279                 *retlen = D_PPP_MIN(*retlen, curlen);
280                 *retlen = D_PPP_MIN(*retlen, UTF8SKIP(s));
281                 do {
282                     if (s[i] < 0x80 || s[i] > 0xBF) {
283                         *retlen = i;
284                         break;
285                     }
286                 } while (++i < *retlen);
287             }
288
289 #    endif
290
291         }
292     }
293
294     return ret;
295 }
296
297 #  endif
298 #endif
299
300 #if defined(UTF8SKIP) && defined(utf8_to_uvchr_buf)
301 #undef utf8_to_uvchr /* Always redefine this unsafe function so that it refuses
302                         to read past a NUL, making it much less likely to read
303                         off the end of the buffer.  A NUL indicates the start
304                         of the next character anyway.  If the input isn't
305                         NUL-terminated, the function remains unsafe, as it
306                         always has been. */
307
308 __UNDEFINED__  utf8_to_uvchr(s, lp)                                             \
309     ((*(s) == '\0')                                                             \
310     ? utf8_to_uvchr_buf(s,((s)+1), lp) /* Handle single NUL specially */        \
311     : utf8_to_uvchr_buf(s, (s) + my_strnlen((char *) (s), UTF8SKIP(s)), (lp)))
312
313 #endif
314
315 /* Hint: utf8_to_uvchr
316     Use utf8_to_uvchr_buf() instead.  But ONLY if you KNOW the upper bound
317     of the input string (not resorting to using UTF8SKIP, etc., to infer it).
318     The backported utf8_to_uvchr() will do a better job to prevent most cases
319     of trying to read beyond the end of the buffer */
320
321 /* Replace utf8_to_uvchr with utf8_to_uvchr_buf */
322
323 #ifdef SV_NOSTEAL
324    /* Older Perl versions have broken sv_len_utf8() when passed sv does not have SVf_UTF8 flag set */
325    /* Also note that SvGETMAGIC() may change presence of SVf_UTF8 flag */
326 #  if { VERSION < 5.17.5 }
327 #    undef sv_len_utf8
328 #    if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN)
329 #      define sv_len_utf8_nomg(sv) ({ SV *_sv2 = (sv); (SvUTF8(_sv2) ? Perl_sv_len_utf8(aTHX_ (!SvGMAGICAL(_sv2) ? _sv2 : sv_mortalcopy_flags(_sv2, SV_NOSTEAL))) : ({ STRLEN _len; SvPV_nomg(_sv2, _len); _len; })); })
330 #      define sv_len_utf8(sv) ({ SV *_sv1 = (sv); SvGETMAGIC(_sv1); sv_len_utf8_nomg(_sv1); })
331 #    else
332 #      define sv_len_utf8_nomg(sv) (PL_Sv = (sv), (SvUTF8(PL_Sv) ? Perl_sv_len_utf8(aTHX_ (!SvGMAGICAL(PL_Sv) ? PL_Sv : sv_mortalcopy_flags(PL_Sv, SV_NOSTEAL))) : (SvPV_nomg(PL_Sv, PL_na), PL_na)))
333 #      define sv_len_utf8(sv) (PL_Sv = (sv), SvGETMAGIC(PL_Sv), sv_len_utf8_nomg(PL_Sv))
334 #    endif
335 #  endif
336 #  if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN)
337      __UNDEFINED__ sv_len_utf8_nomg(sv) ({ SV *_sv = (sv); sv_len_utf8(!SvGMAGICAL(_sv) ? _sv : sv_mortalcopy_flags(_sv, SV_NOSTEAL)); })
338 #  else
339      __UNDEFINED__ sv_len_utf8_nomg(sv) ((PL_Sv = (sv)), sv_len_utf8(!SvGMAGICAL(PL_Sv) ? PL_Sv : sv_mortalcopy_flags(PL_Sv, SV_NOSTEAL)))
340 #  endif
341 #endif
342
343 =xsinit
344
345 #define NEED_utf8_to_uvchr_buf
346
347 =xsubs
348
349 #if defined(UTF8_SAFE_SKIP) && defined(UTF8SKIP)
350
351 STRLEN
352 UTF8_SAFE_SKIP(s, adjustment)
353         char * s
354         int adjustment
355         PREINIT:
356             const char *const_s;
357         CODE:
358             const_s = s;
359             /* Instead of passing in an 'e' ptr, use the real end, adjusted */
360             RETVAL = UTF8_SAFE_SKIP(const_s, s + UTF8SKIP(s) + adjustment);
361         OUTPUT:
362             RETVAL
363
364 #endif
365
366 #ifdef isUTF8_CHAR
367
368 STRLEN
369 isUTF8_CHAR(s, adjustment)
370         unsigned char * s
371         int adjustment
372         PREINIT:
373             const unsigned char *const_s;
374             const unsigned char *const_e;
375         CODE:
376             const_s = s;
377             /* Instead of passing in an 'e' ptr, use the real end, adjusted */
378             const_e = const_s + UTF8SKIP(const_s) + adjustment;
379             RETVAL = isUTF8_CHAR(const_s, const_e);
380         OUTPUT:
381             RETVAL
382
383 #endif
384
385
386 #ifdef foldEQ_utf8
387
388 STRLEN
389 foldEQ_utf8(s1, l1, u1, s2, l2, u2)
390         char *s1
391         UV l1
392         bool u1
393         char *s2
394         UV l2
395         bool u2
396         PREINIT:
397             const char *const_s1;
398             const char *const_s2;
399         CODE:
400             const_s1 = s1;
401             const_s2 = s2;
402             RETVAL = foldEQ_utf8(const_s1, NULL, l1, u1, const_s2, NULL, l2, u2);
403         OUTPUT:
404             RETVAL
405
406 #endif
407
408 #ifdef utf8_to_uvchr_buf
409
410 AV *
411 utf8_to_uvchr_buf(s, adjustment)
412         unsigned char *s
413         int adjustment
414         PREINIT:
415             AV *av;
416             STRLEN len;
417             const unsigned char *const_s;
418         CODE:
419             av = newAV();
420             const_s = s;
421             av_push(av, newSVuv(utf8_to_uvchr_buf(const_s,
422                                                   s + UTF8SKIP(s) + adjustment,
423                                                   &len)));
424             if (len == (STRLEN) -1) {
425                 av_push(av, newSViv(-1));
426             }
427             else {
428                 av_push(av, newSVuv(len));
429             }
430             RETVAL = av;
431         OUTPUT:
432                 RETVAL
433
434 #endif
435
436 #ifdef utf8_to_uvchr
437
438 AV *
439 utf8_to_uvchr(s)
440         unsigned char *s
441         PREINIT:
442             AV *av;
443             STRLEN len;
444             const unsigned char *const_s;
445         CODE:
446             av = newAV();
447             const_s = s;
448             av_push(av, newSVuv(utf8_to_uvchr(const_s, &len)));
449             if (len == (STRLEN) -1) {
450                 av_push(av, newSViv(-1));
451             }
452             else {
453                 av_push(av, newSVuv(len));
454             }
455             RETVAL = av;
456         OUTPUT:
457                 RETVAL
458
459 #endif
460
461 #ifdef SV_NOSTEAL
462
463 STRLEN
464 sv_len_utf8(sv)
465         SV *sv
466         CODE:
467                 RETVAL = sv_len_utf8(sv);
468         OUTPUT:
469                 RETVAL
470
471 STRLEN
472 sv_len_utf8_nomg(sv)
473         SV *sv
474         CODE:
475                 RETVAL = sv_len_utf8_nomg(sv);
476         OUTPUT:
477                 RETVAL
478
479 #endif
480
481 #ifdef UVCHR_IS_INVARIANT
482
483 bool
484 UVCHR_IS_INVARIANT(c)
485         unsigned c
486         PREINIT:
487         CODE:
488             RETVAL = UVCHR_IS_INVARIANT(c);
489         OUTPUT:
490             RETVAL
491
492 #endif
493
494 =tests plan => 84
495
496 BEGIN { require warnings if "$]" > '5.006' }
497
498 # skip tests on 5.6.0 and earlier, plus 7.0
499 if ("$]" <= '5.006' || "$]" == '5.007' ) {
500     for (1..84) {
501         skip 'skip: broken utf8 support', 0;
502     }
503     exit;
504 }
505
506 ok(&Devel::PPPort::UTF8_SAFE_SKIP("A", 0), 1);
507 ok(&Devel::PPPort::UTF8_SAFE_SKIP("A", -1), 0);
508
509 ok(&Devel::PPPort::isUTF8_CHAR("A", -1), 0);
510 ok(&Devel::PPPort::isUTF8_CHAR("A",  0), 1);
511 ok(&Devel::PPPort::isUTF8_CHAR("\x{100}",  -1), 0);
512 ok(&Devel::PPPort::isUTF8_CHAR("\x{100}",  0), 2);
513
514 ok(&Devel::PPPort::UVCHR_IS_INVARIANT(ord("A")), 1);
515 ok(! &Devel::PPPort::UVCHR_IS_INVARIANT(0xb6));
516 ok(! &Devel::PPPort::UVCHR_IS_INVARIANT(0x100));
517
518 if ("$]" < '5.008') {
519     for (1 ..3) {
520         ok(1, 1)
521     }
522 }
523 else {
524     ok(&Devel::PPPort::foldEQ_utf8("A\x{100}", 3, 1, "a\x{101}", 3, 1), 1);
525     ok(&Devel::PPPort::foldEQ_utf8("A\x{100}", 3, 1, "a\x{102}", 3, 1), 0);
526     ok(&Devel::PPPort::foldEQ_utf8("A\x{100}", 3, 1, "b\x{101}", 3, 1), 0);
527 }
528
529 my $ret = &Devel::PPPort::utf8_to_uvchr("A");
530 ok($ret->[0], ord("A"));
531 ok($ret->[1], 1);
532
533 $ret = &Devel::PPPort::utf8_to_uvchr("\0");
534 ok($ret->[0], 0);
535 ok($ret->[1], 1);
536
537 $ret = &Devel::PPPort::utf8_to_uvchr_buf("A", 0);
538 ok($ret->[0], ord("A"));
539 ok($ret->[1], 1);
540
541 $ret = &Devel::PPPort::utf8_to_uvchr_buf("\0", 0);
542 ok($ret->[0], 0);
543 ok($ret->[1], 1);
544
545 if (ord("A") != 65) {   # tests not valid for EBCDIC
546     for (1 .. (2 + 4 + (7 * 5))) {
547         ok(1, 1);
548     }
549 }
550 else {
551     $ret = &Devel::PPPort::utf8_to_uvchr_buf("\xc4\x80", 0);
552     ok($ret->[0], 0x100);
553     ok($ret->[1], 2);
554
555     my @warnings;
556     local $SIG{__WARN__} = sub { push @warnings, @_; };
557
558     {
559         BEGIN { 'warnings'->import('utf8') if "$]" > '5.006' }
560         $ret = &Devel::PPPort::utf8_to_uvchr("\xe0\0\x80");
561         ok($ret->[0], 0);
562         ok($ret->[1], -1);
563
564         BEGIN { 'warnings'->unimport() if "$]" > '5.006' }
565         $ret = &Devel::PPPort::utf8_to_uvchr("\xe0\0\x80");
566         ok($ret->[0], 0xFFFD);
567         ok($ret->[1], 1);
568     }
569
570     my @buf_tests = (
571         {
572             input      => "A",
573             adjustment => -1,
574             warning    => eval "qr/empty/",
575             no_warnings_returned_length => 0,
576         },
577         {
578             input      => "\xc4\xc5",
579             adjustment => 0,
580             warning    => eval "qr/non-continuation/",
581             no_warnings_returned_length => 1,
582         },
583         {
584             input      => "\xc4\x80",
585             adjustment => -1,
586             warning    => eval "qr/short|1 byte, need 2/",
587             no_warnings_returned_length => 1,
588         },
589         {
590             input      => "\xc0\x81",
591             adjustment => 0,
592             warning    => eval "qr/overlong|2 bytes, need 1/",
593             no_warnings_returned_length => 2,
594         },
595         {
596             input      => "\xe0\x80\x81",
597             adjustment => 0,
598             warning    => eval "qr/overlong|3 bytes, need 1/",
599             no_warnings_returned_length => 3,
600         },
601         {
602             input      => "\xf0\x80\x80\x81",
603             adjustment => 0,
604             warning    => eval "qr/overlong|4 bytes, need 1/",
605             no_warnings_returned_length => 4,
606         },
607         {                 # Old algorithm failed to detect this
608             input      => "\xff\x80\x90\x90\x90\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf",
609             adjustment => 0,
610             warning    => eval "qr/overflow/",
611             no_warnings_returned_length => 13,
612         },
613     );
614
615     # An empty input is an assertion failure on debugging builds.  It is
616     # deliberately the first test.
617     require Config; import Config;
618     use vars '%Config';
619     if ($Config{ccflags} =~ /-DDEBUGGING/) {
620         shift @buf_tests;
621         for (1..5) {
622             ok(1, 1);
623         }
624     }
625
626     my $test;
627     for $test (@buf_tests) {
628         my $input = $test->{'input'};
629         my $adjustment = $test->{'adjustment'};
630         my $display = 'utf8_to_uvchr_buf("';
631         my $i;
632         for ($i = 0; $i < length($input) + $adjustment; $i++) {
633             $display .= sprintf "\\x%02x", ord substr($input, $i, 1);
634         }
635
636         $display .= '")';
637         my $warning = $test->{'warning'};
638
639         undef @warnings;
640         BEGIN { 'warnings'->import('utf8') if "$]" > '5.006' }
641         $ret = &Devel::PPPort::utf8_to_uvchr_buf($input, $adjustment);
642         ok($ret->[0], 0,  "returned value $display; warnings enabled");
643         ok($ret->[1], -1, "returned length $display; warnings enabled");
644         my $all_warnings = join "; ", @warnings;
645         my $contains = grep { $_ =~ $warning } $all_warnings;
646         ok($contains, 1, $display
647                     . "; Got: '$all_warnings', which should contain '$warning'");
648
649         undef @warnings;
650         BEGIN { 'warnings'->unimport('utf8') if "$]" > '5.006' }
651         $ret = &Devel::PPPort::utf8_to_uvchr_buf($input, $adjustment);
652         ok($ret->[0], 0xFFFD,  "returned value $display; warnings disabled");
653         ok($ret->[1], $test->{'no_warnings_returned_length'},
654                       "returned length $display; warnings disabled");
655     }
656 }
657
658 if ("$]" ge '5.008') {
659     BEGIN { if ("$]" ge '5.008') { require utf8; "utf8"->import() } }
660
661     ok(Devel::PPPort::sv_len_utf8("aščť"), 4);
662     ok(Devel::PPPort::sv_len_utf8_nomg("aščť"), 4);
663
664     my $str = "áíé";
665     utf8::downgrade($str);
666     ok(Devel::PPPort::sv_len_utf8($str), 3);
667     utf8::downgrade($str);
668     ok(Devel::PPPort::sv_len_utf8_nomg($str), 3);
669     utf8::upgrade($str);
670     ok(Devel::PPPort::sv_len_utf8($str), 3);
671     utf8::upgrade($str);
672     ok(Devel::PPPort::sv_len_utf8_nomg($str), 3);
673
674     tie my $scalar, 'TieScalarCounter', "é";
675
676     ok(tied($scalar)->{fetch}, 0);
677     ok(tied($scalar)->{store}, 0);
678     ok(Devel::PPPort::sv_len_utf8($scalar), 2);
679     ok(tied($scalar)->{fetch}, 1);
680     ok(tied($scalar)->{store}, 0);
681     ok(Devel::PPPort::sv_len_utf8($scalar), 3);
682     ok(tied($scalar)->{fetch}, 2);
683     ok(tied($scalar)->{store}, 0);
684     ok(Devel::PPPort::sv_len_utf8($scalar), 4);
685     ok(tied($scalar)->{fetch}, 3);
686     ok(tied($scalar)->{store}, 0);
687     ok(Devel::PPPort::sv_len_utf8_nomg($scalar), 4);
688     ok(tied($scalar)->{fetch}, 3);
689     ok(tied($scalar)->{store}, 0);
690     ok(Devel::PPPort::sv_len_utf8_nomg($scalar), 4);
691     ok(tied($scalar)->{fetch}, 3);
692     ok(tied($scalar)->{store}, 0);
693 } else {
694     for (1..23) {
695         skip 'skip: no SV_NOSTEAL support', 0;
696     }
697 }
698
699 package TieScalarCounter;
700
701 sub TIESCALAR {
702     my ($class, $value) = @_;
703     return bless { fetch => 0, store => 0, value => $value }, $class;
704 }
705
706 sub FETCH {
707     BEGIN { if ("$]" ge '5.008') { require utf8; "utf8"->import() } }
708     my ($self) = @_;
709     $self->{fetch}++;
710     return $self->{value} .= "é";
711 }
712
713 sub STORE {
714     my ($self, $value) = @_;
715     $self->{store}++;
716     $self->{value} = $value;
717 }