view release on metacpan or  search on metacpan

t/firebird.t  view on Meta::CPAN

#
#
use strict;
use warnings;
use 5.010;
use Test::More;
use App::Sqitch;
use App::Sqitch::Target;
use Test::MockModule;
use Path::Class;
use Try::Tiny;
use Test::Exception;
use Locale::TextDomain qw(App-Sqitch);
use File::Basename qw(dirname);
use File::Spec::Functions;
use File::Temp 'tempdir';
use DBD::Mem;
use lib 't/lib';
use DBIEngineTest;
use TestConfig;

my $CLASS;
my $uri;
my $tmpdir;
my $have_fb_driver = 1; # assume DBD::Firebird is installed and so is Firebird

# Is DBD::Firebird really installed?
try { require DBD::Firebird; } catch { $have_fb_driver = 0; };

BEGIN {
    $CLASS = 'App::Sqitch::Engine::firebird';
    require_ok $CLASS or die;
    $uri = URI->new($ENV{SQITCH_TEST_FIREBIRD_URI} || $ENV{FIREBIRD_URI} || do {
        my $user = $ENV{ISC_USER}     || $ENV{DBI_USER} || 'SYSDBA';
        my $pass = $ENV{ISC_PASSWORD} || $ENV{DBI_PASS} || 'masterkey';
        "db:firebird://$user:$pass@/"
    });
    delete $ENV{$_} for qw(ISC_USER ISC_PASSWORD);
    $tmpdir = File::Spec->tmpdir();
}

is_deeply [$CLASS->config_vars], [
    target   => 'any',
    registry => 'any',
    client   => 'any',
], 'config_vars should return three vars';

my $config = TestConfig->new('core.engine' => 'firebird');
my $sqitch = App::Sqitch->new(config => $config);
my $target = App::Sqitch::Target->new(
    sqitch => $sqitch,
    uri    => URI->new('db:firebird:foo.fdb'),
);
isa_ok my $fb = $CLASS->new(sqitch  => $sqitch, target => $target), $CLASS;

is $fb->key, 'firebird', 'Key should be "firebird"';
is $fb->name, 'Firebird', 'Name should be "Firebird"';
is $fb->username, $ENV{ISC_USER}, 'Should have username from environment';
is $fb->password, $ENV{ISC_PASSWORD}, 'Should have password from environment';
is $fb->_limit_default, '18446744073709551615', 'Should have _limit_default';
is $fb->_dsn, 'dbi:Firebird:dbname=sqitch.fdb;ib_dialect=3;ib_charset=UTF8',
    'Should append "ib_dialect=3;ib_charset=UTF8" to the DSN';

my $have_fb_client;
if ($have_fb_driver && (my $client = try { $fb->client })) {
    $have_fb_client = 1;
    like $client, qr/isql|fbsql|isql-fb/,
        'client should default to isql | fbsql | isql-fb';
}

is $fb->uri->dbname, file('foo.fdb'), 'dbname should be filled in';
is $fb->registry_uri->dbname, 'sqitch.fdb',
    'registry dbname should be "sqitch.fdb"';

is $fb->registry_destination, $fb->registry_uri->as_string,
    'registry_destination should be the same as registry URI';

my @std_opts = (
    '-quiet',
    '-bail',
    '-sqldialect' => '3',
    '-pagelength' => '16384',
    '-charset'    => 'UTF8',
);

my $dbname = $fb->connection_string($fb->uri);
is_deeply([$fb->isql], [$fb->client, @std_opts, $dbname],
          'isql command should be std opts-only') if $have_fb_client;

isa_ok $fb = $CLASS->new(sqitch => $sqitch, target => $target), $CLASS;
ok $fb->set_variables(foo => 'baz', whu => 'hi there', yo => 'stellar'),
    'Set some variables';

is_deeply([$fb->isql], [$fb->client, @std_opts, $dbname],
          'isql command should be std opts-only') if $have_fb_client;

##############################################################################
# Make sure environment variables are read.
ENV: {
    local $ENV{ISC_USER} = '__kamala__';
    local $ENV{ISC_PASSWORD} = 'answer the question';
    ok my $fb = $CLASS->new(sqitch => $sqitch, target => $target),
        'Create a firebird with environment variables set';
    is $fb->username, $ENV{ISC_USER}, 'Should have username from environment';
    is $fb->password, $ENV{ISC_PASSWORD}, 'Should have password from environment';
}

##############################################################################
# Make sure config settings override defaults.
$config->update(
    'engine.firebird.client'   => '/path/to/isql',
    'engine.firebird.target'   => 'db:firebird://freddy:s3cr3t@db.example.com:1234/widgets',
    'engine.firebird.registry' => 'meta',
);
$target = App::Sqitch::Target->new(sqitch => $sqitch);
ok $fb = $CLASS->new(sqitch => $sqitch, target => $target), 'Create another firebird';

is $fb->client, '/path/to/isql', 'client should be as configured';
is $fb->uri, URI::db->new('db:firebird://freddy:s3cr3t@db.example.com:1234/widgets'),
    'URI should be as configured';
