Import version.pm 0.9914 from CPAN
authorJohn Peacock <jpeacock@cpan.org>
Wed, 17 Feb 2016 03:34:52 +0000 (21:34 -0600)
committerRicardo Signes <rjbs@cpan.org>
Fri, 18 Mar 2016 00:51:15 +0000 (20:51 -0400)
17 files changed:
cpan/version/lib/version.pm
cpan/version/lib/version.pod
cpan/version/lib/version/Internals.pod
cpan/version/lib/version/regex.pm
cpan/version/t/01base.t
cpan/version/t/02derived.t
cpan/version/t/03require.t
cpan/version/t/05sigdie.t
cpan/version/t/06noop.t
cpan/version/t/07locale.t
cpan/version/t/08_corelist.t
cpan/version/t/09_list_util.t
cpan/version/t/10_lyon.t [new file with mode: 0644]
cpan/version/t/coretests.pm
vutil.c
vutil.h
vxs.inc

index f8afd84..d20427c 100644 (file)
@@ -3,10 +3,14 @@ package version;
 
 use 5.006002;
 use strict;
+use warnings::register;
+if ($] >= 5.015) {
+    warnings::register_categories(qw/version/);
+}
 
 use vars qw(@ISA $VERSION $CLASS $STRICT $LAX *declare *qv);
 
-$VERSION = 0.9909;
+$VERSION = 0.9914;
 $CLASS = 'version';
 
 # avoid using Exporter
index 40ceee2..42691b1 100644 (file)
@@ -12,8 +12,8 @@ version - Perl extension for Version Objects
   # Declaring a dotted-decimal $VERSION (keep on one line!)
 
   use version; our $VERSION = version->declare("v1.2.3"); # formal
-  use version; our $VERSION = qv("v1.2.3");               # shorthand
-  use version; our $VERSION = qv("v1.2_3");               # alpha
+  use version; our $VERSION = qv("v1.2.3");               # deprecated
+  use version; our $VERSION = qv("v1.2_3");               # deprecated
 
   # Declaring an old-style decimal $VERSION (use quotes!)
 
@@ -270,7 +270,7 @@ Returns a value representing the object in a pure decimal form without
 trailing zeroes.
 
  version->declare('v1.2')->numify;  # 1.002
- version->parse('1.2')->numify;     # 1.2
+ version->parse('1.2')->numify;     # 1.200
 
 =head2 stringify()
 
index 95be844..dd784fe 100644 (file)
@@ -21,14 +21,14 @@ There are actually two distinct kinds of version objects:
 
 =over 4
 
-=item Decimal Versions
+=item Decimal versions
 
 Any version which "looks like a number", see L<Decimal Versions>.  This
 also includes versions with a single decimal point and a single embedded
 underscore, see L<Alpha Versions>, even though these must be quoted
 to preserve the underscore formatting.
 
-=item Dotted-Decimal Versions
+=item Dotted-Decimal versions
 
 Also referred to as "Dotted-Integer", these contains more than one decimal
 point and may have an optional embedded underscore, see L<Dotted-Decimal
index f732963..dc769c2 100644 (file)
@@ -4,7 +4,7 @@ use strict;
 
 use vars qw($VERSION $CLASS $STRICT $LAX);
 
-$VERSION = 0.9909;
+$VERSION = 0.9914;
 
 #--------------------------------------------------------------------------#
 # Version regexp components
index 6174194..4c1a23d 100644 (file)
@@ -5,11 +5,14 @@
 #########################
 
 use Test::More qw/no_plan/;
+use File::Spec;
 
 BEGIN {
-    (my $coretests = $0) =~ s'[^/]+\.t'coretests.pm';
+    my $coretests = File::Spec->catpath(
+        (File::Spec->splitpath($0))[0,1], 'coretests.pm'
+    );
     require $coretests;
-    use_ok('version', 0.9909);
+    use_ok('version', 0.9914);
 }
 
 BaseTests("version","new","qv");
index a5aa2e4..ac0dea9 100644 (file)
@@ -5,12 +5,15 @@
 #########################
 
 use Test::More qw/no_plan/;
+use File::Spec;
 use File::Temp qw/tempfile/;
 
 BEGIN {
-    (my $coretests = $0) =~ s'[^/]+\.t'coretests.pm';
+    my $coretests = File::Spec->catpath(
+        (File::Spec->splitpath($0))[0,1], 'coretests.pm'
+    );
     require $coretests;
-    use_ok("version", 0.9909);
+    use_ok("version", 0.9914);
     # If we made it this far, we are ok.
 }
 
index f6100ef..ed437be 100644 (file)
@@ -5,16 +5,19 @@
 #########################
 
 use Test::More qw/no_plan/;
+use File::Spec;
 
 BEGIN {
-    (my $coretests = $0) =~ s'[^/]+\.t'coretests.pm';
+    my $coretests = File::Spec->catpath(
+        (File::Spec->splitpath($0))[0,1], 'coretests.pm'
+    );
     require $coretests;
 }
 
 # 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.9909, "Make sure we have the correct class";
