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         STORE_NUMERIC_LOCAL_SET_STANDARD();
 595         LOCK_NUMERIC_STANDARD();
 596         if (sv) {
 597             Perl_sv_catpvf(aTHX_ sv, "%.9"NVff, SvNVX(ver));
 598             len = SvCUR(sv);
 599             buf = SvPVX(sv);
 600         }
 601         else {
 602             len = my_snprintf(tbuf, sizeof(tbuf), "%.9"NVff, SvNVX(ver));
 603             buf = tbuf;
 604         }
 605         UNLOCK_NUMERIC_STANDARD();
 606         RESTORE_NUMERIC_LOCAL();
 607         while (buf[len-1] == '0' && len > 0) len--;
 608         if ( buf[len-1] == '.' ) len--; /* eat the trailing decimal */
 609         version = savepvn(buf, len);
 610         SAVEFREEPV(version);
 611         SvREFCNT_dec(sv);
 612     }
 613 #ifdef SvVOK
 614     else if ( (mg = SvVSTRING_mg(ver)) ) { /* already a v-string */
 615         version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
 616         SAVEFREEPV(version);
 617         qv = TRUE;
 618     }
 619 #endif
 620     else if ( SvPOK(ver))/* must be a string or something like a string */
 621 #if PERL_VERSION_LT(5,17,2)
 622 VER_PV:
 623 #endif
 624     {
 625         STRLEN len;
 626         version = savepvn(SvPV(ver,len), SvCUR(ver));
 627         SAVEFREEPV(version);
 628 #ifndef SvVOK
 629 #  if PERL_VERSION > 5
 630         /* This will only be executed for 5.6.0 - 5.8.0 inclusive */
 631         if ( len >= 3 && !instr(version,".") && !instr(version,"_")) {
 632             /* may be a v-string */
 633             char *testv = (char *)version;
 634             STRLEN tlen = len;
 635             for (tlen=0; tlen < len; tlen++, testv++) {
 636                 /* if one of the characters is non-text assume v-string */
 637                 if (testv[0] < ' ') {
 638                     SV * const nsv = sv_newmortal();
 639                     const char *nver;
 640                     const char *pos;
 641                     int saw_decimal = 0;
 642                     sv_setpvf(nsv,"v%vd",ver);
 643                     pos = nver = savepv(SvPV_nolen(nsv));
 644                     SAVEFREEPV(pos);
 645
 646                     /* scan the resulting formatted string */
 647                     pos++; /* skip the leading 'v' */
 648                     while ( *pos == '.' || isDIGIT(*pos) ) {
 649                         if ( *pos == '.' )
 650                             saw_decimal++ ;
 651                         pos++;
 652                     }
 653
 654                     /* is definitely a v-string */
 655                     if ( saw_decimal >= 2 ) {
 656                         version = nver;
 657                     }
 658                     break;
 659                 }
 660             }
 661         }
 662 #  endif
 663 #endif
 664     }
 665 #if PERL_VERSION_LT(5,17,2)
 666     else if (SvIOKp(ver)) {
 667         goto VER_IV;
 668     }
 669     else if (SvNOKp(ver)) {
 670         goto VER_NV;
 671     }
 672     else if (SvPOKp(ver)) {
 673         goto VER_PV;
 674     }
 675 #endif
 676     else
 677     {
 678         /* no idea what this is */
 679         Perl_croak(aTHX_ "Invalid version format (non-numeric data)");
 680     }
 681
 682     s = SCAN_VERSION(version, ver, qv);
 683     if ( *s != '\0' )
 684         Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
 685                        "Version string '%s' contains invalid data; "
 686                        "ignoring: '%s'", version, s);
 687
 688 #if PERL_VERSION_LT(5,19,8) && defined(USE_ITHREADS)
 689     LEAVE;
 690 #endif
 691
 692     return ver;
 693 }
 694
 695 /*
 696 =for apidoc vverify
 697
 698 Validates that the SV contains valid internal structure for a version object.
 699 It may be passed either the version object (RV) or the hash itself (HV).  If
 700 the structure is valid, it returns the HV.  If the structure is invalid,
 701 it returns NULL.
 702
 703     SV *hv = vverify(sv);
 704
 705 Note that it only confirms the bare minimum structure (so as not to get
 706 confused by derived classes which may contain additional hash entries):
 707
 708 =over 4
 709
 710 =item * The SV is an HV or a reference to an HV
 711
 712 =item * The hash contains a "version" key
 713
 714 =item * The "version" key has a reference to an AV as its value
 715
 716 =back
 717
 718 =cut
 719 */
 720
 721 SV *
 722 #ifdef VUTIL_REPLACE_CORE
 723 Perl_vverify2(pTHX_ SV *vs)
 724 #else
 725 Perl_vverify(pTHX_ SV *vs)
 726 #endif
 727 {
 728     SV *sv;
 729     SV **svp;
 730
 731     PERL_ARGS_ASSERT_VVERIFY;
 732
 733     if ( SvROK(vs) )
 734         vs = SvRV(vs);
 735
 736     /* see if the appropriate elements exist */
 737     if ( SvTYPE(vs) == SVt_PVHV
 738          && (svp = hv_fetchs(MUTABLE_HV(vs), "version", FALSE))
 739          && (sv = SvRV(*svp))
 740          && SvTYPE(sv) == SVt_PVAV )
 741         return vs;
 742     else
 743         return NULL;
 744 }
 745
 746 /*
 747 =for apidoc vnumify
 748
 749 Accepts a version object and returns the normalized floating
 750 point representation.  Call like:
 751
 752     sv = vnumify(rv);
 753
 754 NOTE: you can pass either the object directly or the SV
 755 contained within the RV.
 756
 757 The SV returned has a refcount of 1.
 758
 759 =cut
 760 */
 761
 762 SV *
 763 #ifdef VUTIL_REPLACE_CORE
 764 Perl_vnumify2(pTHX_ SV *vs)
 765 #else
 766 Perl_vnumify(pTHX_ SV *vs)
 767 #endif
 768 {
 769     SSize_t i, len;
 770     I32 digit;
 771     int width;
 772     bool alpha = FALSE;
 773     SV *sv;
 774     AV *av;
 775
 776     PERL_ARGS_ASSERT_VNUMIFY;
 777
 778     /* extract the HV from the object */
 779     vs = VVERIFY(vs);
 780     if ( ! vs )
 781         Perl_croak(aTHX_ "Invalid version object");
 782
 783     /* see if various flags exist */
 784     if ( hv_exists(MUTABLE_HV(vs), "alpha", 5 ) )
 785         alpha = TRUE;
 786     {
 787         SV ** svp = hv_fetchs(MUTABLE_HV(vs), "width", FALSE);
 788         if ( svp )
 789             width = SvIV(*svp);
 790         else
 791             width = 3;
 792     }
 793
 794
 795     /* attempt to retrieve the version array */
 796     if ( !(av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE))) ) ) {
 797         return newSVpvs("0");
 798     }
 799
 800     len = av_len(av);
 801     if ( len == -1 )
 802     {
 803         return newSVpvs("0");
 804     }
 805
 806     {
 807         SV * tsv = *av_fetch(av, 0, 0);
 808         digit = SvIV(tsv);
 809     }
 810     sv = Perl_newSVpvf(aTHX_ "%d.", (int)PERL_ABS(digit));
 811     for ( i = 1 ; i < len ; i++ )
 812     {
 813         SV * tsv = *av_fetch(av, i, 0);
 814         digit = SvIV(tsv);
 815         if ( width < 3 ) {
 816             const int denom = (width == 2 ? 10 : 100);
 817             const div_t term = div((int)PERL_ABS(digit),denom);
 818             Perl_sv_catpvf(aTHX_ sv, "%0*d_%d", width, term.quot, term.rem);
 819         }
 820         else {
 821             Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit);
 822         }
 823     }
 824
 825     if ( len > 0 )
 826     {
 827         SV * tsv = *av_fetch(av, len, 0);
 828         digit = SvIV(tsv);
 829         if ( alpha && width == 3 ) /* alpha version */
 830             sv_catpvs(sv,"_");
 831         Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit);
 832     }
 833     else /* len == 0 */
 834     {
 835         sv_catpvs(sv, "000");
 836     }
 837     return sv;
 838 }
 839
 840 /*
 841 =for apidoc vnormal
 842
 843 Accepts a version object and returns the normalized string
 844 representation.  Call like:
 845
 846     sv = vnormal(rv);
 847
 848 NOTE: you can pass either the object directly or the SV
 849 contained within the RV.
 850
 851 The SV returned has a refcount of 1.
 852
 853 =cut
 854 */
 855
 856 SV *
 857 #ifdef VUTIL_REPLACE_CORE
 858 Perl_vnormal2(pTHX_ SV *vs)
 859 #else
 860 Perl_vnormal(pTHX_ SV *vs)
 861 #endif
 862 {
 863     I32 i, len, digit;
 864     bool alpha = FALSE;
 865     SV *sv;
 866     AV *av;
 867
 868     PERL_ARGS_ASSERT_VNORMAL;
 869
 870     /* extract the HV from the object */
 871     vs = VVERIFY(vs);
 872     if ( ! vs )
 873         Perl_croak(aTHX_ "Invalid version object");
 874
 875     if ( hv_exists(MUTABLE_HV(vs), "alpha", 5 ) )
 876         alpha = TRUE;
 877     av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE)));
 878
 879     len = av_len(av);
 880     if ( len == -1 )
 881     {
 882         return newSVpvs("");
 883     }
 884     {
 885         SV * tsv = *av_fetch(av, 0, 0);
 886         digit = SvIV(tsv);
 887     }
 888     sv = Perl_newSVpvf(aTHX_ "v%"IVdf, (IV)digit);
 889     for ( i = 1 ; i < len ; i++ ) {
 890         SV * tsv = *av_fetch(av, i, 0);
 891         digit = SvIV(tsv);
 892         Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
 893     }
 894
 895     if ( len > 0 )
 896     {
 897         /* handle last digit specially */
 898         SV * tsv = *av_fetch(av, len, 0);
 899         digit = SvIV(tsv);
 900         if ( alpha )
 901             Perl_sv_catpvf(aTHX_ sv, "_%"IVdf, (IV)digit);
 902         else
 903             Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
 904     }
 905
 906     if ( len <= 2 ) { /* short version, must be at least three */
 907         for ( len = 2 - len; len != 0; len-- )
 908             sv_catpvs(sv,".0");
 909     }
 910     return sv;
 911 }
 912
 913 /*
 914 =for apidoc vstringify
 915
 916 In order to maintain maximum compatibility with earlier versions
 917 of Perl, this function will return either the floating point
 918 notation or the multiple dotted notation, depending on whether
 919 the original version contained 1 or more dots, respectively.
 920
 921 The SV returned has a refcount of 1.
 922
 923 =cut
 924 */
 925
 926 SV *
 927 #ifdef VUTIL_REPLACE_CORE
 928 Perl_vstringify2(pTHX_ SV *vs)
 929 #else
 930 Perl_vstringify(pTHX_ SV *vs)
 931 #endif
 932 {
 933     SV ** svp;
 934     PERL_ARGS_ASSERT_VSTRINGIFY;
 935
 936     /* extract the HV from the object */
 937     vs = VVERIFY(vs);
 938     if ( ! vs )
 939         Perl_croak(aTHX_ "Invalid version object");
 940
 941     svp = hv_fetchs(MUTABLE_HV(vs), "original", FALSE);
 942     if (svp) {
 943         SV *pv;
 944         pv = *svp;
 945         if ( SvPOK(pv) )
 946             return newSVsv(pv);
 947         else
 948             return &PL_sv_undef;
 949     }
 950     else {
 951         if ( hv_exists(MUTABLE_HV(vs), "qv", 2) )
 952             return VNORMAL(vs);
 953         else
 954             return VNUMIFY(vs);
 955     }
 956 }
 957
 958 /*
 959 =for apidoc vcmp
 960
 961 Version object aware cmp.  Both operands must already have been
 962 converted into version objects.
 963
 964 =cut
 965 */
 966
 967 int
 968 #ifdef VUTIL_REPLACE_CORE
 969 Perl_vcmp2(pTHX_ SV *lhv, SV *rhv)
 970 #else
 971 Perl_vcmp(pTHX_ SV *lhv, SV *rhv)
 972 #endif
 973 {
 974     SSize_t i,l,m,r;
 975     I32 retval;
 976     bool lalpha = FALSE;
 977     bool ralpha = FALSE;
 978     I32 left = 0;
 979     I32 right = 0;
 980     AV *lav, *rav;
 981
 982     PERL_ARGS_ASSERT_VCMP;
 983
 984     /* extract the HVs from the objects */
 985     lhv = VVERIFY(lhv);
 986     rhv = VVERIFY(rhv);
 987     if ( ! ( lhv && rhv ) )
 988         Perl_croak(aTHX_ "Invalid version object");
 989
 990     /* get the left hand term */
 991     lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(lhv), "version", FALSE)));
 992     if ( hv_exists(MUTABLE_HV(lhv), "alpha", 5 ) )
 993         lalpha = TRUE;
 994
 995     /* and the right hand term */
 996     rav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(rhv), "version", FALSE)));
 997     if ( hv_exists(MUTABLE_HV(rhv), "alpha", 5 ) )
 998         ralpha = TRUE;
 999
