This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
https://perl5.git.perl.org / perl5.git / blobdiff
? search:
summary | shortlog | log | commit | commitdiff | tree
raw | inline | side by side
Grab latest changes from CPAN 0.9905
[perl5.git] / vxs.inc
diff --git a/vxs.inc b/vxs.inc
index a8b9294..cb894f2 100644 (file)
--- a/vxs.inc
+++ b/vxs.inc
@@ -3,48 +3,51 @@
 
 #ifdef PERL_CORE
 #  define VXS_CLASS "version"
 
 #ifdef PERL_CORE
 #  define VXS_CLASS "version"
+#  define VXSp(name) XS_##name
 #else
 #  define VXS_CLASS "version::vxs"
 #else
 #  define VXS_CLASS "version::vxs"
+#  define VXSp(name) VXS_##name
 #endif
 #endif
+#define VXS(name) XS(VXSp(name))
 
 #ifdef VXS_XSUB_DETAILS
 #  ifdef PERL_CORE
     {"UNIVERSAL::VERSION", XS_UNIVERSAL_VERSION, NULL},
 #  else
 
 #ifdef VXS_XSUB_DETAILS
 #  ifdef PERL_CORE
     {"UNIVERSAL::VERSION", XS_UNIVERSAL_VERSION, NULL},
 #  else
-    {VXS_CLASS "::_VERSION", XS_UNIVERSAL_VERSION, NULL},
+    {VXS_CLASS "::_VERSION", VXS_UNIVERSAL_VERSION, NULL},
 #  endif
 #  endif
-    {VXS_CLASS "::()", XS_version_noop, NULL},
-    {VXS_CLASS "::new", XS_version_new, NULL},
-    {VXS_CLASS "::parse", XS_version_new, NULL},
-    {VXS_CLASS "::(\"\"", XS_version_stringify, NULL},
-    {VXS_CLASS "::stringify", XS_version_stringify, NULL},
-    {VXS_CLASS "::(0+", XS_version_numify, NULL},
-    {VXS_CLASS "::numify", XS_version_numify, NULL},
-    {VXS_CLASS "::normal", XS_version_normal, NULL},
-    {VXS_CLASS "::(cmp", XS_version_vcmp, NULL},
-    {VXS_CLASS "::(<=>", XS_version_vcmp, 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},
 #  ifdef PERL_CORE
     {VXS_CLASS "::vcmp", XS_version_vcmp, NULL},
 #  else
 #  ifdef PERL_CORE
     {VXS_CLASS "::vcmp", XS_version_vcmp, NULL},
 #  else
-    {VXS_CLASS "::VCMP", XS_version_vcmp, NULL},
+    {VXS_CLASS "::VCMP", VXS_version_vcmp, NULL},
 #  endif
 #  endif
-    {VXS_CLASS "::(bool", XS_version_boolean, NULL},
-    {VXS_CLASS "::boolean", XS_version_boolean, NULL},
-    {VXS_CLASS "::(+", XS_version_noop, NULL},
-    {VXS_CLASS "::(-", XS_version_noop, NULL},
-    {VXS_CLASS "::(*", XS_version_noop, NULL},
-    {VXS_CLASS "::(/", XS_version_noop, NULL},
-    {VXS_CLASS "::(+=", XS_version_noop, NULL},
-    {VXS_CLASS "::(-=", XS_version_noop, NULL},
-    {VXS_CLASS "::(*=", XS_version_noop, NULL},
-    {VXS_CLASS "::(/=", XS_version_noop, NULL},
-    {VXS_CLASS "::(abs", XS_version_noop, NULL},
-    {VXS_CLASS "::(nomethod", XS_version_noop, NULL},
-    {VXS_CLASS "::noop", XS_version_noop, NULL},
-    {VXS_CLASS "::is_alpha", XS_version_is_alpha, NULL},
-    {VXS_CLASS "::qv", XS_version_qv, NULL},
-    {VXS_CLASS "::declare", XS_version_qv, NULL},
-    {VXS_CLASS "::is_qv", XS_version_is_qv, NULL},
+    {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},
 #else
 
 #ifndef dVAR
 #else
 
 #ifndef dVAR
