From 86faf44d2af47e73561640add4bf1e1716b6389e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Fri, 17 Feb 2017 15:21:31 +0100 Subject: [PATCH] run-program: initial separation (logic / low-level interface) --- src/c/symbols_list.h | 3 +- src/c/symbols_list2.h | 3 +- src/c/unixsys.d | 47 ++++----------------- src/h/internal.h | 4 ++ src/lsp/process.lsp | 95 +++++++++++++++++++++++++++++++++++++++++++ 5 files changed, 112 insertions(+), 40 deletions(-) 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 1c1c09b3c..da4c105a5 100644 --- a/src/c/unixsys.d +++ b/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); - @) +} 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..272d78199 100644 --- a/src/lsp/process.lsp +++ b/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))