view release on metacpan or  search on metacpan

t/lib/DBIEngineTest.pm  view on Meta::CPAN

        $mock_dbh->mock(begin_work => sub { $txn = 1 });
        $mock_dbh->mock(commit     => sub { $txn = 0  });
        $mock_dbh->mock(rollback   => sub { $txn = -1 });
        my @do;
        $mock_dbh->mock(do => sub {
            shift;
            @do = @_;
        });
        ok $engine->begin_work, 'Begin work';
        is $txn, 1, 'Should have started a transaction';
        ok $engine->finish_work, 'Finish work';
        is $txn, 0, 'Should have committed a transaction';
        ok $engine->begin_work, 'Begin work again';
        is $txn, 1, 'Should have started another transaction';
        ok $engine->rollback_work, 'Rollback work';
        is $txn, -1, 'Should have rolled back a transaction';
        $mock_dbh->unmock('do');

        ######################################################################
        # Revert and re-deploy all the changes.
        my @all_changes  = ($change, $change2, $fred, $barney, $ext_change, $ext_change2, $hyper, $ext_change3);
        ok $engine->log_revert_change($_),
            'Revert "' . $_->name . '" change' for reverse @all_changes;
        ok $engine->log_deploy_change($_),
            'Deploy "' . $_->name . '" change' for @all_changes;

        ######################################################################
        # Add a reworked change.
        my $name = $change2->name;
        ok my $rev_change = $plan->rework( name => $name ), qq{Rework change "$name"};
        $_->resolved_id( $engine->change_id_for_depend($_) ) for $rev_change->requires;

        # Should get an error for identical deploy script except on engines
        # that don't support unique constraints.
        is $rev_change->script_hash, $change2->script_hash,
            'It should have the same script hash';
        unless ($p{no_unique}) {
            throws_ok { $engine->log_deploy_change($rev_change) } 'App::Sqitch::X',
                'Should die on unchanged rework deploy script';
            # diag "ERR: ", ($DBI::err // ''), " (", ($DBI::state // ''), "): ", $DBI::errstr // '';
            is $@->ident, 'engine', 'Mode should be "engine"';
            is $@->message, __x(
                'Cannot log change "{change}": The deploy script is not unique',
                change => $name,
            ), 'And it should report the script is not unique';

            # Make sure log_deploy_change dies on any other error.
            MOCKPROJECT: {
                my $engine_mocker = Test::MockModule->new(ref $engine);
                $engine_mocker->mock(_unique_error => 0);
                throws_ok { $engine->log_deploy_change($rev_change) } 'App::Sqitch::X',
                    'Should re-throw if not a unique erorr';
                is $@->ident, $DBI::state, 'Mode should be the error state';
                is $@->message, $DBI::errstr, 'Should not have the underlying DB error';
            }
        }

        # Make a temporary copy of the deploy file so we can restore it later.
        my $deploy_file = $rev_change->deploy_file;
        my $tmp_dir = dir( tempdir CLEANUP => 1 );
        my $backup = $tmp_dir->file($deploy_file->basename);
        ok $deploy_file->copy_to($backup), 'Back up deploy file';

        # Modify the file so that its hash digest will vary.
        delete $rev_change->{script_hash};
        my $fh = $deploy_file->opena or die "Cannot open $deploy_file: $!\n";
        try {
            say $fh '-- Append line to reworked script so it gets a new SHA-1 hash';
            close $fh;
            isnt $rev_change->script_hash, $change2->script_hash,
                'It should no longer have the same script hash';
            lives_ok {
                ok $engine->log_deploy_change($rev_change), 'Deploy the reworked change';
            } 'The deploy should not fail';
        } finally {
            # Restore the reworked script.
            $backup->copy_to($deploy_file);
        };

        # Make sure that change_id_for() chokes on the dupe.
        MOCKVENT: {
            my $sqitch_mocker = Test::MockModule->new(ref $sqitch);
            my @args;
            $sqitch_mocker->mock(vent => sub { shift; push @args => \@_ });
            throws_ok { $engine->change_id_for( change => $name) } 'App::Sqitch::X',
                'Should die on ambiguous change spec';
            is $@->ident, 'engine', 'Mode should be "engine"';
            is $@->message, __ 'Change Lookup Failed',
                'And it should report change lookup failure';
            is_deeply \@args, [
                [__x(
                    'Change "{change}" is ambiguous. Please specify a tag-qualified change:',
                    change => $name,
                )],
                [ '  * ', $rev_change->format_name . '@HEAD' ],
                [ '  * ', $change2->format_tag_qualified_name ],
            ], 'Should have vented output for lookup failure';

            # But it should work okay if we ask for the first ID.
            ok my $id = $engine->change_id_for(change => $name, first => 1),
                'Should get ID for first of ambiguous change spec';
            is $id, $change2->id, 'Should now have first change id';
        }

        is $engine->change_id_for( change => $change->name, tag => 'alpha'),
            $change->id,
            'change_id_for() should find the tag-qualified change ID';
        is $engine->change_id_for( change => $name, tag => 'HEAD'),
            $rev_change->id,
            'change_id_for() should find the reworked change ID @HEAD';


        ######################################################################
        # Tag and Rework the change again.
        ok $plan->tag(name => 'theta'), 'Tag the plan "theta"';
        ok $engine->log_new_tags($rev_change), 'Log new tag';

        ok my $rev_change2 = $plan->rework( name => $name ),
            qq{Rework change "$name" again};
        $fh = $deploy_file->opena or die "Cannot open $deploy_file: $!\n";
        try {
            say $fh '-- Append another line to reworked script for a new SHA-1 hash';
            close $fh;
            $_->resolved_id( $engine->change_id_for_depend($_) ) for $rev_change2->requires;
            lives_ok {
                ok $engine->log_deploy_change($rev_change2),
                    'Deploy the reworked change';
            } 'Should not die deploying the reworked change';
        } finally {
            # Restore the reworked script.
            $tmp_dir->file( $deploy_file->basename )->copy_to($deploy_file);
        };

        # make sure that change_id_for is still good with things.
        for my $spec (
            [