Developer-Dashboard
view release on metacpan or search on metacpan
lib/Developer/Dashboard/RuntimeManager.pm view on Meta::CPAN
sub _start_web_windows_background {
my ( $self, %args ) = @_;
my $host = defined $args{host} ? $args{host} : '0.0.0.0';
my $port = defined $args{port} ? $args{port} : 7890;
my $workers = defined $args{workers} ? $args{workers} : 1;
my $ssl = $args{ssl} ? 1 : 0;
$self->_cleanup_web_files;
my @command = $self->_windows_background_web_command(
host => $host,
port => $port,
workers => $workers,
ssl => $ssl,
);
my $pid = $self->_spawn_windows_background_command(@command);
die "Unable to start dashboard web service on Windows\n" if !$pid;
my $running;
for ( 1 .. $self->_runtime_stability_polls ) {
my @listener_pids = $self->_listener_pids_for_port($port);
if (@listener_pids) {
my $listener_pid = $listener_pids[0];
$running = {
host => $host,
pid => $listener_pid,
port => $port + 0,
process_name => $self->_web_process_title( $host, $port ),
started_at => _now_iso8601(),
status => 'running',
workers => $workers + 0,
ssl => $ssl + 0,
};
last if $self->_port_accepting_connections($port);
}
sleep $self->_runtime_poll_interval;
}
if ($running) {
my $state = {
%{$running},
host => $host,
pid => $running->{pid} || $pid,
port => $port + 0,
process_name => $running->{process_name},
started_at => $running->{started_at},
status => 'running', # uncoverable condition false the spawned Windows pid used by the pid fallback on this state is always a positive integer here
workers => $workers + 0,
ssl => $ssl + 0,
};
$self->{files}->write( 'web_pid', "$state->{pid}\n" );
$self->_write_web_state($state);
return $state->{pid};
}
return $pid;
}
# _running_web_satisfies_request($running, $host, $port, $workers, $ssl)
# Decides whether an already running web service satisfies a background start
# request. The endpoint decides identity and must be known: an unknown host or
# port is a mismatch, never an uninitialized-value warning. A property the
# persisted payload does not carry is unverifiable rather than different, so it
# never justifies forking a second listener onto an endpoint that already
# matches, which would strand the running child as an untrackable orphan.
# Input: running web state hash reference, requested host, port, worker count,
# and ssl flag.
# Output: boolean true when the running service already satisfies the request.
sub _running_web_satisfies_request {
my ( $self, $running, $host, $port, $workers, $ssl ) = @_;
return 0 if !defined $running->{host} || !defined $running->{port};
return 0 if $running->{host} ne $host;
return 0 if $running->{port} != $port;
return 0 if defined $running->{workers} && $running->{workers} != $workers;
return 0 if defined $running->{ssl} && $running->{ssl} != $ssl;
return 1;
}
# _state_settle_polls()
# Returns how many times a lifecycle read re-checks a state file that exists but
# yields no usable payload before concluding there is no state to read. The
# budget stays small on purpose: the window it covers is a single file
# replacement, and every probe pays it when a state file is corrupt rather than
# merely mid-write.
# Input: none.
# Output: positive poll count integer.
sub _state_settle_polls {
return 10;
}
# _state_settle_interval()
# Returns the pause between re-checks of a state file that exists but yields no
# usable payload.
# Input: none.
# Output: fractional seconds.
sub _state_settle_interval {
return 0.01;
}
# _read_settled_web_state()
# Reads persisted web state for lifecycle decisions, tolerating the brief window
# in which an existing state file is observable as empty or partially written.
# The lifecycle uses this answer to deduplicate starts and to delete persisted
# files, so a transient observation must never be treated as a fact.
# Input: none.
# Output: two-element list of the state hash reference or undef, and a flag that
# is true when a state file exists but never yielded a usable payload.
sub _read_settled_web_state {
my ($self) = @_;
my $file = $self->{files}->web_state;
my $polls = $self->_state_settle_polls;
for my $attempt ( 1 .. $polls ) {
my $state = $self->web_state;
return ( $state, 0 ) if ref($state) eq 'HASH';
return ( undef, 0 ) if !-f $file;
sleep $self->_state_settle_interval if $attempt < $polls;
}
return ( undef, 1 );
}
# _web_state_with_endpoint($state, $pid)
# Builds the running-web answer for one live managed pid, filling a host or port
# the persisted payload does not carry from the live process title. Callers
# compare the reported endpoint against a requested one, so a gap in the
# persisted payload must never surface as an unknown endpoint.
# Input: persisted state hash reference and live process id.
# Output: web state hash reference carrying the live pid.
sub _web_state_with_endpoint {
my ( $self, $state, $pid ) = @_;
my $running = {
%{$state},
pid => $pid + 0,
};
return $running if defined $running->{host} && defined $running->{port};
my $title = $self->_read_process_title($pid);
if ( defined $title && $title =~ /^dashboard web:\s+(\S+):(\d+)$/ ) {
$running->{host} = defined $running->{host} ? $running->{host} : $1;
$running->{port} = defined $running->{port} ? $running->{port} : $2 + 0;
}
return $running;
}
# running_web()
# Discovers the currently running managed web service if present.
# Input: none.
# Output: web state hash reference or undef.
sub running_web {
my ($self) = @_;
my ( $settled, $unresolved ) = $self->_read_settled_web_state;
my $state = $settled || {};
if ( my $pid = $self->{files}->read('web_pid') ) {
chomp $pid;
$pid = $self->_normalized_process_id($pid);
if ( $pid && $self->_pid_is_running($pid) && $self->_same_pid_namespace($pid) ) {
if ( $self->_is_managed_web($pid) || ( $state->{status} || '' ) eq 'running' ) {
return $self->_web_state_with_endpoint( $state, $pid );
}
}
}
for my $proc ( $self->_find_web_processes ) {
if ( $proc->{args} =~ /^dashboard web:\s+(\S+):(\d+)$/ ) {
return {
%$state,
pid => $proc->{pid},
host => $1,
port => $2 + 0,
process_name => $proc->{args},
status => 'running',
};
}
return {
%$state,
pid => $proc->{pid},
host => $state->{host} || '0.0.0.0',
port => $state->{port} || 7890,
process_name => $proc->{args},
status => 'running',
};
}
if ( ( $state->{status} || '' ) eq 'running' ) {
my @listener_pids = $self->_listener_pids_from_state($state);
if (@listener_pids) {
return {
%$state,
pid => $listener_pids[0],
process_name => $self->_read_process_title( $listener_pids[0] ) || ( $state->{process_name} || '' ),
status => 'running',
};
}
}
# A state file that exists but never yielded a usable payload is evidence of
# nothing. Removing it here would destroy the persisted identity of a service
# this probe merely failed to observe, so leave the files for the next read.
return if $unresolved;
$self->_cleanup_web_files;
return;
}
# stop_web()
# Stops the managed web service, including older compatible process shapes.
# Input: none.
# Output: stopped pid or undef.
sub stop_web {
my ( $self, %args ) = @_;
my $progress = $args{progress};
$self->_progress_emit(
$progress,
{
task_id => 'stop_web',
status => 'running',
label => 'Stop dashboard web service',
lib/Developer/Dashboard/RuntimeManager.pm view on Meta::CPAN
updated_at => _now_iso8601(),
}
);
POSIX::_exit(0);
}
# _run_web_child($writer, $host, $port, %args)
# Runs the daemonized web child lifecycle and reports startup status.
# Input: pipe writer handle, host, port, worker count, ssl flag, and detach/redirect options.
# Output: process exit code.
sub _run_web_child {
my ( $self, $writer, $host, $port, %args ) = @_;
my $detach = exists $args{detach} ? $args{detach} : 1;
my $redirect = exists $args{redirect} ? $args{redirect} : 1;
my $workers = exists $args{workers} ? $args{workers} : 1;
my $ssl = exists $args{ssl} ? $args{ssl} : 0;
if ($detach) {
$self->_detach_web_process_session;
my $pid = $self->_fork_process();
die "Unable to complete dashboard web daemonize: $!" if !defined $pid;
return 0 if $pid;
}
if ($redirect) {
open STDIN, '<', File::Spec->devnull() or die $!; # uncoverable branch true reopening stdin on the null device does not fail on the test host
open STDOUT, '>>', $self->{files}->dashboard_log or die $!; # uncoverable branch true the dashboard log directory exists and is writable on the test host
open STDERR, '>>', $self->{files}->dashboard_log or die $!; # uncoverable branch true the dashboard log directory exists and is writable on the test host
}
$ENV{DEVELOPER_DASHBOARD_WEB_SERVICE} = 1;
$ENV{DEVELOPER_DASHBOARD_WEB_HOST} = $host;
$ENV{DEVELOPER_DASHBOARD_WEB_PORT} = $port;
$ENV{DEVELOPER_DASHBOARD_WEB_WORKERS} = $workers;
$ENV{DEVELOPER_DASHBOARD_WEB_SSL} = $ssl;
local $0 = $self->_web_process_title( $host, $port );
local $SIGNAL_MANAGER = $self;
my $shutdown = sub { $self->_shutdown_web('stopped') };
local $SIG{TERM} = $shutdown;
local $SIG{INT} = $shutdown;
local $SIG{HUP} = $shutdown;
my $server = eval { $self->{app_builder}->( host => $host, port => $port, workers => $workers, ssl => $ssl ) };
if ($@) {
$self->_write_startup_pipe_message( $writer, "err: $@" );
return 1;
}
my $daemon = eval { $server->start_daemon };
if ($@) {
$self->_write_startup_pipe_message( $writer, "err: $@" );
return 1;
}
my $bound_host = $daemon->sockhost;
my $bound_port = $daemon->sockport;
my $child_pid = $self->_normalized_process_id($$);
# The startup pipe is a private handshake with the forking parent, which
# persists pid and state synchronously before start_web returns. Signalling it
# before this child's own state write therefore exposes no consumer-visible
# window: every caller that learns about the service through start_web already
# sees persisted state, and the write below only refreshes it with the bound
# endpoint. Keep the order - reversing it would delay the parent's read
# without closing any window.
$self->_write_startup_pipe_message( $writer, join( '|', 'ok', $child_pid, $bound_host, $bound_port ) . "\n" );
$self->_close_inherited_fds( close_ipc => 1 ) if $detach || $redirect;
$self->_write_web_state(
{
host => $host,
pid => $child_pid,
port => $bound_port + 0,
process_name => $self->_web_process_title( $host, $port ),
started_at => _now_iso8601(),
status => 'running',
bound_host => $bound_host,
workers => $workers + 0,
ssl => $ssl + 0,
}
);
eval { $server->serve_daemon($daemon) };
if ($@) {
my $message = sprintf "[%s][web] %s\n", _now_iso8601(), $@;
$self->{files}->append( 'dashboard_log', $message );
$self->_write_web_state(
{
host => $host,
pid => $child_pid,
port => $bound_port + 0,
status => 'error',
error => "$@",
updated_at => _now_iso8601(),
bound_host => $bound_host,
workers => $workers + 0,
}
);
return 1;
}
$self->_write_web_state(
{
host => $host,
pid => $child_pid,
port => $bound_port + 0,
status => 'stopped',
updated_at => _now_iso8601(),
bound_host => $bound_host,
workers => $workers + 0,
}
);
return 0;
}
# _write_startup_pipe_message($writer, $message)
# Writes one startup status payload to the parent startup pipe without relying
# on buffered stdio semantics in detached children.
# Input: writable startup pipe handle and message string.
# Output: true value after the whole message is written and the handle closed.
sub _write_startup_pipe_message {
my ( $self, $writer, $message ) = @_;
$message = '' if !defined $message;
my $fd = fileno($writer);
lib/Developer/Dashboard/RuntimeManager.pm view on Meta::CPAN
if ( -e $source ) { # uncoverable branch false the source pending file still exists when the overwrite path reaches this cleanup
$self->_unlink_path($source) or undef;
}
return ( 1, '' );
}
# _cleanup_web_files()
# Removes persisted web pid and state files.
# Input: none.
# Output: true value.
sub _cleanup_web_files {
my ($self) = @_;
$self->{files}->remove('web_pid');
$self->{files}->remove('web_state');
return 1;
}
# _close_inherited_fds(%args)
# Closes inherited non-stdio descriptors in runtime children so background
# web/watchdog processes do not keep caller-side capture handles open after
# lifecycle commands exit.
# Input: optional keep array reference of descriptor integers, optional
# close_ipc boolean for socketpair/anon_inode cleanup, and optional
# preserve_harness boolean for in-process TAP harness execution.
# Output: true value.
sub _close_inherited_fds {
my ( $self, %args ) = @_;
return 1 if $args{preserve_harness} && $ENV{HARNESS_ACTIVE};
my %keep = map { $_ => 1 } grep { defined $_ && $_ =~ /^\d+$/ } @{ $args{keep} || [] };
$keep{0} = 1;
$keep{1} = 1;
$keep{2} = 1;
for my $fd ( $self->_open_file_descriptors ) {
next if $keep{$fd};
next if !$self->_descriptor_is_inherited_pipe( $fd, %args );
POSIX::close($fd);
}
return 1;
}
# _open_file_descriptors()
# Lists the current process file-descriptor numbers from procfs or /dev/fd so
# detached runtime children can close inherited caller pipes safely.
# Input: none.
# Output: sorted list of descriptor integers.
sub _open_file_descriptors {
my ($self) = @_;
my %seen;
my @fds;
for my $path ( glob('/proc/self/fd/*'), glob('/dev/fd/*') ) {
next if $path !~ m{(?:/proc/self/fd|/dev/fd)/(\d+)\z}; # uncoverable branch true the two globs only ever yield numeric descriptor entries under these directories
my $fd = $1 + 0;
next if $seen{$fd}++;
push @fds, $fd;
}
return sort { $a <=> $b } @fds;
}
# _descriptor_is_inherited_pipe($fd)
# Returns whether one descriptor currently points at an inherited capture or
# IPC endpoint that a detached runtime child should close after stdio has been
# redirected.
# Input: descriptor integer.
# Output: boolean true when the descriptor target is an inherited pipe,
# socketpair, or anonymous kernel handle.
sub _descriptor_is_inherited_pipe {
my ( $self, $fd, %args ) = @_;
return 0 if !defined $fd || $fd !~ /^\d+$/;
my $proc_target = readlink("/proc/self/fd/$fd");
my $dev_target = readlink("/dev/fd/$fd");
my $target = defined $proc_target ? $proc_target : $dev_target;
return 0 if !defined $target || $target eq ''; # uncoverable condition right readlink returns a non-empty path or undef, never an empty string
return 1 if $target =~ /^pipe:/;
return 0 if !$args{close_ipc};
return $target =~ /^(?:socket:|anon_inode:)/ ? 1 : 0;
}
# _web_process_title($host, $port)
# Builds the managed web process title string.
# Input: host and port values.
# Output: process title string.
sub _web_process_title {
my ( $self, $host, $port ) = @_;
return "dashboard web: $host:$port";
}
# _portable_signal($signal)
# Converts signal names used by dashboard lifecycle code into POSIX signal numbers.
# Input: signal name or numeric signal value.
# Output: numeric signal value safe for Perl builds that reject named signals.
sub _portable_signal {
my ($signal) = @_;
die 'Missing signal name' if !defined $signal || $signal eq '';
return $signal + 0 if $signal =~ /^\d+$/;
my %signal_number = (
HUP => 1,
INT => 2,
TERM => 15,
KILL => 9,
);
my $name = uc $signal;
die "Unsupported signal name: $signal" if !exists $signal_number{$name};
return $signal_number{$name};
}
# _send_signal($signal, @pids)
# Sends a portable numeric signal to live process ids.
# Input: signal name/number and candidate process id values.
# Output: number of process ids signalled by Perl kill.
sub _send_signal {
my ( $self, $signal, @pids ) = @_;
my @targets = grep { defined $_ && /^\d+$/ && $_ > 0 } @pids;
return 0 if !@targets;
if (is_windows()) {
my $joined = join ',', @targets;
my @taskkill = ('taskkill');
for my $target (@targets) {
push @taskkill, '/PID', $target;
}
push @taskkill, '/T', '/F';
my ( $stdout, $stderr, $exit_code ) = capture {
( run in 0.564 second using v1.01-cache-2.11-cpan-9789f410c06 )