view release on metacpan or  search on metacpan

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

            $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 (
            [

                'beta instance of change',
                { change => $name, tag => 'beta' },
                $change2->id,
            ],
            [
                'HEAD instance of change',
                { change => $name, tag => 'HEAD' },
                $rev_change2->id,
            ],
            [
                'second instance of change by tag',
                { change => $name, tag => 'theta' },
                $rev_change->id,
            ],
        ) {
            my ( $desc, $params, $exp_id ) = @{ $spec };
            is $engine->change_id_for(%{ $params }), $exp_id, "Should find id for $desc";
        }

        # Unmock everything and call it a day.
        $mock_dbh->unmock_all;
        $mock_sqitch->unmock_all;

        ######################################################################
        # Let's make sure script_hash upgrades work.
        $engine->dbh->do('UPDATE changes SET script_hash = change_id WHERE 1=1');
        ok $engine->_update_script_hashes, 'Update script hashes';

        # Make sure they were updated properly.
        my $sth = $engine->dbh->prepare(
            'SELECT change_id, script_hash FROM changes WHERE project = ?',
        );
        $sth->execute($plan->project);
        while (my $row = $sth->fetch) {
            my $change = $plan->get($row->[0]);
            is $row->[1], $change->script_hash,
                'Should have updated script hash for ' . $change->name;
        }

        # Make sure no other projects were updated.
        $sth = $engine->dbh->prepare(
            'SELECT change_id, script_hash FROM changes WHERE project <> ?',
        );
        $sth->execute($plan->project);
        while (my $row = $sth->fetch) {
            is $row->[1], $row->[0],
                'Change ID and script hash should be ' . substr $row->[0], 0, 6;
        }

        ######################################################################
        # Test try_lock() and wait_lock().
        if (my $sql = ($p{lock_sql} || sub {})->($engine)) {
            ok !$engine->dbh->selectcol_arrayref($sql->{is_locked})->[0],
                'Should not be locked';
            ok $engine->try_lock, 'Try lock';
            ok $engine->dbh->selectcol_arrayref($sql->{is_locked})->[0],
                'Should be locked';
            ok $engine->wait_lock, 'Should not have to wait for lock';

            # Make a second connection to the database.
            my $dbh = DBI->connect($engine->_dsn, $engine->username, $engine->password, {
                PrintError  => 0,
                RaiseError  => 0,
                AutoCommit  => 1,
                HandleError => $engine->error_handler,
            });
            ok !$dbh->selectcol_arrayref($sql->{try_lock})->[0],
                'Should fail to get same lock in second connection';

            lives_ok { $engine->dbh->do($sql->{free_lock}) } 'Free the lock';
            # Wait for the free to complete if frees are async.
            if (my $wait = $sql->{async_free}) {
                while ($wait) {
                    $wait = $engine->dbh->selectcol_arrayref($sql->{free_lock})->[0];
                }
            }

            ok !$engine->dbh->selectcol_arrayref($sql->{is_locked})->[0],
                'Should not be locked';
            ok $dbh->selectcol_arrayref($sql->{try_lock})->[0],
                'Should now get the lock in second connection';
            ok $engine->dbh->selectcol_arrayref($sql->{is_locked})->[0],
                'Should be locked';
            ok !$engine->try_lock, 'Try lock should now return false';

            # Make sure that wait_lock waits.
            my $secs = $sql->{wait_time} || 0.005;
            $engine->lock_timeout($secs);
            my $time = [gettimeofday];
            ok !$engine->wait_lock, 'Should wait and fail to get the lock';
            cmp_ok tv_interval($time), '>=', $secs, 'Should have waited for the lock';
            lives_ok { $dbh->do($sql->{free_lock}) } 'Free the second lock';

            # Wait for the free to complete if frees are async.
            if (my $wait = $sql->{async_free}) {
                while ($wait) {
                    $wait = $engine->dbh->selectcol_arrayref($sql->{free_lock})->[0];
                }
            }