From: John Peacock Date: Mon, 6 Jun 2005 05:18:21 +0000 (-0400) Subject: Bring bleadperl up to version.pm X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=9137345a080bfc646c2f9440cdb7bd90b8b37428;p=p5sagit%2Fp5-mst-13.2.git Bring bleadperl up to version.pm Message-ID: <42A414DD.8090504@rowman.com> p4raw-id: //depot/perl@24823 --- diff --git a/configpm b/configpm index 6ac52e2..ab26eef 100755 --- a/configpm +++ b/configpm @@ -82,7 +82,7 @@ use strict; # use vars pulls in Carp ENDOFBEG -my $myver = sprintf "v%vd", $^V; +my $myver = sprintf "%vd", $^V; printf CONFIG <<'ENDOFBEG', ($myver) x 3; # This file was created by configpm when Perl was built. Any changes diff --git a/embed.fnc b/embed.fnc index baa3312..cdcfceb 100644 --- a/embed.fnc +++ b/embed.fnc @@ -546,7 +546,7 @@ Apa |OP* |newWHILEOP |I32 flags|I32 debuggable|LOOP* loop \ |I32 has_my Apa |PERL_SI*|new_stackinfo|I32 stitems|I32 cxitems Ap |char* |scan_vstring |NN const char *vstr|NN SV *sv -Apd |char* |scan_version |NN const char *vstr|NN SV *sv|bool qv +Apd |const char* |scan_version |NN const char *vstr|NN SV *sv|bool qv Apd |SV* |new_version |SV *ver Apd |SV* |upg_version |SV *ver Apd |SV* |vnumify |SV *vs diff --git a/lib/h2xs.t b/lib/h2xs.t index a59afa2..380f838 100644 --- a/lib/h2xs.t +++ b/lib/h2xs.t @@ -56,6 +56,7 @@ if ($^O eq 'MacOS') { my $name = 'h2xst'; my $header = "$name.h"; my $thisversion = sprintf "%vd", $^V; +$thisversion =~ s/^v//; # If this test has failed previously a copy may be left. rmtree($name); diff --git a/lib/version.pm b/lib/version.pm index 0c888cd..d2648d1 100644 --- a/lib/version.pm +++ b/lib/version.pm @@ -12,7 +12,7 @@ use vars qw(@ISA $VERSION $CLASS @EXPORT); @EXPORT = qw(qv); -$VERSION = 0.42; # stop using CVS and switch to subversion +$VERSION = "0.43"; $CLASS = 'version'; @@ -36,15 +36,15 @@ version - Perl extension for Version Objects print $version->numify; # 12.002001 if ( $version gt "12.2" ) # true - $alphaver = version->new("1.2_3"); # must be quoted! - print $alphaver; # 1.2_3 + $alphaver = version->new("1.02_03"); # must be quoted! + print $alphaver; # 1.02_030 print $alphaver->is_alpha(); # true $ver = qv(1.2); # 1.2.0 $ver = qv("1.2"); # 1.2.0 $perlver = version->new(5.005_03); # must not be quoted! - print $perlver; # 5.5.30 + print $perlver; # 5.005030 =head1 DESCRIPTION @@ -67,16 +67,14 @@ There are actually two distinct ways to initialize versions: =item * Numeric Versions Any initial parameter which "looks like a number", see L. +Versions>. This also covers versions with a single decimal place and +a single embedded underscore, see L, even though +these must be quoted to preserve the underscore formatting. =item * Quoted Versions Any initial parameter which contains more than one decimal point -or contains an embedded underscore, see L. The -most recent development version of Perl (5.9.x) and the next major -release (5.10.0) will automatically create version objects for bare -numbers containing more than one decimal point in the appropriate -context. +and an optional embedded underscore, see L. =back @@ -85,11 +83,15 @@ the default stringification will yield the version L only if required: $v = version->new(1.002); # 1.002, but compares like 1.2.0 - $v = version->new(1.002003); # 1.2.3 - $v2 = version->new( "1.2.3"); # 1.2.3 - $v3 = version->new( 1.2.3); # 1.2.3 for Perl >= 5.8.1 + $v = version->new(1.002003); # 1.002003 + $v2 = version->new( "1.2.3"); # v1.2.3 + $v3 = version->new( 1.2.3); # v1.2.3 for Perl >= 5.8.1 -Please see L<"Quoting"> for more details on how Perl will parse various +In specific, version numbers initialized as L will +stringify in Numeric form. Version numbers initialized as L +will be stringified as L. + +Please see L for more details on how Perl will parse various input values. Any value passed to the new() operator will be parsed only so far as it @@ -187,6 +189,29 @@ to specify a version, whereas Numeric Versions enforce a certain uniformity. See also L for an additional method of initializing version objects. +=head2 Numeric Alpha Versions + +The one time that a numeric version must be quoted is when a alpha form is +used with an otherwise numeric version (i.e. a single decimal place). This +is commonly used for CPAN releases, where CPAN or CPANPLUS will ignore alpha +versions for automatic updating purposes. Since some developers have used +only two significant decimal places for their non-alpha releases, the +version object will automatically take that into account if the initializer +is quoted. For example Module::Example was released to CPAN with the +following sequence of $VERSION's: + + # $VERSION Stringified + 0.01 0.010 + 0.02 0.020 + 0.02_01 0.02_0100 + 0.02_02 0.02_0200 + 0.03 0.030 + etc. + +As you can see, the version object created from the values in the first +column may contain a trailing 0, but will otherwise be both mathematically +equivalent and sorts alpha-numerically as would be expected. + =head2 Object Methods Overloading has been used with version objects to provide a natural @@ -218,13 +243,18 @@ carries for versions. The CVS $Revision$ increments differently from numeric versions (i.e. 1.10 follows 1.9), so it must be handled as if it were a L. -New in 0.38, a new version object can be created as a copy of an existing -version object: +A new version object can be created as a copy of an existing version +object, either as a class method: $v1 = version->new(12.3); $v2 = version->new($v1); -and $v1 and $v2 will be identical. +or as an object method: + + $v1 = version->new(12.3); + $v2 = $v1->new(); + +and in each case, $v1 and $v2 will be identical. =back @@ -250,7 +280,7 @@ For the subsequent examples, the following three objects will be used: $ver = version->new("1.2.3.4"); # see "Quoting" below $alpha = version->new("1.2.3_4"); # see "Alpha versions" below - $nver = version->new(1.2); # see "Numeric Versions" above + $nver = version->new(1.002); # see "Numeric Versions" above =over 4 @@ -259,13 +289,13 @@ For the subsequent examples, the following three objects will be used: For any version object which is initialized with multiple decimal places (either quoted or if possible v-string), or initialized using the L operator, the stringified representation is returned in -a normalized or reduced form (no extraneous zeros): +a normalized or reduced form (no extraneous zeros), and with a leading 'v': - print $ver->normal; # prints as 1.2.3 + print $ver->normal; # prints as v1.2.3 print $ver->stringify; # ditto print $ver; # ditto - print $nver->normal; # prints as 1.2.0 - print $nver->stringify; # prints as 1.2, see "Stringification" + print $nver->normal; # prints as v1.2.0 + print $nver->stringify; # prints as 1.002, see "Stringification" In order to preserve the meaning of the processed version, the normalized representation will always contain at least three sub terms. @@ -289,7 +319,7 @@ corresponds a version object, all sub versions are assumed to have three decimal places. So for example: print $ver->numify; # prints 1.002003 - print $nver->numify; # prints 1.2 + print $nver->numify; # prints 1.002 Unlike the stringification operator, there is never any need to append trailing zeros to preserve the correct version value. @@ -318,8 +348,8 @@ form will be the L. The $obj->normal operation can always be used to produce the L, even if the version was originally a L. - print $ver->stringify; # prints 1.2.3 - print $nver->stringify; # prints 1.2 + print $ver->stringify; # prints v1.2.3 + print $nver->stringify; # prints 1.002 =back @@ -412,9 +442,8 @@ but other operations are not likely to be what you intend. For example: $V2 = version->new(100/9); # Integer overflow in decimal number print $V2; # yields something like 11.111.111.100 -Perl 5.8.1 and beyond will be able to automatically quote v-strings -(although a warning may be issued under 5.9.x and 5.10.0), but that -is not possible in earlier versions of Perl. In other words: +Perl 5.8.1 and beyond will be able to automatically quote v-strings but +that is not possible in earlier versions of Perl. In other words: $version = version->new("v2.5.4"); # legal in all versions of Perl $newvers = version->new(v2.5.4); # legal only in Perl >= 5.8.1 @@ -441,39 +470,35 @@ This allows you to automatically increment your module version by using the Revision number from the primary file in a distribution, see L. -=item * Alpha versions +=item * Alpha Versions For module authors using CPAN, the convention has been to note unstable releases with an underscore in the version string, see L. Alpha releases will test as being newer than the more recent stable release, and less than the next stable release. For example: - $alphaver = version->new("12.3_1"); # must quote + $alphaver = version->new("12.03_01"); # must be quoted obeys the relationship - 12.3 < $alphaver < 12.4 - -As a matter of fact, if is also true that - - 12.3.0 < $alphaver < 12.3.1 - -where the subversion is identical but the alpha release is less than -the non-alpha release. + 12.03 < $alphaver < 12.04 Alpha versions with a single decimal place will be treated exactly as if they were L, for parsing purposes. The stringification for alpha versions with a single decimal place may seem suprising, since any trailing zeros will visible. For example, the above $alphaver will print as - 12.300_100 + 12.03_0100 + +which is mathematically equivalent and ASCII sorts exactly the same as +without the trailing zeros. Alpha versions with more than a single decimal place will be treated exactly as if they were L, and will display without any trailing (or leading) zeros, in the L form. For example, $newver = version->new("12.3.1_1"); - print $newver; # 12.3.1_1 + print $newver; # v12.3.1_1 =head2 Replacement UNIVERSAL::VERSION @@ -509,12 +534,9 @@ The replacement UNIVERSAL::VERSION, when used as a function, like this: print $module->VERSION; -will follow the stringification rules; i.e. Numeric versions will be displayed -with the numified format, and the rest will be displayed with the Normal -format. Technically, the $module->VERSION function returns a string (PV) that -can be converted to a number following the normal Perl rules, when used in a -numeric context. - +will also exclusively return the numified form. Technically, the +$module->VERSION function returns a string (PV) that can be converted to a +number following the normal Perl rules, when used in a numeric context. =head1 EXPORT @@ -522,7 +544,7 @@ qv - quoted version initialization operator =head1 AUTHOR -John Peacock Ejpeacock@rowman.comE +John Peacock Ejpeacock@cpan.orgE =head1 SEE ALSO diff --git a/lib/version.t b/lib/version.t index 8636a3f..0bb0185 100644 --- a/lib/version.t +++ b/lib/version.t @@ -4,7 +4,7 @@ ######################### -use Test::More tests => 170; +use Test::More tests => 183; diag "Tests with base class" unless $ENV{PERL_CORE}; @@ -15,16 +15,16 @@ diag "Tests with empty derived class" unless $ENV{PERL_CORE}; package version::Empty; use vars qw($VERSION @ISA); -use Exporter; use version 0.30; -@ISA = qw(Exporter version); +@ISA = qw(version); $VERSION = 0.01; package main; my $testobj = new version::Empty 1.002_003; isa_ok( $testobj, "version::Empty" ); ok( $testobj->numify == 1.002003, "Numified correctly" ); -ok( $testobj->stringify eq "1.2.3", "Stringified correctly" ); +ok( $testobj->stringify eq "1.002003", "Stringified correctly" ); +ok( $testobj->normal eq "v1.2.3", "Normalified correctly" ); my $verobj = new version "1.2.4"; ok( $verobj > $testobj, "Comparison vs parent class" ); @@ -41,7 +41,7 @@ sub BaseTests { # Test bare number processing diag "tests with bare numbers" unless $ENV{PERL_CORE}; $version = $CLASS->new(5.005_03); - is ( "$version" , "5.5.30" , '5.005_03 eq 5.5.30' ); + is ( "$version" , "5.005030" , '5.005_03 eq 5.5.30' ); $version = $CLASS->new(1.23); is ( "$version" , "1.230" , '1.23 eq "1.230"' ); @@ -50,16 +50,16 @@ sub BaseTests { $version = $CLASS->new("5.005_03"); is ( "$version" , "5.005_030" , '"5.005_03" eq "5.005_030"' ); $version = $CLASS->new("v1.23"); - is ( "$version" , "1.23.0" , '"v1.23" eq "1.23.0"' ); + is ( "$version" , "v1.23.0" , '"v1.23" eq "v1.23.0"' ); # Test stringify operator diag "tests with stringify" unless $ENV{PERL_CORE}; $version = $CLASS->new("5.005"); is ( "$version" , "5.005" , '5.005 eq "5.005"' ); $version = $CLASS->new("5.006.001"); - is ( "$version" , "5.6.1" , '5.006.001 eq 5.6.1' ); + is ( "$version" , "v5.6.1" , '5.006.001 eq v5.6.1' ); $version = $CLASS->new("1.2.3_4"); - is ( "$version" , "1.2.3_4" , 'alpha version 1.2.3_4 eq 1.2.3_4' ); + is ( "$version" , "v1.2.3_4" , 'alpha version 1.2.3_4 eq v1.2.3_4' ); # test illegal formats diag "test illegal formats" unless $ENV{PERL_CORE}; @@ -74,6 +74,7 @@ sub BaseTests { $version = $CLASS->new("99 and 44/100 pure"); ok ("$version" eq "99.000", '$version eq "99.000"'); ok ($version->numify == 99.0, '$version->numify == 99.0'); + ok ($version->normal eq "v99.0.0", '$version->normal eq v99.0.0'); $version = $CLASS->new("something"); ok (defined $version, 'defined $version'); @@ -216,7 +217,11 @@ sub BaseTests { diag "create new from existing version" unless $ENV{PERL_CORE}; ok (eval {$new_version = version->new($version)}, "new from existing object"); - ok ($new_version == $version, "duped object identical"); + ok ($new_version == $version, "class->new($version) identical"); + $new_version = $version->new(); + ok ($new_version == $version, "$version->new() also identical"); + $new_version = $version->new("1.2.3"); + is ($new_version, "v1.2.3" , '$version->new("1.2.3") works too'); # test the CVS revision mode diag "testing CVS Revision" unless $ENV{PERL_CORE}; @@ -225,6 +230,13 @@ sub BaseTests { $version = new version qw$Revision: 1.2.3.4$; ok ( $version eq "1.2.3.4", 'qw$Revision: 1.2.3.4$ eq 1.2.3.4' ); + # test the CPAN style reduced significant digit form + diag "testing CPAN-style versions" unless $ENV{PERL_CORE}; + $version = $CLASS->new("1.23_01"); + is ( "$version" , "1.23_0100", "CPAN-style alpha version" ); + ok ( $version > 1.23, "1.23_01 > 1.23"); + ok ( $version < 1.24, "1.23_01 < 1.24"); + # test reformed UNIVERSAL::VERSION diag "Replacement UNIVERSAL::VERSION tests" unless $ENV{PERL_CORE}; @@ -255,12 +267,12 @@ SKIP: { if $] < 5.008_001; diag "Tests with v-strings" unless $ENV{PERL_CORE}; $version = $CLASS->new(1.2.3); - ok("$version" eq "1.2.3", '"$version" eq 1.2.3'); + ok("$version" eq "v1.2.3", '"$version" eq 1.2.3'); $version = $CLASS->new(1.0.0); $new_version = $CLASS->new(1); ok($version == $new_version, '$version == $new_version'); ok($version eq $new_version, '$version eq $new_version'); $version = qv(1.2.3); - ok("$version" eq "1.2.3", 'v-string initialized qv()'); + ok("$version" eq "v1.2.3", 'v-string initialized qv()'); } } diff --git a/pod/perlapi.pod b/pod/perlapi.pod index 6ffe590..c27e4e2 100644 --- a/pod/perlapi.pod +++ b/pod/perlapi.pod @@ -1828,7 +1828,7 @@ is a alpha version). The boolean qv denotes that the version should be interpreted as if it had multiple decimals, even if it doesn't. - char* scan_version(const char *vstr, SV *sv, bool qv) + const char* scan_version(const char *vstr, SV *sv, bool qv) =for hackers Found in file util.c diff --git a/pp_ctl.c b/pp_ctl.c index 8355b58..69bc3fe 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -3084,8 +3084,8 @@ PP(pp_require) if (!sv_derived_from(PL_patchlevel, "version")) (void *)upg_version(PL_patchlevel); if ( vcmp(sv,PL_patchlevel) > 0 ) - DIE(aTHX_ "Perl v%"SVf" required--this is only v%"SVf", stopped", - vstringify(sv), vstringify(PL_patchlevel)); + DIE(aTHX_ "Perl %"SVf" required--this is only %"SVf", stopped", + vnormal(sv), vnormal(PL_patchlevel)); RETPUSHYES; } diff --git a/proto.h b/proto.h index 57c3826..e7d4c63 100644 --- a/proto.h +++ b/proto.h @@ -1080,7 +1080,7 @@ PERL_CALLCONV char* Perl_scan_vstring(pTHX_ const char *vstr, SV *sv) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); -PERL_CALLCONV char* Perl_scan_version(pTHX_ const char *vstr, SV *sv, bool qv) +PERL_CALLCONV const char* Perl_scan_version(pTHX_ const char *vstr, SV *sv, bool qv) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); diff --git a/t/comp/require.t b/t/comp/require.t index 29f5436..f16b8eb 100755 --- a/t/comp/require.t +++ b/t/comp/require.t @@ -75,7 +75,7 @@ print "ok ",$i++,"\n"; # check inaccurate fp $ver = 10.2; eval { require $ver; }; -print "# $@\nnot " unless $@ =~ /^Perl v10\.200 required/; +print "# $@\nnot " unless $@ =~ /^Perl v10\.200.0 required/; print "ok ",$i++,"\n"; $ver = 10.000_02; diff --git a/t/comp/use.t b/t/comp/use.t index db84b93..a8be2d3 100755 --- a/t/comp/use.t +++ b/t/comp/use.t @@ -111,7 +111,7 @@ print "ok ",$i++,"\n"; print "ok ",$i++,"\n"; eval "use lib v100.105"; - unless ($@ =~ /lib version 100.105 \(100\.105\.0\) required--this is only version 35.360 \(35\.360\.0\)/) { + unless ($@ =~ /lib version 100.105 \(v100\.105\.0\) required--this is only version 35.360 \(v35\.360\.0\)/) { print "not "; } print "ok ",$i++,"\n"; @@ -121,7 +121,7 @@ print "ok ",$i++,"\n"; print "ok ",$i++,"\n"; eval "use lib 100.105"; - unless ($@ =~ /lib version 100.105 \(100\.105\.0\) required--this is only version 35.360 \(35\.360\.0\)/) { + unless ($@ =~ /lib version 100.105 \(v100\.105\.0\) required--this is only version 35.360 \(v35\.360\.0\)/) { print "not "; } print "ok ",$i++,"\n"; @@ -132,7 +132,7 @@ print "ok ",$i++,"\n"; print "ok ",$i++,"\n"; eval "use lib v100.105"; - unless ($@ =~ /lib version 100.105 \(100\.105\.0\) required--this is only version 35.360 \(35\.360\.0\)/) { + unless ($@ =~ /lib version 100.105 \(v100\.105\.0\) required--this is only version 35.360 \(v35\.360\.0\)/) { print "not "; } print "ok ",$i++,"\n"; @@ -142,7 +142,7 @@ print "ok ",$i++,"\n"; print "ok ",$i++,"\n"; eval "use lib 100.105"; - unless ($@ =~ /lib version 100.105 \(100\.105\.0\) required--this is only version 35.360 \(35\.360\.0\)/) { + unless ($@ =~ /lib version 100.105 \(v100\.105\.0\) required--this is only version 35.360 \(v35\.360\.0\)/) { print "not "; } print "ok ",$i++,"\n"; @@ -153,7 +153,7 @@ print "ok ",$i++,"\n"; print "ok ",$i++,"\n"; eval "use lib v100.105"; - unless ($@ =~ /lib version 100.105 \(100\.105\.0\) required--this is only version 35.036 \(35\.36\.0\)/) { + unless ($@ =~ /lib version 100.105 \(v100\.105\.0\) required--this is only version 35.036 \(v35\.36\.0\)/) { print "not "; } print "ok ",$i++,"\n"; @@ -163,7 +163,7 @@ print "ok ",$i++,"\n"; print "ok ",$i++,"\n"; eval "use lib 100.105"; - unless ($@ =~ /lib version 100.105 \(100\.105\.0\) required--this is only version 35.036 \(35\.36\.0\)/) { + unless ($@ =~ /lib version 100.105 \(v100\.105\.0\) required--this is only version 35.036 \(v35\.36\.0\)/) { print "not "; } print "ok ",$i++,"\n"; diff --git a/t/op/universal.t b/t/op/universal.t index b7d452f..83f5a4f 100755 --- a/t/op/universal.t +++ b/t/op/universal.t @@ -121,7 +121,7 @@ test ! $a->can("export_tags"); # a method in Exporter test (eval { $a->VERSION }) == 2.718; test ! (eval { $a->VERSION(2.719) }) && - $@ =~ /^Alice version 2.719 \(2\.719\.0\) required--this is only version 2.718 \(2\.718\.0\) at /; + $@ =~ /^Alice version 2.719 \(v2\.719\.0\) required--this is only version 2.718 \(v2\.718\.0\) at /; test (eval { $a->VERSION(2.718) }) && ! $@; diff --git a/t/op/ver.t b/t/op/ver.t index e030ec1..759104a 100755 --- a/t/op/ver.t +++ b/t/op/ver.t @@ -205,6 +205,9 @@ is(v200, eval("+v200"), 'v200 eq eval("+v200")' ); # Tests for string/numeric value of $] itself my ($revision,$version,$subversion) = split '\.', sprintf("%vd",$^V); +# $^V always displays the leading 'v' but we don't want that here +$revision =~ s/^v//; + print "# revision = '$revision'\n"; print "# version = '$version'\n"; print "# subversion = '$subversion'\n"; diff --git a/universal.c b/universal.c index 0a729e9..1564b59 100644 --- a/universal.c +++ b/universal.c @@ -174,6 +174,7 @@ PERL_XS_EXPORT_C void XS_UNIVERSAL_VERSION(pTHX_ CV *cv); XS(XS_version_new); XS(XS_version_stringify); XS(XS_version_numify); +XS(XS_version_normal); XS(XS_version_vcmp); XS(XS_version_boolean); #ifdef HASATTRIBUTE_NORETURN @@ -218,6 +219,7 @@ Perl_boot_core_UNIVERSAL(pTHX) newXS("version::stringify", XS_version_stringify, file); newXS("version::(0+", XS_version_numify, file); newXS("version::numify", XS_version_numify, file); + newXS("version::normal", XS_version_normal, file); newXS("version::(cmp", XS_version_vcmp, file); newXS("version::(<=>", XS_version_vcmp, file); newXS("version::vcmp", XS_version_vcmp, file); @@ -395,12 +397,32 @@ XS(XS_version_new) Perl_croak(aTHX_ "Usage: version::new(class, version)"); SP -= items; { - const char *classname = SvPV_nolen_const(ST(0)); SV *vs = ST(1); SV *rv; - if (items == 3 ) - { - vs = sv_newmortal(); + const char *classname; + + /* get the class if called as an object method */ + if ( sv_isobject(ST(0)) ) { + classname = HvNAME(SvSTASH(SvRV(ST(0)))); + } + else { + classname = (char *)SvPV_nolen(ST(0)); + } + + if ( items == 1 ) { + /* no parameter provided */ + if ( sv_isobject(ST(0)) ) { + /* copy existing object */ + vs = ST(0); + } + else { + /* create empty object */ + vs = sv_newmortal(); + sv_setpv(vs,""); + } + } + else if ( items == 3 ) { + vs = sv_newmortal(); Perl_sv_setpvf(aTHX_ vs,"v%s",SvPV_nolen_const(ST(2))); } @@ -424,8 +446,7 @@ XS(XS_version_stringify) SV * lobj = Nullsv; if (sv_derived_from(ST(0), "version")) { - SV *tmp = SvRV(ST(0)); - lobj = tmp; + lobj = SvRV(ST(0)); } else Perl_croak(aTHX_ "lobj is not of type version"); @@ -447,8 +468,7 @@ XS(XS_version_numify) SV * lobj = Nullsv; if (sv_derived_from(ST(0), "version")) { - SV *tmp = SvRV(ST(0)); - lobj = tmp; + lobj = SvRV(ST(0)); } else Perl_croak(aTHX_ "lobj is not of type version"); @@ -460,6 +480,28 @@ XS(XS_version_numify) } } +XS(XS_version_normal) +{ + dXSARGS; + if (items < 1) + Perl_croak(aTHX_ "Usage: version::normal(lobj, ...)"); + SP -= items; + { + SV * lobj = Nullsv; + + if (sv_derived_from(ST(0), "version")) { + lobj = SvRV(ST(0)); + } + else + Perl_croak(aTHX_ "lobj is not of type version"); + + PUSHs(sv_2mortal(vnormal(lobj))); + + PUTBACK; + return; + } +} + XS(XS_version_vcmp) { dXSARGS; @@ -470,8 +512,7 @@ XS(XS_version_vcmp) SV * lobj = Nullsv; if (sv_derived_from(ST(0), "version")) { - SV *tmp = SvRV(ST(0)); - lobj = tmp; + lobj = SvRV(ST(0)); } else Perl_croak(aTHX_ "lobj is not of type version"); @@ -515,9 +556,7 @@ XS(XS_version_boolean) SV * lobj = Nullsv; if (sv_derived_from(ST(0), "version")) { - /* XXX If tmp serves a purpose, explain it. */ - SV *tmp = SvRV(ST(0)); - lobj = tmp; + lobj = SvRV(ST(0)); } else Perl_croak(aTHX_ "lobj is not of type version"); @@ -556,17 +595,12 @@ XS(XS_version_is_alpha) { SV * lobj = Nullsv; - if (sv_derived_from(ST(0), "version")) { - /* XXX If tmp serves a purpose, explain it. */ - SV *tmp = SvRV(ST(0)); - lobj = tmp; - } + if (sv_derived_from(ST(0), "version")) + lobj = ST(0); else Perl_croak(aTHX_ "lobj is not of type version"); { - const I32 len = av_len((AV *)lobj); - const I32 digit = SvIVX(*av_fetch((AV *)lobj, len, 0)); - if ( digit < 0 ) + if ( hv_exists((HV*)SvRV(lobj), "alpha", 5 ) ) XSRETURN_YES; else XSRETURN_NO; diff --git a/util.c b/util.c index 6df4ebf..a3dcd47 100644 --- a/util.c +++ b/util.c @@ -3825,18 +3825,27 @@ it doesn't. =cut */ -char * +const char * Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv) { const char *start = s; - const char *pos = s; - I32 saw_period = 0; - bool saw_under = 0; - SV* sv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */ - (void)sv_upgrade(sv, SVt_PVAV); /* needs to be an AV type */ - AvREAL_on((AV*)sv); - - /* pre-scan the imput string to check for decimals */ + const char *pos; + const char *last; + int saw_period = 0; + int saw_under = 0; + int width = 3; + AV *av = newAV(); + SV* hv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */ + (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */ + + if (*s == 'v') { + s++; /* get past 'v' */ + qv = 1; /* force quoted version processing */ + } + + last = pos = s; + + /* pre-scan the input string to check for decimals/underbars */ while ( *pos == '.' || *pos == '_' || isDIGIT(*pos) ) { if ( *pos == '.' ) @@ -3844,38 +3853,45 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv) if ( saw_under ) Perl_croak(aTHX_ "Invalid version format (underscores before decimal)"); saw_period++ ; + last = pos; } else if ( *pos == '_' ) { if ( saw_under ) Perl_croak(aTHX_ "Invalid version format (multiple underscores)"); saw_under = 1; + width = pos - last - 1; /* natural width of sub-version */ } pos++; } - pos = s; - if (*pos == 'v') { - pos++; /* get past 'v' */ + if ( saw_period > 1 ) { qv = 1; /* force quoted version processing */ } + + pos = s; + + if ( qv ) + hv_store((HV *)hv, "qv", 2, &PL_sv_yes, 0); + if ( saw_under ) { + hv_store((HV *)hv, "alpha", 5, &PL_sv_yes, 0); + } + if ( !qv && width < 3 ) + hv_store((HV *)hv, "width", 5, newSViv(width), 0); + while (isDIGIT(*pos)) pos++; if (!isALPHA(*pos)) { I32 rev; - if (*s == 'v') s++; /* get past 'v' */ - for (;;) { rev = 0; { /* this is atoi() that delimits on underscores */ - const char *end = pos; + const char *end = pos; I32 mult = 1; I32 orev; - if ( s < pos && s > start && *(s-1) == '_' ) { - mult *= -1; /* alpha version */ - } + /* the following if() will only be true after the decimal * point of a version originally created with a bare * floating point number, i.e. not quoted in any way @@ -3889,6 +3905,8 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv) if ( PERL_ABS(orev) > PERL_ABS(rev) ) Perl_croak(aTHX_ "Integer overflow in version"); s++; + if ( *s == '_' ) + s++; } } else { @@ -3901,10 +3919,12 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv) } } } - + /* Append revision */ - av_push((AV *)sv, newSViv(rev)); - if ( (*pos == '.' || *pos == '_') && isDIGIT(pos[1])) + av_push(av, newSViv(rev)); + if ( *pos == '.' && isDIGIT(pos[1]) ) + s = ++pos; + else if ( *pos == '_' && isDIGIT(pos[1]) ) s = ++pos; else if ( isDIGIT(*pos) ) s = pos; @@ -3912,15 +3932,22 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv) s = pos; break; } - while ( isDIGIT(*pos) ) { - if ( saw_period == 1 && pos-s == 3 ) - break; - pos++; + if ( qv ) { + while ( isDIGIT(*pos) ) + pos++; + } + else { + int digits = 0; + while ( ( isDIGIT(*pos) || *pos == '_' ) && digits < 3 ) { + if ( *pos != '_' ) + digits++; + pos++; + } } } } - if ( qv ) { /* quoted versions always become full version objects */ - I32 len = av_len((AV *)sv); + if ( qv ) { /* quoted versions always get at least three terms*/ + I32 len = av_len(av); /* This for loop appears to trigger a compiler bug on OS X, as it loops infinitely. Yes, len is negative. No, it makes no sense. Compiler in question is: @@ -3930,9 +3957,15 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv) */ len = 2 - len; while (len-- > 0) - av_push((AV *)sv, newSViv(0)); + av_push(av, newSViv(0)); } - return (char *)s; + + if ( av_len(av) == -1 ) /* oops, someone forgot to pass a value */ + av_push(av, newSViv(0)); + + /* And finally, store the AV in the hash */ + hv_store((HV *)hv, "version", 7, (SV *)av, 0); + return s; } /* @@ -3955,15 +3988,37 @@ Perl_new_version(pTHX_ SV *ver) if ( sv_derived_from(ver,"version") ) /* can just copy directly */ { I32 key; - AV *av = (AV *)SvRV(ver); - SV* sv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */ - (void)sv_upgrade(sv, SVt_PVAV); /* needs to be an AV type */ - AvREAL_on((AV*)sv); - for ( key = 0; key <= av_len(av); key++ ) + AV *av = newAV(); + AV *sav; + /* This will get reblessed later if a derived class*/ + SV* hv = newSVrv(rv, "version"); + (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */ + + if ( SvROK(ver) ) + ver = SvRV(ver); + + /* Begin copying all of the elements */ + if ( hv_exists((HV *)ver, "qv", 2) ) + hv_store((HV *)hv, "qv", 2, &PL_sv_yes, 0); + + if ( hv_exists((HV *)ver, "alpha", 5) ) + hv_store((HV *)hv, "alpha", 5, &PL_sv_yes, 0); + + if ( hv_exists((HV*)ver, "width", 5 ) ) { - const I32 rev = SvIV(*av_fetch(av, key, FALSE)); - av_push((AV *)sv, newSViv(rev)); + I32 width = SvIV(*hv_fetch((HV*)ver, "width", 5, FALSE)); + hv_store((HV *)hv, "width", 5, newSViv(width), 0); } + + sav = (AV *)*hv_fetch((HV*)ver, "version", 7, FALSE); + /* This will get reblessed later if a derived class*/ + for ( key = 0; key <= av_len(sav); key++ ) + { + const I32 rev = SvIV(*av_fetch(sav, key, FALSE)); + av_push(av, newSViv(rev)); + } + + hv_store((HV *)hv, "version", 7, (SV *)av, 0); return rv; } #ifdef SvVOK @@ -4017,7 +4072,7 @@ Perl_upg_version(pTHX_ SV *ver) #endif else /* must be a string or something like a string */ { - version = savesvpv(ver); + version = savepv(SvPV_nolen(ver)); } (void)scan_version(version, ver, qv); Safefree(version); @@ -4043,35 +4098,60 @@ SV * Perl_vnumify(pTHX_ SV *vs) { I32 i, len, digit; + int width; + bool alpha = FALSE; SV *sv = newSV(0); + AV *av; if ( SvROK(vs) ) vs = SvRV(vs); - len = av_len((AV *)vs); + + /* see if various flags exist */ + if ( hv_exists((HV*)vs, "alpha", 5 ) ) + alpha = TRUE; + if ( hv_exists((HV*)vs, "width", 5 ) ) + width = SvIV(*hv_fetch((HV*)vs, "width", 5, FALSE)); + else + width = 3; + + + /* attempt to retrieve the version array */ + if ( !(av = (AV *)*hv_fetch((HV*)vs, "version", 7, FALSE) ) ) { + Perl_sv_catpv(aTHX_ sv,"0"); + return sv; + } + + len = av_len(av); if ( len == -1 ) { sv_catpvn(sv,"0",1); return sv; } - digit = SvIVX(*av_fetch((AV *)vs, 0, 0)); + + digit = SvIV(*av_fetch(av, 0, 0)); Perl_sv_setpvf(aTHX_ sv,"%d.", (int)PERL_ABS(digit)); for ( i = 1 ; i < len ; i++ ) { - digit = SvIVX(*av_fetch((AV *)vs, i, 0)); - Perl_sv_catpvf(aTHX_ sv,"%03d", (int)PERL_ABS(digit)); + digit = SvIV(*av_fetch(av, i, 0)); + if ( width < 3 ) { + int denom = (int)pow(10,(3-width)); + 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); + } } if ( len > 0 ) { - digit = SvIVX(*av_fetch((AV *)vs, len, 0)); - if ( (int)PERL_ABS(digit) != 0 || len == 1 ) - { - if ( digit < 0 ) /* alpha version */ - sv_catpvn(sv,"_",1); - /* Don't display additional trailing zeros */ - Perl_sv_catpvf(aTHX_ sv,"%03d", (int)PERL_ABS(digit)); - } + digit = SvIV(*av_fetch(av, len, 0)); + if ( alpha && width == 3 ) /* alpha version */ + Perl_sv_catpv(aTHX_ sv,"_"); + /* Don't display additional trailing zeros */ + if ( digit > 0 ) + Perl_sv_catpvf(aTHX_ sv,"%0*d", width, (int)digit); } - else /* len == 0 */ + else /* len == 1 */ { sv_catpvn(sv,"000",3); } @@ -4096,33 +4176,44 @@ SV * Perl_vnormal(pTHX_ SV *vs) { I32 i, len, digit; + bool alpha = FALSE; SV *sv = newSV(0); + AV *av; if ( SvROK(vs) ) vs = SvRV(vs); - len = av_len((AV *)vs); - if ( len == -1 ) - { + + if ( hv_exists((HV*)vs, "alpha", 5 ) ) + alpha = TRUE; + av = (AV *)*hv_fetch((HV*)vs, "version", 7, FALSE); + + len = av_len(av); + if ( len == -1 ) { sv_catpvn(sv,"",0); return sv; } - digit = SvIVX(*av_fetch((AV *)vs, 0, 0)); - Perl_sv_setpvf(aTHX_ sv,"%"IVdf,(IV)digit); - for ( i = 1 ; i <= len ; i++ ) - { - digit = SvIVX(*av_fetch((AV *)vs, i, 0)); - if ( digit < 0 ) - Perl_sv_catpvf(aTHX_ sv,"_%"IVdf,(IV)-digit); + digit = SvIV(*av_fetch(av, 0, 0)); + Perl_sv_setpvf(aTHX_ sv,"v%"IVdf,(IV)digit); + for ( i = 1 ; i <= len-1 ; i++ ) { + digit = SvIV(*av_fetch(av, i, 0)); + Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit); + } + + if ( len > 0 ) { + /* handle last digit specially */ + digit = SvIV(*av_fetch(av, len, 0)); + if ( alpha ) + Perl_sv_catpvf(aTHX_ sv, "_%"IVdf, (IV)digit); else - Perl_sv_catpvf(aTHX_ sv,".%"IVdf,(IV)digit); + 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_catpvn(sv,".0",2); } return sv; -} +} /* =for apidoc vstringify @@ -4138,16 +4229,17 @@ the original version contained 1 or more dots, respectively SV * Perl_vstringify(pTHX_ SV *vs) { - I32 len, digit; + I32 qv = 0; if ( SvROK(vs) ) vs = SvRV(vs); - len = av_len((AV *)vs); - digit = SvIVX(*av_fetch((AV *)vs, len, 0)); - if ( len < 2 || ( len == 2 && digit < 0 ) ) - return vnumify(vs); - else + if ( hv_exists((HV *)vs, "qv", 2) ) + qv = 1; + + if ( qv ) return vnormal(vs); + else + return vnumify(vs); } /* @@ -4160,40 +4252,65 @@ converted into version objects. */ int -Perl_vcmp(pTHX_ SV *lsv, SV *rsv) +Perl_vcmp(pTHX_ SV *lhv, SV *rhv) { I32 i,l,m,r,retval; - if ( SvROK(lsv) ) - lsv = SvRV(lsv); - if ( SvROK(rsv) ) - rsv = SvRV(rsv); - l = av_len((AV *)lsv); - r = av_len((AV *)rsv); + bool lalpha = FALSE; + bool ralpha = FALSE; + I32 left = 0; + I32 right = 0; + AV *lav, *rav; + if ( SvROK(lhv) ) + lhv = SvRV(lhv); + if ( SvROK(rhv) ) + rhv = SvRV(rhv); + + /* get the left hand term */ + lav = (AV *)*hv_fetch((HV*)lhv, "version", 7, FALSE); + if ( hv_exists((HV*)lhv, "alpha", 5 ) ) + lalpha = TRUE; + + /* and the right hand term */ + rav = (AV *)*hv_fetch((HV*)rhv, "version", 7, FALSE); + if ( hv_exists((HV*)rhv, "alpha", 5 ) ) + ralpha = TRUE; + + l = av_len(lav); + r = av_len(rav); m = l < r ? l : r; retval = 0; i = 0; while ( i <= m && retval == 0 ) { - I32 left = SvIV(*av_fetch((AV *)lsv,i,0)); - I32 right = SvIV(*av_fetch((AV *)rsv,i,0)); - bool lalpha = left < 0 ? 1 : 0; - bool ralpha = right < 0 ? 1 : 0; - left = abs(left); - right = abs(right); - if ( left < right || (left == right && lalpha && !ralpha) ) + left = SvIV(*av_fetch(lav,i,0)); + right = SvIV(*av_fetch(rav,i,0)); + if ( left < right ) retval = -1; - if ( left > right || (left == right && ralpha && !lalpha) ) + if ( left > right ) retval = +1; 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 ) { while ( i <= r && retval == 0 ) { - if ( SvIV(*av_fetch((AV *)rsv,i,0)) != 0 ) + if ( SvIV(*av_fetch(rav,i,0)) != 0 ) retval = -1; /* not a match after all */ i++; } @@ -4202,7 +4319,7 @@ Perl_vcmp(pTHX_ SV *lsv, SV *rsv) { while ( i <= l && retval == 0 ) { - if ( SvIV(*av_fetch((AV *)lsv,i,0)) != 0 ) + if ( SvIV(*av_fetch(lav,i,0)) != 0 ) retval = +1; /* not a match after all */ i++; } diff --git a/utils/h2xs.PL b/utils/h2xs.PL index bb4f537..a9ff420 100644 --- a/utils/h2xs.PL +++ b/utils/h2xs.PL @@ -639,10 +639,10 @@ usage if $opt_h; if( $opt_b ){ usage "You cannot use -b and -m at the same time.\n" if ($opt_b && $opt_m); - $opt_b =~ /^\d+\.\d+\.\d+/ || + $opt_b =~ /^v?(\d+)\.(\d+)\.(\d+)/ || usage "You must provide the backwards compatibility version in X.Y.Z form. " . "(i.e. 5.5.0)\n"; - my ($maj,$min,$sub) = split(/\./,$opt_b,3); + my ($maj,$min,$sub) = ($1,$2,$3); if ($maj < 5 || ($maj == 5 && $min < 6)) { $compat_version = $sub ? sprintf("%d.%03d%02d",$maj,$min,$sub) :