+is $version::VERSION, 0.9914, "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()");
 
index 0b82313..fad9139 100644 (file)
@@ -14,7 +14,7 @@ BEGIN {
 }
 
 BEGIN {
-    use version 0.9909;
+    use version 0.9914;
 }
 
 pass "Didn't get caught by the wrong DIE handler, which is a good thing";
index ed24602..e9f7187 100644 (file)
@@ -7,7 +7,7 @@
 use Test::More qw/no_plan/;
 
 BEGIN {
-    use_ok('version', 0.9909);
+    use_ok('version', 0.9914);
 }
 
 my $v1 = version->new('1.2');
index 7af61b5..22b9def 100644 (file)
@@ -7,11 +7,11 @@
 use File::Basename;
 use File::Temp qw/tempfile/;
 use POSIX qw/locale_h/;
-use Test::More tests => 7;
+use Test::More tests => 8;
 use Config;
 
 BEGIN {
-    use_ok('version', 0.9909);
+    use_ok('version', 0.9914);
 }
 
 SKIP: {
@@ -20,7 +20,7 @@ SKIP: {
            if(!$Config{d_setlocale});
 
        # test locale handling
-       my $warning;
+       my $warning = '';
 
        local $SIG{__WARN__} = sub { $warning = $_[0] };
 
@@ -38,7 +38,7 @@ SKIP: {
            $loc = setlocale( LC_ALL, $_);
            last if $loc && localeconv()->{decimal_point} eq ',';
        }
-       skip 'Cannot test locale handling without a comma locale', 5
+       skip 'Cannot test locale handling without a comma locale', 6
            unless $loc and localeconv()->{decimal_point} eq ',';
 
        setlocale(LC_NUMERIC, $loc);
@@ -50,11 +50,14 @@ SKIP: {
        ok ($v eq "1.23", "Locale doesn't apply to version objects");
        ok ($v == $ver, "Comparison to locale floating point");
 
+        TODO: { # Resolve https://rt.cpan.org/Ticket/Display.html?id=102272
+            local $TODO = 'Fails for Perl 5.x.0 < 5.19.0';
+            $ver = version->new($]);
+            is "$ver", "$]", 'Use PV for dualvars';
+        }
        setlocale( LC_ALL, $orig_loc); # reset this before possible skip
        skip 'Cannot test RT#46921 with Perl < 5.008', 1
            if ($] < 5.008);
-       skip 'Cannot test RT#46921 with pure Perl module', 1
-           if exists $INC{'version/vpp.pm'};
        my ($fh, $filename) = tempfile('tXXXXXXX', SUFFIX => '.pm', UNLINK => 1);
        (my $package = basename($filename)) =~ s/\.pm$//;
        print $fh <<"EOF";
@@ -79,169 +82,243 @@ EOF
 __DATA__
 af_ZA
 af_ZA.utf8
+af_ZA.UTF-8
 an_ES
 an_ES.utf8
+an_ES.UTF-8
 az_AZ.utf8
+az_AZ.UTF-8
 be_BY
 be_BY.utf8
+be_BY.UTF-8
 bg_BG
 bg_BG.utf8
+bg_BG.UTF-8
 br_FR
 br_FR@euro
 br_FR.utf8
+br_FR.UTF-8
 bs_BA
 bs_BA.utf8
+bs_BA.UTF-8
 ca_ES
 ca_ES@euro
 ca_ES.utf8
+ca_ES.UTF-8
 cs_CZ
 cs_CZ.utf8
+cs_CZ.UTF-8
 da_DK
 da_DK.utf8
+da_DK.UTF-8
 de_AT
 de_AT@euro
 de_AT.utf8
+de_AT.UTF-8
 de_BE
 de_BE@euro
 de_BE.utf8
+de_BE.UTF-8
 de_DE
 de_DE@euro
 de_DE.utf8
+de_DE.UTF-8
+de_DE.UTF-8
 de_LU
 de_LU@euro
 de_LU.utf8
+de_LU.UTF-8
 el_GR
 el_GR.utf8
+el_GR.UTF-8
 en_DK
 en_DK.utf8
+en_DK.UTF-8
 es_AR
 es_AR.utf8
+es_AR.UTF-8
 es_BO
 es_BO.utf8
+es_BO.UTF-8
 es_CL
 es_CL.utf8
+es_CL.UTF-8
 es_CO
 es_CO.utf8
+es_CO.UTF-8
 es_EC
 es_EC.utf8
+es_EC.UTF-8
 es_ES
 es_ES@euro
 es_ES.utf8
+es_ES.UTF-8
 es_PY
 es_PY.utf8
+es_PY.UTF-8
 es_UY
 es_UY.utf8
+es_UY.UTF-8
 es_VE
 es_VE.utf8
+es_VE.UTF-8
 et_EE
 et_EE.iso885915
 et_EE.utf8
+et_EE.UTF-8
 eu_ES
 eu_ES@euro
 eu_ES.utf8
+eu_ES.UTF-8
 fi_FI
 fi_FI@euro
 fi_FI.utf8
+fi_FI.UTF-8
 fo_FO
 fo_FO.utf8
+fo_FO.UTF-8
 fr_BE
 fr_BE@euro
 fr_BE.utf8
+fr_BE.UTF-8
 fr_CA
 fr_CA.utf8
+fr_CA.UTF-8
 fr_CH
 fr_CH.utf8
+fr_CH.UTF-8
 fr_FR
 fr_FR@euro
 fr_FR.utf8
+fr_FR.UTF-8
 fr_LU
 fr_LU@euro
 fr_LU.utf8
+fr_LU.UTF-8
 gl_ES
 gl_ES@euro
 gl_ES.utf8
+gl_ES.UTF-8
 hr_HR
 hr_HR.utf8
+hr_HR.UTF-8
 hu_HU
 hu_HU.utf8
+hu_HU.UTF-8
 id_ID
 id_ID.utf8
+id_ID.UTF-8
 is_IS
 is_IS.utf8
+is_IS.UTF-8
 it_CH
 it_CH.utf8
+it_CH.UTF-8
 it_IT
 it_IT@euro
 it_IT.utf8
+it_IT.UTF-8
 ka_GE
 ka_GE.utf8
+ka_GE.UTF-8
 kk_KZ
 kk_KZ.utf8
+kk_KZ.UTF-8
 kl_GL
 kl_GL.utf8
+kl_GL.UTF-8
 lt_LT
 lt_LT.utf8
+lt_LT.UTF-8
 lv_LV
 lv_LV.utf8
+lv_LV.UTF-8
 mk_MK
 mk_MK.utf8
+mk_MK.UTF-8
 mn_MN
 mn_MN.utf8
+mn_MN.UTF-8
 nb_NO
 nb_NO.utf8
+nb_NO.UTF-8
 nl_BE
 nl_BE@euro
 nl_BE.utf8
+nl_BE.UTF-8
 nl_NL
 nl_NL@euro
 nl_NL.utf8
+nl_NL.UTF-8
 nn_NO
 nn_NO.utf8
+nn_NO.UTF-8
 no_NO
 no_NO.utf8
+no_NO.UTF-8
 oc_FR
 oc_FR.utf8
+oc_FR.UTF-8
 pl_PL
 pl_PL.utf8
+pl_PL.UTF-8
 pt_BR
 pt_BR.utf8
+pt_BR.UTF-8
 pt_PT
 pt_PT@euro
 pt_PT.utf8
+pt_PT.UTF-8
 ro_RO
 ro_RO.utf8
+ro_RO.UTF-8
 ru_RU
 ru_RU.koi8r
 ru_RU.utf8
+ru_RU.UTF-8
 ru_UA
 ru_UA.utf8
+ru_UA.UTF-8
 se_NO
 se_NO.utf8
+se_NO.UTF-8
 sh_YU
 sh_YU.utf8
+sh_YU.UTF-8
 sk_SK
 sk_SK.utf8
+sk_SK.UTF-8
 sl_SI
 sl_SI.utf8
+sl_SI.UTF-8
 sq_AL
 sq_AL.utf8
+sq_AL.UTF-8
 sr_CS
 sr_CS.utf8
+sr_CS.UTF-8
 sv_FI
 sv_FI@euro
 sv_FI.utf8
+sv_FI.UTF-8
 sv_SE
 sv_SE.iso885915
 sv_SE.utf8
+sv_SE.UTF-8
 tg_TJ
 tg_TJ.utf8
+tg_TJ.UTF-8
 tr_TR
 tr_TR.utf8
+tr_TR.UTF-8
 tt_RU.utf8
+tt_RU.UTF-8
 uk_UA
 uk_UA.utf8
+uk_UA.UTF-8
 vi_VN
 vi_VN.tcvn
 wa_BE
 wa_BE@euro
 wa_BE.utf8
+wa_BE.UTF-8
index d7829c1..d8cd147 100644 (file)
@@ -5,7 +5,7 @@
 #########################
 
 use Test::More tests => 3;
-use_ok("version", 0.9909);
+use_ok("version", 0.9914);
 
 # do strict lax tests in a sub to isolate a package to test importing
 SKIP: {
index dbd387d..bb6d3ec 100644 (file)
@@ -4,7 +4,7 @@
 #########################
 
 use strict;
-use_ok("version", 0.9909);
+use_ok("version", 0.9914);
 use Test::More;
 
 BEGIN {
diff --git a/cpan/version/t/10_lyon.t b/cpan/version/t/10_lyon.t
new file mode 100644 (file)
index 0000000..4f927aa
--- /dev/null
@@ -0,0 +1,44 @@
+#! perl
+
+use Test::More qw/no_plan/;
+
+use version;
+
+# These values are from the Lyon consensus, as taken from
+# https://gist.github.com/dagolden/9559280
+
+ok(version->new(1.0203) == version->new('1.0203'));
+ok(version->new(1.02_03) == version->new('1.02_03'));
+ok(version->new(v1.2.3) == version->new('v1.2.3'));
+if ($] >= 5.008_001) {
+    ok(version->new(v1.2.3_0) == version->new('v1.2.3_0'));
+}
+
+cmp_ok(version->new(1.0203), '==', version->new('1.0203'));
+cmp_ok(version->new(1.02_03), '==', version->new('1.02_03'));
+cmp_ok(version->new(v1.2.3), '==', version->new('v1.2.3'));
+if ($] >= 5.008_001) {
+    cmp_ok(version->new(v1.2.3_0), '==', version->new('v1.2.3_0'));
+}
+
+cmp_ok(version->new('1.0203')->numify, '==', '1.0203');
+is(version->new('1.0203')->normal, 'v1.20.300');
+
+cmp_ok(version->new('1.02_03')->numify, '==', '1.0203');
+is(version->new('1.02_03')->normal, 'v1.20.300');
+
+cmp_ok(version->new('v1.2.30')->numify, '==', '1.002030');
+is(version->new('v1.2.30')->normal, 'v1.2.30');
+cmp_ok(version->new('v1.2.3_0')->numify, '==', '1.002030');
+is(version->new('v1.2.3_0')->normal, 'v1.2.30');
+
+is(version->new("1.0203")->stringify, "1.0203");
+is(version->new("1.02_03")->stringify, "1.02_03");
+is(version->new("v1.2.30")->stringify, "v1.2.30");
+is(version->new("v1.2.3_0")->stringify, "v1.2.3_0");
+is(version->new(1.0203)->stringify, "1.0203");
+is(version->new(1.02_03)->stringify, "1.0203");
+is(version->new(v1.2.30)->stringify, "v1.2.30");
+if ($] >= 5.008_001) {
+    is(version->new(v1.2.3_0)->stringify, "v1.2.30");
+}
index 17bf9ec..07cc82e 100644 (file)
@@ -10,7 +10,7 @@ if ($Test::More::VERSION < 0.48) { # Fix for RT#48268
     *main::use_ok = sub ($;@) {
        my ($pkg, $req, @args) = @_;
        eval "use $pkg $req ".join(' ',@args);
-       is ${"$pkg\::VERSION"}, $req, 'Had to manually use version';
+       is ${"$pkg\::VERSION"}, eval($req), 'Had to manually use version';
        # If we made it this far, we are ok.
     };
 }
