[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
/* VXSXSDP = XSUB Details Proto */
#  define VXSXSDP(x) x, 0
#else
#  define VXS_CLASS "version::vxs"
#  define VXSp(name) VXS_##name
/* proto member is unused in version, it is used in CORE by non version xsubs */
#  define VXSXSDP(x)
#endif

#ifndef XS_INTERNAL
#  define XS_INTERNAL(name) static XSPROTO(name)
#endif

#define VXS(name) XS_INTERNAL(VXSp(name)); XS_INTERNAL(VXSp(name))

/* uses PUSHs, so SP must be at start, PUSHs sv on Perl stack, then returns from
   xsub; this is a little more machine code/tailcall friendly than mPUSHs(foo);
   PUTBACK; return; */

#define VXS_RETURN_M_SV(sv) \
    STMT_START {							\
	SV * sv_vtc = sv;						\
	PUSHs(sv_vtc);							\
	PUTBACK;							\
	sv_2mortal(sv_vtc);						\
	return;								\
    } STMT_END


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

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

    XSRETURN(1);
}

VXS(version_new)
{
    dXSARGS;
    SV *vs;
    SV *rv;
    const char * classname = "";
    STRLEN len;
    U32 flags = 0;
    SV * svarg0 = NULL;
    PERL_UNUSED_VAR(cv);

    SP -= items;

    switch((U32)items) {
    case 3: {
        SV * svarg2;
        vs = sv_newmortal();
        svarg2 = ST(2);
#if PERL_VERSION == 5
        sv_setpvf(vs,"v%s",SvPV_nolen_const(svarg2));
#else
        Perl_sv_setpvf(aTHX_ vs,"v%s",SvPV_nolen_const(svarg2));
#endif
        break;
    }
    case 2:
        vs = ST(1);
    /* Just in case this is something like a tied hash */
        SvGETMAGIC(vs);
        if(SvOK(vs))
            break;
        /* fall through */
    case 1:
        /* no param or explicit undef */
        /* create empty object */
        vs = sv_newmortal();
        sv_setpvs(vs,"undef");
        break;
    default:
    case 0:
        Perl_croak_nocontext("Usage: version::new(class, version)");
    }

    svarg0 = ST(0);
    if ( sv_isobject(svarg0) ) {
	/* get the class if called as an object method */
	const HV * stash = SvSTASH(SvRV(svarg0));
	classname = HvNAME_get(stash);
	len	  = HvNAMELEN_get(stash);
#ifdef HvNAMEUTF8
	flags	  = HvNAMEUTF8(stash) ? SVf_UTF8 : 0;
#endif
    }
    else {
	classname = SvPV_nomg(svarg0, len);
	flags     = SvUTF8(svarg0);
    }

    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

    VXS_RETURN_M_SV(rv);
}

#define VTYPECHECK(var, val, varname) \
    STMT_START {							\
	SV * sv_vtc = val;						\
	if (ISA_VERSION_OBJ(sv_vtc)) {				\
	    (var) = SvRV(sv_vtc);						\
	}								\
	else								\
	    Perl_croak_nocontext(varname " is not of type version");	\
    } STMT_END

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

	  VXS_RETURN_M_SV(VSTRINGIFY(lobj));
     }
}

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

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

	  VXS_RETURN_M_SV(VNORMAL(ver));
     }
}

VXS(version_vcmp)
{
     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_VERSION_OBJ(robj) )
	       {
		    robj = sv_2mortal(NEW_VERSION(SvOK(robj) ? robj : newSVpvs_flags("0", SVs_TEMP)));
	       }
	       rvs = SvRV(robj);

	       if ( swap )
	       {
		    rs = newSViv(VCMP(rvs,lobj));
	       }
	       else
	       {
		    rs = newSViv(VCMP(lobj,rvs));
	       }

	       VXS_RETURN_M_SV(rs);
	  }
     }
}

VXS(version_boolean)
{
    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"))
				    ))
			 )
		   );
	VXS_RETURN_M_SV(rs);
    }
}

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

static
void
S_version_check_key(pTHX_ CV * cv, const char * key, int keylen)
{
    dXSARGS;
    if (items != 1)
	croak_xs_usage(cv, "lobj");
    {
	SV *lobj = POPs;
	SV *ret;
	VTYPECHECK(lobj, lobj, "lobj");
	if ( hv_exists(MUTABLE_HV(lobj), key, keylen ) )
	    ret = &PL_sv_yes;
	else
	    ret = &PL_sv_no;
	PUSHs(ret);
	PUTBACK;
	return;
    }
}

VXS(version_is_alpha)
{
    S_version_check_key(aTHX_ cv, "alpha", 5);
}

VXS(version_qv)
{
    dXSARGS;
    PERL_UNUSED_ARG(cv);
    SP -= items;
    {
	SV * ver = ST(0);
	SV * sv0 = ver;
	SV * rv;
        STRLEN len = 0;
        const char * classname = "";
        U32 flags = 0;
        if ( items == 2 ) {
	    SV * sv1 = ST(1);
	    SvGETMAGIC(sv1);
	    if (SvOK(sv1)) {
		ver = sv1;
	    }
	    else {
		Perl_croak(aTHX_ "Invalid version format (version required)");
	    }
            if ( sv_isobject(sv0) ) { /* class called as an object method */
                const HV * stash = SvSTASH(SvRV(sv0));
                classname = HvNAME_get(stash);
                len       = HvNAMELEN_get(stash);
#ifdef HvNAMEUTF8
                flags     = HvNAMEUTF8(stash) ? SVf_UTF8 : 0;
#endif
            }
            else {
	       classname = SvPV(sv0, len);
                flags     = SvUTF8(sv0);
            }
	}
	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)
{
    S_version_check_key(aTHX_ cv, "qv", 2);
}

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