summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--cpan/version/lib/version.pm6
-rw-r--r--cpan/version/lib/version.pod6
-rw-r--r--cpan/version/lib/version/Internals.pod4
-rw-r--r--cpan/version/lib/version/regex.pm2
-rw-r--r--cpan/version/t/01base.t7
-rw-r--r--cpan/version/t/02derived.t7
-rw-r--r--cpan/version/t/03require.t7
-rw-r--r--cpan/version/t/05sigdie.t2
-rw-r--r--cpan/version/t/06noop.t2
-rw-r--r--cpan/version/t/07locale.t89
-rw-r--r--cpan/version/t/08_corelist.t2
-rw-r--r--cpan/version/t/09_list_util.t2
-rw-r--r--cpan/version/t/10_lyon.t44
-rw-r--r--cpan/version/t/coretests.pm72
-rw-r--r--vutil.c200
-rw-r--r--vutil.h30
-rw-r--r--vxs.inc18
17 files changed, 332 insertions, 168 deletions
diff --git a/cpan/version/lib/version.pm b/cpan/version/lib/version.pm
index f8afd8435b..d20427cc1c 100644
--- a/cpan/version/lib/version.pm
+++ b/cpan/version/lib/version.pm
@@ -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
diff --git a/cpan/version/lib/version.pod b/cpan/version/lib/version.pod
index 40ceee2063..42691b1e0c 100644
--- a/cpan/version/lib/version.pod
+++ b/cpan/version/lib/version.pod
@@ -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()
diff --git a/cpan/version/lib/version/Internals.pod b/cpan/version/lib/version/Internals.pod
index 95be844881..dd784fe4c8 100644
--- a/cpan/version/lib/version/Internals.pod
+++ b/cpan/version/lib/version/Internals.pod
@@ -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
diff --git a/cpan/version/lib/version/regex.pm b/cpan/version/lib/version/regex.pm
index f73296383a..dc769c28dd 100644
--- 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.9909;
+$VERSION = 0.9914;
#--------------------------------------------------------------------------#
# Version regexp components
diff --git a/cpan/version/t/01base.t b/cpan/version/t/01base.t
index 6174194b8a..4c1a23dd49 100644
--- a/cpan/version/t/01base.t
+++ b/cpan/version/t/01base.t
@@ -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");
diff --git a/cpan/version/t/02derived.t b/cpan/version/t/02derived.t
index a5aa2e48ff..ac0dea9130 100644
--- a/cpan/version/t/02derived.t
+++ b/cpan/version/t/02derived.t
@@ -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.
}
diff --git a/cpan/version/t/03require.t b/cpan/version/t/03require.t
index f6100ef4f6..ed437be64f 100644
--- a/cpan/version/t/03require.t
+++ b/cpan/version/t/03require.t
@@ -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()");
diff --git a/cpan/version/t/05sigdie.t b/cpan/version/t/05sigdie.t
index 0b82313df0..fad9139acf 100644
--- a/cpan/version/t/05sigdie.t
+++ b/cpan/version/t/05sigdie.t
@@ -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";
diff --git a/cpan/version/t/06noop.t b/cpan/version/t/06noop.t
index ed24602e41..e9f7187145 100644
--- 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.9909);
+ use_ok('version', 0.9914);
}
my $v1 = version->new('1.2');
diff --git a/cpan/version/t/07locale.t b/cpan/version/t/07locale.t
index 7af61b5725..22b9def883 100644
--- a/cpan/version/t/07locale.t
+++ b/cpan/version/t/07locale.t
@@ -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
diff --git a/cpan/version/t/08_corelist.t b/cpan/version/t/08_corelist.t
index d7829c1c92..d8cd147949 100644
--- 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.9909);
+use_ok("version", 0.9914);
# 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 dbd387dbd4..bb6d3ec443 100644
--- 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.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
index 0000000000..4f927aa65f
--- /dev/null
+++ b/cpan/version/t/10_lyon.t
@@ -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");
+}
diff --git a/cpan/version/t/coretests.pm b/cpan/version/t/coretests.pm
index 17bf9ec5fc..07cc82e614 100644
--- a/cpan/version/t/coretests.pm
+++ b/cpan/version/t/coretests.pm
@@ -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 20fb522ee5..e43d2b2788 100644
--- 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 aaf2284e89..a60ca9d479 100644
--- 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 4d74adbd06..a047b2c171 100644
--- a/vxs.inc
+++ b/vxs.inc
@@ -12,7 +12,12 @@
/* 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;
View Lorry Controller Status