@@ -132,8 +132,8 @@ sub BaseTests {
     ok ( $version != $new_version, '$version != $new_version' );
 
     $version = $CLASS->$method("1.2.4");
-    ok ( $version > $new_version, '$version > $new_version' );
-    ok ( $new_version < $version, '$new_version < $version' );
+    ok ( $version < $new_version, '$version < $new_version' );
+    ok ( $new_version > $version, '$new_version > $version' );
     ok ( $version != $new_version, '$version != $new_version' );
 
     # now test with alpha version form with object
@@ -146,24 +146,22 @@ sub BaseTests {
     ok ( $new_version->is_alpha, '$new_version->is_alpha');
 
     $version = $CLASS->$method("1.2.4");
-    ok ( $version > $new_version, '$version > $new_version' );
-    ok ( $new_version < $version, '$new_version < $version' );
+    ok ( $version < $new_version, '$version < $new_version' );
+    ok ( $new_version > $version, '$new_version > $version' );
     ok ( $version != $new_version, '$version != $new_version' );
 
-    $version = $CLASS->$method("1.2.3.4");
+    $version = $CLASS->$method("1.2.34");
     $new_version = $CLASS->$method("1.2.3_4");
-    ok ( $version > $new_version, '$version > $new_version' );
-    ok ( $new_version < $version, '$new_version < $version' );
-    ok ( $version != $new_version, '$version != $new_version' );
+    ok ( $version == $new_version, '$version == $new_version' );
 
-    $version = $CLASS->$method("v1.2.3");
-    $new_version = $CLASS->$method("1.2.3.0");
+    $version = $CLASS->$method("v1.2.30");
+    $new_version = $CLASS->$method("1.2.30.0");
     ok ( $version == $new_version, '$version == $new_version' );
     $new_version = $CLASS->$method("1.2.3_0");
     ok ( $version == $new_version, '$version == $new_version' );
-    $new_version = $CLASS->$method("1.2.3.1");
+    $new_version = $CLASS->$method("1.2.30.1");
     ok ( $version < $new_version, '$version < $new_version' );
-    $new_version = $CLASS->$method("1.2.3_1");
+    $new_version = $CLASS->$method("1.2.30_1");
     ok ( $version < $new_version, '$version < $new_version' );
     $new_version = $CLASS->$method("1.1.999");
     ok ( $version > $new_version, '$version > $new_version' );
@@ -348,9 +346,10 @@ SKIP:      {
        skip 'Cannot test bare alpha v-strings with Perl < 5.8.1', 2
                if $] lt 5.008_001;
        $version = $CLASS->$method(v1.2.3_4);
-       is($version, "v1.2.3_4", '"$version" eq "v1.2.3_4"');
+       $DB::single = 1;
+       is($version, "v1.2.34", '"$version" eq "v1.2.34"');
        $version = $CLASS->$method(eval "v1.2.3_4");
-       is($version, "v1.2.3_4", '"$version" eq "v1.2.3_4" (from eval)');
+       is($version, "v1.2.34", '"$version" eq "v1.2.34" (from eval)');
     }
 
     # trailing zero testing (reported by Andreas Koenig).
@@ -592,7 +591,48 @@ SKIP: {
        eval {my $v = $CLASS->new({1 => 2}) };
        like $@, qr/Invalid version format/, 'Do not crash for garbage';
     }
-
+    { # https://rt.cpan.org/Ticket/Display.html?id=93603
+       eval {my $v = $CLASS->$method('.1.')};
+       like $@, qr/trailing decimal/, 'Forbid trailing decimals';
+       eval {my $v = $CLASS->$method('.1.2.')};
+       like $@, qr/trailing decimal/, 'Forbid trailing decimals';
+    }
+    { # https://rt.cpan.org/Ticket/Display.html?id=93715
+       eval {my $v = $CLASS->new(v1.2)};
+       unlike $@, qr/non-numeric data/, 'Handle short v-strings';
+       eval {my $v = $CLASS->new(v1)};
+       unlike $@, qr/non-numeric data/, 'Handle short v-strings';
+    }
+    {
+       my $two31 = '2147483648';
+       my $v = $CLASS->new($two31);
+       is "$v", 'v.Inf', 'Element Exceeds VERSION_MAX';
+       like $warning, qr/Integer overflow in version/, 'Overflow warning';
+       $v = $CLASS->new("1.$two31.$two31");
+       is "$v", 'v.Inf', 'Element Exceeds VERSION_MAX';
+       like $warning, qr/Integer overflow in version/, 'Overflow warning';
+    }
+    {
+       # now as a number
+       $two31 = 2**31;
+       $v = $CLASS->new($two31);
+       is "$v", 'v.Inf', 'Element Exceeds VERSION_MAX';
+       like $warning, qr/Integer overflow in version/, 'Overflow warning';
+    }
+    { # https://rt.cpan.org/Ticket/Display.html?id=101628
+       undef $warning;
+       $v = $CLASS->new('1.1.00000000010');
+       is $v->normal, "v1.1.10", 'Ignore leading zeros';
+       unlike $warning, qr/Integer overflow in version/, 'No overflow warning';
+    }
+    { # https://rt.cpan.org/Ticket/Display.html?id=93340
+       $v = $CLASS->parse(q[2.6_01]);
+       is $v->normal, 'v2.601.0', 'Normal strips underscores from alphas'
+    }
+    { # https://rt.cpan.org/Ticket/Display.html?id=98744
+       $v = $CLASS->new("1.02_003");
+       is $v->numify, '1.020030', 'Ignore underscores for numify';
+    }
 }
 
 1;
