From 14f3031b13a4d4c094ca37dc42e1cbb34863a050 Mon Sep 17 00:00:00 2001 From: John Peacock Date: Tue, 16 Feb 2016 21:34:52 -0600 Subject: [PATCH] Import version.pm 0.9914 from CPAN --- cpan/version/lib/version.pm | 6 +- cpan/version/lib/version.pod | 6 +- cpan/version/lib/version/Internals.pod | 4 +- cpan/version/lib/version/regex.pm | 2 +- cpan/version/t/01base.t | 7 +- cpan/version/t/02derived.t | 7 +- cpan/version/t/03require.t | 7 +- cpan/version/t/05sigdie.t | 2 +- cpan/version/t/06noop.t | 2 +- cpan/version/t/07locale.t | 89 ++++++++++++++- cpan/version/t/08_corelist.t | 2 +- cpan/version/t/09_list_util.t | 2 +- cpan/version/t/10_lyon.t | 44 ++++++++ cpan/version/t/coretests.pm | 72 +++++++++--- vutil.c | 200 +++++++++++++++------------------ vutil.h | 30 +++-- vxs.inc | 18 +-- 17 files changed, 332 insertions(+), 168 deletions(-) create mode 100644 cpan/version/t/10_lyon.t diff --git a/cpan/version/lib/version.pm b/cpan/version/lib/version.pm index f8afd84..d20427c 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 40ceee2..42691b1 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 95be844..dd784fe 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. This also includes versions with a single decimal point and a single embedded underscore, see L, 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 Lcatpath( + (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 a5aa2e4..ac0dea9 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 f6100ef..ed437be 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 0b82313..fad9139 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 ed24602..e9f7187 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 7af61b5..22b9def 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 d7829c1..d8cd147 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 dbd387d..bb6d3ec 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 0000000..4f927aa --- /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 17bf9ec..07cc82e 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 20fb522..e43d2b2 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 aaf2284..a60ca9d 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 4d74adb..a047b2c 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; -- 1.8.3.1