run-program: initial separation (logic / low-level interface)

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

@@ -541,12 +541,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;
@@ -555,37 +556,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;
@@ -602,7 +573,7 @@ create_descriptor(cl_object stream, cl_object direction,
        arguments or file names have spaces */
     command =
       cl_format(4, ECL_NIL,
-                ecl_make_simple_base_string("~S~{ ~S~}", -1),
+                ecl_make_simple_base_string("~A~{ ~A~}", -1),
                 command, argv);
     command = si_copy_to_simple_base_string(command);
     command = ecl_null_terminated_base_string(command);
@@ -796,4 +767,4 @@ create_descriptor(cl_object stream, cl_object direction,
             ECL_NIL)
     exit_status
     process);
-  @)
+}

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,98 @@
                               :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
+           (if (every #'simple-string-p args)
+               args
+               (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 ((args (prepare-args (cons command argv))))
+      (si:run-program-internal (car args) (cdr 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))