diff --git a/vutil.c b/vutil.c
index 20fb522..e43d2b2 100644 (file)
--- a/vutil.c
+++ b/vutil.c
@@ -1,25 +1,13 @@
 /* This file is part of the "version" CPAN distribution.  Please avoid
    editing it in the perl core. */
 
-#ifndef PERL_CORE
-#  define PERL_NO_GET_CONTEXT
-#  include "EXTERN.h"
-#  include "perl.h"
-#  include "XSUB.h"
-#  define NEED_my_snprintf
-#  define NEED_newRV_noinc
-#  define NEED_vnewSVpvf
-#  define NEED_newSVpvn_flags_GLOBAL
-#  define NEED_warner
-#  include "ppport.h"
+#ifdef PERL_CORE
+#  include "vutil.h"
 #endif
-#include "vutil.h"
 
 #define VERSION_MAX 0x7FFFFFFF
 
 /*
-=head1 Versioning
-
 =for apidoc prescan_version
 
 Validate that a given string can be parsed as a version object, but doesn't
@@ -43,7 +31,7 @@ Perl_prescan_version(pTHX_ const char *s, bool strict,
     bool alpha = FALSE;
     const char *d = s;
 
-    PERL_ARGS_ASSERT_PRESCAN_VERSION;
+    PERL_ARGS_ASSERT_PRESCAN_VERSION; PERL_UNUSED_CONTEXT;
 
     if (qv && isDIGIT(*d))
        goto dotted_decimal_version;
@@ -226,6 +214,11 @@ version_prescan_finish:
        /* trailing non-numeric data */
        BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
     }
