=head1 DESCRIPTION
-This class models Gentoo versions.
+This class models Gentoo versions as described in L<http://devmanual.gentoo.org/ebuild-writing/file-format/index.html>.
=cut
'""' => \&_stringify,
);
-my $int_rx = qr/[0-9]+/;
-my $dotted_num_rx = qr/$int_rx(?:\.$int_rx)*/o;
+my $int_rx = qr/[0-9]+/;
+my $positive_int_rx = qr/0*[1-9][0-9]*/;
+my $letter_rx = qr/[a-zA-Z]/;
+my $dotted_num_rx = qr/$int_rx(?:\.$int_rx)*/o;
-our $version_rx = qr/$dotted_num_rx(?:_p$dotted_num_rx)?(?:-r$int_rx)?/o;
+my @suffixes = qw(alpha beta pre rc normal p);
+my $suffix_rx = join '|', grep !/^normal$/, @suffixes;
+$suffix_rx = qr/(?:$suffix_rx)/o;
+
+our $version_rx = qr{
+ $dotted_num_rx $letter_rx?
+ (?:_$suffix_rx$positive_int_rx?)*
+ (?:-r$positive_int_rx)?
+}xo;
+
+my $capturing_version_rx = qr{
+ ($dotted_num_rx) ($letter_rx)?
+ ((?:_$suffix_rx$positive_int_rx?)*)
+ (?:-r($positive_int_rx))?
+}xo;
=head1 METHODS
if (defined $vstring) {
$vstring =~ s/^[._]+//g;
$vstring =~ s/[._]+$//g;
- if ($vstring =~ /^($dotted_num_rx)(?:_p($dotted_num_rx))?(?:-r($int_rx))?$/o){
+
+ if ($vstring =~ /^$capturing_version_rx$/o) {
return bless {
string => $vstring,
version => [ split /\.+/, $1 ],
- patch => [ defined $2 ? (split /\.+/, $2) : () ],
- revision => [ defined $3 ? $3 : () ],
+ letter => $2,
+ suffixes => [ map /_($suffix_rx)($positive_int_rx)?/go, $3 ],
+ revision => $4,
}, $class;
}
+
+ require Carp;
+ Carp::croak("Couldn't parse version string '$vstring'");
}
require Carp;
- Carp::croak("Couldn't parse version string '$vstring'");
+ Carp::croak('You must specify a version string');
}
my @parts;
BEGIN {
- @parts = qw/version patch revision/;
+ @parts = qw/version letter suffixes revision/;
eval "sub $_ { \$_[0]->{$_} }" for @parts;
}
Read-only accessor for the C<version> part of the version object.
-=head2 C<patch>
+=head2 C<letter>
+
+Read-only accessor for the C<letter> part of the version object.
+
+=head2 C<suffixes>
-Read-only accessor for the C<patch> part of the version object.
+Read-only accessor for the C<suffixes> part of the version object.
=head2 C<revision>
=cut
+my %suffix_grade = do {
+ my $i = 0;
+ map { $_ => ++$i } @suffixes;
+};
+
sub _spaceship {
my ($v1, $v2, $r) = @_;
($v1, $v2) = ($v2, $v1) if $r;
- for (@parts) {
- my @a = @{ $v1->$_ };
- my @b = @{ $v2->$_ };
+ {
+ my @a = @{ $v1->version };
+ my @b = @{ $v2->version };
+
while (@a or @b) {
my $x = shift(@a) || 0;
my $y = shift(@b) || 0;
}
}
+ {
+ my ($l1, $l2) = map { defined() ? ord : 0 } map $_->letter, $v1, $v2;
+
+ my $c = $l1 <=> $l2;
+ return $c if $c;
+ }
+
+ {
+ my @a = @{ $v1->suffixes };
+ my @b = @{ $v2->suffixes };
+
+ while (@a or @b) {
+ my $x = $suffix_grade{ shift(@a) || 'normal' };
+ my $y = $suffix_grade{ shift(@b) || 'normal' };
+ my $c = $x <=> $y;
+ return $c if $c;
+
+ $x = shift(@a) || 0;
+ $y = shift(@b) || 0;
+ $c = $x <=> $y;
+ return $c if $c;
+ }
+ }
+
+ {
+ my ($r1, $r2) = map { defined() ? $_ : 0 } map $_->revision, $v1, $v2;
+
+ my $c = $r1 <=> $r2;
+ return $c if $c;
+ }
+
return 0;
}
sub _stringify {
my ($v) = @_;
- my ($version, $patch, $revision) = map $v->$_, @parts;
+ my ($version, $letter, $suffixes, $revision) = map $v->$_, @parts;
+ my @suffixes = @$suffixes;
- $version = join '.', @$version;
- $version .= '_p' . join('.', @$patch) if @$patch;
- $version .= '-r' . join('.', @$revision) if @$revision;
+ $version = join '.', @$version;
+ $version .= $letter if defined $letter;
+ while (my @suffix = splice @suffixes, 0, 2) {
+ my $s = $suffix[0];
+ my $n = $suffix[1];
+ $version .= "_$s" . (defined $n ? $n : '');
+ }
+ $version .= "-r$revision" if defined $revision;
$version;
}
use strict;
use warnings;
-use Test::More tests => 2 + 21 * (3 + 2);
+use Test::More tests => 3 + (2 + 2 * 3) * (50 + 4 * 7);
use CPANPLUS::Dist::Gentoo::Version;
sub V () { 'CPANPLUS::Dist::Gentoo::Version' }
+eval { V->new() };
+like $@, qr/You\s+must\s+specify\s+a\s+version\s+string/, "V->(undef)";
+
eval { V->new('dongs') };
like $@, qr/Couldn't\s+parse\s+version\s+string/, "V->('dongs')";
like $@, qr/Couldn't\s+parse\s+version\s+string/, "'dongs' < V->new(1)";
my @tests = (
- [ 0, 0, 0 ],
- [ 1, 0, 1 ],
- [ 0, 1, -1 ],
- [ 1, 1, 0 ],
-
- [ '1.0', 1, 0 ],
- [ '1.1', 1, 1 ],
- [ '1.1', '1.0', 1 ],
- [ 1, '1.0', 0 ],
- [ 1, '1.1', -1 ],
- [ '1.0', '1.1', -1 ],
-
- [ '1.0_p0', '1.0_p0', 0 ],
- [ '1.0_p0', '1.0_p1', -1 ],
- [ '1.1_p0', '1.0_p1', 1 ],
- [ '1.1_p0', '1.1_p0.1', -1 ],
- [ '1.1_p0.1', '1.1_p0.1', 0 ],
-
- [ '1.2_p0-r0', '1.2_p0', 0 ],
- [ '1.2_p0-r1', '1.2_p0', 1 ],
- [ '1.2-r0', '1.2_p0', 0 ],
- [ '1.2-r1', '1.2_p0', 1 ],
- [ '1.2-r1', '1.2_p1', -1 ],
- [ '1.2-r2', '1.2_p1', -1 ],
+ [ 0, 0 => 0 ],
+ [ 1, 0 => 1 ],
+ [ 0, 1 => -1 ],
+ [ 1, 1 => 0 ],
+
+ [ '1.0', 1 => 0 ],
+ [ '1.1', 1 => 1 ],
+ [ '1.1', '1.0' => 1 ],
+ [ 1, '1.0' => 0 ],
+ [ 1, '1.1' => -1 ],
+ [ '1.0', '1.1' => -1 ],
+ [ '1.0.1', '1.1' => -1 ],
+ [ '1.0.1', '1.0.0' => 1 ],
+
+ [ '1a', 1 => 1 ],
+ [ '1.0a', 1 => 1 ],
+ [ '1.0', '1a' => -1 ],
+ [ '1a', '1b' => -1 ],
+ [ '1.1a', '1.0b' => 1 ],
+
+ map( {
+ [ '1.0', "1.0_${_}" => 1 ],
+ [ '1.0a', "1.0_${_}" => 1 ],
+ [ '1.0', "1.0_${_}1" => 1 ],
+ [ "1.0_${_}1", "1.0_${_}1" => 0 ],
+ [ "1.0_${_}1", "1.0_${_}2" => -1 ],
+ [ "1.0a_${_}1", "1.0_${_}2" => 1 ],
+ [ "1.1_${_}1", "1.0_${_}2" => 1 ],
+ } qw(alpha beta pre rc)),
+
+ [ '1.0', '1.0_p' => -1 ],
+ [ '1.0a', '1.0_p' => 1 ],
+ [ '1.0', '1.0_p1' => -1 ],
+ [ '1.0_p1', '1.0_p1' => 0 ],
+ [ '1.0_p1', '1.0_p2' => -1 ],
+ [ '1.0a_p1', '1.0_p2' => 1 ],
+ [ '1.1_p1', '1.0_p2' => 1 ],
+
+ [ '1.0_alpha1', '1.0_beta1' => -1 ],
+ [ '1.0_beta1', '1.0_pre1' => -1 ],
+ [ '1.0_pre1', '1.0_rc1' => -1 ],
+ [ '1.0_rc1', '1.0' => -1 ],
+ [ '1.0', '1.0_p1' => -1 ],
+
+ [ '1.0_alpha', '1.0_alpha_alpha' => 1 ],
+ [ '1.0_beta', '1.0_beta_beta' => 1 ],
+ [ '1.0_pre', '1.0_pre_pre' => 1 ],
+ [ '1.0_rc', '1.0_rc_rc' => 1 ],
+ [ '1.0_p', '1.0_p_p' => -1 ],
+
+ [ '1.0_alpha', '1.0_alpha_p' => -1 ],
+ [ '1.0_beta', '1.0_alpha_beta' => 1 ],
+ [ '1.0_beta', '1.0_alpha_p' => 1 ],
+ [ '1.0_pre1_rc2', '1.0_pre1_rc2' => 0 ],
+ [ '1.0_pre1_rc2', '1.0_pre1_rc3' => -1 ],
+
+ [ '1.0', '1.0-r1' => -1 ],
+ [ '1.0-r1', '1.0-r1' => 0 ],
+ [ '1.0-r1', '1.0-r2' => -1 ],
+ [ '1.1-r1', '1.0-r2' => 1 ],
+
+ [ '1.2_p1-r1', '1.2_p1', 1 ],
+ [ '1.2_p1-r1', '1.2_p1_p1', -1 ],
+ [ '1.2_p1_pre2-r1', '1.2_p1-r1', -1 ],
+ [ '1.2_p1_pre2-r1', '1.2_p1_beta3-r1', 1 ],
+ [ '1.2_p1_pre2-r1', '1.2_p1_beta3-r4', 1 ],
+ [ '1.2_p1_pre2-r1', '1.2_p2_beta3-r4', -1 ],
+ [ '1.2_p1_pre2-r1', '1.2a_p1_beta3-r1', -1 ],
);
+sub compare_ok {
+ my ($a, $cmp, $b, $exp) = @_;
+
+ my $desc = join " $cmp ", map { ref() ? "V->new('$_')" : "'$_'" } $a, $b;
+
+ my ($err, $c);
+ {
+ local $@;
+ $c = eval "\$a $cmp \$b";
+ $err = $@;
+ }
+
+ if (ref $exp eq 'Regexp') {
+ like $err, $exp, "$desc should fail";
+ } elsif ($err) {
+ fail "$desc failed but shouldn't: $err";
+ } else {
+ is $c, $exp, "$desc == '$exp'";
+ }
+}
+
for (@tests) {
- my ($s1, $s2, $res) = @$_;
+ my ($s1, $s2, $exp) = @$_;
+
+ my $v1 = eval { V->new($s1) };
+ is $@, '', "'$s1' parses fine";
- my $v1 = V->new($s1);
- my $v2 = V->new($s2);
+ my $v2 = eval { V->new($s2) };
+ is $@, '', "'$s2' parses fine";
- is $s1 <=> $v2, $res, "'$s1' <=> V->new('$s2')";
- is $v1 <=> $s2, $res, "V->new('$s1') <=> '$s2'";
- is $v1 <=> $v2, $res, "V->new('$s1') <=> V->new('$s2')";
+ for my $r (0 .. 1) {
+ if ($r) {
+ ($v1, $v2) = ($v2, $v1);
+ ($s1, $s2) = ($s2, $s1);
+ $exp = -$exp;
+ }
- cmp_ok "$v1", 'eq', $s1, "V->new('$s1') eq '$s1'";
- cmp_ok "$v2", 'eq', $s2, "V->new('$s2') eq '$s2'";
+ compare_ok($v1, '<=>', $v2, $exp);
+ compare_ok($v1, '<=>', $s2, $exp);
+ compare_ok($s1, '<=>', $v2, $exp);
+ }
}
projects / perl / modules / CPANPLUS-Dist-Gentoo.git / commitdiff