File Coverage

blib/lib/Sys/Cmd.pm

Criterion	Covered	Total	%
statement	258	291	88.6
branch	99	154	64.2
condition	45	88	51.1
subroutine	37	46	80.4
pod	11	14	78.5
total	450	593	75.8

package Sys::Cmd;
use v5.18;

use warnings;
no warnings "experimental::lexical_subs";
use feature 'lexical_subs';

use Carp            qw[];
use Cwd             qw[getcwd];
use Encode::Locale  qw[$ENCODING_LOCALE];      # Also Creates the 'locale' alias
use Encode          qw[encode resolve_alias];
use IO::Handle      qw[];
use Log::Any        qw[$log];
use Proc::FastSpawn qw[];
use Sys::Cmd::Process;
use Exporter::Tidy _map => {
    run    => sub { _syscmd( undef, @_ )->_run },
    spawn  => sub { _syscmd( undef, @_ )->_spawn },
    syscmd => sub { _syscmd( undef, @_ ) },
    runsub => sub {
        my $cmd = _syscmd( undef, @_ );
        sub { @_ ? _syscmd( $cmd, @_ )->_run : $cmd->_run }
    },
    spawnsub => sub {
        my $cmd = syscmd( undef, @_ );
        sub { @_ ? _syscmd( $cmd, @_ )->_spawn : $cmd->_spawn }
    },
};

our $VERSION = 'v0.986.3';

### START Class::Inline ### v0.0.1 Thu Dec 11 13:24:56 2025
require Carp;
our ( @_CLASS, $_FIELDS, %_NEW );

sub new {
    my $class = shift;
    my $CLASS = ref $class || $class;
    $_NEW{$CLASS} //= do {
        my ( %seen, @new, @build );
        my @possible = ($CLASS);
        while (@possible) {
            my $c = shift @possible;
            no strict 'refs';
            push @new,   $c . '::_NEW'  if exists &{ $c . '::_NEW' };
            push @build, $c . '::BUILD' if exists &{ $c . '::BUILD' };
            $seen{$c}++;
            if ( exists &{ $c . '::DOES' } ) {
                push @possible, grep { not $seen{$_}++ } $c->DOES('*');
            }
            push @possible, grep { not $seen{$_}++ } @{ $c . '::ISA' };
        }
        [ [ reverse(@new) ], [ reverse(@build) ] ];
    };
    my $self = { @_ ? @_ > 1 ? @_ : %{ $_[0] } : () };
    bless $self, $CLASS;
    my $attrs = { map { ( $_ => 1 ) } keys %$self };
    map { $self->$_($attrs) } @{ $_NEW{$CLASS}->[0] };
    {
        local $Carp::CarpLevel = 3;
        Carp::carp("Sys::Cmd: unexpected argument '$_'") for keys %$attrs
    }
    map { $self->$_ } @{ $_NEW{$CLASS}->[1] };
    $self;
}

sub _NEW {
    CORE::state $fix_FIELDS = do {
        $_FIELDS = { @_CLASS > 1 ? @_CLASS : %{ $_CLASS[0] } };
        $_FIELDS = $_FIELDS->{'FIELDS'} if exists $_FIELDS->{'FIELDS'};
    };
    if ( my @missing = grep { not exists $_[0]->{$_} } 'cmd' ) {
        Carp::croak( 'Sys::Cmd required initial argument(s): '
              . join( ', ', @missing ) );
    }
    $_[0]{'cmd'} = eval { $_FIELDS->{'cmd'}->{'isa'}->( $_[0]{'cmd'} ) };
    delete $_[0]{'cmd'} || Carp::confess( 'Sys::Cmd cmd: ' . $@ ) if $@;
    $_[0]{'dir'} = eval { $_FIELDS->{'dir'}->{'isa'}->( $_[0]{'dir'} ) }
      if exists $_[0]{'dir'};
    delete $_[0]{'dir'} || Carp::confess( 'Sys::Cmd dir: ' . $@ ) if $@;
    $_[0]{'encoding'} =
      eval { $_FIELDS->{'encoding'}->{'isa'}->( $_[0]{'encoding'} ) }
      if exists $_[0]{'encoding'};
    delete $_[0]{'encoding'} || Carp::confess( 'Sys::Cmd encoding: ' . $@ )
      if $@;
    $_[0]{'env'} = eval { $_FIELDS->{'env'}->{'isa'}->( $_[0]{'env'} ) }
      if exists $_[0]{'env'};
    delete $_[0]{'env'} || Carp::confess( 'Sys::Cmd env: ' . $@ ) if $@;
    $_[0]{'mock'} = eval { $_FIELDS->{'mock'}->{'isa'}->( $_[0]{'mock'} ) }
      if exists $_[0]{'mock'};
    delete $_[0]{'mock'} || Carp::confess( 'Sys::Cmd mock: ' . $@ ) if $@;
    map { delete $_[1]->{$_} } '_coderef', 'cmd', 'dir', 'encoding', 'env',
      'err', 'exit', 'input', 'log_any', 'mock', 'on_exit', 'out';
}