+    if (saw_decimal > 1 && d[-1] == '.') {
+       /* no trailing period allowed */
+       BADVERSION(s,errstr,"Invalid version format (trailing decimal)");
+    }
+
 
     if (sqv)
        *sqv = qv;
@@ -312,7 +305,7 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
     if ( !qv && width < 3 )
        (void)hv_stores(MUTABLE_HV(hv), "width", newSViv(width));
 
-    while (isDIGIT(*pos))
+    while (isDIGIT(*pos) || *pos == '_')
        pos++;
     if (!isALPHA(*pos)) {
        I32 rev;
@@ -332,6 +325,8 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
                if ( !qv && s > start && saw_decimal == 1 ) {
                    mult *= 100;
                    while ( s < end ) {
+                       if (*s == '_')
+                           continue;
                        orev = rev;
                        rev += (*s - '0') * mult;
                        mult /= 10;
@@ -350,17 +345,27 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
                }
                else {
                    while (--end >= s) {
-                       orev = rev;
-                       rev += (*end - '0') * mult;
-                       mult *= 10;
-                       if (   (PERL_ABS(orev) > PERL_ABS(rev)) 
-                           || (PERL_ABS(rev) > VERSION_MAX )) {
+                       int i;
+                       if (*end == '_')
+                           continue;
+                       i = (*end - '0');
+                        if (   (mult == VERSION_MAX)
+                            || (i > VERSION_MAX / mult)
+                            || (i * mult > VERSION_MAX - rev))
+                        {
                            Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW), 
                                           "Integer overflow in version");
                            end = s - 1;
                            rev = VERSION_MAX;
                            vinf = 1;
                        }
+                        else
+                            rev += i * mult;
+
+                        if (mult > VERSION_MAX / 10)
+                            mult = VERSION_MAX;
+                        else
+                            mult *= 10;
                    }
                } 
            }
