[perl5.git] / vxs.inc

/* This file is part of the "version" CPAN distribution.  Please avoid
   editing it in the perl core. */

#ifdef PERL_CORE
#  define VXS_CLASS "version"
#else
#  define VXS_CLASS "version::vxs"
#endif

#ifdef VXS_XSUB_DETAILS
#  ifdef PERL_CORE
    {"UNIVERSAL::VERSION", XS_UNIVERSAL_VERSION, NULL},
#  else
    {VXS_CLASS "::_VERSION", XS_UNIVERSAL_VERSION, NULL},
#  endif
    {VXS_CLASS "::()", XS_version_noop, NULL},
    {VXS_CLASS "::new", XS_version_new, NULL},
    {VXS_CLASS "::parse", XS_version_new, NULL},
    {VXS_CLASS "::(\"\"", XS_version_stringify, NULL},
    {VXS_CLASS "::stringify", XS_version_stringify, NULL},
    {VXS_CLASS "::(0+", XS_version_numify, NULL},
    {VXS_CLASS "::numify", XS_version_numify, NULL},
    {VXS_CLASS "::normal", XS_version_normal, NULL},
    {VXS_CLASS "::(cmp", XS_version_vcmp, NULL},
    {VXS_CLASS "::(<=>", XS_version_vcmp, NULL},
#  ifdef PERL_CORE
    {VXS_CLASS "::vcmp", XS_version_vcmp, NULL},
#  else
    {VXS_CLASS "::VCMP", XS_version_vcmp, NULL},
#  endif
    {VXS_CLASS "::(bool", XS_version_boolean, NULL},
    {VXS_CLASS "::boolean", XS_version_boolean, NULL},
    {VXS_CLASS "::(+", XS_version_noop, NULL},
    {VXS_CLASS "::(-", XS_version_noop, NULL},
    {VXS_CLASS "::(*", XS_version_noop, NULL},
    {VXS_CLASS "::(/", XS_version_noop, NULL},
    {VXS_CLASS "::(+=", XS_version_noop, NULL},
    {VXS_CLASS "::(-=", XS_version_noop, NULL},
    {VXS_CLASS "::(*=", XS_version_noop, NULL},
    {VXS_CLASS "::(/=", XS_version_noop, NULL},
    {VXS_CLASS "::(abs", XS_version_noop, NULL},
    {VXS_CLASS "::(nomethod", XS_version_noop, NULL},
    {VXS_CLASS "::noop", XS_version_noop, NULL},
    {VXS_CLASS "::is_alpha", XS_version_is_alpha, NULL},
    {VXS_CLASS "::qv", XS_version_qv, NULL},
    {VXS_CLASS "::declare", XS_version_qv, NULL},
    {VXS_CLASS "::is_qv", XS_version_is_qv, NULL},
#else

#ifndef dVAR
#  define dVAR
#endif

#ifdef HvNAME_HEK
typedef HEK HVNAME;
#  ifndef HEKf
#    define HEKfARG(arg)	((void*)(sv_2mortal(newSVhek(arg))))
#    define HEKf		SVf
#  endif
#else
typedef char HVNAME;
#  define HvNAME_HEK	HvNAME_get
#  define HEKfARG(arg)	arg
#  define HEKf		"s"
#endif

