view release on metacpan or  search on metacpan

t/191-foundation-questions.t  view on Meta::CPAN

    my $id = $box->ask(
        question => 'Which registry do we publish to?',
        context  => 'The release gate is waiting on this.',
        options  => [ 'cpan', 'darkpan' ],
        default  => 'cpan',
        policy   => 'use_default',
        deadline => stamp(3600),
        step     => 12,
    );
    is( $id, 1, 'the first question is #1' );

    is_deeply(
        [ refs_under( $repo, 'refs/karr-foundation/' ) ],
        ['refs/karr-foundation/questions/1/ask'],
        'asking writes one ref and nothing else'
    );

    my $q = $box->question(1);
    is( $q->{question}, 'Which registry do we publish to?', 'the question survives' );
    is( $q->{context},  'The release gate is waiting on this.', 'the context survives' );
    is_deeply( $q->{options}, [ 'cpan', 'darkpan' ], 'the options survive' );
    is( $q->{default}, 'cpan',        'the default survives' );
    is( $q->{policy},  'use_default', 'the policy survives' );
    is( $q->{step},    12,            'the step the chain is waiting on survives' );
    like( $q->{asked}, qr/\A[0-9]{4}-[0-9]{2}-[0-9]{2}T[0-9:]{8}Z\z/, 'and when' );

    my $before = oid_of( $repo, 'refs/karr-foundation/questions/1/ask' );
    $box->settle( 1, 'darkpan', note => 'the release is a private one' );

    is_deeply(
        [ refs_under( $repo, 'refs/karr-foundation/' ) ],
        [   'refs/karr-foundation/questions/1/answer',
            'refs/karr-foundation/questions/1/ask',
        ],
        'the answer is its own ref beside the question'
    );
    is( oid_of( $repo, 'refs/karr-foundation/questions/1/ask' ), $before,
        'answering does not rewrite the question ref -- which is the whole '
      . 'reason the answer is not a field in it (#190)' );

    my $a = $box->answer(1);
    is( $a->{answer}, 'darkpan', 'the answer is there' );
    is( $a->{note}, 'the release is a private one', 'with its note' );
    is( $a->{question}, 'Which registry do we publish to?',
        'and it names the question it answers' );
};

subtest 'an answer that names another question does not settle this one' => sub {
    my $repo = init_repo();
    my $box  = mk_mailbox($repo);

    my $id = $box->ask( question => 'Ship it?' );
    $box->settle( $id, 'yes' );
    is( $box->resolve($id)->{state}, 'answered', 'the matching answer counts' );

    # What two clones minting the same id between syncs leaves behind: an
    # answer ref that survived and an ask ref that is now somebody else's
    # question. Simulated by writing the ask ref to a different question.
    App::karr::Git->new( dir => "$repo" )->write_ref(
        'refs/karr-foundation/questions/1/ask',
        "id: 1\nquestion: Delete the backups?\nasked: " . stamp(-60) . "\npolicy: block\n" );

    my $warned = '';
    my $r = do {
        local $SIG{__WARN__} = sub { $warned .= $_[0] };
        $box->resolve($id);
    };
    is( $r->{state}, 'open',
        'an answer to a different question does not settle this one' );
    like( $warned, qr/different question/, 'and it says so out loud' );

    # ... and re-answering it needs no force: there is nothing to protect.
    $box->settle( $id, 'no' );
    is( $box->resolve($id)->{state}, 'answered', 'the new answer settles it' );
    is( $box->answer($id)->{answer}, 'no',       'with the new value' );
};

subtest 'a mint that loses the race bumps instead of clobbering the winner' => sub {
    my $repo = init_repo();
    my $box  = mk_mailbox($repo);
    my $git  = App::karr::Git->new( dir => "$repo" );

    # Another writer takes the id between this one's read and its write. No
    # fork needed to pin the decision: what matters is that the create-only
    # write refuses and the caller moves on to the next id.
    my $raced = 0;
    no warnings 'redefine';
    my $orig = \&App::karr::Git::write_ref_cas;
    local *App::karr::Git::write_ref_cas = sub {
        my ( $self, $ref, $content, $old ) = @_;
        if ( !$raced++ && $ref eq 'refs/karr-foundation/questions/1/ask' ) {
            $git->write_ref( $ref,
                "id: 1\nquestion: Somebody else got here first\n"
              . "asked: " . stamp(-5) . "\npolicy: block\n" );
        }
        return $orig->( $self, $ref, $content, $old );
    };

    my $id = $box->ask( question => 'Mine' );
    is( $id, 2, 'the loser takes the next id' );
    is( $box->question(1)->{question}, 'Somebody else got here first',
        'and the winner is untouched' );
    is( $box->question(2)->{question}, 'Mine', 'while the loser is stored whole' );
};

subtest 'two answers at once is one answer and one refusal' => sub {
    my $repo = init_repo();
    my $box  = mk_mailbox($repo);
    my $id   = $box->ask( question => 'Ship it?' );

    $box->settle( $id, 'yes' );
    my $err = err_of( sub { $box->settle( $id, 'no' ) } );
    like( $err, qr/already answered/, 'the second answer is refused' );
    unlike( $err, qr/ at \S+ line \d+/, 'without a source location' );
    is( $box->answer($id)->{answer}, 'yes', 'and the first one stands' );

    $box->settle( $id, 'no', force => 1 );
    is( $box->answer($id)->{answer}, 'no', 'force is the way to change it' );
};

subtest 'the policy for nobody-answers is checked where it is written' => sub {