# define VXS_CLASS "version"
# define VXSp(name) XS_##name
/* VXSXSDP = XSUB Details Proto */
-# define VXSXSDP(x) x
+# 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
-#define VXS(name) XS(VXSp(name))
+
+#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
VXS(universal_version)
{
- dVAR;
dXSARGS;
HV *pkg;
GV **gvp;
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
+ "%" HEKf " does not define $%" HEKf
"::VERSION--version check failed",
HEKfARG(name), HEKfARG(name));
-#endif
}
else {
-#if PERL_VERSION >= 8
+#if PERL_VERSION_GE(5,8,0)
Perl_croak(aTHX_
- "%"SVf" defines neither package nor VERSION--version check failed",
+ "%" 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",
req = VSTRINGIFY(req);
sv = VSTRINGIFY(sv);
}
- Perl_croak(aTHX_ "%"HEKf" version %"SVf" required--"
- "this is only version %"SVf"", HEKfARG(HvNAME_HEK(pkg)),
+ Perl_croak(aTHX_ "%" HEKf " version %" SVf " required--"
+ "this is only version %" SVf, HEKfARG(HvNAME_HEK(pkg)),
SVfARG(sv_2mortal(req)),
SVfARG(sv_2mortal(sv)));
}
VXS(version_new)
{
- dVAR;
dXSARGS;
- SV *vs = items ? ST(1) : &PL_sv_undef;
+ SV *vs;
SV *rv;
const char * classname = "";
STRLEN len;
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 ) {
+ 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 */
#endif
}
else {
- classname = SvPV(svarg0, len);
+ 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
- mPUSHs(rv);
- PUTBACK;
- return;
+ VXS_RETURN_M_SV(rv);
}
#define VTYPECHECK(var, val, varname) \
(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)
{
- dVAR;
dXSARGS;
if (items < 1)
croak_xs_usage(cv, "lobj, ...");
SV * lobj;
VTYPECHECK(lobj, ST(0), "lobj");
- mPUSHs(VSTRINGIFY(lobj));
-
- PUTBACK;
- return;
+ VXS_RETURN_M_SV(VSTRINGIFY(lobj));
}
}
VXS(version_numify)
{
- dVAR;
dXSARGS;
if (items < 1)
croak_xs_usage(cv, "lobj, ...");
{
SV * lobj;
VTYPECHECK(lobj, ST(0), "lobj");
- mPUSHs(VNUMIFY(lobj));
- PUTBACK;
- return;
+ VXS_RETURN_M_SV(VNUMIFY(lobj));
}
}
VXS(version_normal)
{
- dVAR;
dXSARGS;
if (items != 1)
croak_xs_usage(cv, "ver");
SV * ver;
VTYPECHECK(ver, ST(0), "ver");
- mPUSHs(VNORMAL(ver));
-
- PUTBACK;
- return;
+ VXS_RETURN_M_SV(VNORMAL(ver));
}
}
VXS(version_vcmp)
{
- dVAR;
dXSARGS;
- if (items < 1)
- croak_xs_usage(cv, "lobj, ...");
+ if (items < 2)
+ croak_xs_usage(cv, "lobj, robj, ...");
SP -= items;
{
SV * lobj;
SV *rs;
SV *rvs;
SV * robj = ST(1);
- const IV swap = (IV)SvIV(ST(2));
+ const int swap = items > 2 ? SvTRUE(ST(2)) : 0;
if ( !ISA_VERSION_OBJ(robj) )
{
rs = newSViv(VCMP(lobj,rvs));
}
- mPUSHs(rs);
+ VXS_RETURN_M_SV(rs);
}
-
- PUTBACK;
- return;
}
}
VXS(version_boolean)
{
- dVAR;
dXSARGS;
SV *lobj;
if (items < 1)
))
)
);
- mPUSHs(rs);
- PUTBACK;
- return;
+ VXS_RETURN_M_SV(rs);
}
}
VXS(version_noop)
{
- dVAR;
dXSARGS;
if (items < 1)
croak_xs_usage(cv, "lobj, ...");
void
S_version_check_key(pTHX_ CV * cv, const char * key, int keylen)
{
- dVAR;
dXSARGS;
if (items != 1)
croak_xs_usage(cv, "lobj");
VXS(version_qv)
{
- dVAR;
dXSARGS;
PERL_UNUSED_ARG(cv);
SP -= items;
}
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);
}
https://perl5.git.perl.org / perl5.git / blobdiff