Add IPC::Run::Win32Process, for delivering nonstandard command lines.

nmisch · nmisch · commit 8491dfeb8f20 · 2021-07-06T05:04:17.000-07:00
This unblocks general use of programs like cmd.exe and cscript.exe as
stages in IPC::Run pipelines.
diff --git a/MANIFEST b/MANIFEST
@@ -16,6 +16,7 @@ lib/IPC/Run/IO.pm
 lib/IPC/Run/Timer.pm
 lib/IPC/Run/Win32Helper.pm
 lib/IPC/Run/Win32IO.pm
+lib/IPC/Run/Win32Process.pm
 lib/IPC/Run/Win32Pump.pm
 LICENSE
 Makefile.PL
diff --git a/lib/IPC/Run.pm b/lib/IPC/Run.pm
@@ -413,8 +413,8 @@ to the systems' shell:
 
 or a list of commands, io operations, and/or timers/timeouts to execute.
 Consecutive commands must be separated by a pipe operator '|' or an '&'.
-External commands are passed in as array references, and, on systems
-supporting fork(), Perl code may be passed in as subs:
+External commands are passed in as array references or L<IPC::Run::Win32Process>
+objects.  On systems supporting fork(), Perl code may be passed in as subs:
 
    run \@cmd;
    run \@cmd1, '|', \@cmd2;
@@ -1240,6 +1240,33 @@ sub _search_path {
     croak "Command '$cmd_name' not found in " . join( ", ", @searched_in );
 }
 
+# Translate a command or CODE reference (a $kid->{VAL}) to a list of strings
+# suitable for passing to _debug().
+sub _debugstrings {
+    my $operand = shift;
+    if ( !defined $operand ) {
+        return '<undef>';
+    }
+
+    my $ref = ref $operand;
+    if ( !$ref ) {
+        return length $operand < 50
+          ? "'$operand'"
+          : join( '', "'", substr( $operand, 0, 10 ), "...'" );
+    }
+    elsif ( $ref eq 'ARRAY' ) {
+        return (
+            '[ ',
+            join( " ", map /[^\w.-]/ ? "'$_'" : $_, @$operand ),
+            ' ]'
+        );
+    }
+    elsif ( UNIVERSAL::isa( $operand, 'IPC::Run::Win32Process' ) ) {
+        return "$operand";
+    }
+    return $ref;
+}
+
 sub _empty($) { !( defined $_[0] && length $_[0] ) }
 
 ## 'safe' versions of otherwise fun things to do. See also IPC::Run::Win32Helper.
