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
 577 #ifdef dVAR
 578     dVAR;
 579 #endif
 580
 581     const char *version, *s;
 582 #ifdef SvVOK
 583     const MAGIC *mg;
 584 #endif
 585
 586 #if PERL_VERSION_LT(5,19,8) && defined(USE_ITHREADS)
 587     ENTER;
 588 #endif
 589     PERL_ARGS_ASSERT_UPG_VERSION;
 590
 591     if ( (SvUOK(ver) && SvUVX(ver) > VERSION_MAX)
 592            || (SvIOK(ver) && SvIVX(ver) > VERSION_MAX) ) {
 593         /* out of bounds [unsigned] integer */
 594         STRLEN len;
 595         char tbuf[64];
 596         len = my_snprintf(tbuf, sizeof(tbuf), "%d", VERSION_MAX);
 597         version = savepvn(tbuf, len);
 598         SAVEFREEPV(version);
 599         Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
 600                        "Integer overflow in version %d",VERSION_MAX);
 601     }
 602     else if ( SvUOK(ver) || SvIOK(ver))
 603 #if PERL_VERSION_LT(5,17,2)
 604 VER_IV:
 605 #endif
 606     {
 607         version = savesvpv(ver);
 608         SAVEFREEPV(version);
 609     }
 610     else if (SvNOK(ver) && !( SvPOK(ver) && SvCUR(ver) == 3 ) )
 611 #if PERL_VERSION_LT(5,17,2)
 612 VER_NV:
 613 #endif
 614     {
 615         STRLEN len;
 616
 617         /* may get too much accuracy */
 618         char tbuf[64];
 619         SV *sv = SvNVX(ver) > 10e50 ? newSV(64) : 0;
 620         char *buf;
 621
 622 #if PERL_VERSION_GE(5,19,0)
 623         if (SvPOK(ver)) {
 624             /* dualvar? */
 625             goto VER_PV;
 626         }
 627 #endif
 628 #ifdef USE_LOCALE_NUMERIC
 629
 630         {
 631             /* This may or may not be called from code that has switched
 632              * locales without letting perl know, therefore we have to find it
 633              * from first principals.  See [perl #121930]. */
 634
 635             /* In windows, or not threaded, or not thread-safe, if it isn't C,
 636              * set it to C. */
 637
 638 #  ifndef USE_POSIX_2008_LOCALE
 639
 640             const char * locale_name_on_entry;
 641
 642             LC_NUMERIC_LOCK(0);    /* Start critical section */
 643
 644             locale_name_on_entry = setlocale(LC_NUMERIC, NULL);
 645             if (   strNE(locale_name_on_entry, "C")
 646                 && strNE(locale_name_on_entry, "POSIX"))
 647             {
 648                 /* the setlocale() call might free or overwrite the name */
 649                 locale_name_on_entry = savepv(locale_name_on_entry);
 650                 setlocale(LC_NUMERIC, "C");
 651             }
 652             else {  /* This value indicates to the restore code that we didn't
 653                        change the locale */
 654                 locale_name_on_entry = NULL;
 655             }
 656
 657 # else
 658
 659             const locale_t locale_obj_on_entry = uselocale((locale_t) 0);
 660             const char * locale_name_on_entry = NULL;
 661             DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
 662
 663             if (locale_obj_on_entry == LC_GLOBAL_LOCALE) {
 664
 665                 /* in the global locale, we can call system setlocale and if it
 666                  * isn't C, set it to C. */
 667                 LC_NUMERIC_LOCK(0);
 668
 669                 locale_name_on_entry = setlocale(LC_NUMERIC, NULL);
 670                 if (   strNE(locale_name_on_entry, "C")
 671                     && strNE(locale_name_on_entry, "POSIX"))
 672                 {
 673                     /* the setlocale() call might free or overwrite the name */
 674                     locale_name_on_entry = savepv(locale_name_on_entry);
 675                     setlocale(LC_NUMERIC, "C");
 676                 }
 677                 else {  /* This value indicates to the restore code that we
 678                            didn't change the locale */
 679                     locale_name_on_entry = NULL;
 680             }
 681         }
 682             else if (locale_obj_on_entry == PL_underlying_numeric_obj) {
 683                 /* Here, the locale appears to have been changed to use the
 684                  * program's underlying locale.  Just use our mechanisms to
 685                  * switch back to C.   It might be possible for this pointer to
 686                  * actually refer to something else if it got released and
 687                  * reused somehow.  But it doesn't matter, our mechanisms will
 688                  * work even so */
 689                 STORE_LC_NUMERIC_SET_STANDARD();
 690             }
 691             else if (locale_obj_on_entry != PL_C_locale_obj) {
 692                 /* The C object should be unchanged during a program's
 693                  * execution, so it should be safe to assume it means what it
 694                  * says, so if we are in it, no locale change is required.
 695                  * Otherwise, simply use the thread-safe operation. */
 696                 uselocale(PL_C_locale_obj);
 697             }
 698
 699 # endif
 700
 701             /* Prevent recursed calls from trying to change back */
 702             LOCK_LC_NUMERIC_STANDARD();
 703
 704 #endif
 705
 706         if (sv) {
 707                 Perl_sv_catpvf(aTHX_ sv, "%.9" NVff, SvNVX(ver));
 708             len = SvCUR(sv);
 709             buf = SvPVX(sv);
 710         }
 711         else {
 712                 len = my_snprintf(tbuf, sizeof(tbuf), "%.9" NVff, SvNVX(ver));
 713             buf = tbuf;
 714         }
 715
 716 #ifdef USE_LOCALE_NUMERIC
 717
 718             UNLOCK_LC_NUMERIC_STANDARD();
 719
 720 #  ifndef USE_POSIX_2008_LOCALE
 721
 722             if (locale_name_on_entry) {
 723                 setlocale(LC_NUMERIC, locale_name_on_entry);
 724                 Safefree(locale_name_on_entry);
 725             }
 726
 727             LC_NUMERIC_UNLOCK;  /* End critical section */
 728
 729 #  else
 730
 731             if (locale_name_on_entry) {
 732                 setlocale(LC_NUMERIC, locale_name_on_entry);
 733                 Safefree(locale_name_on_entry);
 734                 LC_NUMERIC_UNLOCK;
 735             }
 736             else if (locale_obj_on_entry == PL_underlying_numeric_obj) {
 737                 RESTORE_LC_NUMERIC();
 738             }
 739             else if (locale_obj_on_entry != PL_C_locale_obj) {
 740                 uselocale(locale_obj_on_entry);
 741         }
 742
 743 #  endif
 744
 745         }
 746
 747 #endif  /* USE_LOCALE_NUMERIC */
 748
 749         while (buf[len-1] == '0' && len > 0) len--;
 750         if ( buf[len-1] == '.' ) len--; /* eat the trailing decimal */
 751         version = savepvn(buf, len);
 752         SAVEFREEPV(version);
 753         SvREFCNT_dec(sv);
 754     }
 755 #ifdef SvVOK
 756     else if ( (mg = SvVSTRING_mg(ver)) ) { /* already a v-string */
 757         version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
 758         SAVEFREEPV(version);
 759         qv = TRUE;
 760     }
 761 #endif
 762     else if ( SvPOK(ver))/* must be a string or something like a string */
 763 VER_PV:
 764     {
 765         STRLEN len;
 766         version = savepvn(SvPV(ver,len), SvCUR(ver));
 767         SAVEFREEPV(version);
 768 #ifndef SvVOK
 769 #  if PERL_VERSION > 5
 770         /* This will only be executed for 5.6.0 - 5.8.0 inclusive */
 771         if ( len >= 3 && !instr(version,".") && !instr(version,"_")) {
 772             /* may be a v-string */
 773             char *testv = (char *)version;
 774             STRLEN tlen = len;
 775             for (tlen=0; tlen < len; tlen++, testv++) {
 776                 /* if one of the characters is non-text assume v-string */
 777                 if (testv[0] < ' ') {
 778                     SV * const nsv = sv_newmortal();
 779                     const char *nver;
 780                     const char *pos;
 781                     int saw_decimal = 0;
 782                     sv_setpvf(nsv,"v%vd",ver);
 783                     pos = nver = savepv(SvPV_nolen(nsv));
 784                     SAVEFREEPV(pos);
 785
 786                     /* scan the resulting formatted string */
 787                     pos++; /* skip the leading 'v' */
 788                     while ( *pos == '.' || isDIGIT(*pos) ) {
 789                         if ( *pos == '.' )
 790                             saw_decimal++ ;
 791                         pos++;
 792                     }
 793
 794                     /* is definitely a v-string */
 795                     if ( saw_decimal >= 2 ) {
 796                         version = nver;
 797                     }
 798                     break;
 799                 }
 800             }
 801         }
 802 #  endif
 803 #endif
 804     }
 805 #if PERL_VERSION_LT(5,17,2)
 806     else if (SvIOKp(ver)) {
 807         goto VER_IV;
 808     }
 809     else if (SvNOKp(ver)) {
 810         goto VER_NV;
 811     }
 812     else if (SvPOKp(ver)) {
 813         goto VER_PV;
 814     }
 815 #endif
 816     else
 817     {
 818         /* no idea what this is */
 819         Perl_croak(aTHX_ "Invalid version format (non-numeric data)");
 820     }
 821
 822     s = SCAN_VERSION(version, ver, qv);
 823     if ( *s != '\0' )
 824         Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
 825                        "Version string '%s' contains invalid data; "
 826                        "ignoring: '%s'", version, s);
 827
 828 #if PERL_VERSION_LT(5,19,8) && defined(USE_ITHREADS)
 829     LEAVE;
 830 #endif
 831
 832     return ver;
 833 }
 834
 835 /*
 836 =for apidoc vverify
 837
 838 Validates that the SV contains valid internal structure for a version object.
 839 It may be passed either the version object (RV) or the hash itself (HV).  If
 840 the structure is valid, it returns the HV.  If the structure is invalid,
 841 it returns NULL.
 842
 843     SV *hv = vverify(sv);
 844
 845 Note that it only confirms the bare minimum structure (so as not to get
 846 confused by derived classes which may contain additional hash entries):
 847
 848 =over 4
 849
 850 =item * The SV is an HV or a reference to an HV
 851
 852 =item * The hash contains a "version" key
 853
 854 =item * The "version" key has a reference to an AV as its value
 855
 856 =back
 857
 858 =cut
 859 */
 860
 861 SV *
 862 #ifdef VUTIL_REPLACE_CORE
 863 Perl_vverify2(pTHX_ SV *vs)
 864 #else
 865 Perl_vverify(pTHX_ SV *vs)
 866 #endif
 867 {
 868     SV *sv;
 869     SV **svp;
 870
 871     PERL_ARGS_ASSERT_VVERIFY;
 872
 873     if ( SvROK(vs) )
 874         vs = SvRV(vs);
 875
 876     /* see if the appropriate elements exist */
 877     if ( SvTYPE(vs) == SVt_PVHV
 878          && (svp = hv_fetchs(MUTABLE_HV(vs), "version", FALSE))
 879          && (sv = SvRV(*svp))
 880          && SvTYPE(sv) == SVt_PVAV )
 881         return vs;
 882     else
 883         return NULL;
 884 }
 885
 886 /*
 887 =for apidoc vnumify
 888
 889 Accepts a version object and returns the normalized floating
 890 point representation.  Call like:
 891
 892     sv = vnumify(rv);
 893
 894 NOTE: you can pass either the object directly or the SV
 895 contained within the RV.
 896
 897 The SV returned has a refcount of 1.
 898
 899 =cut
 900 */
 901
 902 SV *
 903 #ifdef VUTIL_REPLACE_CORE
 904 Perl_vnumify2(pTHX_ SV *vs)
 905 #else
 906 Perl_vnumify(pTHX_ SV *vs)
 907 #endif
 908 {
 909     SSize_t i, len;
 910     I32 digit;
 911     bool alpha = FALSE;
 912     SV *sv;
 913     AV *av;
 914
 915     PERL_ARGS_ASSERT_VNUMIFY;
 916
 917     /* extract the HV from the object */
 918     vs = VVERIFY(vs);
 919     if ( ! vs )
 920         Perl_croak(aTHX_ "Invalid version object");
 921
 922     /* see if various flags exist */
 923     if ( hv_exists(MUTABLE_HV(vs), "alpha", 5 ) )
 924         alpha = TRUE;
 925
 926     if (alpha) {
 927         Perl_ck_warner(aTHX_ packWARN(WARN_NUMERIC),
 928                        "alpha->numify() is lossy");
 929     }
 930
 931     /* attempt to retrieve the version array */
 932     if ( !(av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE))) ) ) {
 933         return newSVpvs("0");
 934     }
 935
 936     len = av_len(av);
 937     if ( len == -1 )
 938     {
 939         return newSVpvs("0");
 940     }
 941
 942     {
 943         SV * tsv = *av_fetch(av, 0, 0);
 944         digit = SvIV(tsv);
 945     }
 946     sv = Perl_newSVpvf(aTHX_ "%d.", (int)PERL_ABS(digit));
 947     for ( i = 1 ; i <= len ; i++ )
 948     {
 949         SV * tsv = *av_fetch(av, i, 0);
 950         digit = SvIV(tsv);
 951         Perl_sv_catpvf(aTHX_ sv, "%03d", (int)digit);
 952     }
 953
 954     if ( len == 0 ) {
 955         sv_catpvs(sv, "000");
 956     }
 957     return sv;
 958 }
 959
 960 /*
 961 =for apidoc vnormal
 962
 963 Accepts a version object and returns the normalized string
 964 representation.  Call like:
 965
 966     sv = vnormal(rv);
 967
 968 NOTE: you can pass either the object directly or the SV
 969 contained within the RV.
 970
 971 The SV returned has a refcount of 1.
 972
 973 =cut
 974 */
 975
 976 SV *
 977 #ifdef VUTIL_REPLACE_CORE
 978 Perl_vnormal2(pTHX_ SV *vs)
 979 #else
 980 Perl_vnormal(pTHX_ SV *vs)
 981 #endif
 982 {
 983     I32 i, len, digit;
 984     SV *sv;
 985     AV *av;
 986
 987     PERL_ARGS_ASSERT_VNORMAL;
 988
 989     /* extract the HV from the object */
 990     vs = VVERIFY(vs);
 991     if ( ! vs )
 992         Perl_croak(aTHX_ "Invalid version object");
 993
 994     av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE)));
 995
 996     len = av_len(av);
 997     if ( len == -1 )
 998     {
 999         return newSVpvs("");
1000     }
1001     {
1002         SV * tsv = *av_fetch(av, 0, 0);
1003         digit = SvIV(tsv);
1004     }
1005     sv = Perl_newSVpvf(aTHX_ "v%" IVdf, (IV)digit);
1006     for ( i = 1 ; i <= len ; i++ ) {
1007         SV * tsv = *av_fetch(av, i, 0);
1008         digit = SvIV(tsv);
1009         Perl_sv_catpvf(aTHX_ sv, ".%" IVdf, (IV)digit);
1010     }
1011
1012     if ( len <= 2 ) { /* short version, must be at least three */
1013         for ( len = 2 - len; len != 0; len-- )
1014             sv_catpvs(sv,".0");
1015     }
1016     return sv;
1017 }
1018
1019 /*
1020 =for apidoc vstringify
1021
1022 In order to maintain maximum compatibility with earlier versions
1023 of Perl, this function will return either the floating point
1024 notation or the multiple dotted notation, depending on whether
1025 the original version contained 1 or more dots, respectively.
1026
1027 The SV returned has a refcount of 1.
1028
1029 =cut
1030 */
1031
1032 SV *
1033 #ifdef VUTIL_REPLACE_CORE
1034 Perl_vstringify2(pTHX_ SV *vs)
1035 #else
1036 Perl_vstringify(pTHX_ SV *vs)
1037 #endif
1038 {
1039     SV ** svp;
1040     PERL_ARGS_ASSERT_VSTRINGIFY;
1041
1042     /* extract the HV from the object */
1043     vs = VVERIFY(vs);
1044     if ( ! vs )
1045         Perl_croak(aTHX_ "Invalid version object");
1046
1047     svp = hv_fetchs(MUTABLE_HV(vs), "original", FALSE);
1048     if (svp) {
1049         SV *pv;
1050         pv = *svp;
1051         if ( SvPOK(pv)
1052 #if PERL_VERSION_LT(5,17,2)
1053             || SvPOKp(pv)
1054 #endif
1055         )
1056             return newSVsv(pv);
1057         else
1058             return &PL_sv_undef;
1059     }
1060     else {
1061         if ( hv_exists(MUTABLE_HV(vs), "qv", 2) )
1062             return VNORMAL(vs);
1063         else
1064             return VNUMIFY(vs);
1065     }
1066 }
1067
1068 /*
1069 =for apidoc vcmp
1070
1071 Version object aware cmp.  Both operands must already have been
1072 converted into version objects.
1073
1074 =cut
1075 */
1076
1077 int
1078 #ifdef VUTIL_REPLACE_CORE
1079 Perl_vcmp2(pTHX_ SV *lhv, SV *rhv)
1080 #else
1081 Perl_vcmp(pTHX_ SV *lhv, SV *rhv)
1082 #endif
1083 {
1084     SSize_t i,l,m,r;
1085     I32 retval;
1086     I32 left = 0;
1087     I32 right = 0;
1088     AV *lav, *rav;
1089
1090     PERL_ARGS_ASSERT_VCMP;
1091
1092     /* extract the HVs from the objects */
1093     lhv = VVERIFY(lhv);
1094     rhv = VVERIFY(rhv);
1095     if ( ! ( lhv && rhv ) )
1096         Perl_croak(aTHX_ "Invalid version object");
1097
1098     /* get the left hand term */
1099     lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(lhv), "version", FALSE)));
1100
1101     /* and the right hand term */
1102     rav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(rhv), "version", FALSE)));
1103
1104     l = av_len(lav);
1105     r = av_len(rav);
1106     m = l < r ? l : r;
1107     retval = 0;
1108     i = 0;
1109     while ( i <= m && retval == 0 )
1110     {
1111         SV * const lsv = *av_fetch(lav,i,0);
1112         SV * rsv;
1113         left = SvIV(lsv);
1114         rsv = *av_fetch(rav,i,0);
1115         right = SvIV(rsv);
1116         if ( left < right  )
1117             retval = -1;
1118         if ( left > right )
1119             retval = +1;
1120         i++;
1121     }
1122
1123     if ( l != r && retval == 0 ) /* possible match except for trailing 0's */
1124     {
1125         if ( l < r )
1126         {
1127             while ( i <= r && retval == 0 )
1128             {
1129                 SV * const rsv = *av_fetch(rav,i,0);
1130                 if ( SvIV(rsv) != 0 )
1131                     retval = -1; /* not a match after all */
1132                 i++;
1133             }
1134         }
1135         else
1136         {
1137             while ( i <= l && retval == 0 )
1138             {
1139                 SV * const lsv = *av_fetch(lav,i,0);
1140                 if ( SvIV(lsv) != 0 )
1141                     retval = +1; /* not a match after all */
1142                 i++;
1143             }
1144         }
1145     }
1146     return retval;
1147 }
1148
1149 /* ex: set ro: */