XS(XS_UNIVERSAL_VERSION)
{
    dVAR;
    dXSARGS;
    HV *pkg;
    GV **gvp;
    GV *gv;
    SV *ret;
    SV *sv;
    const char *undef;
    PERL_UNUSED_ARG(cv);

    if (items < 1)
       Perl_croak(aTHX_ "Usage: UNIVERSAL::VERSION(sv, ...)");

    sv = ST(0);

    if (SvROK(sv)) {
        sv = (SV*)SvRV(sv);
        if (!SvOBJECT(sv))
            Perl_croak(aTHX_ "Cannot find version of an unblessed reference");
        pkg = SvSTASH(sv);
    }
    else {
        pkg = gv_stashsv(sv, FALSE);
    }

    gvp = pkg ? (GV**)hv_fetchs(pkg,"VERSION",FALSE) : (GV**)NULL;

    if (gvp && isGV(gv = *gvp) && (sv = GvSV(gv)) && SvOK(sv)) {
        sv = sv_mortalcopy(sv);
	if ( ! ISA_CLASS_OBJ(sv, "version::vxs"))
	    UPG_VERSION(sv, FALSE);
        undef = NULL;
    }
    else {
        sv = ret = &PL_sv_undef;
        undef = "(undef)";
    }

    if (items > 1) {
	SV *req = ST(1);

	if (undef) {
	    if (pkg) {
		const HVNAME* const name = HvNAME_HEK(pkg);
#if PERL_VERSION == 5
		Perl_croak(aTHX_ "%s version %s required--this is only version ",
			    name, SvPVx_nolen_const(req));
#else
		Perl_croak(aTHX_
			   "%"HEKf" does not define $%"HEKf
			   "::VERSION--version check failed",
			   HEKfARG(name), HEKfARG(name));
#endif
	    }
	    else {
#if PERL_VERSION >= 8
		Perl_croak(aTHX_
			     "%"SVf" defines neither package nor VERSION--version check failed",
			     (void*)(ST(0)) );
#else
		Perl_croak(aTHX_ "%s does not define $%s::VERSION--version check failed",
			   SvPVx_nolen_const(ST(0)),
			   SvPVx_nolen_const(ST(0)) );
#endif
	    }
	}

	if ( ! ISA_CLASS_OBJ(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 ) ) {
		req = VNORMAL(req);
		sv  = VNORMAL(sv);
	    }
	    else {
		req = VSTRINGIFY(req);
		sv  = VSTRINGIFY(sv);
	    }
	    Perl_croak(aTHX_ "%"HEKf" version %"SVf" required--"
		"this is only version %"SVf"", HEKfARG(HvNAME_HEK(pkg)),
		SVfARG(sv_2mortal(req)),
		SVfARG(sv_2mortal(sv)));
	}
    }
    ST(0) = ret;

    /* if the package's $VERSION is not undef, it is upgraded to be a version object */
    if (ISA_CLASS_OBJ(sv, "version")) {
	ST(0) = sv_2mortal(VSTRINGIFY(sv));
    } else {
	ST(0) = sv;
    }

    XSRETURN(1);
}

