Extract version routines into two new files

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.

1 files changed, 5 insertions, 405 deletions

diff --git a/universal.c b/universal.c
index 229b05dcfd..c5102e342b 100644
--- a/universal.c
+++ b/universal.c
@@ -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},