File Coverage

blib/lib/Test/Database/Driver.pm

Criterion	Covered	Total	%
statement	130	147	88.4
branch	40	56	71.4
condition	29	40	72.5
subroutine	36	40	90.0
pod	19	19	100.0
total	254	302	84.1

package Test::Database::Driver;
$Test::Database::Driver::VERSION = '1.113';
use strict;
use warnings;
use Carp;
use File::Spec;
use File::Path;
use version;
use YAML::Tiny qw( LoadFile DumpFile );
use Cwd;

use Test::Database::Handle;

#
# GLOBAL CONFIGURATION
#

# the location where all drivers-related files will be stored
my $KEY   = '';
my $login = getlogin() || getpwuid($<);
$login =~ s/\W+//g;
my $root  = File::Spec->rel2abs(
    File::Spec->catdir( File::Spec->tmpdir(), "Test-Database-$login" ) );

# generic driver class initialisation
sub __init {
    my ($class) = @_;

    # create directory if needed
    my $dir = $class->base_dir();
    if ( !-e $dir ) {
        mkpath( [$dir] );
    }
    elsif ( !-d $dir ) {
        croak "$dir is not a directory. Initializing $class failed";
    }

    # load the DBI driver (may die)
    DBI->install_driver( $class->name() );
}

#
# METHODS
#
sub new {
    my ( $class, %args ) = @_;

    if ( $class eq __PACKAGE__ ) {
        if ( exists $args{driver_dsn} ) {
            my ( $scheme, $driver, $attr_string, $attr_hash, $driver_dsn )
                = DBI->parse_dsn( $args{driver_dsn} );
            $args{dbd} = $driver;
        }
        croak "dbd or driver_dsn parameter required" if !exists $args{dbd};
        eval "require Test::Database::Driver::$args{dbd}"
            or do { $@ =~ s/ at .*?\z//s; croak $@; };
        $class = "Test::Database::Driver::$args{dbd}";
        $class->__init();
    }

    my $self = bless {
        %args,
        dbd => $class->name() || $args{dbd},
        },
        $class;

    $self->_load_mapping();

    # try to connect before returning the object
    if ( !$class->is_filebased() ) {
        eval {
            DBI->connect_cached( $self->connection_info(),
                { PrintError => 0 } );
        } or return;
    }

    return $self;
}

sub _mapping_file {
    return File::Spec->catfile( $_[0]->base_dir(), 'mapping.yml' );
}

sub available_dbname {
    my ($self) = @_;
    my $name = $self->_basename();
    my %taken = map { $_ => 1 } $self->databases();
    my $n = 0;
    $n++ while $taken{"$name$n"};
    return "$name$n";
}

sub _load_mapping {
    my ($self, $file)= @_;
    $file = $self->_mapping_file() if ! defined $file;

    # basic mapping info
    $self->{mapping} = {};
    return if !-e $file;

    # load mapping from file
    my $mapping = LoadFile( $file );
    $self->{mapping} = $mapping->{$self->driver_dsn()} || {};

    # remove stale entries
    $self->_save_mapping( $file ) if $self->_check_mapping();
}

sub _save_mapping {
    my ($self, $file )= @_;
    $file = $self->_mapping_file() if ! defined $file;

    # update mapping information
    my $mapping = {};
    $mapping = LoadFile( $file ) if -e $file;
    $mapping->{ $self->driver_dsn() } = $self->{mapping};

    # save mapping information
    DumpFile( "$file.tmp", $mapping );
    rename "$file.tmp", $file
        or croak "Can't rename $file.tmp to $file: $!";
}

sub _check_mapping {
    my ($self) = @_;
    my $mapping = $self->{mapping};
    my %database = map { $_ => undef } $self->databases();
    my $updated;

    # check that all databases in the mapping exist
    for my $cwd ( keys %$mapping ) {
        if ( !exists $database{ $mapping->{$cwd} } ) {
            delete $mapping->{$cwd};
            $updated++;
        }
    }
    return $updated;
}

sub make_dsn {
    my ($self, @args, @pairs) = @_;

    push @pairs, join '=', splice @args, 0, 2 while @args;

    my $dsn = $self->driver_dsn();
    return $dsn
        . ( $dsn =~ /^dbi:[^:]+:$/ ? '' : ';' )
        . join( ';', @pairs  );
}

sub make_handle {
    my ($self) = @_;
    my $handle;

    # get the database name from the mapping
    my $dbname = $self->{mapping}{ cwd() };

    # if the database still exists, return it
    if ( $dbname && grep { $_ eq $dbname } $self->databases() ) {
        $handle = Test::Database::Handle->new(
            dsn      => $self->dsn($dbname),
            username => $self->username(),
            password => $self->password(),
            name     => $dbname,
            driver   => $self,
        );
    }

    # otherwise create the database and update the mapper
    else {
        $handle = $self->create_database();
        $self->{mapping}{ cwd() } = $handle->{name};
        $self->_save_mapping();
    }

    return $handle;
}

sub version_matches {
    my ( $self, $request ) = @_;

    # string tests
    my $version_string = $self->version_string();
    return
        if exists $request->{version}
            && $version_string ne $request->{version};
    return
        if exists $request->{regex_version}
            && $version_string !~ $request->{regex_version};

    # numeric tests
    my $version = $self->version();
    return
        if exists $request->{min_version}
            && $version < $request->{min_version};
    return
        if exists $request->{max_version}
            && $version >= $request->{max_version};

    return 1;
}

#
# ACCESSORS
#
sub name { return ( $_[0] =~ /^Test::Database::Driver::([:\w]*)/g )[0]; }
*dbd = \&name;

sub base_dir {
    my ($self) = @_;
    my $class = ref $self || $self;
    return $root if $class eq __PACKAGE__;
    my $dir = File::Spec->catdir( $root, $class->name() );
    return $dir if !ref $self;    # class method
    return $self->{base_dir} ||= $dir;    # may be overriden in new()
}

sub version {
    no warnings;
    return $_[0]{version}
        ||= version->new( $_[0]->_version() =~ /^([0-9._]*[0-9])/ );
}

sub version_string {
    return $_[0]{version_string} ||= $_[0]->_version();
}

sub dbd_version { return "DBD::$_[0]{dbd}"->VERSION; }

sub driver_dsn { return $_[0]{driver_dsn} ||= $_[0]->_driver_dsn() }
sub username { return $_[0]{username} }
sub password { return $_[0]{password} }

sub connection_info {
    return ( $_[0]->driver_dsn(), $_[0]->username(), $_[0]->password() );
}

# THESE MUST BE IMPLEMENTED IN THE DERIVED CLASSES
sub drop_database { die "$_[0] doesn't have a drop_database() method\n" }
sub _version      { die "$_[0] doesn't have a _version() method\n" }

# create_database creates the database and returns a handle
sub create_database {
    my $class = ref $_[0] || $_[0];
    goto &_filebased_create_database if $class->is_filebased();
    die "$class doesn't have a create_database() method\n";
}

sub databases {
    goto &_filebased_databases if $_[0]->is_filebased();
    die "$_[0] doesn't have a databases() method\n";
}

# THESE MAY BE OVERRIDDEN IN THE DERIVED CLASSES
sub is_filebased {0}
sub _driver_dsn    { join ':', 'dbi', $_[0]->name(), ''; }

sub dsn {
    my ( $self, $dbname ) = @_;
    return $self->make_dsn( database => $dbname );
}

#
# PRIVATE METHODS
#
sub _set_key {
    $KEY = $_[1] || '';
    croak "Invalid format for key '$KEY'" if $KEY !~ /^\w*$/;
}

sub _basename {
    lc join '_', 'TDD', $_[0]->name(), $login, ( $KEY ? $KEY : (), '' );
}

# generic implementations for file-based drivers
sub _filebased_databases {
    my ($self)   = @_;
    my $dir      = $self->base_dir();
    my $basename = qr/^@{[$self->_basename()]}/;

    opendir my $dh, $dir or croak "Can't open directory $dir for reading: $!";
    my @databases = grep {/$basename/} File::Spec->no_upwards( readdir($dh) );
    closedir $dh;

    return @databases;
}

sub _filebased_create_database {
    my ( $self ) = @_;
    my $dbname = $self->available_dbname();

    return Test::Database::Handle->new(
        dsn    => $self->dsn($dbname),
        name   => $dbname,
        driver => $self,
    );
}

'CONNECTION';

__END__