ext:run-program: support unicode characters for the process name, arguments and environment

The encoding is determined by ext:*default-external-format* as usual.

src/c/unixsys.d

@@ -113,30 +113,24 @@ static cl_object
 from_list_to_execve_argument(cl_object l, char ***environp)
 {
   cl_object p;
-  cl_index i, j, total_size = 0, nstrings = 0;
-  cl_object buffer;
+  cl_index j, total_size = 0, nstrings = 0;
+  cl_object buffer, buffer_stream;
   char **my_environ;
   for (p = l; !Null(p); p = ECL_CONS_CDR(p)) {
     cl_object s = ECL_CONS_CAR(p);
     total_size += s->base_string.fillp + 1;
     nstrings++;
   }
-  /* Extra place for ending null */
-  total_size++;
-  buffer = ecl_alloc_simple_base_string(++total_size);
+  buffer = ecl_alloc_adjustable_base_string(total_size + 1);
   my_environ = ecl_alloc_atomic((nstrings + 1) * sizeof(char*));
-  for (j = i = 0, p = l; !Null(p); p = ECL_CONS_CDR(p)) {
+  buffer_stream = si_make_sequence_output_stream(1, buffer);
+  for (j = 0, p = l; !Null(p); p = ECL_CONS_CDR(p)) {
     cl_object s = ECL_CONS_CAR(p);
-    cl_index l = s->base_string.fillp;
-
-    my_environ[j++] = (char*)(buffer->base_string.self + i);
-    memcpy(buffer->base_string.self + i,
-           s->base_string.self,
-           l);
-    i += l;
-    buffer->base_string.self[i++] = 0;
+    my_environ[j++] = (char*)buffer->base_string.self + buffer->base_string.fillp;
+    si_do_write_sequence(s, buffer_stream, ecl_make_fixnum(0), ECL_NIL);
+    ecl_write_char(0, buffer_stream);
   }
-  buffer->base_string.self[i++] = 0;
+  ecl_write_char(0, buffer_stream);
   my_environ[j] = 0;
   if (environp) *environp = my_environ;
   return buffer;
@@ -361,15 +355,12 @@ si_run_program_inner(cl_object command, cl_object argv, cl_object my_environ, cl
   int parent_write = 0, parent_read = 0, parent_error = 0;
   cl_object pid, stream_read, exit_status;
 
-  command = si_copy_to_simple_base_string(command);
-
 #if defined(ECL_MS_WINDOWS_HOST)
   argv = cl_format(4, ECL_NIL,
                    @"~A~{ ~A~}",
                    command, argv);
-  argv = si_copy_to_simple_base_string(argv);
 #else
-  argv = CONS(command, cl_mapcar(2, @'si::copy-to-simple-base-string', argv));
+  argv = CONS(command, argv);
 #endif
 
   pid = si_spawn_subprocess(command, argv, my_environ, @':stream', @':stream', @':output');
@@ -402,13 +393,10 @@ si_spawn_subprocess(cl_object command, cl_object argv, cl_object my_environ,
                     cl_object input, cl_object output, cl_object error) {
 
   int parent_write = 0, parent_read = 0, parent_error = 0;
-  int child_pid;
   cl_object pid;
 
   /* my_environ is either a list or `:default'. */
-  if (ECL_LISTP(my_environ)) {
-    my_environ = cl_mapcar(2, @'si::copy-to-simple-base-string', my_environ);
-  } else if (!ecl_eql(my_environ, @':default')) {
+  if (!ECL_LISTP(my_environ) && !ecl_eql(my_environ, @':default')) {
     FEerror("Malformed :ENVIRON argument to EXT:RUN-PROGRAM.", 0);
   }
   
@@ -423,10 +411,14 @@ si_spawn_subprocess(cl_object command, cl_object argv, cl_object my_environ,
     cl_object env_buffer;
     char *env = NULL;
 
+    argv = si_string_to_octets(5, argv,
+                               @':null-terminate', ECL_T,
+                               @':element-type', @'base-char');
     if (ECL_LISTP(my_environ)) {
       env_buffer = from_list_to_execve_argument(my_environ, NULL);
-      env = env_buffer->base_string.self;
+      env = (char*)env_buffer->base_string.self;
     }
+
     create_descriptor(input,  @':input',  &child_stdin,  &parent_write);
     create_descriptor(output, @':output', &child_stdout, &parent_read);
     if (error == @':output') {
@@ -453,12 +445,10 @@ si_spawn_subprocess(cl_object command, cl_object argv, cl_object my_environ,
     /* 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. */
-    /* ecl_null_terminated_base_string(argv); */
-    ok = CreateProcess(NULL, argv->base_string.self,
+    ok = CreateProcess(NULL, (char*)argv->base_string.self,
                        NULL, NULL, /* lpProcess/ThreadAttributes */
                        TRUE, /* Inherit handles (for files) */
-                       /*CREATE_NEW_CONSOLE |*/
-                       0 /*(input == ECL_T || output == ECL_T || error == ECL_T ? 0 : CREATE_NO_WINDOW)*/,
+                       0, /* dwCreationFlags */
                        env, /* Inherit environment */
                        NULL, /* Current directory */
                        &st_info, /* Startup info */
@@ -488,25 +478,31 @@ si_spawn_subprocess(cl_object command, cl_object argv, cl_object my_environ,
   }
 #elif !defined(NACL) /* All POSIX but NaCL/pNaCL */
   {
+    cl_object command_encoded = si_string_to_octets(3, command, @':null-terminate', ECL_T);
+    int child_pid;
     int child_stdin, child_stdout, child_stderr;
     int saved_errno;
-    argv = ecl_nconc(argv, ecl_list1(ECL_NIL));
-    argv = _ecl_funcall3(@'coerce', argv, @'vector');
 
     create_descriptor(input,  @':input',  &child_stdin,  &parent_write);
     create_descriptor(output, @':output', &child_stdout, &parent_read);
     if (error == @':output') {
       child_stderr = child_stdout;
       parent_error = dup(parent_read);
-    }
-    else
+    } else {
       create_descriptor(error,  @':output', &child_stderr, &parent_error);
+    }
 
     child_pid = fork();
     if (child_pid == 0) {
       /* Child */
       int j;
-      void **argv_ptr = (void **)argv->vector.self.t;
+      cl_object p;
+      char **argv_ptr = ecl_alloc_atomic((ecl_length(argv) + 1) * sizeof(char*));
+      for (p = argv, j = 0; p != ECL_NIL; p = ECL_CONS_CDR(p)) {
+        cl_object arg = si_string_to_octets(3, ECL_CONS_CAR(p), @':null-terminate', ECL_T);
+        argv_ptr[j++] = (char*)arg->base_string.self;
+      }
+      argv_ptr[j] = NULL;
 
       if (parent_write) close(parent_write);
       if (parent_read)  close(parent_read);
@@ -516,25 +512,17 @@ si_spawn_subprocess(cl_object command, cl_object argv, cl_object my_environ,
       dup2(child_stdout, STDOUT_FILENO);
       dup2(child_stderr, STDERR_FILENO);
 
-      for (j = 0; j < argv->vector.fillp; j++) {
-        cl_object arg = argv->vector.self.t[j];
-        if (arg == ECL_NIL) {
-          argv_ptr[j] = NULL;
-        } else {
-          argv_ptr[j] = arg->base_string.self;
-        }
-      }
       if (ECL_LISTP(my_environ)) {
         char **pstrings;
         from_list_to_execve_argument(my_environ, &pstrings);
 #if defined(HAVE_ENVIRON)
         environ = pstrings;
-        execvp((char*)command->base_string.self, (char **)argv_ptr);
+        execvp((char*)command_encoded->base_string.self, argv_ptr);
 #else
-        execve((char*)command->base_string.self, (char **)argv_ptr, pstrings);
+        execve((char*)command_encoded->base_string.self, argv_ptr, pstrings);
 #endif
       } else {
-        execvp((char*)command->base_string.self, (char **)argv_ptr);
+        execvp((char*)command_encoded->base_string.self, argv_ptr);
       }
       /* at this point exec has failed */
       perror("exec");

src/lsp/process.lsp

@@ -143,19 +143,18 @@
                    (T (error "Invalid ~S argument to EXT:RUN-PROGRAM" which))))
            (prepare-args (args)
              #-windows
-             (mapcar #'si:copy-to-simple-base-string args)
+	          args
              #+windows
-             (si:copy-to-simple-base-string
-              (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))))))
+             (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)))))
            (null-stream (direction)
              (open #-windows "/dev/null"
                    #+windows "nul"
@@ -174,8 +173,7 @@
                                  :input)))
                (:virtual-stream :stream)
                (otherwise stream))))
