Merge branch 'refactor-run-program' into develop

Refactor run-program to have HL interface in lisp sources. Add proper
argument escaping on Windows (fixes #304).

TODO:
- write tests for run-program
- documentation
- move external-process logic to process.lsp
- implement external-process-pipe-thread

src/c/symbols_list.h

@@ -1232,7 +1232,8 @@ cl_symbols[] = {
 {SYS_ "REM-SYSPROP", SI_ORDINARY, si_rem_sysprop, 2, OBJNULL},
 {SYS_ "REPLACE-ARRAY", SI_ORDINARY, si_replace_array, 2, OBJNULL},
 {SYS_ "ROW-MAJOR-ASET", SI_ORDINARY, si_row_major_aset, 3, OBJNULL},
-{EXT_ "RUN-PROGRAM", EXT_ORDINARY, si_run_program, -1, OBJNULL},
+{EXT_ "RUN-PROGRAM", EXT_ORDINARY, ECL_NAME(si_run_program), -1, OBJNULL},
+{SYS_ "RUN-PROGRAM-INTERNAL", SI_ORDINARY, si_run_program_internal, 8, OBJNULL},
 {EXT_ "TERMINATE-PROCESS", EXT_ORDINARY, si_terminate_process, -1, OBJNULL},
 {SYS_ "WAIT-FOR-ALL-PROCESSES", SI_ORDINARY, si_wait_for_all_processes, -1, OBJNULL},
 {EXT_ "SAFE-EVAL", EXT_ORDINARY, ECL_NAME(si_safe_eval), -1, OBJNULL},

src/c/symbols_list2.h

@@ -1232,7 +1232,8 @@ cl_symbols[] = {
 {SYS_ "REM-SYSPROP","si_rem_sysprop"},
 {SYS_ "REPLACE-ARRAY","si_replace_array"},
 {SYS_ "ROW-MAJOR-ASET","si_row_major_aset"},
-{EXT_ "RUN-PROGRAM","si_run_program"},
+{EXT_ "RUN-PROGRAM","ECL_NAME(si_run_program)"},
+{SYS_ "RUN-PROGRAM-INTERNAL","si_run_program_internal"},
 {EXT_ "TERMINATE-PROCESS","si_terminate_process"},
 {SYS_ "WAIT-FOR-ALL-PROCESSES","si_wait_for_all_processes"},
 {EXT_ "SAFE-EVAL","ECL_NAME(si_safe_eval)"},

src/c/unixsys.d

@@ -547,12 +547,13 @@ create_descriptor(cl_object stream, cl_object direction,
   }
 }
 #endif
-@(defun ext::run-program (command argv &key (input @':stream') (output @':stream')
-                          (error @':output') (wait @'t') (environ ECL_NIL)
-                          (if_input_does_not_exist ECL_NIL)
-                          (if_output_exists @':error')
-                          (if_error_exists  @':error')
-                          (external_format  @':default'))
+
+cl_object
+si_run_program_internal(cl_object command, cl_object argv,
+                        cl_object input, cl_object output, cl_object error,
+                        cl_object wait, cl_object environ, cl_object external_format) {
+
+  cl_env_ptr the_env = ecl_process_env();
   int parent_write = 0, parent_read = 0, parent_error = 0;
   int child_pid;
   cl_object pid, process;
@@ -561,37 +562,7 @@ create_descriptor(cl_object stream, cl_object direction,
   cl_object stream_error;
   cl_object exit_status = ECL_NIL;
   @
-  command = si_copy_to_simple_base_string(command);
-  argv = cl_mapcar(2, @'si::copy-to-simple-base-string', argv);
   process = make_external_process();
-
-  {
-    if (input == @'t')
-      input = ecl_symbol_value(@'*standard-input*');
-    if (ECL_STRINGP(input) || ECL_PATHNAMEP(input))
-      input = cl_open(5, input,
-                      @':direction', @':input',
-                      @':if-does-not-exist', if_input_does_not_exist,
-                      @':external-format', external_format);
-
-    if (output == @'t')
-      output = ecl_symbol_value(@'*standard-output*');
-    if (ECL_STRINGP(output) || ECL_PATHNAMEP(output))
-      output = cl_open(7, output,
-                       @':direction', @':output',
-                       @':if-exists', if_output_exists,
-                       @':if-does-not-exist', @':create',
-                       @':external-format', external_format);
-
-    if (error == @'t')
-      error = ecl_symbol_value(@'*error-output*');
-    if (ECL_STRINGP(error) || ECL_PATHNAMEP(error))
-      error = cl_open(7, error,
-                      @':direction', @':output',
-                      @':if-exists', if_error_exists,
-                      @':if-does-not-exist', @':create',
-                      @':external-format', external_format);
-  }
 #if defined(ECL_MS_WINDOWS_HOST)
   {
     BOOL ok;
@@ -603,16 +574,6 @@ create_descriptor(cl_object stream, cl_object direction,
     cl_object env_buffer;
     char *env = NULL;
 
-    /* Enclose each argument, as well as the file name
-       in double quotes, to avoid problems when these
-       arguments or file names have spaces */
-    command =
-      cl_format(4, ECL_NIL,
-                ecl_make_simple_base_string("~S~{ ~S~}", -1),
-                command, argv);
-    command = si_copy_to_simple_base_string(command);
-    command = ecl_null_terminated_base_string(command);
-
     if (!Null(environ)) {
       env_buffer = from_list_to_execve_argument(environ, NULL);
       env = env_buffer->base_string.self;
@@ -639,7 +600,12 @@ create_descriptor(cl_object stream, cl_object direction,
     st_info.hStdOutput = child_stdout;
     st_info.hStdError = child_stderr;
     ZeroMemory(&pr_info, sizeof(PROCESS_INFORMATION));
-    ok = CreateProcess(NULL, command->base_string.self,
+    /* Command is passed as is from argv. It is responsibility of
+       higher level interface to decide, whenever arguments should be
+       quoted or left as-is. */
+    argv = si_copy_to_simple_base_string(argv);
+    argv = ecl_null_terminated_base_string(argv);
+    ok = CreateProcess(NULL, argv->base_string.self,
                        NULL, NULL, /* lpProcess/ThreadAttributes */
                        TRUE, /* Inherit handles (for files) */
                        /*CREATE_NEW_CONSOLE |*/
@@ -672,7 +638,7 @@ create_descriptor(cl_object stream, cl_object direction,
   {
     int child_stdin, child_stdout, child_stderr;
     int pipe_fd[2];
-    argv = CONS(command, ecl_nconc(argv, ecl_list1(ECL_NIL)));
+    argv = ecl_nconc(argv, ecl_list1(ECL_NIL));
     argv = _ecl_funcall3(@'coerce', argv, @'vector');
 
     create_descriptor(input,  @':input',  &child_stdin,  &parent_write);
@@ -802,4 +768,4 @@ create_descriptor(cl_object stream, cl_object direction,
             ECL_NIL)
     exit_status
     process);
-  @)
+}

src/cmp/sysfun.lsp

@@ -939,6 +939,7 @@
     si::do-defsetf si::do-define-setf-method
     ;; process.lsp
     ext:system
+    ext:run-program
     ;; pprint.lsp
     pprint-fill copy-pprint-dispatch pprint-dispatch
     pprint-linear pprint-newline pprint-tab pprint-tabular

src/h/internal.h

@@ -527,6 +527,10 @@ extern void ecl_interrupt_process(cl_object process, cl_object function);
 
 /* unixsys.d */
 extern cl_object si_wait_for_all_processes _ECL_ARGS((cl_narg narg, ...));
+extern cl_object si_run_program_internal
+(cl_object command, cl_object argv,
+ cl_object input, cl_object output, cl_object error,
+ cl_object wait, cl_object environ, cl_object external_format);
 
 /*
  * Fake several ISO C99 mathematical functions if not available

src/lsp/process.lsp

@@ -46,3 +46,97 @@
                               :wait t :output nil :input nil
                               :error nil))))
 
+;;;
+;;; Wrapper around si_run_program call. Thanks to that C interface
+;;; isn't clobbered with lispisms. Ultimately we'd want to have as
+;;; little as possible in unixsys.d.
+;;;
+(defun run-program (command argv
+                    &key
+                      (input :stream)
+                      (output :stream)
+                      (error :output)
+                      (wait t)
+                      (environ nil)
+                      (if-input-does-not-exist nil)
+                      (if-output-exists :error)
+                      (if-error-exists :error)
+                      (external-format :default)
+                      #+windows (escape-arguments t))
+
+  (flet ((process-stream (which default &rest args)
+           (cond ((eql which t) default)
+                 ((or (stringp which) (pathnamep which))
+                  (apply #'open which :external-format external-format args))
+                 ;; this three cases are handled in create_descriptor (for now)
+                 ((eql which nil)     which)
+                 ((eql which :stream) which)
+                 ((streamp which)     which)
+                 ;; signal error as early as possible
+                 (T (error "Invalid ~S argument to EXT:RUN-PROGRAM" which))))
+
+         (prepare-args (args)
+           #-windows
+           (mapcar #'si:copy-to-simple-base-string args)
+           #+windows
+           (with-output-to-string (str)
+             (loop for (arg . rest) on args
+                do (if (and escape-arguments
+                            (find-if (lambda (c)
+                                       (find c '(#\Space #\Tab #\")))
+                                     arg))
+                       (escape-arg arg str)
+                       (princ arg str))
+                  (when rest
+                    (write-char #\Space str))))))
+
+    (setf input (process-stream input *standard-input*
+                                :direction :input
+                                :if-does-not-exist if-input-does-not-exist)
+          output (process-stream output *standard-output*
+                                 :direction :output
+                                 :if-exists if-output-exists)
+          error (if (eql error :output)
+                    :output
+                    (process-stream error *error-output*
+                                    :direction :output
+                                    :if-exists if-error-exists)))
+
+    (let ((progname (si:copy-to-simple-base-string command))
+          (args (prepare-args (cons command argv))))
+      (si:run-program-internal progname args
+                               input output error
+                               wait environ external-format))))
+
+
+
+#+windows
+(defun escape-arg (arg stream)
+  ;; Normally, #\\ doesn't have to be escaped But if #\"
+  ;; follows #\\, then they have to be escaped.  Do that by
+  ;; counting the number of consequent backslashes, and
+  ;; upon encoutering #\" immediately after them, output
+  ;; the same number of backslashes, plus one for #\"
+  (write-char #\" stream)
+  (loop with slashes = 0
+     for i below (length arg)
+     for previous-char = #\a then char
+     for char = (char arg i)
+     do
+       (case char
+         (#\"
+          (loop repeat slashes
+             do (write-char #\\ stream))
+          (write-string "\\\"" stream))
+         (t
+          (write-char char stream)))
+       (case char
+         (#\\
+          (incf slashes))
+         (t
+          (setf slashes 0)))
+     finally
+     ;; The final #\" counts too, but doesn't need to be escaped itself
+       (loop repeat slashes
+          do (write-char #\\ stream)))
+  (write-char #\" stream))