This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
fixup Perl_magic_freemglob()
[perl5.git] / vxs.inc
diff --git a/vxs.inc b/vxs.inc
index cb894f2..80bb8eb 100644 (file)
--- a/vxs.inc
+++ b/vxs.inc
@@ -4,50 +4,72 @@
 #ifdef PERL_CORE
 #  define VXS_CLASS "version"
 #  define VXSp(name) XS_##name
+/* VXSXSDP = XSUB Details Proto */
+#  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
-    {"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
@@ -67,14 +89,12 @@ typedef char HVNAME;
 #  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);
@@ -98,12 +118,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)";
     }
 
@@ -113,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",
@@ -136,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) );
        }
@@ -150,16 +166,15 @@ 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)));
        }
     }
-    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;
@@ -170,38 +185,47 @@ VXS(UNIVERSAL_VERSION)
 
 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;
+    SV * svarg0 = NULL;
+    PERL_UNUSED_VAR(cv);
 
-    if (items > 3 || items == 0)
-        Perl_croak(aTHX_ "Usage: version::new(class, version)");
+    SP -= items;
 
+    switch((U32)items) {
+    case 3: {
+        SV * svarg2;
+        vs = sv_newmortal();
+        svarg2 = ST(2);
+        Perl_sv_setpvf(aTHX_ vs,"v%s",SvPV_nolen_const(svarg2));
+        break;
+    }
+    case 2:
+        vs = ST(1);
     /* Just in case this is something like a tied hash */
-    SvGETMAGIC(vs);
-
-    if ( items == 1 || ! SvOK(vs) ) { /* no param or explicit undef */
+        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)");
     }
-    else if (items == 3 ) {
-        vs = sv_newmortal();
-#if PERL_VERSION == 5
-        sv_setpvf(vs,"v%s",SvPV_nolen_const(ST(2)));
-#else
-        Perl_sv_setpvf(aTHX_ vs,"v%s",SvPV_nolen_const(ST(2)));
-#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,36 +233,30 @@ 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);
     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) \
     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)
 {
-     dVAR;
      dXSARGS;
      if (items < 1)
         croak_xs_usage(cv, "lobj, ...");
@@ -247,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, ...");
@@ -264,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");
@@ -281,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;
@@ -302,12 +309,11 @@ 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_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);
 
@@ -320,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)
@@ -345,66 +347,71 @@ 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, ...");
-    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;
     dXSARGS;
     PERL_UNUSED_ARG(cv);
     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 +419,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 */
@@ -425,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);
     }
@@ -437,23 +440,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