# 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
|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
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);
@EXPORT = qw(qv);
-$VERSION = 0.42; # stop using CVS and switch to subversion
+$VERSION = "0.43";
$CLASS = 'version';
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
=item * Numeric Versions
Any initial parameter which "looks like a number", see L<Numeric
-Versions>.
+Versions>. This also covers versions with a single decimal place and
+a single embedded underscore, see L<Numeric Alpha Versions>, 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<Quoted Versions>. 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<Quoted Versions>.
=back
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<Numeric Versions> will
+stringify in Numeric form. Version numbers initialized as L<Quoted Versions>
+will be stringified as L<Normal Form>.
+
+Please see L<Quoting> 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
uniformity. See also L<New Operator> 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
numeric versions (i.e. 1.10 follows 1.9), so it must be handled as if
it were a L<Quoted Version>.
-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
$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
For any version object which is initialized with multiple decimal
places (either quoted or if possible v-string), or initialized using
the L<qv()> 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.
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.
used to produce the L<Normal Form>, even if the version was originally a
L<Numeric Version>.
- 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
$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
using the Revision number from the primary file in a distribution, see
L<ExtUtils::MakeMaker/"VERSION_FROM">.
-=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<CPAN>. 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<Numeric Versions>, 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<Quoted Versions>, and will display without any
trailing (or leading) zeros, in the L<Version Normal> 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
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
=head1 AUTHOR
-John Peacock E<lt>jpeacock@rowman.comE<gt>
+John Peacock E<lt>jpeacock@cpan.orgE<gt>
=head1 SEE ALSO
#########################
-use Test::More tests => 170;
+use Test::More tests => 183;
diag "Tests with base 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" );
# 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"' );
$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};
$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');
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};
$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};
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()');
}
}
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
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;
}
__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);
# 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;
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";
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";
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";
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";
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";
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";
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) }) && ! $@;
# 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";
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
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);
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)));
}
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");
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");
}
}
+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;
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");
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");
{
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;
=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 == '.' )
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
if ( PERL_ABS(orev) > PERL_ABS(rev) )
Perl_croak(aTHX_ "Integer overflow in version");
s++;
+ if ( *s == '_' )
+ s++;
}
}
else {
}
}
}
-
+
/* 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;
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:
*/
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;
}
/*
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
#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);
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);
}
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
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);
}
/*
*/
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++;
}
{
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++;
}
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) :
projects / p5sagit/p5-mst-13.2.git / commitdiff