File Coverage

blib/lib/Test2/Tools/QuickDB.pm

Criterion	Covered	Total	%
statement	59	75	78.6
branch	24	38	63.1
condition	14	17	82.3
subroutine	11	11	100.0
pod	4	5	80.0
total	112	146	76.7

package Test2::Tools::QuickDB;
use strict;
use warnings;

our $VERSION = '0.000049';

use Carp qw/croak/;
use Test2::API qw/context/;
use DBIx::QuickDB();

use Importer Importer => 'import';

our @EXPORT = qw/get_db_or_skipall get_db skipall_unless_can_db skipall_on_resource_error/;

# Match the errors a host throws when it cannot give a database server the
# System V IPC resources it needs to start -- semaphore or shared-memory table
# exhaustion. These come through as the failed initdb/start command's captured
# output (e.g. PostgreSQL: "could not create semaphores: No space left on
# device", "semget(...)", SEMMNI/SEMMNS hints). Returns a human reason if the
# error is one of these, else undef.
sub resource_exhaustion_reason {
    my ($err) = @_;
    return undef unless defined $err;

    return "host is out of System V semaphores (cannot start a database server)"
        if $err =~ /could not create semaphores/i
        || $err =~ /\bsemget\(/
        || $err =~ /\bSEMM(?:NI|NS)\b/;

    return "host is out of System V shared memory (cannot start a database server)"
        if $err =~ /could not create shared memory/i
        || $err =~ /\bshmget\(/;

    return undef;
}

# If $err is a host IPC-exhaustion error, skip the whole test (it is an
# environment limit, not a fault in this distribution) -- this does not return,
# it terminates like skip_all. Otherwise returns false so the caller can rethrow.
sub skipall_on_resource_error {
    my ($err) = @_;

    my $reason = resource_exhaustion_reason($err) or return 0;

    my $ctx = context();
    $ctx->plan(0, SKIP => ucfirst($reason));
    $ctx->release;

    return 1;
}

sub skipall_unless_can_db {
    my %spec;
    if (@_ == 1) {
        my $type = ref($_[0]) || '';
        if (!$type) {
            $spec{driver} = $_[0];
        }
        elsif ($type eq 'ARRAY') {
            $spec{drivers} = $_[0];
        }
        elsif ($type eq 'HASH') {
            %spec = %{$_[0]};
        }
        else {
            croak "Invalid Argument: $_[0]";
        }
    }
    else {
        %spec = @_;
    }

    my $ctx = context();

    $spec{bootstrap} = 1 unless defined $spec{bootstrap};
    $spec{autostart} = 1 unless defined $spec{autostart};
    $spec{load_sql}  = 1 unless defined $spec{load_sql};

    my $drivers = $spec{driver} ? [$spec{driver}] : $spec{drivers} || [DBIx::QuickDB->plugins];

    my $reason;
    my $ok = 0;
    for my $driver (@$drivers) {
        next unless defined $driver;
        my ($v, $fqn, $why) = DBIx::QuickDB->check_driver($driver, \%spec);
        $reason = $why if @$drivers == 1;
        next unless $v;
        $ok = $fqn;
        last;
    }

    if ($ok) {
        $ctx->release;
        return $ok;
    }

    $ctx->plan(0, 'SKIP' => $reason || "no db driver is viable");
    $ctx->release;

    return;
}

sub get_db {
    # Get a context in case anything below here has testing code.
    my $ctx = context();

    my $db = eval { DBIx::QuickDB->build_db(@_) };
    if (my $err = $@) {
        # A host out of System V semaphores/shared memory cannot start a server;
        # that is an environment limit, not a fault here, so skip rather than
        # fail. skipall_on_resource_error() terminates the test in that case;
        # any other error is real and is rethrown.
        skipall_on_resource_error($err);
        $ctx->release;
        die $err;
    }

    $ctx->release;

    return $db;
}

sub get_db_or_skipall {
    my $name = ref($_[0]) ? undef : shift(@_);
    my $spec = shift(@_) || {};

    my $ctx = context();

    skipall_unless_can_db(%$spec);
    my $db = get_db($name ? $name : (), $spec);

    $ctx->release;

    return $db;
}

1;

__END__