This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
And now the rest of the sync to 0.9908
authorJohn Peacock <jpeacock@cpan.org>
Mon, 3 Feb 2014 23:42:20 +0000 (18:42 -0500)
committerSteve Hay <steve.m.hay@googlemail.com>
Tue, 4 Feb 2014 08:15:50 +0000 (08:15 +0000)
vutil.c
vxs.inc

diff --git a/vutil.c b/vutil.c
index 4cf0173..4e24e05 100644 (file)
--- a/vutil.c
+++ b/vutil.c
@@ -525,7 +525,8 @@ Perl_new_version(pTHX_ SV *ver)
        }
     }
 #endif
-    return UPG_VERSION(rv, FALSE);
+    sv_2mortal(rv); /* in case upg_version croaks before it returns */
+    return SvREFCNT_inc_NN(UPG_VERSION(rv, FALSE));
 }
 
 /*
@@ -558,7 +559,25 @@ Perl_upg_version(pTHX_ SV *ver, bool qv)
 #endif
     PERL_ARGS_ASSERT_UPG_VERSION;
 
-    if ( SvNOK(ver) && !( SvPOK(ver) && SvCUR(ver) == 3 ) )
+    if ( (SvUOK(ver) && SvUVX(ver) > VERSION_MAX)
+          || (SvIOK(ver) && SvIVX(ver) > VERSION_MAX) ) {
+       /* out of bounds [unsigned] integer */
+       STRLEN len;
+       char tbuf[64];
+       len = my_snprintf(tbuf, sizeof(tbuf), "%d", VERSION_MAX);
+       version = savepvn(tbuf, len);
+       SAVEFREEPV(version);
+       Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
+                      "Integer overflow in version %d",VERSION_MAX);
+    }
+    else if ( SvUOK(ver) || SvIOK(ver))
+VER_IV:
+    {
+       version = savesvpv(ver);
+       SAVEFREEPV(version);
+    }
+    else if (SvNOK(ver) && !( SvPOK(ver) && SvCUR(ver) == 3 ) )
+VER_NV:
     {
        STRLEN len;
 
@@ -590,22 +609,8 @@ Perl_upg_version(pTHX_ SV *ver, bool qv)
        qv = TRUE;
     }
 #endif
-    else if ( (SvUOK(ver) && SvUVX(ver) > VERSION_MAX)
-          || (SvIOK(ver) && SvIVX(ver) > VERSION_MAX) ) {
-       /* out of bounds [unsigned] integer */
-       STRLEN len;
-       char tbuf[64];
-       len = my_snprintf(tbuf, sizeof(tbuf), "%d", VERSION_MAX);
-       version = savepvn(tbuf, len);
-       SAVEFREEPV(version);
-       Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
-                      "Integer overflow in version %d",VERSION_MAX);
-    }
-    else if ( SvUOK(ver) || SvIOK(ver) ) {
-       version = savesvpv(ver);
-       SAVEFREEPV(version);
-    }
-    else if ( SvPOK(ver) )/* must be a string or something like a string */
+    else if ( SvPOK(ver))/* must be a string or something like a string */
+VER_PV:
     {
        STRLEN len;
        version = savepvn(SvPV(ver,len), SvCUR(ver));
@@ -647,6 +652,17 @@ Perl_upg_version(pTHX_ SV *ver, bool qv)
 #  endif
 #endif
     }
+#if PERL_VERSION_LT(5,17,2)
+    else if (SvIOKp(ver)) {
+       goto VER_IV;
+    }
+    else if (SvNOKp(ver)) {
+       goto VER_NV;
+    }
+    else if (SvPOKp(ver)) {
+       goto VER_PV;
+    }
+#endif
     else
     {
        /* no idea what this is */
@@ -662,6 +678,7 @@ Perl_upg_version(pTHX_ SV *ver, bool qv)
 #if PERL_VERSION_LT(5,19,8) && defined(USE_ITHREADS)
     LEAVE;
 #endif
+
     return ver;
 }
 
diff --git a/vxs.inc b/vxs.inc
index 0a02056..dcf9537 100644 (file)
--- a/vxs.inc
+++ b/vxs.inc
 #endif
 #define VXS(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), VXSXSDP(NULL)},
@@ -173,7 +187,7 @@ VXS(version_new)
 {
     dVAR;
     dXSARGS;
-    SV *vs = items ? ST(1) : &PL_sv_undef;
+    SV *vs;
     SV *rv;
     const char * classname = "";
     STRLEN len;
@@ -183,18 +197,8 @@ 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);
@@ -203,7 +207,27 @@ VXS(version_new)
 #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;
+        /* 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 */
@@ -215,7 +239,7 @@ VXS(version_new)
 #endif
     }
     else {
-       classname = SvPV(svarg0, len);
+       classname = SvPV_nomg(svarg0, len);
        flags     = SvUTF8(svarg0);
     }
 
@@ -228,9 +252,7 @@ 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) \
@@ -240,7 +262,7 @@ 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)
@@ -254,10 +276,7 @@ VXS(version_stringify)
          SV *  lobj;
          VTYPECHECK(lobj, ST(0), "lobj");
 
-         mPUSHs(VSTRINGIFY(lobj));
-
-         PUTBACK;
-         return;
+         VXS_RETURN_M_SV(VSTRINGIFY(lobj));
      }
 }
 
@@ -271,9 +290,7 @@ VXS(version_numify)
      {
          SV *  lobj;
          VTYPECHECK(lobj, ST(0), "lobj");
-         mPUSHs(VNUMIFY(lobj));
-         PUTBACK;
-         return;
+         VXS_RETURN_M_SV(VNUMIFY(lobj));
      }
 }
 
@@ -288,10 +305,7 @@ VXS(version_normal)
          SV *  ver;
          VTYPECHECK(ver, ST(0), "ver");
 
-         mPUSHs(VNORMAL(ver));
-
-         PUTBACK;
-         return;
+         VXS_RETURN_M_SV(VNORMAL(ver));
      }
 }
 
@@ -326,11 +340,8 @@ VXS(version_vcmp)
                    rs = newSViv(VCMP(lobj,rvs));
               }
 
-              mPUSHs(rs);
+              VXS_RETURN_M_SV(rs);
          }
-
-         PUTBACK;
-         return;
      }
 }
 
@@ -351,9 +362,7 @@ VXS(version_boolean)
                                    ))
                         )
                   );
-       mPUSHs(rs);
-       PUTBACK;
-       return;
+       VXS_RETURN_M_SV(rs);
     }
 }