This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Extract version routines into two new files
authorFather Chrysostomos <sprout@cpan.org>
Tue, 10 Sep 2013 07:14:59 +0000 (00:14 -0700)
committerFather Chrysostomos <sprout@cpan.org>
Sat, 4 Jan 2014 13:10:02 +0000 (05:10 -0800)
This is to make synchronisation between the CPAN distribution and the
perl core easier.

The files have different extensions to match what the CPAN distribu-
tion will have.  vutil.c is a separate compilation unit that the CPAN
dist already has.  vxs.inc will be included by vxs.xs (vxs.c is obvi-
ously alreday taken, being generated from vxs.xs).

In the perl core util.c includes vutil.c and universal.c
includes vxs.inc.

MANIFEST
universal.c
util.c
vutil.c [new file with mode: 0644]
vxs.inc [new file with mode: 0644]

index a0a8578..6ad17f6 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -5478,6 +5478,8 @@ vos/configure_full_perl.sh        VOS shell script to configure "full" perl before buil
 vos/make_full_perl.sh          VOS shell script to build and test "full" perl
 vos/vos.c                      VOS emulations for missing POSIX functions
 vos/vosish.h                   VOS-specific header file
+vutil.c                                Version object C functions
+vxs.inc                                Version object XS methods
 warnings.h                     The warning numbers
 win32/bin/exetype.pl           Set executable type to CONSOLE or WINDOWS
 win32/bin/perlglob.pl          Win32 globbing
index 229b05d..c5102e3 100644 (file)
@@ -416,382 +416,6 @@ XS(XS_UNIVERSAL_DOES)
     }
 }
 
-XS(XS_UNIVERSAL_VERSION)
-{
-    dVAR;
-    dXSARGS;
-    HV *pkg;
-    GV **gvp;
-    GV *gv;
-    SV *sv;
-    const char *undef;
-    PERL_UNUSED_ARG(cv);
-
-    if (SvROK(ST(0))) {
-        sv = MUTABLE_SV(SvRV(ST(0)));
-        if (!SvOBJECT(sv))
-            Perl_croak(aTHX_ "Cannot find version of an unblessed reference");
-        pkg = SvSTASH(sv);
-    }
-    else {
-        pkg = gv_stashsv(ST(0), 0);
-    }
-
-    gvp = pkg ? (GV**)hv_fetchs(pkg, "VERSION", FALSE) : NULL;
-
-    if (gvp && isGV(gv = *gvp) && (sv = GvSV(gv)) && SvOK(sv)) {
-        SV * const nsv = sv_newmortal();
-        sv_setsv(nsv, sv);
-        sv = nsv;
-       if ( !sv_isobject(sv) || !sv_derived_from(sv, "version"))
-           upg_version(sv, FALSE);
-
-        undef = NULL;
-    }
-    else {
-        sv = &PL_sv_undef;
-        undef = "(undef)";
-    }
-
-    if (items > 1) {
-       SV *req = ST(1);
-
-       if (undef) {
-           if (pkg) {
-               const HEK * const name = HvNAME_HEK(pkg);
-               Perl_croak(aTHX_
-                          "%"HEKf" does not define $%"HEKf
-                          "::VERSION--version check failed",
-                          HEKfARG(name), HEKfARG(name));
-           } else {
-               Perl_croak(aTHX_
-                            "%"SVf" defines neither package nor VERSION--version check failed",
-                            SVfARG(ST(0)) );
-            }
-       }
-
-       if ( !sv_isobject(req) || !sv_derived_from(req, "version")) {
-           /* req may very well be R/O, so create a new object */
-           req = sv_2mortal( new_version(req) );
-       }
-
-       if ( vcmp( req, sv ) > 0 ) {
-           if ( hv_exists(MUTABLE_HV(SvRV(req)), "qv", 2 ) ) {
-               Perl_croak(aTHX_ "%"HEKf" version %"SVf" required--"
-                      "this is only version %"SVf"",
-                       HEKfARG(HvNAME_HEK(pkg)),
-                      SVfARG(sv_2mortal(vnormal(req))),
-                      SVfARG(sv_2mortal(vnormal(sv))));
-           } else {
-               Perl_croak(aTHX_ "%"HEKf" version %"SVf" required--"
-                      "this is only version %"SVf,
-                       HEKfARG(HvNAME_HEK(pkg)),
-                      SVfARG(sv_2mortal(vstringify(req))),
-                      SVfARG(sv_2mortal(vstringify(sv))));
-           }
-       }
-
-    }
-
-    if ( SvOK(sv) && sv_derived_from(sv, "version") ) {
-       ST(0) = sv_2mortal(vstringify(sv));
-    } else {
-       ST(0) = sv;
-    }
-
-    XSRETURN(1);
-}
-
-XS(XS_version_new)
-{
-    dVAR;
-    dXSARGS;
-    if (items > 3 || items < 1)
-       croak_xs_usage(cv, "class, version");
-    SP -= items;
-    {
-        SV *vs = ST(1);
-       SV *rv;
-        STRLEN len;
-        const char *classname;
-        U32 flags;
-
-       /* Just in case this is something like a tied hash */
-       SvGETMAGIC(vs);
-
-        if ( sv_isobject(ST(0)) ) { /* get the class if called as an object method */
-            const HV * stash = SvSTASH(SvRV(ST(0)));
-            classname = HvNAME(stash);
-            len       = HvNAMELEN(stash);
-            flags     = HvNAMEUTF8(stash) ? SVf_UTF8 : 0;
-        }
-        else {
-           classname = SvPV(ST(0), len);
-            flags     = SvUTF8(ST(0));
-        }
-
-       if ( items == 1 || ! SvOK(vs) ) { /* no param or explicit undef */
-           /* create empty object */
-           vs = sv_newmortal();
-           sv_setpvs(vs, "0");
-       }
-       else if ( items == 3 ) {
-           vs = sv_newmortal();
-           Perl_sv_setpvf(aTHX_ vs,"v%s",SvPV_nolen_const(ST(2)));
-       }
-
-       rv = new_version(vs);
-       if ( strnNE(classname,"version", len) ) /* inherited new() */
-           sv_bless(rv, gv_stashpvn(classname, len, GV_ADD | flags));
-
-       mPUSHs(rv);
-       PUTBACK;
-       return;
-    }
-}
-
-XS(XS_version_stringify)
-{
-     dVAR;
-     dXSARGS;
-     if (items < 1)
-        croak_xs_usage(cv, "lobj, ...");
-     SP -= items;
-     {
-         SV *  lobj = ST(0);
-
-         if (sv_isobject(lobj) && sv_derived_from(lobj, "version")) {
-              lobj = SvRV(lobj);
-         }
-         else
-              Perl_croak(aTHX_ "lobj is not of type version");
-
-         mPUSHs(vstringify(lobj));
-
-         PUTBACK;
-         return;
-     }
-}
-
-XS(XS_version_numify)
-{
-     dVAR;
-     dXSARGS;
-     if (items < 1)
-        croak_xs_usage(cv, "lobj, ...");
-     SP -= items;
-     {
-         SV *  lobj = ST(0);
-
-         if (sv_isobject(lobj) && sv_derived_from(lobj, "version")) {
-              lobj = SvRV(lobj);
-         }
-         else
-              Perl_croak(aTHX_ "lobj is not of type version");
-
-         mPUSHs(vnumify(lobj));
-
-         PUTBACK;
-         return;
-     }
-}
-
-XS(XS_version_normal)
-{
-     dVAR;
-     dXSARGS;
-     if (items < 1)
-        croak_xs_usage(cv, "lobj, ...");
-     SP -= items;
-     {
-         SV *  lobj = ST(0);
-
-         if (sv_isobject(lobj) && sv_derived_from(lobj, "version")) {
-              lobj = SvRV(lobj);
-         }
-         else
-              Perl_croak(aTHX_ "lobj is not of type version");
-
-         mPUSHs(vnormal(lobj));
-
-         PUTBACK;
-         return;
-     }
-}
-
-XS(XS_version_vcmp)
-{
-     dVAR;
-     dXSARGS;
-     if (items < 1)
-        croak_xs_usage(cv, "lobj, ...");
-     SP -= items;
-     {
-         SV *  lobj = ST(0);
-
-         if (sv_isobject(lobj) && sv_derived_from(lobj, "version")) {
-              lobj = SvRV(lobj);
-         }
-         else
-              Perl_croak(aTHX_ "lobj is not of type version");
-
-         {
-              SV       *rs;
-              SV       *rvs;
-              SV * robj = ST(1);
-              const IV  swap = (IV)SvIV(ST(2));
-
-              if ( !sv_isobject(robj) || !sv_derived_from(robj, "version") )
-              {
-                   robj = new_version(SvOK(robj) ? robj : newSVpvs_flags("0", SVs_TEMP));
-                   sv_2mortal(robj);
-              }
-              rvs = SvRV(robj);
-
-              if ( swap )
-              {
-                   rs = newSViv(vcmp(rvs,lobj));
-              }
-              else
-              {
-                   rs = newSViv(vcmp(lobj,rvs));
-              }
-
-              mPUSHs(rs);
-         }
-
-         PUTBACK;
-         return;
-     }
-}
-
-XS(XS_version_boolean)
-{
-    dVAR;
-    dXSARGS;
-    if (items < 1)
-       croak_xs_usage(cv, "lobj, ...");
-    SP -= items;
-    if (sv_isobject(ST(0)) && sv_derived_from(ST(0), "version")) {
-       SV * const lobj = SvRV(ST(0));
-       SV * const rs =
-           newSViv( vcmp(lobj,
-                         sv_2mortal(new_version(
-                                       sv_2mortal(newSVpvs("0"))
-                                   ))
-                        )
-                  );
-       mPUSHs(rs);
-       PUTBACK;
-       return;
-    }
-    else
-       Perl_croak(aTHX_ "lobj is not of type version");
-}
-
-XS(XS_version_noop)
-{
-    dVAR;
-    dXSARGS;
-    if (items < 1)
-       croak_xs_usage(cv, "lobj, ...");
-    if (sv_isobject(ST(0)) && sv_derived_from(ST(0), "version"))
-       Perl_croak(aTHX_ "operation not supported with version object");
-    else
-       Perl_croak(aTHX_ "lobj is not of type version");
-#ifndef HASATTRIBUTE_NORETURN
-    XSRETURN_EMPTY;
-#endif
-}
-
-XS(XS_version_is_alpha)
-{
-    dVAR;
-    dXSARGS;
-    if (items != 1)
-       croak_xs_usage(cv, "lobj");
-    SP -= items;
-    if (sv_isobject(ST(0)) && sv_derived_from(ST(0), "version")) {
-       SV * const lobj = ST(0);
-       if ( hv_exists(MUTABLE_HV(SvRV(lobj)), "alpha", 5 ) )
-           XSRETURN_YES;
-       else
-           XSRETURN_NO;
-       PUTBACK;
-       return;
-    }
-    else
-       Perl_croak(aTHX_ "lobj is not of type version");
-}
-
-XS(XS_version_qv)
-{
-    dVAR;
-    dXSARGS;
-    PERL_UNUSED_ARG(cv);
-    SP -= items;
-    {
-       SV * ver = ST(0);
-       SV * rv;
-        STRLEN len = 0;
-        const char * classname = "";
-        U32 flags = 0;
-        if ( items == 2 ) {
-           SvGETMAGIC(ST(1));
-           if (SvOK(ST(1))) {
-               ver = ST(1);
-           }
-           else {
-               Perl_croak(aTHX_ "Invalid version format (version required)");
-           }
-            if ( sv_isobject(ST(0)) ) { /* class called as an object method */
-                const HV * stash = SvSTASH(SvRV(ST(0)));
-                classname = HvNAME(stash);
-                len       = HvNAMELEN(stash);
-                flags     = HvNAMEUTF8(stash) ? SVf_UTF8 : 0;
-            }
-            else {
-              classname = SvPV(ST(0), len);
-                flags     = SvUTF8(ST(0));
-            }
-        }
-       if ( !SvVOK(ver) ) { /* not already a v-string */
-           rv = sv_newmortal();
-           sv_setsv(rv,ver); /* make a duplicate */
-           upg_version(rv, TRUE);
-       } else {
-           rv = sv_2mortal(new_version(ver));
-       }
-       if ( items == 2
-                && strnNE(classname,"version", len) ) { /* inherited new() */
-           sv_bless(rv, gv_stashpvn(classname, len, GV_ADD | flags));
-        }
-       PUSHs(rv);
-    }
-    PUTBACK;
-    return;
-}
-
-XS(XS_version_is_qv)
-{
-    dVAR;
-    dXSARGS;
-    if (items != 1)
-       croak_xs_usage(cv, "lobj");
-    SP -= items;
-    if (sv_isobject(ST(0)) && sv_derived_from(ST(0), "version")) {
-       SV * const lobj = ST(0);
-       if ( hv_exists(MUTABLE_HV(SvRV(lobj)), "qv", 2 ) )
-           XSRETURN_YES;
-       else
-           XSRETURN_NO;
-       PUTBACK;
-       return;
-    }
-    else
-       Perl_croak(aTHX_ "lobj is not of type version");
-}
-
 XS(XS_utf8_is_utf8)
 {
      dVAR;
@@ -1372,6 +996,8 @@ XS(XS_re_regexp_pattern)
     /* NOT-REACHED */
 }
 
