X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/05402f6b212ae526674299c1c22151299db21ebb..fefcc043b6a92984b721aeb113c9251b5d87f34d:/vxs.inc

diff --git a/vxs.inc b/vxs.inc
index 0a02056..80bb8eb 100644
--- a/vxs.inc
+++ b/vxs.inc
@@ -5,14 +5,33 @@
 #  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
@@ -72,7 +91,6 @@ typedef char HVNAME;
 
 VXS(universal_version)
 {
-    dVAR;
     dXSARGS;
     HV *pkg;
     GV **gvp;
@@ -115,20 +133,16 @@ VXS(universal_version)
 	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",
@@ -152,8 +166,8 @@ VXS(universal_version)
 		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)));
 	}
@@ -171,9 +185,8 @@ VXS(universal_version)
 
 VXS(version_new)
 {
-    dVAR;
     dXSARGS;
-    SV *vs = items ? ST(1) : &PL_sv_undef;
+    SV *vs;
     SV *rv;
     const char * classname = "";
     STRLEN len;
@@ -183,27 +196,32 @@ VXS(version_new)
 
     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 */
@@ -215,22 +233,16 @@ VXS(version_new)
 #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) \
@@ -240,12 +252,11 @@ VXS(version_new)
 	    (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, ...");
@@ -254,16 +265,12 @@ VXS(version_stringify)
 	  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, ...");
@@ -271,15 +278,12 @@ VXS(version_numify)
      {
 	  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");
@@ -288,19 +292,15 @@ VXS(version_normal)
 	  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;
@@ -309,7 +309,7 @@ VXS(version_vcmp)
 	       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) )
 	       {
@@ -326,17 +326,13 @@ VXS(version_vcmp)
 		    rs = newSViv(VCMP(lobj,rvs));
 	       }
 
-	       mPUSHs(rs);
+	       VXS_RETURN_M_SV(rs);
 	  }
-
-	  PUTBACK;
-	  return;
      }
 }
 
 VXS(version_boolean)
 {
-    dVAR;
     dXSARGS;
     SV *lobj;
     if (items < 1)
@@ -351,15 +347,12 @@ VXS(version_boolean)
 				    ))
 			 )
 		   );
-	mPUSHs(rs);
-	PUTBACK;
-	return;
+	VXS_RETURN_M_SV(rs);
     }
 }
 
 VXS(version_noop)
 {
-    dVAR;
     dXSARGS;
     if (items < 1)
 	croak_xs_usage(cv, "lobj, ...");
@@ -374,7 +367,6 @@ static
 void
 S_version_check_key(pTHX_ CV * cv, const char * key, int keylen)
 {
-    dVAR;
     dXSARGS;
     if (items != 1)
 	croak_xs_usage(cv, "lobj");
@@ -399,7 +391,6 @@ VXS(version_is_alpha)
 
 VXS(version_qv)
 {
-    dVAR;
     dXSARGS;
     PERL_UNUSED_ARG(cv);
     SP -= items;
@@ -441,11 +432,7 @@ VXS(version_qv)
 	}
 	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);
     }