@@ -1375,6 +1402,9 @@ sub _spawn {
     my IPC::Run $self = shift;
     my ($kid) = @_;
 
+    croak "Can't spawn IPC::Run::Win32Process except on Win32"
+      if UNIVERSAL::isa( $kid->{VAL}, 'IPC::Run::Win32Process' );
+
     _debug "opening sync pipe ", $kid->{PID} if _debugging_details;
     my $sync_reader_fd;
     ( $sync_reader_fd, $self->{SYNC_WRITER_FD} ) = _pipe;
@@ -1730,24 +1760,12 @@ sub harness {
         for ( shift @args ) {
             eval {
                 $first_parse = 1;
-                _debug(
-                    "parsing ",
-                    defined $_
-                    ? ref $_ eq 'ARRAY'
-                          ? ( '[ ', join( ', ', map "'$_'", @$_ ), ' ]' )
-                          : (
-                              ref $_
-                                || (
-                                  length $_ < 50
-                                  ? "'$_'"
-                                  : join( '', "'", substr( $_, 0, 10 ), "...'" )
-                                )
-                          )
-                    : '<undef>'
-                ) if _debugging;
+                _debug( "parsing ", _debugstrings($_) ) if _debugging;
 
               REPARSE:
-                if ( ref eq 'ARRAY' || ( !$cur_kid && ref eq 'CODE' ) ) {
+                if (   ref eq 'ARRAY'
+                    || UNIVERSAL::isa( $_, 'IPC::Run::Win32Process' )
+                    || ( !$cur_kid && ref eq 'CODE' ) ) {
                     croak "Process control symbol ('|', '&') missing" if $cur_kid;
                     croak "Can't spawn a subroutine on Win32"
                       if Win32_MODE && ref eq "CODE";
@@ -2077,7 +2095,7 @@ sub _open_pipes {
     ## Loop through the kids and their OPS, interpreting any that require
     ## parent-side actions.
     for my $kid ( @{ $self->{KIDS} } ) {
-        unless ( ref $kid->{VAL} eq 'CODE' ) {
+        if ( ref $kid->{VAL} eq 'ARRAY' ) {
             $kid->{PATH} = _search_path $kid->{VAL}->[0];
         }
         if ( defined $pipe_read_fd ) {
@@ -2789,14 +2807,8 @@ sub start {
         { my $ofh = select STDERR; my $of = $|; $| = 1; $| = $of; select $ofh; }
         for my $kid ( @{ $self->{KIDS} } ) {
             $kid->{RESULT} = undef;
-            _debug "child: ",
-              ref( $kid->{VAL} ) eq "CODE"
-              ? "CODE ref"
-              : (
-                "`",
-                join( " ", map /[^\w.-]/ ? "'$_'" : $_, @{ $kid->{VAL} } ),
-                "`"
-              ) if _debugging_details;
+            _debug "child: ", _debugstrings( $kid->{VAL} )
+              if _debugging_details;
             eval {
                 croak "simulated failure of fork"
                   if $self->{_simulate_fork_failure};
@@ -2807,17 +2819,20 @@ sub start {
 ## TODO: Test and debug spawning code.  Someday.
                     _debug(
                         'spawning ',
-                        join(
-                            ' ',
-                            map( "'$_'",
-                                ( $kid->{PATH}, @{ $kid->{VAL} }[ 1 .. $#{ $kid->{VAL} } ] ) )
+                        _debugstrings(
+                            [
+                                $kid->{PATH},
+                                @{ $kid->{VAL} }[ 1 .. $#{ $kid->{VAL} } ]
+                            ]
                         )
-                    ) if _debugging;
+                    ) if $kid->{PATH} && _debugging;
                     ## The external kid wouldn't know what to do with it anyway.
                     ## This is only used by the "helper" pump processes on Win32.
                     _dont_inherit( $self->{DEBUG_FD} );
                     ( $kid->{PID}, $kid->{PROCESS} ) = IPC::Run::Win32Helper::win32_spawn(
-                        [ $kid->{PATH}, @{ $kid->{VAL} }[ 1 .. $#{ $kid->{VAL} } ] ],
+                        ref( $kid->{VAL} ) eq "ARRAY"
+                        ? [ $kid->{PATH}, @{ $kid->{VAL} }[ 1 .. $#{ $kid->{VAL} } ] ]
+                        : $kid->{VAL},
                         $kid->{OPS},
                     );
                     _debug "spawn() = ", $kid->{PID} if _debugging;
@@ -4170,8 +4185,8 @@ rules|https://docs.microsoft.com/en-us/cpp/cpp/main-function-command-line-args#p
 will see an C<argv> that matches the array reference specifying the command.
 Some programs use different rules to parse their command line.  Notable examples
 include F<cmd.exe>, F<cscript.exe>, and Cygwin programs called from non-Cygwin
-programs.  Use L<Win32::Process>, not IPC::Run, to call these and other
-nonstandard programs.
+programs.  Use L<IPC::Run::Win32Process> to call these and other nonstandard
+programs.
 
 =item batch files
 
diff --git a/lib/IPC/Run/Win32Helper.pm b/lib/IPC/Run/Win32Helper.pm
@@ -409,7 +409,11 @@ sub win32_spawn {
 
     my ( $app, $cmd_line );
     my $need_pct = 0;
-    if ( $cmd->[0] !~ /\.(bat|cmd) *$/i ) {
+    if ( UNIVERSAL::isa( $cmd, 'IPC::Run::Win32Process' ) ) {
+        $app      = $cmd->{lpApplicationName};
+        $cmd_line = $cmd->{lpCommandLine};
+    }
+    elsif ( $cmd->[0] !~ /\.(bat|cmd) *$/i ) {
         $app      = $cmd->[0];
         $cmd_line = Win32::ShellQuote::quote_native(@$cmd);
     }
diff --git a/lib/IPC/Run/Win32Process.pm b/lib/IPC/Run/Win32Process.pm
@@ -0,0 +1,80 @@
+package IPC::Run::Win32Process;
+
+=pod
+
+=head1 NAME
+
+IPC::Run::Win32Process -- deliver nonstandard command lines via IPC::Run.
+
+=head1 SYNOPSIS
+
+   use File::Spec ();
+   use IPC::Run qw(run);
+   use IPC::Run::Win32Process ();
+   use Win32 ();
+
+   $find_exe = File::Spec->catfile(Win32::GetFolderPath(Win32::CSIDL_SYSTEM),
+                                   'find.exe');
+   run(IPC::Run::Win32Process->new($ENV{COMSPEC}, q{cmd.exe /c echo ""}),
+       '|', IPC::Run::Win32Process->new($find_exe, q{find_exe """"""}),
+       '>', \$out);
+
+=head1 DESCRIPTION
+
+This class facilitates executing Windows programs that don't use L<standard
+command line parsing
+rules|https://docs.microsoft.com/en-us/cpp/cpp/main-function-command-line-args#parsing-c-command-line-arguments>.
+Notable programs having nonstandard rules include F<cmd.exe>, F<cscript.exe>,
+and Cygwin programs called from non-Cygwin programs.  IPC::Run will use the two
+strings, verbatim, as the lpApplicationName and lpCommandLine arguments of
+CreateProcessA().  This furnishes unfiltered control over the child process
+command line.
+
+=head1 FUNCTIONS & METHODS
+
+=over
+
+=cut
+
+use strict;
+use warnings;
+use Carp;
+
+use overload '""' => sub {
+    my ($self) = @_;
+    return join(
+        '',
+        'IPC::Run::Win32Process(',
+        $self->{lpApplicationName},
+        ', ',
+        $self->{lpCommandLine},
+        ')'
+    );
+};
+
+=item new
+
+   IPC::Run::Win32Process->new( $lpApplicationName, $lpCommandLine );
+   IPC::Run::Win32Process->new( $ENV{COMSPEC}, q{cmd.exe /c echo ""} );
+
+Constructor.
+
+=back
+
+=cut
+
+sub new {
+    my ( $class, $lpApplicationName, $lpCommandLine ) = @_;
+    $class = ref $class || $class;
+
+    croak "missing lpApplicationName" if !defined $lpApplicationName;
+    croak "missing lpCommandLine"     if !defined $lpCommandLine;
+
+    my IPC::Run::Win32Process $self = bless {}, $class;
+    $self->{lpApplicationName} = $lpApplicationName;
+    $self->{lpCommandLine}     = $lpCommandLine;
+
+    return $self;
+}
+
+1;
diff --git a/t/run.t b/t/run.t
@@ -38,7 +38,7 @@ sub get_warnings {
 select STDERR;
 select STDOUT;
 
-use Test::More tests => 286;
+use Test::More tests => 288;
 use IPC::Run::Debug qw( _map_fds );
 use IPC::Run qw( :filters :filter_imp start );
 
@@ -344,6 +344,36 @@ SKIP: {
     chdir $initial_cwd;
 }
 
+##
+## IPC::Run::Win32Process
+##
+SKIP: {
+    if ( !IPC::Run::Win32_MODE() ) {
+        skip( "cmd.exe is specific to Win32", 2 );
+    }
+
+    use File::Spec ();
+    require Win32;
+    require IPC::Run::Win32Process;
+
+    run(
+        IPC::Run::Win32Process->new( $ENV{COMSPEC}, q{cmd.exe /c echo ""} ),
+        '>', \$out
+    );
+    eok( $out, qq{""\n} );
+
+    my $find_exe = File::Spec->catfile(
+        Win32::GetFolderPath( Win32::CSIDL_SYSTEM() ),
+        'find.exe'
+    );
+    run(
+        IPC::Run::Win32Process->new( $ENV{COMSPEC}, q{cmd.exe /c echo ""} ),
+        '|', IPC::Run::Win32Process->new( $find_exe, q{find_exe """"""} ),
+        '>', \$out
+    );
+    eok( $out, qq{""\n} );
+}
+
 ##
 ## A function
 ##
diff --git a/xt/98_pod_coverage.t b/xt/98_pod_coverage.t
@@ -25,15 +25,16 @@ foreach my $MODULE (@MODULES) {
           : plan( skip_all => "$MODULE not available for testing" );
     }
 }
-plan tests => 7;
+plan tests => 8;
 
 #my $private_subs = { private => [qr/foo_fizz/]};
 #pod_coverage_ok('IPC::Run', $private_subs, "Test IPC::Run that all modules are documented.");
 
-pod_coverage_ok( 'IPC::Run',        "Test IPC::Run that all modules are documented." );
-pod_coverage_ok( 'IPC::Run::Debug', "Test IPC::Run::Debug that all modules are documented." );
-pod_coverage_ok( 'IPC::Run::IO',    "Test IPC::Run::IO that all modules are documented." );
-pod_coverage_ok( 'IPC::Run::Timer', "Test IPC::Run::Timer that all modules are documented." );
+pod_coverage_ok( 'IPC::Run',               "Test IPC::Run that all modules are documented." );
+pod_coverage_ok( 'IPC::Run::Debug',        "Test IPC::Run::Debug that all modules are documented." );
+pod_coverage_ok( 'IPC::Run::IO',           "Test IPC::Run::IO that all modules are documented." );
+pod_coverage_ok( 'IPC::Run::Timer',        "Test IPC::Run::Timer that all modules are documented." );
+pod_coverage_ok( 'IPC::Run::Win32Process', "Test IPC::Run::Win32Process that all modules are documented." );
 TODO: {
     local $TODO = "These modules are not fully documented yet.";
     pod_coverage_ok( 'IPC::Run::Win32Helper', "Test IPC::Run::Win32Helper that all modules are documented." );
