File Coverage

blib/lib/Test/Database.pm

Criterion	Covered	Total	%
statement	104	108	96.3
branch	29	40	72.5
condition	4	8	50.0
subroutine	18	18	100.0
pod	7	7	100.0
total	162	181	89.5

package Test::Database;
$Test::Database::VERSION = '1.113';
use 5.006;
use warnings;
use strict;

use File::HomeDir;
use File::Spec;
use DBI;
use Carp;

use Test::Database::Util;
use Test::Database::Driver;
use Test::Database::Handle;

#
# global configuration
#

# internal data structures
my @HANDLES;
my @DRIVERS;

# driver information
my @DRIVERS_OUR;
my @DRIVERS_OK;

# find the list of all drivers we support
sub load_drivers {
    my %seen;
    for my $dir (@INC) {
        opendir my $dh, File::Spec->catdir( $dir, qw( Test Database Driver ) )
            or next;
        $seen{$_}++ for map { s/\.pm$//; $_ } grep {/\.pm$/} readdir $dh;
        closedir $dh;
    }

    # drivers we support
    @DRIVERS_OUR = sort keys %seen;

    # available DBI drivers
    my %DRIVERS_DBI = map { $_ => 1 } DBI->available_drivers();

    # supported
    @DRIVERS_OK = grep { exists $DRIVERS_DBI{$_} } @DRIVERS_OUR;

    # automatically load all drivers in @DRIVERS_OK
    # (but ignore compilation errors)
    eval "require Test::Database::Driver::$_" for @DRIVERS_OK;

    # actual driver objects
    @DRIVERS = map {
        my $driver;
        eval { $driver = Test::Database::Driver->new( dbd => $_ ); 1; }
            or warn "$@\n";
        $driver || ();
        }
        grep { "Test::Database::Driver::$_"->is_filebased() } @DRIVERS_OK;
}

# startup configuration
__PACKAGE__->load_drivers();
__PACKAGE__->load_config();

#
# private functions
#
# location of our resource file
sub _rcfile {
    my $basename = '.test-database';
    my $rc = File::Spec->catfile( File::HomeDir->my_home(), $basename );
    return $rc if -e $rc;

    # while transitioning to the new scheme, give the old name if it exists
    my $old = File::Spec->catfile( File::HomeDir->my_data(), $basename );
    return -e $old ? $old : $rc;
}

#
# methods
#
sub clean_config {
    @HANDLES = ();
    @DRIVERS = ();
}

sub load_config {
    my ( $class, @files ) = @_;
    @files = grep -e, _rcfile() if !@files;

    # fetch the items (dsn, driver_dsn) from the config files
    my @items = map { _read_file($_) } @files;

    # load the key
    Test::Database::Driver->_set_key( $_->{key} )
        for grep { exists $_->{key} } @items;

    # create the handles
    push @HANDLES,
        map { eval { Test::Database::Handle->new(%$_) } || () }
        grep { exists $_->{dsn} } @items;

    # create the drivers
    push @DRIVERS,
        map { eval { Test::Database::Driver->new(%$_) } || () }
        grep { exists $_->{driver_dsn} } @items;
}

sub list_drivers {
    my ( $class, $type ) = @_;
    $type ||= '';
    return
          $type eq 'all'       ? @DRIVERS_OUR
        : $type eq 'available' ? @DRIVERS_OK
        :                        map { $_->name() } @DRIVERS;
}

sub drivers { @DRIVERS }

# requests for handles
sub handles {
    my ( $class, @requests ) = @_;
    my @handles;

    # empty request means "everything"
    return @handles = ( @HANDLES, map { $_->make_handle() } @DRIVERS )
        if !@requests;

    # turn strings (driver name) into actual requests
    @requests = map { (ref) ? $_ : { dbd => $_ } } @requests;

    # process parameter aliases
    $_->{dbd} ||= delete $_->{driver} for @requests;

    # get the matching handles
    for my $handle (@HANDLES) {
        my $ok;
        my $driver = $handle->{driver};
        for my $request (@requests) {
            next if $request->{dbd} ne $handle->dbd();
            if ( grep /version/, keys %$request ) {
                next if !$driver || !$driver->version_matches($request);
            }
            $ok = 1;
            last;
        }
        push @handles, $handle if $ok;
    }

    # get the matching drivers
    my @drivers;
    for my $driver (@DRIVERS) {
        my $ok;
        for my $request (@requests) {
            next if $request->{dbd} ne $driver->dbd();
            next if !$driver->version_matches($request);
            $ok = 1;
            last;
        }
        push @drivers, $driver if $ok;
    }

    # get a new database handle from the drivers
    push @handles, map { $_->make_handle() } @drivers;

    # then on the handles
    return @handles;
}

sub handle {
    my @h = shift->handles(@_);
    return @h ? $h[0] : ();
}

'TRUE';

__END__