view release on metacpan or  search on metacpan

lib/Developer/Dashboard/RuntimeManager.pm  view on Meta::CPAN

    if ( -e $source ) {
        $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};
        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 '';
    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 {