@@ -64,7 +67,7 @@ typedef char HVNAME;
 #  define HEKf         "s"
 #endif
 
 #  define HEKf         "s"
 #endif
 
-XS(XS_UNIVERSAL_VERSION)
+VXS(UNIVERSAL_VERSION)
 {
     dVAR;
     dXSARGS;
 {
     dVAR;
     dXSARGS;
@@ -95,7 +98,7 @@ XS(XS_UNIVERSAL_VERSION)
 
     if (gvp && isGV(gv = *gvp) && (sv = GvSV(gv)) && SvOK(sv)) {
         sv = sv_mortalcopy(sv);
 
     if (gvp && isGV(gv = *gvp) && (sv = GvSV(gv)) && SvOK(sv)) {
         sv = sv_mortalcopy(sv);
-       if ( ! ISA_CLASS_OBJ(sv, "version::vxs"))
+       if ( ! ISA_CLASS_OBJ(sv, "version"))
            UPG_VERSION(sv, FALSE);
         undef = NULL;
     }
            UPG_VERSION(sv, FALSE);
         undef = NULL;
     }
@@ -165,55 +168,75 @@ XS(XS_UNIVERSAL_VERSION)
     XSRETURN(1);
 }
 
     XSRETURN(1);
 }
 
-XS(XS_version_new)
+VXS(version_new)
 {
     dVAR;
     dXSARGS;
 {
     dVAR;
     dXSARGS;
-    if (items > 3 || items < 1)
-       croak_xs_usage(cv, "class, version");
+    PERL_UNUSED_VAR(cv);
+    SV *vs = items ? ST(1) : &PL_sv_undef;
+    SV *rv;
+    const char * classname = "";
+    STRLEN len;
+    U32 flags = 0;
     SP -= items;
     SP -= items;
-    {
-        SV *vs = ST(1);
-       SV *rv;
-        STRLEN len;
-        const char *classname;
-        U32 flags;
-
-       /* Just in case this is something like a tied hash */
-       SvGETMAGIC(vs);
-
-        if ( sv_isobject(ST(0)) ) { /* get the class if called as an object method */
-            const HV * stash = SvSTASH(SvRV(ST(0)));
-            classname = HvNAME(stash);
-            len       = HvNAMELEN(stash);
-            flags     = HvNAMEUTF8(stash) ? SVf_UTF8 : 0;
-        }
-        else {
-           classname = SvPV(ST(0), len);
-            flags     = SvUTF8(ST(0));
-        }
 
 
-       if ( items == 1 || ! SvOK(vs) ) { /* no param or explicit undef */
-           /* create empty object */
-           vs = sv_newmortal();
-           sv_setpvs(vs, "0");
-       }
-       else if ( items == 3 ) {
-           vs = sv_newmortal();
-           Perl_sv_setpvf(aTHX_ vs,"v%s",SvPV_nolen_const(ST(2)));
-       }
+    if (items > 3 || items == 0)
+        Perl_croak(aTHX_ "Usage: version::new(class, version)");
 
 
-       rv = new_version(vs);
-       if ( strnNE(classname,"version", len) ) /* inherited new() */
-           sv_bless(rv, gv_stashpvn(classname, len, GV_ADD | flags));
+    /* Just in case this is something like a tied hash */
+    SvGETMAGIC(vs);
 
 
-       mPUSHs(rv);
-       PUTBACK;
-       return;
+    if ( items == 1 || ! SvOK(vs) ) { /* no param or explicit undef */
+        /* create empty object */
+        vs = sv_newmortal();
+        sv_setpvs(vs,"undef");
+    }
+    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)) ) {
+       /* get the class if called as an object method */
+       const HV * stash = SvSTASH(SvRV(ST(0)));
+       classname = HvNAME_get(stash);
+       len       = HvNAMELEN_get(stash);
+#ifdef HvNAMEUTF8
+       flags     = HvNAMEUTF8(stash) ? SVf_UTF8 : 0;
+#endif
     }
     }
