From: Vincent Pit Date: Sat, 11 Sep 2010 22:47:44 +0000 (+0200) Subject: Handle Gentoo versions thouroughly and correctly X-Git-Tag: v0.11~17 X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2FCPANPLUS-Dist-Gentoo.git;a=commitdiff_plain;h=f7846983c923e0aac6f815d8c494fbd958cb3fbe Handle Gentoo versions thouroughly and correctly --- diff --git a/lib/CPANPLUS/Dist/Gentoo/Atom.pm b/lib/CPANPLUS/Dist/Gentoo/Atom.pm index dfddd42..b58ebc3 100644 --- a/lib/CPANPLUS/Dist/Gentoo/Atom.pm +++ b/lib/CPANPLUS/Dist/Gentoo/Atom.pm @@ -59,7 +59,7 @@ sub new { Carp::confess('Invalid name') unless $name =~ /^$name_rx$/o; } elsif (defined $args{atom}) { my $atom = $args{atom}; - $atom =~ m{^($range_rx)?($category_rx)/($name_rx)(?:-v?($version_rx))?$}o + $atom =~ m{^($range_rx)?($category_rx)/($name_rx)(?:-($version_rx))?$}o or Carp::confess('Invalid atom'); ($range, $category, $name, $version) = ($1, $2, $3, $4); } else { @@ -106,7 +106,7 @@ sub new_from_ebuild { my $ebuild = shift; $ebuild = '' unless defined $ebuild; - $ebuild =~ m{/($category_rx)/($name_rx)/\2-v?($version_rx)\.ebuild$}o + $ebuild =~ m{/($category_rx)/($name_rx)/\2-($version_rx)\.ebuild$}o or Carp::confess('Invalid ebuild'); my ($category, $name, $version) = ($1, $2, $3); diff --git a/lib/CPANPLUS/Dist/Gentoo/Version.pm b/lib/CPANPLUS/Dist/Gentoo/Version.pm index 47cec96..bce74ea 100644 --- a/lib/CPANPLUS/Dist/Gentoo/Version.pm +++ b/lib/CPANPLUS/Dist/Gentoo/Version.pm @@ -17,7 +17,7 @@ our $VERSION = '0.10'; =head1 DESCRIPTION -This class models Gentoo versions. +This class models Gentoo versions as described in L. =cut @@ -28,10 +28,26 @@ use overload ( '""' => \&_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 @@ -49,23 +65,28 @@ sub new { 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; } @@ -73,9 +94,13 @@ BEGIN { Read-only accessor for the C part of the version object. -=head2 C +=head2 C + +Read-only accessor for the C part of the version object. + +=head2 C -Read-only accessor for the C part of the version object. +Read-only accessor for the C part of the version object. =head2 C @@ -83,6 +108,11 @@ Read-only accessor for the C part of the version object. =cut +my %suffix_grade = do { + my $i = 0; + map { $_ => ++$i } @suffixes; +}; + sub _spaceship { my ($v1, $v2, $r) = @_; @@ -92,9 +122,10 @@ sub _spaceship { ($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; @@ -103,17 +134,54 @@ sub _spaceship { } } + { + 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; } diff --git a/t/20-version.t b/t/20-version.t index 16294ae..51bbf05 100644 --- a/t/20-version.t +++ b/t/20-version.t @@ -3,12 +3,15 @@ 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')"; @@ -16,42 +19,115 @@ eval { my $res = 'dongs' < V->new(1) }; 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); + } } diff --git a/t/30-atom-new.t b/t/30-atom-new.t index dec89c2..c51175e 100644 --- a/t/30-atom-new.t +++ b/t/30-atom-new.t @@ -43,11 +43,11 @@ my @tests = ( [ { %$a1, range => '<>' } => inv('range'), ], [ { %$a1, range => '<=' } => { %$a1, range => '<=' } ], - [ { atom => 'test/a' } => $a0 ], - [ { atom => 'test/a-1.0' } => { %$a1, range => '>=' } ], - [ { atom => '=test/a-v1.0' } => { %$a1, range => '=' } ], - [ { atom => '= inv('atom') ], - [ { atom => '>=test/a' } => $range_no_ver ], + [ { atom => 'test/a' } => $a0 ], + [ { atom => 'test/a-1.0' } => { %$a1, range => '>=' } ], + [ { atom => '=test/a-1.0' } => { %$a1, range => '=' } ], + [ { atom => '= inv('atom') ], + [ { atom => '>=test/a' } => $range_no_ver ], [ { ebuild => undef } => inv('ebuild') ], [ { ebuild => '/wat/test/a/a.ebuild' } => inv('ebuild') ],