vutil.c

   1 /* This file is part of the "version" CPAN distribution.  Please avoid
   2    editing it in the perl core. */
   3
   4 #ifdef PERL_CORE
   5 #  include "vutil.h"
   6 #endif
   7
   8 #define VERSION_MAX 0x7FFFFFFF
   9
  10 #ifndef STRLENs
  11 #  define STRLENs(s)  (sizeof("" s "") - 1)
  12 #endif
  13 #ifndef POSIX_SETLOCALE_LOCK
  14 #  ifdef gwLOCALE_LOCK
  15 #    define POSIX_SETLOCALE_LOCK    gwLOCALE_LOCK
  16 #    define POSIX_SETLOCALE_UNLOCK  gwLOCALE_UNLOCK
  17 #  else
  18 #    define POSIX_SETLOCALE_LOCK    NOOP
  19 #    define POSIX_SETLOCALE_UNLOCK  NOOP
  20 #  endif
  21 #endif
  22 #ifndef DISABLE_LC_NUMERIC_CHANGES
  23 #  ifdef LOCK_LC_NUMERIC_STANDARD
  24 #    define DISABLE_LC_NUMERIC_CHANGES()   LOCK_LC_NUMERIC_STANDARD()
  25 #    define REENABLE_LC_NUMERIC_CHANGES()  UNLOCK_LC_NUMERIC_STANDARD()
  26 #  else
  27 #    define DISABLE_LC_NUMERIC_CHANGES()   NOOP
  28 #    define REENABLE_LC_NUMERIC_CHANGES()  NOOP
  29 #  endif
  30 #endif
  31
  32 /*
  33 =for apidoc prescan_version
  34
  35 Validate that a given string can be parsed as a version object, but doesn't
  36 actually perform the parsing.  Can use either strict or lax validation rules.
  37 Can optionally set a number of hint variables to save the parsing code
  38 some time when tokenizing.
  39
  40 =cut
  41 */
  42 const char *
  43 #ifdef VUTIL_REPLACE_CORE
  44 Perl_prescan_version2(pTHX_ const char *s, bool strict,
  45 #else
  46 Perl_prescan_version(pTHX_ const char *s, bool strict,
  47 #endif
  48                      const char **errstr,
  49                      bool *sqv, int *ssaw_decimal, int *swidth, bool *salpha) {
  50     bool qv = (sqv ? *sqv : FALSE);
  51     int width = 3;
  52     int saw_decimal = 0;
  53     bool alpha = FALSE;
  54     const char *d = s;
  55
  56     PERL_ARGS_ASSERT_PRESCAN_VERSION;
  57     PERL_UNUSED_CONTEXT;
  58
  59     if (qv && isDIGIT(*d))
  60         goto dotted_decimal_version;
  61
  62     if (*d == 'v') { /* explicit v-string */
  63         d++;
  64         if (isDIGIT(*d)) {
  65             qv = TRUE;
  66         }
  67         else { /* degenerate v-string */
  68             /* requires v1.2.3 */
  69             BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
  70         }
  71
  72 dotted_decimal_version:
  73         if (strict && d[0] == '0' && isDIGIT(d[1])) {
  74             /* no leading zeros allowed */
  75             BADVERSION(s,errstr,"Invalid version format (no leading zeros)");
  76         }
  77
  78         while (isDIGIT(*d))     /* integer part */
  79             d++;
  80
  81         if (*d == '.')
  82         {
  83             saw_decimal++;
  84             d++;                /* decimal point */
  85         }
  86         else
  87         {
  88             if (strict) {
  89                 /* require v1.2.3 */
  90                 BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
  91             }
  92             else {
  93                 goto version_prescan_finish;
  94             }
  95         }
  96
  97         {
  98             int i = 0;
  99             int j = 0;
 100             while (isDIGIT(*d)) {       /* just keep reading */
 101                 i++;
 102                 while (isDIGIT(*d)) {
 103                     d++; j++;
 104                     /* maximum 3 digits between decimal */
 105                     if (strict && j > 3) {
 106                         BADVERSION(s,errstr,"Invalid version format (maximum 3 digits between decimals)");
 107                     }
 108                 }
 109                 if (*d == '_') {
 110                     if (strict) {
 111                         BADVERSION(s,errstr,"Invalid version format (no underscores)");
 112                     }
 113                     if ( alpha ) {
 114                         BADVERSION(s,errstr,"Invalid version format (multiple underscores)");
 115                     }
 116                     d++;
 117                     alpha = TRUE;
 118                 }
 119                 else if (*d == '.') {
 120                     if (alpha) {
 121                         BADVERSION(s,errstr,"Invalid version format (underscores before decimal)");
 122                     }
 123                     saw_decimal++;
 124                     d++;
 125                 }
 126                 else if (!isDIGIT(*d)) {
 127                     break;
 128                 }
 129                 j = 0;
 130             }
 131
 132             if (strict && i < 2) {
 133                 /* requires v1.2.3 */
 134                 BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
 135             }
 136         }
 137     }                                   /* end if dotted-decimal */
 138     else
 139     {                                   /* decimal versions */
 140         int j = 0;                      /* may need this later */
 141         /* special strict case for leading '.' or '0' */
 142         if (strict) {
 143             if (*d == '.') {
 144                 BADVERSION(s,errstr,"Invalid version format (0 before decimal required)");
 145             }
 146             if (*d == '0' && isDIGIT(d[1])) {
 147                 BADVERSION(s,errstr,"Invalid version format (no leading zeros)");
 148             }
 149         }
 150
 151         /* and we never support negative versions */
 152         if ( *d == '-') {
 153             BADVERSION(s,errstr,"Invalid version format (negative version number)");
 154         }
 155
 156         /* consume all of the integer part */
 157         while (isDIGIT(*d))
 158             d++;
 159
 160         /* look for a fractional part */
 161         if (*d == '.') {
 162             /* we found it, so consume it */
 163             saw_decimal++;
 164             d++;
 165         }
 166         else if (!*d || *d == ';' || isSPACE(*d) || *d == '{' || *d == '}') {
 167             if ( d == s ) {
 168                 /* found nothing */
 169                 BADVERSION(s,errstr,"Invalid version format (version required)");
 170             }
 171             /* found just an integer */
 172             goto version_prescan_finish;
 173         }
 174         else if ( d == s ) {
 175             /* didn't find either integer or period */
 176             BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
 177         }
 178         else if (*d == '_') {
 179             /* underscore can't come after integer part */
 180             if (strict) {
 181                 BADVERSION(s,errstr,"Invalid version format (no underscores)");
 182             }
 183             else if (isDIGIT(d[1])) {
 184                 BADVERSION(s,errstr,"Invalid version format (alpha without decimal)");
 185             }
 186             else {
 187                 BADVERSION(s,errstr,"Invalid version format (misplaced underscore)");
 188             }
 189         }
 190         else {
 191             /* anything else after integer part is just invalid data */
 192             BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
 193         }
 194
 195         /* scan the fractional part after the decimal point*/
 196
 197         if (!isDIGIT(*d) && (strict || ! (!*d || *d == ';' || isSPACE(*d) || *d == '{' || *d == '}') )) {
 198                 /* strict or lax-but-not-the-end */
 199                 BADVERSION(s,errstr,"Invalid version format (fractional part required)");
 200         }
 201
 202         while (isDIGIT(*d)) {
 203             d++; j++;
 204             if (*d == '.' && isDIGIT(d[-1])) {
 205                 if (alpha) {
 206                     BADVERSION(s,errstr,"Invalid version format (underscores before decimal)");
 207                 }
 208                 if (strict) {
 209                     BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions must begin with 'v')");
 210                 }
 211                 d = (char *)s;          /* start all over again */
 212                 qv = TRUE;
 213                 goto dotted_decimal_version;
 214             }
 215             if (*d == '_') {
 216                 if (strict) {
 217                     BADVERSION(s,errstr,"Invalid version format (no underscores)");
 218                 }
 219                 if ( alpha ) {
 220                     BADVERSION(s,errstr,"Invalid version format (multiple underscores)");
 221                 }
 222                 if ( ! isDIGIT(d[1]) ) {
 223                     BADVERSION(s,errstr,"Invalid version format (misplaced underscore)");
 224                 }
 225                 width = j;
 226                 d++;
 227                 alpha = TRUE;
 228             }
 229         }
 230     }
 231
 232 version_prescan_finish:
 233     while (isSPACE(*d))
 234         d++;
 235
 236     if (!isDIGIT(*d) && (! (!*d || *d == ';' || *d == ':' || *d == '{' || *d == '}') )) {
 237         /* trailing non-numeric data */
 238         BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
 239     }
 240     if (saw_decimal > 1 && d[-1] == '.') {
 241         /* no trailing period allowed */
 242         BADVERSION(s,errstr,"Invalid version format (trailing decimal)");
 243     }
 244
 245
 246     if (sqv)
 247         *sqv = qv;
 248     if (swidth)
 249         *swidth = width;
 250     if (ssaw_decimal)
 251         *ssaw_decimal = saw_decimal;
 252     if (salpha)
 253         *salpha = alpha;
 254     return d;
 255 }
 256
 257 /*
 258 =for apidoc scan_version
 259
 260 Returns a pointer to the next character after the parsed
 261 version string, as well as upgrading the passed in SV to
 262 an RV.
 263
 264 Function must be called with an already existing SV like
 265
 266     sv = newSV(0);
 267     s = scan_version(s, SV *sv, bool qv);
 268
 269 Performs some preprocessing to the string to ensure that
 270 it has the correct characteristics of a version.  Flags the
 271 object if it contains an underscore (which denotes this
 272 is an alpha version).  The boolean qv denotes that the version
 273 should be interpreted as if it had multiple decimals, even if
 274 it doesn't.
 275
 276 =cut
 277 */
 278
 279 const char *
 280 #ifdef VUTIL_REPLACE_CORE
 281 Perl_scan_version2(pTHX_ const char *s, SV *rv, bool qv)
 282 #else
 283 Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
 284 #endif
 285 {
 286     const char *start = s;
 287     const char *pos;
 288     const char *last;
 289     const char *errstr = NULL;
 290     int saw_decimal = 0;
 291     int width = 3;
 292     bool alpha = FALSE;
 293     bool vinf = FALSE;
 294     AV * av;
 295     SV * hv;
 296
 297     PERL_ARGS_ASSERT_SCAN_VERSION;
 298
 299     while (isSPACE(*s)) /* leading whitespace is OK */
 300         s++;
 301
 302     last = PRESCAN_VERSION(s, FALSE, &errstr, &qv, &saw_decimal, &width, &alpha);
 303     if (errstr) {
 304         /* "undef" is a special case and not an error */
 305         if ( ! ( *s == 'u' && strEQ(s+1,"ndef")) ) {
 306             Perl_croak(aTHX_ "%s", errstr);
 307         }
 308     }
 309
 310     start = s;
 311     if (*s == 'v')
 312         s++;
 313     pos = s;
 314
 315     /* Now that we are through the prescan, start creating the object */
 316     av = newAV();
 317     hv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */
 318     (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
 319
 320 #ifndef NODEFAULT_SHAREKEYS
 321     HvSHAREKEYS_on(hv);         /* key-sharing on by default */
 322 #endif
 323
 324     if ( qv )
 325         (void)hv_stores(MUTABLE_HV(hv), "qv", newSViv(qv));
 326     if ( alpha )
 327         (void)hv_stores(MUTABLE_HV(hv), "alpha", newSViv(alpha));
 328     if ( !qv && width < 3 )
 329         (void)hv_stores(MUTABLE_HV(hv), "width", newSViv(width));
 330
 331     while (isDIGIT(*pos) || *pos == '_')
 332         pos++;
 333     if (!isALPHA(*pos)) {
 334         I32 rev;
 335
 336         for (;;) {
 337             rev = 0;
 338             {
 339                 /* this is atoi() that delimits on underscores */
 340                 const char *end = pos;
 341                 I32 mult = 1;
 342                 I32 orev;
 343
 344                 /* the following if() will only be true after the decimal
 345                  * point of a version originally created with a bare
 346                  * floating point number, i.e. not quoted in any way
 347                  */
 348                 if ( !qv && s > start && saw_decimal == 1 ) {
 349                     mult *= 100;
 350                     while ( s < end ) {
 351                         if (*s == '_')
 352                             continue;
 353                         orev = rev;
 354                         rev += (*s - '0') * mult;
 355                         mult /= 10;
 356                         if (   (PERL_ABS(orev) > PERL_ABS(rev))
 357                             || (PERL_ABS(rev) > VERSION_MAX )) {
 358                             Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
 359                                            "Integer overflow in version %d",VERSION_MAX);
 360                             s = end - 1;
 361                             rev = VERSION_MAX;
 362                             vinf = 1;
 363                         }
 364                         s++;
 365                         if ( *s == '_' )
 366                             s++;
 367                     }
 368                 }
 369                 else {
 370                     while (--end >= s) {
 371                         int i;
 372                         if (*end == '_')
 373                             continue;
 374                         i = (*end - '0');
 375                         if (   (mult == VERSION_MAX)
 376                             || (i > VERSION_MAX / mult)
 377                             || (i * mult > VERSION_MAX - rev))
 378                         {
 379                             Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
 380                                            "Integer overflow in version");
 381                             end = s - 1;
 382                             rev = VERSION_MAX;
 383                             vinf = 1;
 384                         }
 385                         else
 386                             rev += i * mult;
 387
 388                         if (mult > VERSION_MAX / 10)
 389                             mult = VERSION_MAX;
 390                         else
 391                             mult *= 10;
 392                     }
 393                 }
 394             }
 395
 396             /* Append revision */
 397             av_push(av, newSViv(rev));
 398             if ( vinf ) {
 399                 s = last;
 400                 break;
 401             }
 402             else if ( *pos == '.' ) {
 403                 pos++;
 404                 if (qv) {
 405                     while (*pos == '0')
 406                         ++pos;
 407                 }
 408                 s = pos;
 409             }
 410             else if ( *pos == '_' && isDIGIT(pos[1]) )
 411                 s = ++pos;
 412             else if ( *pos == ',' && isDIGIT(pos[1]) )
 413                 s = ++pos;
 414             else if ( isDIGIT(*pos) )
 415                 s = pos;
 416             else {
 417                 s = pos;
 418                 break;
 419             }
 420             if ( qv ) {
 421                 while ( isDIGIT(*pos) || *pos == '_')
 422                     pos++;
 423             }
 424             else {
 425                 int digits = 0;
 426                 while ( ( isDIGIT(*pos) || *pos == '_' ) && digits < 3 ) {
 427                     if ( *pos != '_' )
 428                         digits++;
 429                     pos++;
 430                 }
 431             }
 432         }
 433     }
 434     if ( qv ) { /* quoted versions always get at least three terms*/
 435         SSize_t len = AvFILLp(av);
 436         /* This for loop appears to trigger a compiler bug on OS X, as it
 437            loops infinitely. Yes, len is negative. No, it makes no sense.
 438            Compiler in question is:
 439            gcc version 3.3 20030304 (Apple Computer, Inc. build 1640)
 440            for ( len = 2 - len; len > 0; len-- )
 441            av_push(MUTABLE_AV(sv), newSViv(0));
 442         */
 443         len = 2 - len;
 444         while (len-- > 0)
 445             av_push(av, newSViv(0));
 446     }
 447
 448     /* need to save off the current version string for later */
 449     if ( vinf ) {
 450         SV * orig = newSVpvn("v.Inf", sizeof("v.Inf")-1);
 451         (void)hv_stores(MUTABLE_HV(hv), "original", orig);
 452         (void)hv_stores(MUTABLE_HV(hv), "vinf", newSViv(1));
 453     }
 454     else if ( s > start ) {
 455         SV * orig = newSVpvn(start,s-start);
 456         if ( qv && saw_decimal == 1 && *start != 'v' ) {
 457             /* need to insert a v to be consistent */
 458             sv_insert(orig, 0, 0, "v", 1);
 459         }
 460         (void)hv_stores(MUTABLE_HV(hv), "original", orig);
 461     }
 462     else {
 463         (void)hv_stores(MUTABLE_HV(hv), "original", newSVpvs("0"));
 464         av_push(av, newSViv(0));
 465     }
 466
 467     /* And finally, store the AV in the hash */
 468     (void)hv_stores(MUTABLE_HV(hv), "version", newRV_noinc(MUTABLE_SV(av)));
 469
 470     /* fix RT#19517 - special case 'undef' as string */
 471     if ( *s == 'u' && strEQ(s+1,"ndef") ) {
 472         s += 5;
 473     }
 474
 475     return s;
 476 }
 477
 478 /*
 479 =for apidoc new_version
 480
 481 Returns a new version object based on the passed in SV:
 482
 483     SV *sv = new_version(SV *ver);
 484
 485 Does not alter the passed in ver SV.  See "upg_version" if you
 486 want to upgrade the SV.
 487
 488 =cut
 489 */
 490
 491 SV *
 492 #ifdef VUTIL_REPLACE_CORE
 493 Perl_new_version2(pTHX_ SV *ver)
 494 #else
 495 Perl_new_version(pTHX_ SV *ver)
 496 #endif
 497 {
 498     SV * const rv = newSV(0);
 499     PERL_ARGS_ASSERT_NEW_VERSION;
 500     if ( ISA_VERSION_OBJ(ver) ) /* can just copy directly */
 501     {
 502         SSize_t key;
 503         AV * const av = newAV();
 504         AV *sav;
 505         /* This will get reblessed later if a derived class*/
 506         SV * const hv = newSVrv(rv, "version");
 507         (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
 508 #ifndef NODEFAULT_SHAREKEYS
 509         HvSHAREKEYS_on(hv);         /* key-sharing on by default */
 510 #endif
 511
 512         if ( SvROK(ver) )
 513             ver = SvRV(ver);
 514
 515         /* Begin copying all of the elements */
 516         if ( hv_exists(MUTABLE_HV(ver), "qv", 2) )
 517             (void)hv_stores(MUTABLE_HV(hv), "qv", newSViv(1));
 518
 519         if ( hv_exists(MUTABLE_HV(ver), "alpha", 5) )
 520             (void)hv_stores(MUTABLE_HV(hv), "alpha", newSViv(1));
 521         {
 522             SV ** svp = hv_fetchs(MUTABLE_HV(ver), "width", FALSE);
 523             if(svp) {
 524                 const I32 width = SvIV(*svp);
 525                 (void)hv_stores(MUTABLE_HV(hv), "width", newSViv(width));
 526             }
 527         }
 528         {
 529             SV ** svp = hv_fetchs(MUTABLE_HV(ver), "original", FALSE);
 530             if(svp)
 531                 (void)hv_stores(MUTABLE_HV(hv), "original", newSVsv(*svp));
 532         }
 533         sav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(ver), "version", FALSE)));
 534         /* This will get reblessed later if a derived class*/
 535         for ( key = 0; key <= av_len(sav); key++ )
 536         {
 537             SV * const sv = *av_fetch(sav, key, FALSE);
 538             const I32 rev = SvIV(sv);
 539             av_push(av, newSViv(rev));
 540         }
 541
 542         (void)hv_stores(MUTABLE_HV(hv), "version", newRV_noinc(MUTABLE_SV(av)));
 543         return rv;
 544     }
 545 #ifdef SvVOK
 546     {
 547         const MAGIC* const mg = SvVSTRING_mg(ver);
 548         if ( mg ) { /* already a v-string */
 549             const STRLEN len = mg->mg_len;
 550             const char * const version = (const char*)mg->mg_ptr;
 551             char *raw, *under;
 552             static const char underscore[] = "_";
 553             sv_setpvn(rv,version,len);
 554             raw = SvPV_nolen(rv);
 555             under = ninstr(raw, raw+len, underscore, underscore + 1);
 556             if (under) {
 557                 Move(under + 1, under, raw + len - under - 1, char);
 558                 SvCUR_set(rv, SvCUR(rv) - 1);
 559                 *SvEND(rv) = '\0';
 560             }
 561             /* this is for consistency with the pure Perl class */
 562             if ( isDIGIT(*version) )
 563                 sv_insert(rv, 0, 0, "v", 1);
 564         }
 565         else {
 566 #endif
 567         SvSetSV_nosteal(rv, ver); /* make a duplicate */
 568 #ifdef SvVOK
 569         }
 570     }
 571 #endif
 572     sv_2mortal(rv); /* in case upg_version croaks before it returns */
 573     return SvREFCNT_inc_NN(UPG_VERSION(rv, FALSE));
 574 }
 575
 576 /*
 577 =for apidoc upg_version
 578
 579 In-place upgrade of the supplied SV to a version object.
 580
 581     SV *sv = upg_version(SV *sv, bool qv);
 582
 583 Returns a pointer to the upgraded SV.  Set the boolean qv if you want
 584 to force this SV to be interpreted as an "extended" version.
 585
 586 =cut
 587 */
 588
 589 /* Macro to do the meat of getting the PV of an NV version number.  This is
 590  * macroized because can be called from several places */
 591 #define GET_NUMERIC_VERSION(ver, sv, tbuf, buf, len)                        \
 592     STMT_START {                                                            \
 593                                                                             \
 594         /* Prevent callees from trying to change the locale */              \
 595         DISABLE_LC_NUMERIC_CHANGES();                                       \
 596                                                                             \
 597         /* We earlier created 'sv' for very large version numbers, to rely  \
 598          * on the specialized algorithms SV code has built-in for such      \
 599          * values */                                                        \
 600         if (sv) {                                                           \
 601             Perl_sv_setpvf(aTHX_ sv, "%.9" NVff, SvNVX(ver));               \
 602             len = SvCUR(sv);                                                \
 603             buf = SvPVX(sv);                                                \
 604         }                                                                   \
 605         else {                                                              \
 606             len = my_snprintf(tbuf, sizeof(tbuf), "%.9" NVff, SvNVX(ver));  \
 607             buf = tbuf;                                                     \
 608         }                                                                   \
 609                                                                             \
 610         REENABLE_LC_NUMERIC_CHANGES();                                      \
 611     } STMT_END
 612
 613 SV *
 614 #ifdef VUTIL_REPLACE_CORE
 615 Perl_upg_version2(pTHX_ SV *ver, bool qv)
 616 #else
 617 Perl_upg_version(pTHX_ SV *ver, bool qv)
 618 #endif
 619 {
 620     const char *version, *s;
 621 #ifdef SvVOK
 622     const MAGIC *mg;
 623 #endif
 624
 625 #if PERL_VERSION_LT(5,19,8) && defined(USE_ITHREADS)
 626     ENTER;
 627 #endif
 628     PERL_ARGS_ASSERT_UPG_VERSION;
 629
 630     if ( (SvUOK(ver) && SvUVX(ver) > VERSION_MAX)
 631         || (SvIOK(ver) && SvIVX(ver) > VERSION_MAX) )
 632     {
 633         /* out of bounds [unsigned] integer */
 634         STRLEN len;
 635         char tbuf[64];
 636         len = my_snprintf(tbuf, sizeof(tbuf), "%d", VERSION_MAX);
 637         version = savepvn(tbuf, len);
 638         SAVEFREEPV(version);
 639         Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
 640                        "Integer overflow in version %d",VERSION_MAX);
 641     }
 642     else if ( SvUOK(ver) || SvIOK(ver))
 643 #if PERL_VERSION_LT(5,17,2)
 644 VER_IV:
 645 #endif
 646     {
 647         version = savesvpv(ver);
 648         SAVEFREEPV(version);
 649     }
 650     else if (SvNOK(ver) && !( SvPOK(ver) && SvCUR(ver) == 3 ) )
 651 #if PERL_VERSION_LT(5,17,2)
 652 VER_NV:
 653 #endif
 654     {
 655         STRLEN len;
 656
 657         /* may get too much accuracy */
 658         char tbuf[64];
 659         SV *sv = SvNVX(ver) > 10e50 ? newSV(64) : 0;
 660         char *buf;
 661
 662 #if PERL_VERSION_GE(5,19,0)
 663         if (SvPOK(ver)) {
 664             /* dualvar? */
 665             goto VER_PV;
 666         }
 667 #endif
 668
 669         {
 670
 671 #ifdef USE_POSIX_2008_LOCALE
 672
 673             /* With POSIX 2008, all we have to do is toggle to the C locale
 674              * just long enough to get the value (which should have a dot). */
 675             const locale_t locale_obj_on_entry = uselocale(PL_C_locale_obj);
 676             GET_NUMERIC_VERSION(ver, sv, tbuf, buf, len);
 677             uselocale(locale_obj_on_entry);
 678 #else
 679             /* Without POSIX 2008, it could be that toggling will zap another
 680             * thread's locale.  Avoid that if possible by looking at the NV and
 681             * changing a non-dot radix into a dot */
 682
 683             char * radix = NULL;
 684             unsigned int radix_len = 0;
 685
 686             GET_NUMERIC_VERSION(ver, sv, tbuf, buf, len);
 687
 688 #  ifndef ARABIC_DECIMAL_SEPARATOR_UTF8
 689
 690             /* This becomes feasible since there are only very few possible
 691              * radix characters in the world.  khw knows of just 3 possible
 692              * ones.  If we are being compiled on a perl without the very rare
 693              * third one, ARABIC DECIMAL SEPARATOR,  just scan for the other
 694              * two: FULL STOP (dot) and COMMA */
 695             radix = strpbrk(buf, ".,");
 696             if (LIKELY(radix)) {
 697                 radix_len = 1;
 698             }
 699 #  else
 700             /* Here, we have information about the third one; since it is
 701              * multi-byte, it becomes a little more work.  Scan for the dot,
 702              * comma, or first byte of the arabic one */
 703             radix = strpbrk(buf,
 704                             ".,"
 705                             ARABIC_DECIMAL_SEPARATOR_UTF8_FIRST_BYTE_s);
 706
 707             if (LIKELY(radix)) {
 708                 if (LIKELY(   (* (U8 *) radix)
 709                            != ARABIC_DECIMAL_SEPARATOR_UTF8_FIRST_BYTE))
 710                 {
 711                     radix_len = 1;  /* Dot and comma are length 1 */
 712                 }
 713                 else {
 714
 715                     /* Make sure that the rest of the bytes are what we expect
 716                      * for the remainder of the arabic radix.  If not, we
 717                      * didn't find the radix. */
 718                     radix_len = STRLENs(ARABIC_DECIMAL_SEPARATOR_UTF8);
 719                     if (   radix + radix_len >= buf + len
 720                         || memNEs(radix + 1,
 721                                 STRLENs(ARABIC_DECIMAL_SEPARATOR_UTF8_TAIL),
 722                                 ARABIC_DECIMAL_SEPARATOR_UTF8_TAIL))
 723                     {
 724                         radix = NULL;
 725                         radix_len = 0;
 726                     }
 727                 }
 728             }
 729
 730 #  endif
 731
 732             /* Now convert any found radix into a dot (if not already).  This
 733             * effectively does:  ver =~ s/radix/dot/   */
 734             if (radix) {
 735                 if (*radix != '.') {
 736                     *radix = '.';
 737
 738                     if (radix_len > 1) {
 739                         Move(radix + radix_len,  /* from what follows the radix
 740                                                   */
 741                             radix + 1,          /* to just after the new dot */
 742
 743                                 /* the number of bytes remaining, plus the NUL
 744                                  * */
 745                             len - (radix - buf) - radix_len + 1,
 746                             char);
 747                         len -= radix_len - 1;
 748                     }
 749                 }
 750
 751                 /* Guard against the very unlikely case that the radix is more
 752                  * than a single character, like ".."; that is, make sure the
 753                  * radix string we found above is the whole radix, and not just
 754                  * the prefix of a longer one.   Success is indicated by it
 755                  * being at the end of the string, or the next byte should be a
 756                  * digit */
 757                 if (radix < buf + len && ! inRANGE(radix[1], '0', '9')) {
 758                     radix = NULL;
 759                     radix_len = 0;
 760                 }
 761             }
 762
 763             if (! radix) {
 764
 765                 /* If we couldn't find what the radix is, or didn't find it in
 766                  * the PV, resort to toggling the locale to one known to have a
 767                  * dot radix.  This may or may not be called from code that has
 768                  * switched locales without letting perl know, therefore we
 769                  * have to find it from first principals.  See [perl #121930].
 770                  * */
 771
 772 #  if ! defined(LC_NUMERIC) || ! defined(USE_LOCALE_NUMERIC)
 773
 774                 Perl_croak(aTHX_ "panic: Unexpectedly didn't find a dot radix"
 775                                  " character in '%s'", buf);
 776 #  else
 777                 const char * locale_name_on_entry = NULL;
 778
 779                 /* In windows, or not threaded, or not thread-safe, if it isn't
 780                  * C, set it to C. */
 781
 782                 POSIX_SETLOCALE_LOCK;    /* Start critical section */
 783
 784                 locale_name_on_entry = setlocale(LC_NUMERIC, NULL);
 785                 if (   strEQ(locale_name_on_entry, "C")
 786                     || strEQ(locale_name_on_entry, "C.UTF-8")
 787                     || strEQ(locale_name_on_entry, "POSIX"))
 788                 {
 789                     /* No need to change the locale, since these all are known
 790                      * to have a dot radix.  Change the variable to indicate to
 791                      * the restore code that nothing needs to be done */
 792                     locale_name_on_entry = NULL;
 793                 }
 794                 else {
 795                     /* The setlocale() call might free or overwrite the name */
 796                     locale_name_on_entry = savepv(locale_name_on_entry);
 797                     setlocale(LC_NUMERIC, "C");
 798                 }
 799
 800                 GET_NUMERIC_VERSION(ver, sv, tbuf, buf, len);
 801
 802                 if (locale_name_on_entry) {
 803                     setlocale(LC_NUMERIC, locale_name_on_entry);
 804                     Safefree(locale_name_on_entry);
 805                 }
 806
 807                 POSIX_SETLOCALE_UNLOCK;  /* End critical section */
 808 #  endif
 809             }
 810 #endif
 811         }
 812
 813         /* Strip trailing zero's from the version number */
 814         while (buf[len-1] == '0' && len > 0) len--;
 815
 816         if ( buf[len-1] == '.' ) len--; /* eat the trailing decimal */
 817
 818         version = savepvn(buf, len);
 819         SAVEFREEPV(version);
 820         SvREFCNT_dec(sv);
 821     }
 822 #ifdef SvVOK
 823     else if ( (mg = SvVSTRING_mg(ver)) ) { /* already a v-string */
 824         version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
 825         SAVEFREEPV(version);
 826         qv = TRUE;
 827     }
 828 #endif
 829     else if ( SvPOK(ver))/* must be a string or something like a string */
 830 VER_PV:
 831     {
 832         STRLEN len;
 833         version = savepvn(SvPV(ver,len), SvCUR(ver));
 834         SAVEFREEPV(version);
 835 #ifndef SvVOK
 836         /* This will only be executed for 5.6.0 - 5.8.0 inclusive */
 837         if ( len >= 3 && !instr(version,".") && !instr(version,"_")) {
 838             /* may be a v-string */
 839             char *testv = (char *)version;
 840             STRLEN tlen = len;
 841             for (tlen=0; tlen < len; tlen++, testv++) {
 842                 /* if one of the characters is non-text assume v-string */
 843                 if (testv[0] < ' ') {
 844                     SV * const nsv = sv_newmortal();
 845                     const char *nver;
 846                     const char *pos;
 847                     int saw_decimal = 0;
 848                     sv_setpvf(nsv,"v%vd",ver);
 849                     pos = nver = savepv(SvPV_nolen(nsv));
 850                     SAVEFREEPV(pos);
 851
 852                     /* scan the resulting formatted string */
 853                     pos++; /* skip the leading 'v' */
 854                     while ( *pos == '.' || isDIGIT(*pos) ) {
 855                         if ( *pos == '.' )
 856                             saw_decimal++ ;
 857                         pos++;
 858                     }
 859
 860                     /* is definitely a v-string */
 861                     if ( saw_decimal >= 2 ) {
 862                         version = nver;
 863                     }
 864                     break;
 865                 }
 866             }
 867         }
 868 #endif
 869     }
 870 #if PERL_VERSION_LT(5,17,2)
 871     else if (SvIOKp(ver)) {
 872         goto VER_IV;
 873     }
 874     else if (SvNOKp(ver)) {
 875         goto VER_NV;
 876     }
 877     else if (SvPOKp(ver)) {
 878         goto VER_PV;
 879     }
 880 #endif
 881     else
 882     {
 883         /* no idea what this is */
 884         Perl_croak(aTHX_ "Invalid version format (non-numeric data)");
 885     }
 886
 887     s = SCAN_VERSION(version, ver, qv);
 888     if ( *s != '\0' )
 889         Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
 890                        "Version string '%s' contains invalid data; "
 891                        "ignoring: '%s'", version, s);
 892
 893 #if PERL_VERSION_LT(5,19,8) && defined(USE_ITHREADS)
 894     LEAVE;
 895 #endif
 896
 897     return ver;
 898 }
 899
 900 /*
 901 =for apidoc vverify
 902
 903 Validates that the SV contains valid internal structure for a version object.
 904 It may be passed either the version object (RV) or the hash itself (HV).  If
 905 the structure is valid, it returns the HV.  If the structure is invalid,
 906 it returns NULL.
 907
 908     SV *hv = vverify(sv);
 909
 910 Note that it only confirms the bare minimum structure (so as not to get
 911 confused by derived classes which may contain additional hash entries):
 912
 913 =over 4
 914
 915 =item * The SV is an HV or a reference to an HV
 916
 917 =item * The hash contains a "version" key
 918
 919 =item * The "version" key has a reference to an AV as its value
 920
 921 =back
 922
 923 =cut
 924 */
 925
 926 SV *
 927 #ifdef VUTIL_REPLACE_CORE
 928 Perl_vverify2(pTHX_ SV *vs)
 929 #else
 930 Perl_vverify(pTHX_ SV *vs)
 931 #endif
 932 {
 933     SV *sv;
 934     SV **svp;
 935
 936     PERL_ARGS_ASSERT_VVERIFY;
 937
 938     if ( SvROK(vs) )
 939         vs = SvRV(vs);
 940
 941     /* see if the appropriate elements exist */
 942     if ( SvTYPE(vs) == SVt_PVHV
 943          && (svp = hv_fetchs(MUTABLE_HV(vs), "version", FALSE))
 944          && (sv = SvRV(*svp))
 945          && SvTYPE(sv) == SVt_PVAV )
 946         return vs;
 947     else
 948         return NULL;
 949 }
 950
 951 /*
 952 =for apidoc vnumify
 953
 954 Accepts a version object and returns the normalized floating
 955 point representation.  Call like:
 956
 957     sv = vnumify(rv);
 958
 959 NOTE: you can pass either the object directly or the SV
 960 contained within the RV.
 961
 962 The SV returned has a refcount of 1.
 963
 964 =cut
 965 */
 966
 967 SV *
 968 #ifdef VUTIL_REPLACE_CORE
 969 Perl_vnumify2(pTHX_ SV *vs)
 970 #else
 971 Perl_vnumify(pTHX_ SV *vs)
 972 #endif
 973 {
 974     SSize_t i, len;
 975     I32 digit;
 976     bool alpha = FALSE;
 977     SV *sv;
 978     AV *av;
 979
 980     PERL_ARGS_ASSERT_VNUMIFY;
 981
 982     /* extract the HV from the object */
 983     vs = VVERIFY(vs);
 984     if ( ! vs )
 985         Perl_croak(aTHX_ "Invalid version object");
 986
 987     /* see if various flags exist */
 988     if ( hv_exists(MUTABLE_HV(vs), "alpha", 5 ) )
 989         alpha = TRUE;
 990
 991     if (alpha) {
 992         Perl_ck_warner(aTHX_ packWARN(WARN_NUMERIC),
 993                        "alpha->numify() is lossy");
 994     }
 995
 996     /* attempt to retrieve the version array */
 997     if ( !(av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE))) ) ) {
 998         return newSVpvs("0");
 999     }
