t/31-atom-cmp.t

   1 #!perl
   2
   3 use strict;
   4 use warnings;
   5
   6 use Test::More tests => 6 * ((8 * 7) / 2);
   7
   8 use CPANPLUS::Dist::Gentoo::Atom;
   9
  10 sub A () { 'CPANPLUS::Dist::Gentoo::Atom' }
  11
  12 my $a0 = A->new(
  13  category => 'test',
  14  name     => 'a',
  15 );
  16
  17 my $a1 = A->new(
  18  category => 'test',
  19  name     => 'a',
  20  version  => '1.0',
  21  range    => '=',
  22 );
  23
  24 my $a2 = A->new(
  25  category => 'test',
  26  name     => 'a',
  27  version  => '1.0',
  28  range    => '<',
  29 );
  30
  31 my $a3 = A->new(
  32  category => 'test',
  33  name     => 'a',
  34  version  => '1.0',
  35  range    => '<=',
  36 );
  37
  38 my $a4 = A->new(
  39  category => 'test',
  40  name     => 'a',
  41  version  => '2.0',
  42  range    => '=',
  43 );
  44
  45 my $a5 = A->new(
  46  category => 'test',
  47  name     => 'a',
  48  version  => '2.0',
  49  range    => '>=',
  50 );
  51
  52 my $a6 = A->new(
  53  category => 'test',
  54  name     => 'a',
  55  version  => '2.0',
  56  range    => '>',
  57 );
  58
  59 my @tests = (
  60  [ $a0, $a0 =>  0 ],
  61  [ $a0, $a1 => -1 ],
  62  [ $a0, $a2 => -1 ],
  63  [ $a0, $a3 => -1 ],
  64  [ $a0, $a4 => -1 ],
  65  [ $a0, $a5 => -1 ],
  66  [ $a0, $a6 => -1 ],
  67
  68  [ $a1, $a1 =>  0 ],
  69  [ $a1, $a2 =>  0 ],
  70  [ $a1, $a3 =>  0 ],
  71  [ $a1, $a4 => -1 ],
  72  [ $a1, $a5 => -1 ],
  73  [ $a1, $a6 => -1 ],
  74
  75  [ $a2, $a2 =>  0 ],
  76  [ $a2, $a3 =>  0 ],
  77  [ $a2, $a4 => -1 ],
  78  [ $a2, $a5 => -1 ],
  79  [ $a2, $a5 => -1 ],
  80
  81  [ $a3, $a3 =>  0 ],
  82  [ $a3, $a4 => -1 ],
  83  [ $a3, $a5 => -1 ],
  84  [ $a3, $a6 => -1 ],
  85
  86  [ $a4, $a4 =>  0 ],
  87  [ $a4, $a5 =>  0 ],
  88  [ $a4, $a6 =>  0 ],
  89
  90  [ $a5, $a5 =>  0 ],
  91  [ $a5, $a6 =>  0 ],
  92
  93  [ $a6, $a6 =>  0 ],
  94 );
  95
  96 sub compare_ok {
  97  my ($a, $cmp, $b, $exp) = @_;
  98
  99  my $desc = join " $cmp ", map "'$_'", $a, $b;
 100
 101  my $c   = eval "\$a $cmp \$b";
 102  my $err = $@;
 103
 104  if (ref $exp eq 'Regexp') {
 105   like $err, $exp, "$desc should fail";
 106  } elsif ($err) {
 107   fail "$desc failed but shouldn't: $err";
 108  } else {
 109   is $c, $exp, "$desc == '$exp'";
 110  }
 111 }
 112
 113 for my $t (@tests) {
 114  my ($a, $b, $exp) = @$t;
 115
 116  for my $r (0 .. 1) {
 117   if ($r) {
 118    ($a, $b) = ($b, $a);
 119    $exp = -$exp;
 120   }
 121
 122   compare_ok($a, '<=>', $b, $exp);
 123   compare_ok($a, '<=>', "$b", $exp);
 124   compare_ok($a, 'cmp', $b, $exp);
 125  }
 126 }