sub __RO {
    my ( undef, undef, undef, $sub ) = caller(1);
    Carp::confess("attribute $sub is read-only");
}

sub _coderef {
    __RO() if @_ > 1;
    $_[0]{'_coderef'} //= $_FIELDS->{'_coderef'}->{'default'}->( $_[0] );
}
sub cmd { __RO() if @_ > 1; $_[0]{'cmd'} // undef }
sub dir { __RO() if @_ > 1; $_[0]{'dir'} // undef }

sub encoding {
    __RO() if @_ > 1;
    $_[0]{'encoding'} //= eval {
        $_FIELDS->{'encoding'}->{'isa'}
          ->( $_FIELDS->{'encoding'}->{'default'} );
    };
    delete $_[0]{'encoding'}
      || Carp::confess( 'invalid (Sys::Cmd::encoding) default: ' . $@ )
      if $@;
    $_[0]{'encoding'};
}
sub env     { __RO() if @_ > 1; $_[0]{'env'}     // undef }
sub err     { __RO() if @_ > 1; $_[0]{'err'}     // undef }
sub exit    { __RO() if @_ > 1; $_[0]{'exit'}    // undef }
sub input   { __RO() if @_ > 1; $_[0]{'input'}   // undef }
sub log_any { __RO() if @_ > 1; $_[0]{'log_any'} // undef }

sub mock {
    if ( @_ > 1 ) {
        $_[0]{'mock'} = eval { $_FIELDS->{'mock'}->{'isa'}->( $_[1] ) };
        delete $_[0]{'mock'}
          || Carp::confess( 'invalid (Sys::Cmd::mock) value: ' . $@ )
          if $@;
    }
    $_[0]{'mock'} // undef;
}

sub on_exit {
    if ( @_ > 1 ) { $_[0]{'on_exit'} = $_[1] }
    $_[0]{'on_exit'} // undef;
}
sub out { __RO() if @_ > 1; $_[0]{'out'} // undef }
@_CLASS = grep 1,    ### END Class::Inline ###
  {
    cmd => {
        isa => sub {
            ref $_[0] eq 'ARRAY' || _croak("cmd must be ARRAYREF");
            @{ $_[0] }           || _croak("Missing cmd elements");
            if ( grep { !defined $_ } @{ $_[0] } ) {
                _croak('cmd array cannot contain undef elements');
            }
            $_[0];
        },
        required => 1,
    },
    _coderef => {
        default => sub {
            my $c = $_[0]->cmd->[0];
            ref($c) eq 'CODE' ? $c : undef;
        },
    },
    encoding => {
        default => $ENCODING_LOCALE,
        isa     => sub {
            resolve_alias( $_[0] )
              || _croak("Unknown Encoding: $_[0]");
            $_[0];
        },
    },
    env => {
        isa => sub {
            ref $_[0] eq 'HASH' || _croak("env must be HASHREF");
            $_[0];
        },
    },
    dir => {
        isa => sub {
            -d $_[0] || _croak("directory not found: $_[0]");
            $_[0];
        },
    },
    input   => {},
    log_any => {},
    out     => {},
    err     => {},
    exit    => {},
    mock    => {
        is  => 'rw',
        isa => sub {
            ( ( not defined $_[0] ) || 'CODE' eq ref $_[0] )
              || _croak('must be CODEref');
            $_[0];
        },
    },
    on_exit => { is => 'rw', },
  };

sub _croak {
    local $Carp::CarpInternal{'Sys::Cmd'}          = 1;
    local $Carp::CarpInternal{'Sys::Cmd::Process'} = 1;
    Carp::croak(@_);
}

sub _syscmd {
    my $template = shift;

    my ( @cmd, $opts );
    foreach my $arg (@_) {
        if ( ref($arg) eq 'HASH' ) {
            _croak( __PACKAGE__ . ': only a single hashref allowed' )
              if $opts;
            $opts = $arg;
        }
        else {
            push( @cmd, $arg );
        }
    }
    $opts //= {};

    if ($template) {
        $opts->{cmd} = [ @{ $template->cmd }, @cmd ];
        if ( exists $opts->{env} ) {
            my %env = ( each %{ $template->env }, each %{ $opts->{env} } );
            $opts->{env} = \%env;
        }
        return Sys::Cmd->new( { %$template, %$opts } );
    }

    _croak('$cmd must be defined') unless @cmd && defined $cmd[0];

    if ( 'CODE' ne ref( $cmd[0] ) and not $opts->{mock} ) {
        delete $opts->{mock};
        require File::Spec;
        if ( File::Spec->splitdir( $cmd[0] ) == 1 ) {
            require File::Which;
            $cmd[0] = File::Which::which( $cmd[0] )
              || _croak( 'command not found: ' . $cmd[0] );
        }

        if ( !-x $cmd[0] ) {
            _croak( 'command not executable: ' . $cmd[0] );
        }
    }
    $opts->{cmd} = \@cmd;
    Sys::Cmd->new($opts);
}

my sub _fastspawn {
    my @cmd = @_;

    # Backup the original 0,1,2 file descriptors
    open my $old_fd0, '<&', 0;
    open my $old_fd1, '>&', 1;
    open my $old_fd2, '>&', 2;

    # Get new handles to descriptors 0,1,2
    my $fd0 = IO::Handle->new_from_fd( 0, 'r' );
    my $fd1 = IO::Handle->new_from_fd( 1, 'w' );
    my $fd2 = IO::Handle->new_from_fd( 2, 'w' );

    # New handles for the child
    my $stdin  = IO::Handle->new;
    my $stdout = IO::Handle->new;
    my $stderr = IO::Handle->new;

    # Pipe our filehandles to new child filehandles
    pipe( my $child_in, $stdin )        || die "pipe: $!";
    pipe( $stdout,      my $child_out ) || die "pipe: $!";
    pipe( $stderr,      my $child_err ) || die "pipe: $!";

    # Make sure that 0,1,2 are inherited (probably are anyway)
    Proc::FastSpawn::fd_inherit( $_, 1 ) for 0, 1, 2;

    # But don't inherit the rest
    Proc::FastSpawn::fd_inherit( fileno($_), 0 )
      for $old_fd0, $old_fd1, $old_fd2,
      $child_in, $child_out, $child_err,
      $stdin,    $stdout,    $stderr;

    # Re-open 0,1,2 by duping the child pipe ends
    open $fd0, '<&', fileno($child_in)  || die "open: $!";
    open $fd1, '>&', fileno($child_out) || die "open: $!";
    open $fd2, '>&', fileno($child_err) || die "open: $!";

    # Kick off the new process
    my $pid = eval {
        Proc::FastSpawn::spawn(
            $cmd[0],
            \@cmd,
            [
                map { $_ . '=' . ( defined $ENV{$_} ? $ENV{$_} : '' ) }
                  keys %ENV
            ]
        );
    };
    my $err = $@;

    # Restore our local 0,1,2 to the originals
    open $fd0, '<&', fileno($old_fd0) || die "open: $!";
    open $fd1, '>&', fileno($old_fd1) || die "open: $!";
    open $fd2, '>&', fileno($old_fd2) || die "open: $!";

    # Parent doesn't need to see the child or backup descriptors anymore
    close($_) || die "close: $!"
      for $old_fd0,
      $old_fd1,
      $old_fd2,
      $child_in,
      $child_out,
      $child_err;

    # Complain if the spawn failed for some reason
    _croak($err) if $err;
    _croak('Unable to spawn child') unless defined $pid;

    (
        pid    => $pid,
        stdin  => $stdin,
        stdout => $stdout,
        stderr => $stderr
    );
}

my sub _fork {
    my $encoding = shift // die 'need encoding';
    my $code     = shift // die 'need code';
    my @args     = @_;
    my ( $stdin, $stdout, $stderr ) =
      ( IO::Handle->new, IO::Handle->new, IO::Handle->new, );

    pipe( my $child_in, $stdin )        || die "pipe: $!";
    pipe( $stdout,      my $child_out ) || die "pipe: $!";
    pipe( $stderr,      my $child_err ) || die "pipe: $!";

    my $pid = fork();
    if ( !defined $pid ) {
        my $why = $!;
        die "fork: $why";
    }

    if ( $pid > 0 ) {    # parent
        close($_) for
          $child_in,
          $child_out,
          $child_err;

        return (
            pid    => $pid,
            stdin  => $stdin,
            stdout => $stdout,
            stderr => $stderr
        );
    }

    # Child
    $child_err->autoflush(1);

    foreach my $quad (
        [ \*STDERR, '>&=', fileno($child_err), 1 ],
        [ \*STDOUT, '>&=', fileno($child_out), 1 ],
        [ \*STDIN,  '<&=', fileno($child_in),  0 ],
      )
    {
        my ( $fh, $mode, $fileno, $autoflush ) = @$quad;

        open( $fh, $mode, $fileno )
          or print $child_err sprintf "[%d] open %s, %s: %s\n", $pid,
          $fh, $mode, $!;

        binmode $fh, ':encoding(' . $encoding . ')'
          or warn sprintf "[%d] binmode %d(%s) %s: %s", $pid,
          $fileno, $mode, $encoding, $!;

        $fh->autoflush(1) if $autoflush;
    }

    close($_) for
      $stdin,
      $stdout,
      $stderr,
      $child_in,
      $child_out,
      $child_err;

    $code->(@args);
    _exit(0);

    #    exec( @{ $self->cmd } );
    #    die "exec: $!";
}

sub _spawn {
    my $self = shift;
    my $dir  = $self->dir;
    my $cwd  = getcwd if defined $dir;

    my $proc = eval {
        local %ENV = %ENV;
        my $locale = $self->encoding;
        while ( my ( $key, $val ) = each %{ $self->env // {} } ) {
            my $keybytes = encode( $locale, $key, Encode::FB_CROAK );
            if ( defined $val ) {
                $ENV{$keybytes} = encode( $locale, $val, Encode::FB_CROAK );
            }
            else {
                delete $ENV{$keybytes};
            }
        }

        chdir $dir or die "chdir: $!" if defined $dir;
        my $oe = $self->on_exit;

        Sys::Cmd::Process->new(
            cmd => $self->cmd,
            $oe ? ( on_exit => $oe ) : (),
            $self->_coderef
            ? _fork( $self->encoding, @{ $self->cmd } )
            : _fastspawn(
                map {
                    encode(
                        $locale => $_,
                        Encode::FB_CROAK | Encode::LEAVE_SRC
                    )
                } @{ $self->cmd }
            )
        );
    };
    my $err = $@;
    chdir $cwd if defined $dir;
    die $err   if $err;

    my $enc = ':encoding(' . $self->encoding . ')';
    binmode( $proc->stdin,  $enc ) or warn "binmode stdin: $!";
    binmode( $proc->stdout, $enc ) or warn "binmode stdout: $!";
    binmode( $proc->stderr, $enc ) or warn "binmode stderr: $!";

    $proc->stdin->autoflush(1);

    # some input was provided
    if ( defined( my $input = $self->input ) ) {
        local $SIG{PIPE} =
          sub { warn "Broken pipe when writing to:" . $proc->cmdline };

        if ( ( 'ARRAY' eq ref $input ) && @$input ) {
            $proc->stdin->print(@$input);
        }
        elsif ( length $input ) {
            $proc->stdin->print($input);
        }

        $proc->stdin->close;
    }

    $proc;
}

sub _run {
    my $self   = shift;
    my $proc   = $self->_spawn;
    my $stderr = $proc->stderr;
    my $stdout = $proc->stdout;

    # Select idea borrowed from System::Command
    require IO::Select;
    my $select = IO::Select->new( $stdout, $stderr );
    my @err;
    my @out;

    while ( my @ready = $select->can_read ) {
        for my $fh (@ready) {
            my $dest = $fh == $stdout ? \@out : \@err;
            if ( defined( my $line = <$fh> ) ) {
                push @$dest, $line;
            }
            else {
                $select->remove($fh);
                $fh->close;
            }
        }
    }

    $proc->stdin->close;
    my $ok = $proc->wait_child;

    if ( my $ref = $self->exit ) {
        $$ref = $proc->exit;
    }
    elsif ( !$ok ) {
        _croak( join( '', @err ) . $proc->status );
    }

    if ( my $ref = $self->err ) {
        $$ref = join '', @err;
    }
    elsif (@err) {
        local @Carp::CARP_NOT = (__PACKAGE__);
        Carp::carp @err;
    }

    if ( my $ref = $self->out ) {
        $$ref = join '', @out;
    }
    elsif ( defined( my $wa = wantarray ) ) {
        return @out if $wa;
        return join( '', @out );
    }
}

# Legacy object interface, undocumented.
sub run   { _syscmd(@_)->_run }
sub spawn { _syscmd(@_)->_spawn }

1;

__END__