diff --git a/src/c/symbols_list.h b/src/c/symbols_list.h index 7ff4aca99..859121c5b 100755 --- a/src/c/symbols_list.h +++ b/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}, diff --git a/src/c/symbols_list2.h b/src/c/symbols_list2.h index 8141dcde3..926c6df87 100644 --- a/src/c/symbols_list2.h +++ b/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)"}, diff --git a/src/c/unixsys.d b/src/c/unixsys.d index 4e9f98749..cabc76723 100644 --- a/src/c/unixsys.d +++ b/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); - @) +} diff --git a/src/cmp/sysfun.lsp b/src/cmp/sysfun.lsp index d187439c5..61a37a6cc 100644 --- a/src/cmp/sysfun.lsp +++ b/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 diff --git a/src/h/internal.h b/src/h/internal.h index 7351e1887..9a512c0cd 100755 --- a/src/h/internal.h +++ b/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 diff --git a/src/lsp/process.lsp b/src/lsp/process.lsp index 467905b64..4cc006262 100644 --- a/src/lsp/process.lsp +++ b/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))