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 #  include "EXTERN.h"
   6 #  include "perl.h"
   7 #  include "XSUB.h"
   8 #  define NEED_my_snprintf
   9 #  define NEED_newRV_noinc
  10 #  define NEED_vnewSVpvf
  11 #  define NEED_newSVpvn_flags_GLOBAL
  12 #  define NEED_warner
  13 #  include "ppport.h"
  14 #endif
  15 #include "vutil.h"
  16
  17 #define VERSION_MAX 0x7FFFFFFF
  18
  19 /*
  20 =for apidoc prescan_version
  21
  22 Validate that a given string can be parsed as a version object, but doesn't
  23 actually perform the parsing.  Can use either strict or lax validation rules.
  24 Can optionally set a number of hint variables to save the parsing code
  25 some time when tokenizing.
  26
  27 =cut
  28 */
  29 const char *
  30 #if VUTIL_REPLACE_CORE
  31 Perl_prescan_version2(pTHX_ const char *s, bool strict,
  32 #else
  33 Perl_prescan_version(pTHX_ const char *s, bool strict,
  34 #endif
  35                      const char **errstr,
  36                      bool *sqv, int *ssaw_decimal, int *swidth, bool *salpha) {
  37     bool qv = (sqv ? *sqv : FALSE);
  38     int width = 3;
  39     int saw_decimal = 0;
  40     bool alpha = FALSE;
  41     const char *d = s;
  42
  43     PERL_ARGS_ASSERT_PRESCAN_VERSION;
  44
  45     if (qv && isDIGIT(*d))
  46         goto dotted_decimal_version;
  47
  48     if (*d == 'v') { /* explicit v-string */
  49         d++;
  50         if (isDIGIT(*d)) {
  51             qv = TRUE;
  52         }
  53         else { /* degenerate v-string */
  54             /* requires v1.2.3 */
  55             BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
  56         }
  57
  58 dotted_decimal_version:
  59         if (strict && d[0] == '0' && isDIGIT(d[1])) {
  60             /* no leading zeros allowed */
  61             BADVERSION(s,errstr,"Invalid version format (no leading zeros)");
  62         }
  63
  64         while (isDIGIT(*d))     /* integer part */
  65             d++;
  66
  67         if (*d == '.')
  68         {
  69             saw_decimal++;
  70             d++;                /* decimal point */
  71         }
  72         else
  73         {
  74             if (strict) {
  75                 /* require v1.2.3 */
  76                 BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
  77             }
  78             else {
  79                 goto version_prescan_finish;
  80             }
  81         }
  82
  83         {
  84             int i = 0;
  85             int j = 0;
  86             while (isDIGIT(*d)) {       /* just keep reading */
  87                 i++;
  88                 while (isDIGIT(*d)) {
  89                     d++; j++;
  90                     /* maximum 3 digits between decimal */
  91                     if (strict && j > 3) {
  92                         BADVERSION(s,errstr,"Invalid version format (maximum 3 digits between decimals)");
  93                     }
  94                 }
  95                 if (*d == '_') {
  96                     if (strict) {
  97                         BADVERSION(s,errstr,"Invalid version format (no underscores)");
  98                     }
  99                     if ( alpha ) {
 100                         BADVERSION(s,errstr,"Invalid version format (multiple underscores)");
 101                     }
 102                     d++;
 103                     alpha = TRUE;
 104                 }
 105                 else if (*d == '.') {
 106                     if (alpha) {
 107                         BADVERSION(s,errstr,"Invalid version format (underscores before decimal)");
 108                     }
 109                     saw_decimal++;
 110                     d++;
 111                 }
 112                 else if (!isDIGIT(*d)) {
 113                     break;
 114                 }
 115                 j = 0;
 116             }
 117
 118             if (strict && i < 2) {
 119                 /* requires v1.2.3 */
 120                 BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
 121             }
 122         }
 123     }                                   /* end if dotted-decimal */
 124     else
 125     {                                   /* decimal versions */
 126         int j = 0;                      /* may need this later */
 127         /* special strict case for leading '.' or '0' */
 128         if (strict) {
 129             if (*d == '.') {
 130                 BADVERSION(s,errstr,"Invalid version format (0 before decimal required)");
 131             }
 132             if (*d == '0' && isDIGIT(d[1])) {
 133                 BADVERSION(s,errstr,"Invalid version format (no leading zeros)");
 134             }
 135         }
 136
 137         /* and we never support negative versions */
 138         if ( *d == '-') {
 139             BADVERSION(s,errstr,"Invalid version format (negative version number)");
 140         }
 141
 142         /* consume all of the integer part */
 143         while (isDIGIT(*d))
 144             d++;
 145
 146         /* look for a fractional part */
 147         if (*d == '.') {
 148             /* we found it, so consume it */
 149             saw_decimal++;
 150             d++;
 151         }
 152         else if (!*d || *d == ';' || isSPACE(*d) || *d == '{' || *d == '}') {
 153             if ( d == s ) {
 154                 /* found nothing */
 155                 BADVERSION(s,errstr,"Invalid version format (version required)");
 156             }
 157             /* found just an integer */
 158             goto version_prescan_finish;
 159         }
 160         else if ( d == s ) {
 161             /* didn't find either integer or period */
 162             BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
 163         }
 164         else if (*d == '_') {
 165             /* underscore can't come after integer part */
 166             if (strict) {
 167                 BADVERSION(s,errstr,"Invalid version format (no underscores)");
 168             }
 169             else if (isDIGIT(d[1])) {
 170                 BADVERSION(s,errstr,"Invalid version format (alpha without decimal)");
 171             }
 172             else {
 173                 BADVERSION(s,errstr,"Invalid version format (misplaced underscore)");
 174             }
 175         }
 176         else {
 177             /* anything else after integer part is just invalid data */
 178             BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
 179         }
 180
 181         /* scan the fractional part after the decimal point*/
 182
 183         if (!isDIGIT(*d) && (strict || ! (!*d || *d == ';' || isSPACE(*d) || *d == '{' || *d == '}') )) {
 184                 /* strict or lax-but-not-the-end */
 185                 BADVERSION(s,errstr,"Invalid version format (fractional part required)");
 186         }
 187
 188         while (isDIGIT(*d)) {
 189             d++; j++;
 190             if (*d == '.' && isDIGIT(d[-1])) {
 191                 if (alpha) {
 192                     BADVERSION(s,errstr,"Invalid version format (underscores before decimal)");
 193                 }
 194                 if (strict) {
 195                     BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions must begin with 'v')");
 196                 }
 197                 d = (char *)s;          /* start all over again */
 198                 qv = TRUE;
 199                 goto dotted_decimal_version;
 200             }
 201             if (*d == '_') {
 202                 if (strict) {
 203                     BADVERSION(s,errstr,"Invalid version format (no underscores)");
 204                 }
 205                 if ( alpha ) {
 206                     BADVERSION(s,errstr,"Invalid version format (multiple underscores)");
 207                 }
 208                 if ( ! isDIGIT(d[1]) ) {
 209                     BADVERSION(s,errstr,"Invalid version format (misplaced underscore)");
 210                 }
 211                 width = j;
 212                 d++;
 213                 alpha = TRUE;
 214             }
 215         }
 216     }
 217
 218 version_prescan_finish:
 219     while (isSPACE(*d))
 220         d++;
 221
 222     if (!isDIGIT(*d) && (! (!*d || *d == ';' || *d == '{' || *d == '}') )) {
 223         /* trailing non-numeric data */
 224         BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
 225     }
 226
 227     if (sqv)
 228         *sqv = qv;
 229     if (swidth)
 230         *swidth = width;
 231     if (ssaw_decimal)
 232         *ssaw_decimal = saw_decimal;
 233     if (salpha)
 234         *salpha = alpha;
 235     return d;
 236 }
 237
 238 /*
 239 =for apidoc scan_version
 240
 241 Returns a pointer to the next character after the parsed
 242 version string, as well as upgrading the passed in SV to
 243 an RV.
 244
 245 Function must be called with an already existing SV like
 246
 247     sv = newSV(0);
 248     s = scan_version(s, SV *sv, bool qv);
 249
 250 Performs some preprocessing to the string to ensure that
 251 it has the correct characteristics of a version.  Flags the
 252 object if it contains an underscore (which denotes this
 253 is an alpha version).  The boolean qv denotes that the version
 254 should be interpreted as if it had multiple decimals, even if
 255 it doesn't.
 256
 257 =cut
 258 */
 259
 260 const char *
 261 #if VUTIL_REPLACE_CORE
 262 Perl_scan_version2(pTHX_ const char *s, SV *rv, bool qv)
 263 #else
 264 Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
 265 #endif
 266 {
 267     const char *start = s;
 268     const char *pos;
 269     const char *last;
 270     const char *errstr = NULL;
 271     int saw_decimal = 0;
 272     int width = 3;
 273     bool alpha = FALSE;
 274     bool vinf = FALSE;
 275     AV * av;
 276     SV * hv;
 277
 278     PERL_ARGS_ASSERT_SCAN_VERSION;
 279
 280     while (isSPACE(*s)) /* leading whitespace is OK */
 281         s++;
 282
 283     last = PRESCAN_VERSION(s, FALSE, &errstr, &qv, &saw_decimal, &width, &alpha);
 284     if (errstr) {
 285         /* "undef" is a special case and not an error */
 286         if ( ! ( *s == 'u' && strEQ(s,"undef")) ) {
 287             Safefree(start);
 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 = av_len(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,"undef") ) {
 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 #if 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_CLASS_OBJ(ver,"version") ) /* 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         if ( hv_exists(MUTABLE_HV(ver), "width", 5 ) )
 488         {
 489             const I32 width = SvIV(*hv_fetchs(MUTABLE_HV(ver), "width", FALSE));
 490             (void)hv_stores(MUTABLE_HV(hv), "width", newSViv(width));
 491         }
 492
 493         if ( hv_exists(MUTABLE_HV(ver), "original", 8 ) )
 494         {
 495             SV * pv = *hv_fetchs(MUTABLE_HV(ver), "original", FALSE);
 496             (void)hv_stores(MUTABLE_HV(hv), "original", newSVsv(pv));
 497         }
 498
 499         sav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(ver), "version", FALSE)));
 500         /* This will get reblessed later if a derived class*/
 501         for ( key = 0; key <= av_len(sav); key++ )
 502         {
 503             const I32 rev = SvIV(*av_fetch(sav, key, FALSE));
 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             char * const version = savepvn( (const char*)mg->mg_ptr, len);
 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             Safefree(version);
 521         }
 522         else {
 523 #endif
 524         SvSetSV_nosteal(rv, ver); /* make a duplicate */
 525 #ifdef SvVOK
 526         }
 527     }
 528 #endif
 529     return 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 #if 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     PERL_ARGS_ASSERT_UPG_VERSION;
 558
 559     if ( SvNOK(ver) && !( SvPOK(ver) && sv_len(ver) == 3 ) )
 560     {
 561         STRLEN len;
 562
 563         /* may get too much accuracy */
 564         char tbuf[64];
 565         SV *sv = SvNVX(ver) > 10e50 ? newSV(64) : 0;
 566         char *buf;
 567 #ifdef USE_LOCALE_NUMERIC
 568         char *loc = NULL;
 569         if (! PL_numeric_standard) {
 570             loc = savepv(setlocale(LC_NUMERIC, NULL));
 571             setlocale(LC_NUMERIC, "C");
 572         }
 573 #endif
 574         if (sv) {
 575             Perl_sv_setpvf(aTHX_ sv, "%.9"NVff, SvNVX(ver));
 576             buf = SvPV(sv, len);
 577         }
 578         else {
 579             len = my_snprintf(tbuf, sizeof(tbuf), "%.9"NVff, SvNVX(ver));
 580             buf = tbuf;
 581         }
 582 #ifdef USE_LOCALE_NUMERIC
 583         if (loc) {
 584             setlocale(LC_NUMERIC, loc);
 585             Safefree(loc);
 586         }
 587 #endif
 588         while (buf[len-1] == '0' && len > 0) len--;
 589         if ( buf[len-1] == '.' ) len--; /* eat the trailing decimal */
 590         version = savepvn(buf, len);
 591         SvREFCNT_dec(sv);
 592     }
 593 #ifdef SvVOK
 594     else if ( (mg = SvVSTRING_mg(ver)) ) { /* already a v-string */
 595         version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
 596         qv = TRUE;
 597     }
 598 #endif
 599     else if ( (SvUOK(ver) && SvUVX(ver) > VERSION_MAX)
 600            || (SvIOK(ver) && SvIVX(ver) > VERSION_MAX) ) {
 601         /* out of bounds [unsigned] integer */
 602         STRLEN len;
 603         char tbuf[64];
 604         len = my_snprintf(tbuf, sizeof(tbuf), "%d", VERSION_MAX);
 605         version = savepvn(tbuf, len);
 606         Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
 607                        "Integer overflow in version %d",VERSION_MAX);
 608     }
 609     else if ( SvUOK(ver) || SvIOK(ver) ) {
 610         version = savesvpv(ver);
 611     }
 612     else /* must be a string or something like a string */
 613     {
 614         STRLEN len;
 615         version = savepvn(SvPV(ver,len), SvCUR(ver));
 616 #ifndef SvVOK
 617 #  if PERL_VERSION > 5
 618         /* This will only be executed for 5.6.0 - 5.8.0 inclusive */
 619         if ( len >= 3 && !instr(version,".") && !instr(version,"_")) {
 620             /* may be a v-string */
 621             char *testv = (char *)version;
 622             STRLEN tlen = len;
 623             for (tlen=0; tlen < len; tlen++, testv++) {
 624                 /* if one of the characters is non-text assume v-string */
 625                 if (testv[0] < ' ') {
 626                     SV * const nsv = sv_newmortal();
 627                     const char *nver;
 628                     const char *pos;
 629                     int saw_decimal = 0;
 630                     sv_setpvf(nsv,"v%vd",ver);
 631                     pos = nver = savepv(SvPV_nolen(nsv));
 632
 633                     /* scan the resulting formatted string */
 634                     pos++; /* skip the leading 'v' */
 635                     while ( *pos == '.' || isDIGIT(*pos) ) {
 636                         if ( *pos == '.' )
 637                             saw_decimal++ ;
 638                         pos++;
 639                     }
 640
 641                     /* is definitely a v-string */
 642                     if ( saw_decimal >= 2 ) {
 643                         Safefree(version);
 644                         version = nver;
 645                     }
 646                     break;
 647                 }
 648             }
 649         }
 650 #  endif
 651 #endif
 652     }
 653
 654     s = SCAN_VERSION(version, ver, qv);
 655     if ( *s != '\0' )
 656         Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
 657                        "Version string '%s' contains invalid data; "
 658                        "ignoring: '%s'", version, s);
 659     Safefree(version);
 660     return ver;
 661 }
 662
 663 /*
 664 =for apidoc vverify
 665
 666 Validates that the SV contains valid internal structure for a version object.
 667 It may be passed either the version object (RV) or the hash itself (HV).  If
 668 the structure is valid, it returns the HV.  If the structure is invalid,
 669 it returns NULL.
 670
 671     SV *hv = vverify(sv);
 672
 673 Note that it only confirms the bare minimum structure (so as not to get
 674 confused by derived classes which may contain additional hash entries):
 675
 676 =over 4
 677
 678 =item * The SV is an HV or a reference to an HV
 679
 680 =item * The hash contains a "version" key
 681
 682 =item * The "version" key has a reference to an AV as its value
 683
 684 =back
 685
 686 =cut
 687 */
 688
 689 SV *
 690 #if VUTIL_REPLACE_CORE
 691 Perl_vverify2(pTHX_ SV *vs)
 692 #else
 693 Perl_vverify(pTHX_ SV *vs)
 694 #endif
 695 {
 696     SV *sv;
 697
 698     PERL_ARGS_ASSERT_VVERIFY;
 699
 700     if ( SvROK(vs) )
 701         vs = SvRV(vs);
 702
 703     /* see if the appropriate elements exist */
 704     if ( SvTYPE(vs) == SVt_PVHV
 705          && hv_exists(MUTABLE_HV(vs), "version", 7)
 706          && (sv = SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE)))
 707          && SvTYPE(sv) == SVt_PVAV )
 708         return vs;
 709     else
 710         return NULL;
 711 }
 712
 713 /*
 714 =for apidoc vnumify
 715
 716 Accepts a version object and returns the normalized floating
 717 point representation.  Call like:
 718
 719     sv = vnumify(rv);
 720
 721 NOTE: you can pass either the object directly or the SV
 722 contained within the RV.
 723
 724 The SV returned has a refcount of 1.
 725
 726 =cut
 727 */
 728
 729 SV *
 730 #if VUTIL_REPLACE_CORE
 731 Perl_vnumify2(pTHX_ SV *vs)
 732 #else
 733 Perl_vnumify(pTHX_ SV *vs)
 734 #endif
 735 {
 736     SSize_t i, len;
 737     I32 digit;
 738     int width;
 739     bool alpha = FALSE;
 740     SV *sv;
 741     AV *av;
 742
 743     PERL_ARGS_ASSERT_VNUMIFY;
 744
 745     /* extract the HV from the object */
 746     vs = VVERIFY(vs);
 747     if ( ! vs )
 748         Perl_croak(aTHX_ "Invalid version object");
 749
 750     /* see if various flags exist */
 751     if ( hv_exists(MUTABLE_HV(vs), "alpha", 5 ) )
 752         alpha = TRUE;
 753     if ( hv_exists(MUTABLE_HV(vs), "width", 5 ) )
 754         width = SvIV(*hv_fetchs(MUTABLE_HV(vs), "width", FALSE));
 755     else
 756         width = 3;
 757
 758
 759     /* attempt to retrieve the version array */
 760     if ( !(av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE))) ) ) {
 761         return newSVpvs("0");
 762     }
 763
 764     len = av_len(av);
 765     if ( len == -1 )
 766     {
 767         return newSVpvs("0");
 768     }
 769
 770     digit = SvIV(*av_fetch(av, 0, 0));
 771     sv = Perl_newSVpvf(aTHX_ "%d.", (int)PERL_ABS(digit));
 772     for ( i = 1 ; i < len ; i++ )
 773     {
 774         digit = SvIV(*av_fetch(av, i, 0));
 775         if ( width < 3 ) {
 776             const int denom = (width == 2 ? 10 : 100);
 777             const div_t term = div((int)PERL_ABS(digit),denom);
 778             Perl_sv_catpvf(aTHX_ sv, "%0*d_%d", width, term.quot, term.rem);
 779         }
 780         else {
 781             Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit);
 782         }
 783     }
 784
 785     if ( len > 0 )
 786     {
 787         digit = SvIV(*av_fetch(av, len, 0));
 788         if ( alpha && width == 3 ) /* alpha version */
 789             sv_catpvs(sv,"_");
 790         Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit);
 791     }
 792     else /* len == 0 */
 793     {
 794         sv_catpvs(sv, "000");
 795     }
 796     return sv;
 797 }
 798
 799 /*
 800 =for apidoc vnormal
 801
 802 Accepts a version object and returns the normalized string
 803 representation.  Call like:
 804
 805     sv = vnormal(rv);
 806
 807 NOTE: you can pass either the object directly or the SV
 808 contained within the RV.
 809
 810 The SV returned has a refcount of 1.
 811
 812 =cut
 813 */
 814
 815 SV *
 816 #if VUTIL_REPLACE_CORE
 817 Perl_vnormal2(pTHX_ SV *vs)
 818 #else
 819 Perl_vnormal(pTHX_ SV *vs)
 820 #endif
 821 {
 822     I32 i, len, digit;
 823     bool alpha = FALSE;
 824     SV *sv;
 825     AV *av;
 826
 827     PERL_ARGS_ASSERT_VNORMAL;
 828
 829     /* extract the HV from the object */
 830     vs = VVERIFY(vs);
 831     if ( ! vs )
 832         Perl_croak(aTHX_ "Invalid version object");
 833
 834     if ( hv_exists(MUTABLE_HV(vs), "alpha", 5 ) )
 835         alpha = TRUE;
 836     av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE)));
 837
 838     len = av_len(av);
 839     if ( len == -1 )
 840     {
 841         return newSVpvs("");
 842     }
 843     digit = SvIV(*av_fetch(av, 0, 0));
 844     sv = Perl_newSVpvf(aTHX_ "v%"IVdf, (IV)digit);
 845     for ( i = 1 ; i < len ; i++ ) {
 846         digit = SvIV(*av_fetch(av, i, 0));
 847         Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
 848     }
 849
 850     if ( len > 0 )
 851     {
 852         /* handle last digit specially */
 853         digit = SvIV(*av_fetch(av, len, 0));
 854         if ( alpha )
 855             Perl_sv_catpvf(aTHX_ sv, "_%"IVdf, (IV)digit);
 856         else
 857             Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
 858     }
 859
 860     if ( len <= 2 ) { /* short version, must be at least three */
 861         for ( len = 2 - len; len != 0; len-- )
 862             sv_catpvs(sv,".0");
 863     }
 864     return sv;
 865 }
 866
 867 /*
 868 =for apidoc vstringify
 869
 870 In order to maintain maximum compatibility with earlier versions
 871 of Perl, this function will return either the floating point
 872 notation or the multiple dotted notation, depending on whether
 873 the original version contained 1 or more dots, respectively.
 874
 875 The SV returned has a refcount of 1.
 876
 877 =cut
 878 */
 879
 880 SV *
 881 #if VUTIL_REPLACE_CORE
 882 Perl_vstringify2(pTHX_ SV *vs)
 883 #else
 884 Perl_vstringify(pTHX_ SV *vs)
 885 #endif
 886 {
 887     PERL_ARGS_ASSERT_VSTRINGIFY;
 888
 889     /* extract the HV from the object */
 890     vs = VVERIFY(vs);
 891     if ( ! vs )
 892         Perl_croak(aTHX_ "Invalid version object");
 893
 894     if (hv_exists(MUTABLE_HV(vs), "original",  sizeof("original") - 1)) {
 895         SV *pv;
 896         pv = *hv_fetchs(MUTABLE_HV(vs), "original", FALSE);
 897         if ( SvPOK(pv) )
 898             return newSVsv(pv);
 899         else
 900             return &PL_sv_undef;
 901     }
 902     else {
 903         if ( hv_exists(MUTABLE_HV(vs), "qv", 2) )
 904             return VNORMAL(vs);
 905         else
 906             return VNUMIFY(vs);
 907     }
 908 }
 909
 910 /*
 911 =for apidoc vcmp
 912
 913 Version object aware cmp.  Both operands must already have been
 914 converted into version objects.
 915
 916 =cut
 917 */
 918
 919 int
 920 #if VUTIL_REPLACE_CORE
 921 Perl_vcmp2(pTHX_ SV *lhv, SV *rhv)
 922 #else
 923 Perl_vcmp(pTHX_ SV *lhv, SV *rhv)
 924 #endif
 925 {
 926     SSize_t i,l,m,r;
 927     I32 retval;
 928     bool lalpha = FALSE;
 929     bool ralpha = FALSE;
 930     I32 left = 0;
 931     I32 right = 0;
 932     AV *lav, *rav;
 933
 934     PERL_ARGS_ASSERT_VCMP;
 935
 936     /* extract the HVs from the objects */
 937     lhv = VVERIFY(lhv);
 938     rhv = VVERIFY(rhv);
 939     if ( ! ( lhv && rhv ) )
 940         Perl_croak(aTHX_ "Invalid version object");
 941
 942     /* get the left hand term */
 943     lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(lhv), "version", FALSE)));
 944     if ( hv_exists(MUTABLE_HV(lhv), "alpha", 5 ) )
 945         lalpha = TRUE;
 946
 947     /* and the right hand term */
 948     rav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(rhv), "version", FALSE)));
 949     if ( hv_exists(MUTABLE_HV(rhv), "alpha", 5 ) )
 950         ralpha = TRUE;
 951
 952     l = av_len(lav);
 953     r = av_len(rav);
 954     m = l < r ? l : r;
 955     retval = 0;
 956     i = 0;
 957     while ( i <= m && retval == 0 )
 958     {
 959         left  = SvIV(*av_fetch(lav,i,0));
 960         right = SvIV(*av_fetch(rav,i,0));
 961         if ( left < right  )
 962             retval = -1;
 963         if ( left > right )
 964             retval = +1;
 965         i++;
 966     }
 967
 968     /* tiebreaker for alpha with identical terms */
 969     if ( retval == 0 && l == r && left == right && ( lalpha || ralpha ) )
 970     {
 971         if ( lalpha && !ralpha )
 972         {
 973             retval = -1;
 974         }
 975         else if ( ralpha && !lalpha)
 976         {
 977             retval = +1;
 978         }
 979     }
 980
 981     if ( l != r && retval == 0 ) /* possible match except for trailing 0's */
 982     {
 983         if ( l < r )
 984         {
 985             while ( i <= r && retval == 0 )
 986             {
 987                 if ( SvIV(*av_fetch(rav,i,0)) != 0 )
 988                     retval = -1; /* not a match after all */
 989                 i++;
 990             }
 991         }
 992         else
 993         {
 994             while ( i <= l && retval == 0 )
 995             {
 996                 if ( SvIV(*av_fetch(lav,i,0)) != 0 )
 997                     retval = +1; /* not a match after all */
 998                 i++;
 999             }
1000         }
1001     }
1002     return retval;
1003 }