File Coverage

blib/lib/DBIx/QuickDB/Driver.pm

Criterion	Covered	Total	%
statement	34	238	14.2
branch	0	116	0.0
condition	0	62	0.0
subroutine	12	50	24.0
pod	28	33	84.8
total	74	499	14.8

package DBIx::QuickDB::Driver;
use strict;
use warnings;

our $VERSION = '0.000050';

use Carp qw/croak confess/;
use File::Path qw/remove_tree/;
use File::Temp qw/tempdir/;
use POSIX ":sys_wait_h";
use Scalar::Util qw/blessed/;
use Time::HiRes qw/sleep time/;

use DBIx::QuickDB::Util qw/clone_dir env_timeout/;

use DBIx::QuickDB::Watcher;

use DBIx::QuickDB::Util::HashBase qw{
    -root_pid
    -dir
    -_cleanup
    -autostop -autostart
    verbose
    -_log_id
    username
    password
    env_vars


    -fast_destroy
};

sub viable { (0, "viable() is not implemented for the " . $_[0]->name . " driver") }

sub socket         { confess "socket() is not implemented for the " . $_[0]->name . " driver" }
sub load_sql       { confess "load_sql() is not implemented for the " . $_[0]->name . " driver" }
sub bootstrap      { confess "bootstrap() is not implemented for the " . $_[0]->name . " driver" }
sub connect_string { confess "connect_string() is not implemented for the " . $_[0]->name . " driver" }
sub start_command  { confess "start_command() is not implemented for the " . $_[0]->name . " driver" }
sub shell_command  { confess "shell_command() is not implemented for the " . $_[0]->name . " driver" }

sub error_log { undef }

sub read_error_log {
    my $self = shift;
    my $log = $self->error_log or return "";
    return "" unless -f $log;
    open(my $fh, '<', $log) or return "Could not open error log '$log': $!";
    return join "" => <$fh>;
}

# Slurp a file for diagnostics; returns "" if it is missing or unreadable.
sub _read_file {
    my $self = shift;
    my ($file) = @_;
    return "" unless $file && -f $file;
    open(my $fh, '<', $file) or return "";
    return join "" => <$fh>;
}

sub list_env_vars { qw/DBI_USER DBI_PASS DBI_DSN/ }

sub version_string { 'unknown' }

sub stop_sig { 'TERM' }

# Signal the watcher sends to the server for fast (disposable) teardown via
# destroy_quietly()/fast_destroy. The default SIGKILL is the quickest possible
# stop. Drivers whose server leaks an OS resource on a hard kill should override
# this with a clean-but-immediate shutdown signal (see PostgreSQL, which returns
# 'QUIT' so the postmaster releases its SysV semaphores instead of orphaning
# them). The watcher escalates to SIGKILL if the chosen signal does not exit the
# server promptly, so teardown always completes.
sub fast_stop_sig { 'KILL' }

sub write_config {}

sub do_in_env {
    my $self = shift;
    my ($code) = @_;

    my $old = $self->mask_env_vars;

    my $ok = eval { $code->(); 1 };
    my $err = $@;

    $self->unmask_env_vars($old);

    die $err unless $ok;

    return;
}

sub mask_env_vars {
    my $self = shift;

    my %old;

    for my $var ($self->list_env_vars) {
        next unless defined $ENV{$var};
        $old{$var} = delete $ENV{$var};
    }

    my $env_vars = $self->env_vars || {};
    for my $var (keys %$env_vars) {
        $old{$var} = delete $ENV{$var} unless defined $old{$var};
        $ENV{$var} = $env_vars->{$var};
    }

    return \%old;
}

sub unmask_env_vars {
    my $self = shift;
    my ($old) = @_;

    for my $var (keys %$old) {
        my $val = $old->{$var};

        if (defined $val) {
            $ENV{$var} = $val;
        }
        else {
            delete $ENV{$var};
        }
    }

    return;
}

