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