From ce111619cf2a370ed4ae77ec8ee3fc154b9cef9a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Sat, 18 Feb 2017 20:31:03 +0100 Subject: [PATCH] run-program: provide simple interface run-program-inner Both run-program and run-program-inner work on same interface si:spawn-subprocess. --- src/c/unixsys.d | 63 +++++--------------------------------- src/cmp/cmpos-features.lsp | 18 +++++------ src/cmp/proclamations.lsp | 4 +++ src/h/internal.h | 10 +++--- src/lsp/process.lsp | 48 ++++++++++++++++++++++++++--- 5 files changed, 69 insertions(+), 74 deletions(-) diff --git a/src/c/unixsys.d b/src/c/unixsys.d index cedcdafb3..251d3c192 100644 --- a/src/c/unixsys.d +++ b/src/c/unixsys.d @@ -626,13 +626,9 @@ si_spawn_subprocess(cl_object command, cl_object argv, cl_object environ, } else { pid = ecl_make_fixnum(child_pid); } - set_external_process_pid(process, pid); { - /* This guarantees that the child process does not exit - * before we have created the process structure. If we do not - * do this, the SIGPIPE signal may arrive before - * set_external_process_pid() and our call to external-process-wait - * down there may block indefinitely. */ + /* This guarantees that the child process does not exit before + * we have created the process structure. */ char sync[1]; close(pipe_fd[0]); while (write(pipe_fd[1], sync, 1) < 1) { @@ -647,57 +643,12 @@ si_spawn_subprocess(cl_object command, cl_object argv, cl_object environ, } #else /* NACL */ { - FElibc_error("ext::run-program not implemented",1); + FElibc_error("ext::run-program-inner not implemented",1); @(return ECL_NIL); } #endif - if (Null(pid)) { - if (parent_write) close(parent_write); - if (parent_read) close(parent_read); - if (parent_error) close(parent_error); - parent_write = 0; - parent_read = 0; - parent_error = 0; - FEerror("Could not spawn subprocess to run ~S.", 1, command); - } - if (parent_write > 0) { - stream_write = ecl_make_stream_from_fd(command, parent_write, - ecl_smm_output, 8, - ECL_STREAM_DEFAULT_FORMAT, - external_format); - } else { - parent_write = 0; - stream_write = cl_core.null_stream; - } - if (parent_read > 0) { - stream_read = ecl_make_stream_from_fd(command, parent_read, - ecl_smm_input, 8, - ECL_STREAM_DEFAULT_FORMAT, - external_format); - } else { - parent_read = 0; - stream_read = cl_core.null_stream; - } - if (parent_error > 0) { - stream_error = ecl_make_stream_from_fd(command, parent_error, - ecl_smm_input, 8, - ECL_STREAM_DEFAULT_FORMAT, - external_format); - } else { - parent_error = 0; - stream_error = cl_core.null_stream; - } - ecl_structure_set(process, @'ext::external-process', 1, input); - ecl_structure_set(process, @'ext::external-process', 2, output); - ecl_structure_set(process, @'ext::external-process', 3, error); - - if (!Null(wait)) { - exit_status = si_external_process_wait(2, process, ECL_T); - exit_status = ecl_nth_value(the_env, 1); - } - @(return ((parent_read || parent_write)? - cl_make_two_way_stream(stream_read, stream_write) : - ECL_NIL) - exit_status - process); + @(return pid + ecl_make_fixnum(parent_write) + ecl_make_fixnum(parent_read) + ecl_make_fixnum(parent_error)) } diff --git a/src/cmp/cmpos-features.lsp b/src/cmp/cmpos-features.lsp index 7e956a27e..6ea89df53 100644 --- a/src/cmp/cmpos-features.lsp +++ b/src/cmp/cmpos-features.lsp @@ -21,16 +21,14 @@ while line collect line))) (handler-case - (multiple-value-bind (stream process) - (ext:run-program command args :input nil :output :stream :error :output) - (let ((lines (collect-lines stream))) - (cond ((null file) - lines) - ((probe-file file) - (with-open-file (s file :direction :input) - (collect-lines s))) - (t - (warn "Unable to find file ~A" file))))) + (let ((lines (collect-lines (si:run-program-inner command args nil)))) + (cond ((null file) + lines) + ((probe-file file) + (with-open-file (s file :direction :input) + (collect-lines s))) + (t + (warn "Unable to find file ~A" file)))) (error (c) (format t "~&;;; Unable to execute program ~S~&;;; Condition~&;;; ~A" command c))))) diff --git a/src/cmp/proclamations.lsp b/src/cmp/proclamations.lsp index 9fe66b5c5..42813d01f 100644 --- a/src/cmp/proclamations.lsp +++ b/src/cmp/proclamations.lsp @@ -1329,6 +1329,10 @@ (values (or null two-way-stream) (or null integer) ext:external-process)) +(proclamation si:run-program-inner (string (or list string) list) + (values two-way-stream integer)) +(proclamation si:spawn-subprocess (string (or list string) list t t t) + (values (or null integer) fixnum fixnum fixnum)) (proclamation ext:terminate-process (t &optional gen-bool) null) (proclamation ext:make-weak-pointer (t) ext:weak-pointer :no-side-effects) diff --git a/src/h/internal.h b/src/h/internal.h index 7f18783a8..f37106713 100755 --- a/src/h/internal.h +++ b/src/h/internal.h @@ -526,10 +526,12 @@ extern cl_object mp_get_rwlock_write_wait(cl_object lock); extern void ecl_interrupt_process(cl_object process, cl_object function); /* unixsys.d */ -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); +extern cl_object si_run_program_inner +(cl_object command, cl_object argv, cl_object environ); + +extern cl_object si_spawn_subprocess +(cl_object command, cl_object argv, cl_object environ, + cl_object input, cl_object output, cl_object error); /* * Fake several ISO C99 mathematical functions if not available diff --git a/src/lsp/process.lsp b/src/lsp/process.lsp index 60e44d601..15d7533c6 100644 --- a/src/lsp/process.lsp +++ b/src/lsp/process.lsp @@ -104,12 +104,34 @@ :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)))) + (args (prepare-args (cons command argv))) + (process (make-external-process))) + (multiple-value-bind (pid parent-write parent-read parent-error) + (si:spawn-subprocess progname args environ input output error) + (unless pid + (when parent-write (ff-close parent-write)) + (when parent-read (ff-close parent-read)) + (when parent-error (ff-close parent-error)) + (error "Could not spawn subprocess to run ~S." progname)) + (let ((stream-write + (when (< 0 parent-write) + (make-output-stream-from-fd progname parent-write external-format))) + (stream-read + (when (< 0 parent-read) + (make-input-stream-from-fd progname parent-read external-format))) + (stream-error + (when (< 0 parent-error) + (make-input-stream-from-fd progname parent-error external-format)))) + (setf (external-process-pid process) pid + (external-process-input process) (or stream-write (null-stream)) + (external-process-output process) (or stream-read (null-stream)) + (external-process-error-stream process) (or stream-error (null-stream))) + (values (make-two-way-stream (external-process-output process) + (external-process-input process)) + (when wait (nth-value 1 (si:external-process-wait process t))) + process)))))) #+windows (defun escape-arg (arg stream) @@ -141,3 +163,21 @@ (loop repeat slashes do (write-char #\\ stream))) (write-char #\" stream)) + + +;;; low level interface to descriptors +(defun make-input-stream-from-fd (name fd external-format) + (ffi:c-inline (name fd external-format) (:string :int :object) :object + "ecl_make_stream_from_fd(#0, #1, ecl_smm_input, 8, ECL_STREAM_DEFAULT_FORMAT, #2)" + :one-liner t)) + +(defun make-output-stream-from-fd (name fd external-format) + (ffi:c-inline (name fd external-format) (:string :int :object) :object + "ecl_make_stream_from_fd(#0, #1, ecl_smm_output, 8, ECL_STREAM_DEFAULT_FORMAT, #2)" + :one-liner t)) + +(defun null-stream () + (ffi:c-inline () () :object "cl_core.null_stream" :one-liner t :side-effects nil)) + +(ffi:defentry ff-close (:int) (:int "close") :no-interrupts t) +