cl-rw

Layered streams for Common Lisp
git clone https://logand.com/git/cl-rw.git/
Log | Files | Refs

commit faaea200a6af5cbfb46fe09c1c3daa347ec4a66b
parent efe868a939ca8d32e4eead237481d3b93a126320
Author: Tomas Hlavaty <tom@logand.com>
Date:   Sat,  1 Nov 2014 10:06:01 +0100

with-program-io added

Diffstat:
Mos.lisp | 271++++++++++++++++++++++++++++++++++++++++++-------------------------------------
1 file changed, 143 insertions(+), 128 deletions(-)

diff --git a/os.lisp b/os.lisp @@ -29,141 +29,156 @@ :md5sum :run-command :sha1sum + :with-program-io :with-program-output :with-temporary-file)) (in-package :rw.os) -(defun make-program (input output cmd args) - #-(or ccl ecl sbcl cmu #+nil clisp) - (error "RW.OS:MAKE-PROGRAM not ported") - #+ccl - (let ((p (ccl:run-program cmd - args - :input input - :output output - :error nil - :sharing :external - :wait nil - ;; TODO make bivalent - ;;:character-p t - ;;:element-type '(unsigned-byte 8) - ))) - (let ((status (ccl:external-process-status p))) - (if input - (assert (eq :running status)) - (assert (member status '(:running :exited))))) - (lambda (msg) - (ecase msg - (:status-and-code (ccl:external-process-status p)) - (:input-stream (ccl:external-process-input-stream p)) - (:output-stream (ccl:external-process-output-stream p)) - (:wait (ccl::external-process-wait p)) - (:close (flet ((finish (x) (when x (close x)))) - (finish (ccl:external-process-output-stream p)) - (finish (ccl:external-process-input-stream p)) - (finish (ccl:external-process-error-stream p))))))) - #+ecl - (multiple-value-bind (io x p) - (ext:run-program cmd - args - :input input - :output output - :error nil - :wait (not (or input output))) ;; TODO why wait=nil + wait call doesnt work? - (declare (ignore x)) - (let ((status (ext:external-process-status p))) - (if input - (assert (eq :running status)) - (assert (member status '(:running :exited))))) - (lambda (msg) - (ecase msg - (:status-and-code (ext:external-process-status p)) - (:input-stream io) - (:output-stream io) - (:wait (ext:external-process-wait p)) - (:close (when io (close io)))))) ;; TODO is this the right thing to close process? - #+sbcl - (let ((p (sb-ext:run-program cmd - args - :input input - :output output - :error nil - :wait nil - :search t))) - (let ((status (sb-ext:process-status p))) - (if input - (assert (eq :running status)) - (assert (member status '(:running :exited))))) - (lambda (msg) - (ecase msg - (:status-and-code (sb-ext:process-status p)) - (:input-stream (sb-ext:process-input p)) - (:output-stream (sb-ext:process-output p)) - (:wait (sb-ext:process-wait p)) - (:close (sb-ext:process-close p))))) - #+cmu - (let ((p (ext:run-program cmd - args - :input input - :output output - :error nil - :wait nil))) - (let ((status (sb-ext:process-status p))) - (if input - (assert (eq :running status)) - (assert (member status '(:running :exited))))) - (lambda (msg) - (ecase msg - (:status-and-code (sb-ext:process-status p)) - (:input-stream (sb-ext:process-input p)) - (:output-stream (sb-ext:process-output p)) - (:wait (sb-ext:process-wait p)) - (:close (ext:process-close p))))) - ;;#+clisp - #+nil - (let ((p (ext:run-program cmd - :arguments args - :input input - :output output - :error nil - :wait nil))) - (let ((status :running)) ;; TODO - (if input - (assert (eq :running status)) - (assert (member status '(:running :exited))))) - (lambda (msg) - (ecase msg - (:status-and-code (values :running 0)) ;; TODO - (:input-stream p) - (:output-stream p) - (:wait (ext:process-wait p)) ;; TODO - (:close (close p)))))) - -(defun call-with-program-output (output cmd args error-plist fn) - (let ((p (make-program nil output cmd args))) - (unwind-protect - (let ((z (if output - (funcall fn (funcall p :output-stream)) - t))) - (funcall p :wait) - (multiple-value-bind (status code) (funcall p :status-and-code) - (assert (member status '(:running :exited))) - (if (member code '(nil 0)) - z - (unless (eq t error-plist) - (error (format nil "~a error ~d: ~a ~s" cmd code - (when error-plist - (or (cdr (assoc code error-plist)) "")) - args)))))) - (funcall p :close)))) - -(defun run-command (cmd &optional args error-plist) - (call-with-program-output nil cmd args error-plist nil)) +(defun make-program (input output cmd args error-plist) + (flet ((fail (code) + (unless (eq t error-plist) + (error (format nil "~a error ~d: ~a ~s" cmd code + (when error-plist + (or (cdr (assoc code error-plist)) "")) + args))))) + #-(or ccl ecl sbcl cmu #+nil clisp) + (error "RW.OS:MAKE-PROGRAM not ported") + #+ccl + (let ((p (ccl:run-program cmd + args + :input input + :output output + :error nil + :sharing :external + :wait nil + ;; TODO make bivalent + ;;:character-p t + ;;:element-type '(unsigned-byte 8) + ))) + (let ((status (ccl:external-process-status p))) + (if input + (assert (eq :running status)) + (assert (member status '(:running :exited))))) + (lambda (msg) + (ecase msg + (:fail (fail (nth-value 2 (ccl:external-process-status p)))) + (:status-and-code (ccl:external-process-status p)) + (:streams (values (ccl:external-process-input-stream p) + (ccl:external-process-output-stream p))) + (:wait (ccl::external-process-wait p)) + (:close (flet ((finish (x) (when x (close x)))) + (finish (ccl:external-process-output-stream p)) + (finish (ccl:external-process-input-stream p)) + (finish (ccl:external-process-error-stream p))))))) + #+ecl + (multiple-value-bind (io x p) + (ext:run-program cmd + args + :input input + :output output + :error nil + :wait (not (or input output))) ;; TODO why wait=nil + wait call doesnt work? + (declare (ignore x)) + (let ((status (ext:external-process-status p))) + (if input + (assert (eq :running status)) + (assert (member status '(:running :exited))))) + (lambda (msg) + (ecase msg + (:fail (fail (nth-value 2 (ext:external-process-status p)))) + (:status-and-code (ext:external-process-status p)) + (:streams (values io io)) + (:wait (ext:external-process-wait p)) + (:close (when io (close io)))))) ;; TODO is this the right thing to close process? + #+sbcl + (let ((p (sb-ext:run-program cmd + args + :input input + :output output + :error nil + :wait nil + :search t))) + (let ((status (sb-ext:process-status p))) + (if input + (assert (eq :running status)) + (assert (member status '(:running :exited))))) + (lambda (msg) + (ecase msg + (:fail (fail (sb-ext:process-exit-code p))) + (:status-and-code (values (sb-ext:process-status p) + (sb-ext:process-exit-code p))) + (:streams (values (sb-ext:process-input p) + (sb-ext:process-output p))) + (:wait (sb-ext:process-wait p)) + (:close (sb-ext:process-close p))))) + #+cmu + (let ((p (ext:run-program cmd + args + :input input + :output output + :error nil + :wait nil))) + (let ((status (sb-ext:process-status p))) + (if input + (assert (eq :running status)) + (assert (member status '(:running :exited))))) + (lambda (msg) + (ecase msg + (:fail (fail (nth-value 2 (sb-ext:process-status p)))) + (:status-and-code (sb-ext:process-status p)) + (:streams (values (sb-ext:process-input p) + (sb-ext:process-output p))) + (:wait (sb-ext:process-wait p)) + (:close (ext:process-close p))))) + ;;#+clisp + #+nil + (let ((p (ext:run-program cmd + :arguments args + :input input + :output output + :error nil + :wait nil))) + (let ((status :running)) ;; TODO + (if input + (assert (eq :running status)) + (assert (member status '(:running :exited))))) + (lambda (msg) + (ecase msg + (:fail (fail 0)) ;; TODO + (:status-and-code (values :running 0)) ;; TODO + (:streams (values p p)) + (:wait (ext:process-wait p)) ;; TODO + (:close (close p))))))) + +(defun call-with-program (program fn) + (unwind-protect + (let ((z (multiple-value-bind (input output) + (funcall program :streams) + (cond + ((and input output) + (funcall fn input output)) + ((or input output) + (funcall fn (or input output))) + (t t))))) + (funcall program :wait) + (multiple-value-bind (status code) + (funcall program :status-and-code) + (assert (member status '(:running :exited))) + (if (member code '(nil 0)) + z + (funcall program :fail)))) + (funcall program :close))) + +(defmacro with-program-io ((ivar ovar program) &body body) + `(call-with-program ,program (lambda (,ivar ,ovar) ,@body))) (defmacro with-program-output ((var cmd &optional args error-plist) &body body) - `(call-with-program-output :stream ,cmd ,args ,error-plist - (lambda (,var) ,@body))) + `(call-with-program (make-program nil :stream ,cmd ,args ,error-plist) + (lambda (,var) ,@body))) + +(defun run-command (cmd &optional args error-plist) + (call-with-program (make-program nil nil cmd args error-plist) nil)) (defun %namestring (x) ;; TODO why not NAMESTRING directly usable? (with-output-to-string (*standard-output*)