The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
use strict;
use warnings;
use Test::More;
use File::Spec;
use Test::Database;

my %handle = (
    mysql1 => Test::Database::Handle->new(
        dsn      => 'dbi:mysql:database=mydb;host=localhost;port=1234',
        username => 'user',
        password => 's3k r3t',
    ),
    mysql2 => Test::Database::Handle->new(
        dsn      => 'dbi:mysql:database=mydb;host=remotehost;port=5678',
        username => 'otheruser',
    ),
    sqlite => Test::Database::Handle->new( dsn => 'dbi:SQLite:db.sqlite', ),
);
delete $_->{driver} for values %handle;

# test description:
# 1st char is variable to look at: array (@) or scalar ($)
# 2nd char is expected result: list (@), single item ($) or number (1)
my @code;
my %tests = map {
    my ( $fmt, $code ) = split / /, $_, 2;
    push @code, $code;
    ( $code => $fmt )
} split /\n/, << 'CODE';
@@ @handles = Test::Database->handles(@requests);
$1 $handle  = Test::Database->handles(@requests);
$$ $handle  = ( Test::Database->handles(@requests) )[0];
$$ ($handle) = Test::Database->handles(@requests);
$$ $handle  = Test::Database->handle(@requests);
@$ @handles = Test::Database->handle(@requests);
CODE

my @tests = (

    # request, expected response
    [ [],        [ @handle{qw( mysql1 mysql2 sqlite )} ], '' ],
    [ ['mysql'], [ @handle{qw( mysql1 mysql2 )} ],        q{'mysql'} ],
    [ ['sqlite'], [], q{'sqlite'} ],
    [ ['SQLite'], [ $handle{sqlite} ], q{'SQLite'} ],
    [ ['Oracle'], [], q{'Oracle'} ],
    [   [ 'SQLite', 'mysql' ],
        [ @handle{qw( mysql1 mysql2 sqlite )} ],
        q{'SQLite', 'mysql'}
    ],
    [   [ 'mysql', 'SQLite', 'mysql' ],
        [ @handle{qw( mysql1 mysql2 sqlite )} ],
        q{'mysql', 'SQLite', 'mysql'}
    ],
    [   [ 'mysql', 'Oracle', 'SQLite' ],
        [ @handle{qw( mysql1 mysql2 sqlite )} ],
        q{'Oracle', 'mysql', 'SQLite'}
    ],
    [ [ { dbd => 'mysql' } ], [ @handle{qw( mysql1 mysql2 )} ], q{'mysql'} ],
    [   [ { driver => 'mysql' } ],
        [ @handle{qw( mysql1 mysql2 )} ],
        q{'mysql'}
    ],

);

# reset the internal structures and force loading our test config
Test::Database->clean_config();
my $config = File::Spec->catfile( 't', 'database.rc' );
Test::Database->load_config( $config );

plan tests => @tests * keys %tests;

for my $test (@tests) {
    my ( $requests, $responses, $desc ) = @$test;
    my %expected = (
        '1' => [ scalar @$responses ],
        '$' => [ $responses->[0] ],
        '@' => $responses,
        '0' => [],
    );

    # try out each piece of code
    my @requests = @$requests;
    for my $code (@code) {
        my ( $handle, @handles );
        my ( $got, $expected ) = split //, $tests{$code};

        # special case
        $expected = '0' if $tests{$code} eq '@$' && !@$responses;

        # run the code
        eval "$code; 1;" or do {
            ok( 0, $code );
            diag $@;
            next;
        };
        ( my $mesg = $code ) =~ s/\@requests/$desc/;
        $got
            = $got eq '$' ? [$handle]
            : $got eq '@' ? \@handles
            :               die "Unknown variable symbol $got";
        ref && delete $_->{driver} for @$got;
        is_deeply( $got, $expected{$expected}, $mesg );
    }
}