From 05402f6b212ae526674299c1c22151299db21ebb Mon Sep 17 00:00:00 2001 From: John Peacock Date: Sun, 12 Jan 2014 11:19:53 -0500 Subject: Lots of C optimizations for both speed/correctness Clean up a lot of the less efficient uses of various Perl macros and functions, mostly from bulk88@hotmail.com. Also deal with the fact that older Perl's were not handling locale setting in a consistent manner. This means going back to the less efficient but always correct method of ALWAYS copying the old locale and switch to C and then restoring, for all Perl releases prior to 5.19.0. Discontinue support for Perl's prior to v5.6.2. --- vxs.inc | 159 +++++++++++++++++++++++++++++++++------------------------------- 1 file changed, 81 insertions(+), 78 deletions(-) (limited to 'vxs.inc') diff --git a/vxs.inc b/vxs.inc index 2e4f409390..0a02056561 100644 --- a/vxs.inc +++ b/vxs.inc @@ -4,49 +4,53 @@ #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), 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 +77,6 @@ VXS(universal_version) HV *pkg; GV **gvp; GV *gv; - SV *ret; SV *sv; const char *undef; PERL_UNUSED_ARG(cv); @@ -97,12 +100,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 +138,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 +158,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; @@ -176,6 +178,7 @@ VXS(version_new) const char * classname = ""; STRLEN len; U32 flags = 0; + SV * svarg0 = NULL; PERL_UNUSED_VAR(cv); SP -= items; @@ -192,16 +195,19 @@ VXS(version_new) 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(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 } - if ( sv_isobject(ST(0)) ) { + 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 @@ -209,8 +215,8 @@ VXS(version_new) #endif } else { - classname = SvPV(ST(0), len); - flags = SvUTF8(ST(0)); + classname = SvPV(svarg0, len); + flags = SvUTF8(svarg0); } rv = NEW_VERSION(vs); @@ -229,8 +235,9 @@ VXS(version_new) #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"); \ @@ -304,10 +311,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); @@ -357,32 +363,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; @@ -391,20 +405,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 @@ -412,8 +428,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 */ @@ -437,23 +453,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 -- cgit v1.2.1