win32: default the shell to cmd.exe in the Windows system directory

This prevents picking up cmd.exe from the current directory, or
even from the PATH.

This protects against a privilege escalation attack where an attacker
in a separate session creates a cmd.exe in a directory where the
target account happens to have its current directory.

t/win32/system.t

@@ -82,6 +82,7 @@ close $F;
 chdir($testdir);
 END {
     chdir($cwd) && rmtree("$cwd/$testdir") if -d "$cwd/$testdir";
+    unlink "cmd.exe";
 }
 if (open(my $EIN, "$cwd/win32/${exename}_exe.uu")) {
     note "Unpacking $exename.exe";
@@ -104,21 +105,20 @@ else {
      }
     note "Compiling $exename.c";
     note "$Config{cc} $Config{ccflags} $exename.c";
-    if (system("$Config{cc} $Config{ccflags} $minus_o $exename.c >log 2>&1") != 0) {
+    if (system("$Config{cc} $Config{ccflags} $minus_o $exename.c >log 2>&1") != 0 ||
+        !-f "$exename.exe") {
 	note "Could not compile $exename.c, status $?";
-    note "Where is your C compiler?";
-    skip_all "can't build test executable";
-    }
-    unless (-f "$exename.exe") {
-	if (open(LOG,'<log'))
-         {
-          while(<LOG>) {
-              note $_;
-          } 
-         }
+        note "Where is your C compiler?";
+        if (open(LOG,'<log'))
+        {
+            while(<LOG>) {
+                note $_;
+            }
+        }
         else {
-	  warn "Cannot open log (in $testdir):$!";
+            warn "Cannot open log (in $testdir):$!";
         }
+        skip_all "can't build test executable";
     }
 }
 copy("$plxname.bat","$plxname.cmd");
@@ -128,6 +128,12 @@ unless (-x "$testdir/$exename.exe") {
     skip_all "can't build test executable";
 }
 
+# test we only look for cmd.exe in the standard place
+delete $ENV{PERLSHELL};
+copy("$testdir/$exename.exe", "$testdir/cmd.exe") or die $!;
+copy("$testdir/$exename.exe", "cmd.exe") or die $!;
+$ENV{PATH} = qq("$testdir";$ENV{PATH});
+
 open my $T, "$^X -I../lib -w win32/system_tests |"
     or die "Can't spawn win32/system_tests: $!";
 my $expect;

win32/win32.c

@@ -117,7 +117,7 @@ static char*	win32_get_xlib(const char *pl,
 
 static BOOL	has_shell_metachars(const char *ptr);
 static long	tokenize(const char *str, char **dest, char ***destv);
-static void	get_shell(void);
+static int	get_shell(void);
 static char*	find_next_space(const char *s);
 static int	do_spawn2(pTHX_ const char *cmd, int exectype);
 static int	do_spawn2_handles(pTHX_ const char *cmd, int exectype,
@@ -600,7 +600,13 @@ tokenize(const char *str, char **dest, char ***destv)
     return items;
 }
 
-static void
+static const char
+cmd_opts[] = "/x/d/c";
+
+static const char
+shell_cmd[] = "cmd.exe";
+
+static int
 get_shell(void)
 {
     dTHX;
@@ -612,12 +618,53 @@ get_shell(void)
          *     interactive use (which is what most programs look in COMSPEC
          *     for).
          */
-        const char* defaultshell = "cmd.exe /x/d/c";
-        const char *usershell = PerlEnv_getenv("PERL5SHELL");
-        w32_perlshell_items = tokenize(usershell ? usershell : defaultshell,
-                                       &w32_perlshell_tokens,
-                                       &w32_perlshell_vec);
+        const char *shell = PerlEnv_getenv("PERL5SHELL");
+        if (shell) {
+            w32_perlshell_items = tokenize(shell,
+                                           &w32_perlshell_tokens,
+                                           &w32_perlshell_vec);
+        }
+        else {
+            /* tokenize does some Unix-ish like things like
+               \\ escaping that don't work well here
+            */
+            char shellbuf[MAX_PATH];
+            UINT len = GetSystemDirectoryA(shellbuf, sizeof(shellbuf));
+            if (len == 0) {
+                translate_to_errno();
+                return -1;
+            }
+            else if (len >= MAX_PATH) {
+                /* buffer too small */
+                errno = E2BIG;
+                return -1;
+            }
+            if (shellbuf[len-1] != '\\') {
+                my_strlcat(shellbuf, "\\", sizeof(shellbuf));
+                ++len;
+            }
+            if (len + sizeof(shell_cmd) > sizeof(shellbuf)) {
+                errno = E2BIG;
+                return -1;
+            }
+            my_strlcat(shellbuf, shell_cmd, sizeof(shellbuf));
+            len += sizeof(shell_cmd)-1;
+
+            Newx(w32_perlshell_vec, 3, char *);
+            Newx(w32_perlshell_tokens, len + 1 + sizeof(cmd_opts), char);
+
+            my_strlcpy(w32_perlshell_tokens, shellbuf, len+1);
+            my_strlcpy(w32_perlshell_tokens + len +1, cmd_opts,
+                       sizeof(cmd_opts));
+
+            w32_perlshell_vec[0] = w32_perlshell_tokens;
+            w32_perlshell_vec[1] = w32_perlshell_tokens + len + 1;
+            w32_perlshell_vec[2] = NULL;
+
+            w32_perlshell_items = 2;
+        }
     }
+    return 0;
 }
 
 int
@@ -635,7 +682,9 @@ Perl_do_aspawn(pTHX_ SV *really, SV **mark, SV **sp)
     if (sp <= mark)
         return -1;
 
-    get_shell();
+    if (get_shell() < 0)
+        return -1;
+
     Newx(argv, (sp - mark) + w32_perlshell_items + 2, const char*);
 
     if (SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
@@ -765,7 +814,8 @@ do_spawn2_handles(pTHX_ const char *cmd, int exectype, const int *handles)
     if (needToTry) {
         char **argv;
         int i = -1;
-        get_shell();
+        if (get_shell() < 0)
+            return -1;
         Newx(argv, w32_perlshell_items + 2, char*);
         while (++i < w32_perlshell_items)
             argv[i] = w32_perlshell_vec[i];
@@ -3482,7 +3532,8 @@ win32_pipe(int *pfd, unsigned int size, int mode)
 DllExport PerlIO*
 win32_popenlist(const char *mode, IV narg, SV **args)
 {
-    get_shell();
+    if (get_shell() < 0)
+        return NULL;
 
     return do_popen(mode, NULL, narg, args);
 }