view release on metacpan or  search on metacpan

t/177-expired-claim-takeover.t  view on Meta::CPAN

    for my $n ( 1 .. ( $opt{tasks} || 1 ) ) {
        my $rv = _run_karr( $repo, 'create', "Task $n" );
        is( $rv->{exit}, 0, "task $n created" ) or diag $rv->{stderr};
    }

    return $repo;
}

my $HOLDER  = 'agent-holder';
my $TAKEOVER = 'agent-takeover';

# The one sentence every command has to produce, whoever is stepping over the
# claim -- including the two that pass no claimant at all.
sub _trace_re {
    my ( $id, $holder ) = @_;
    return qr/task \Q$id\E: overriding the expired claim held by \Q$holder\E/;
}

subtest 'an expired claim taken over by another name is reported' => sub {
    my $repo = _setup_repo( claim_timeout => '1s', tasks => 6 );

    my $claim = _run_karr( $repo, 'move', '1,2,3,4,5,6', 'in-progress',
        '--claim', $HOLDER );
    is( $claim->{exit}, 0, 'all six tasks claimed by the holder' )
      or diag $claim->{stderr};

    # One sleep for the whole subtest: every claim above was stamped before it,
    # so every card below is expired by the same wait.
    sleep 2;

    subtest 'handoff under a different name' => sub {
        my $r = _run_karr( $repo, 'handoff', '1', '--claim', $TAKEOVER,
            '--note', 'x' );

        # Unchanged, and deliberately so: an expired claim must not start
        # blocking anybody just because it is now audible.
        is( $r->{exit}, 0, 'the handoff still succeeds' ) or diag $r->{stderr};
        like( $r->{stdout}, qr/Handed off task 1/, '...and still says so' );

        like( $r->{stderr}, _trace_re( 1, $HOLDER ),
            'STDERR names the holder the takeover stepped over' );

        my $show = _run_karr( $repo, 'show', '1' );
        like( $show->{stdout}, qr/^Claimed:\s+\Q$TAKEOVER\E$/m,
            'the card really did change hands' );
    };

    subtest 'archive, which passes no claimant at all' => sub {
        my $r = _run_karr( $repo, 'archive', '2' );
        is( $r->{exit}, 0, 'the archive still succeeds' ) or diag $r->{stderr};
        like( $r->{stderr}, _trace_re( 2, $HOLDER ),
            'a card archived out from under an expired claim says whose it was' );
    };

    subtest 'delete, which checks the claim twice' => sub {
        my $r = _run_karr( $repo, 'delete', '3', '--yes' );
        is( $r->{exit}, 0, 'the delete still succeeds' ) or diag $r->{stderr};

        # Delete applies the rule once outside the guard (to decide whether to
        # prompt) and again inside delete_task_guarded, against the revision it
        # removes. Two checks, one card, one line: the record is keyed by task
        # id and replaced, not appended to.
        my @lines = ( $r->{stderr} =~ /(overriding the expired claim)/g );
        is( scalar @lines, 1,
            'the two check_claim calls on the delete path report once, not twice' )
          or diag $r->{stderr};
        like( $r->{stderr}, _trace_re( 3, $HOLDER ), '...and it names the holder' );
    };

    subtest 'the holder continuing under its own name is not reported' => sub {
        # check_claim answers "the current claimant may always proceed" before
        # it ever asks about expiry, so a long-running agent that outlives its
        # own claim_timeout gets no warning about itself.
        my $r = _run_karr( $repo, 'move', '4', 'review', '--claim', $HOLDER );
        is( $r->{exit}, 0, 'the holder still moves its own card' )
          or diag $r->{stderr};
        unlike( $r->{stderr}, qr/expired claim/,
            'no trace: nothing changed hands' );
    };

    subtest '--quiet silences the human copy' => sub {
        my $r = _run_karr( $repo, 'move', '5', 'review', '--claim', $TAKEOVER,
            '--quiet' );
        is( $r->{exit}, 0, 'the move still succeeds under --quiet' )
          or diag $r->{stderr};
        unlike( $r->{stderr}, qr/expired claim/,
            '--quiet silences the takeover line like every other warning' );
    };

    subtest '--json carries the pair instead of the line' => sub {
        my $r = _run_karr( $repo, 'handoff', '6', '--claim', $TAKEOVER,
            '--note', 'x', '--json' );
        is( $r->{exit}, 0, 'the handoff still succeeds under --json' )
          or diag $r->{stderr};

        unlike( $r->{stderr}, qr/expired claim/,
            'nothing on STDERR: a JSON consumer would never read it there' );

        my $data = eval { decode_json( $r->{stdout} ) };
        ok( $data, 'STDOUT is one decodable JSON object' )
          or diag "stdout: $r->{stdout}";
        is( ref $data->{expired_claim}, 'HASH',
            'the payload carries an expired_claim object' )
          or return;

        # Structured, not a sentence: karr-foundation attributes stalls per
        # claim name, so the name it needs must not have to be parsed out of
        # English.
        is( $data->{expired_claim}{held_by}, $HOLDER,
            'expired_claim.held_by is the previous holder' );
        like( $data->{expired_claim}{claimed_at},
            qr/\A\d{4}-\d{2}-\d{2}T\d{2}:\d{2}:\d{2}Z\z/,
            'expired_claim.claimed_at is when that claim was stamped' );
    };
};

subtest 'a live claim is still refused, loudly and for every command' => sub {
    my $repo = _setup_repo( tasks => 4 );   # default claim_timeout: 1h

    my $claim = _run_karr( $repo, 'move', '1,2,3', 'in-progress',