-    (let ((progname (si:copy-to-simple-base-string command))
-          (args (prepare-args (cons command argv)))
+    (let ((args (prepare-args (cons command argv)))
           (process (make-external-process))
           (process-input (process-stream input
                                          :direction :input
@@ -191,7 +189,7 @@
           pid parent-write parent-read parent-error)
 
       (multiple-value-setq (pid parent-write parent-read parent-error)
-        (si:spawn-subprocess progname args environ
+        (si:spawn-subprocess command args environ
                              (verify-stream process-input :input)
                              (verify-stream process-output :output)
                              (verify-stream process-error :error)))

src/tests/ecl-tests.lisp

@@ -134,3 +134,50 @@ as a second value."
     (double-float double-float-epsilon)
     (long-float long-float-epsilon)
     (rational 0)))
+
+(defun test-C-program (c-code &key capture-output (args '()) (environ '()))
+  (ensure-directories-exist "tmp/")
+  (with-open-file (s "tmp/ecl-aux.c" :direction :output :if-exists :supersede
+				     :if-does-not-exist :create)
+    (princ c-code s))
+  (c::compiler-cc "tmp/ecl-aux.c" "tmp/ecl-aux.o")
+  (c::linker-cc "tmp/ecl-aux.exe" '("tmp/ecl-aux.o"))
+  (let ((environment
+          (append #+windows (list (format nil "PATH=~a;~a"
+                                          (ext:getenv "PATH")
+                                          c::*ecl-library-directory*))
+                  #+cygwin (list (format nil "PATH=~a:~a"
+                                         (ext:getenv "PATH")
+                                         c::*ecl-library-directory*))
+                  #-(or windows cygwin) (list (format nil "LD_LIBRARY_PATH=~a:~a"
+                                                      (ext:getenv "LD_LIBRARY_PATH")
+                                                      c::*ecl-library-directory*))
+		  environ
+                  (ext:environ))))
+    (ecase capture-output
+      ((nil)
+       (multiple-value-bind (stream return-code)
+           (si::run-program "tmp/ecl-aux.exe" args
+                            :output t :error t
+                            :environ environment)
+         (declare (ignore stream))
+         (zerop return-code)))
+      ((string :string)
+       (multiple-value-bind (in return-code)
+           (si::run-program "tmp/ecl-aux.exe" args :output :stream :error t
+						   :environ environment)
+	 (values return-code
+		 (with-output-to-string (s)
+                   (loop with line
+			 do (setf line (read-line in nil))
+		            (unless line (return))
+		            (write-line line s))))))
+      ((t forms :forms)
+       (do* ((all '())
+             (x t)
+             (in (si::run-program "tmp/ecl-aux.exe" args :output :stream
+							 :environ environment)))
+            ((null in) all)
+         (setf x (ignore-errors (read in nil nil)))
+         (unless x (return all))
+         (push x all))))))

