dist/Devel-PPPort/parts/inc/uv

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