XS(XS_version_new)
{
    dVAR;
    dXSARGS;
    PERL_UNUSED_VAR(cv);
    SV *vs = items ? ST(1) : &PL_sv_undef;
    SV *rv;
    const char * classname = "";
    STRLEN len;
    U32 flags = 0;
    SP -= items;

    if (items > 3 || items == 0)
        Perl_croak(aTHX_ "Usage: version::new(class, version)");

    /* Just in case this is something like a tied hash */
    SvGETMAGIC(vs);

    if ( items == 1 || ! SvOK(vs) ) { /* no param or explicit undef */
        /* create empty object */
        vs = sv_newmortal();
        sv_setpvs(vs,"undef");
    }
    else if (items == 3 ) {
        vs = sv_newmortal();
#if PERL_VERSION == 5
        sv_setpvf(vs,"v%s",SvPV_nolen_const(ST(2)));
#else
        Perl_sv_setpvf(aTHX_ vs,"v%s",SvPV_nolen_const(ST(2)));
#endif
    }
    if ( sv_isobject(ST(0)) ) {
	/* get the class if called as an object method */
	const HV * stash = SvSTASH(SvRV(ST(0)));
	classname = HvNAME_get(stash);
	len	  = HvNAMELEN_get(stash);
#ifdef HvNAMEUTF8
	flags	  = HvNAMEUTF8(stash) ? SVf_UTF8 : 0;
#endif
    }
    else {
	classname = SvPV(ST(0), len);
	flags     = SvUTF8(ST(0));
    }

    rv = NEW_VERSION(vs);
    if ( len != sizeof(VXS_CLASS)-1
      || strcmp(classname,VXS_CLASS) != 0 ) /* inherited new() */
#if PERL_VERSION == 5
        sv_bless(rv, gv_stashpv((char *)classname, GV_ADD));
#else
        sv_bless(rv, gv_stashpvn(classname, len, GV_ADD | flags));
#endif

    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, "ver, ...");
     SP -= items;
     {
	  SV *	ver = ST(0);

	  if (sv_isobject(ver) && sv_derived_from(ver, "version")) {
	       ver = SvRV(ver);
	  }
	  else
	       Perl_croak(aTHX_ "ver is not of type version");

	  mPUSHs(vnormal(ver));

	  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 && (len != 7
               || 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
Commit	Line	Data
abc6d738 FC	1	/* This file is part of the "version" CPAN distribution. Please avoid
	2	editing it in the perl core. */
	3
b42aaea1 FC	4	#ifdef PERL_CORE
	5	# define VXS_CLASS "version"
	6	#else
	7	# define VXS_CLASS "version::vxs"
	8	#endif
	9
abc6d738	10	#ifdef VXS_XSUB_DETAILS
b42aaea1	11	# ifdef PERL_CORE
abc6d738	12	{"UNIVERSAL::VERSION", XS_UNIVERSAL_VERSION, NULL},
b42aaea1 FC	13	# else
	14	{VXS_CLASS "::_VERSION", XS_UNIVERSAL_VERSION, NULL},
	15	# endif
	16	{VXS_CLASS "::()", XS_version_noop, NULL},
	17	{VXS_CLASS "::new", XS_version_new, NULL},
	18	{VXS_CLASS "::parse", XS_version_new, NULL},
	19	{VXS_CLASS "::(\"\"", XS_version_stringify, NULL},
	20	{VXS_CLASS "::stringify", XS_version_stringify, NULL},
	21	{VXS_CLASS "::(0+", XS_version_numify, NULL},
	22	{VXS_CLASS "::numify", XS_version_numify, NULL},
	23	{VXS_CLASS "::normal", XS_version_normal, NULL},
	24	{VXS_CLASS "::(cmp", XS_version_vcmp, NULL},
	25	{VXS_CLASS "::(<=>", XS_version_vcmp, NULL},
	26	# ifdef PERL_CORE
	27	{VXS_CLASS "::vcmp", XS_version_vcmp, NULL},
	28	# else
	29	{VXS_CLASS "::VCMP", XS_version_vcmp, NULL},
	30	# endif
	31	{VXS_CLASS "::(bool", XS_version_boolean, NULL},
	32	{VXS_CLASS "::boolean", XS_version_boolean, NULL},
	33	{VXS_CLASS "::(+", XS_version_noop, NULL},
	34	{VXS_CLASS "::(-", XS_version_noop, NULL},
	35	{VXS_CLASS "::(*", XS_version_noop, NULL},
	36	{VXS_CLASS "::(/", XS_version_noop, NULL},
	37	{VXS_CLASS "::(+=", XS_version_noop, NULL},
	38	{VXS_CLASS "::(-=", XS_version_noop, NULL},
	39	{VXS_CLASS "::(*=", XS_version_noop, NULL},
	40	{VXS_CLASS "::(/=", XS_version_noop, NULL},
	41	{VXS_CLASS "::(abs", XS_version_noop, NULL},
	42	{VXS_CLASS "::(nomethod", XS_version_noop, NULL},
	43	{VXS_CLASS "::noop", XS_version_noop, NULL},
	44	{VXS_CLASS "::is_alpha", XS_version_is_alpha, NULL},
	45	{VXS_CLASS "::qv", XS_version_qv, NULL},
	46	{VXS_CLASS "::declare", XS_version_qv, NULL},
	47	{VXS_CLASS "::is_qv", XS_version_is_qv, NULL},
abc6d738 FC	48	#else
abc6d738 FC	49
04df8d4d FC	50	#ifndef dVAR
	51	# define dVAR
	52	#endif
	53
0c96c511 FC	54	#ifdef HvNAME_HEK
	55	typedef HEK HVNAME;
	56	# ifndef HEKf
	57	# define HEKfARG(arg) ((void*)(sv_2mortal(newSVhek(arg))))
	58	# define HEKf SVf
	59	# endif
	60	#else
	61	typedef char HVNAME;
	62	# define HvNAME_HEK HvNAME_get
	63	# define HEKfARG(arg) arg
	64	# define HEKf "s"
	65	#endif
	66
abc6d738 FC	67	XS(XS_UNIVERSAL_VERSION)
	68	{
	69	dVAR;
	70	dXSARGS;
	71	HV *pkg;
	72	GV **gvp;
	73	GV *gv;
0c96c511	74	SV *ret;
abc6d738 FC	75	SV *sv;
	76	const char *undef;
	77	PERL_UNUSED_ARG(cv);
	78
8372457d FC	79	if (items < 1)
	80	Perl_croak(aTHX_ "Usage: UNIVERSAL::VERSION(sv, ...)");
	81
0c96c511 FC	82	sv = ST(0);
	83
	84	if (SvROK(sv)) {
	85	sv = (SV*)SvRV(sv);
abc6d738 FC	86	if (!SvOBJECT(sv))
	87	Perl_croak(aTHX_ "Cannot find version of an unblessed reference");
	88	pkg = SvSTASH(sv);
	89	}
	90	else {
0c96c511	91	pkg = gv_stashsv(sv, FALSE);
abc6d738 FC	92	}
abc6d738 FC	93
0c96c511	94	gvp = pkg ? (GV)hv_fetchs(pkg,"VERSION",FALSE) : (GV)NULL;
abc6d738 FC	95
abc6d738 FC	96	if (gvp && isGV(gv = *gvp) && (sv = GvSV(gv)) && SvOK(sv)) {
0c96c511 FC	97	sv = sv_mortalcopy(sv);
	98	if ( ! ISA_CLASS_OBJ(sv, "version::vxs"))
	99	UPG_VERSION(sv, FALSE);
abc6d738 FC	100	undef = NULL;
	101	}
	102	else {
0c96c511	103	sv = ret = &PL_sv_undef;
abc6d738 FC	104	undef = "(undef)";
	105	}
	106
	107	if (items > 1) {
	108	SV *req = ST(1);
	109
	110	if (undef) {
	111	if (pkg) {
0c96c511 FC	112	const HVNAME* const name = HvNAME_HEK(pkg);
	113	#if PERL_VERSION == 5
	114	Perl_croak(aTHX_ "%s version %s required--this is only version ",
	115	name, SvPVx_nolen_const(req));
	116	#else
abc6d738 FC	117	Perl_croak(aTHX_
	118	"%"HEKf" does not define $%"HEKf
	119	"::VERSION--version check failed",
	120	HEKfARG(name), HEKfARG(name));
0c96c511 FC	121	#endif
	122	}
	123	else {
	124	#if PERL_VERSION >= 8
abc6d738 FC	125	Perl_croak(aTHX_
abc6d738 FC	126	"%"SVf" defines neither package nor VERSION--version check failed",
0c96c511 FC	127	(void*)(ST(0)) );
	128	#else
	129	Perl_croak(aTHX_ "%s does not define $%s::VERSION--version check failed",
	130	SvPVx_nolen_const(ST(0)),
	131	SvPVx_nolen_const(ST(0)) );
	132	#endif
abc6d738 FC	133	}
	134	}
	135
0c96c511	136	if ( ! ISA_CLASS_OBJ(req, "version")) {
abc6d738	137	/* req may very well be R/O, so create a new object */
0c96c511	138	req = sv_2mortal( NEW_VERSION(req) );
abc6d738 FC	139	}
abc6d738 FC	140
0c96c511	141	if ( VCMP( req, sv ) > 0 ) {
abc6d738	142	if ( hv_exists(MUTABLE_HV(SvRV(req)), "qv", 2 ) ) {
0c96c511 FC	143	req = VNORMAL(req);
	144	sv = VNORMAL(sv);
	145	}
	146	else {
	147	req = VSTRINGIFY(req);
	148	sv = VSTRINGIFY(sv);
abc6d738	149	}
0c96c511 FC	150	Perl_croak(aTHX_ "%"HEKf" version %"SVf" required--"
	151	"this is only version %"SVf"", HEKfARG(HvNAME_HEK(pkg)),
	152	SVfARG(sv_2mortal(req)),
	153	SVfARG(sv_2mortal(sv)));
abc6d738 FC	154	}
abc6d738 FC	155	}
0c96c511	156	ST(0) = ret;
abc6d738	157
0c96c511 FC	158	/* if the package's $VERSION is not undef, it is upgraded to be a version object */
	159	if (ISA_CLASS_OBJ(sv, "version")) {
	160	ST(0) = sv_2mortal(VSTRINGIFY(sv));
abc6d738 FC	161	} else {
	162	ST(0) = sv;
	163	}
	164
	165	XSRETURN(1);
	166	}
	167
	168	XS(XS_version_new)
	169	{
	170	dVAR;
	171	dXSARGS;
e1c774b6 FC	172	PERL_UNUSED_VAR(cv);
	173	SV *vs = items ? ST(1) : &PL_sv_undef;
	174	SV *rv;
	175	const char * classname = "";
	176	STRLEN len;
	177	U32 flags = 0;
abc6d738	178	SP -= items;
abc6d738	179
e1c774b6 FC	180	if (items > 3 \|\| items == 0)
e1c774b6 FC	181	Perl_croak(aTHX_ "Usage: version::new(class, version)");
abc6d738	182
e1c774b6 FC	183	/* Just in case this is something like a tied hash */
	184	SvGETMAGIC(vs);
	185
	186	if ( items == 1 \|\| ! SvOK(vs) ) { /* no param or explicit undef */
	187	/* create empty object */
	188	vs = sv_newmortal();
	189	sv_setpvs(vs,"undef");
	190	}
	191	else if (items == 3 ) {
	192	vs = sv_newmortal();
	193	#if PERL_VERSION == 5
	194	sv_setpvf(vs,"v%s",SvPV_nolen_const(ST(2)));
	195	#else
	196	Perl_sv_setpvf(aTHX_ vs,"v%s",SvPV_nolen_const(ST(2)));
	197	#endif
	198	}
	199	if ( sv_isobject(ST(0)) ) {
	200	/* get the class if called as an object method */
	201	const HV * stash = SvSTASH(SvRV(ST(0)));
	202	classname = HvNAME_get(stash);
	203	len = HvNAMELEN_get(stash);
	204	#ifdef HvNAMEUTF8
	205	flags = HvNAMEUTF8(stash) ? SVf_UTF8 : 0;
	206	#endif
	207	}
	208	else {
	209	classname = SvPV(ST(0), len);
	210	flags = SvUTF8(ST(0));
abc6d738	211	}
e1c774b6 FC	212
	213	rv = NEW_VERSION(vs);
	214	if ( len != sizeof(VXS_CLASS)-1
	215	\|\| strcmp(classname,VXS_CLASS) != 0 ) /* inherited new() */
	216	#if PERL_VERSION == 5
	217	sv_bless(rv, gv_stashpv((char *)classname, GV_ADD));
	218	#else
	219	sv_bless(rv, gv_stashpvn(classname, len, GV_ADD \| flags));
	220	#endif
	221
	222	mPUSHs(rv);
	223	PUTBACK;
	224	return;
abc6d738 FC	225	}
	226
	227	XS(XS_version_stringify)
	228	{
	229	dVAR;
	230	dXSARGS;
	231	if (items < 1)
	232	croak_xs_usage(cv, "lobj, ...");
	233	SP -= items;
	234	{
	235	SV * lobj = ST(0);
	236
	237	if (sv_isobject(lobj) && sv_derived_from(lobj, "version")) {
	238	lobj = SvRV(lobj);
	239	}
	240	else
	241	Perl_croak(aTHX_ "lobj is not of type version");
	242
	243	mPUSHs(vstringify(lobj));
	244
	245	PUTBACK;
	246	return;
	247	}
	248	}
	249
	250	XS(XS_version_numify)
	251	{
	252	dVAR;
	253	dXSARGS;
	254	if (items < 1)
	255	croak_xs_usage(cv, "lobj, ...");
	256	SP -= items;
	257	{
	258	SV * lobj = ST(0);
	259
	260	if (sv_isobject(lobj) && sv_derived_from(lobj, "version")) {
	261	lobj = SvRV(lobj);
	262	}
	263	else
	264	Perl_croak(aTHX_ "lobj is not of type version");
	265
	266	mPUSHs(vnumify(lobj));
	267
	268	PUTBACK;
	269	return;
	270	}
	271	}
	272
	273	XS(XS_version_normal)
	274	{
	275	dVAR;
	276	dXSARGS;
b47c4431 FC	277	if (items != 1)
b47c4431 FC	278	croak_xs_usage(cv, "ver, ...");
abc6d738 FC	279	SP -= items;
abc6d738 FC	280	{
b47c4431	281	SV * ver = ST(0);
abc6d738	282
b47c4431 FC	283	if (sv_isobject(ver) && sv_derived_from(ver, "version")) {
b47c4431 FC	284	ver = SvRV(ver);
abc6d738 FC	285	}
abc6d738 FC	286	else
b47c4431	287	Perl_croak(aTHX_ "ver is not of type version");
abc6d738	288
b47c4431	289	mPUSHs(vnormal(ver));
abc6d738 FC	290
	291	PUTBACK;
	292	return;
	293	}
	294	}
	295
	296	XS(XS_version_vcmp)
	297	{
	298	dVAR;
	299	dXSARGS;
	300	if (items < 1)
	301	croak_xs_usage(cv, "lobj, ...");
	302	SP -= items;
	303	{
	304	SV * lobj = ST(0);
	305
	306	if (sv_isobject(lobj) && sv_derived_from(lobj, "version")) {
	307	lobj = SvRV(lobj);
	308	}
	309	else
	310	Perl_croak(aTHX_ "lobj is not of type version");
	311
	312	{
	313	SV *rs;
	314	SV *rvs;
	315	SV * robj = ST(1);
	316	const IV swap = (IV)SvIV(ST(2));
	317
	318	if ( !sv_isobject(robj) \|\| !sv_derived_from(robj, "version") )
	319	{
	320	robj = new_version(SvOK(robj) ? robj : newSVpvs_flags("0", SVs_TEMP));
	321	sv_2mortal(robj);
	322	}
	323	rvs = SvRV(robj);
	324
	325	if ( swap )
	326	{
	327	rs = newSViv(vcmp(rvs,lobj));
	328	}
	329	else
	330	{
	331	rs = newSViv(vcmp(lobj,rvs));
	332	}
	333
	334	mPUSHs(rs);
	335	}
	336
	337	PUTBACK;
	338	return;
	339	}
	340	}
	341
	342	XS(XS_version_boolean)
	343	{
	344	dVAR;
	345	dXSARGS;
	346	if (items < 1)
	347	croak_xs_usage(cv, "lobj, ...");
	348	SP -= items;
	349	if (sv_isobject(ST(0)) && sv_derived_from(ST(0), "version")) {
	350	SV * const lobj = SvRV(ST(0));
	351	SV * const rs =
	352	newSViv( vcmp(lobj,
	353	sv_2mortal(new_version(
354	sv_2mortal(newSVpvs("0"))
355	))
356	)
357	);
358	mPUSHs(rs);
359	PUTBACK;
360	return;
361	}
362	else
363	Perl_croak(aTHX_ "lobj is not of type version");
364	}
365
366	XS(XS_version_noop)
367	{
368	dVAR;
369	dXSARGS;
370	if (items < 1)
371	croak_xs_usage(cv, "lobj, ...");
372	if (sv_isobject(ST(0)) && sv_derived_from(ST(0), "version"))
373	Perl_croak(aTHX_ "operation not supported with version object");
374	else
375	Perl_croak(aTHX_ "lobj is not of type version");
376	#ifndef HASATTRIBUTE_NORETURN
377	XSRETURN_EMPTY;
378	#endif
379	}
380
381	XS(XS_version_is_alpha)
382	{
383	dVAR;
384	dXSARGS;
385	if (items != 1)
386	croak_xs_usage(cv, "lobj");
387	SP -= items;
388	if (sv_isobject(ST(0)) && sv_derived_from(ST(0), "version")) {
389	SV * const lobj = ST(0);
390	if ( hv_exists(MUTABLE_HV(SvRV(lobj)), "alpha", 5 ) )
391	XSRETURN_YES;
392	else
393	XSRETURN_NO;
394	PUTBACK;
395	return;
396	}
397	else
398	Perl_croak(aTHX_ "lobj is not of type version");
399	}
400
401	XS(XS_version_qv)
402	{
403	dVAR;
404	dXSARGS;
405	PERL_UNUSED_ARG(cv);
406	SP -= items;
407	{
408	SV * ver = ST(0);
409	SV * rv;
410	STRLEN len = 0;
411	const char * classname = "";
412	U32 flags = 0;
413	if ( items == 2 ) {
414	SvGETMAGIC(ST(1));
415	if (SvOK(ST(1))) {
416	ver = ST(1);
417	}
418	else {
419	Perl_croak(aTHX_ "Invalid version format (version required)");
420	}
421	if ( sv_isobject(ST(0)) ) { /* class called as an object method */
422	const HV * stash = SvSTASH(SvRV(ST(0)));
423	classname = HvNAME(stash);
424	len = HvNAMELEN(stash);
425	flags = HvNAMEUTF8(stash) ? SVf_UTF8 : 0;
426	}
427	else {
428	classname = SvPV(ST(0), len);
429	flags = SvUTF8(ST(0));
430	}
431	}
432	if ( !SvVOK(ver) ) { /* not already a v-string */
433	rv = sv_newmortal();
434	sv_setsv(rv,ver); /* make a duplicate */
435	upg_version(rv, TRUE);
436	} else {
437	rv = sv_2mortal(new_version(ver));
438	}
8a3edca7 FC	439	if ( items == 2 && (len != 7
8a3edca7 FC	440	\|\| strnNE(classname,"version", len)) ) { /* inherited new() */
abc6d738 FC	441	sv_bless(rv, gv_stashpvn(classname, len, GV_ADD \| flags));
	442	}
	443	PUSHs(rv);
	444	}
	445	PUTBACK;
	446	return;
	447	}
	448
	449	XS(XS_version_is_qv)
	450	{
	451	dVAR;
	452	dXSARGS;
	453	if (items != 1)
	454	croak_xs_usage(cv, "lobj");
	455	SP -= items;
	456	if (sv_isobject(ST(0)) && sv_derived_from(ST(0), "version")) {
	457	SV * const lobj = ST(0);
	458	if ( hv_exists(MUTABLE_HV(SvRV(lobj)), "qv", 2 ) )
	459	XSRETURN_YES;
	460	else
	461	XSRETURN_NO;
	462	PUTBACK;
	463	return;
	464	}
	465	else
	466	Perl_croak(aTHX_ "lobj is not of type version");
	467	}
	468
	469	#endif