[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"
#  define VXSp(name) XS_##name
#else
#  define VXS_CLASS "version::vxs"
#  define VXSp(name) VXS_##name
#endif
#define VXS(name) XS(VXSp(name))

#ifdef VXS_XSUB_DETAILS
#  ifdef PERL_CORE
    {"UNIVERSAL::VERSION", XS_UNIVERSAL_VERSION, NULL},
#  else
    {VXS_CLASS "::_VERSION", VXS_UNIVERSAL_VERSION, NULL},
#  endif
    {VXS_CLASS "::()", VXSp(version_noop), NULL},
    {VXS_CLASS "::new", VXSp(version_new), NULL},
    {VXS_CLASS "::parse", VXSp(version_new), NULL},
    {VXS_CLASS "::(\"\"", VXSp(version_stringify), NULL},
    {VXS_CLASS "::stringify", VXSp(version_stringify), NULL},
    {VXS_CLASS "::(0+", VXSp(version_numify), NULL},
    {VXS_CLASS "::numify", VXSp(version_numify), NULL},
    {VXS_CLASS "::normal", VXSp(version_normal), NULL},
    {VXS_CLASS "::(cmp", VXSp(version_vcmp), NULL},
    {VXS_CLASS "::(<=>", VXSp(version_vcmp), NULL},
#  ifdef PERL_CORE
    {VXS_CLASS "::vcmp", XS_version_vcmp, NULL},
#  else
    {VXS_CLASS "::VCMP", VXS_version_vcmp, NULL},
#  endif
    {VXS_CLASS "::(bool", VXSp(version_boolean), NULL},
    {VXS_CLASS "::boolean", VXSp(version_boolean), NULL},
    {VXS_CLASS "::(+", VXSp(version_noop), NULL},
    {VXS_CLASS "::(-", VXSp(version_noop), NULL},
    {VXS_CLASS "::(*", VXSp(version_noop), NULL},
    {VXS_CLASS "::(/", VXSp(version_noop), NULL},
    {VXS_CLASS "::(+=", VXSp(version_noop), NULL},
    {VXS_CLASS "::(-=", VXSp(version_noop), NULL},
    {VXS_CLASS "::(*=", VXSp(version_noop), NULL},
    {VXS_CLASS "::(/=", VXSp(version_noop), NULL},
    {VXS_CLASS "::(abs", VXSp(version_noop), NULL},
    {VXS_CLASS "::(nomethod", VXSp(version_noop), NULL},
    {VXS_CLASS "::noop", VXSp(version_noop), NULL},
    {VXS_CLASS "::is_alpha", VXSp(version_is_alpha), NULL},
    {VXS_CLASS "::qv", VXSp(version_qv), NULL},
    {VXS_CLASS "::declare", VXSp(version_qv), NULL},
    {VXS_CLASS "::is_qv", VXSp(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

VXS(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"))
	    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);
}

VXS(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;
}

#define VTYPECHECK(var, val, varname) \
    STMT_START {							\
	if (ISA_CLASS_OBJ(val, "version")) {				\
	    (var) = SvRV(val);						\
	}								\
	else								\
	    Perl_croak(aTHX_ varname " is not of type version");	\
    } STMT_END

VXS(version_stringify)
{
     dVAR;
     dXSARGS;
     if (items < 1)
	 croak_xs_usage(cv, "lobj, ...");
     SP -= items;
     {
	  SV *	lobj;
	  VTYPECHECK(lobj, ST(0), "lobj");

	  mPUSHs(VSTRINGIFY(lobj));

	  PUTBACK;
	  return;
     }
}

VXS(version_numify)
{
     dVAR;
     dXSARGS;
     if (items < 1)
	 croak_xs_usage(cv, "lobj, ...");
     SP -= items;
     {
	  SV *	lobj;
	  VTYPECHECK(lobj, ST(0), "lobj");
	  mPUSHs(VNUMIFY(lobj));
	  PUTBACK;
	  return;
     }
}

VXS(version_normal)
{
     dVAR;
     dXSARGS;
     if (items != 1)
	 croak_xs_usage(cv, "ver");
     SP -= items;
     {
	  SV *	ver;
	  VTYPECHECK(ver, ST(0), "ver");

	  mPUSHs(VNORMAL(ver));

	  PUTBACK;
	  return;
     }
}

VXS(version_vcmp)
{
     dVAR;
     dXSARGS;
     if (items < 1)
	 croak_xs_usage(cv, "lobj, ...");
     SP -= items;
     {
	  SV *	lobj;
	  VTYPECHECK(lobj, ST(0), "lobj");
	  {
	       SV	*rs;
	       SV	*rvs;
	       SV * robj = ST(1);
	       const IV	 swap = (IV)SvIV(ST(2));

	       if ( !ISA_CLASS_OBJ(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;
     }
}

VXS(version_boolean)
{
    dVAR;
    dXSARGS;
    SV *lobj;
    if (items < 1)
	croak_xs_usage(cv, "lobj, ...");
    SP -= items;
    VTYPECHECK(lobj, ST(0), "lobj");
    {
	SV * const rs =
	    newSViv( VCMP(lobj,
			  sv_2mortal(NEW_VERSION(
					sv_2mortal(newSVpvs("0"))
				    ))
			 )
		   );
	mPUSHs(rs);
	PUTBACK;
	return;
    }
}

VXS(version_noop)
{
    dVAR;
    dXSARGS;
    if (items < 1)
	croak_xs_usage(cv, "lobj, ...");
    if (ISA_CLASS_OBJ(ST(0), "version"))
	Perl_croak(aTHX_ "operation not supported with version object");
    else
	Perl_croak(aTHX_ "lobj is not of type version");
    XSRETURN_EMPTY;
}

VXS(version_is_alpha)
{
    dVAR;
    dXSARGS;
    if (items != 1)
	croak_xs_usage(cv, "lobj");
    SP -= items;
    {
	SV *lobj;
	VTYPECHECK(lobj, ST(0), "lobj");
	if ( hv_exists(MUTABLE_HV(lobj), "alpha", 5 ) )
	    XSRETURN_YES;
	else
	    XSRETURN_NO;
	PUTBACK;
	return;
    }
}

VXS(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_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));
            }
	}
	if ( !SvVOK(ver) ) { /* not already a v-string */
	    rv = sv_newmortal();
	    SvSetSV_nosteal(rv,ver); /* make a duplicate */
	    UPG_VERSION(rv, TRUE);
	} else {
	    rv = sv_2mortal(NEW_VERSION(ver));
	}
	if ( items == 2 && (len != 7
                || strcmp(classname,"version")) ) { /* 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
        }
	PUSHs(rv);
    }
    PUTBACK;
    return;
}

VXS(version_is_qv)
{
    dVAR;
    dXSARGS;
    if (items != 1)
	croak_xs_usage(cv, "lobj");
    SP -= items;
    {
	SV *lobj;
	VTYPECHECK(lobj, ST(0), "lobj");
	if ( hv_exists(MUTABLE_HV(lobj), "qv", 2 ) )
	    XSRETURN_YES;
	else
	    XSRETURN_NO;
	PUTBACK;
	return;
    }
}

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