1000
1001     len = av_len(av);
1002     if ( len == -1 )
1003     {
1004         return newSVpvs("0");
1005     }
1006
1007     {
1008         SV * tsv = *av_fetch(av, 0, 0);
1009         digit = SvIV(tsv);
1010     }
1011     sv = Perl_newSVpvf(aTHX_ "%d.", (int)PERL_ABS(digit));
1012     for ( i = 1 ; i <= len ; i++ )
1013     {
1014         SV * tsv = *av_fetch(av, i, 0);
1015         digit = SvIV(tsv);
1016         sv_catpvf(sv, "%03d", (int)digit);
1017     }
1018
1019     if ( len == 0 ) {
1020         sv_catpvs(sv, "000");
1021     }
1022     return sv;
1023 }
1024
1025 /*
1026 =for apidoc vnormal
1027
1028 Accepts a version object and returns the normalized string
1029 representation.  Call like:
1030
1031     sv = vnormal(rv);
1032
1033 NOTE: you can pass either the object directly or the SV
1034 contained within the RV.
1035
1036 The SV returned has a refcount of 1.
1037
1038 =cut
1039 */
1040
1041 SV *
1042 #ifdef VUTIL_REPLACE_CORE
1043 Perl_vnormal2(pTHX_ SV *vs)
1044 #else
1045 Perl_vnormal(pTHX_ SV *vs)
1046 #endif
1047 {
1048     I32 i, len, digit;
1049     SV *sv;
1050     AV *av;
1051
1052     PERL_ARGS_ASSERT_VNORMAL;
1053
1054     /* extract the HV from the object */
1055     vs = VVERIFY(vs);
1056     if ( ! vs )
1057         Perl_croak(aTHX_ "Invalid version object");
1058
1059     av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE)));
1060
1061     len = av_len(av);
1062     if ( len == -1 )
1063     {
1064         return newSVpvs("");
1065     }
1066     {
1067         SV * tsv = *av_fetch(av, 0, 0);
1068         digit = SvIV(tsv);
1069     }
1070     sv = Perl_newSVpvf(aTHX_ "v%" IVdf, (IV)digit);
1071     for ( i = 1 ; i <= len ; i++ ) {
1072         SV * tsv = *av_fetch(av, i, 0);
1073         digit = SvIV(tsv);
1074         sv_catpvf(sv, ".%" IVdf, (IV)digit);
1075     }
1076
1077     if ( len <= 2 ) { /* short version, must be at least three */
1078         for ( len = 2 - len; len != 0; len-- )
1079             sv_catpvs(sv,".0");
1080     }
1081     return sv;
1082 }
1083
1084 /*
1085 =for apidoc vstringify
1086
1087 In order to maintain maximum compatibility with earlier versions
1088 of Perl, this function will return either the floating point
1089 notation or the multiple dotted notation, depending on whether
1090 the original version contained 1 or more dots, respectively.
1091
1092 The SV returned has a refcount of 1.
1093
1094 =cut
1095 */
1096
1097 SV *
1098 #ifdef VUTIL_REPLACE_CORE
1099 Perl_vstringify2(pTHX_ SV *vs)
1100 #else
1101 Perl_vstringify(pTHX_ SV *vs)
1102 #endif
1103 {
1104     SV ** svp;
1105     PERL_ARGS_ASSERT_VSTRINGIFY;
1106
1107     /* extract the HV from the object */
1108     vs = VVERIFY(vs);
1109     if ( ! vs )
1110         Perl_croak(aTHX_ "Invalid version object");
1111
1112     svp = hv_fetchs(MUTABLE_HV(vs), "original", FALSE);
1113     if (svp) {
1114         SV *pv;
1115         pv = *svp;
1116         if ( SvPOK(pv)
1117 #if PERL_VERSION_LT(5,17,2)
1118             || SvPOKp(pv)
1119 #endif
1120         )
1121             return newSVsv(pv);
1122         else
1123             return &PL_sv_undef;
1124     }
1125     else {
1126         if ( hv_exists(MUTABLE_HV(vs), "qv", 2) )
1127             return VNORMAL(vs);
1128         else
1129             return VNUMIFY(vs);
1130     }
1131 }
1132
1133 /*
1134 =for apidoc vcmp
1135
1136 Version object aware cmp.  Both operands must already have been
1137 converted into version objects.
1138
1139 =cut
1140 */
1141
1142 int
1143 #ifdef VUTIL_REPLACE_CORE
1144 Perl_vcmp2(pTHX_ SV *lhv, SV *rhv)
1145 #else
1146 Perl_vcmp(pTHX_ SV *lhv, SV *rhv)
1147 #endif
1148 {
1149     SSize_t i,l,m,r;
1150     I32 retval;
1151     I32 left = 0;
1152     I32 right = 0;
1153     AV *lav, *rav;
1154
1155     PERL_ARGS_ASSERT_VCMP;
1156
1157     /* extract the HVs from the objects */
1158     lhv = VVERIFY(lhv);
1159     rhv = VVERIFY(rhv);
1160     if ( ! ( lhv && rhv ) )
1161         Perl_croak(aTHX_ "Invalid version object");
1162
1163     /* get the left hand term */
1164     lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(lhv), "version", FALSE)));
1165
1166     /* and the right hand term */
1167     rav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(rhv), "version", FALSE)));
1168
1169     l = av_len(lav);
1170     r = av_len(rav);
1171     m = l < r ? l : r;
1172     retval = 0;
1173     i = 0;
1174     while ( i <= m && retval == 0 )
1175     {
1176         SV * const lsv = *av_fetch(lav,i,0);
1177         SV * rsv;
1178         left = SvIV(lsv);
1179         rsv = *av_fetch(rav,i,0);
1180         right = SvIV(rsv);
1181         if ( left < right  )
1182             retval = -1;
1183         if ( left > right )
1184             retval = +1;
1185         i++;
1186     }
1187
1188     if ( l != r && retval == 0 ) /* possible match except for trailing 0's */
1189     {
1190         if ( l < r )
1191         {
1192             while ( i <= r && retval == 0 )
1193             {
1194                 SV * const rsv = *av_fetch(rav,i,0);
1195                 if ( SvIV(rsv) != 0 )
1196                     retval = -1; /* not a match after all */
1197                 i++;
1198             }
1199         }
1200         else
1201         {
1202             while ( i <= l && retval == 0 )
1203             {
1204                 SV * const lsv = *av_fetch(lav,i,0);
1205                 if ( SvIV(lsv) != 0 )
1206                     retval = +1; /* not a match after all */
1207                 i++;
1208             }
1209         }
1210     }
1211     return retval;
1212 }
1213
1214 /* ex: set ro: */