+    else {
+       classname = SvPV(ST(0), len);
+       flags     = SvUTF8(ST(0));
+    }
+
+    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;
 }
 
 }
 
-XS(XS_version_stringify)
+#define VTYPECHECK(var, val, varname) \
+    STMT_START {                                                       \
+       if (ISA_CLASS_OBJ(val, "version")) {                            \
+           (var) = SvRV(val);                                          \
+       }                                                               \
+       else                                                            \
+           Perl_croak(aTHX_ varname " is not of type version");        \
+    } STMT_END
+
+VXS(version_stringify)
 {
      dVAR;
      dXSARGS;
 {
      dVAR;
      dXSARGS;
@@ -221,22 +244,17 @@ XS(XS_version_stringify)
         croak_xs_usage(cv, "lobj, ...");
      SP -= items;
      {
         croak_xs_usage(cv, "lobj, ...");
      SP -= items;
      {
-         SV *  lobj = ST(0);
+         SV *  lobj;
+         VTYPECHECK(lobj, ST(0), "lobj");
 
 
-         if (sv_isobject(lobj) && sv_derived_from(lobj, "version")) {
-              lobj = SvRV(lobj);
-         }
-         else
-              Perl_croak(aTHX_ "lobj is not of type version");
-
-         mPUSHs(vstringify(lobj));
+         mPUSHs(VSTRINGIFY(lobj));
 
          PUTBACK;
          return;
      }
 }
 
 
          PUTBACK;
          return;
      }
 }
 
-XS(XS_version_numify)
+VXS(version_numify)
 {
      dVAR;
      dXSARGS;
 {
      dVAR;
      dXSARGS;
@@ -244,45 +262,33 @@ XS(XS_version_numify)
         croak_xs_usage(cv, "lobj, ...");
      SP -= items;
      {
         croak_xs_usage(cv, "lobj, ...");
      SP -= items;
      {
-         SV *  lobj = ST(0);
-
-         if (sv_isobject(lobj) && sv_derived_from(lobj, "version")) {
-              lobj = SvRV(lobj);
-         }
-         else
-              Perl_croak(aTHX_ "lobj is not of type version");
-
-         mPUSHs(vnumify(lobj));
-
+         SV *  lobj;
+         VTYPECHECK(lobj, ST(0), "lobj");
+         mPUSHs(VNUMIFY(lobj));
          PUTBACK;
          return;
      }
 }
 
          PUTBACK;
          return;
      }
 }
 
-XS(XS_version_normal)
+VXS(version_normal)
 {
      dVAR;
      dXSARGS;
 {
      dVAR;
      dXSARGS;
-     if (items < 1)
-        croak_xs_usage(cv, "lobj, ...");
+     if (items != 1)
+        croak_xs_usage(cv, "ver");
      SP -= items;
      {
      SP -= items;
      {
-         SV *  lobj = ST(0);
-
-         if (sv_isobject(lobj) && sv_derived_from(lobj, "version")) {
-              lobj = SvRV(lobj);
-         }
-         else
-              Perl_croak(aTHX_ "lobj is not of type version");
+         SV *  ver;
+         VTYPECHECK(ver, ST(0), "ver");
 
 
-         mPUSHs(vnormal(lobj));
+         mPUSHs(VNORMAL(ver));
 
          PUTBACK;
          return;
      }
 }
 
 
          PUTBACK;
          return;
      }
 }
 