+#include "vxs.inc"
+
 struct xsub_details {
     const char *name;
     XSUBADDR_t xsub;
@@ -1382,35 +1008,9 @@ static const struct xsub_details details[] = {
     {"UNIVERSAL::isa", XS_UNIVERSAL_isa, NULL},
     {"UNIVERSAL::can", XS_UNIVERSAL_can, NULL},
     {"UNIVERSAL::DOES", XS_UNIVERSAL_DOES, NULL},
-    {"UNIVERSAL::VERSION", XS_UNIVERSAL_VERSION, NULL},
-    {"version::()", XS_version_noop, NULL},
-    {"version::new", XS_version_new, NULL},
-    {"version::parse", XS_version_new, NULL},
-    {"version::(\"\"", XS_version_stringify, NULL},
-    {"version::stringify", XS_version_stringify, NULL},
-    {"version::(0+", XS_version_numify, NULL},
-    {"version::numify", XS_version_numify, NULL},
-    {"version::normal", XS_version_normal, NULL},
-    {"version::(cmp", XS_version_vcmp, NULL},
-    {"version::(<=>", XS_version_vcmp, NULL},
-    {"version::vcmp", XS_version_vcmp, NULL},
-    {"version::(bool", XS_version_boolean, NULL},
-    {"version::boolean", XS_version_boolean, NULL},
-    {"version::(+", XS_version_noop, NULL},
-    {"version::(-", XS_version_noop, NULL},
-    {"version::(*", XS_version_noop, NULL},
-    {"version::(/", XS_version_noop, NULL},
-    {"version::(+=", XS_version_noop, NULL},
-    {"version::(-=", XS_version_noop, NULL},
-    {"version::(*=", XS_version_noop, NULL},
-    {"version::(/=", XS_version_noop, NULL},
-    {"version::(abs", XS_version_noop, NULL},
-    {"version::(nomethod", XS_version_noop, NULL},
-    {"version::noop", XS_version_noop, NULL},
-    {"version::is_alpha", XS_version_is_alpha, NULL},
-    {"version::qv", XS_version_qv, NULL},
-    {"version::declare", XS_version_qv, NULL},
-    {"version::is_qv", XS_version_is_qv, NULL},
+#define VXS_XSUB_DETAILS
+#include "vxs.inc"
+#undef VXS_XSUB_DETAILS
     {"utf8::is_utf8", XS_utf8_is_utf8, NULL},
     {"utf8::valid", XS_utf8_valid, NULL},
     {"utf8::encode", XS_utf8_encode, NULL},
diff --git a/util.c b/util.c
index 596955b..f308e93 100644 (file)
--- a/util.c
+++ b/util.c
@@ -3919,945 +3919,7 @@ Perl_getcwd_sv(pTHX_ SV *sv)
 #endif
 }
 
-#define VERSION_MAX 0x7FFFFFFF
-
-/*
-=for apidoc prescan_version
-
-Validate that a given string can be parsed as a version object, but doesn't
-actually perform the parsing.  Can use either strict or lax validation rules.
-Can optionally set a number of hint variables to save the parsing code
-some time when tokenizing.
-
-=cut
-*/
-const char *
-Perl_prescan_version(pTHX_ const char *s, bool strict,
-                    const char **errstr,
-                    bool *sqv, int *ssaw_decimal, int *swidth, bool *salpha) {
-    bool qv = (sqv ? *sqv : FALSE);
-    int width = 3;
-    int saw_decimal = 0;
-    bool alpha = FALSE;
-    const char *d = s;
-
-    PERL_ARGS_ASSERT_PRESCAN_VERSION;
-
-    if (qv && isDIGIT(*d))
-       goto dotted_decimal_version;
-
-    if (*d == 'v') { /* explicit v-string */
-       d++;
-       if (isDIGIT(*d)) {
-           qv = TRUE;
-       }
-       else { /* degenerate v-string */
-           /* requires v1.2.3 */
-           BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
-       }
-
-dotted_decimal_version:
-       if (strict && d[0] == '0' && isDIGIT(d[1])) {
-           /* no leading zeros allowed */
-           BADVERSION(s,errstr,"Invalid version format (no leading zeros)");
-       }
-
-       while (isDIGIT(*d))     /* integer part */
-           d++;
-
-       if (*d == '.')
-       {
-           saw_decimal++;
-           d++;                /* decimal point */
-       }
-       else
-       {
-           if (strict) {
-               /* require v1.2.3 */
-               BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
-           }
-           else {
-               goto version_prescan_finish;
-           }
-       }
-
-       {
-           int i = 0;
-           int j = 0;
-           while (isDIGIT(*d)) {       /* just keep reading */
-               i++;
-               while (isDIGIT(*d)) {
-                   d++; j++;
-                   /* maximum 3 digits between decimal */
-                   if (strict && j > 3) {
-                       BADVERSION(s,errstr,"Invalid version format (maximum 3 digits between decimals)");
-                   }
-               }
-               if (*d == '_') {
-                   if (strict) {
-                       BADVERSION(s,errstr,"Invalid version format (no underscores)");
-                   }
-                   if ( alpha ) {
-                       BADVERSION(s,errstr,"Invalid version format (multiple underscores)");
-                   }
-                   d++;
-                   alpha = TRUE;
-               }
-               else if (*d == '.') {
-                   if (alpha) {
-                       BADVERSION(s,errstr,"Invalid version format (underscores before decimal)");
-                   }
-                   saw_decimal++;
-                   d++;
-               }
-               else if (!isDIGIT(*d)) {
-                   break;
-               }
-               j = 0;
-           }
-
-           if (strict && i < 2) {
-               /* requires v1.2.3 */
-               BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
-           }
-       }
-    }                                  /* end if dotted-decimal */
-    else
-    {                                  /* decimal versions */
-       int j = 0;                      /* may need this later */
-       /* special strict case for leading '.' or '0' */
-       if (strict) {
-           if (*d == '.') {
-               BADVERSION(s,errstr,"Invalid version format (0 before decimal required)");
-           }
-           if (*d == '0' && isDIGIT(d[1])) {
-               BADVERSION(s,errstr,"Invalid version format (no leading zeros)");
-           }
-       }
-
-       /* and we never support negative versions */
-       if ( *d == '-') {
-           BADVERSION(s,errstr,"Invalid version format (negative version number)");
-       }
-
-       /* consume all of the integer part */
-       while (isDIGIT(*d))
-           d++;
-
-       /* look for a fractional part */
-       if (*d == '.') {
-           /* we found it, so consume it */
-           saw_decimal++;
-           d++;
-       }
-       else if (!*d || *d == ';' || isSPACE(*d) || *d == '{' || *d == '}') {
-           if ( d == s ) {
-               /* found nothing */
-               BADVERSION(s,errstr,"Invalid version format (version required)");
-           }
-           /* found just an integer */
-           goto version_prescan_finish;
-       }
-       else if ( d == s ) {
-           /* didn't find either integer or period */
-           BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
-       }
-       else if (*d == '_') {
-           /* underscore can't come after integer part */
-           if (strict) {
-               BADVERSION(s,errstr,"Invalid version format (no underscores)");
-           }
-           else if (isDIGIT(d[1])) {
-               BADVERSION(s,errstr,"Invalid version format (alpha without decimal)");
-           }
-           else {
-               BADVERSION(s,errstr,"Invalid version format (misplaced underscore)");
-           }
-       }
-       else {
-           /* anything else after integer part is just invalid data */
-           BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
-       }
-
-       /* scan the fractional part after the decimal point*/
-
-       if (!isDIGIT(*d) && (strict || ! (!*d || *d == ';' || isSPACE(*d) || *d == '{' || *d == '}') )) {
-               /* strict or lax-but-not-the-end */
-               BADVERSION(s,errstr,"Invalid version format (fractional part required)");
-       }
-
-       while (isDIGIT(*d)) {
-           d++; j++;
-           if (*d == '.' && isDIGIT(d[-1])) {
-               if (alpha) {
-                   BADVERSION(s,errstr,"Invalid version format (underscores before decimal)");
-               }
-               if (strict) {
-                   BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions must begin with 'v')");
-               }
-               d = (char *)s;          /* start all over again */
-               qv = TRUE;
-               goto dotted_decimal_version;
-           }
-           if (*d == '_') {
-               if (strict) {
-                   BADVERSION(s,errstr,"Invalid version format (no underscores)");
-               }
-               if ( alpha ) {
-                   BADVERSION(s,errstr,"Invalid version format (multiple underscores)");
-               }
-               if ( ! isDIGIT(d[1]) ) {
-                   BADVERSION(s,errstr,"Invalid version format (misplaced underscore)");
-               }
-               width = j;
-               d++;
-               alpha = TRUE;
-           }
-       }
-    }
-
-version_prescan_finish:
-    while (isSPACE(*d))
-       d++;
-
-    if (!isDIGIT(*d) && (! (!*d || *d == ';' || *d == '{' || *d == '}') )) {
-       /* trailing non-numeric data */
-       BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
-    }
-
-    if (sqv)
-       *sqv = qv;
-    if (swidth)
-       *swidth = width;
-    if (ssaw_decimal)
-       *ssaw_decimal = saw_decimal;
-    if (salpha)
-       *salpha = alpha;
-    return d;
-}
-
-/*
-=for apidoc scan_version
-
-Returns a pointer to the next character after the parsed
-version string, as well as upgrading the passed in SV to
-an RV.
-
-Function must be called with an already existing SV like
-
-    sv = newSV(0);
-    s = scan_version(s, SV *sv, bool qv);
-
-Performs some preprocessing to the string to ensure that
-it has the correct characteristics of a version.  Flags the
-object if it contains an underscore (which denotes this
-is an alpha version).  The boolean qv denotes that the version
-should be interpreted as if it had multiple decimals, even if
-it doesn't.
-
-=cut
-*/
-
-const char *
-Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
-{
-    const char *start = s;
-    const char *pos;
-    const char *last;
-    const char *errstr = NULL;
-    int saw_decimal = 0;
-    int width = 3;
-    bool alpha = FALSE;
-    bool vinf = FALSE;
-    AV * av;
-    SV * hv;
-
-    PERL_ARGS_ASSERT_SCAN_VERSION;
-
-    while (isSPACE(*s)) /* leading whitespace is OK */
-       s++;
-
-    last = prescan_version(s, FALSE, &errstr, &qv, &saw_decimal, &width, &alpha);
-    if (errstr) {
-       /* "undef" is a special case and not an error */
-       if ( ! ( *s == 'u' && strEQ(s,"undef")) ) {
-           Safefree(start);
-           Perl_croak(aTHX_ "%s", errstr);
-       }
-    }
-
-    start = s;
-    if (*s == 'v')
-       s++;
-    pos = s;
-
-    /* Now that we are through the prescan, start creating the object */
-    av = newAV();
-    hv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */
-    (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
-
-#ifndef NODEFAULT_SHAREKEYS
-    HvSHAREKEYS_on(hv);         /* key-sharing on by default */
-#endif
-
-    if ( qv )
-       (void)hv_stores(MUTABLE_HV(hv), "qv", newSViv(qv));
-    if ( alpha )
-       (void)hv_stores(MUTABLE_HV(hv), "alpha", newSViv(alpha));
-    if ( !qv && width < 3 )
-       (void)hv_stores(MUTABLE_HV(hv), "width", newSViv(width));
-
-    while (isDIGIT(*pos))
-       pos++;
-    if (!isALPHA(*pos)) {
-       I32 rev;
-
-       for (;;) {
-           rev = 0;
-           {
-               /* this is atoi() that delimits on underscores */
-               const char *end = pos;
-               I32 mult = 1;
-               I32 orev;
-
-               /* the following if() will only be true after the decimal
-                * point of a version originally created with a bare
-                * floating point number, i.e. not quoted in any way
-                */
-               if ( !qv && s > start && saw_decimal == 1 ) {
-                   mult *= 100;
-                   while ( s < end ) {
-                       orev = rev;
-                       rev += (*s - '0') * mult;
-                       mult /= 10;
-                       if (   (PERL_ABS(orev) > PERL_ABS(rev)) 
-                           || (PERL_ABS(rev) > VERSION_MAX )) {
-                           Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW), 
-                                          "Integer overflow in version %d",VERSION_MAX);
-                           s = end - 1;
-                           rev = VERSION_MAX;
-                           vinf = 1;
-                       }
-                       s++;
-                       if ( *s == '_' )
-                           s++;
-                   }
-               }
-               else {
-                   while (--end >= s) {
-                       orev = rev;
-                       rev += (*end - '0') * mult;
-                       mult *= 10;
-                       if (   (PERL_ABS(orev) > PERL_ABS(rev)) 
-                           || (PERL_ABS(rev) > VERSION_MAX )) {
-                           Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW), 
-                                          "Integer overflow in version");
-                           end = s - 1;
-                           rev = VERSION_MAX;
-                           vinf = 1;
-                       }
-                   }
-               } 
-           }
-
-           /* Append revision */
-           av_push(av, newSViv(rev));
-           if ( vinf ) {
-               s = last;
-               break;
-           }
-           else if ( *pos == '.' )
-               s = ++pos;
-           else if ( *pos == '_' && isDIGIT(pos[1]) )
-               s = ++pos;
-           else if ( *pos == ',' && isDIGIT(pos[1]) )
-               s = ++pos;
-           else if ( isDIGIT(*pos) )
-               s = pos;
-           else {
-               s = pos;
-               break;
-           }
-           if ( qv ) {
-               while ( isDIGIT(*pos) )
-                   pos++;
-           }
-           else {
-               int digits = 0;
-               while ( ( isDIGIT(*pos) || *pos == '_' ) && digits < 3 ) {
-                   if ( *pos != '_' )
-                       digits++;
-                   pos++;
-               }
-           }
-       }
-    }
-    if ( qv ) { /* quoted versions always get at least three terms*/
-       SSize_t len = av_len(av);
-       /* This for loop appears to trigger a compiler bug on OS X, as it
-          loops infinitely. Yes, len is negative. No, it makes no sense.
-          Compiler in question is:
-          gcc version 3.3 20030304 (Apple Computer, Inc. build 1640)
-          for ( len = 2 - len; len > 0; len-- )
-          av_push(MUTABLE_AV(sv), newSViv(0));
-       */
-       len = 2 - len;
-       while (len-- > 0)
-           av_push(av, newSViv(0));
-    }
-
-    /* need to save off the current version string for later */
-    if ( vinf ) {
-       SV * orig = newSVpvn("v.Inf", sizeof("v.Inf")-1);
-       (void)hv_stores(MUTABLE_HV(hv), "original", orig);
-       (void)hv_stores(MUTABLE_HV(hv), "vinf", newSViv(1));
-    }
-    else if ( s > start ) {
-       SV * orig = newSVpvn(start,s-start);
-       if ( qv && saw_decimal == 1 && *start != 'v' ) {
-           /* need to insert a v to be consistent */
-           sv_insert(orig, 0, 0, "v", 1);
-       }
-       (void)hv_stores(MUTABLE_HV(hv), "original", orig);
-    }
-    else {
-       (void)hv_stores(MUTABLE_HV(hv), "original", newSVpvs("0"));
-       av_push(av, newSViv(0));
-    }
-
-    /* And finally, store the AV in the hash */
-    (void)hv_stores(MUTABLE_HV(hv), "version", newRV_noinc(MUTABLE_SV(av)));
-
-    /* fix RT#19517 - special case 'undef' as string */
-    if ( *s == 'u' && strEQ(s,"undef") ) {
-       s += 5;
-    }
-
-    return s;
-}
-
-/*
-=for apidoc new_version
-
-Returns a new version object based on the passed in SV:
-
-    SV *sv = new_version(SV *ver);
-
-Does not alter the passed in ver SV.  See "upg_version" if you
-want to upgrade the SV.
-
-=cut
-*/
-
-SV *
-Perl_new_version(pTHX_ SV *ver)
-{
-    dVAR;
-    SV * const rv = newSV(0);
-    PERL_ARGS_ASSERT_NEW_VERSION;
-    if ( sv_isobject(ver) && sv_derived_from(ver, "version") )
-        /* can just copy directly */
-    {
-       SSize_t key;
-       AV * const av = newAV();
-       AV *sav;
-       /* This will get reblessed later if a derived class*/
-       SV * const hv = newSVrv(rv, "version"); 
-       (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
-#ifndef NODEFAULT_SHAREKEYS
-       HvSHAREKEYS_on(hv);         /* key-sharing on by default */
-#endif
-
-       if ( SvROK(ver) )
-           ver = SvRV(ver);
-
-       /* Begin copying all of the elements */
-       if ( hv_exists(MUTABLE_HV(ver), "qv", 2) )
-           (void)hv_stores(MUTABLE_HV(hv), "qv", newSViv(1));
-
-       if ( hv_exists(MUTABLE_HV(ver), "alpha", 5) )
-           (void)hv_stores(MUTABLE_HV(hv), "alpha", newSViv(1));
-
-       if ( hv_exists(MUTABLE_HV(ver), "width", 5 ) )
-       {
-           const I32 width = SvIV(*hv_fetchs(MUTABLE_HV(ver), "width", FALSE));
-           (void)hv_stores(MUTABLE_HV(hv), "width", newSViv(width));
-       }
-
-       if ( hv_exists(MUTABLE_HV(ver), "original", 8 ) )
-       {
-           SV * pv = *hv_fetchs(MUTABLE_HV(ver), "original", FALSE);
-           (void)hv_stores(MUTABLE_HV(hv), "original", newSVsv(pv));
-       }
-
-       sav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(ver), "version", FALSE)));
-       /* This will get reblessed later if a derived class*/
-       for ( key = 0; key <= av_len(sav); key++ )
-       {
-           const I32 rev = SvIV(*av_fetch(sav, key, FALSE));
-           av_push(av, newSViv(rev));
-       }
-
-       (void)hv_stores(MUTABLE_HV(hv), "version", newRV_noinc(MUTABLE_SV(av)));
-       return rv;
-    }
-#ifdef SvVOK
-    {
-       const MAGIC* const mg = SvVSTRING_mg(ver);
-       if ( mg ) { /* already a v-string */
-           const STRLEN len = mg->mg_len;
-           char * const version = savepvn( (const char*)mg->mg_ptr, len);
-           sv_setpvn(rv,version,len);
-           /* this is for consistency with the pure Perl class */
-           if ( isDIGIT(*version) )
-               sv_insert(rv, 0, 0, "v", 1);
-           Safefree(version);
-       }
-       else {
-#endif
-       sv_setsv(rv,ver); /* make a duplicate */
-#ifdef SvVOK
-       }
-    }
-#endif
-    return upg_version(rv, FALSE);
-}
-
-/*
-=for apidoc upg_version
-
-In-place upgrade of the supplied SV to a version object.
-
-    SV *sv = upg_version(SV *sv, bool qv);
-
-Returns a pointer to the upgraded SV.  Set the boolean qv if you want
-to force this SV to be interpreted as an "extended" version.
-
-=cut
-*/
-
-SV *
-Perl_upg_version(pTHX_ SV *ver, bool qv)
-{
-    const char *version, *s;
-#ifdef SvVOK
-    const MAGIC *mg;
-#endif
-
-    PERL_ARGS_ASSERT_UPG_VERSION;
-
-    if ( SvNOK(ver) && !( SvPOK(ver) && sv_len(ver) == 3 ) )
-    {
-       STRLEN len;
-
-       /* may get too much accuracy */ 
-       char tbuf[64];
-       SV *sv = SvNVX(ver) > 10e50 ? newSV(64) : 0;
-       char *buf;
-#ifdef USE_LOCALE_NUMERIC
-       char *loc = NULL;
-       if (! PL_numeric_standard) {
-           loc = savepv(setlocale(LC_NUMERIC, NULL));
-           setlocale(LC_NUMERIC, "C");
-       }
-#endif
-       if (sv) {
-           Perl_sv_setpvf(aTHX_ sv, "%.9"NVff, SvNVX(ver));
-           buf = SvPV(sv, len);
-       }
-       else {
-           len = my_snprintf(tbuf, sizeof(tbuf), "%.9"NVff, SvNVX(ver));
-           buf = tbuf;
-       }
-#ifdef USE_LOCALE_NUMERIC
-       if (loc) {
-           setlocale(LC_NUMERIC, loc);
-           Safefree(loc);
-       }
-#endif
-       while (buf[len-1] == '0' && len > 0) len--;
-       if ( buf[len-1] == '.' ) len--; /* eat the trailing decimal */
-       version = savepvn(buf, len);
-       SvREFCNT_dec(sv);
-    }
-#ifdef SvVOK
-    else if ( (mg = SvVSTRING_mg(ver)) ) { /* already a v-string */
-       version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
-       qv = TRUE;
-    }
-#endif
-    else /* must be a string or something like a string */
-    {
-       STRLEN len;
-       version = savepv(SvPV(ver,len));
-#ifndef SvVOK
-#  if PERL_VERSION > 5
-       /* This will only be executed for 5.6.0 - 5.8.0 inclusive */
-       if ( len >= 3 && !instr(version,".") && !instr(version,"_")) {
-           /* may be a v-string */
-           char *testv = (char *)version;
-           STRLEN tlen = len;
-           for (tlen=0; tlen < len; tlen++, testv++) {
-               /* if one of the characters is non-text assume v-string */
-               if (testv[0] < ' ') {
-                   SV * const nsv = sv_newmortal();
-                   const char *nver;
-                   const char *pos;
-                   int saw_decimal = 0;
-                   sv_setpvf(nsv,"v%vd",ver);
-                   pos = nver = savepv(SvPV_nolen(nsv));
-
-                   /* scan the resulting formatted string */
-                   pos++; /* skip the leading 'v' */
-                   while ( *pos == '.' || isDIGIT(*pos) ) {
-                       if ( *pos == '.' )
-                           saw_decimal++ ;
-                       pos++;
-                   }
-
-                   /* is definitely a v-string */
-                   if ( saw_decimal >= 2 ) {
-                       Safefree(version);
-                       version = nver;
-                   }
-                   break;
-               }
-           }
-       }
-#  endif
-#endif
-    }
-
-    s = scan_version(version, ver, qv);
-    if ( *s != '\0' ) 
-       Perl_ck_warner(aTHX_ packWARN(WARN_MISC), 
-                      "Version string '%s' contains invalid data; "
-                      "ignoring: '%s'", version, s);
-    Safefree(version);
-    return ver;
-}
-
-/*
-=for apidoc vverify
-
-Validates that the SV contains valid internal structure for a version object.
-It may be passed either the version object (RV) or the hash itself (HV).  If
-the structure is valid, it returns the HV.  If the structure is invalid,
-it returns NULL.
-
-    SV *hv = vverify(sv);
-
-Note that it only confirms the bare minimum structure (so as not to get
-confused by derived classes which may contain additional hash entries):
-
-=over 4
-
-=item * The SV is an HV or a reference to an HV
-
-=item * The hash contains a "version" key
-
-=item * The "version" key has a reference to an AV as its value
-
-=back
-
-=cut
-*/
-
-SV *
-Perl_vverify(pTHX_ SV *vs)
-{
-    SV *sv;
-
-    PERL_ARGS_ASSERT_VVERIFY;
-
-    if ( SvROK(vs) )
-       vs = SvRV(vs);
-
-    /* see if the appropriate elements exist */
-    if ( SvTYPE(vs) == SVt_PVHV
-        && hv_exists(MUTABLE_HV(vs), "version", 7)
-        && (sv = SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE)))
-        && SvTYPE(sv) == SVt_PVAV )
-       return vs;
-    else
-       return NULL;
-}
-
-/*
-=for apidoc vnumify
-
-Accepts a version object and returns the normalized floating
-point representation.  Call like:
-
-    sv = vnumify(rv);
-
-NOTE: you can pass either the object directly or the SV
-contained within the RV.
-
-The SV returned has a refcount of 1.
-
-=cut
-*/
-
-SV *
-Perl_vnumify(pTHX_ SV *vs)
-{
-    SSize_t i, len;
-    I32 digit;
-    int width;
-    bool alpha = FALSE;
-    SV *sv;
-    AV *av;
-
-    PERL_ARGS_ASSERT_VNUMIFY;
-
-    /* extract the HV from the object */
-    vs = vverify(vs);
-    if ( ! vs )
-       Perl_croak(aTHX_ "Invalid version object");
-
-    /* see if various flags exist */
-    if ( hv_exists(MUTABLE_HV(vs), "alpha", 5 ) )
-       alpha = TRUE;
-    if ( hv_exists(MUTABLE_HV(vs), "width", 5 ) )
-       width = SvIV(*hv_fetchs(MUTABLE_HV(vs), "width", FALSE));
-    else
-       width = 3;
-
-
-    /* attempt to retrieve the version array */
-    if ( !(av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE))) ) ) {
-       return newSVpvs("0");
-    }
-
-    len = av_len(av);
-    if ( len == -1 )
-    {
-       return newSVpvs("0");
-    }
-
-    digit = SvIV(*av_fetch(av, 0, 0));
-    sv = Perl_newSVpvf(aTHX_ "%d.", (int)PERL_ABS(digit));
-    for ( i = 1 ; i < len ; i++ )
-    {
-       digit = SvIV(*av_fetch(av, i, 0));
-       if ( width < 3 ) {
-           const int denom = (width == 2 ? 10 : 100);
-           const div_t term = div((int)PERL_ABS(digit),denom);
-           Perl_sv_catpvf(aTHX_ sv, "%0*d_%d", width, term.quot, term.rem);
-       }
-       else {
-           Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit);
-       }
-    }
-
-    if ( len > 0 )
-    {
-       digit = SvIV(*av_fetch(av, len, 0));
-       if ( alpha && width == 3 ) /* alpha version */
-           sv_catpvs(sv,"_");
-       Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit);
-    }
-    else /* len == 0 */
-    {
-       sv_catpvs(sv, "000");
-    }
-    return sv;
-}
-
-/*
-=for apidoc vnormal
-
-Accepts a version object and returns the normalized string
-representation.  Call like:
-
-    sv = vnormal(rv);
-
-NOTE: you can pass either the object directly or the SV
-contained within the RV.
-
-The SV returned has a refcount of 1.
-
-=cut
-*/
-
-SV *
-Perl_vnormal(pTHX_ SV *vs)
-{
-    I32 i, len, digit;
-    bool alpha = FALSE;
-    SV *sv;
-    AV *av;
-
-    PERL_ARGS_ASSERT_VNORMAL;
-
-    /* extract the HV from the object */
-    vs = vverify(vs);
-    if ( ! vs )
-       Perl_croak(aTHX_ "Invalid version object");
-
-    if ( hv_exists(MUTABLE_HV(vs), "alpha", 5 ) )
-       alpha = TRUE;
-    av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE)));
-
-    len = av_len(av);
-    if ( len == -1 )
-    {
-       return newSVpvs("");
-    }
-    digit = SvIV(*av_fetch(av, 0, 0));
-    sv = Perl_newSVpvf(aTHX_ "v%"IVdf, (IV)digit);
-    for ( i = 1 ; i < len ; i++ ) {
-       digit = SvIV(*av_fetch(av, i, 0));
-       Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
-    }
-
-    if ( len > 0 )
-    {
-       /* handle last digit specially */
-       digit = SvIV(*av_fetch(av, len, 0));
-       if ( alpha )
-           Perl_sv_catpvf(aTHX_ sv, "_%"IVdf, (IV)digit);
-       else
-           Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
-    }
-
-    if ( len <= 2 ) { /* short version, must be at least three */
-       for ( len = 2 - len; len != 0; len-- )
-           sv_catpvs(sv,".0");
-    }
-    return sv;
-}
-
-/*
-=for apidoc vstringify
-
-In order to maintain maximum compatibility with earlier versions
-of Perl, this function will return either the floating point
-notation or the multiple dotted notation, depending on whether
-the original version contained 1 or more dots, respectively.
-
-The SV returned has a refcount of 1.
-
-=cut
-*/
-
-SV *
-Perl_vstringify(pTHX_ SV *vs)
-{
-    PERL_ARGS_ASSERT_VSTRINGIFY;
-
-    /* extract the HV from the object */
-    vs = vverify(vs);
-    if ( ! vs )
-       Perl_croak(aTHX_ "Invalid version object");
-
-    if (hv_exists(MUTABLE_HV(vs), "original",  sizeof("original") - 1)) {
-       SV *pv;
-       pv = *hv_fetchs(MUTABLE_HV(vs), "original", FALSE);
-       if ( SvPOK(pv) )
-           return newSVsv(pv);
-       else
-           return &PL_sv_undef;
-    }
-    else {
-       if ( hv_exists(MUTABLE_HV(vs), "qv", 2) )
-           return vnormal(vs);
-       else
-           return vnumify(vs);
-    }
-}
-
-/*
-=for apidoc vcmp
-
-Version object aware cmp.  Both operands must already have been 
-converted into version objects.
-
-=cut
-*/
-
-int
-Perl_vcmp(pTHX_ SV *lhv, SV *rhv)
-{
-    SSize_t i,l,m,r;
-    I32 retval;
-    bool lalpha = FALSE;
-    bool ralpha = FALSE;
-    I32 left = 0;
-    I32 right = 0;
-    AV *lav, *rav;
-
-    PERL_ARGS_ASSERT_VCMP;
-
-    /* extract the HVs from the objects */
-    lhv = vverify(lhv);
-    rhv = vverify(rhv);
-    if ( ! ( lhv && rhv ) )
-       Perl_croak(aTHX_ "Invalid version object");
-
-    /* get the left hand term */
-    lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(lhv), "version", FALSE)));
-    if ( hv_exists(MUTABLE_HV(lhv), "alpha", 5 ) )
-       lalpha = TRUE;
-
-    /* and the right hand term */
-    rav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(rhv), "version", FALSE)));
-    if ( hv_exists(MUTABLE_HV(rhv), "alpha", 5 ) )
-       ralpha = TRUE;
-
-    l = av_len(lav);
-    r = av_len(rav);
-    m = l < r ? l : r;
-    retval = 0;
-    i = 0;
-    while ( i <= m && retval == 0 )
-    {
-       left  = SvIV(*av_fetch(lav,i,0));
-       right = SvIV(*av_fetch(rav,i,0));
-       if ( left < right  )
-           retval = -1;
-       if ( left > right )
-           retval = +1;
-       i++;
-    }
-
-    /* tiebreaker for alpha with identical terms */
-    if ( retval == 0 && l == r && left == right && ( lalpha || ralpha ) )
-    {
-       if ( lalpha && !ralpha )
-       {
-           retval = -1;
-       }
-       else if ( ralpha && !lalpha)
-       {
-           retval = +1;
-       }
-    }
-
-    if ( l != r && retval == 0 ) /* possible match except for trailing 0's */
-    {
-       if ( l < r )
-       {
-           while ( i <= r && retval == 0 )
-           {
-               if ( SvIV(*av_fetch(rav,i,0)) != 0 )
-                   retval = -1; /* not a match after all */
-               i++;
-           }
-       }
-       else
-       {
-           while ( i <= l && retval == 0 )
-           {
-               if ( SvIV(*av_fetch(lav,i,0)) != 0 )
-                   retval = +1; /* not a match after all */
-               i++;
-           }
-       }
-    }
-    return retval;
-}
+#include "vutil.c"
 
 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET) && defined(SOCK_DGRAM) && defined(HAS_SELECT)
 #   define EMULATE_SOCKETPAIR_UDP
