From: Vincent Pit <vince@profvince.com>
Date: Sun, 29 Nov 2009 13:23:27 +0000 (+0100)
Subject: Strengthen validation of the thingies an atom can be numerically compared against
X-Git-Tag: v0.09~4
X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2FCPANPLUS-Dist-Gentoo.git;a=commitdiff_plain;h=1c1a8d6482b5d4baac0e7aa58c6bf1ceb380c8b9

Strengthen validation of the thingies an atom can be numerically compared against
---

diff --git a/MANIFEST b/MANIFEST
index 858868a..2e4782e 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -14,6 +14,7 @@ t/11-maps-name.t
 t/12-maps-version.t
 t/13-maps-license.t
 t/20-version.t
+t/30-atom-cmp.t
 t/31-atom-and.t
 t/91-pod.t
 t/92-pod-coverage.t
diff --git a/lib/CPANPLUS/Dist/Gentoo/Atom.pm b/lib/CPANPLUS/Dist/Gentoo/Atom.pm
index 76af6fe..dd35ad6 100644
--- a/lib/CPANPLUS/Dist/Gentoo/Atom.pm
+++ b/lib/CPANPLUS/Dist/Gentoo/Atom.pm
@@ -153,16 +153,36 @@ sub _spaceship {
  my $v1 = $a1->version;
 
  my $v2;
- if (Scalar::Util::blessed($a2) and $a2->isa(__PACKAGE__)) {
-  Carp::confess('Can\'t compare atoms of different packages')
-                    if $a1->category ne $a2->category or $a1->name ne $a2->name;
+ my $blessed = Scalar::Util::blessed($a2);
+ unless ($blessed and $a2->isa(__PACKAGE__)) {
+  if ($blessed and $a2->isa('CPANPLUS::Dist::Gentoo::Version')) {
+   $v2 = $a2;
+   $a2 = undef;
+  } else {
+   my $maybe_atom = eval { __PACKAGE__->new(atom => $a2) };
+   if (my $err = $@) {
+    $v2 = eval { CPANPLUS::Dist::Gentoo::Version->new($a2) };
+    Carp::confess("Can't compare an atom against something that's not an atom, an atom string ($err), a version or a version string ($@)") if $@;
+    $a2 = undef;
+   } else {
+    $a2 = $maybe_atom;
+   }
+  }
+ }
+
+ if (defined $a2) {
   $v2 = $a2->version;
- } else {
-  $v2 = $a2;
+
+  my $p1 = $a1->qualified_name;
+  my $p2 = $a2->qualified_name;
+  Carp::confess("Atoms for different packages $p1 and $p2") unless $p1 eq $p2;
  }
 
  ($v1, $v2) = ($v2, $v1) if $r;
 
+ return (defined $v1 or 0) <=> (defined $v2 or 0) unless defined $v1
+                                                     and defined $v2;
+
  return $v1 <=> $v2;
 }
 
diff --git a/t/30-atom-cmp.t b/t/30-atom-cmp.t
new file mode 100644
index 0000000..1bb1bfb
--- /dev/null
+++ b/t/30-atom-cmp.t
@@ -0,0 +1,123 @@
+#!perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 4 * ((8 * 7) / 2);
+
+use CPANPLUS::Dist::Gentoo::Atom;
+
+sub A () { 'CPANPLUS::Dist::Gentoo::Atom' }
+
+my $a0 = A->new(
+ category => 'test',
+ name     => 'a',
+);
+
+my $a1 = A->new(
+ category => 'test',
+ name     => 'a',
+ version  => '1.0',
+ range    => '=',
+);
+
+my $a2 = A->new(
+ category => 'test',
+ name     => 'a',
+ version  => '1.0',
+ range    => '<',
+);
+
+my $a3 = A->new(
+ category => 'test',
+ name     => 'a',
+ version  => '1.0',
+ range    => '<=',
+);
+
+my $a4 = A->new(
+ category => 'test',
+ name     => 'a',
+ version  => '2.0',
+ range    => '=',
+);
+
+my $a5 = A->new(
+ category => 'test',
+ name     => 'a',
+ version  => '2.0',
+ range    => '>=',
+);
+
+my $a6 = A->new(
+ category => 'test',
+ name     => 'a',
+ version  => '2.0',
+ range    => '>',
+);
+
+my @tests = (
+ [ $a0, $a0 =>  0 ],
+ [ $a0, $a1 => -1 ],
+ [ $a0, $a2 => -1 ],
+ [ $a0, $a3 => -1 ],
+ [ $a0, $a4 => -1 ],
+ [ $a0, $a5 => -1 ],
+ [ $a0, $a6 => -1 ],
+
+ [ $a1, $a1 =>  0 ],
+ [ $a1, $a2 =>  0 ],
+ [ $a1, $a3 =>  0 ],
+ [ $a1, $a4 => -1 ],
+ [ $a1, $a5 => -1 ],
+ [ $a1, $a6 => -1 ],
+
+ [ $a2, $a2 =>  0 ],
+ [ $a2, $a3 =>  0 ],
+ [ $a2, $a4 => -1 ],
+ [ $a2, $a5 => -1 ],
+ [ $a2, $a5 => -1 ],
+
+ [ $a3, $a3 =>  0 ],
+ [ $a3, $a4 => -1 ],
+ [ $a3, $a5 => -1 ],
+ [ $a3, $a6 => -1 ],
+
+ [ $a4, $a4 =>  0 ],
+ [ $a4, $a5 =>  0 ],
+ [ $a4, $a6 =>  0 ],
+
+ [ $a5, $a5 =>  0 ],
+ [ $a5, $a6 =>  0 ],
+
+ [ $a6, $a6 =>  0 ],
+);
+
+sub compare_ok {
+ my ($a, $cmp, $b, $exp) = @_;
+
+ my $desc = join " $cmp ", map "'$_'", $a, $b;
+
+ my $c   = eval "\$a $cmp \$b";
+ my $err = $@;
+
+ if (ref $exp eq 'Regexp') {
+  like $err, $exp, "$desc should fail";
+ } else {
+  is $c, $exp, "$desc == '$exp'";
+ }
+}
+
+for my $t (@tests) {
+ my ($a, $b, $exp) = @$t;
+
+ for my $r (0 .. 1) {
+  if ($r) {
+   ($a, $b) = ($b, $a);
+   $exp = -$exp;
+  }
+
+  compare_ok($a, '<=>', $b, $exp);
+  compare_ok($a, 'cmp', $b, $exp);
+ }
+}