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