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