The London Perl and Raku Workshop takes place on 26th Oct 2024. If your company depends on Perl, please consider sponsoring and/or attending.
#!perl

use strict;
use warnings;

use Test::More tests => 2 * (2 + (8 * 7) / 2 + 2) + 3 * 4;

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 $x_ver   = qr/Version mismatch/;
my $x_range = qr/Incompatible ranges/;

my @tests = (
 [ [ $a0 ] => $a0 ],
 [ [ $a1 ] => $a1 ],

 [ [ $a0, $a0 ] => $a0 ],
 [ [ $a0, $a1 ] => $a1 ],
 [ [ $a0, $a2 ] => $a2 ],
 [ [ $a0, $a3 ] => $a3 ],
 [ [ $a0, $a4 ] => $a4 ],
 [ [ $a0, $a5 ] => $a5 ],
 [ [ $a0, $a6 ] => $a6 ],

 [ [ $a1, $a1 ] => $a1 ],
 [ [ $a1, $a2 ] => $x_ver ],
 [ [ $a1, $a3 ] => $a1 ],
 [ [ $a1, $a4 ] => $x_ver ],
 [ [ $a1, $a5 ] => $x_ver ],
 [ [ $a1, $a6 ] => $x_ver ],

 [ [ $a2, $a2 ] => $a2 ],
 [ [ $a2, $a3 ] => $a2 ],
 [ [ $a2, $a4 ] => $x_ver ],
 [ [ $a2, $a5 ] => $x_range ],
 [ [ $a2, $a5 ] => $x_range ],

 [ [ $a3, $a3 ] => $a3 ],
 [ [ $a3, $a4 ] => $x_ver ],
 [ [ $a3, $a5 ] => $x_range ],
 [ [ $a3, $a6 ] => $x_range ],

 [ [ $a4, $a4 ] => $a4 ],
 [ [ $a4, $a5 ] => $a4 ],
 [ [ $a4, $a6 ] => $x_ver ],

 [ [ $a5, $a5 ] => $a5 ],
 [ [ $a5, $a6 ] => $a6 ],

 [ [ $a6, $a6 ] => $a6 ],

 [ [ ($a1) x 3 ] => $a1 ],
 [ [ ($a2) x 4 ] => $a2 ],
);

for my $t (@tests) {
 my ($args, $exp) = @$t;

 for my $r (0 .. 1) {
  my @a = @$args;
  @a = reverse @a if $r;

  my $desc = join ' AND ', map "'$_'", @a;

  my $a   = eval { A->and(@a) };
  my $err = $@;

  if (ref $exp eq 'Regexp') {
   like $err, $exp, "$desc should fail";
  } elsif ($err) {
   fail "$desc failed but shouldn't: $err";
  } else {
   ok +($a == $exp), "$desc == '$exp'";
  }
 }
}

my $a1b = A->new(
 category => 'test',
 name     => 'a',
 version  => '1.0',
);

my $b1 = A->new(
 category => 'test',
 name     => 'b',
 version  => '1.0',
 range    => '<',
);

my $b2 = A->new(
 category => 'test',
 name     => 'b',
 version  => '3.0',
 range    => '<',
);

my @folded = eval { A->fold($a1b, $a5, $b1, $b2) };
is $@,      '', 'aabb: no error';
is @folded, 2,  'aabb: fold results in two atoms';
ok $folded[0] == $a5, 'aabb: first result is >=test/a-2.0';
ok $folded[1] == $b1, 'aabb: second result is <test/b-1.0';

@folded = eval { A->fold($a1b, $b1, $b2, $a5) };
is $@,      '', 'abba: no error';
is @folded, 2,  'abba: fold results in two atoms';
ok $folded[0] == $a5, 'abba: first result is >=test/a-2.0';
ok $folded[1] == $b1, 'abba: second result is <test/b-1.0';

@folded = eval { A->fold($a1b, $b1, $a5, $b2) };
is $@,      '', 'abab: no error';
is @folded, 2,  'abab: fold results in two atoms';
ok $folded[0] == $a5, 'abab: first result is >=test/a-2.0';
ok $folded[1] == $b1, 'abab: second result is <test/b-1.0';