view release on metacpan or  search on metacpan

lib/DBIx/QuickDB/Watcher.pm  view on Meta::CPAN

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

our $VERSION = '0.000065';

use Carp qw/croak/;
use Cwd qw/abs_path/;
use Errno qw/ESRCH/;
use POSIX qw/:sys_wait_h/;
use Time::HiRes qw/sleep time/;
use Scalar::Util qw/weaken/;
use File::Path qw/remove_tree/;

# Resolved at load time, not at spawn time: $INC{} can be relative, and an
# application may chdir before starting a database, which would resolve it
# against the wrong directory and hand the watcher a different Watcher.pm.
my $LOADED_FROM = do {
    my $file = $INC{'DBIx/QuickDB/Watcher.pm'};

    my $dir;
    if (defined($file) && length($file)) {
        my $root = $file;
        $root =~ s{[\\/]?\QDBIx/QuickDB/Watcher.pm\E$}{};
        $dir = abs_path(length($root) ? $root : '.');
    }

    (defined($dir) && length($dir) && -d $dir) ? $dir : undef;
};

use DBIx::QuickDB::Util::HashBase qw{
    <db <args
    <server_pid
    <watcher_pid
    <master_pid
    <log_file
    <data_dir

    <stopped
    <eliminated
    <detached

    <delete_data
    <server_reaped
};

# The watch loop records its reap inside the data dir, which disposable teardown
# then deletes -- so the proof is gone by the time wait() wants it. Latch it
# before signalling, while the dir is still there.
sub _latch_server_reaped {
    my $self = shift;

    return if $self->{+SERVER_REAPED};

    my $dir = $self->{+DATA_DIR} or return;
    $self->{+SERVER_REAPED} = 1 if -f $self->server_exit_status_file($dir);

    return;
}

sub init {
    my $self = shift;

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

    # Captured up front: wait() needs it after teardown, when the DB reference
    # has been weakened and may already be gone.
    $self->{+DATA_DIR} //= $self->{+DB}->dir;

    $self->{+LOG_FILE} = $self->{+DB}->gen_log;

    $self->start();

    weaken($self->{+DB}) if $self->{+MASTER_PID} == $$;
}

sub start {
    my $self = shift;
    return if $self->{+SERVER_PID};

    my ($rh, $wh);
    pipe($rh, $wh) or die "Could not open pipe: $!";

    my $pid = fork;
    die "Could not fork: $!" unless defined $pid;

    if ($pid) {
        close($wh);
        waitpid($pid, 0);
        chomp($self->{+WATCHER_PID} = <$rh>);
        chomp($self->{+SERVER_PID}  = <$rh>);
        close($rh);
        die "Did not get watcher pid!" unless $self->{+WATCHER_PID};
        die "Did not get server pid!"  unless $self->{+SERVER_PID};
        return;
    }

    close($rh);
    POSIX::setsid();
    setpgrp(0, 0);
    $pid = fork;
    die "Could not fork: $!" unless defined $pid;
    POSIX::_exit(0) if $pid;

    $wh->autoflush(1);
    print $wh "$$\n";

    # In watcher now
    eval { $self->watch($wh); 1 } or POSIX::_exit(1);
    POSIX::_exit(0);
}

# -I args for the re-exec'd watcher: the directory this module was loaded from,
# then the rest of @INC. The watcher must load the same Watcher.pm its parent
# did, so the parent's own resolution is forwarded rather than guessed.
#
# -I rather than PERL5LIB, which the MySQLCom and MariaDB drivers deliberately
# blank so vendor scripts cannot reach application modules.
#
# $root is only passed by tests; it defaults to the load-time capture.
sub _watcher_inc_args {
    my ($root) = @_ ? @_ : ($LOADED_FROM);

    my @dirs;
    push @dirs => $root if defined $root;

    # @INC hooks (refs) cannot be expressed as -I.
    push @dirs => grep { !ref($_) && defined($_) && length($_) } @INC;

    # Absolutizing the rest is hygiene only -- this runs in the forked watcher,
    # which shares the caller's cwd, so a relative entry would resolve the same
    # either way. $LOADED_FROM above is what actually pins the module.
    my (@out, %seen);
    for my $dir (@dirs) {