diff --git a/src/c/unixsys.d b/src/c/unixsys.d index e62e5fa2e..f8d9e09f3 100644 --- a/src/c/unixsys.d +++ b/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"); diff --git a/src/lsp/process.lsp b/src/lsp/process.lsp index c9392b61e..608c2b007 100644 --- a/src/lsp/process.lsp +++ b/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))) diff --git a/src/tests/ecl-tests.lisp b/src/tests/ecl-tests.lisp index e05953873..29777adf1 100644 --- a/src/tests/ecl-tests.lisp +++ b/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)))))) diff --git a/src/tests/normal-tests/embedding.lsp b/src/tests/normal-tests/embedding.lsp index a2ef7acb5..87909e9ba 100644 --- a/src/tests/normal-tests/embedding.lsp +++ b/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: diff --git a/src/tests/normal-tests/run-program.lsp b/src/tests/normal-tests/run-program.lsp index 46c6ee576..ef0da61ca 100644 --- a/src/tests/normal-tests/run-program.lsp +++ b/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 +#include +#include + +#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-λ")))) +