diff --git a/vutil.c b/vutil.c
new file mode 100644 (file)
index 0000000..b1ff941
--- /dev/null
+++ b/vutil.c
@@ -0,0 +1,942 @@
+/* This file is part of the "version" CPAN distribution.  Please avoid
+   editing it in the perl core. */
+
+#define VERSION_MAX 0x7FFFFFFF
+
+/*
+=for apidoc prescan_version
+
+Validate that a given string can be parsed as a version object, but doesn't
+actually perform the parsing.  Can use either strict or lax validation rules.
+Can optionally set a number of hint variables to save the parsing code
+some time when tokenizing.
+
+=cut
+*/
+const char *
+Perl_prescan_version(pTHX_ const char *s, bool strict,
+                    const char **errstr,
+                    bool *sqv, int *ssaw_decimal, int *swidth, bool *salpha) {
+    bool qv = (sqv ? *sqv : FALSE);
+    int width = 3;
+    int saw_decimal = 0;
+    bool alpha = FALSE;
+    const char *d = s;
+
+    PERL_ARGS_ASSERT_PRESCAN_VERSION;
+
+    if (qv && isDIGIT(*d))
+       goto dotted_decimal_version;
+
+    if (*d == 'v') { /* explicit v-string */
+       d++;
+       if (isDIGIT(*d)) {
+           qv = TRUE;
+       }
+       else { /* degenerate v-string */
+           /* requires v1.2.3 */
+           BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
+       }
+
+dotted_decimal_version:
+       if (strict && d[0] == '0' && isDIGIT(d[1])) {
+           /* no leading zeros allowed */
+           BADVERSION(s,errstr,"Invalid version format (no leading zeros)");
+       }
+
+       while (isDIGIT(*d))     /* integer part */
+           d++;
+
+       if (*d == '.')
+       {
+           saw_decimal++;
+           d++;                /* decimal point */
+       }
+       else
+       {
+           if (strict) {
+               /* require v1.2.3 */
+               BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
+           }
+           else {
+               goto version_prescan_finish;
+           }
+       }
+
+       {
+           int i = 0;
+           int j = 0;
+           while (isDIGIT(*d)) {       /* just keep reading */
+               i++;
+               while (isDIGIT(*d)) {
+                   d++; j++;
+                   /* maximum 3 digits between decimal */
+                   if (strict && j > 3) {
+                       BADVERSION(s,errstr,"Invalid version format (maximum 3 digits between decimals)");
+                   }
+               }
+               if (*d == '_') {
+                   if (strict) {
+                       BADVERSION(s,errstr,"Invalid version format (no underscores)");
+                   }
+                   if ( alpha ) {
+                       BADVERSION(s,errstr,"Invalid version format (multiple underscores)");
+                   }
+                   d++;
+                   alpha = TRUE;
+               }
+               else if (*d == '.') {
+                   if (alpha) {
+                       BADVERSION(s,errstr,"Invalid version format (underscores before decimal)");
+                   }
+                   saw_decimal++;
+                   d++;
+               }
+               else if (!isDIGIT(*d)) {
+                   break;
+               }
+               j = 0;
+           }
+
+           if (strict && i < 2) {
+               /* requires v1.2.3 */
+               BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
+           }
+       }
+    }                                  /* end if dotted-decimal */
+    else
+    {                                  /* decimal versions */
+       int j = 0;                      /* may need this later */
+       /* special strict case for leading '.' or '0' */
+       if (strict) {
+           if (*d == '.') {
+               BADVERSION(s,errstr,"Invalid version format (0 before decimal required)");
+           }
+           if (*d == '0' && isDIGIT(d[1])) {
+               BADVERSION(s,errstr,"Invalid version format (no leading zeros)");
+           }
+       }
+
+       /* and we never support negative versions */
+       if ( *d == '-') {
+           BADVERSION(s,errstr,"Invalid version format (negative version number)");
+       }
+
+       /* consume all of the integer part */
+       while (isDIGIT(*d))
+           d++;
+
+       /* look for a fractional part */
+       if (*d == '.') {
+           /* we found it, so consume it */
+           saw_decimal++;
+           d++;
+       }
+       else if (!*d || *d == ';' || isSPACE(*d) || *d == '{' || *d == '}') {
+           if ( d == s ) {
+               /* found nothing */
+               BADVERSION(s,errstr,"Invalid version format (version required)");
+           }
+           /* found just an integer */
+           goto version_prescan_finish;
+       }
+       else if ( d == s ) {
+           /* didn't find either integer or period */
+           BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
+       }
+       else if (*d == '_') {
+           /* underscore can't come after integer part */
+           if (strict) {
+               BADVERSION(s,errstr,"Invalid version format (no underscores)");
+           }
+           else if (isDIGIT(d[1])) {
+               BADVERSION(s,errstr,"Invalid version format (alpha without decimal)");
+           }
+           else {
+               BADVERSION(s,errstr,"Invalid version format (misplaced underscore)");
+           }
+       }
+       else {
+           /* anything else after integer part is just invalid data */
+           BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
+       }
+
+       /* scan the fractional part after the decimal point*/
+
+       if (!isDIGIT(*d) && (strict || ! (!*d || *d == ';' || isSPACE(*d) || *d == '{' || *d == '}') )) {
+               /* strict or lax-but-not-the-end */
+               BADVERSION(s,errstr,"Invalid version format (fractional part required)");
+       }
+
+       while (isDIGIT(*d)) {
+           d++; j++;
+           if (*d == '.' && isDIGIT(d[-1])) {
+               if (alpha) {
+                   BADVERSION(s,errstr,"Invalid version format (underscores before decimal)");
+               }
+               if (strict) {
+                   BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions must begin with 'v')");
+               }
+               d = (char *)s;          /* start all over again */
+               qv = TRUE;
+               goto dotted_decimal_version;
+           }
+           if (*d == '_') {
+               if (strict) {
+                   BADVERSION(s,errstr,"Invalid version format (no underscores)");
+               }
+               if ( alpha ) {
+                   BADVERSION(s,errstr,"Invalid version format (multiple underscores)");
+               }
+               if ( ! isDIGIT(d[1]) ) {
+                   BADVERSION(s,errstr,"Invalid version format (misplaced underscore)");
+               }
+               width = j;
+               d++;
+               alpha = TRUE;
+           }
+       }
+    }
+
+version_prescan_finish:
+    while (isSPACE(*d))
+       d++;
+
+    if (!isDIGIT(*d) && (! (!*d || *d == ';' || *d == '{' || *d == '}') )) {
+       /* trailing non-numeric data */
+       BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
+    }
+
+    if (sqv)
+       *sqv = qv;
+    if (swidth)
+       *swidth = width;
+    if (ssaw_decimal)
+       *ssaw_decimal = saw_decimal;
+    if (salpha)
+       *salpha = alpha;
+    return d;
+}
+
+/*
+=for apidoc scan_version
+
+Returns a pointer to the next character after the parsed
+version string, as well as upgrading the passed in SV to
+an RV.
+
+Function must be called with an already existing SV like
+
+    sv = newSV(0);
+    s = scan_version(s, SV *sv, bool qv);
+
+Performs some preprocessing to the string to ensure that
+it has the correct characteristics of a version.  Flags the
+object if it contains an underscore (which denotes this
+is an alpha version).  The boolean qv denotes that the version
+should be interpreted as if it had multiple decimals, even if
+it doesn't.
+
+=cut
+*/
+
+const char *
+Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
+{
+    const char *start = s;
+    const char *pos;
+    const char *last;
+    const char *errstr = NULL;
+    int saw_decimal = 0;
+    int width = 3;
+    bool alpha = FALSE;
+    bool vinf = FALSE;
+    AV * av;
+    SV * hv;
+
+    PERL_ARGS_ASSERT_SCAN_VERSION;
+
+    while (isSPACE(*s)) /* leading whitespace is OK */
+       s++;
+
+    last = prescan_version(s, FALSE, &errstr, &qv, &saw_decimal, &width, &alpha);
+    if (errstr) {
+       /* "undef" is a special case and not an error */
+       if ( ! ( *s == 'u' && strEQ(s,"undef")) ) {
+           Safefree(start);
+           Perl_croak(aTHX_ "%s", errstr);
+       }
+    }
+
+    start = s;
+    if (*s == 'v')
+       s++;
+    pos = s;
+
+    /* Now that we are through the prescan, start creating the object */
+    av = newAV();
+    hv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */
+    (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
+
+#ifndef NODEFAULT_SHAREKEYS
+    HvSHAREKEYS_on(hv);         /* key-sharing on by default */
+#endif
+
+    if ( qv )
+       (void)hv_stores(MUTABLE_HV(hv), "qv", newSViv(qv));
+    if ( alpha )
+       (void)hv_stores(MUTABLE_HV(hv), "alpha", newSViv(alpha));
+    if ( !qv && width < 3 )
+       (void)hv_stores(MUTABLE_HV(hv), "width", newSViv(width));
+
+    while (isDIGIT(*pos))
+       pos++;
+    if (!isALPHA(*pos)) {
+       I32 rev;
+
+       for (;;) {
+           rev = 0;
+           {
+               /* this is atoi() that delimits on underscores */
+               const char *end = pos;
+               I32 mult = 1;
+               I32 orev;
+
+               /* the following if() will only be true after the decimal
+                * point of a version originally created with a bare
+                * floating point number, i.e. not quoted in any way
+                */
+               if ( !qv && s > start && saw_decimal == 1 ) {
+                   mult *= 100;
+                   while ( s < end ) {
+                       orev = rev;
+                       rev += (*s - '0') * mult;
+                       mult /= 10;
+                       if (   (PERL_ABS(orev) > PERL_ABS(rev)) 
+                           || (PERL_ABS(rev) > VERSION_MAX )) {
+                           Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW), 
+                                          "Integer overflow in version %d",VERSION_MAX);
+                           s = end - 1;
+                           rev = VERSION_MAX;
+                           vinf = 1;
+                       }
+                       s++;
+                       if ( *s == '_' )
+                           s++;
+                   }
+               }
+               else {
+                   while (--end >= s) {
+                       orev = rev;
+                       rev += (*end - '0') * mult;
+                       mult *= 10;
+                       if (   (PERL_ABS(orev) > PERL_ABS(rev)) 
+                           || (PERL_ABS(rev) > VERSION_MAX )) {
+                           Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW), 
+                                          "Integer overflow in version");
+                           end = s - 1;
+                           rev = VERSION_MAX;
+                           vinf = 1;
+                       }
+                   }
+               } 
+           }
+
+           /* Append revision */
+           av_push(av, newSViv(rev));
+           if ( vinf ) {
+               s = last;
+               break;
+           }
+           else if ( *pos == '.' )
+               s = ++pos;
+           else if ( *pos == '_' && isDIGIT(pos[1]) )
+               s = ++pos;
+           else if ( *pos == ',' && isDIGIT(pos[1]) )
+               s = ++pos;
+           else if ( isDIGIT(*pos) )
+               s = pos;
+           else {
+               s = pos;
+               break;
+           }
+           if ( qv ) {
+               while ( isDIGIT(*pos) )
+                   pos++;
+           }
+           else {
+               int digits = 0;
+               while ( ( isDIGIT(*pos) || *pos == '_' ) && digits < 3 ) {
+                   if ( *pos != '_' )
+                       digits++;
+                   pos++;
+               }
+           }
+       }
+    }
+    if ( qv ) { /* quoted versions always get at least three terms*/
+       SSize_t len = av_len(av);
+       /* This for loop appears to trigger a compiler bug on OS X, as it
+          loops infinitely. Yes, len is negative. No, it makes no sense.
+          Compiler in question is:
+          gcc version 3.3 20030304 (Apple Computer, Inc. build 1640)
+          for ( len = 2 - len; len > 0; len-- )
+          av_push(MUTABLE_AV(sv), newSViv(0));
+       */
+       len = 2 - len;
+       while (len-- > 0)
+           av_push(av, newSViv(0));
+    }
+
+    /* need to save off the current version string for later */
+    if ( vinf ) {
+       SV * orig = newSVpvn("v.Inf", sizeof("v.Inf")-1);
+       (void)hv_stores(MUTABLE_HV(hv), "original", orig);
+       (void)hv_stores(MUTABLE_HV(hv), "vinf", newSViv(1));
+    }
+    else if ( s > start ) {
+       SV * orig = newSVpvn(start,s-start);
+       if ( qv && saw_decimal == 1 && *start != 'v' ) {
+           /* need to insert a v to be consistent */
+           sv_insert(orig, 0, 0, "v", 1);
+       }
+       (void)hv_stores(MUTABLE_HV(hv), "original", orig);
+    }
+    else {
+       (void)hv_stores(MUTABLE_HV(hv), "original", newSVpvs("0"));
+       av_push(av, newSViv(0));
+    }
+
+    /* And finally, store the AV in the hash */
+    (void)hv_stores(MUTABLE_HV(hv), "version", newRV_noinc(MUTABLE_SV(av)));
+
+    /* fix RT#19517 - special case 'undef' as string */
+    if ( *s == 'u' && strEQ(s,"undef") ) {
+       s += 5;
+    }
+
+    return s;
+}
+
+/*
+=for apidoc new_version
+
+Returns a new version object based on the passed in SV:
+
+    SV *sv = new_version(SV *ver);
+
+Does not alter the passed in ver SV.  See "upg_version" if you
+want to upgrade the SV.
+
+=cut
+*/
+
+SV *
+Perl_new_version(pTHX_ SV *ver)
+{
+    dVAR;
+    SV * const rv = newSV(0);
+    PERL_ARGS_ASSERT_NEW_VERSION;
+    if ( sv_isobject(ver) && sv_derived_from(ver, "version") )
+        /* can just copy directly */
+    {
+       SSize_t key;
+       AV * const av = newAV();
+       AV *sav;
+       /* This will get reblessed later if a derived class*/
+       SV * const hv = newSVrv(rv, "version"); 
+       (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
+#ifndef NODEFAULT_SHAREKEYS
+       HvSHAREKEYS_on(hv);         /* key-sharing on by default */
+#endif
+
+       if ( SvROK(ver) )
+           ver = SvRV(ver);
+
+       /* Begin copying all of the elements */
+       if ( hv_exists(MUTABLE_HV(ver), "qv", 2) )
+           (void)hv_stores(MUTABLE_HV(hv), "qv", newSViv(1));
+
+       if ( hv_exists(MUTABLE_HV(ver), "alpha", 5) )
+           (void)hv_stores(MUTABLE_HV(hv), "alpha", newSViv(1));
+
+       if ( hv_exists(MUTABLE_HV(ver), "width", 5 ) )
+       {
+           const I32 width = SvIV(*hv_fetchs(MUTABLE_HV(ver), "width", FALSE));
+           (void)hv_stores(MUTABLE_HV(hv), "width", newSViv(width));
+       }
+
+       if ( hv_exists(MUTABLE_HV(ver), "original", 8 ) )
+       {
+           SV * pv = *hv_fetchs(MUTABLE_HV(ver), "original", FALSE);
+           (void)hv_stores(MUTABLE_HV(hv), "original", newSVsv(pv));
+       }
+
+       sav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(ver), "version", FALSE)));
+       /* This will get reblessed later if a derived class*/
+       for ( key = 0; key <= av_len(sav); key++ )
+       {
+           const I32 rev = SvIV(*av_fetch(sav, key, FALSE));
+           av_push(av, newSViv(rev));
+       }
+
+       (void)hv_stores(MUTABLE_HV(hv), "version", newRV_noinc(MUTABLE_SV(av)));
+       return rv;
+    }
+#ifdef SvVOK
+    {
+       const MAGIC* const mg = SvVSTRING_mg(ver);
+       if ( mg ) { /* already a v-string */
+           const STRLEN len = mg->mg_len;
+           char * const version = savepvn( (const char*)mg->mg_ptr, len);
+           sv_setpvn(rv,version,len);
+           /* this is for consistency with the pure Perl class */
+           if ( isDIGIT(*version) )
+               sv_insert(rv, 0, 0, "v", 1);
+           Safefree(version);
+       }
+       else {
+#endif
+       sv_setsv(rv,ver); /* make a duplicate */
+#ifdef SvVOK
+       }
+    }
+#endif
+    return upg_version(rv, FALSE);
+}
+
+/*
+=for apidoc upg_version
+
+In-place upgrade of the supplied SV to a version object.
+
+    SV *sv = upg_version(SV *sv, bool qv);
+
+Returns a pointer to the upgraded SV.  Set the boolean qv if you want
+to force this SV to be interpreted as an "extended" version.
+
+=cut
+*/
+
+SV *
+Perl_upg_version(pTHX_ SV *ver, bool qv)
+{
+    const char *version, *s;
+#ifdef SvVOK
+    const MAGIC *mg;
+#endif
+
+    PERL_ARGS_ASSERT_UPG_VERSION;
+
+    if ( SvNOK(ver) && !( SvPOK(ver) && sv_len(ver) == 3 ) )
+    {
+       STRLEN len;
+
+       /* may get too much accuracy */ 
+       char tbuf[64];
+       SV *sv = SvNVX(ver) > 10e50 ? newSV(64) : 0;
+       char *buf;
+#ifdef USE_LOCALE_NUMERIC
+       char *loc = NULL;
+       if (! PL_numeric_standard) {
+           loc = savepv(setlocale(LC_NUMERIC, NULL));
+           setlocale(LC_NUMERIC, "C");
+       }
+#endif
+       if (sv) {
+           Perl_sv_setpvf(aTHX_ sv, "%.9"NVff, SvNVX(ver));
+           buf = SvPV(sv, len);
+       }
+       else {
+           len = my_snprintf(tbuf, sizeof(tbuf), "%.9"NVff, SvNVX(ver));
+           buf = tbuf;
+       }
+#ifdef USE_LOCALE_NUMERIC
+       if (loc) {
+           setlocale(LC_NUMERIC, loc);
+           Safefree(loc);
+       }
+#endif
+       while (buf[len-1] == '0' && len > 0) len--;
+       if ( buf[len-1] == '.' ) len--; /* eat the trailing decimal */
+       version = savepvn(buf, len);
+       SvREFCNT_dec(sv);
+    }
+#ifdef SvVOK
+    else if ( (mg = SvVSTRING_mg(ver)) ) { /* already a v-string */
+       version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
+       qv = TRUE;
+    }
+#endif
+    else /* must be a string or something like a string */
+    {
+       STRLEN len;
+       version = savepv(SvPV(ver,len));
+#ifndef SvVOK
+#  if PERL_VERSION > 5
+       /* This will only be executed for 5.6.0 - 5.8.0 inclusive */
+       if ( len >= 3 && !instr(version,".") && !instr(version,"_")) {
+           /* may be a v-string */
+           char *testv = (char *)version;
+           STRLEN tlen = len;
+           for (tlen=0; tlen < len; tlen++, testv++) {
+               /* if one of the characters is non-text assume v-string */
+               if (testv[0] < ' ') {
+                   SV * const nsv = sv_newmortal();
+                   const char *nver;
+                   const char *pos;
+                   int saw_decimal = 0;
+                   sv_setpvf(nsv,"v%vd",ver);
+                   pos = nver = savepv(SvPV_nolen(nsv));
+
+                   /* scan the resulting formatted string */
+                   pos++; /* skip the leading 'v' */
+                   while ( *pos == '.' || isDIGIT(*pos) ) {
+                       if ( *pos == '.' )
+                           saw_decimal++ ;
+                       pos++;
+                   }
+
+                   /* is definitely a v-string */
+                   if ( saw_decimal >= 2 ) {
+                       Safefree(version);
+                       version = nver;
+                   }
+                   break;
+               }
+           }
+       }
+#  endif
+#endif
+    }
+
+    s = scan_version(version, ver, qv);
+    if ( *s != '\0' ) 
+       Perl_ck_warner(aTHX_ packWARN(WARN_MISC), 
+                      "Version string '%s' contains invalid data; "
+                      "ignoring: '%s'", version, s);
+    Safefree(version);
+    return ver;
+}
+
+/*
+=for apidoc vverify
+
+Validates that the SV contains valid internal structure for a version object.
+It may be passed either the version object (RV) or the hash itself (HV).  If
+the structure is valid, it returns the HV.  If the structure is invalid,
+it returns NULL.
+
+    SV *hv = vverify(sv);
+
+Note that it only confirms the bare minimum structure (so as not to get
+confused by derived classes which may contain additional hash entries):
+
+=over 4
+
+=item * The SV is an HV or a reference to an HV
+
+=item * The hash contains a "version" key
+
+=item * The "version" key has a reference to an AV as its value
+
+=back
+
+=cut
+*/
+
+SV *
+Perl_vverify(pTHX_ SV *vs)
+{
+    SV *sv;
+
+    PERL_ARGS_ASSERT_VVERIFY;
+
+    if ( SvROK(vs) )
+       vs = SvRV(vs);
+
+    /* see if the appropriate elements exist */
+    if ( SvTYPE(vs) == SVt_PVHV
+        && hv_exists(MUTABLE_HV(vs), "version", 7)
+        && (sv = SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE)))
+        && SvTYPE(sv) == SVt_PVAV )
+       return vs;
+    else
+       return NULL;
+}
+
+/*
+=for apidoc vnumify
+
+Accepts a version object and returns the normalized floating
+point representation.  Call like:
+
+    sv = vnumify(rv);
+
+NOTE: you can pass either the object directly or the SV
+contained within the RV.
+
+The SV returned has a refcount of 1.
+
+=cut
+*/
+
+SV *
+Perl_vnumify(pTHX_ SV *vs)
+{
+    SSize_t i, len;
+    I32 digit;
+    int width;
+    bool alpha = FALSE;
+    SV *sv;
+    AV *av;
+
+    PERL_ARGS_ASSERT_VNUMIFY;
+
+    /* extract the HV from the object */
+    vs = vverify(vs);
+    if ( ! vs )
+       Perl_croak(aTHX_ "Invalid version object");
+
+    /* see if various flags exist */
+    if ( hv_exists(MUTABLE_HV(vs), "alpha", 5 ) )
+       alpha = TRUE;
+    if ( hv_exists(MUTABLE_HV(vs), "width", 5 ) )
+       width = SvIV(*hv_fetchs(MUTABLE_HV(vs), "width", FALSE));
+    else
+       width = 3;
+
+
+    /* attempt to retrieve the version array */
+    if ( !(av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE))) ) ) {
+       return newSVpvs("0");
+    }
+
+    len = av_len(av);
+    if ( len == -1 )
+    {
+       return newSVpvs("0");
+    }
+
+    digit = SvIV(*av_fetch(av, 0, 0));
+    sv = Perl_newSVpvf(aTHX_ "%d.", (int)PERL_ABS(digit));
+    for ( i = 1 ; i < len ; i++ )
+    {
+       digit = SvIV(*av_fetch(av, i, 0));
+       if ( width < 3 ) {
+           const int denom = (width == 2 ? 10 : 100);
+           const div_t term = div((int)PERL_ABS(digit),denom);
+           Perl_sv_catpvf(aTHX_ sv, "%0*d_%d", width, term.quot, term.rem);
+       }
+       else {
+           Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit);
+       }
+    }
+
+    if ( len > 0 )
+    {
+       digit = SvIV(*av_fetch(av, len, 0));
+       if ( alpha && width == 3 ) /* alpha version */
+           sv_catpvs(sv,"_");
+       Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit);
+    }
+    else /* len == 0 */
+    {
+       sv_catpvs(sv, "000");
+    }
+    return sv;
+}
+
+/*
+=for apidoc vnormal
+
+Accepts a version object and returns the normalized string
+representation.  Call like:
+
+    sv = vnormal(rv);
+
+NOTE: you can pass either the object directly or the SV
+contained within the RV.
+
+The SV returned has a refcount of 1.
+
+=cut
+*/
+
+SV *
+Perl_vnormal(pTHX_ SV *vs)
+{
+    I32 i, len, digit;
+    bool alpha = FALSE;
+    SV *sv;
+    AV *av;
+
+    PERL_ARGS_ASSERT_VNORMAL;
+
+    /* extract the HV from the object */
+    vs = vverify(vs);
+    if ( ! vs )
+       Perl_croak(aTHX_ "Invalid version object");
+
+    if ( hv_exists(MUTABLE_HV(vs), "alpha", 5 ) )
+       alpha = TRUE;
+    av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE)));
+
+    len = av_len(av);
+    if ( len == -1 )
+    {
+       return newSVpvs("");
+    }
+    digit = SvIV(*av_fetch(av, 0, 0));
+    sv = Perl_newSVpvf(aTHX_ "v%"IVdf, (IV)digit);
+    for ( i = 1 ; i < len ; i++ ) {
+       digit = SvIV(*av_fetch(av, i, 0));
+       Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
+    }
+
+    if ( len > 0 )
+    {
+       /* handle last digit specially */
+       digit = SvIV(*av_fetch(av, len, 0));
+       if ( alpha )
+           Perl_sv_catpvf(aTHX_ sv, "_%"IVdf, (IV)digit);
+       else
+           Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
+    }
+
+    if ( len <= 2 ) { /* short version, must be at least three */
+       for ( len = 2 - len; len != 0; len-- )
+           sv_catpvs(sv,".0");
+    }
+    return sv;
+}
+
+/*
+=for apidoc vstringify
+
+In order to maintain maximum compatibility with earlier versions
+of Perl, this function will return either the floating point
+notation or the multiple dotted notation, depending on whether
+the original version contained 1 or more dots, respectively.
+
+The SV returned has a refcount of 1.
+
+=cut
+*/
+
+SV *
+Perl_vstringify(pTHX_ SV *vs)
+{
+    PERL_ARGS_ASSERT_VSTRINGIFY;
+
+    /* extract the HV from the object */
+    vs = vverify(vs);
+    if ( ! vs )
+       Perl_croak(aTHX_ "Invalid version object");
+
+    if (hv_exists(MUTABLE_HV(vs), "original",  sizeof("original") - 1)) {
+       SV *pv;
+       pv = *hv_fetchs(MUTABLE_HV(vs), "original", FALSE);
+       if ( SvPOK(pv) )
+           return newSVsv(pv);
+       else
+           return &PL_sv_undef;
+    }
+    else {
+       if ( hv_exists(MUTABLE_HV(vs), "qv", 2) )
+           return vnormal(vs);
+       else
+           return vnumify(vs);
+    }
+}
+
+/*
+=for apidoc vcmp
+
+Version object aware cmp.  Both operands must already have been 
+converted into version objects.
+
+=cut
+*/
+
+int
+Perl_vcmp(pTHX_ SV *lhv, SV *rhv)
+{
+    SSize_t i,l,m,r;
+    I32 retval;
+    bool lalpha = FALSE;
+    bool ralpha = FALSE;
+    I32 left = 0;
+    I32 right = 0;
+    AV *lav, *rav;
+
+    PERL_ARGS_ASSERT_VCMP;
+
+    /* extract the HVs from the objects */
+    lhv = vverify(lhv);
+    rhv = vverify(rhv);
+    if ( ! ( lhv && rhv ) )
+       Perl_croak(aTHX_ "Invalid version object");
+
+    /* get the left hand term */
+    lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(lhv), "version", FALSE)));
+    if ( hv_exists(MUTABLE_HV(lhv), "alpha", 5 ) )
+       lalpha = TRUE;
+
+    /* and the right hand term */
+    rav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(rhv), "version", FALSE)));
+    if ( hv_exists(MUTABLE_HV(rhv), "alpha", 5 ) )
+       ralpha = TRUE;
+
+    l = av_len(lav);
+    r = av_len(rav);
+    m = l < r ? l : r;
+    retval = 0;
+    i = 0;
+    while ( i <= m && retval == 0 )
+    {
+       left  = SvIV(*av_fetch(lav,i,0));
+       right = SvIV(*av_fetch(rav,i,0));
+       if ( left < right  )
+           retval = -1;
+       if ( left > right )
+           retval = +1;
+       i++;
+    }
+
+    /* tiebreaker for alpha with identical terms */
+    if ( retval == 0 && l == r && left == right && ( lalpha || ralpha ) )
+    {
+       if ( lalpha && !ralpha )
+       {
+           retval = -1;
+       }
+       else if ( ralpha && !lalpha)
+       {
+           retval = +1;
+       }
+    }
+
+    if ( l != r && retval == 0 ) /* possible match except for trailing 0's */
+    {
+       if ( l < r )
+       {
+           while ( i <= r && retval == 0 )
+           {
+               if ( SvIV(*av_fetch(rav,i,0)) != 0 )
+                   retval = -1; /* not a match after all */
+               i++;
+           }
+       }
+       else
+       {
+           while ( i <= l && retval == 0 )
+           {
+               if ( SvIV(*av_fetch(lav,i,0)) != 0 )
+                   retval = +1; /* not a match after all */
+               i++;
+           }
+       }
+    }
+    return retval;
+}
diff --git a/vxs.inc b/vxs.inc
new file mode 100644 (file)
index 0000000..697be74
--- /dev/null
+++ b/vxs.inc
@@ -0,0 +1,411 @@
+/* This file is part of the "version" CPAN distribution.  Please avoid
+   editing it in the perl core. */
+
+#ifdef VXS_XSUB_DETAILS
+    {"UNIVERSAL::VERSION", XS_UNIVERSAL_VERSION, NULL},
+    {"version::()", XS_version_noop, NULL},
+    {"version::new", XS_version_new, NULL},
+    {"version::parse", XS_version_new, NULL},
+    {"version::(\"\"", XS_version_stringify, NULL},
+    {"version::stringify", XS_version_stringify, NULL},
+    {"version::(0+", XS_version_numify, NULL},
+    {"version::numify", XS_version_numify, NULL},
+    {"version::normal", XS_version_normal, NULL},
+    {"version::(cmp", XS_version_vcmp, NULL},
+    {"version::(<=>", XS_version_vcmp, NULL},
+    {"version::vcmp", XS_version_vcmp, NULL},
+    {"version::(bool", XS_version_boolean, NULL},
+    {"version::boolean", XS_version_boolean, NULL},
+    {"version::(+", XS_version_noop, NULL},
+    {"version::(-", XS_version_noop, NULL},
+    {"version::(*", XS_version_noop, NULL},
+    {"version::(/", XS_version_noop, NULL},
+    {"version::(+=", XS_version_noop, NULL},
+    {"version::(-=", XS_version_noop, NULL},
+    {"version::(*=", XS_version_noop, NULL},
+    {"version::(/=", XS_version_noop, NULL},
+    {"version::(abs", XS_version_noop, NULL},
+    {"version::(nomethod", XS_version_noop, NULL},
+    {"version::noop", XS_version_noop, NULL},
+    {"version::is_alpha", XS_version_is_alpha, NULL},
+    {"version::qv", XS_version_qv, NULL},
+    {"version::declare", XS_version_qv, NULL},
+    {"version::is_qv", XS_version_is_qv, NULL},
+#else
+
+XS(XS_UNIVERSAL_VERSION)
+{
+    dVAR;
+    dXSARGS;
+    HV *pkg;
+    GV **gvp;
+    GV *gv;
+    SV *sv;
+    const char *undef;
+    PERL_UNUSED_ARG(cv);
+
+    if (SvROK(ST(0))) {
+        sv = MUTABLE_SV(SvRV(ST(0)));
+        if (!SvOBJECT(sv))
+            Perl_croak(aTHX_ "Cannot find version of an unblessed reference");
+        pkg = SvSTASH(sv);
+    }
+    else {
+        pkg = gv_stashsv(ST(0), 0);
+    }
+
+    gvp = pkg ? (GV**)hv_fetchs(pkg, "VERSION", FALSE) : NULL;
+
+    if (gvp && isGV(gv = *gvp) && (sv = GvSV(gv)) && SvOK(sv)) {
+        SV * const nsv = sv_newmortal();
+        sv_setsv(nsv, sv);
+        sv = nsv;
+       if ( !sv_isobject(sv) || !sv_derived_from(sv, "version"))
+           upg_version(sv, FALSE);
+
+        undef = NULL;
+    }
+    else {
+        sv = &PL_sv_undef;
+        undef = "(undef)";
+    }
+
+    if (items > 1) {
+       SV *req = ST(1);
+
+       if (undef) {
+           if (pkg) {
+               const HEK * const name = HvNAME_HEK(pkg);
+               Perl_croak(aTHX_
+                          "%"HEKf" does not define $%"HEKf
+                          "::VERSION--version check failed",
+                          HEKfARG(name), HEKfARG(name));
+           } else {
+               Perl_croak(aTHX_
+                            "%"SVf" defines neither package nor VERSION--version check failed",
+                            SVfARG(ST(0)) );
+           }
+       }
+
+       if ( !sv_isobject(req) || !sv_derived_from(req, "version")) {
+           /* req may very well be R/O, so create a new object */
+           req = sv_2mortal( new_version(req) );
+       }
+
+       if ( vcmp( req, sv ) > 0 ) {
+           if ( hv_exists(MUTABLE_HV(SvRV(req)), "qv", 2 ) ) {
+               Perl_croak(aTHX_ "%"HEKf" version %"SVf" required--"
+                      "this is only version %"SVf"",
+                       HEKfARG(HvNAME_HEK(pkg)),
+                      SVfARG(sv_2mortal(vnormal(req))),
+                      SVfARG(sv_2mortal(vnormal(sv))));
+           } else {
+               Perl_croak(aTHX_ "%"HEKf" version %"SVf" required--"
+                      "this is only version %"SVf,
+                       HEKfARG(HvNAME_HEK(pkg)),
+                      SVfARG(sv_2mortal(vstringify(req))),
+                      SVfARG(sv_2mortal(vstringify(sv))));
+           }
+       }
+    }
+
+    if ( SvOK(sv) && sv_derived_from(sv, "version") ) {
+       ST(0) = sv_2mortal(vstringify(sv));
+    } else {
+       ST(0) = sv;
+    }
+
+    XSRETURN(1);
+}
+
+XS(XS_version_new)
+{
+    dVAR;
+    dXSARGS;
+    if (items > 3 || items < 1)
+       croak_xs_usage(cv, "class, version");
+    SP -= items;
+    {
+        SV *vs = ST(1);
+       SV *rv;
+        STRLEN len;
+        const char *classname;
+        U32 flags;
+
+       /* Just in case this is something like a tied hash */
+       SvGETMAGIC(vs);
+
+        if ( sv_isobject(ST(0)) ) { /* get the class if called as an object method */
+            const HV * stash = SvSTASH(SvRV(ST(0)));
+            classname = HvNAME(stash);
+            len       = HvNAMELEN(stash);
+            flags     = HvNAMEUTF8(stash) ? SVf_UTF8 : 0;
+        }
+        else {
+           classname = SvPV(ST(0), len);
+            flags     = SvUTF8(ST(0));
+        }
+
+       if ( items == 1 || ! SvOK(vs) ) { /* no param or explicit undef */
+           /* create empty object */
+           vs = sv_newmortal();
+           sv_setpvs(vs, "0");
+       }
+       else if ( items == 3 ) {
+           vs = sv_newmortal();
+           Perl_sv_setpvf(aTHX_ vs,"v%s",SvPV_nolen_const(ST(2)));
+       }
+
+       rv = new_version(vs);
+       if ( strnNE(classname,"version", len) ) /* inherited new() */
+           sv_bless(rv, gv_stashpvn(classname, len, GV_ADD | flags));
+
+       mPUSHs(rv);
+       PUTBACK;
+       return;
+    }
+}
+
+XS(XS_version_stringify)
+{
+     dVAR;
+     dXSARGS;
+     if (items < 1)
+        croak_xs_usage(cv, "lobj, ...");
+     SP -= items;
+     {
+         SV *  lobj = ST(0);
+
+         if (sv_isobject(lobj) && sv_derived_from(lobj, "version")) {
+              lobj = SvRV(lobj);
+         }
+         else
+              Perl_croak(aTHX_ "lobj is not of type version");
+
+         mPUSHs(vstringify(lobj));
+
+         PUTBACK;
+         return;
+     }
+}
+
+XS(XS_version_numify)
+{
+     dVAR;
+     dXSARGS;
+     if (items < 1)
+        croak_xs_usage(cv, "lobj, ...");
+     SP -= items;
+     {
+         SV *  lobj = ST(0);
+
+         if (sv_isobject(lobj) && sv_derived_from(lobj, "version")) {
+              lobj = SvRV(lobj);
+         }
+         else
+              Perl_croak(aTHX_ "lobj is not of type version");
+
+         mPUSHs(vnumify(lobj));
+
+         PUTBACK;
+         return;
+     }
+}
+
+XS(XS_version_normal)
+{
+     dVAR;
+     dXSARGS;
+     if (items < 1)
+        croak_xs_usage(cv, "lobj, ...");
+     SP -= items;
+     {
+         SV *  lobj = ST(0);
+
+         if (sv_isobject(lobj) && sv_derived_from(lobj, "version")) {
+              lobj = SvRV(lobj);
+         }
+         else
+              Perl_croak(aTHX_ "lobj is not of type version");
+
+         mPUSHs(vnormal(lobj));
+
+         PUTBACK;
+         return;
+     }
+}
+
+XS(XS_version_vcmp)
+{
+     dVAR;
+     dXSARGS;
+     if (items < 1)
+        croak_xs_usage(cv, "lobj, ...");
+     SP -= items;
+     {
+         SV *  lobj = ST(0);
+
+         if (sv_isobject(lobj) && sv_derived_from(lobj, "version")) {
+              lobj = SvRV(lobj);
+         }
+         else
+              Perl_croak(aTHX_ "lobj is not of type version");
+
+         {
+              SV       *rs;
+              SV       *rvs;
+              SV * robj = ST(1);
+              const IV  swap = (IV)SvIV(ST(2));
+
+              if ( !sv_isobject(robj) || !sv_derived_from(robj, "version") )
+              {
+                   robj = new_version(SvOK(robj) ? robj : newSVpvs_flags("0", SVs_TEMP));
+                   sv_2mortal(robj);
+              }
+              rvs = SvRV(robj);
+
+              if ( swap )
+              {
+                   rs = newSViv(vcmp(rvs,lobj));
+              }
+              else
+              {
+                   rs = newSViv(vcmp(lobj,rvs));
+              }
+
+              mPUSHs(rs);
+         }
+
+         PUTBACK;
+         return;
+     }
+}
+
+XS(XS_version_boolean)
+{
+    dVAR;
+    dXSARGS;
+    if (items < 1)
+       croak_xs_usage(cv, "lobj, ...");
+    SP -= items;
+    if (sv_isobject(ST(0)) && sv_derived_from(ST(0), "version")) {
+       SV * const lobj = SvRV(ST(0));
+       SV * const rs =
+           newSViv( vcmp(lobj,
+                         sv_2mortal(new_version(
+                                       sv_2mortal(newSVpvs("0"))
+                                   ))
+                        )
+                  );
+       mPUSHs(rs);
+       PUTBACK;
+       return;
+    }
+    else
+       Perl_croak(aTHX_ "lobj is not of type version");
+}
+
+XS(XS_version_noop)
+{
+    dVAR;
+    dXSARGS;
+    if (items < 1)
+       croak_xs_usage(cv, "lobj, ...");
+    if (sv_isobject(ST(0)) && sv_derived_from(ST(0), "version"))
+       Perl_croak(aTHX_ "operation not supported with version object");
+    else
+       Perl_croak(aTHX_ "lobj is not of type version");
+#ifndef HASATTRIBUTE_NORETURN
+    XSRETURN_EMPTY;
+#endif
+}
+
+XS(XS_version_is_alpha)
+{
+    dVAR;
+    dXSARGS;
+    if (items != 1)
+       croak_xs_usage(cv, "lobj");
+    SP -= items;
+    if (sv_isobject(ST(0)) && sv_derived_from(ST(0), "version")) {
+       SV * const lobj = ST(0);
+       if ( hv_exists(MUTABLE_HV(SvRV(lobj)), "alpha", 5 ) )
+           XSRETURN_YES;
+       else
+           XSRETURN_NO;
+       PUTBACK;
+       return;
+    }
+    else
+       Perl_croak(aTHX_ "lobj is not of type version");
+}
+
+XS(XS_version_qv)
+{
+    dVAR;
+    dXSARGS;
+    PERL_UNUSED_ARG(cv);
+    SP -= items;
+    {
+       SV * ver = ST(0);
+       SV * rv;
+        STRLEN len = 0;
+        const char * classname = "";
+        U32 flags = 0;
+        if ( items == 2 ) {
+           SvGETMAGIC(ST(1));
+           if (SvOK(ST(1))) {
+               ver = ST(1);
+           }
+           else {
+               Perl_croak(aTHX_ "Invalid version format (version required)");
+           }
+            if ( sv_isobject(ST(0)) ) { /* class called as an object method */
+                const HV * stash = SvSTASH(SvRV(ST(0)));
+                classname = HvNAME(stash);
+                len       = HvNAMELEN(stash);
+                flags     = HvNAMEUTF8(stash) ? SVf_UTF8 : 0;
+            }
+            else {
+              classname = SvPV(ST(0), len);
+                flags     = SvUTF8(ST(0));
+            }
+        }
+       if ( !SvVOK(ver) ) { /* not already a v-string */
+           rv = sv_newmortal();
+           sv_setsv(rv,ver); /* make a duplicate */
+           upg_version(rv, TRUE);
+       } else {
+           rv = sv_2mortal(new_version(ver));
+       }
+       if ( items == 2
+                && strnNE(classname,"version", len) ) { /* inherited new() */
+           sv_bless(rv, gv_stashpvn(classname, len, GV_ADD | flags));
+        }
+       PUSHs(rv);
+    }
+    PUTBACK;
+    return;
+}
+
+XS(XS_version_is_qv)
+{
+    dVAR;
+    dXSARGS;
+    if (items != 1)
+       croak_xs_usage(cv, "lobj");
+    SP -= items;
+    if (sv_isobject(ST(0)) && sv_derived_from(ST(0), "version")) {
+       SV * const lobj = ST(0);
+       if ( hv_exists(MUTABLE_HV(SvRV(lobj)), "qv", 2 ) )
+           XSRETURN_YES;
+       else
+           XSRETURN_NO;
+       PUTBACK;
+       return;
+    }
+    else
+       Perl_croak(aTHX_ "lobj is not of type version");
+}
+
+#endif