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