-XS(XS_version_vcmp)
+VXS(version_vcmp)
 {
      dVAR;
      dXSARGS;
 {
      dVAR;
      dXSARGS;
@@ -290,34 +296,28 @@ XS(XS_version_vcmp)
         croak_xs_usage(cv, "lobj, ...");
      SP -= items;
      {
         croak_xs_usage(cv, "lobj, ...");
      SP -= items;
      {
-         SV *  lobj = ST(0);
-
-         if (sv_isobject(lobj) && sv_derived_from(lobj, "version")) {
-              lobj = SvRV(lobj);
-         }
-         else
-              Perl_croak(aTHX_ "lobj is not of type version");
-
+         SV *  lobj;
+         VTYPECHECK(lobj, ST(0), "lobj");
          {
               SV       *rs;
               SV       *rvs;
               SV * robj = ST(1);
               const IV  swap = (IV)SvIV(ST(2));
 
          {
               SV       *rs;
               SV       *rvs;
               SV * robj = ST(1);
               const IV  swap = (IV)SvIV(ST(2));
 
-              if ( !sv_isobject(robj) || !sv_derived_from(robj, "version") )
+              if ( !ISA_CLASS_OBJ(robj, "version") )
               {
               {
-                   robj = new_version(SvOK(robj) ? robj : newSVpvs_flags("0", SVs_TEMP));
+                   robj = NEW_VERSION(SvOK(robj) ? robj : newSVpvs_flags("0", SVs_TEMP));
                    sv_2mortal(robj);
               }
               rvs = SvRV(robj);
 
               if ( swap )
               {
                    sv_2mortal(robj);
               }
               rvs = SvRV(robj);
 
               if ( swap )
               {
-                   rs = newSViv(vcmp(rvs,lobj));
+                   rs = newSViv(VCMP(rvs,lobj));
               }
               else
               {
               }
               else
               {
-                   rs = newSViv(vcmp(lobj,rvs));
+                   rs = newSViv(VCMP(lobj,rvs));
               }
 
               mPUSHs(rs);
               }
 
               mPUSHs(rs);
@@ -328,18 +328,19 @@ XS(XS_version_vcmp)
      }
 }
 
      }
 }
 
-XS(XS_version_boolean)
+VXS(version_boolean)
 {
     dVAR;
     dXSARGS;
 {
     dVAR;
     dXSARGS;
+    SV *lobj;
     if (items < 1)
        croak_xs_usage(cv, "lobj, ...");
     SP -= items;
     if (items < 1)
        croak_xs_usage(cv, "lobj, ...");
     SP -= items;
-    if (sv_isobject(ST(0)) && sv_derived_from(ST(0), "version")) {
-       SV * const lobj = SvRV(ST(0));
+    VTYPECHECK(lobj, ST(0), "lobj");
+    {
        SV * const rs =
        SV * const rs =
-           newSViv( vcmp(lobj,
-                         sv_2mortal(new_version(
+           newSViv( VCMP(lobj,
+                         sv_2mortal(NEW_VERSION(
                                        sv_2mortal(newSVpvs("0"))
                                    ))
                         )
                                        sv_2mortal(newSVpvs("0"))
                                    ))
                         )
@@ -348,46 +349,41 @@ XS(XS_version_boolean)
        PUTBACK;
        return;
     }
        PUTBACK;
        return;
     }
-    else
-       Perl_croak(aTHX_ "lobj is not of type version");
 }
 
 }
 
-XS(XS_version_noop)
+VXS(version_noop)
 {
     dVAR;
     dXSARGS;
     if (items < 1)
        croak_xs_usage(cv, "lobj, ...");
 {
     dVAR;
     dXSARGS;
     if (items < 1)
        croak_xs_usage(cv, "lobj, ...");
-    if (sv_isobject(ST(0)) && sv_derived_from(ST(0), "version"))
+    if (ISA_CLASS_OBJ(ST(0), "version"))
        Perl_croak(aTHX_ "operation not supported with version object");
     else
        Perl_croak(aTHX_ "lobj is not of type version");
        Perl_croak(aTHX_ "operation not supported with version object");
     else
        Perl_croak(aTHX_ "lobj is not of type version");
-#ifndef HASATTRIBUTE_NORETURN
     XSRETURN_EMPTY;
     XSRETURN_EMPTY;
-#endif
 }
 
 }
 
-XS(XS_version_is_alpha)
+VXS(version_is_alpha)
 {
     dVAR;
     dXSARGS;
     if (items != 1)
        croak_xs_usage(cv, "lobj");
     SP -= items;
 {
     dVAR;
     dXSARGS;
     if (items != 1)
        croak_xs_usage(cv, "lobj");
     SP -= items;
-    if (sv_isobject(ST(0)) && sv_derived_from(ST(0), "version")) {
-       SV * const lobj = ST(0);
-       if ( hv_exists(MUTABLE_HV(SvRV(lobj)), "alpha", 5 ) )
+    {
+       SV *lobj;
+       VTYPECHECK(lobj, ST(0), "lobj");
+       if ( hv_exists(MUTABLE_HV(lobj), "alpha", 5 ) )
            XSRETURN_YES;
        else
            XSRETURN_NO;
        PUTBACK;
        return;
     }
            XSRETURN_YES;
        else
            XSRETURN_NO;
        PUTBACK;
        return;
     }
-    else
-       Perl_croak(aTHX_ "lobj is not of type version");
 }
 
 }
 
-XS(XS_version_qv)
+VXS(version_qv)
 {
     dVAR;
     dXSARGS;
 {
     dVAR;
     dXSARGS;
@@ -409,25 +405,31 @@ XS(XS_version_qv)
            }
             if ( sv_isobject(ST(0)) ) { /* class called as an object method */
                 const HV * stash = SvSTASH(SvRV(ST(0)));
            }
             if ( sv_isobject(ST(0)) ) { /* class called as an object method */
                 const HV * stash = SvSTASH(SvRV(ST(0)));
-                classname = HvNAME(stash);
-                len       = HvNAMELEN(stash);
+                classname = HvNAME_get(stash);
+                len       = HvNAMELEN_get(stash);
+#ifdef HvNAMEUTF8
                 flags     = HvNAMEUTF8(stash) ? SVf_UTF8 : 0;
                 flags     = HvNAMEUTF8(stash) ? SVf_UTF8 : 0;
+#endif
             }
             else {
               classname = SvPV(ST(0), len);
                 flags     = SvUTF8(ST(0));
             }
             }
             else {
               classname = SvPV(ST(0), len);
                 flags     = SvUTF8(ST(0));
             }
-        }
+       }
        if ( !SvVOK(ver) ) { /* not already a v-string */
            rv = sv_newmortal();
        if ( !SvVOK(ver) ) { /* not already a v-string */
            rv = sv_newmortal();
-           sv_setsv(rv,ver); /* make a duplicate */
-           upg_version(rv, TRUE);
+           SvSetSV_nosteal(rv,ver); /* make a duplicate */
+           UPG_VERSION(rv, TRUE);
        } else {
        } else {
-           rv = sv_2mortal(new_version(ver));
+           rv = sv_2mortal(NEW_VERSION(ver));
        }
        }
-       if ( items == 2
-                && strnNE(classname,"version", len) ) { /* inherited new() */
+       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));
            sv_bless(rv, gv_stashpvn(classname, len, GV_ADD | flags));
+#endif
         }
        PUSHs(rv);
     }
         }
        PUSHs(rv);
     }
