#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))
+#define VXS(name) XS(VXSp(name)); XS(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", XS_UNIVERSAL_VERSION, NULL},
-# else
- {VXS_CLASS "::_VERSION", VXS_UNIVERSAL_VERSION, NULL},
+ {"UNIVERSAL::VERSION", VXSp(universal_version), VXSXSDP(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},
+ {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, NULL},
+ {VXS_CLASS "::vcmp", XS_version_vcmp, VXSXSDP(NULL)},
# else
- {VXS_CLASS "::VCMP", VXS_version_vcmp, NULL},
+ {VXS_CLASS "::VCMP", VXS_version_vcmp, VXSXSDP(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},
+ {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 HEKf "s"
#endif
-VXS(UNIVERSAL_VERSION)
+VXS(universal_version)
{
dVAR;
dXSARGS;
HV *pkg;
GV **gvp;
GV *gv;
- SV *ret;
SV *sv;
const char *undef;
PERL_UNUSED_ARG(cv);
if (gvp && isGV(gv = *gvp) && (sv = GvSV(gv)) && SvOK(sv)) {
sv = sv_mortalcopy(sv);
- if ( ! ISA_CLASS_OBJ(sv, "version"))
+ if ( ! ISA_VERSION_OBJ(sv) )
UPG_VERSION(sv, FALSE);
undef = NULL;
}
else {
- sv = ret = &PL_sv_undef;
+ sv = &PL_sv_undef;
undef = "(undef)";
}
}
}
- if ( ! ISA_CLASS_OBJ(req, "version")) {
+ if ( ! ISA_VERSION_OBJ(req) ) {
/* req may very well be R/O, so create a new object */
req = sv_2mortal( NEW_VERSION(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")) {
+ if (ISA_VERSION_OBJ(sv)) {
ST(0) = sv_2mortal(VSTRINGIFY(sv));
} else {
ST(0) = sv;
{
dVAR;
dXSARGS;
- PERL_UNUSED_VAR(cv);
- SV *vs = items ? ST(1) : &PL_sv_undef;
+ SV *vs;
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)");
+ SV * svarg0 = NULL;
+ PERL_UNUSED_VAR(cv);
- /* Just in case this is something like a tied hash */
- SvGETMAGIC(vs);
+ SP -= items;
- if ( items == 1 || ! SvOK(vs) ) { /* no param or explicit undef */
- /* create empty object */
- vs = sv_newmortal();
- sv_setpvs(vs,"undef");
- }
- else if (items == 3 ) {
+ 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(ST(2)));
+ sv_setpvf(vs,"v%s",SvPV_nolen_const(svarg2));
#else
- Perl_sv_setpvf(aTHX_ vs,"v%s",SvPV_nolen_const(ST(2)));
+ Perl_sv_setpvf(aTHX_ vs,"v%s",SvPV_nolen_const(svarg2));
#endif
+ break;
}
- if ( sv_isobject(ST(0)) ) {
+ case 2:
+ vs = ST(1);
+ /* Just in case this is something like a tied hash */
+ SvGETMAGIC(vs);
+ if(SvOK(vs))
+ break;
+ /* drop 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)");
+ break;
+ }
+
+ svarg0 = ST(0);
+ if ( sv_isobject(svarg0) ) {
/* get the class if called as an object method */
- const HV * stash = SvSTASH(SvRV(ST(0)));
+ const HV * stash = SvSTASH(SvRV(svarg0));
classname = HvNAME_get(stash);
len = HvNAMELEN_get(stash);
#ifdef HvNAMEUTF8
#endif
}
else {
- classname = SvPV(ST(0), len);
- flags = SvUTF8(ST(0));
+ classname = SvPV_nomg(svarg0, len);
+ flags = SvUTF8(svarg0);
}
rv = NEW_VERSION(vs);
sv_bless(rv, gv_stashpvn(classname, len, GV_ADD | flags));
#endif
- mPUSHs(rv);
- PUTBACK;
- return;
+ VXS_RETURN_M_SV(rv);
}
#define VTYPECHECK(var, val, varname) \
STMT_START { \
- if (ISA_CLASS_OBJ(val, "version")) { \
- (var) = SvRV(val); \
+ SV * sv_vtc = val; \
+ if (ISA_VERSION_OBJ(sv_vtc)) { \
+ (var) = SvRV(sv_vtc); \
} \
else \
- Perl_croak(aTHX_ varname " is not of type version"); \
+ Perl_croak_nocontext(varname " is not of type version"); \
} STMT_END
VXS(version_stringify)
SV * lobj;
VTYPECHECK(lobj, ST(0), "lobj");
- mPUSHs(VSTRINGIFY(lobj));
-
- PUTBACK;
- return;
+ VXS_RETURN_M_SV(VSTRINGIFY(lobj));
}
}
{
SV * lobj;
VTYPECHECK(lobj, ST(0), "lobj");
- mPUSHs(VNUMIFY(lobj));
- PUTBACK;
- return;
+ VXS_RETURN_M_SV(VNUMIFY(lobj));
}
}
SV * ver;
VTYPECHECK(ver, ST(0), "ver");
- mPUSHs(VNORMAL(ver));
-
- PUTBACK;
- return;
+ VXS_RETURN_M_SV(VNORMAL(ver));
}
}
SV * robj = ST(1);
const IV swap = (IV)SvIV(ST(2));
- if ( !ISA_CLASS_OBJ(robj, "version") )
+ if ( !ISA_VERSION_OBJ(robj) )
{
- robj = NEW_VERSION(SvOK(robj) ? robj : newSVpvs_flags("0", SVs_TEMP));
- sv_2mortal(robj);
+ robj = sv_2mortal(NEW_VERSION(SvOK(robj) ? robj : newSVpvs_flags("0", SVs_TEMP)));
}
rvs = SvRV(robj);
rs = newSViv(VCMP(lobj,rvs));
}
- mPUSHs(rs);
+ VXS_RETURN_M_SV(rs);
}
-
- PUTBACK;
- return;
}
}
))
)
);
- mPUSHs(rs);
- PUTBACK;
- return;
+ VXS_RETURN_M_SV(rs);
}
}
dXSARGS;
if (items < 1)
croak_xs_usage(cv, "lobj, ...");
- if (ISA_CLASS_OBJ(ST(0), "version"))
+ 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;
}
-VXS(version_is_alpha)
+static
+void
+S_version_check_key(pTHX_ CV * cv, const char * key, int keylen)
{
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;
+ SV *lobj = POPs;
+ SV *ret;
+ VTYPECHECK(lobj, lobj, "lobj");
+ if ( hv_exists(MUTABLE_HV(lobj), key, keylen ) )
+ ret = &PL_sv_yes;
else
- XSRETURN_NO;
+ ret = &PL_sv_no;
+ PUSHs(ret);
PUTBACK;
return;
}
}
+VXS(version_is_alpha)
+{
+ S_version_check_key(aTHX_ cv, "alpha", 5);
+}
+
VXS(version_qv)
{
dVAR;
SP -= items;
{
SV * ver = ST(0);
+ SV * sv0 = ver;
SV * rv;
STRLEN len = 0;
const char * classname = "";
U32 flags = 0;
if ( items == 2 ) {
- SvGETMAGIC(ST(1));
- if (SvOK(ST(1))) {
- ver = ST(1);
+ SV * sv1 = ST(1);
+ SvGETMAGIC(sv1);
+ if (SvOK(sv1)) {
+ ver = sv1;
}
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)));
+ 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
#endif
}
else {
- classname = SvPV(ST(0), len);
- flags = SvUTF8(ST(0));
+ classname = SvPV(sv0, len);
+ flags = SvUTF8(sv0);
}
}
if ( !SvVOK(ver) ) { /* not already a v-string */
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;
- }
+ S_version_check_key(aTHX_ cv, "qv", 2);
}
#endif
https://perl5.git.perl.org / perl5.git / blobdiff