vutil.c

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