@@ -371,8 +376,14 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
                s = last;
                break;
            }
-           else if ( *pos == '.' )
-               s = ++pos;
+           else if ( *pos == '.' ) {
+               pos++;
+               if (qv) {
+                   while (*pos == '0')
+                       ++pos;
+               }
+               s = pos;
+           }
            else if ( *pos == '_' && isDIGIT(pos[1]) )
                s = ++pos;
            else if ( *pos == ',' && isDIGIT(pos[1]) )
@@ -384,7 +395,7 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
                break;
            }
            if ( qv ) {
-               while ( isDIGIT(*pos) )
+               while ( isDIGIT(*pos) || *pos == '_')
                    pos++;
            }
            else {
@@ -461,7 +472,6 @@ Perl_new_version2(pTHX_ SV *ver)
 Perl_new_version(pTHX_ SV *ver)
 #endif
 {
-    dVAR;
     SV * const rv = newSV(0);
     PERL_ARGS_ASSERT_NEW_VERSION;
     if ( ISA_VERSION_OBJ(ver) ) /* can just copy directly */
@@ -515,7 +525,16 @@ Perl_new_version(pTHX_ SV *ver)
        if ( mg ) { /* already a v-string */
            const STRLEN len = mg->mg_len;
            const char * const version = (const char*)mg->mg_ptr;
+           char *raw, *under;
+           static const char underscore[] = "_";
            sv_setpvn(rv,version,len);
+           raw = SvPV_nolen(rv);
+           under = ninstr(raw, raw+len, underscore, underscore + 1);
+           if (under) {
+               Move(under + 1, under, raw + len - under - 1, char);
+               SvCUR(rv)--;
+               *SvEND(rv) = '\0';
+           }
            /* this is for consistency with the pure Perl class */
            if ( isDIGIT(*version) )
                sv_insert(rv, 0, 0, "v", 1);
@@ -591,35 +610,45 @@ VER_NV:
        char tbuf[64];
        SV *sv = SvNVX(ver) > 10e50 ? newSV(64) : 0;
        char *buf;
+
+#if PERL_VERSION_GE(5,19,0)
+       if (SvPOK(ver)) {
+           /* dualvar? */
+           goto VER_PV;
+       }
+#endif
+
 #ifdef USE_LOCALE_NUMERIC
-        const char * const cur_numeric = setlocale(LC_NUMERIC, NULL);
-        assert(cur_numeric);
-
-        /* XS code can set the locale without us knowing.  To protect the
-         * version number parsing, which requires the radix character to be a
-         * dot, update our records as to what the locale is, so that our
-         * existing macro mechanism can correctly change it to a dot and back
-         * if necessary.  This code is extremely unlikely to be in a loop, so
-         * the extra work will have a negligible performance impact.  See [perl
-         * #121930].
-         *
-         * If the current locale is a standard one, but we are expecting it to
-         * be a different, underlying locale, update our records to make the
-         * underlying locale this (standard) one.  If the current locale is not
-         * a standard one, we should be expecting a non-standard one, the same
-         * one that we have recorded as the underlying locale.  If not, update
-         * our records. */
-        if (strEQ(cur_numeric, "C") || strEQ(cur_numeric, "POSIX")) {
-            if (! PL_numeric_standard) {
-                new_numeric(cur_numeric);
-            }
-        }
-        else if (PL_numeric_standard
-                 || ! PL_numeric_name
-                 || strNE(PL_numeric_name, cur_numeric))
-        {
-            new_numeric(cur_numeric);
-        }
+       {
+           const char * const cur_numeric = setlocale(LC_NUMERIC, NULL);
+           assert(cur_numeric);
+
+           /* XS code can set the locale without us knowing.  To protect the
+            * version number parsing, which requires the radix character to be a
+            * dot, update our records as to what the locale is, so that our
+            * existing macro mechanism can correctly change it to a dot and back
+            * if necessary.  This code is extremely unlikely to be in a loop, so
+            * the extra work will have a negligible performance impact.  See [perl
+            * #121930].
+            *
+            * If the current locale is a standard one, but we are expecting it to
+            * be a different, underlying locale, update our records to make the
+            * underlying locale this (standard) one.  If the current locale is not
+            * a standard one, we should be expecting a non-standard one, the same
+            * one that we have recorded as the underlying locale.  If not, update
+            * our records. */
+           if (strEQ(cur_numeric, "C") || strEQ(cur_numeric, "POSIX")) {
+               if (! PL_numeric_standard) {
+                   new_numeric(cur_numeric);
+               }
+           }
+           else if (PL_numeric_standard
+                    || ! PL_numeric_name
+                    || strNE(PL_numeric_name, cur_numeric))
+           {
+               new_numeric(cur_numeric);
+           }
+       }
 #endif
         { /* Braces needed because macro just below declares a variable */
         STORE_NUMERIC_LOCAL_SET_STANDARD();
@@ -650,9 +679,7 @@ VER_NV:
     }
 #endif
     else if ( SvPOK(ver))/* must be a string or something like a string */
-#if PERL_VERSION_LT(5,17,2)
 VER_PV:
-#endif
     {
        STRLEN len;
        version = savepvn(SvPV(ver,len), SvCUR(ver));
@@ -800,7 +827,6 @@ Perl_vnumify(pTHX_ SV *vs)
 {
     SSize_t i, len;
     I32 digit;
-    int width;
     bool alpha = FALSE;
     SV *sv;
     AV *av;
@@ -815,14 +841,11 @@ Perl_vnumify(pTHX_ SV *vs)
     /* see if various flags exist */
     if ( hv_exists(MUTABLE_HV(vs), "alpha", 5 ) )
        alpha = TRUE;
-    {
-       SV ** svp = hv_fetchs(MUTABLE_HV(vs), "width", FALSE);
-       if ( svp )
-           width = SvIV(*svp);
-       else
-           width = 3;
-    }
 
+    if (alpha) {
+       Perl_ck_warner(aTHX_ packWARN(WARN_NUMERIC),
+                      "alpha->numify() is lossy");
+    }
 
     /* attempt to retrieve the version array */
     if ( !(av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE))) ) ) {
@@ -840,30 +863,14 @@ Perl_vnumify(pTHX_ SV *vs)
        digit = SvIV(tsv);
     }
     sv = Perl_newSVpvf(aTHX_ "%d.", (int)PERL_ABS(digit));
-    for ( i = 1 ; i < len ; i++ )
+    for ( i = 1 ; i <= len ; i++ )
     {
        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);
-           Perl_sv_catpvf(aTHX_ sv, "%0*d_%d", width, term.quot, term.rem);
-       }
-       else {
-           Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit);
-       }
+       Perl_sv_catpvf(aTHX_ sv, "%03d", (int)digit);
     }
 
