view release on metacpan or  search on metacpan

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

# Wraps rename so tests can simulate platform-specific file replacement
# failures without mutating the real filesystem behavior globally.
# Input: source file path and destination file path.
# Output: true when the rename succeeds, false otherwise.
sub _rename_path {
    my ( $self, $source, $target ) = @_;
    return rename $source, $target;
}

# _unlink_path($path)
# Wraps unlink so tests can observe cleanup and Windows replacement retries in
# isolation from the caller.
# Input: one filesystem path string.
# Output: true when the path was removed, false otherwise.
sub _unlink_path {
    my ( $self, $path ) = @_;
    return unlink $path;
}

# _overwrite_state_file_in_place($source, $target)
# Rewrites one runtime state target in place from the prepared temporary
# payload when Windows denies delete-or-move replacement but still permits a
# direct overwrite.
# Input: temporary source path and final state-file path.
# Output: boolean success flag and optional failure text string.
sub _overwrite_state_file_in_place {
    my ( $self, $source, $target ) = @_;
    return ( 0, '' ) if !$self->is_windows;
    open my $source_fh, '<', $source or return ( 0, "Unable to read $source for in-place overwrite: $!" );
    local $/;
    my $content = <$source_fh>;
    close $source_fh;
    open my $target_fh, '>', $target or return ( 0, "Unable to open $target for in-place overwrite: $!" );
    print {$target_fh} $content
      or return ( 0, "Unable to write $target during in-place overwrite: $!" );
    close $target_fh;
    $self->_unlink_path($source);
    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/*') ) {
        my ($fd) = $path =~ m{(\d+)\z};
        $fd += 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;
    return 1 if $target =~ /^pipe:/;
    return 0 if !$args{close_ipc};
    return $target =~ /^(?:socket:|anon_inode:)/ ? 1 : 0;
}

# _current_perl_command()
# Resolves a runnable Perl interpreter path for detached helper launches,
# including Windows sessions where $^X can point at a nonexistent local::lib
# shim path.
# Input: none.
# Output: executable path string for the current Perl interpreter.
sub _current_perl_command {
    my ($self) = @_;
    if ($self->is_windows) {
        return command_in_path('perl')     if command_in_path('perl');
        return command_in_path('perl.exe') if command_in_path('perl.exe');
    }
    return $^X if defined $^X && $^X ne '' && -f $^X;
    return command_in_path('perl')     if command_in_path('perl');
    return command_in_path('perl.exe') if command_in_path('perl.exe');
    return $^X;
}

# _powershell_command()
# Resolves the PowerShell executable to invoke on Windows. Tries PATH under both
# spellings, then the SystemRoot install path, because a Windows host commonly has
# powershell.exe present at its standard location while PATH does not name it.
# Shared by RuntimeManager and CollectorRunner (DD-753): RuntimeManager previously
# hardcoded the bare string at four call sites and so failed through system() with
# an empty capture, while CollectorRunner resolved it and named the failure.
# Called as a plain function, not a method - it needs no object state.
# Input: none.
# Output: a usable PowerShell command string, or the empty string when none
#         resolves or the host is not Windows. Callers branch on empty and report
#         which executable was missing.
sub _powershell_command {
    return '' if !is_windows();
    return command_in_path('powershell')     if command_in_path('powershell');
    return command_in_path('powershell.exe') if command_in_path('powershell.exe');
    my $system_root = $ENV{SystemRoot} || 'C:\\Windows';
    my $fallback = File::Spec->catfile( $system_root, 'System32', 'WindowsPowerShell', 'v1.0', 'powershell.exe' );
    return $fallback if -f $fallback;
    return '';
}

# _powershell_single_quote($value)
# Escapes one literal string for safe use in a single-quoted PowerShell
# argument position.
# Input: raw scalar string value.