src/tests/normal-tests/embedding.lsp

@@ -9,51 +9,6 @@
 
 (suite 'emb)
 
-(defun test-C-program (c-code &key capture-output)
-  (ensure-directories-exist "tmp/")
-  (with-open-file (s "tmp/ecl-aux.c" :direction :output :if-exists :supersede
-                     :if-does-not-exist :create)
-    (princ c-code s))
-  (c::compiler-cc "tmp/ecl-aux.c" "tmp/ecl-aux.o")
-  (c::linker-cc "tmp/ecl-aux.exe" '("tmp/ecl-aux.o"))
-  (let ((environment 
-         (append #+windows (list (format nil "PATH=~a;~a"
-                                         (ext:getenv "PATH")
-                                         c::*ecl-library-directory*))
-                 #+cygwin (list (format nil "PATH=~a:~a"
-                                        (ext:getenv "PATH")
-                                        c::*ecl-library-directory*))
-                 #-(or windows cygwin) (list (format nil "LD_LIBRARY_PATH=~a:~a"
-                                                     (ext:getenv "LD_LIBRARY_PATH")
-                                                     c::*ecl-library-directory*))
-                 (ext:environ))))
-    (ecase capture-output
-      ((nil)
-       (multiple-value-bind (stream return-code)
-           (si::run-program "tmp/ecl-aux.exe" '()
-                            :output t :error t
-                            :environ environment)
-         (declare (ignore stream))
-         (zerop return-code)))
-      ((string :string)
-       (with-output-to-string (s)
-         (let ((in (si::run-program "tmp/ecl-aux.exe" '() :output :stream
-                                    :environ environment))
-               line)
-           (loop
-            (setf line (read-line in nil))
-            (unless line (return))
-            (write-line line s)))))
-      ((t forms :forms)
-       (do* ((all '())
-             (x t)
-             (in (si::run-program "tmp/ecl-aux.exe" '() :output :stream
-                                  :environ environment)))
-            ((null in) all)
-         (setf x (ignore-errors (read in nil nil)))
-         (unless x (return all))
-         (push x all))))))
-
 ;;; Date: 21/06/2006 (goffioul)
 ;;; Fixed: 23/06/2006 (juanjo)
 ;;; Description:

