[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
#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
#define VXS(name) XS(VXSp(name))

#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)
{
    dVAR;
    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)
{
    dVAR;
    dXSARGS;
    SV *vs = items ? ST(1) : &PL_sv_undef;
    SV *rv;
    const char * classname = "";
    STRLEN len;
    U32 flags = 0;
    SV * svarg0 = NULL;
    PERL_UNUSED_VAR(cv);

    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 ) {
        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
    }
    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(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

    mPUSHs(rv);
    PUTBACK;
    return;
}

#define VTYPECHECK(var, val, varname) \
    STMT_START {							\
	SV * sv_vtc = val;						\
	if (ISA_VERSION_OBJ(sv_vtc)) {				\
	    (var) = SvRV(sv_vtc);						\
	}								\
	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_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));
	       }

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