like $fb->destination, qr{db:firebird://freddy:?\@db.example.com:1234/widgets},
    'destination should default to URI without password';
like $fb->registry_destination, qr{db:firebird://freddy:?\@db.example.com:1234/meta},
    'registry_destination should be URI with configured registry and no password';
is_deeply [$fb->isql], [(
    '/path/to/isql',
    '-user', 'freddy',
    '-password', 's3cr3t',
), @std_opts, 'db.example.com/1234:widgets'], 'firebird command should be configured';

##############################################################################
# Test connection_string.
can_ok $fb, 'connection_string';
for my $file (qw(
    foo.fdb
    /blah/hi.fdb
    C:/blah/hi.fdb
)) {
    # DB name only.
    is $fb->connection_string( URI::db->new("db:firebird:$file") ),
        $file, "Connection for db:firebird:$file";
    # DB name and host.
    is $fb->connection_string( URI::db->new("db:firebird:foo.com/$file") ),

t/firebird.t  view on Meta::CPAN

        eng => 'firebird',
    ), 'Client exception message should be correct';
}

# Make sure we have templates.
DBIEngineTest->test_templates_for($fb->key);

##############################################################################
# Can we do live tests?
my ($data_dir, $fb_version, @cleanup) = ($tmpdir);
my $id = DBIEngineTest->randstr;
my ($reg1, $reg2) = map { $_ . $id } qw(__sqitchreg_ __metasqitch_);
my $err = try {
    return unless $have_fb_driver;
    if ($uri->dbname) {
        $data_dir = dirname $uri->dbname; # Assumes local OS semantics.
    } else {
        # Assume we're running locally and create the database.
        my $dbpath = catfile($tmpdir, "__sqitchtest__$id");
        $data_dir = $tmpdir;
        $uri->dbname($dbpath);
        DBD::Firebird->create_database({
            db_path       => $dbpath,
            user          => $uri->user,
            password      => $uri->password,
            character_set => 'UTF8',
            page_size     => 16384,
        });
        # We created this database, we need to clean it up.
        @cleanup = ($dbpath);
    }

    # Try to connect.
    my $dbh = DBI->connect($uri->dbi_dsn, $uri->user, $uri->password, {
        PrintError  => 0,
        RaiseError  => 0,
        AutoCommit  => 1,
        HandleError => $fb->error_handler,
    });
    $fb_version = $dbh->selectcol_arrayref(q{
        SELECT rdb$get_context('SYSTEM', 'ENGINE_VERSION')
          FROM rdb$database
    })->[0];

    # We will need to clean up the registry DBs we create.
    push @cleanup => map { catfile $data_dir, $_ } $reg1, $reg2;
    return undef;
} catch {
    return $_ if blessed $_ && $_->isa('App::Sqitch::X');
    return App::Sqitch::X->new(
        message            => 'Failed to connect to Firebird',
        previous_exception => $_,
    ),
};

END {
    return if $ENV{CI}; # No need to clean up in CI environment.
    foreach my $dbname (@cleanup) {
        next unless -e $dbname;
        $uri->dbname($dbname);
        my $dsn = $uri->dbi_dsn . q{;ib_dialect=3;ib_charset=UTF8};
        my $dbh = DBI->connect($dsn, $uri->user, $uri->password, {
            FetchHashKeyName => 'NAME_lc',
            AutoCommit       => 1,
            RaiseError       => 0,
            PrintError       => 0,
        }) or die $DBI::errstr;

        # Disconnect any other database handles.
        $dbh->{Driver}->visit_child_handles(sub {
            my $h = shift;
            $h->disconnect if $h->{Type} eq 'db' && $h->{Active} && $h ne $dbh;
        });

        # Kill all other connections.
        $dbh->do('DELETE FROM MON$ATTACHMENTS WHERE MON$ATTACHMENT_ID <> CURRENT_CONNECTION');
        $dbh->func('ib_drop_database') or diag "Cannot drop '$dbname': $DBI::errstr";
    }
}

DBIEngineTest->run(
    class             => $CLASS,
    target_params     => [ uri => $uri, registry => catfile($data_dir, $reg1) ],
    alt_target_params => [ uri => $uri, registry => catfile($data_dir, $reg2) ],
    skip_unless => sub {
        my $self = shift;
        die $err if $err;
        # Make sure we have the right isql and can connect to the
        # database.  Adapted from the FirebirdMaker.pm module of
        # DBD::Firebird.
        my $cmd = $self->client;
        my $cmd_echo = qx(echo "quit;" | "$cmd" -z -quiet 2>&1 );
        App::Sqitch::X::hurl('isql not for Firebird')
             unless $cmd_echo =~ m{Firebird}ims;
        chomp $cmd_echo;
        say "# Detected $cmd_echo";
        # Skip if no DBD::Firebird.
        App::Sqitch::X::hurl('DBD::Firebird did not load')
            unless $have_fb_driver;
        say "# Connected to Firebird $fb_version" if $fb_version;
        return 1;
    },
    engine_err_regex  => qr/\QDynamic SQL Error\E/xms,
    init_error        => __x(
        'Sqitch database {database} already initialized',
        database => catfile($data_dir, $reg2),
    ),
    add_second_format => q{dateadd(1 second to %s)},
    test_dbh => sub {
        my $dbh = shift;
        # Check the session configuration...
        # To try: https://www.firebirdsql.org/refdocs/langrefupd21-intfunc-get_context.html
        is(
            $dbh->selectcol_arrayref(q{
                SELECT rdb$get_context('SYSTEM', 'DB_NAME')
                  FROM rdb$database
            })->[0],
            catfile($data_dir, $reg2),
            'The Sqitch db should be the current db'
        );
    },