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