view release on metacpan or  search on metacpan

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

=item C<version_query>

  version_query => 'SELECT version()',

Optional SQL query that should return a single row with a single column
containing the engine server version. Used to display a diagnostic in the
test output.

=item C<init_error>

    init_error => __x(
        'Sqitch schema "{schema}" already exists',
        schema => $reg2,
    ),

Localized string representing the error raised when database initialization
fails because the registry database already exists. Required.

=item C<engine_err_regex>

    engine_err_regex => qr/^ERROR:  /,

Regular expression that matches an error from the database engine. Required.

=item C<test_dbh>

    test_dbh => sub {
        my $dbh = shift;
        # Make sure the sqitch schema is the first in the search path.
        is $dbh->selectcol_arrayref('SELECT current_schema')->[0],
            $reg2, 'The Sqitch schema should be the current schema';
    },

Optional subroutine that tests a database connection once it has been
established. Use to test that connection parameters were properly set or
executed.

=item C<add_second_format>

    add_second_format => 'dateadd(second, 1, %s)',

Optional C<sprintf> format that adds one second to the named timestamp
column, to be filled in for C<%s>. Use for engines without sub-second
timestamp precision.

=item C<no_unique>

  no_unique => 1,

Indicates that the engine being tested does not support unique constraints.
Required for such engines.

=item C<lock_sql>

Anonymous subroutine that returns a hash reference with SQL queries to test
for various lock states. Required only for engines that support locking on
a per-deploy basis. The keys in the returned hash reference must be:

=over

=item C<is_locked>

An SQL query that returns true if a lock is in place. Required.

=item C<try_lock>

An SQL query that returns true when it creates a lock and false when it fails
to create a lock. Required.

=item C<free_lock>

An SQL query that frees a lock. Required.

=item C<wait_time>

Time to pass to C<lock_timeout> to wait for a lock to time out. Defaults to
C<0.005>.

=item C<async_free>

Boolean indicating whether the freeing of a lock is performed asynchronously.
Required only for engines that don't free locks synchronously.

=back

=back

=cut

sub run {
    my ( $self, %p ) = @_;

    my $class         = $p{class};
    my @sqitch_params = @{ $p{sqitch_params} || [] };
    my $user1_name    = 'Marge Simpson';
    my $user1_email   = 'marge@example.com';
    my $mock_sqitch   = Test::MockModule->new('App::Sqitch');

    # Mock script hashes using lines from the README.
    my $mock_change = Test::MockModule->new('App::Sqitch::Plan::Change');
    my @lines = grep { $_ } file('README.md')->slurp(
        chomp  => 1,
        iomode => '<:raw'
    );

    # Each change should retain its own hash.
    my $orig_deploy_hash;
    $mock_change->mock(_deploy_hash => sub {
        my $self = shift;
        $self->$orig_deploy_hash || sha1_hex shift @lines;
    });
    $orig_deploy_hash = $mock_change->original('_deploy_hash');

    can_ok $class, qw(
        initialized
        initialize
        run_file
        run_handle
        log_deploy_change
        log_fail_change
        log_revert_change

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

            # 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];
                }
            }

            # Now wait lock should acquire the lock.
            ok $engine->wait_lock, 'Should no longer wait for lock';
            ok $engine->dbh->selectcol_arrayref($sql->{is_locked})->[0],
                'Should be locked';
            lives_ok { $dbh->do($sql->{free_lock}) } 'Free the lock one last time';
        }

        ######################################################################
        # All done.
        done_testing;
    };
}

sub dt_for_change {
    my $engine = shift;
    my $col = sprintf $engine->_ts2char_format, 'committed_at';
    my $dtfunc = $engine->can('_dt');
    $dtfunc->($engine->dbh->selectcol_arrayref(
        "SELECT $col FROM changes WHERE change_id = ?",
        undef, shift
    )->[0]);
}

sub dt_for_tag {
    my $engine = shift;
    my $col = sprintf $engine->_ts2char_format, 'committed_at';
    my $dtfunc = $engine->can('_dt');
    $dtfunc->($engine->dbh->selectcol_arrayref(
        "SELECT $col FROM tags WHERE tag_id = ?",
        undef, shift
    )->[0]);
}

sub all {
    my $iter = shift;
    my @res;
    while (my $row = $iter->()) {
        push @res => $row;
    }
    return \@res;
}

sub dt_for_event {
    my ($engine, $offset) = @_;
    my $col = sprintf $engine->_ts2char_format, 'committed_at';
    my $dtfunc = $engine->can('_dt');
    my $dbh = $engine->dbh;
    return $dtfunc->($engine->dbh->selectcol_arrayref(qq{
        SELECT ts FROM (
            SELECT ts, rownum AS rnum FROM (
                SELECT $col AS ts
                  FROM events
                 ORDER BY committed_at ASC
            )
        ) WHERE rnum = ?
    }, undef, $offset + 1)->[0]) if $dbh->{Driver}->{Name} eq 'Oracle';
    return $dtfunc->($engine->dbh->selectcol_arrayref(
        "SELECT FIRST 1 SKIP $offset $col FROM events ORDER BY committed_at ASC",
    )->[0]) if $dbh->{Driver}->{Name} eq 'Firebird';
    return $dtfunc->($engine->dbh->selectcol_arrayref(
        "SELECT $col FROM events ORDER BY committed_at ASC LIMIT 1 OFFSET $offset",
    )->[0]);
}