1000     l = av_len(lav);
1001     r = av_len(rav);
1002     m = l < r ? l : r;
1003     retval = 0;
1004     i = 0;
1005     while ( i <= m && retval == 0 )
1006     {
1007         SV * const lsv = *av_fetch(lav,i,0);
1008         SV * rsv;
1009         left = SvIV(lsv);
1010         rsv = *av_fetch(rav,i,0);
1011         right = SvIV(rsv);
1012         if ( left < right  )
1013             retval = -1;
1014         if ( left > right )
1015             retval = +1;
1016         i++;
1017     }
1018
1019     /* tiebreaker for alpha with identical terms */
1020     if ( retval == 0 && l == r && left == right && ( lalpha || ralpha ) )
1021     {
1022         if ( lalpha && !ralpha )
1023         {
1024             retval = -1;
1025         }
1026         else if ( ralpha && !lalpha)
1027         {
1028             retval = +1;
1029         }
1030     }
1031
1032     if ( l != r && retval == 0 ) /* possible match except for trailing 0's */
1033     {
1034         if ( l < r )
1035         {
1036             while ( i <= r && retval == 0 )
1037             {
1038                 SV * const rsv = *av_fetch(rav,i,0);
1039                 if ( SvIV(rsv) != 0 )
1040                     retval = -1; /* not a match after all */
1041                 i++;
1042             }
1043         }
1044         else
1045         {
1046             while ( i <= l && retval == 0 )
1047             {
1048                 SV * const lsv = *av_fetch(lav,i,0);
1049                 if ( SvIV(lsv) != 0 )
1050                     retval = +1; /* not a match after all */
1051                 i++;
1052             }
1053         }
1054     }
1055     return retval;
1056 }