This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
21d0f08a19d31c996d59515d7c149402c591765b
[perl5.git] / utf8.c
1 /*    utf8.c
2  *
3  *    Copyright (C) 2000, 2001, 2002, 2003, by Larry Wall and others
4  *
5  *    You may distribute under the terms of either the GNU General Public
6  *    License or the Artistic License, as specified in the README file.
7  *
8  */
9
10 /*
11  * 'What a fix!' said Sam. 'That's the one place in all the lands we've ever
12  * heard of that we don't want to see any closer; and that's the one place
13  * we're trying to get to!  And that's just where we can't get, nohow.'
14  *
15  * 'Well do I understand your speech,' he answered in the same language;
16  * 'yet few strangers do so.  Why then do you not speak in the Common Tongue,
17  * as is the custom in the West, if you wish to be answered?'
18  *
19  * ...the travellers perceived that the floor was paved with stones of many
20  * hues; branching runes and strange devices intertwined beneath their feet.
21  */
22
23 #include "EXTERN.h"
24 #define PERL_IN_UTF8_C
25 #include "perl.h"
26
27 static char unees[] = "Malformed UTF-8 character (unexpected end of string)";
28
29 /* 
30 =head1 Unicode Support
31
32 =for apidoc A|U8 *|uvuni_to_utf8_flags|U8 *d|UV uv|UV flags
33
34 Adds the UTF8 representation of the Unicode codepoint C<uv> to the end
35 of the string C<d>; C<d> should be have at least C<UTF8_MAXLEN+1> free
36 bytes available. The return value is the pointer to the byte after the
37 end of the new character. In other words,
38
39     d = uvuni_to_utf8_flags(d, uv, flags);
40
41 or, in most cases,
42
43     d = uvuni_to_utf8(d, uv);
44
45 (which is equivalent to)
46
47     d = uvuni_to_utf8_flags(d, uv, 0);
48
49 is the recommended Unicode-aware way of saying
50
51     *(d++) = uv;
52
53 =cut
54 */
55
56 U8 *
57 Perl_uvuni_to_utf8_flags(pTHX_ U8 *d, UV uv, UV flags)
58 {
59     if (ckWARN(WARN_UTF8)) {
60          if (UNICODE_IS_SURROGATE(uv) &&
61              !(flags & UNICODE_ALLOW_SURROGATE))
62               Perl_warner(aTHX_ packWARN(WARN_UTF8), "UTF-16 surrogate 0x%04"UVxf, uv);
63          else if (
64                   ((uv >= 0xFDD0 && uv <= 0xFDEF &&
65                     !(flags & UNICODE_ALLOW_FDD0))
66                    ||
67                    ((uv & 0xFFFE) == 0xFFFE && /* Either FFFE or FFFF. */
68                     !(flags & UNICODE_ALLOW_FFFF))) &&
69                   /* UNICODE_ALLOW_SUPER includes
70                    * FFFEs and FFFFs beyond 0x10FFFF. */
71                   ((uv <= PERL_UNICODE_MAX) ||
72                    !(flags & UNICODE_ALLOW_SUPER))
73                   )
74               Perl_warner(aTHX_ packWARN(WARN_UTF8),
75                          "Unicode character 0x%04"UVxf" is illegal", uv);
76     }
77     if (UNI_IS_INVARIANT(uv)) {
78         *d++ = (U8)UTF_TO_NATIVE(uv);
79         return d;
80     }
81 #if defined(EBCDIC)
82     else {
83         STRLEN len  = UNISKIP(uv);
84         U8 *p = d+len-1;
85         while (p > d) {
86             *p-- = (U8)UTF_TO_NATIVE((uv & UTF_CONTINUATION_MASK) | UTF_CONTINUATION_MARK);
87             uv >>= UTF_ACCUMULATION_SHIFT;
88         }
89         *p = (U8)UTF_TO_NATIVE((uv & UTF_START_MASK(len)) | UTF_START_MARK(len));
90         return d+len;
91     }
92 #else /* Non loop style */
93     if (uv < 0x800) {
94         *d++ = (U8)(( uv >>  6)         | 0xc0);
95         *d++ = (U8)(( uv        & 0x3f) | 0x80);
96         return d;
97     }
98     if (uv < 0x10000) {
99         *d++ = (U8)(( uv >> 12)         | 0xe0);
100         *d++ = (U8)(((uv >>  6) & 0x3f) | 0x80);
101         *d++ = (U8)(( uv        & 0x3f) | 0x80);
102         return d;
103     }
104     if (uv < 0x200000) {
105         *d++ = (U8)(( uv >> 18)         | 0xf0);
106         *d++ = (U8)(((uv >> 12) & 0x3f) | 0x80);
107         *d++ = (U8)(((uv >>  6) & 0x3f) | 0x80);
108         *d++ = (U8)(( uv        & 0x3f) | 0x80);
109         return d;
110     }
111     if (uv < 0x4000000) {
112         *d++ = (U8)(( uv >> 24)         | 0xf8);
113         *d++ = (U8)(((uv >> 18) & 0x3f) | 0x80);
114         *d++ = (U8)(((uv >> 12) & 0x3f) | 0x80);
115         *d++ = (U8)(((uv >>  6) & 0x3f) | 0x80);
116         *d++ = (U8)(( uv        & 0x3f) | 0x80);
117         return d;
118     }
119     if (uv < 0x80000000) {
120         *d++ = (U8)(( uv >> 30)         | 0xfc);
121         *d++ = (U8)(((uv >> 24) & 0x3f) | 0x80);
122         *d++ = (U8)(((uv >> 18) & 0x3f) | 0x80);
123         *d++ = (U8)(((uv >> 12) & 0x3f) | 0x80);
124         *d++ = (U8)(((uv >>  6) & 0x3f) | 0x80);
125         *d++ = (U8)(( uv        & 0x3f) | 0x80);
126         return d;
127     }
128 #ifdef HAS_QUAD
129     if (uv < UTF8_QUAD_MAX)
130 #endif
131     {
132         *d++ =                            0xfe; /* Can't match U+FEFF! */
133         *d++ = (U8)(((uv >> 30) & 0x3f) | 0x80);
134         *d++ = (U8)(((uv >> 24) & 0x3f) | 0x80);
135         *d++ = (U8)(((uv >> 18) & 0x3f) | 0x80);
136         *d++ = (U8)(((uv >> 12) & 0x3f) | 0x80);
137         *d++ = (U8)(((uv >>  6) & 0x3f) | 0x80);
138         *d++ = (U8)(( uv        & 0x3f) | 0x80);
139         return d;
140     }
141 #ifdef HAS_QUAD
142     {
143         *d++ =                            0xff;         /* Can't match U+FFFE! */
144         *d++ =                            0x80;         /* 6 Reserved bits */
145         *d++ = (U8)(((uv >> 60) & 0x0f) | 0x80);        /* 2 Reserved bits */
146         *d++ = (U8)(((uv >> 54) & 0x3f) | 0x80);
147         *d++ = (U8)(((uv >> 48) & 0x3f) | 0x80);
148         *d++ = (U8)(((uv >> 42) & 0x3f) | 0x80);
149         *d++ = (U8)(((uv >> 36) & 0x3f) | 0x80);
150         *d++ = (U8)(((uv >> 30) & 0x3f) | 0x80);
151         *d++ = (U8)(((uv >> 24) & 0x3f) | 0x80);
152         *d++ = (U8)(((uv >> 18) & 0x3f) | 0x80);
153         *d++ = (U8)(((uv >> 12) & 0x3f) | 0x80);
154         *d++ = (U8)(((uv >>  6) & 0x3f) | 0x80);
155         *d++ = (U8)(( uv        & 0x3f) | 0x80);
156         return d;
157     }
158 #endif
159 #endif /* Loop style */
160 }
161  
162 U8 *
163 Perl_uvuni_to_utf8(pTHX_ U8 *d, UV uv)
164 {
165     return Perl_uvuni_to_utf8_flags(aTHX_ d, uv, 0);
166 }
167
168
169 /*
170 =for apidoc A|STRLEN|is_utf8_char|U8 *s
171
172 Tests if some arbitrary number of bytes begins in a valid UTF-8
173 character.  Note that an INVARIANT (i.e. ASCII) character is a valid
174 UTF-8 character.  The actual number of bytes in the UTF-8 character
175 will be returned if it is valid, otherwise 0.
176
177 =cut */
178 STRLEN
179 Perl_is_utf8_char(pTHX_ U8 *s)
180 {
181     U8 u = *s;
182     STRLEN slen, len;
183     UV uv, ouv;
184
185     if (UTF8_IS_INVARIANT(u))
186         return 1;
187
188     if (!UTF8_IS_START(u))
189         return 0;
190
191     len = UTF8SKIP(s);
192
193     if (len < 2 || !UTF8_IS_CONTINUATION(s[1]))
194         return 0;
195
196     slen = len - 1;
197     s++;
198     u &= UTF_START_MASK(len);
199     uv  = u;
200     ouv = uv;
201     while (slen--) {
202         if (!UTF8_IS_CONTINUATION(*s))
203             return 0;
204         uv = UTF8_ACCUMULATE(uv, *s);
205         if (uv < ouv) 
206             return 0;
207         ouv = uv;
208         s++;
209     }
210
211     if ((STRLEN)UNISKIP(uv) < len)
212         return 0;
213
214     return len;
215 }
216
217 /*
218 =for apidoc A|bool|is_utf8_string|U8 *s|STRLEN len
219
220 Returns true if first C<len> bytes of the given string form a valid
221 UTF8 string, false otherwise.  Note that 'a valid UTF8 string' does
222 not mean 'a string that contains code points above 0x7F encoded in
223 UTF8' because a valid ASCII string is a valid UTF8 string.
224
225 =cut
226 */
227
228 bool
229 Perl_is_utf8_string(pTHX_ U8 *s, STRLEN len)
230 {
231     U8* x = s;
232     U8* send;
233     STRLEN c;
234
235     if (!len)
236         len = strlen((char *)s);
237     send = s + len;
238
239     while (x < send) {
240          /* Inline the easy bits of is_utf8_char() here for speed... */
241          if (UTF8_IS_INVARIANT(*x))
242               c = 1;
243          else if (!UTF8_IS_START(*x))
244               return FALSE;
245          else {
246               /* ... and call is_utf8_char() only if really needed. */
247               c = is_utf8_char(x);
248               if (!c)
249                    return FALSE;
250          }
251         x += c;
252     }
253     if (x != send)
254         return FALSE;
255
256     return TRUE;
257 }
258
259 /*
260 =for apidoc A|UV|utf8n_to_uvuni|U8 *s|STRLEN curlen|STRLEN *retlen|U32 flags
261
262 Bottom level UTF-8 decode routine.
263 Returns the unicode code point value of the first character in the string C<s>
264 which is assumed to be in UTF8 encoding and no longer than C<curlen>;
265 C<retlen> will be set to the length, in bytes, of that character.
266
267 If C<s> does not point to a well-formed UTF8 character, the behaviour
268 is dependent on the value of C<flags>: if it contains UTF8_CHECK_ONLY,
269 it is assumed that the caller will raise a warning, and this function
270 will silently just set C<retlen> to C<-1> and return zero.  If the
271 C<flags> does not contain UTF8_CHECK_ONLY, warnings about
272 malformations will be given, C<retlen> will be set to the expected
273 length of the UTF-8 character in bytes, and zero will be returned.
274
275 The C<flags> can also contain various flags to allow deviations from
276 the strict UTF-8 encoding (see F<utf8.h>).
277
278 Most code should use utf8_to_uvchr() rather than call this directly.
279
280 =cut
281 */
282
283 UV
284 Perl_utf8n_to_uvuni(pTHX_ U8 *s, STRLEN curlen, STRLEN *retlen, U32 flags)
285 {
286     U8 *s0 = s;
287     UV uv = *s, ouv = 0;
288     STRLEN len = 1;
289     bool dowarn = ckWARN_d(WARN_UTF8);
290     UV startbyte = *s;
291     STRLEN expectlen = 0;
292     U32 warning = 0;
293
294 /* This list is a superset of the UTF8_ALLOW_XXX. */
295
296 #define UTF8_WARN_EMPTY                          1
297 #define UTF8_WARN_CONTINUATION                   2
298 #define UTF8_WARN_NON_CONTINUATION               3
299 #define UTF8_WARN_FE_FF                          4
300 #define UTF8_WARN_SHORT                          5
301 #define UTF8_WARN_OVERFLOW                       6
302 #define UTF8_WARN_SURROGATE                      7
303 #define UTF8_WARN_LONG                           8
304 #define UTF8_WARN_FFFF                           9 /* Also FFFE. */
305
306     if (curlen == 0 &&
307         !(flags & UTF8_ALLOW_EMPTY)) {
308         warning = UTF8_WARN_EMPTY;
309         goto malformed;
310     }
311
312     if (UTF8_IS_INVARIANT(uv)) {
313         if (retlen)
314             *retlen = 1;
315         return (UV) (NATIVE_TO_UTF(*s));
316     }
317
318     if (UTF8_IS_CONTINUATION(uv) &&
319         !(flags & UTF8_ALLOW_CONTINUATION)) {
320         warning = UTF8_WARN_CONTINUATION;
321         goto malformed;
322     }
323
324     if (UTF8_IS_START(uv) && curlen > 1 && !UTF8_IS_CONTINUATION(s[1]) &&
325         !(flags & UTF8_ALLOW_NON_CONTINUATION)) {
326         warning = UTF8_WARN_NON_CONTINUATION;
327         goto malformed;
328     }
329
330 #ifdef EBCDIC
331     uv = NATIVE_TO_UTF(uv);
332 #else
333     if ((uv == 0xfe || uv == 0xff) &&
334         !(flags & UTF8_ALLOW_FE_FF)) {
335         warning = UTF8_WARN_FE_FF;
336         goto malformed;
337     }
338 #endif
339
340     if      (!(uv & 0x20))      { len =  2; uv &= 0x1f; }
341     else if (!(uv & 0x10))      { len =  3; uv &= 0x0f; }
342     else if (!(uv & 0x08))      { len =  4; uv &= 0x07; }
343     else if (!(uv & 0x04))      { len =  5; uv &= 0x03; }
344 #ifdef EBCDIC
345     else if (!(uv & 0x02))      { len =  6; uv &= 0x01; }
346     else                        { len =  7; uv &= 0x01; }
347 #else
348     else if (!(uv & 0x02))      { len =  6; uv &= 0x01; }
349     else if (!(uv & 0x01))      { len =  7; uv = 0; }
350     else                        { len = 13; uv = 0; } /* whoa! */
351 #endif
352
353     if (retlen)
354         *retlen = len;
355
356     expectlen = len;
357
358     if ((curlen < expectlen) &&
359         !(flags & UTF8_ALLOW_SHORT)) {
360         warning = UTF8_WARN_SHORT;
361         goto malformed;
362     }
363
364     len--;
365     s++;
366     ouv = uv;
367
368     while (len--) {
369         if (!UTF8_IS_CONTINUATION(*s) &&
370             !(flags & UTF8_ALLOW_NON_CONTINUATION)) {
371             s--;
372             warning = UTF8_WARN_NON_CONTINUATION;
373             goto malformed;
374         }
375         else
376             uv = UTF8_ACCUMULATE(uv, *s);
377         if (!(uv > ouv)) {
378             /* These cannot be allowed. */
379             if (uv == ouv) {
380                 if (!(flags & UTF8_ALLOW_LONG)) {
381                     warning = UTF8_WARN_LONG;
382                     goto malformed;
383                 }
384             }
385             else { /* uv < ouv */
386                 /* This cannot be allowed. */
387                 warning = UTF8_WARN_OVERFLOW;
388                 goto malformed;
389             }
390         }
391         s++;
392         ouv = uv;
393     }
394
395     if (UNICODE_IS_SURROGATE(uv) &&
396         !(flags & UTF8_ALLOW_SURROGATE)) {
397         warning = UTF8_WARN_SURROGATE;
398         goto malformed;
399     } else if ((expectlen > (STRLEN)UNISKIP(uv)) &&
400                !(flags & UTF8_ALLOW_LONG)) {
401         warning = UTF8_WARN_LONG;
402         goto malformed;
403     } else if (UNICODE_IS_ILLEGAL(uv) &&
404                !(flags & UTF8_ALLOW_FFFF)) {
405         warning = UTF8_WARN_FFFF;
406         goto malformed;
407     }
408
409     return uv;
410
411 malformed:
412
413     if (flags & UTF8_CHECK_ONLY) {
414         if (retlen)
415             *retlen = -1;
416         return 0;
417     }
418
419     if (dowarn) {
420         SV* sv = sv_2mortal(newSVpv("Malformed UTF-8 character ", 0));
421
422         switch (warning) {
423         case 0: /* Intentionally empty. */ break;
424         case UTF8_WARN_EMPTY:
425             Perl_sv_catpvf(aTHX_ sv, "(empty string)");
426             break;
427         case UTF8_WARN_CONTINUATION:
428             Perl_sv_catpvf(aTHX_ sv, "(unexpected continuation byte 0x%02"UVxf", with no preceding start byte)", uv);
429             break;
430         case UTF8_WARN_NON_CONTINUATION:
431             if (s == s0)
432                 Perl_sv_catpvf(aTHX_ sv, "(unexpected non-continuation byte 0x%02"UVxf", immediately after start byte 0x%02"UVxf")",
433                            (UV)s[1], startbyte);
434             else
435                 Perl_sv_catpvf(aTHX_ sv, "(unexpected non-continuation byte 0x%02"UVxf", %d byte%s after start byte 0x%02"UVxf", expected %d bytes)",
436                            (UV)s[1], s - s0, s - s0 > 1 ? "s" : "", startbyte, expectlen);
437               
438             break;
439         case UTF8_WARN_FE_FF:
440             Perl_sv_catpvf(aTHX_ sv, "(byte 0x%02"UVxf")", uv);
441             break;
442         case UTF8_WARN_SHORT:
443             Perl_sv_catpvf(aTHX_ sv, "(%d byte%s, need %d, after start byte 0x%02"UVxf")",
444                            curlen, curlen == 1 ? "" : "s", expectlen, startbyte);
445             expectlen = curlen;         /* distance for caller to skip */
446             break;
447         case UTF8_WARN_OVERFLOW:
448             Perl_sv_catpvf(aTHX_ sv, "(overflow at 0x%"UVxf", byte 0x%02x, after start byte 0x%02"UVxf")",
449                            ouv, *s, startbyte);
450             break;
451         case UTF8_WARN_SURROGATE:
452             Perl_sv_catpvf(aTHX_ sv, "(UTF-16 surrogate 0x%04"UVxf")", uv);
453             break;
454         case UTF8_WARN_LONG:
455             Perl_sv_catpvf(aTHX_ sv, "(%d byte%s, need %d, after start byte 0x%02"UVxf")",
456                            expectlen, expectlen == 1 ? "": "s", UNISKIP(uv), startbyte);
457             break;
458         case UTF8_WARN_FFFF:
459             Perl_sv_catpvf(aTHX_ sv, "(character 0x%04"UVxf")", uv);
460             break;
461         default:
462             Perl_sv_catpvf(aTHX_ sv, "(unknown reason)");
463             break;
464         }
465         
466         if (warning) {
467             char *s = SvPVX(sv);
468
469             if (PL_op)
470                 Perl_warner(aTHX_ packWARN(WARN_UTF8),
471                             "%s in %s", s,  OP_DESC(PL_op));
472             else
473                 Perl_warner(aTHX_ packWARN(WARN_UTF8), "%s", s);
474         }
475     }
476
477     if (retlen)
478         *retlen = expectlen ? expectlen : len;
479
480     return 0;
481 }
482
483 /*
484 =for apidoc A|UV|utf8_to_uvchr|U8 *s|STRLEN *retlen
485
486 Returns the native character value of the first character in the string C<s>
487 which is assumed to be in UTF8 encoding; C<retlen> will be set to the
488 length, in bytes, of that character.
489
490 If C<s> does not point to a well-formed UTF8 character, zero is
491 returned and retlen is set, if possible, to -1.
492
493 =cut
494 */
495
496 UV
497 Perl_utf8_to_uvchr(pTHX_ U8 *s, STRLEN *retlen)
498 {
499     return Perl_utf8n_to_uvchr(aTHX_ s, UTF8_MAXLEN, retlen,
500                                ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY);
501 }
502
503 /*
504 =for apidoc A|UV|utf8_to_uvuni|U8 *s|STRLEN *retlen
505
506 Returns the Unicode code point of the first character in the string C<s>
507 which is assumed to be in UTF8 encoding; C<retlen> will be set to the
508 length, in bytes, of that character.
509
510 This function should only be used when returned UV is considered
511 an index into the Unicode semantic tables (e.g. swashes).
512
513 If C<s> does not point to a well-formed UTF8 character, zero is
514 returned and retlen is set, if possible, to -1.
515
516 =cut
517 */
518
519 UV
520 Perl_utf8_to_uvuni(pTHX_ U8 *s, STRLEN *retlen)
521 {
522     /* Call the low level routine asking for checks */
523     return Perl_utf8n_to_uvuni(aTHX_ s, UTF8_MAXLEN, retlen,
524                                ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY);
525 }
526
527 /*
528 =for apidoc A|STRLEN|utf8_length|U8 *s|U8 *e
529
530 Return the length of the UTF-8 char encoded string C<s> in characters.
531 Stops at C<e> (inclusive).  If C<e E<lt> s> or if the scan would end
532 up past C<e>, croaks.
533
534 =cut
535 */
536
537 STRLEN
538 Perl_utf8_length(pTHX_ U8 *s, U8 *e)
539 {
540     STRLEN len = 0;
541
542     /* Note: cannot use UTF8_IS_...() too eagerly here since e.g.
543      * the bitops (especially ~) can create illegal UTF-8.
544      * In other words: in Perl UTF-8 is not just for Unicode. */
545
546     if (e < s) {
547         if (ckWARN_d(WARN_UTF8)) {
548             if (PL_op)
549                 Perl_warner(aTHX_ packWARN(WARN_UTF8),
550                             "%s in %s", unees, OP_DESC(PL_op));
551             else
552                 Perl_warner(aTHX_ packWARN(WARN_UTF8), unees);
553         }
554         return 0;
555     }
556     while (s < e) {
557         U8 t = UTF8SKIP(s);
558
559         if (e - s < t) {
560             if (ckWARN_d(WARN_UTF8)) {
561                 if (PL_op)
562                     Perl_warner(aTHX_ packWARN(WARN_UTF8),
563                                 unees, OP_DESC(PL_op));
564                 else
565                     Perl_warner(aTHX_ packWARN(WARN_UTF8), unees);
566             }
567             return len;
568         }
569         s += t;
570         len++;
571     }
572
573     return len;
574 }
575
576 /*
577 =for apidoc A|IV|utf8_distance|U8 *a|U8 *b
578
579 Returns the number of UTF8 characters between the UTF-8 pointers C<a>
580 and C<b>.
581
582 WARNING: use only if you *know* that the pointers point inside the
583 same UTF-8 buffer.
584
585 =cut
586 */
587
588 IV
589 Perl_utf8_distance(pTHX_ U8 *a, U8 *b)
590 {
591     IV off = 0;
592
593     /* Note: cannot use UTF8_IS_...() too eagerly here since  e.g.
594      * the bitops (especially ~) can create illegal UTF-8.
595      * In other words: in Perl UTF-8 is not just for Unicode. */
596
597     if (a < b) {
598         while (a < b) {
599             U8 c = UTF8SKIP(a);
600
601             if (b - a < c) {
602                 if (ckWARN_d(WARN_UTF8)) {
603                     if (PL_op)
604                         Perl_warner(aTHX_ packWARN(WARN_UTF8),
605                                     "%s in %s", unees, OP_DESC(PL_op));
606                     else
607                         Perl_warner(aTHX_ packWARN(WARN_UTF8), unees);
608                 }
609                 return off;
610             }
611             a += c;
612             off--;
613         }
614     }
615     else {
616         while (b < a) {
617             U8 c = UTF8SKIP(b);
618
619             if (a - b < c) {
620                 if (ckWARN_d(WARN_UTF8)) {
621                     if (PL_op)
622                         Perl_warner(aTHX_ packWARN(WARN_UTF8),
623                                     "%s in %s", unees, OP_DESC(PL_op));
624                     else
625                         Perl_warner(aTHX_ packWARN(WARN_UTF8), unees);
626                 }
627                 return off;
628             }
629             b += c;
630             off++;
631         }
632     }
633
634     return off;
635 }
636
637 /*
638 =for apidoc A|U8 *|utf8_hop|U8 *s|I32 off
639
640 Return the UTF-8 pointer C<s> displaced by C<off> characters, either
641 forward or backward.
642
643 WARNING: do not use the following unless you *know* C<off> is within
644 the UTF-8 data pointed to by C<s> *and* that on entry C<s> is aligned
645 on the first byte of character or just after the last byte of a character.
646
647 =cut
648 */
649
650 U8 *
651 Perl_utf8_hop(pTHX_ U8 *s, I32 off)
652 {
653     /* Note: cannot use UTF8_IS_...() too eagerly here since e.g
654      * the bitops (especially ~) can create illegal UTF-8.
655      * In other words: in Perl UTF-8 is not just for Unicode. */
656
657     if (off >= 0) {
658         while (off--)
659             s += UTF8SKIP(s);
660     }
661     else {
662         while (off++) {
663             s--;
664             while (UTF8_IS_CONTINUATION(*s))
665                 s--;
666         }
667     }
668     return s;
669 }
670
671 /*
672 =for apidoc A|U8 *|utf8_to_bytes|U8 *s|STRLEN *len
673
674 Converts a string C<s> of length C<len> from UTF8 into byte encoding.
675 Unlike C<bytes_to_utf8>, this over-writes the original string, and
676 updates len to contain the new length.
677 Returns zero on failure, setting C<len> to -1.
678
679 =cut
680 */
681
682 U8 *
683 Perl_utf8_to_bytes(pTHX_ U8 *s, STRLEN *len)
684 {
685     U8 *send;
686     U8 *d;
687     U8 *save = s;
688
689     /* ensure valid UTF8 and chars < 256 before updating string */
690     for (send = s + *len; s < send; ) {
691         U8 c = *s++;
692
693         if (!UTF8_IS_INVARIANT(c) &&
694             (!UTF8_IS_DOWNGRADEABLE_START(c) || (s >= send)
695              || !(c = *s++) || !UTF8_IS_CONTINUATION(c))) {
696             *len = -1;
697             return 0;
698         }
699     }
700
701     d = s = save;
702     while (s < send) {
703         STRLEN ulen;
704         *d++ = (U8)utf8_to_uvchr(s, &ulen);
705         s += ulen;
706     }
707     *d = '\0';
708     *len = d - save;
709     return save;
710 }
711
712 /*
713 =for apidoc A|U8 *|bytes_from_utf8|U8 *s|STRLEN *len|bool *is_utf8
714
715 Converts a string C<s> of length C<len> from UTF8 into byte encoding.
716 Unlike <utf8_to_bytes> but like C<bytes_to_utf8>, returns a pointer to
717 the newly-created string, and updates C<len> to contain the new
718 length.  Returns the original string if no conversion occurs, C<len>
719 is unchanged. Do nothing if C<is_utf8> points to 0. Sets C<is_utf8> to
720 0 if C<s> is converted or contains all 7bit characters.
721
722 =cut
723 */
724
725 U8 *
726 Perl_bytes_from_utf8(pTHX_ U8 *s, STRLEN *len, bool *is_utf8)
727 {
728     U8 *d;
729     U8 *start = s;
730     U8 *send;
731     I32 count = 0;
732
733     if (!*is_utf8)
734         return start;
735
736     /* ensure valid UTF8 and chars < 256 before converting string */
737     for (send = s + *len; s < send;) {
738         U8 c = *s++;
739         if (!UTF8_IS_INVARIANT(c)) {
740             if (UTF8_IS_DOWNGRADEABLE_START(c) && s < send &&
741                 (c = *s++) && UTF8_IS_CONTINUATION(c))
742                 count++;
743             else
744                 return start;
745         }
746     }
747
748     *is_utf8 = 0;               
749
750     Newz(801, d, (*len) - count + 1, U8);
751     s = start; start = d;
752     while (s < send) {
753         U8 c = *s++;
754         if (!UTF8_IS_INVARIANT(c)) {
755             /* Then it is two-byte encoded */
756             c = UTF8_ACCUMULATE(NATIVE_TO_UTF(c), *s++);
757             c = ASCII_TO_NATIVE(c);
758         }
759         *d++ = c;
760     }
761     *d = '\0';
762     *len = d - start;
763     return start;
764 }
765
766 /*
767 =for apidoc A|U8 *|bytes_to_utf8|U8 *s|STRLEN *len
768
769 Converts a string C<s> of length C<len> from ASCII into UTF8 encoding.
770 Returns a pointer to the newly-created string, and sets C<len> to
771 reflect the new length.
772
773 If you want to convert to UTF8 from other encodings than ASCII,
774 see sv_recode_to_utf8().
775
776 =cut
777 */
778
779 U8*
780 Perl_bytes_to_utf8(pTHX_ U8 *s, STRLEN *len)
781 {
782     U8 *send;
783     U8 *d;
784     U8 *dst;
785     send = s + (*len);
786
787     Newz(801, d, (*len) * 2 + 1, U8);
788     dst = d;
789
790     while (s < send) {
791         UV uv = NATIVE_TO_ASCII(*s++);
792         if (UNI_IS_INVARIANT(uv))
793             *d++ = (U8)UTF_TO_NATIVE(uv);
794         else {
795             *d++ = (U8)UTF8_EIGHT_BIT_HI(uv);
796             *d++ = (U8)UTF8_EIGHT_BIT_LO(uv);
797         }
798     }
799     *d = '\0';
800     *len = d-dst;
801     return dst;
802 }
803
804 /*
805  * Convert native (big-endian) or reversed (little-endian) UTF-16 to UTF-8.
806  *
807  * Destination must be pre-extended to 3/2 source.  Do not use in-place.
808  * We optimize for native, for obvious reasons. */
809
810 U8*
811 Perl_utf16_to_utf8(pTHX_ U8* p, U8* d, I32 bytelen, I32 *newlen)
812 {
813     U8* pend;
814     U8* dstart = d;
815
816     if (bytelen & 1)
817         Perl_croak(aTHX_ "panic: utf16_to_utf8: odd bytelen");
818
819     pend = p + bytelen;
820
821     while (p < pend) {
822         UV uv = (p[0] << 8) + p[1]; /* UTF-16BE */
823         p += 2;
824         if (uv < 0x80) {
825             *d++ = (U8)uv;
826             continue;
827         }
828         if (uv < 0x800) {
829             *d++ = (U8)(( uv >>  6)         | 0xc0);
830             *d++ = (U8)(( uv        & 0x3f) | 0x80);
831             continue;
832         }
833         if (uv >= 0xd800 && uv < 0xdbff) {      /* surrogates */
834             UV low = (p[0] << 8) + p[1];
835             p += 2;
836             if (low < 0xdc00 || low >= 0xdfff)
837                 Perl_croak(aTHX_ "Malformed UTF-16 surrogate");
838             uv = ((uv - 0xd800) << 10) + (low - 0xdc00) + 0x10000;
839         }
840         if (uv < 0x10000) {
841             *d++ = (U8)(( uv >> 12)         | 0xe0);
842             *d++ = (U8)(((uv >>  6) & 0x3f) | 0x80);
843             *d++ = (U8)(( uv        & 0x3f) | 0x80);
844             continue;
845         }
846         else {
847             *d++ = (U8)(( uv >> 18)         | 0xf0);
848             *d++ = (U8)(((uv >> 12) & 0x3f) | 0x80);
849             *d++ = (U8)(((uv >>  6) & 0x3f) | 0x80);
850             *d++ = (U8)(( uv        & 0x3f) | 0x80);
851             continue;
852         }
853     }
854     *newlen = d - dstart;
855     return d;
856 }
857
858 /* Note: this one is slightly destructive of the source. */
859
860 U8*
861 Perl_utf16_to_utf8_reversed(pTHX_ U8* p, U8* d, I32 bytelen, I32 *newlen)
862 {
863     U8* s = (U8*)p;
864     U8* send = s + bytelen;
865     while (s < send) {
866         U8 tmp = s[0];
867         s[0] = s[1];
868         s[1] = tmp;
869         s += 2;
870     }
871     return utf16_to_utf8(p, d, bytelen, newlen);
872 }
873
874 /* for now these are all defined (inefficiently) in terms of the utf8 versions */
875
876 bool
877 Perl_is_uni_alnum(pTHX_ UV c)
878 {
879     U8 tmpbuf[UTF8_MAXLEN+1];
880     uvchr_to_utf8(tmpbuf, c);
881     return is_utf8_alnum(tmpbuf);
882 }
883
884 bool
885 Perl_is_uni_alnumc(pTHX_ UV c)
886 {
887     U8 tmpbuf[UTF8_MAXLEN+1];
888     uvchr_to_utf8(tmpbuf, c);
889     return is_utf8_alnumc(tmpbuf);
890 }
891
892 bool
893 Perl_is_uni_idfirst(pTHX_ UV c)
894 {
895     U8 tmpbuf[UTF8_MAXLEN+1];
896     uvchr_to_utf8(tmpbuf, c);
897     return is_utf8_idfirst(tmpbuf);
898 }
899
900 bool
901 Perl_is_uni_alpha(pTHX_ UV c)
902 {
903     U8 tmpbuf[UTF8_MAXLEN+1];
904     uvchr_to_utf8(tmpbuf, c);
905     return is_utf8_alpha(tmpbuf);
906 }
907
908 bool
909 Perl_is_uni_ascii(pTHX_ UV c)
910 {
911     U8 tmpbuf[UTF8_MAXLEN+1];
912     uvchr_to_utf8(tmpbuf, c);
913     return is_utf8_ascii(tmpbuf);
914 }
915
916 bool
917 Perl_is_uni_space(pTHX_ UV c)
918 {
919     U8 tmpbuf[UTF8_MAXLEN+1];
920     uvchr_to_utf8(tmpbuf, c);
921     return is_utf8_space(tmpbuf);
922 }
923
924 bool
925 Perl_is_uni_digit(pTHX_ UV c)
926 {
927     U8 tmpbuf[UTF8_MAXLEN+1];
928     uvchr_to_utf8(tmpbuf, c);
929     return is_utf8_digit(tmpbuf);
930 }
931
932 bool
933 Perl_is_uni_upper(pTHX_ UV c)
934 {
935     U8 tmpbuf[UTF8_MAXLEN+1];
936     uvchr_to_utf8(tmpbuf, c);
937     return is_utf8_upper(tmpbuf);
938 }
939
940 bool
941 Perl_is_uni_lower(pTHX_ UV c)
942 {
943     U8 tmpbuf[UTF8_MAXLEN+1];
944     uvchr_to_utf8(tmpbuf, c);
945     return is_utf8_lower(tmpbuf);
946 }
947
948 bool
949 Perl_is_uni_cntrl(pTHX_ UV c)
950 {
951     U8 tmpbuf[UTF8_MAXLEN+1];
952     uvchr_to_utf8(tmpbuf, c);
953     return is_utf8_cntrl(tmpbuf);
954 }
955
956 bool
957 Perl_is_uni_graph(pTHX_ UV c)
958 {
959     U8 tmpbuf[UTF8_MAXLEN+1];
960     uvchr_to_utf8(tmpbuf, c);
961     return is_utf8_graph(tmpbuf);
962 }
963
964 bool
965 Perl_is_uni_print(pTHX_ UV c)
966 {
967     U8 tmpbuf[UTF8_MAXLEN+1];
968     uvchr_to_utf8(tmpbuf, c);
969     return is_utf8_print(tmpbuf);
970 }
971
972 bool
973 Perl_is_uni_punct(pTHX_ UV c)
974 {
975     U8 tmpbuf[UTF8_MAXLEN+1];
976     uvchr_to_utf8(tmpbuf, c);
977     return is_utf8_punct(tmpbuf);
978 }
979
980 bool
981 Perl_is_uni_xdigit(pTHX_ UV c)
982 {
983     U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
984     uvchr_to_utf8(tmpbuf, c);
985     return is_utf8_xdigit(tmpbuf);
986 }
987
988 UV
989 Perl_to_uni_upper(pTHX_ UV c, U8* p, STRLEN *lenp)
990 {
991     uvchr_to_utf8(p, c);
992     return to_utf8_upper(p, p, lenp);
993 }
994
995 UV
996 Perl_to_uni_title(pTHX_ UV c, U8* p, STRLEN *lenp)
997 {
998     uvchr_to_utf8(p, c);
999     return to_utf8_title(p, p, lenp);
1000 }
1001
1002 UV
1003 Perl_to_uni_lower(pTHX_ UV c, U8* p, STRLEN *lenp)
1004 {
1005     uvchr_to_utf8(p, c);
1006     return to_utf8_lower(p, p, lenp);
1007 }
1008
1009 UV
1010 Perl_to_uni_fold(pTHX_ UV c, U8* p, STRLEN *lenp)
1011 {
1012     uvchr_to_utf8(p, c);
1013     return to_utf8_fold(p, p, lenp);
1014 }
1015
1016 /* for now these all assume no locale info available for Unicode > 255 */
1017
1018 bool
1019 Perl_is_uni_alnum_lc(pTHX_ UV c)
1020 {
1021     return is_uni_alnum(c);     /* XXX no locale support yet */
1022 }
1023
1024 bool
1025 Perl_is_uni_alnumc_lc(pTHX_ UV c)
1026 {
1027     return is_uni_alnumc(c);    /* XXX no locale support yet */
1028 }
1029
1030 bool
1031 Perl_is_uni_idfirst_lc(pTHX_ UV c)
1032 {
1033     return is_uni_idfirst(c);   /* XXX no locale support yet */
1034 }
1035
1036 bool
1037 Perl_is_uni_alpha_lc(pTHX_ UV c)
1038 {
1039     return is_uni_alpha(c);     /* XXX no locale support yet */
1040 }
1041
1042 bool
1043 Perl_is_uni_ascii_lc(pTHX_ UV c)
1044 {
1045     return is_uni_ascii(c);     /* XXX no locale support yet */
1046 }
1047
1048 bool
1049 Perl_is_uni_space_lc(pTHX_ UV c)
1050 {
1051     return is_uni_space(c);     /* XXX no locale support yet */
1052 }
1053
1054 bool
1055 Perl_is_uni_digit_lc(pTHX_ UV c)
1056 {
1057     return is_uni_digit(c);     /* XXX no locale support yet */
1058 }
1059
1060 bool
1061 Perl_is_uni_upper_lc(pTHX_ UV c)
1062 {
1063     return is_uni_upper(c);     /* XXX no locale support yet */
1064 }
1065
1066 bool
1067 Perl_is_uni_lower_lc(pTHX_ UV c)
1068 {
1069     return is_uni_lower(c);     /* XXX no locale support yet */
1070 }
1071
1072 bool
1073 Perl_is_uni_cntrl_lc(pTHX_ UV c)
1074 {
1075     return is_uni_cntrl(c);     /* XXX no locale support yet */
1076 }
1077
1078 bool
1079 Perl_is_uni_graph_lc(pTHX_ UV c)
1080 {
1081     return is_uni_graph(c);     /* XXX no locale support yet */
1082 }
1083
1084 bool
1085 Perl_is_uni_print_lc(pTHX_ UV c)
1086 {
1087     return is_uni_print(c);     /* XXX no locale support yet */
1088 }
1089
1090 bool
1091 Perl_is_uni_punct_lc(pTHX_ UV c)
1092 {
1093     return is_uni_punct(c);     /* XXX no locale support yet */
1094 }
1095
1096 bool
1097 Perl_is_uni_xdigit_lc(pTHX_ UV c)
1098 {
1099     return is_uni_xdigit(c);    /* XXX no locale support yet */
1100 }
1101
1102 U32
1103 Perl_to_uni_upper_lc(pTHX_ U32 c)
1104 {
1105     /* XXX returns only the first character -- do not use XXX */
1106     /* XXX no locale support yet */
1107     STRLEN len;
1108     U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
1109     return (U32)to_uni_upper(c, tmpbuf, &len);
1110 }
1111
1112 U32
1113 Perl_to_uni_title_lc(pTHX_ U32 c)
1114 {
1115     /* XXX returns only the first character XXX -- do not use XXX */
1116     /* XXX no locale support yet */
1117     STRLEN len;
1118     U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
1119     return (U32)to_uni_title(c, tmpbuf, &len);
1120 }
1121
1122 U32
1123 Perl_to_uni_lower_lc(pTHX_ U32 c)
1124 {
1125     /* XXX returns only the first character -- do not use XXX */
1126     /* XXX no locale support yet */
1127     STRLEN len;
1128     U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
1129     return (U32)to_uni_lower(c, tmpbuf, &len);
1130 }
1131
1132 bool
1133 Perl_is_utf8_alnum(pTHX_ U8 *p)
1134 {
1135     if (!is_utf8_char(p))
1136         return FALSE;
1137     if (!PL_utf8_alnum)
1138         /* NOTE: "IsWord", not "IsAlnum", since Alnum is a true
1139          * descendant of isalnum(3), in other words, it doesn't
1140          * contain the '_'. --jhi */
1141         PL_utf8_alnum = swash_init("utf8", "IsWord", &PL_sv_undef, 0, 0);
1142     return swash_fetch(PL_utf8_alnum, p, TRUE) != 0;
1143 /*    return *p == '_' || is_utf8_alpha(p) || is_utf8_digit(p); */
1144 #ifdef SURPRISINGLY_SLOWER  /* probably because alpha is usually true */
1145     if (!PL_utf8_alnum)
1146         PL_utf8_alnum = swash_init("utf8", "",
1147             sv_2mortal(newSVpv("+utf8::IsAlpha\n+utf8::IsDigit\n005F\n",0)), 0, 0);
1148     return swash_fetch(PL_utf8_alnum, p, TRUE) != 0;
1149 #endif
1150 }
1151
1152 bool
1153 Perl_is_utf8_alnumc(pTHX_ U8 *p)
1154 {
1155     if (!is_utf8_char(p))
1156         return FALSE;
1157     if (!PL_utf8_alnum)
1158         PL_utf8_alnum = swash_init("utf8", "IsAlnumC", &PL_sv_undef, 0, 0);
1159     return swash_fetch(PL_utf8_alnum, p, TRUE) != 0;
1160 /*    return is_utf8_alpha(p) || is_utf8_digit(p); */
1161 #ifdef SURPRISINGLY_SLOWER  /* probably because alpha is usually true */
1162     if (!PL_utf8_alnum)
1163         PL_utf8_alnum = swash_init("utf8", "",
1164             sv_2mortal(newSVpv("+utf8::IsAlpha\n+utf8::IsDigit\n005F\n",0)), 0, 0);
1165     return swash_fetch(PL_utf8_alnum, p, TRUE) != 0;
1166 #endif
1167 }
1168
1169 bool
1170 Perl_is_utf8_idfirst(pTHX_ U8 *p) /* The naming is historical. */
1171 {
1172     if (*p == '_')
1173         return TRUE;
1174     if (!is_utf8_char(p))
1175         return FALSE;
1176     if (!PL_utf8_idstart) /* is_utf8_idstart would be more logical. */
1177         PL_utf8_idstart = swash_init("utf8", "IdStart", &PL_sv_undef, 0, 0);
1178     return swash_fetch(PL_utf8_idstart, p, TRUE) != 0;
1179 }
1180
1181 bool
1182 Perl_is_utf8_idcont(pTHX_ U8 *p)
1183 {
1184     if (*p == '_')
1185         return TRUE;
1186     if (!is_utf8_char(p))
1187         return FALSE;
1188     if (!PL_utf8_idcont)
1189         PL_utf8_idcont = swash_init("utf8", "IdContinue", &PL_sv_undef, 0, 0);
1190     return swash_fetch(PL_utf8_idcont, p, TRUE) != 0;
1191 }
1192
1193 bool
1194 Perl_is_utf8_alpha(pTHX_ U8 *p)
1195 {
1196     if (!is_utf8_char(p))
1197         return FALSE;
1198     if (!PL_utf8_alpha)
1199         PL_utf8_alpha = swash_init("utf8", "IsAlpha", &PL_sv_undef, 0, 0);
1200     return swash_fetch(PL_utf8_alpha, p, TRUE) != 0;
1201 }
1202
1203 bool
1204 Perl_is_utf8_ascii(pTHX_ U8 *p)
1205 {
1206     if (!is_utf8_char(p))
1207         return FALSE;
1208     if (!PL_utf8_ascii)
1209         PL_utf8_ascii = swash_init("utf8", "IsAscii", &PL_sv_undef, 0, 0);
1210     return swash_fetch(PL_utf8_ascii, p, TRUE) != 0;
1211 }
1212
1213 bool
1214 Perl_is_utf8_space(pTHX_ U8 *p)
1215 {
1216     if (!is_utf8_char(p))
1217         return FALSE;
1218     if (!PL_utf8_space)
1219         PL_utf8_space = swash_init("utf8", "IsSpacePerl", &PL_sv_undef, 0, 0);
1220     return swash_fetch(PL_utf8_space, p, TRUE) != 0;
1221 }
1222
1223 bool
1224 Perl_is_utf8_digit(pTHX_ U8 *p)
1225 {
1226     if (!is_utf8_char(p))
1227         return FALSE;
1228     if (!PL_utf8_digit)
1229         PL_utf8_digit = swash_init("utf8", "IsDigit", &PL_sv_undef, 0, 0);
1230     return swash_fetch(PL_utf8_digit, p, TRUE) != 0;
1231 }
1232
1233 bool
1234 Perl_is_utf8_upper(pTHX_ U8 *p)
1235 {
1236     if (!is_utf8_char(p))
1237         return FALSE;
1238     if (!PL_utf8_upper)
1239         PL_utf8_upper = swash_init("utf8", "IsUppercase", &PL_sv_undef, 0, 0);
1240     return swash_fetch(PL_utf8_upper, p, TRUE) != 0;
1241 }
1242
1243 bool
1244 Perl_is_utf8_lower(pTHX_ U8 *p)
1245 {
1246     if (!is_utf8_char(p))
1247         return FALSE;
1248     if (!PL_utf8_lower)
1249         PL_utf8_lower = swash_init("utf8", "IsLowercase", &PL_sv_undef, 0, 0);
1250     return swash_fetch(PL_utf8_lower, p, TRUE) != 0;
1251 }
1252
1253 bool
1254 Perl_is_utf8_cntrl(pTHX_ U8 *p)
1255 {
1256     if (!is_utf8_char(p))
1257         return FALSE;
1258     if (!PL_utf8_cntrl)
1259         PL_utf8_cntrl = swash_init("utf8", "IsCntrl", &PL_sv_undef, 0, 0);
1260     return swash_fetch(PL_utf8_cntrl, p, TRUE) != 0;
1261 }
1262
1263 bool
1264 Perl_is_utf8_graph(pTHX_ U8 *p)
1265 {
1266     if (!is_utf8_char(p))
1267         return FALSE;
1268     if (!PL_utf8_graph)
1269         PL_utf8_graph = swash_init("utf8", "IsGraph", &PL_sv_undef, 0, 0);
1270     return swash_fetch(PL_utf8_graph, p, TRUE) != 0;
1271 }
1272
1273 bool
1274 Perl_is_utf8_print(pTHX_ U8 *p)
1275 {
1276     if (!is_utf8_char(p))
1277         return FALSE;
1278     if (!PL_utf8_print)
1279         PL_utf8_print = swash_init("utf8", "IsPrint", &PL_sv_undef, 0, 0);
1280     return swash_fetch(PL_utf8_print, p, TRUE) != 0;
1281 }
1282
1283 bool
1284 Perl_is_utf8_punct(pTHX_ U8 *p)
1285 {
1286     if (!is_utf8_char(p))
1287         return FALSE;
1288     if (!PL_utf8_punct)
1289         PL_utf8_punct = swash_init("utf8", "IsPunct", &PL_sv_undef, 0, 0);
1290     return swash_fetch(PL_utf8_punct, p, TRUE) != 0;
1291 }
1292
1293 bool
1294 Perl_is_utf8_xdigit(pTHX_ U8 *p)
1295 {
1296     if (!is_utf8_char(p))
1297         return FALSE;
1298     if (!PL_utf8_xdigit)
1299         PL_utf8_xdigit = swash_init("utf8", "IsXDigit", &PL_sv_undef, 0, 0);
1300     return swash_fetch(PL_utf8_xdigit, p, TRUE) != 0;
1301 }
1302
1303 bool
1304 Perl_is_utf8_mark(pTHX_ U8 *p)
1305 {
1306     if (!is_utf8_char(p))
1307         return FALSE;
1308     if (!PL_utf8_mark)
1309         PL_utf8_mark = swash_init("utf8", "IsM", &PL_sv_undef, 0, 0);
1310     return swash_fetch(PL_utf8_mark, p, TRUE) != 0;
1311 }
1312
1313 /*
1314 =for apidoc A|UV|to_utf8_case|U8 *p|U8* ustrp|STRLEN *lenp|SV **swash|char *normal|char *special
1315
1316 The "p" contains the pointer to the UTF-8 string encoding
1317 the character that is being converted.
1318
1319 The "ustrp" is a pointer to the character buffer to put the
1320 conversion result to.  The "lenp" is a pointer to the length
1321 of the result.
1322
1323 The "swashp" is a pointer to the swash to use.
1324
1325 Both the special and normal mappings are stored lib/unicore/To/Foo.pl,
1326 and loaded by SWASHGET, using lib/utf8_heavy.pl.  The special (usually,
1327 but not always, a multicharacter mapping), is tried first.
1328
1329 The "special" is a string like "utf8::ToSpecLower", which means the
1330 hash %utf8::ToSpecLower.  The access to the hash is through
1331 Perl_to_utf8_case().
1332
1333 The "normal" is a string like "ToLower" which means the swash
1334 %utf8::ToLower.
1335
1336 =cut */
1337
1338 UV
1339 Perl_to_utf8_case(pTHX_ U8 *p, U8* ustrp, STRLEN *lenp, SV **swashp, char *normal, char *special)
1340 {
1341     UV uv0, uv1;
1342     U8 tmpbuf[UTF8_MAXLEN_FOLD+1];
1343     STRLEN len = 0;
1344
1345     uv0 = utf8_to_uvchr(p, 0);
1346     /* The NATIVE_TO_UNI() and UNI_TO_NATIVE() mappings
1347      * are necessary in EBCDIC, they are redundant no-ops
1348      * in ASCII-ish platforms, and hopefully optimized away. */
1349     uv1 = NATIVE_TO_UNI(uv0);
1350     uvuni_to_utf8(tmpbuf, uv1);
1351
1352     if (!*swashp) /* load on-demand */
1353          *swashp = swash_init("utf8", normal, &PL_sv_undef, 4, 0);
1354
1355     if (special) {
1356          /* It might be "special" (sometimes, but not always,
1357           * a multicharacter mapping) */
1358          HV *hv;
1359          SV *keysv;
1360          HE *he;
1361          SV *val;
1362         
1363          if ((hv    = get_hv(special, FALSE)) &&
1364              (keysv = sv_2mortal(Perl_newSVpvf(aTHX_ "%04"UVXf, uv1))) &&
1365              (he    = hv_fetch_ent(hv, keysv, FALSE, 0)) &&
1366              (val   = HeVAL(he))) {
1367              char *s;
1368
1369               s = SvPV(val, len);
1370               if (len == 1)
1371                    len = uvuni_to_utf8(ustrp, NATIVE_TO_UNI(*(U8*)s)) - ustrp;
1372               else {
1373 #ifdef EBCDIC
1374                    /* If we have EBCDIC we need to remap the characters
1375                     * since any characters in the low 256 are Unicode
1376                     * code points, not EBCDIC. */
1377                    U8 *t = (U8*)s, *tend = t + len, *d;
1378                 
1379                    d = tmpbuf;
1380                    if (SvUTF8(val)) {
1381                         STRLEN tlen = 0;
1382                         
1383                         while (t < tend) {
1384                              UV c = utf8_to_uvchr(t, &tlen);
1385                              if (tlen > 0) {
1386                                   d = uvchr_to_utf8(d, UNI_TO_NATIVE(c));
1387                                   t += tlen;
1388                              }
1389                              else
1390                                   break;
1391                         }
1392                    }
1393                    else {
1394                         while (t < tend) {
1395                              d = uvchr_to_utf8(d, UNI_TO_NATIVE(*t));
1396                              t++;
1397                         }
1398                    }
1399                    len = d - tmpbuf;
1400                    Copy(tmpbuf, ustrp, len, U8);
1401 #else
1402                    Copy(s, ustrp, len, U8);
1403 #endif
1404               }
1405          }
1406     }
1407
1408     if (!len && *swashp) {
1409          UV uv2 = swash_fetch(*swashp, tmpbuf, TRUE);
1410          
1411          if (uv2) {
1412               /* It was "normal" (a single character mapping). */
1413               UV uv3 = UNI_TO_NATIVE(uv2);
1414               
1415               len = uvchr_to_utf8(ustrp, uv3) - ustrp;
1416          }
1417     }
1418
1419     if (!len) /* Neither: just copy. */
1420          len = uvchr_to_utf8(ustrp, uv0) - ustrp;
1421
1422     if (lenp)
1423          *lenp = len;
1424
1425     return len ? utf8_to_uvchr(ustrp, 0) : 0;
1426 }
1427
1428 /*
1429 =for apidoc A|UV|to_utf8_upper|U8 *p|U8 *ustrp|STRLEN *lenp
1430
1431 Convert the UTF-8 encoded character at p to its uppercase version and
1432 store that in UTF-8 in ustrp and its length in bytes in lenp.  Note
1433 that the ustrp needs to be at least UTF8_MAXLEN_UCLC+1 bytes since the
1434 uppercase version may be longer than the original character (up to two
1435 characters).
1436
1437 The first character of the uppercased version is returned
1438 (but note, as explained above, that there may be more.)
1439
1440 =cut */
1441
1442 UV
1443 Perl_to_utf8_upper(pTHX_ U8 *p, U8* ustrp, STRLEN *lenp)
1444 {
1445     return Perl_to_utf8_case(aTHX_ p, ustrp, lenp,
1446                              &PL_utf8_toupper, "ToUpper", "utf8::ToSpecUpper");
1447 }
1448
1449 /*
1450 =for apidoc A|UV|to_utf8_title|U8 *p|U8 *ustrp|STRLEN *lenp
1451
1452 Convert the UTF-8 encoded character at p to its titlecase version and
1453 store that in UTF-8 in ustrp and its length in bytes in lenp.  Note
1454 that the ustrp needs to be at least UTF8_MAXLEN_UCLC+1 bytes since the
1455 titlecase version may be longer than the original character (up to two
1456 characters).
1457
1458 The first character of the titlecased version is returned
1459 (but note, as explained above, that there may be more.)
1460
1461 =cut */
1462
1463 UV
1464 Perl_to_utf8_title(pTHX_ U8 *p, U8* ustrp, STRLEN *lenp)
1465 {
1466     return Perl_to_utf8_case(aTHX_ p, ustrp, lenp,
1467                              &PL_utf8_totitle, "ToTitle", "utf8::ToSpecTitle");
1468 }
1469
1470 /*
1471 =for apidoc A|UV|to_utf8_lower|U8 *p|U8 *ustrp|STRLEN *lenp
1472
1473 Convert the UTF-8 encoded character at p to its lowercase version and
1474 store that in UTF-8 in ustrp and its length in bytes in lenp.  Note
1475 that the ustrp needs to be at least UTF8_MAXLEN_UCLC+1 bytes since the
1476 lowercase version may be longer than the original character (up to two
1477 characters).
1478
1479 The first character of the lowercased version is returned
1480 (but note, as explained above, that there may be more.)
1481
1482 =cut */
1483
1484 UV
1485 Perl_to_utf8_lower(pTHX_ U8 *p, U8* ustrp, STRLEN *lenp)
1486 {
1487     return Perl_to_utf8_case(aTHX_ p, ustrp, lenp,
1488                              &PL_utf8_tolower, "ToLower", "utf8::ToSpecLower");
1489 }
1490
1491 /*
1492 =for apidoc A|UV|to_utf8_fold|U8 *p|U8 *ustrp|STRLEN *lenp
1493
1494 Convert the UTF-8 encoded character at p to its foldcase version and
1495 store that in UTF-8 in ustrp and its length in bytes in lenp.  Note
1496 that the ustrp needs to be at least UTF8_MAXLEN_FOLD+1 bytes since the
1497 foldcase version may be longer than the original character (up to
1498 three characters).
1499
1500 The first character of the foldcased version is returned
1501 (but note, as explained above, that there may be more.)
1502
1503 =cut */
1504
1505 UV
1506 Perl_to_utf8_fold(pTHX_ U8 *p, U8* ustrp, STRLEN *lenp)
1507 {
1508     return Perl_to_utf8_case(aTHX_ p, ustrp, lenp,
1509                              &PL_utf8_tofold, "ToFold", "utf8::ToSpecFold");
1510 }
1511
1512 /* a "swash" is a swatch hash */
1513
1514 SV*
1515 Perl_swash_init(pTHX_ char* pkg, char* name, SV *listsv, I32 minbits, I32 none)
1516 {
1517     SV* retval;
1518     SV* tokenbufsv = sv_2mortal(NEWSV(0,0));
1519     dSP;
1520     HV *stash = gv_stashpvn(pkg, strlen(pkg), FALSE);
1521     SV* errsv_save;
1522
1523     if (!gv_fetchmeth(stash, "SWASHNEW", 8, -1)) {      /* demand load utf8 */
1524         ENTER;
1525         errsv_save = newSVsv(ERRSV);
1526         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpv(pkg,0), Nullsv);
1527         if (!SvTRUE(ERRSV))
1528             sv_setsv(ERRSV, errsv_save);
1529         SvREFCNT_dec(errsv_save);
1530         LEAVE;
1531     }
1532     SPAGAIN;
1533     PUSHSTACKi(PERLSI_MAGIC);
1534     PUSHMARK(SP);
1535     EXTEND(SP,5);
1536     PUSHs(sv_2mortal(newSVpvn(pkg, strlen(pkg))));
1537     PUSHs(sv_2mortal(newSVpvn(name, strlen(name))));
1538     PUSHs(listsv);
1539     PUSHs(sv_2mortal(newSViv(minbits)));
1540     PUSHs(sv_2mortal(newSViv(none)));
1541     PUTBACK;
1542     ENTER;
1543     SAVEI32(PL_hints);
1544     PL_hints = 0;
1545     save_re_context();
1546     if (PL_curcop == &PL_compiling) {
1547         /* XXX ought to be handled by lex_start */
1548         SAVEI32(PL_in_my);
1549         PL_in_my = 0;
1550         sv_setpv(tokenbufsv, PL_tokenbuf);
1551     }
1552     errsv_save = newSVsv(ERRSV);
1553     if (call_method("SWASHNEW", G_SCALAR))
1554         retval = newSVsv(*PL_stack_sp--);
1555     else
1556         retval = &PL_sv_undef;
1557     if (!SvTRUE(ERRSV))
1558         sv_setsv(ERRSV, errsv_save);
1559     SvREFCNT_dec(errsv_save);
1560     LEAVE;
1561     POPSTACK;
1562     if (PL_curcop == &PL_compiling) {
1563         STRLEN len;
1564         char* pv = SvPV(tokenbufsv, len);
1565
1566         Copy(pv, PL_tokenbuf, len+1, char);
1567         PL_curcop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
1568     }
1569     if (!SvROK(retval) || SvTYPE(SvRV(retval)) != SVt_PVHV) {
1570         if (SvPOK(retval))
1571             Perl_croak(aTHX_ "Can't find Unicode property definition \"%"SVf"\"",
1572                        retval);
1573         Perl_croak(aTHX_ "SWASHNEW didn't return an HV ref");
1574     }
1575     return retval;
1576 }
1577
1578
1579 /* This API is wrong for special case conversions since we may need to
1580  * return several Unicode characters for a single Unicode character
1581  * (see lib/unicore/SpecCase.txt) The SWASHGET in lib/utf8_heavy.pl is
1582  * the lower-level routine, and it is similarly broken for returning
1583  * multiple values.  --jhi */
1584 UV
1585 Perl_swash_fetch(pTHX_ SV *sv, U8 *ptr, bool do_utf8)
1586 {
1587     HV* hv = (HV*)SvRV(sv);
1588     U32 klen;
1589     U32 off;
1590     STRLEN slen;
1591     STRLEN needents;
1592     U8 *tmps = NULL;
1593     U32 bit;
1594     SV *retval;
1595     U8 tmputf8[2];
1596     UV c = NATIVE_TO_ASCII(*ptr);
1597
1598     if (!do_utf8 && !UNI_IS_INVARIANT(c)) {
1599         tmputf8[0] = (U8)UTF8_EIGHT_BIT_HI(c);
1600         tmputf8[1] = (U8)UTF8_EIGHT_BIT_LO(c);
1601         ptr = tmputf8;
1602     }
1603     /* Given a UTF-X encoded char 0xAA..0xYY,0xZZ
1604      * then the "swatch" is a vec() for al the chars which start
1605      * with 0xAA..0xYY
1606      * So the key in the hash (klen) is length of encoded char -1
1607      */
1608     klen = UTF8SKIP(ptr) - 1;
1609     off  = ptr[klen];
1610
1611     if (klen == 0)
1612      {
1613       /* If char in invariant then swatch is for all the invariant chars
1614        * In both UTF-8 and UTF8-MOD that happens to be UTF_CONTINUATION_MARK
1615        */
1616       needents = UTF_CONTINUATION_MARK;
1617       off      = NATIVE_TO_UTF(ptr[klen]);
1618      }
1619     else
1620      {
1621       /* If char is encoded then swatch is for the prefix */
1622       needents = (1 << UTF_ACCUMULATION_SHIFT);
1623       off      = NATIVE_TO_UTF(ptr[klen]) & UTF_CONTINUATION_MASK;
1624      }
1625
1626     /*
1627      * This single-entry cache saves about 1/3 of the utf8 overhead in test
1628      * suite.  (That is, only 7-8% overall over just a hash cache.  Still,
1629      * it's nothing to sniff at.)  Pity we usually come through at least
1630      * two function calls to get here...
1631      *
1632      * NB: this code assumes that swatches are never modified, once generated!
1633      */
1634
1635     if (hv   == PL_last_swash_hv &&
1636         klen == PL_last_swash_klen &&
1637         (!klen || memEQ((char *)ptr, (char *)PL_last_swash_key, klen)) )
1638     {
1639         tmps = PL_last_swash_tmps;
1640         slen = PL_last_swash_slen;
1641     }
1642     else {
1643         /* Try our second-level swatch cache, kept in a hash. */
1644         SV** svp = hv_fetch(hv, (char*)ptr, klen, FALSE);
1645
1646         /* If not cached, generate it via utf8::SWASHGET */
1647         if (!svp || !SvPOK(*svp) || !(tmps = (U8*)SvPV(*svp, slen))) {
1648             dSP;
1649             /* We use utf8n_to_uvuni() as we want an index into
1650                Unicode tables, not a native character number.
1651              */
1652             UV code_point = utf8n_to_uvuni(ptr, UTF8_MAXLEN, 0,
1653                                            ckWARN(WARN_UTF8) ?
1654                                            0 : UTF8_ALLOW_ANY);
1655             SV *errsv_save;
1656             ENTER;
1657             SAVETMPS;
1658             save_re_context();
1659             PUSHSTACKi(PERLSI_MAGIC);
1660             PUSHMARK(SP);
1661             EXTEND(SP,3);
1662             PUSHs((SV*)sv);
1663             /* On EBCDIC & ~(0xA0-1) isn't a useful thing to do */
1664             PUSHs(sv_2mortal(newSViv((klen) ?
1665                                      (code_point & ~(needents - 1)) : 0)));
1666             PUSHs(sv_2mortal(newSViv(needents)));
1667             PUTBACK;
1668             errsv_save = newSVsv(ERRSV);
1669             if (call_method("SWASHGET", G_SCALAR))
1670                 retval = newSVsv(*PL_stack_sp--);
1671             else
1672                 retval = &PL_sv_undef;
1673             if (!SvTRUE(ERRSV))
1674                 sv_setsv(ERRSV, errsv_save);
1675             SvREFCNT_dec(errsv_save);
1676             POPSTACK;
1677             FREETMPS;
1678             LEAVE;
1679             if (PL_curcop == &PL_compiling)
1680                 PL_curcop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
1681
1682             svp = hv_store(hv, (char*)ptr, klen, retval, 0);
1683
1684             if (!svp || !(tmps = (U8*)SvPV(*svp, slen)) || (slen << 3) < needents)
1685                 Perl_croak(aTHX_ "SWASHGET didn't return result of proper length");
1686         }
1687
1688         PL_last_swash_hv = hv;
1689         PL_last_swash_klen = klen;
1690         PL_last_swash_tmps = tmps;
1691         PL_last_swash_slen = slen;
1692         if (klen)
1693             Copy(ptr, PL_last_swash_key, klen, U8);
1694     }
1695
1696     switch ((int)((slen << 3) / needents)) {
1697     case 1:
1698         bit = 1 << (off & 7);
1699         off >>= 3;
1700         return (tmps[off] & bit) != 0;
1701     case 8:
1702         return tmps[off];
1703     case 16:
1704         off <<= 1;
1705         return (tmps[off] << 8) + tmps[off + 1] ;
1706     case 32:
1707         off <<= 2;
1708         return (tmps[off] << 24) + (tmps[off+1] << 16) + (tmps[off+2] << 8) + tmps[off + 3] ;
1709     }
1710     Perl_croak(aTHX_ "panic: swash_fetch");
1711     return 0;
1712 }
1713
1714
1715 /*
1716 =for apidoc A|U8 *|uvchr_to_utf8|U8 *d|UV uv
1717
1718 Adds the UTF8 representation of the Native codepoint C<uv> to the end
1719 of the string C<d>; C<d> should be have at least C<UTF8_MAXLEN+1> free
1720 bytes available. The return value is the pointer to the byte after the
1721 end of the new character. In other words,
1722
1723     d = uvchr_to_utf8(d, uv);
1724
1725 is the recommended wide native character-aware way of saying
1726
1727     *(d++) = uv;
1728
1729 =cut
1730 */
1731
1732 /* On ASCII machines this is normally a macro but we want a
1733    real function in case XS code wants it
1734 */
1735 #undef Perl_uvchr_to_utf8
1736 U8 *
1737 Perl_uvchr_to_utf8(pTHX_ U8 *d, UV uv)
1738 {
1739     return Perl_uvuni_to_utf8_flags(aTHX_ d, NATIVE_TO_UNI(uv), 0);
1740 }
1741
1742 U8 *
1743 Perl_uvchr_to_utf8_flags(pTHX_ U8 *d, UV uv, UV flags)
1744 {
1745     return Perl_uvuni_to_utf8_flags(aTHX_ d, NATIVE_TO_UNI(uv), flags);
1746 }
1747
1748 /*
1749 =for apidoc A|UV|utf8n_to_uvchr|U8 *s|STRLEN curlen|STRLEN *retlen|U32 flags
1750
1751 Returns the native character value of the first character in the string C<s>
1752 which is assumed to be in UTF8 encoding; C<retlen> will be set to the
1753 length, in bytes, of that character.
1754
1755 Allows length and flags to be passed to low level routine.
1756
1757 =cut
1758 */
1759 /* On ASCII machines this is normally a macro but we want
1760    a real function in case XS code wants it
1761 */
1762 #undef Perl_utf8n_to_uvchr
1763 UV
1764 Perl_utf8n_to_uvchr(pTHX_ U8 *s, STRLEN curlen, STRLEN *retlen, U32 flags)
1765 {
1766     UV uv = Perl_utf8n_to_uvuni(aTHX_ s, curlen, retlen, flags);
1767     return UNI_TO_NATIVE(uv);
1768 }
1769
1770 /*
1771 =for apidoc A|char *|pv_uni_display|SV *dsv|U8 *spv|STRLEN len|STRLEN pvlim|UV flags
1772
1773 Build to the scalar dsv a displayable version of the string spv,
1774 length len, the displayable version being at most pvlim bytes long
1775 (if longer, the rest is truncated and "..." will be appended).
1776
1777 The flags argument can have UNI_DISPLAY_ISPRINT set to display
1778 isPRINT()able characters as themselves, UNI_DISPLAY_BACKSLASH
1779 to display the \\[nrfta\\] as the backslashed versions (like '\n')
1780 (UNI_DISPLAY_BACKSLASH is preferred over UNI_DISPLAY_ISPRINT for \\).
1781 UNI_DISPLAY_QQ (and its alias UNI_DISPLAY_REGEX) have both
1782 UNI_DISPLAY_BACKSLASH and UNI_DISPLAY_ISPRINT turned on.
1783
1784 The pointer to the PV of the dsv is returned.
1785
1786 =cut */
1787 char *
1788 Perl_pv_uni_display(pTHX_ SV *dsv, U8 *spv, STRLEN len, STRLEN pvlim, UV flags)
1789 {
1790     int truncated = 0;
1791     char *s, *e;
1792
1793     sv_setpvn(dsv, "", 0);
1794     for (s = (char *)spv, e = s + len; s < e; s += UTF8SKIP(s)) {
1795          UV u;
1796          bool ok = FALSE;
1797
1798          if (pvlim && SvCUR(dsv) >= pvlim) {
1799               truncated++;
1800               break;
1801          }
1802          u = utf8_to_uvchr((U8*)s, 0);
1803          if (u < 256) {
1804              if (!ok && (flags & UNI_DISPLAY_BACKSLASH)) {
1805                  switch (u & 0xFF) {
1806                  case '\n':
1807                      Perl_sv_catpvf(aTHX_ dsv, "\\n"); ok = TRUE; break;
1808                  case '\r':
1809                      Perl_sv_catpvf(aTHX_ dsv, "\\r"); ok = TRUE; break;
1810                  case '\t':
1811                      Perl_sv_catpvf(aTHX_ dsv, "\\t"); ok = TRUE; break;
1812                  case '\f':
1813                      Perl_sv_catpvf(aTHX_ dsv, "\\f"); ok = TRUE; break;
1814                  case '\a':
1815                      Perl_sv_catpvf(aTHX_ dsv, "\\a"); ok = TRUE; break;
1816                  case '\\':
1817                      Perl_sv_catpvf(aTHX_ dsv, "\\\\" ); ok = TRUE; break;
1818                  default: break;
1819                  }
1820              }
1821              /* isPRINT() is the locale-blind version. */
1822              if (!ok && (flags & UNI_DISPLAY_ISPRINT) && isPRINT(u & 0xFF)) {
1823                  Perl_sv_catpvf(aTHX_ dsv, "%c", (char)(u & 0xFF));
1824                  ok = TRUE;
1825              }
1826          }
1827          if (!ok)
1828              Perl_sv_catpvf(aTHX_ dsv, "\\x{%"UVxf"}", u);
1829     }
1830     if (truncated)
1831          sv_catpvn(dsv, "...", 3);
1832     
1833     return SvPVX(dsv);
1834 }
1835
1836 /*
1837 =for apidoc A|char *|sv_uni_display|SV *dsv|SV *ssv|STRLEN pvlim|UV flags
1838
1839 Build to the scalar dsv a displayable version of the scalar sv,
1840 the displayable version being at most pvlim bytes long
1841 (if longer, the rest is truncated and "..." will be appended).
1842
1843 The flags argument is as in pv_uni_display().
1844
1845 The pointer to the PV of the dsv is returned.
1846
1847 =cut */
1848 char *
1849 Perl_sv_uni_display(pTHX_ SV *dsv, SV *ssv, STRLEN pvlim, UV flags)
1850 {
1851      return Perl_pv_uni_display(aTHX_ dsv, (U8*)SvPVX(ssv), SvCUR(ssv),
1852                                 pvlim, flags);
1853 }
1854
1855 /*
1856 =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
1857
1858 Return true if the strings s1 and s2 differ case-insensitively, false
1859 if not (if they are equal case-insensitively).  If u1 is true, the
1860 string s1 is assumed to be in UTF-8-encoded Unicode.  If u2 is true,
1861 the string s2 is assumed to be in UTF-8-encoded Unicode.  If u1 or u2
1862 are false, the respective string is assumed to be in native 8-bit
1863 encoding.
1864
1865 If the pe1 and pe2 are non-NULL, the scanning pointers will be copied
1866 in there (they will point at the beginning of the I<next> character).
1867 If the pointers behind pe1 or pe2 are non-NULL, they are the end
1868 pointers beyond which scanning will not continue under any
1869 circustances.  If the byte lengths l1 and l2 are non-zero, s1+l1 and
1870 s2+l2 will be used as goal end pointers that will also stop the scan,
1871 and which qualify towards defining a successful match: all the scans
1872 that define an explicit length must reach their goal pointers for
1873 a match to succeed).
1874
1875 For case-insensitiveness, the "casefolding" of Unicode is used
1876 instead of upper/lowercasing both the characters, see
1877 http://www.unicode.org/unicode/reports/tr21/ (Case Mappings).
1878
1879 =cut */
1880 I32
1881 Perl_ibcmp_utf8(pTHX_ const char *s1, char **pe1, register UV l1, bool u1, const char *s2, char **pe2, register UV l2, bool u2)
1882 {
1883      register U8 *p1  = (U8*)s1;
1884      register U8 *p2  = (U8*)s2;
1885      register U8 *e1 = 0, *f1 = 0, *q1 = 0;
1886      register U8 *e2 = 0, *f2 = 0, *q2 = 0;
1887      STRLEN n1 = 0, n2 = 0;
1888      U8 foldbuf1[UTF8_MAXLEN_FOLD+1];
1889      U8 foldbuf2[UTF8_MAXLEN_FOLD+1];
1890      U8 natbuf[1+1];
1891      STRLEN foldlen1, foldlen2;
1892      bool match;
1893      
1894      if (pe1)
1895           e1 = *(U8**)pe1;
1896      if (e1 == 0 || (l1 && l1 < (UV)(e1 - (U8*)s1)))
1897           f1 = (U8*)s1 + l1;
1898      if (pe2)
1899           e2 = *(U8**)pe2;
1900      if (e2 == 0 || (l2 && l2 < (UV)(e2 - (U8*)s2)))
1901           f2 = (U8*)s2 + l2;
1902
1903      if ((e1 == 0 && f1 == 0) || (e2 == 0 && f2 == 0) || (f1 == 0 && f2 == 0))
1904           return 1; /* mismatch; possible infinite loop or false positive */
1905
1906      if (!u1 || !u2)
1907           natbuf[1] = 0; /* Need to terminate the buffer. */
1908
1909      while ((e1 == 0 || p1 < e1) &&
1910             (f1 == 0 || p1 < f1) &&
1911             (e2 == 0 || p2 < e2) &&
1912             (f2 == 0 || p2 < f2)) {
1913           if (n1 == 0) {
1914                if (u1)
1915                     to_utf8_fold(p1, foldbuf1, &foldlen1);
1916                else {
1917                     natbuf[0] = *p1;
1918                     to_utf8_fold(natbuf, foldbuf1, &foldlen1);
1919                }
1920                q1 = foldbuf1;
1921                n1 = foldlen1;
1922           }
1923           if (n2 == 0) {
1924                if (u2)
1925                     to_utf8_fold(p2, foldbuf2, &foldlen2);
1926                else {
1927                     natbuf[0] = *p2;
1928                     to_utf8_fold(natbuf, foldbuf2, &foldlen2);
1929                }
1930                q2 = foldbuf2;
1931                n2 = foldlen2;
1932           }
1933           while (n1 && n2) {
1934                if ( UTF8SKIP(q1) != UTF8SKIP(q2) ||
1935                    (UTF8SKIP(q1) == 1 && *q1 != *q2) ||
1936                     memNE((char*)q1, (char*)q2, UTF8SKIP(q1)) )
1937                    return 1; /* mismatch */
1938                n1 -= UTF8SKIP(q1);
1939                q1 += UTF8SKIP(q1);
1940                n2 -= UTF8SKIP(q2);
1941                q2 += UTF8SKIP(q2);
1942           }
1943           if (n1 == 0)
1944                p1 += u1 ? UTF8SKIP(p1) : 1;
1945           if (n2 == 0)
1946                p2 += u2 ? UTF8SKIP(p2) : 1;
1947
1948      }
1949
1950      /* A match is defined by all the scans that specified
1951       * an explicit length reaching their final goals. */
1952      match = (f1 == 0 || p1 == f1) && (f2 == 0 || p2 == f2);
1953
1954      if (match) {
1955           if (pe1)
1956                *pe1 = (char*)p1;
1957           if (pe2)
1958                *pe2 = (char*)p2;
1959      }
1960
1961      return match ? 0 : 1; /* 0 match, 1 mismatch */
1962 }
1963