Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

536 lines (367 sloc) 10.963 kb
package TestFirebird;
#
# Helper file for the DBD::Firebird tests
#
# 2011-04-01: Created by stefan(s.bv.)
# Based on the DBD::InterBase - Makefile.PL script
# (2008-01-08 05:29:19Z by edpratomo)
# Inspired by the 't/dbdpg_test_setup.pl' script from DBD::Pg.
#
use strict;
use warnings;
use Carp;
use DBI 1.43; # minimum version for 'parse_dsn'
use File::Spec;
use File::Basename;
use File::Temp;
use Test::More;
use base 'Exporter';
our @EXPORT = qw(find_new_table);
sub import {
my $me = shift;
$me->export_to_level(1,undef, qw(find_new_table));
}
use constant test_conf => 't/tests-setup.tmp.conf';
use constant test_mark => 't/tests-setup.tmp.OK';
use constant dbd => 'DBD::Firebird';
sub new {
my $class = shift;
my $self = bless {@_}, $class;
$self->read_cached_configs;
$self->check_credentials;
return $self;
}
sub check_credentials {
my $self = shift;
unless ( $self->{pass}
or $ENV{DBI_PASS}
or $ENV{ISC_PASSWORD} )
{
plan skip_all =>
"Neither DBI_PASS nor ISC_PASSWORD present in the environment";
exit 0; # do not fail with CPAN testers
}
}
=head2 read_cached_configs
Read the connection parameters from the 'tests-setup.conf' file.
=cut
sub read_cached_configs {
my $self = shift;
my $test_conf = $self->test_conf;
if (-f $test_conf) {
# print "\nReading cached test configuration...\n";
open my $file_fh, '<', $test_conf
or croak "Can't open file ", $test_conf, ": $!";
foreach my $line (<$file_fh>) {
next if $line =~ m{^#+}; # skip comments
my ($key, $val) = split /:=/, $line, 2;
chomp $val;
$self->{$key} = $val;
}
close $file_fh;
}
}
=head2 connect_to_database
Initialize setting for the connection.
Connect to database and return handler.
Takes optional parameter for connection attributes.
=cut
sub connect_to_database {
my $self = shift or confess;
my $attr = shift;
my $error_str = $self->tests_init();
my $dbh;
unless ($error_str) {
my $default_attr = {
RaiseError => 1,
PrintError => 0,
AutoCommit => 1,
ib_enable_utf8 => 1,
};
# Merge attributes
@{$default_attr}{ keys %{$attr} } = values %{$attr};
# Connect to the database
eval {
$dbh =
DBI->connect( $self->{tdsn}, $self->{user}, $self->{pass},
$default_attr );
};
if ($@) {
$error_str .= "Connection error: $@";
}
}
return ($dbh, $error_str);
}
=head2 tests_init
Read the configurations from the L<tests-setup.conf> file, and checks if
they are valid.
=cut
sub tests_init {
my $self = shift or confess;
my $error_str;
if ( $self->check_mark() ) {
return undef;
}
else {
$error_str = $self->check_and_set_cached_configs;
unless ($error_str) {
$error_str = $self->setup_test_database;
}
}
return $error_str;
}
=head2 check_cached_configs
Simply (double)check every value and return what's missing.
=cut
sub check_and_set_cached_configs {
my $self = shift;
my $error_str = q{};
# Check user and pass, try the get from ENV if missing
$self->{user} ||= $self->get_user;
$self->{pass} ||= $self->get_pass;
# Check host
$self->{host} ||= $self->get_host;
# The user can control the test database name and path using the
# DBI_DSN environment var. Other option is a default made up dsn
$self->{tdsn}
= $self->{tdsn}
? $self->check_dsn( $self->{tdsn} )
: $self->get_dsn;
$error_str .= $self->{tdsn} ? q{} : q{wrong dsn,};
# The database path
$self->{path} = $self->get_path;
my (undef, $path, $file) = File::Spec->splitpath($self->{path});
my ($base, $type) = $file =~ /^(.*?)(\.fdb)\z/i;
# Check database path only if local
if ( !$self->{host} or $self->{host} eq 'localhost' ) {
$error_str .= "wrong path ($path, base $base)"
if $type eq q{.fdb} and $path and not( -d $path and $base );
# if no .fdb extension, then it may be an alias
}
$self->save_configs;
return $error_str;
}
sub get_user {
my $self = shift;
return $ENV{DBI_USER} || $ENV{ISC_USER} || q{sysdba};
}
sub get_pass {
my $self = shift;
return $ENV{DBI_PASS} || $ENV{ISC_PASSWORD} || q{masterkey};
}
sub get_host {
my $self = shift;
return q{localhost};
}
sub get_charset {
my $self = shift;
return $self->{charset} // 'UTF8';
}
=head2 check_dsn
Parse and check the DSN.
=cut
sub check_dsn {
my $self = shift;
my $dsn = shift;
# Check user provided DSN
my ( $scheme, $driver, undef, undef, $driver_dsn ) =
DBI->parse_dsn($dsn)
or die "Can't parse DBI DSN '$dsn'";
return if $scheme !~ m{dbi}i; # wrong scheme name
return if $driver ne q(Firebird); # wrong driver name
return if !$driver_dsn; # wrong driver DSN
return $dsn;
}
=head2 get_dsn
Make a DSN, using a temporary database in the L</tmp> dir for tests as
default.
=cut
sub get_dsn {
my $self = shift;
my $path;
my $host = $self->{host};
# $path
# = 'localhost:'
# . File::Spec->catfile( File::Spec->tmpdir(),
# 'dbd-fb-testdb.fdb' );
$path = File::Spec->catfile( File::Spec->tmpdir(),
'dbd-fb-testdb.fdb' );
return "dbi:Firebird:db=$path;host=$host;ib_dialect=3;ib_charset="
. $self->get_charset;
}
=head2 get_path
Extract the database path from the dsn.
=cut
sub get_path {
my $self = shift;
my $dsn = $self->{tdsn};
my ( $scheme, $driver, undef, undef, $driver_dsn ) =
DBI->parse_dsn($dsn)
or die "Can't parse DBI DSN '$dsn'";
my @drv_dsn = split /;/, $driver_dsn;
( my $path = $drv_dsn[0] ) =~ s{(db(name)?|database)=}{};
return $path;
}
=head2 setup_test_database
Create the test database if doesn't exists.
Check if we can connect, get the dialect as test.
=cut
sub setup_test_database {
my $self = shift;
my $have_testdb = $self->check_database;
unless ($have_testdb) {
$self->create_test_database;
# Check again
return "Failed to create test database!"
unless $have_testdb = $self->check_database;
}
# Create a mark
$self->create_mark;
return;
}
=head2 find_new_table
Find and return a non existent table name between TESTAA and TESTZZ.
=cut
sub find_new_table {
my $dbh = shift;
my $try_name = 'TESTAA';
my $try_name_quoted = $dbh->quote_identifier($try_name);
my %tables = map { uc($_) => undef } $dbh->tables;
while (exists $tables{$dbh->quote_identifier($try_name)}) {
if (++$try_name gt 'TESTZZ') {
diag("Too many test tables cluttering database ($try_name)\n");
exit 255;
}
}
return $try_name;
}
=head2 save_configs
Append the connection parameters to the 'tests-setup.conf' file.
=cut
sub save_configs {
my $self = shift;
open my $t_fh, '>>', $self->test_conf
or die "Can't write " . $self->test_conf . ": $!";
my $test_time = scalar localtime();
my @record = (
q(# Test section: -- (created by tests-setup.pl) #),
q(# Time: ) . $test_time,
qq(tdsn:=$self->{tdsn}),
qq(path:=$self->{path}),
qq(user:=$self->{user}),
qq(pass:=$self->{pass}),
q(# This is a temporary file used for test setup #),
);
my $rec = join "\n", @record;
print {$t_fh} $rec, "\n";
close $t_fh or die "Can't close " . $self->test_conf . ": $!";
return;
}
=head2 create_test_database
Create the test database.
=cut
sub create_test_database {
my $self = shift;
my ( $user, $pass, $path, $host )
= ( $self->{user}, $self->{pass}, $self->{path}, $self->{host} );
$path = "$host:$path" if $host;
#- Create test database
eval 'require ' . $self->dbd . '; 1' or die $@;
diag "Creating test database at $path";
$self->dbd->create_database(
{ db_path => $path,
user => $user,
password => $pass,
# dialect defaults to 3
character_set => 'UTF8',
}
);
#-- turn forced writes off
$self->dbd->gfix(
{ db_path => $path,
user => $user,
password => $pass,
forced_writes => 0,
}
);
return;
}
=head2 check_database
Try to connect and conclude that the database doesn't exist on error.
=cut
sub check_database {
my $self = shift;
my ( $user, $pass, $path, $host ) = (
$self->{user}, $self->{pass},
$self->{path}, $self->{host}
);
#- Connect to the test database
$path = "$host:$path" if $host;
print "The databse path is $path\n";
my $driver = $self->dbd;
$driver =~ s/^DBD:://;
my $dbh = eval {
DBI->connect( "dbi:$driver:database=$path", $user, $pass,
{ RaiseError => 1, PrintError => 0 } );
};
return 0 unless $dbh;
# check the dialect
my $info = $dbh->func('db_sql_dialect', 'ib_database_info');
$dbh->disconnect;
die "Unable to retrieve SQL dialect"
unless $info->{db_sql_dialect};
die "Database dialect wrong ($info->{db_sql_dialect})"
unless $info->{db_sql_dialect} == 3;
return 1;
}
=head2 create_mark
Create empty file used as mark, used to run L<setup_test_database> only
the first time L<test_init> is called.
=cut
sub create_mark {
my $self = shift;
open my $file_fh, '>', $self->test_mark
or croak "Can't open file ",$self->test_mark, ": $!";
close $file_fh;
return;
}
=head2 check_mark
Check is mark file exists.
=cut
sub check_mark {
my $self = shift;
return (-f $self->test_mark);
}
=head2 drop_test_database
Cleanup time, drop the test database, warn on failure or sql errors.
=cut
sub drop_test_database {
my $self = shift;
my ( $dbh, $error ) = $self->connect_to_database( { RaiseError => 0 } );
return unless $dbh; # nothing to drop
$dbh->func('ib_drop_database') or return 'Error dropping test database';
diag "Test database dropped";
return '';
}
=head2 cleanup
Cleanup temporary files, warn on failure.
=cut
sub cleanup {
my $self = shift;
my @tmp_files = (
$self->test_mark,
);
my $unlinked = 0;
foreach my $tmp_file (@tmp_files) {
print qq{Cleanup $tmp_file };
if (unlink $tmp_file) {
$unlinked++;
print qq{ done\n};
}
else {
print qq{could not unlink: $!\n};
}
}
return 'warning: file cleanup failed.' if $unlinked != scalar @tmp_files;
}
1;
Jump to Line
Something went wrong with that request. Please try again.