dist/Devel-PPPort/parts/inc/utf8

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