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.

diff --git a/cpan/version/lib/version.pm b/cpan/version/lib/version.pm
index e20fb6e..280c859 100644 (file)
--- a/cpan/version/lib/version.pm
+++ b/cpan/version/lib/version.pm
@@ -1,12 +1,12 @@
 #!perl -w
 package version;
 
-use 5.005_04;
+use 5.006002;
 use strict;
 
 use vars qw(@ISA $VERSION $CLASS $STRICT $LAX *declare *qv);
 
-$VERSION = 0.9906;
+$VERSION = 0.9907;
 $CLASS = 'version';
 
 # avoid using Exporter

diff --git a/cpan/version/lib/version/regex.pm b/cpan/version/lib/version/regex.pm
index 341902e..1c8f6e1 100644 (file)
--- a/cpan/version/lib/version/regex.pm
+++ b/cpan/version/lib/version/regex.pm
@@ -4,7 +4,7 @@ use strict;
 
 use vars qw($VERSION $CLASS $STRICT $LAX);
 
-$VERSION = 0.9906;
+$VERSION = 0.9907;
 
 #--------------------------------------------------------------------------#
 # Version regexp components

diff --git a/cpan/version/lib/version/vpp.pm b/cpan/version/lib/version/vpp.pm
index 13e5a7e..76b9119 100644 (file)
--- a/cpan/version/lib/version/vpp.pm
+++ b/cpan/version/lib/version/vpp.pm
@@ -117,13 +117,12 @@ sub currstr {
 
 package version::vpp;
 
-use 5.005_04;
+use 5.006002;
 use strict;
 
-use POSIX qw/locale_h/;
-use locale;
+use Config;
 use vars qw($VERSION $CLASS @ISA $LAX $STRICT);
-$VERSION = 0.9906;
+$VERSION = 0.9907;
 $CLASS = 'version::vpp';
 
 require version::regex;
@@ -479,7 +478,7 @@ sub scan_version {
     if ($errstr) {
        # 'undef' is a special case and not an error
        if ( $s ne 'undef') {
-           use Carp;
+           require Carp;
            Carp::croak($errstr);
        }
     }
@@ -654,13 +653,17 @@ sub new
            return $self;
        }
 
-       my $currlocale = setlocale(LC_ALL);
+       if ($Config{d_setlocale}) {
+           use POSIX qw/locale_h/;
+           use if $Config{d_setlocale}, 'locale';
+           my $currlocale = setlocale(LC_ALL);
 
-       # if the current locale uses commas for decimal points, we
-       # just replace commas with decimal places, rather than changing
-       # locales
-       if ( localeconv()->{decimal_point} eq ',' ) {
-           $value =~ tr/,/./;
+           # if the current locale uses commas for decimal points, we
+           # just replace commas with decimal places, rather than changing
+           # locales
+           if ( localeconv()->{decimal_point} eq ',' ) {
+               $value =~ tr/,/./;
+           }
        }
 
        if ( not defined $value or $value =~ /^undef$/ ) {

diff --git a/cpan/version/t/00impl-pp.t b/cpan/version/t/00impl-pp.t
index c62889f..836a75a 100644 (file)
--- a/cpan/version/t/00impl-pp.t
+++ b/cpan/version/t/00impl-pp.t
@@ -9,7 +9,7 @@ use Test::More qw/no_plan/;
 BEGIN {
     (my $coretests = $0) =~ s'[^/]+\.t'coretests.pm';
     require $coretests;
-    use_ok('version::vpp', 0.9906);
+    use_ok('version::vpp', 0.9907);
 }
 
 BaseTests("version::vpp","new","qv");

diff --git a/cpan/version/t/01base.t b/cpan/version/t/01base.t
index 41ba0f6..3c7edcf 100644 (file)
--- a/cpan/version/t/01base.t
+++ b/cpan/version/t/01base.t
@@ -9,7 +9,7 @@ use Test::More qw/no_plan/;
 BEGIN {
     (my $coretests = $0) =~ s'[^/]+\.t'coretests.pm';
     require $coretests;
-    use_ok('version', 0.9906);
+    use_ok('version', 0.9907);
 }
 
 BaseTests("version","new","qv");

diff --git a/cpan/version/t/02derived.t b/cpan/version/t/02derived.t
index 9f2f97e..5bd4437 100644 (file)
--- a/cpan/version/t/02derived.t
+++ b/cpan/version/t/02derived.t
@@ -10,7 +10,7 @@ use File::Temp qw/tempfile/;
 BEGIN {
     (my $coretests = $0) =~ s'[^/]+\.t'coretests.pm';
     require $coretests;
-    use_ok("version", 0.9906);
+    use_ok("version", 0.9907);
     # If we made it this far, we are ok.
 }
 

diff --git a/cpan/version/t/03require.t b/cpan/version/t/03require.t
index d480c88..48ddcd6 100644 (file)
--- a/cpan/version/t/03require.t
+++ b/cpan/version/t/03require.t
@@ -14,7 +14,7 @@ BEGIN {
 # Don't want to use, because we need to make sure that the import doesn't
 # fire just yet (some code does this to avoid importing qv() and delare()).
 require_ok("version");
-is $version::VERSION, 0.9906, "Make sure we have the correct class";
+is $version::VERSION, 0.9907, "Make sure we have the correct class";
 ok(!"main"->can("qv"), "We don't have the imported qv()");
 ok(!"main"->can("declare"), "We don't have the imported declare()");
 

diff --git a/cpan/version/t/05sigdie.t b/cpan/version/t/05sigdie.t
index 5fe5210..a145450 100644 (file)
--- a/cpan/version/t/05sigdie.t
+++ b/cpan/version/t/05sigdie.t
@@ -14,7 +14,7 @@ BEGIN {
 }
 
 BEGIN {
-    use version 0.9906;
+    use version 0.9907;
 }
 
 pass "Didn't get caught by the wrong DIE handler, which is a good thing";

diff --git a/cpan/version/t/06noop.t b/cpan/version/t/06noop.t
index 8db4c75..97c7e65 100644 (file)
--- a/cpan/version/t/06noop.t
+++ b/cpan/version/t/06noop.t
@@ -7,7 +7,7 @@
 use Test::More qw/no_plan/;
 
 BEGIN {
-    use_ok('version', 0.9906);
+    use_ok('version', 0.9907);
 }
 
 my $v1 = version->new('1.2');

diff --git a/cpan/version/t/07locale.t b/cpan/version/t/07locale.t
index 3503b6f..de6588c 100644 (file)
--- a/cpan/version/t/07locale.t
+++ b/cpan/version/t/07locale.t
@@ -11,7 +11,7 @@ use Test::More tests => 7;
 use Config;
 
 BEGIN {
-    use_ok('version', 0.9906);
+    use_ok('version', 0.9907);
 }
 
 SKIP: {

diff --git a/cpan/version/t/08_corelist.t b/cpan/version/t/08_corelist.t
index 8cd2e14..48c61c3 100644 (file)
--- a/cpan/version/t/08_corelist.t
+++ b/cpan/version/t/08_corelist.t
@@ -5,7 +5,7 @@
 #########################
 
 use Test::More tests => 3;
-use_ok("version", 0.9906);
+use_ok("version", 0.9907);
 
 # do strict lax tests in a sub to isolate a package to test importing
 SKIP: {

diff --git a/cpan/version/t/09_list_util.t b/cpan/version/t/09_list_util.t
index 6348f9d..110c1a0 100644 (file)
--- a/cpan/version/t/09_list_util.t
+++ b/cpan/version/t/09_list_util.t
@@ -4,7 +4,7 @@
 #########################
 
 use strict;
-use_ok("version", 0.9906);
+use_ok("version", 0.9907);
 use Test::More;
 
 BEGIN {

diff --git a/vutil.c b/vutil.c
index 6cbfc72..7979c49 100644 (file)
--- a/vutil.c
+++ b/vutil.c
@@ -2,6 +2,7 @@
    editing it in the perl core. */
 
 #ifndef PERL_CORE
+#  define PERL_NO_GET_CONTEXT
 #  include "EXTERN.h"
 #  include "perl.h"
 #  include "XSUB.h"
@@ -283,8 +284,7 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
     last = PRESCAN_VERSION(s, FALSE, &errstr, &qv, &saw_decimal, &width, &alpha);
     if (errstr) {
        /* "undef" is a special case and not an error */
-       if ( ! ( *s == 'u' && strEQ(s,"undef")) ) {
-           Safefree(start);
+       if ( ! ( *s == 'u' && strEQ(s+1,"ndef")) ) {
            Perl_croak(aTHX_ "%s", errstr);
        }
     }
@@ -396,7 +396,7 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
        }
     }
     if ( qv ) { /* quoted versions always get at least three terms*/
-       SSize_t len = av_len(av);
+       SSize_t len = AvFILLp(av);
        /* This for loop appears to trigger a compiler bug on OS X, as it
           loops infinitely. Yes, len is negative. No, it makes no sense.
           Compiler in question is:
@@ -432,7 +432,7 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
     (void)hv_stores(MUTABLE_HV(hv), "version", newRV_noinc(MUTABLE_SV(av)));
 
     /* fix RT#19517 - special case 'undef' as string */
-    if ( *s == 'u' && strEQ(s,"undef") ) {
+    if ( *s == 'u' && strEQ(s+1,"ndef") ) {
        s += 5;
     }
 
@@ -462,7 +462,7 @@ Perl_new_version(pTHX_ SV *ver)
     dVAR;
     SV * const rv = newSV(0);
     PERL_ARGS_ASSERT_NEW_VERSION;
-    if ( ISA_CLASS_OBJ(ver,"version") ) /* can just copy directly */
+    if ( ISA_VERSION_OBJ(ver) ) /* can just copy directly */
     {
        SSize_t key;
        AV * const av = newAV();
@@ -483,24 +483,24 @@ Perl_new_version(pTHX_ SV *ver)
 
        if ( hv_exists(MUTABLE_HV(ver), "alpha", 5) )
            (void)hv_stores(MUTABLE_HV(hv), "alpha", newSViv(1));
-
-       if ( hv_exists(MUTABLE_HV(ver), "width", 5 ) )
        {
-           const I32 width = SvIV(*hv_fetchs(MUTABLE_HV(ver), "width", FALSE));
-           (void)hv_stores(MUTABLE_HV(hv), "width", newSViv(width));
+           SV ** svp = hv_fetchs(MUTABLE_HV(ver), "width", FALSE);
+           if(svp) {
+               const I32 width = SvIV(*svp);
+               (void)hv_stores(MUTABLE_HV(hv), "width", newSViv(width));
+           }
        }
-
-       if ( hv_exists(MUTABLE_HV(ver), "original", 8 ) )
        {
-           SV * pv = *hv_fetchs(MUTABLE_HV(ver), "original", FALSE);
-           (void)hv_stores(MUTABLE_HV(hv), "original", newSVsv(pv));
+           SV ** svp = hv_fetchs(MUTABLE_HV(ver), "original", FALSE);
+           if(svp)
+               (void)hv_stores(MUTABLE_HV(hv), "original", newSVsv(*svp));
        }
-
        sav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(ver), "version", FALSE)));
        /* This will get reblessed later if a derived class*/
        for ( key = 0; key <= av_len(sav); key++ )
        {
-           const I32 rev = SvIV(*av_fetch(sav, key, FALSE));
+           SV * const sv = *av_fetch(sav, key, FALSE);
+           const I32 rev = SvIV(sv);
            av_push(av, newSViv(rev));
        }
 
@@ -512,12 +512,11 @@ Perl_new_version(pTHX_ SV *ver)
        const MAGIC* const mg = SvVSTRING_mg(ver);
        if ( mg ) { /* already a v-string */
            const STRLEN len = mg->mg_len;
-           char * const version = savepvn( (const char*)mg->mg_ptr, len);
+           const char * const version = (const char*)mg->mg_ptr;
            sv_setpvn(rv,version,len);
            /* this is for consistency with the pure Perl class */
            if ( isDIGIT(*version) )
                sv_insert(rv, 0, 0, "v", 1);
-           Safefree(version);
        }
        else {
 #endif
@@ -556,7 +555,7 @@ Perl_upg_version(pTHX_ SV *ver, bool qv)
 
     PERL_ARGS_ASSERT_UPG_VERSION;
 
-    if ( SvNOK(ver) && !( SvPOK(ver) && sv_len(ver) == 3 ) )
+    if ( SvNOK(ver) && !( SvPOK(ver) && SvCUR(ver) == 3 ) )
     {
        STRLEN len;
 
@@ -578,11 +577,13 @@ Perl_upg_version(pTHX_ SV *ver, bool qv)
        while (buf[len-1] == '0' && len > 0) len--;
        if ( buf[len-1] == '.' ) len--; /* eat the trailing decimal */
        version = savepvn(buf, len);
+       SAVEFREEPV(version);
        SvREFCNT_dec(sv);
     }
 #ifdef SvVOK
     else if ( (mg = SvVSTRING_mg(ver)) ) { /* already a v-string */
        version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
+       SAVEFREEPV(version);
        qv = TRUE;
     }
 #endif
@@ -593,16 +594,19 @@ Perl_upg_version(pTHX_ SV *ver, bool qv)
        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 */
     {
        STRLEN len;
        version = savepvn(SvPV(ver,len), SvCUR(ver));
+       SAVEFREEPV(version);
 #ifndef SvVOK
 #  if PERL_VERSION > 5
        /* This will only be executed for 5.6.0 - 5.8.0 inclusive */
@@ -619,6 +623,7 @@ Perl_upg_version(pTHX_ SV *ver, bool qv)
                    int saw_decimal = 0;
                    sv_setpvf(nsv,"v%vd",ver);
                    pos = nver = savepv(SvPV_nolen(nsv));
+                    SAVEFREEPV(pos);
 
                    /* scan the resulting formatted string */
                    pos++; /* skip the leading 'v' */
@@ -630,7 +635,6 @@ Perl_upg_version(pTHX_ SV *ver, bool qv)
 
                    /* is definitely a v-string */
                    if ( saw_decimal >= 2 ) {
-                       Safefree(version);
                        version = nver;
                    }
                    break;
@@ -651,7 +655,6 @@ Perl_upg_version(pTHX_ SV *ver, bool qv)
        Perl_ck_warner(aTHX_ packWARN(WARN_MISC), 
                       "Version string '%s' contains invalid data; "
                       "ignoring: '%s'", version, s);
-    Safefree(version);
     return ver;
 }
 
@@ -689,6 +692,7 @@ Perl_vverify(pTHX_ SV *vs)
 #endif
 {
     SV *sv;
+    SV **svp;
 
     PERL_ARGS_ASSERT_VVERIFY;
 
@@ -697,8 +701,8 @@ Perl_vverify(pTHX_ SV *vs)
 
     /* see if the appropriate elements exist */
     if ( SvTYPE(vs) == SVt_PVHV
-        && hv_exists(MUTABLE_HV(vs), "version", 7)
-        && (sv = SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE)))
+        && (svp = hv_fetchs(MUTABLE_HV(vs), "version", FALSE))
+        && (sv = SvRV(*svp))
         && SvTYPE(sv) == SVt_PVAV )
        return vs;
     else
@@ -745,10 +749,13 @@ Perl_vnumify(pTHX_ SV *vs)
     /* see if various flags exist */
     if ( hv_exists(MUTABLE_HV(vs), "alpha", 5 ) )
        alpha = TRUE;
-    if ( hv_exists(MUTABLE_HV(vs), "width", 5 ) )
-       width = SvIV(*hv_fetchs(MUTABLE_HV(vs), "width", FALSE));
-    else
-       width = 3;
+    {
+       SV ** svp = hv_fetchs(MUTABLE_HV(vs), "width", FALSE);
+       if ( svp )
+           width = SvIV(*svp);
+       else
+           width = 3;
+    }
 
 
     /* attempt to retrieve the version array */
@@ -762,11 +769,15 @@ Perl_vnumify(pTHX_ SV *vs)
        return newSVpvs("0");
     }
 
-    digit = SvIV(*av_fetch(av, 0, 0));
+    {
+       SV * tsv = *av_fetch(av, 0, 0);
+       digit = SvIV(tsv);
+    }
     sv = Perl_newSVpvf(aTHX_ "%d.", (int)PERL_ABS(digit));
     for ( i = 1 ; i < len ; i++ )
     {
-       digit = SvIV(*av_fetch(av, i, 0));
+       SV * tsv = *av_fetch(av, i, 0);
+       digit = SvIV(tsv);
        if ( width < 3 ) {
            const int denom = (width == 2 ? 10 : 100);
            const div_t term = div((int)PERL_ABS(digit),denom);
@@ -779,7 +790,8 @@ Perl_vnumify(pTHX_ SV *vs)
 
     if ( len > 0 )
     {
-       digit = SvIV(*av_fetch(av, len, 0));
+       SV * tsv = *av_fetch(av, len, 0);
+       digit = SvIV(tsv);
        if ( alpha && width == 3 ) /* alpha version */
            sv_catpvs(sv,"_");
        Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit);
@@ -835,17 +847,22 @@ Perl_vnormal(pTHX_ SV *vs)
     {
        return newSVpvs("");
     }
-    digit = SvIV(*av_fetch(av, 0, 0));
+    {
+       SV * tsv = *av_fetch(av, 0, 0);
+       digit = SvIV(tsv);
+    }
     sv = Perl_newSVpvf(aTHX_ "v%"IVdf, (IV)digit);
     for ( i = 1 ; i < len ; i++ ) {
-       digit = SvIV(*av_fetch(av, i, 0));
+       SV * tsv = *av_fetch(av, i, 0);
+       digit = SvIV(tsv);
        Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
     }
 
     if ( len > 0 )
     {
        /* handle last digit specially */
-       digit = SvIV(*av_fetch(av, len, 0));
+       SV * tsv = *av_fetch(av, len, 0);
+       digit = SvIV(tsv);
        if ( alpha )
            Perl_sv_catpvf(aTHX_ sv, "_%"IVdf, (IV)digit);
        else
@@ -879,6 +896,7 @@ Perl_vstringify2(pTHX_ SV *vs)
 Perl_vstringify(pTHX_ SV *vs)
 #endif
 {
+    SV ** svp;
     PERL_ARGS_ASSERT_VSTRINGIFY;
 
     /* extract the HV from the object */
@@ -886,9 +904,10 @@ Perl_vstringify(pTHX_ SV *vs)
     if ( ! vs )
        Perl_croak(aTHX_ "Invalid version object");
 
-    if (hv_exists(MUTABLE_HV(vs), "original",  sizeof("original") - 1)) {
+    svp = hv_fetchs(MUTABLE_HV(vs), "original", FALSE);
+    if (svp) {
        SV *pv;
-       pv = *hv_fetchs(MUTABLE_HV(vs), "original", FALSE);
+       pv = *svp;
        if ( SvPOK(pv) )
            return newSVsv(pv);
        else
@@ -951,8 +970,11 @@ Perl_vcmp(pTHX_ SV *lhv, SV *rhv)
     i = 0;
     while ( i <= m && retval == 0 )
     {
-       left  = SvIV(*av_fetch(lav,i,0));
-       right = SvIV(*av_fetch(rav,i,0));
+       SV * const lsv = *av_fetch(lav,i,0);
+       SV * rsv;
+       left = SvIV(lsv);
+       rsv = *av_fetch(rav,i,0);
+       right = SvIV(rsv);
        if ( left < right  )
            retval = -1;
        if ( left > right )
@@ -979,7 +1001,8 @@ Perl_vcmp(pTHX_ SV *lhv, SV *rhv)
        {
            while ( i <= r && retval == 0 )
            {
-               if ( SvIV(*av_fetch(rav,i,0)) != 0 )
+               SV * const rsv = *av_fetch(rav,i,0);
+               if ( SvIV(rsv) != 0 )
                    retval = -1; /* not a match after all */
                i++;
            }
@@ -988,7 +1011,8 @@ Perl_vcmp(pTHX_ SV *lhv, SV *rhv)
        {
            while ( i <= l && retval == 0 )
            {
-               if ( SvIV(*av_fetch(lav,i,0)) != 0 )
+               SV * const lsv = *av_fetch(lav,i,0);
+               if ( SvIV(lsv) != 0 )
                    retval = +1; /* not a match after all */
                i++;
            }

diff --git a/vutil.h b/vutil.h
index f86631d..aaf2284 100644 (file)
--- a/vutil.h
+++ b/vutil.h
@@ -83,7 +83,49 @@ Perl_ck_warner(pTHX_ U32 err, const char* pat, ...)
 #define PERL_VERSION_GE(r,v,s) \
        (PERL_DECIMAL_VERSION >= PERL_VERSION_DECIMAL(r,v,s))
 
-#define ISA_CLASS_OBJ(v,c) (sv_isobject(v) && sv_derived_from(v,c))
+#if PERL_VERSION_LT(5,15,4)
+#  define ISA_VERSION_OBJ(v) (sv_isobject(v) && sv_derived_from(v,"version"))
+#else
+#  define ISA_VERSION_OBJ(v) (sv_isobject(v) && sv_derived_from_pvn(v,"version",7,0))
+#endif
+
+
+#ifndef PERL_ARGS_ASSERT_CROAK_XS_USAGE
+#define PERL_ARGS_ASSERT_CROAK_XS_USAGE assert(cv); assert(params)
+
+/* prototype to pass -Wmissing-prototypes */
+STATIC void
+S_croak_xs_usage(pTHX_ const CV *const cv, const char *const params);
+
+STATIC void
+S_croak_xs_usage(pTHX_ const CV *const cv, const char *const params)
+{
+    const GV *const gv = CvGV(cv);
+
+    PERL_ARGS_ASSERT_CROAK_XS_USAGE;
+
+    if (gv) {
+        const char *const gvname = GvNAME(gv);
+        const HV *const stash = GvSTASH(gv);
+        const char *const hvname = stash ? HvNAME(stash) : NULL;
+
+        if (hvname)
+            Perl_croak_nocontext("Usage: %s::%s(%s)", hvname, gvname, params);
+        else
+            Perl_croak_nocontext("Usage: %s(%s)", gvname, params);
+    } else {
+        /* Pants. I don't think that it should be possible to get here. */
+        Perl_croak_nocontext("Usage: CODE(0x%"UVxf")(%s)", PTR2UV(cv), params);
+    }
+}
+
+#ifdef PERL_IMPLICIT_CONTEXT
+#define croak_xs_usage(a,b)    S_croak_xs_usage(aTHX_ a,b)
+#else
+#define croak_xs_usage         S_croak_xs_usage
+#endif
+
+#endif
 
 #if PERL_VERSION_GE(5,9,0) && !defined(PERL_CORE)
 
@@ -109,8 +151,10 @@ const char * Perl_prescan_version2(pTHX_ const char *s, bool strict, const char*
 #  define VNORMAL(a)           Perl_vnormal2(aTHX_ a)
 #  define VCMP(a,b)            Perl_vcmp2(aTHX_ a,b)
 #  define PRESCAN_VERSION(a,b,c,d,e,f,g)       Perl_prescan_version2(aTHX_ a,b,c,d,e,f,g)
+#  undef is_LAX_VERSION
 #  define is_LAX_VERSION(a,b) \
        (a != Perl_prescan_version2(aTHX_ a, FALSE, b, NULL, NULL, NULL, NULL))
+#  undef is_STRICT_VERSION
 #  define is_STRICT_VERSION(a,b) \
        (a != Perl_prescan_version2(aTHX_ a, TRUE, b, NULL, NULL, NULL, NULL))
 
@@ -177,3 +221,21 @@ const char * Perl_prescan_version(pTHX_ const char *s, bool strict, const char**
 #  define PERL_ARGS_ASSERT_CK_WARNER      \
        assert(pat)
 #endif
+
+
+#if PERL_VERSION_LT(5,19,0)
+# undef STORE_NUMERIC_LOCAL_SET_STANDARD
+# undef RESTORE_NUMERIC_LOCAL
+# ifdef USE_LOCALE
+#  define STORE_NUMERIC_LOCAL_SET_STANDARD()\
+       char *loc = savepv(setlocale(LC_NUMERIC, NULL)); \
+       SAVEFREEPV(loc); \
+       setlocale(LC_NUMERIC, "C");
+
+#  define RESTORE_NUMERIC_LOCAL()\
+       setlocale(LC_NUMERIC, loc);
+# else
+#  define STORE_NUMERIC_LOCAL_SET_STANDARD()
+#  define RESTORE_NUMERIC_LOCAL()
+# endif
+#endif

diff --git a/vxs.inc b/vxs.inc
index 2e4f409..0a02056 100644 (file)
--- 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