X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/98079c483a238cb7ae83e3cd15c53cf7f1236457..4b819be304b2c9c7ea4749178b42d0136111abbf:/vxs.inc diff --git a/vxs.inc b/vxs.inc index e297c38..4d74adb 100644 --- a/vxs.inc +++ b/vxs.inc @@ -4,49 +4,67 @@ #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", VXSp(universal_version), NULL}, + {"UNIVERSAL::VERSION", VXSp(universal_version), VXSXSDP(NULL)}, # endif - {VXS_CLASS "::_VERSION", VXSp(universal_version), NULL}, - {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 @@ -73,7 +91,6 @@ VXS(universal_version) HV *pkg; GV **gvp; GV *gv; - SV *ret; SV *sv; const char *undef; PERL_UNUSED_ARG(cv); @@ -97,12 +114,12 @@ VXS(universal_version) 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)"; } @@ -135,7 +152,7 @@ VXS(universal_version) } } - 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) ); } @@ -155,10 +172,9 @@ VXS(universal_version) 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; @@ -171,36 +187,51 @@ VXS(version_new) { 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 @@ -208,8 +239,8 @@ VXS(version_new) #endif } else { - classname = SvPV(ST(0), len); - flags = SvUTF8(ST(0)); + classname = SvPV_nomg(svarg0, len); + flags = SvUTF8(svarg0); } rv = NEW_VERSION(vs); @@ -221,18 +252,17 @@ VXS(version_new) 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) @@ -246,10 +276,7 @@ VXS(version_stringify) SV * lobj; VTYPECHECK(lobj, ST(0), "lobj"); - mPUSHs(VSTRINGIFY(lobj)); - - PUTBACK; - return; + VXS_RETURN_M_SV(VSTRINGIFY(lobj)); } } @@ -263,9 +290,7 @@ VXS(version_numify) { SV * lobj; VTYPECHECK(lobj, ST(0), "lobj"); - mPUSHs(VNUMIFY(lobj)); - PUTBACK; - return; + VXS_RETURN_M_SV(VNUMIFY(lobj)); } } @@ -280,10 +305,7 @@ VXS(version_normal) SV * ver; VTYPECHECK(ver, ST(0), "ver"); - mPUSHs(VNORMAL(ver)); - - PUTBACK; - return; + VXS_RETURN_M_SV(VNORMAL(ver)); } } @@ -303,10 +325,9 @@ VXS(version_vcmp) 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); @@ -319,11 +340,8 @@ VXS(version_vcmp) rs = newSViv(VCMP(lobj,rvs)); } - mPUSHs(rs); + VXS_RETURN_M_SV(rs); } - - PUTBACK; - return; } } @@ -344,9 +362,7 @@ VXS(version_boolean) )) ) ); - mPUSHs(rs); - PUTBACK; - return; + VXS_RETURN_M_SV(rs); } } @@ -356,32 +372,40 @@ VXS(version_noop) 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; @@ -390,20 +414,22 @@ VXS(version_qv) 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 @@ -411,8 +437,8 @@ VXS(version_qv) #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 */ @@ -436,23 +462,10 @@ VXS(version_qv) 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