view release on metacpan or  search on metacpan

t/198-pick-rules-shared.t  view on Meta::CPAN

  my $buf = '';
  my $err = do {
    local $@;
    eval {
      local *STDOUT;
      open STDOUT, '>', \$buf or die $!;
      $cmd->execute( [], [] );
    };
    $@;
  };
  die "pick died: $err" if $err;
  return $buf =~ /^Picked task (\d+):/m ? $1 : undef;
}

# karr-foundation's ticket mode, asked about the same board. Claims nothing.
sub ticket_id {
  my ( $repo ) = @_;
  return App::karr::Foundation::Picker->new( store => _store($repo) )->next_ticket;
}

# Ask both selectors about the same board, in the same state, and hold both
# against the pinned expectation. Foundation goes first, because pick writes.
sub both_choose {
  my ( $repo, $expected, $why ) = @_;
  is( ticket_id($repo), $expected, "foundation ticket mode: $why" );
  is( pick_id( $repo, claim => "agent-" . ( $expected // 'none' ) ),
    $expected, "karr pick: $why" );
  return;
}

subtest 'both callers resolve the rules to one definition' => sub {
  ok( App::karr::Cmd::Pick->does('App::karr::Role::PickRules'),
    'karr pick composes the shared pick rules' );
  ok( App::karr::Foundation::Picker->does('App::karr::Role::PickRules'),
    'foundation ticket mode composes the shared pick rules' );

  # Same name is not enough -- two copies would answer ->can too. The installed
  # coderef has to be the role's own, in both packages, or one of them is
  # running something else under the shared name.
  for my $method ( qw( pickable pick_rank pick_candidates ) ) {
    my $rule = App::karr::Role::PickRules->can($method);
    ok( $rule, "the role defines $method" ) or next;
    is( App::karr::Cmd::Pick->can($method), $rule,
      "karr pick's $method is the role's own coderef" );
    is( App::karr::Foundation::Picker->can($method), $rule,
      "foundation's $method is the role's own coderef" );
  }
};

subtest 'neither caller keeps a rule of its own to drift with' => sub {
  # The re-fork guard. Composing the role does not stop anyone from adding a
  # second sort or a second eligibility test next to it -- that is exactly how
  # this ticket happened -- so read both files and insist the rule is not
  # spelled out in either. POD and comments are stripped: both files talk about
  # the rules at length, and #198's own comments name them.
  my %file = (
    'karr pick'          => 'lib/App/karr/Cmd/Pick.pm',
    'foundation ticket'  => 'lib/App/karr/Foundation/Picker.pm',
  );

  # Each fragment is a piece of the rule that used to be written out locally:
  # the three-way comparison chain of the ranking, the two config lists it
  # ranks from, and the three predicates eligibility is made of.
  my @forbidden = (
    [ qr/<=>/,                 'a comparison of its own' ],
    [ qr/\bpriorities\b/,      'the board priorities list' ],
    [ qr/\bclasses\b/,         'the board classes list' ],
    [ qr/is_terminal_status/,  'the terminal-status test' ],
    [ qr/has_blocked/,         'the blocked test' ],
    [ qr/has_claimed_by/,      'the claim test' ],
    [ qr/_claim_expired/,      'the claim-expiry test' ],
  );

  for my $who ( sort keys %file ) {
    my $src = path( $file{$who} )->slurp_utf8;
    $src =~ s/^=\w+.*?^=cut\b.*?$//msg;
    $src =~ s/^\s*#.*$//mg;
    for my $rule ( @forbidden ) {
      my ( $re, $what ) = @$rule;
      unlike( $src, $re,
        "$file{$who} ($who) does not carry $what -- it asks the role" );
    }
  }
};

subtest 'the ranking itself, pinned card by card' => sub {
  # A board whose priorities and classes are its own, so nothing here can be
  # satisfied by a hardcoded table (#149), and every rung of the rule is
  # load-bearing: class before priority, priority most-urgent-last in the
  # config list, id as the tie-break, an unknown class ranking where
  # `standard` would and an unknown priority ranking below every known one.
  my $repo = _board(
    priorities => [qw( p0 p1 p2 p3 )],
    classes    => [qw( alpha beta gamma )],
  );
  mk( $repo, id => 1, class => 'beta',  priority => 'p3' );
  mk( $repo, id => 2, class => 'alpha', priority => 'p0' );
  mk( $repo, id => 3, class => 'beta',  priority => 'p3' );
  mk( $repo, id => 4, class => 'gamma', priority => 'p3' );
  mk( $repo, id => 5, class => 'beta',  priority => 'p1' );
  mk( $repo, id => 6, class => 'alpha', priority => 'p1' );
  mk( $repo, id => 7, class => 'quux',  priority => 'p2' );
  mk( $repo, id => 8, class => 'beta',  priority => 'nonesuch' );

  # 7 and 6 and 2 first: class index 0 (`quux` is not in the list, so it ranks
  # where `standard` would, and `standard` is not in this list either -- index
  # 0), most urgent priority first. Then beta: p3 with the id tie-break, then
  # p1, then the priority the board never heard of. gamma last.
  #
  # What this order does NOT pin is that last step, the fallback for a class
  # the board does not list on a board that lists no `standard` either: 7 has
  # the most urgent priority of the three class-0 cards, so it comes out first
  # whether that fallback is karr's 0 or kanban-md's -1 (ticket #240). The
  # subtest below is the one that can tell those apart -- do not read this
  # `@expected` as cover for it.
  my @expected = ( 7, 6, 2, 1, 3, 5, 8, 4 );

  for my $i ( 0 .. $#expected ) {
    both_choose( $repo, $expected[$i], "round " . ( $i + 1 ) . " is task $expected[$i]" );
  }