-    if ( 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);
-    }
-    else /* len == 0 */
-    {
+    if ( len == 0 ) {
        sv_catpvs(sv, "000");
     }
     return sv;
@@ -906,6 +913,7 @@ Perl_vnormal(pTHX_ SV *vs)
 
     if ( hv_exists(MUTABLE_HV(vs), "alpha", 5 ) )
        alpha = TRUE;
+
     av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE)));
 
     len = av_len(av);
@@ -918,23 +926,12 @@ Perl_vnormal(pTHX_ SV *vs)
        digit = SvIV(tsv);
     }
     sv = Perl_newSVpvf(aTHX_ "v%"IVdf, (IV)digit);
-    for ( i = 1 ; i < len ; i++ ) {
+    for ( i = 1 ; i <= len ; i++ ) {
        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 */
-       SV * tsv = *av_fetch(av, len, 0);
-       digit = SvIV(tsv);
-       if ( alpha )
-           Perl_sv_catpvf(aTHX_ sv, "_%"IVdf, (IV)digit);
-       else
-           Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
-    }
-
     if ( len <= 2 ) { /* short version, must be at least three */
        for ( len = 2 - len; len != 0; len-- )
            sv_catpvs(sv,".0");
@@ -1048,19 +1045,6 @@ Perl_vcmp(pTHX_ SV *lhv, SV *rhv)
        i++;
     }
 
-    /* tiebreaker for alpha with identical terms */
-    if ( retval == 0 && l == r && left == right && ( lalpha || ralpha ) )
-    {
-       if ( lalpha && !ralpha )
-       {
-           retval = -1;
-       }
-       else if ( ralpha && !lalpha)
-       {
-           retval = +1;
-       }
-    }
-
     if ( l != r && retval == 0 ) /* possible match except for trailing 0's */
     {
        if ( l < r )
@@ -1086,3 +1070,5 @@ Perl_vcmp(pTHX_ SV *lhv, SV *rhv)
     }
     return retval;
 }
