commit faaea200a6af5cbfb46fe09c1c3daa347ec4a66b
parent efe868a939ca8d32e4eead237481d3b93a126320
Author: Tomas Hlavaty <tom@logand.com>
Date: Sat, 1 Nov 2014 10:06:01 +0100
with-program-io added
Diffstat:
| M | os.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*)