src/tests/normal-tests/run-program.lsp

@@ -193,3 +193,57 @@
   ;; is granted (before the release). Program to use is `set', not
   ;; sure if it is part of Windows shell or something we can run.
   (is (null "IMPLEMENT ME!")))
+
+;;; Date: 2022-10-22
+;;; From: Marius Gerbershagen
+;;; Description:
+;;;
+;;;     Check that run-program works correctly with different
+;;;     encodings
+;;;
+(test run-program-encoding
+  (let* ((skeleton "
+#include <stdio.h>
+#include <string.h>
+#include <stdlib.h>
+
+#define expected_length ~S
+
+int main (int argc, char **argv) {
+  char expected[expected_length+1] = {~{~S,~}};
+  if (argc != 2) {
+    return 1;
+  }
+  if (strlen(argv[1]) != expected_length) {
+    return 2;
+  }
+  if (strcmp(argv[1], expected) != 0) {
+    return 3;
+  }
+  if (strcmp(getenv(\"ECLTESTVAR\"), expected) != 0) {
+    return 4;
+  }
+  printf(\"%s\", argv[1]);
+  return 0;
+}"))
+    (flet ((test-with-encoding (encoding test-string)
+             (let* ((ext:*default-external-format* encoding)
+                    (encoded-test-string
+                     (coerce (ext:string-to-octets test-string
+  				                                       :null-terminate t
+  				                                       :external-format encoding)
+  	                          'list)))
+               (multiple-value-bind (return-code output)
+                   (test-C-program (format nil skeleton
+  			                                  (1- (length encoded-test-string))
+  			                                  encoded-test-string)
+  		                             :args (list test-string)
+  		                             :environ (list (concatenate 'string "ECLTESTVAR=" test-string))
+  		                             :capture-output :string)
+                 (is (zerop return-code))
+                 (is (string= test-string (delete #\newline output)))))))
+      (test-with-encoding ext:*default-external-format* "default-äöüλ🙋")
+      (test-with-encoding :utf8 "utf8-äöüλ🙋")
+      (test-with-encoding :latin-1 "latin-1-äöü")
+      (test-with-encoding :greek "greek-λ"))))
+