@@ -435,24 +437,23 @@ XS(XS_version_qv)
     return;
 }
 
     return;
 }
 
-XS(XS_version_is_qv)
+VXS(version_is_qv)
 {
     dVAR;
     dXSARGS;
     if (items != 1)
        croak_xs_usage(cv, "lobj");
     SP -= items;
 {
     dVAR;
     dXSARGS;
     if (items != 1)
        croak_xs_usage(cv, "lobj");
     SP -= items;
-    if (sv_isobject(ST(0)) && sv_derived_from(ST(0), "version")) {
-       SV * const lobj = ST(0);
-       if ( hv_exists(MUTABLE_HV(SvRV(lobj)), "qv", 2 ) )
+    {
+       SV *lobj;
+       VTYPECHECK(lobj, ST(0), "lobj");
+       if ( hv_exists(MUTABLE_HV(lobj), "qv", 2 ) )
            XSRETURN_YES;
        else
            XSRETURN_NO;
        PUTBACK;
        return;
     }
            XSRETURN_YES;
        else
            XSRETURN_NO;
        PUTBACK;
        return;
     }
-    else
-       Perl_croak(aTHX_ "lobj is not of type version");
 }
 
 #endif
 }
 
 #endif
Unnamed repository; edit this file 'description' to name the repository.