+
+/* ex: set ro: */
diff --git a/vutil.h b/vutil.h
index aaf2284..a60ca9d 100644 (file)
--- a/vutil.h
+++ b/vutil.h
@@ -131,16 +131,16 @@ S_croak_xs_usage(pTHX_ const CV *const cv, const char *const params)
 
 #  define VUTIL_REPLACE_CORE 1
 
-const char * Perl_scan_version2(pTHX_ const char *s, SV *rv, bool qv);
-SV * Perl_new_version2(pTHX_ SV *ver);
-SV * Perl_upg_version2(pTHX_ SV *sv, bool qv);
-SV * Perl_vstringify2(pTHX_ SV *vs);
-SV * Perl_vverify2(pTHX_ SV *vs);
-SV * Perl_vnumify2(pTHX_ SV *vs);
-SV * Perl_vnormal2(pTHX_ SV *vs);
-SV * Perl_vstringify2(pTHX_ SV *vs);
-int Perl_vcmp2(pTHX_ SV *lsv, SV *rsv);
-const char * Perl_prescan_version2(pTHX_ const char *s, bool strict, const char** errstr, bool *sqv, int *ssaw_decimal, int *swidth, bool *salpha);
+static const char * Perl_scan_version2(pTHX_ const char *s, SV *rv, bool qv);
+static SV * Perl_new_version2(pTHX_ SV *ver);
+static SV * Perl_upg_version2(pTHX_ SV *sv, bool qv);
+static SV * Perl_vstringify2(pTHX_ SV *vs);
+static SV * Perl_vverify2(pTHX_ SV *vs);
+static SV * Perl_vnumify2(pTHX_ SV *vs);
+static SV * Perl_vnormal2(pTHX_ SV *vs);
+static SV * Perl_vstringify2(pTHX_ SV *vs);
+static int Perl_vcmp2(pTHX_ SV *lsv, SV *rsv);
+static const char * Perl_prescan_version2(pTHX_ const char *s, bool strict, const char** errstr, bool *sqv, int *ssaw_decimal, int *swidth, bool *salpha);
 
 #  define SCAN_VERSION(a,b,c)  Perl_scan_version2(aTHX_ a,b,c)
 #  define NEW_VERSION(a)       Perl_new_version2(aTHX_ a)
@@ -239,3 +239,13 @@ const char * Perl_prescan_version(pTHX_ const char *s, bool strict, const char**
 #  define RESTORE_NUMERIC_LOCAL()
 # endif
 #endif
+
+#ifndef LOCK_NUMERIC_STANDARD
+#define LOCK_NUMERIC_STANDARD()
+#endif
+
+#ifndef UNLOCK_NUMERIC_STANDARD
+#define UNLOCK_NUMERIC_STANDARD()
+#endif
+
+/* ex: set ro: */
diff --git a/vxs.inc b/vxs.inc
index 4d74adb..a047b2c 100644 (file)
--- a/vxs.inc
+++ b/vxs.inc
 /* 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)); 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);
@@ -86,7 +91,6 @@ typedef char HVNAME;
 
 VXS(universal_version)
 {
-    dVAR;
     dXSARGS;
     HV *pkg;
     GV **gvp;
@@ -185,7 +189,6 @@ VXS(universal_version)
 
 VXS(version_new)
 {
-    dVAR;
     dXSARGS;
     SV *vs;
     SV *rv;
@@ -225,7 +228,6 @@ VXS(version_new)
     default:
     case 0:
         Perl_croak_nocontext("Usage: version::new(class, version)");
-        break;
     }
 
     svarg0 = ST(0);
@@ -267,7 +269,6 @@ VXS(version_new)
 
 VXS(version_stringify)
 {
-     dVAR;
      dXSARGS;
      if (items < 1)
         croak_xs_usage(cv, "lobj, ...");
@@ -282,7 +283,6 @@ VXS(version_stringify)
 
 VXS(version_numify)
 {
-     dVAR;
      dXSARGS;
      if (items < 1)
         croak_xs_usage(cv, "lobj, ...");
@@ -296,7 +296,6 @@ VXS(version_numify)
 
 VXS(version_normal)
 {
-     dVAR;
      dXSARGS;
      if (items != 1)
         croak_xs_usage(cv, "ver");
@@ -311,7 +310,6 @@ VXS(version_normal)
 
 VXS(version_vcmp)
 {
-     dVAR;
      dXSARGS;
      if (items < 1)
         croak_xs_usage(cv, "lobj, ...");
@@ -347,7 +345,6 @@ VXS(version_vcmp)
 
 VXS(version_boolean)
 {
-    dVAR;
     dXSARGS;
     SV *lobj;
     if (items < 1)
@@ -368,7 +365,6 @@ VXS(version_boolean)
 
 VXS(version_noop)
 {
-    dVAR;
     dXSARGS;
     if (items < 1)
        croak_xs_usage(cv, "lobj, ...");
@@ -383,7 +379,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");
@@ -408,7 +403,6 @@ VXS(version_is_alpha)
 
 VXS(version_qv)
 {
-    dVAR;
     dXSARGS;
     PERL_UNUSED_ARG(cv);
     SP -= items;