sub name {
    my $in = shift;
    my $type = blessed($in) || $in;

    $type =~ s/^DBIx::QuickDB::Driver:://;

    return $type;
}

sub init {
    my $self = shift;

    confess "'dir' is a required attribute" unless $self->{+DIR};

    $self->{+ROOT_PID} = $$;
    $self->{+_CLEANUP} = delete $self->{cleanup};

    $self->{+USERNAME} = '' unless defined $self->{+USERNAME};
    $self->{+PASSWORD} = '' unless defined $self->{+PASSWORD};

    $self->{+ENV_VARS} ||= {};

    return;
}

sub clone_data {
    my $self = shift;

    return (
        USERNAME()  => $self->{+USERNAME},
        PASSWORD()  => $self->{+PASSWORD},
        VERBOSE()   => $self->{+VERBOSE},
        AUTOSTOP()  => $self->{+AUTOSTOP},
        AUTOSTART() => $self->{+AUTOSTART},

        cleanup => $self->{+_CLEANUP},

        FAST_DESTROY() => $self->{+FAST_DESTROY},

        ENV_VARS() => {%{$self->{+ENV_VARS}}},
    );
}

sub resync {
    my $self = shift;

    my $from = $self->{+CLONED_FROM} or croak "No original source to sync from";

    my $started = $self->started;
    $self->stop if $started;

    clone_dir($from, $self->{+DIR}, verbose => (($self->{+VERBOSE} // 0) > 2) ? 1 : 0, checksum => 1);

    $self->write_config();

    $self->start if $started;
}

sub clone {
    my $self = shift;
    my %params = @_;

    confess "Cannot clone a started database, please stop it first."
        if $self->started;

    my $orig_dir = $self->{+DIR};
    my $new_dir  = delete $params{dir} // tempdir('DB-QUICK-CLONE-XXXXXX', CLEANUP => 0, $ENV{QDB_TMPDIR} ? (DIR => $ENV{QDB_TMPDIR}) : (TMPDIR => 1));

    clone_dir($orig_dir, $new_dir, verbose => (($self->{+VERBOSE} // 0) > 2) ? 1 : 0);

    my $class = ref($self);
    my %ok = (
        cleanup => 1,
        map {$_ => 1} DBIx::QuickDB::Util::HashBase::attr_list($class),
    );
    my @bad = grep { !$ok{$_} } keys %params;

    confess "Invalid options to clone(): " . join(', ' => @bad)
        if @bad;

    my $clone = $class->new(
        $self->clone_data,

        %params,

        DIR() => $new_dir,

        WATCHER()  => undef,

        CLONED_FROM() => $orig_dir,
    );

    $clone->write_config();
    $clone->start if $clone->{+AUTOSTART};

    return $clone;
}

sub gen_log {
    my $self = shift;
    return if $self->no_log(@_);
    return $self->{+DIR} . "/cmd-log-$$-" . $self->{+_LOG_ID}++;
}

sub no_log {
    my $self = shift;
    my ($params) = @_;
    return $self->{+VERBOSE} || $params->{no_log} || $ENV{DB_VERBOSE};
}

sub run_command {
    my $self = shift;
    my ($cmd, $params) = @_;

    my $no_log = $self->no_log($params);
    my $log_file = $params->{log_file} || ($no_log ? undef : $self->gen_log);

    my $pid = fork();
    croak "Could not fork" unless defined $pid;

    if ($pid) {
        local $?;
        return ($pid, $log_file) if $params->{no_wait};
        my $ret = waitpid($pid, 0);
        my $exit = $?;
        die "waitpid returned $ret" unless $ret == $pid;

        return unless $exit;

        my $log = "";
        unless ($no_log) {
            open(my $fh, '<', $log_file) or warn "Failed to open log: $!";
            $log = eval { join "" => <$fh> };
        }
        my $error_log = $self->read_error_log;
        $log .= "\n=== error log ===\n$error_log" if length $error_log;
        croak "Failed to run command '" . join(' ' => @$cmd) . "' ($exit)\n$log";
    }

    $self->mask_env_vars;

    unless ($no_log) {
        open(my $log, '>', $log_file) or die "Could not open log file ($log_file): $!";
        close(STDOUT);
        open(STDOUT, '>&', $log);
        close(STDERR);
        open(STDERR, '>&', $log);
    }

    if (my $file = $params->{stdin}) {
        close(STDIN);
        open(STDIN, '<', $file) or die "Could not open new STDIN ($file): $!";
    }

    exec(@$cmd);
}

sub should_cleanup { shift->{+_CLEANUP} }

# Flush server state durably to disk so a hard kill mid-shutdown cannot leave
# the data dir needing crash recovery. Drivers that benefit (e.g. PostgreSQL)
# override this; the default is a no-op.
sub checkpoint { }

sub cleanup {
    my $self = shift;

    # Ignore errors here.
    my $err = [];
    remove_tree($self->{+DIR}, {safe => 1, error => \$err}) if -d $self->{+DIR};
    return;
}

sub connect {
    my $self = shift;
    my ($db_name, %params) = @_;

    %params = (AutoCommit => 1, RaiseError => 1) unless @_ > 1;

    my $dbh;
    $self->do_in_env(
        sub {
            my $cstring = $self->connect_string($db_name);
            require DBI;
            $dbh = DBI->connect($cstring, $self->username, $self->password, \%params);
        }
    );

    return $dbh;
}

sub started {
    my $self = shift;

    my $socket = $self->socket;
    return 1 if $self->{+WATCHER} || -S $socket;
    return 0;
}

sub start {
    my $self = shift;
    my @args = @_;

    my $dir = $self->{+DIR};
    my $socket = $self->socket;

    return if $self->{+WATCHER} || -S $socket;

    my $watcher = $self->{+WATCHER} = DBIx::QuickDB::Watcher->new(db => $self, args => \@args);

    # Defaults to 10s; tunable via QDB_START_TIMEOUT for slow hosts that need
    # longer to bring a server up (e.g. a clone doing crash recovery).
    my $timeout = env_timeout(QDB_START_TIMEOUT => 10);

    my $start = time;
    until (-S $socket) {
        my $waited = time - $start;

        if ($waited > $timeout) {
            # Capture diagnostics BEFORE eliminate() removes the data dir (which
            # holds both the error log and the watcher's launch log). The server
            # process's own stdout/stderr go to the watcher's log_file, not the
            # driver's error_log, so a server that died (or never launched)
            # before writing error_log leaves error_log showing only inherited
            # template history -- the real failure is in the launch log. Also
            # report whether the server pid is still alive: "not running" points
            # at a launch/early-exit failure, "alive" at a slow or hung startup.
            my $spid       = $watcher->server_pid;
            my $alive      = ($spid && kill(0, $spid)) ? "alive (pid $spid)" : "not running";
            my $error_log  = $self->read_error_log;
            my $launch_log = $self->_read_file($watcher->log_file);

            $watcher->eliminate();

            my $msg = "Timed out waiting for server to start after ${timeout}s; server process is $alive.";
            $msg .= "\n=== server launch log ===\n$launch_log" if length $launch_log;
            $msg .= "\n=== error log ===\n$error_log"          if length $error_log;
            confess $msg;
        }

        sleep 0.01;
    }

    return;
}

sub stop {
    my $self = shift;
    my %params = @_;

    my $watcher = delete $self->{+WATCHER} or return;

    # Flush a durable checkpoint while the server is still running. If shutdown
    # is slow enough to be SIGKILLed, this ensures the on-disk state is already
    # consistent so a later clone does not crash-recover and jump SERIAL
    # sequences forward (PostgreSQL SEQ_LOG_VALS=32), corrupting the clone.
    # No-op for drivers that do not need it.
    $self->checkpoint;

    DBI->visit_handles(
        sub {
            my ($driver_handle) = @_;

            $driver_handle->disconnect
               if $driver_handle->{Type} && $driver_handle->{Type} eq 'db'
               && $driver_handle->{Name} && index($driver_handle->{Name}, $self->{+DIR}) >= 0;

            return 1;
        }
    );

    $watcher->stop();

    unless ($params{no_wait}) {
        # wait() blocks until the watcher process exits, and the watcher reaps
        # the server before it exits -- so once wait() returns the server is
        # gone. Trust that instead of polling a stored server pid: after the
        # watcher exits that pid may have been recycled by the OS to an
        # unrelated process, and polling it could hang/confess on the wrong
        # process (the same pid-reuse hazard the watcher teardown guards against).
        $watcher->wait();

        # Remove a stale unix socket left behind by a hard kill so it does not
        # confuse callers or a later run that reuses the same directory.
        my $socket = $self->socket;
        unlink($socket) if $socket && -S $socket;
    }

    return;
}

# Immediate disposable teardown for clones that are about to be deleted. Unlike
# stop()/DESTROY this does NOT checkpoint or attempt a graceful shutdown: it asks
# the watcher to SIGKILL+reap the server and remove the data dir. Only safe when
# the data dir is disposable (cleanup => 1). Idempotent: after the first call
# clears the watcher, later calls and DESTROY become no-ops apart from an
# idempotent cleanup().
sub destroy_quietly {
    my $self = shift;
    return unless $self->{+ROOT_PID} && $self->{+ROOT_PID} == $$;

    if (my $watcher = delete $self->{+WATCHER}) {
        # Disconnect our DBI handles before the server dies so this process does
        # not retain broken handles that later report "server has gone away".
        DBI->visit_handles(
            sub {
                my ($driver_handle) = @_;

                $driver_handle->disconnect
                   if $driver_handle->{Type} && $driver_handle->{Type} eq 'db'
                   && $driver_handle->{Name} && index($driver_handle->{Name}, $self->{+DIR}) >= 0;

                return 1;
            }
        ) if $INC{'DBI.pm'};

        # The watcher is the server's parent, so it is the correct process to
        # kill and reap it. Do NOT signal the stored server pid directly here.
        $watcher->fast_eliminate();
        $watcher->wait();

        # The watcher removes the data dir; this is a defensive fallback in case
        # it exited before doing so.
        $self->cleanup() if $self->should_cleanup;
    }
    elsif ($self->should_cleanup) {
        $self->cleanup();
    }

    return;
}

sub shell {
    my $self = shift;
    my ($db_name) = @_;
    $db_name = 'quickdb' unless defined $db_name;

    system($self->shell_command($db_name));
}

sub DESTROY {
    my $self = shift;
    return unless $self->{+ROOT_PID} && $self->{+ROOT_PID} == $$;

    # Opt-in fast teardown for disposable clones. Only honored when the data dir
    # is actually disposable (_CLEANUP); a contradictory fast_destroy + cleanup
    # => 0 falls through to the normal graceful path below so a reusable data dir
    # is never hard-killed.
    return $self->destroy_quietly()
        if $self->{+FAST_DESTROY} && $self->{+_CLEANUP};

    if (my $watcher = delete $self->{+WATCHER}) {
        # eliminate() signals the watcher to stop the server and delete the data
        # dir; destroying the watcher then blocks (via Watcher::wait) until the
        # watcher process has exited, and the watcher reaps the server before it
        # exits. So once $watcher is gone the server is gone too. We deliberately
        # do NOT fall back to signalling a stored server pid here: after the
        # watcher exits that pid may have been recycled to an unrelated process
        # (the pid-reuse hazard), so a stray TERM/KILL could hit the wrong one.
        $watcher->eliminate();
        undef $watcher;

        $self->cleanup() if $self->should_cleanup;
    }
    elsif ($self->should_cleanup) {
        $self->cleanup();
    }

    return;
}

1;

__END__