cpan-authors · nmisch · Jul 8, 2022 · Jul 6, 2021 · Jul 6, 2021 · Jul 6, 2021
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/Makefile.PL b/Makefile.PL
@@ -16,6 +16,7 @@ if ( $^O ne 'MSWin32' ) {
     }
 }
 else {
+    $PREREQ_PM{'Win32'}             = '0.27';
     $PREREQ_PM{'Win32::Process'}    = '0.14';
     $PREREQ_PM{'Win32::ShellQuote'} = 0;
     $PREREQ_PM{'Win32API::File'}    = '0.0901';

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;
@@ -4162,6 +4177,34 @@ High resolution timeouts.
 
 =over
 
+=item argument-passing rules are program-specific
+
+Win32 programs receive all arguments in a single "command line" string.
+IPC::Run assembles this string so programs using L<standard command line parsing
+rules|https://docs.microsoft.com/en-us/cpp/cpp/main-function-command-line-args#parsing-c-command-line-arguments>
+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<IPC::Run::Win32Process> to call these and other nonstandard
+programs.
+
+=item batch files
+
+Properly escaping a batch file argument depends on how the script will use that
+argument, because some uses experience multiple levels of caret (escape
+character) removal.  Avoid calling batch files with arguments, particularly when
+the argument values originate outside your program or contain non-alphanumeric
+characters.  Perl scripts and PowerShell scripts are sound alternatives.  If you
+do use batch file arguments, IPC::Run escapes them so the batch file can pass
+them, unquoted, to a program having standard command line parsing rules.  If the
+batch file enables delayed environment variable expansion, it must disable that
+feature before expanding its arguments.  For example, if F<foo.cmd> contains
+C<perl %*>, C<run ['foo.cmd', @list]> will create a Perl process in which
+C<@ARGV> matches C<@list>.  Prepending a C<setlocal enabledelayedexpansion> line
+would make the batch file malfunction, silently.  Another silent-malfunction
+example is C<run ['outer.bat', @list]> for F<outer.bat> containing C<foo.cmd
+%*>.
+
 =item Fails on Win9X
 
 If you want Win9X support, you'll have to debug it or fund me because I

diff --git a/lib/IPC/Run/Win32Helper.pm b/lib/IPC/Run/Win32Helper.pm
@@ -38,7 +38,9 @@ BEGIN {
 
 require POSIX;
 
+use File::Spec ();
 use Text::ParseWords;
+use Win32 ();
 use Win32::Process;
 use Win32::ShellQuote ();
 use IPC::Run::Debug;
@@ -405,6 +407,71 @@ sub _dup2_gently {
 sub win32_spawn {
     my ( $cmd, $ops ) = @_;
 
+    my ( $app, $cmd_line );
+    my $need_pct = 0;
+    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);
+    }
+    else {
+        # Batch file, so follow the batch-specific guidance of
+        # https://docs.microsoft.com/en-us/windows/win32/api/processthreadsapi/nf-processthreadsapi-createprocessa
+        # There's no one true way to locate cmd.exe.  In the unlikely event that
+        # %COMSPEC% is missing, fall back on a Windows API.  We could search
+        # %PATH% like _wsystem() does.  That would be prone to security bugs,
+        # and one fallback is enough.
+        $app = (
+            $ENV{COMSPEC}
+              || File::Spec->catfile(
+                Win32::GetFolderPath(Win32::CSIDL_SYSTEM),
+                'cmd.exe'
+              )
+        );
+
+        # Win32 rejects attempts to create files with names containing certain
+        # characters.  Ignore most, but reject the subset that might otherwise
+        # cause us to execute the wrong file instead of failing cleanly.
+        if ( $cmd->[0] =~ /["\r\n\0]/ ) {
+            croak "invalid batch file name";
+        }
+
+        # Make cmd.exe see the batch file name as quoted.  Suppose we instead
+        # used caret escapes, as we do for arguments.  cmd.exe could then "break
+        # the command token at the first occurrence of <space> , ; or ="
+        # (https://stackoverflow.com/a/4095133).
+        my @parts = qq{"$cmd->[0]"};
+
+        # cmd.exe will strip escapes once when parsing our $cmd_line and again
+        # where the batch file injects the argument via %*, %1, etc.  Compensate
+        # by adding one extra cmd_escape layer.
+        if ( @$cmd > 1 ) {
+            my @q = Win32::ShellQuote::quote_cmd( @{$cmd}[ 1 .. $#{$cmd} ] );
+            push @parts, map { Win32::ShellQuote::cmd_escape($_) } @q;
+        }
+
+        # One can't stop cmd.exe from expanding %var%, so inject each literal %
+        # via an environment variable.  Delete that variable before the real
+        # child can see it.  See
+        # https://www.dostips.com/forum/viewtopic.php?f=3&t=10131 for more on
+        # this technique and the limitations of alternatives.
+        $cmd_line = join ' ', @parts;
+        if ( $cmd_line =~ s/%/%ipcrunpct%/g ) {
+            $cmd_line = qq{/c "set "ipcrunpct=" & $cmd_line"};
+            $need_pct = 1;
+        }
+        else {
+            $cmd_line = qq{/c "$cmd_line"};
+        }
+    }
+    _debug "app: ", $app
+      if _debugging;
+    _debug "cmd line: ", $cmd_line
+      if _debugging;
+
     ## NOTE: The debug pipe write handle is passed to pump processes as STDOUT.
     ## and is not to the "real" child process, since they would not know
     ## what to do with it...unlike Unix, we have no code executing in the
@@ -447,20 +514,21 @@ sub win32_spawn {
         }
     }
 
+    local $ENV{ipcrunpct} = '%' if $need_pct;
     my $process;
-    my $cmd_line = Win32::ShellQuote::quote_native(@$cmd);
-
-    _debug "cmd line: ", $cmd_line
-      if _debugging;
-
     Win32::Process::Create(
         $process,
-        $cmd->[0],
+        $app,
         $cmd_line,
         1,    ## Inherit handles
         0,    ## Inherit parent priortiy class. Was NORMAL_PRIORITY_CLASS
         ".",
-    ) or croak "$!: Win32::Process::Create()";
+      )
+      or do {
+        my $err = Win32::FormatMessage( Win32::GetLastError() );
+        $err =~ s/\r?\n$//s;
+        croak "$err: Win32::Process::Create()";
+      };
 
     for my $orig_fd ( keys %saved ) {
         IPC::Run::_dup2_rudely( $saved{$orig_fd}, $orig_fd );

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;