Commits (4)
......@@ -168,16 +168,6 @@ that exports the following macros and functions:
returning as a list of one string per line (stripped of line-ending)
what the inferior command sent to its standard output.
* `*BACKEND*`
a variable to choose between backends. Currently, only supported are
`:AUTO` (the default, using uiop:run-program, and
spawning a shell unless it's a simple process), and
`:SBCL` (only available on `#+(and sbcl sb-thread unix)`,
doesn't need a shell but has some limitations such as
only supporting redirection of stdin, stdout, stderr),
and is not recommended (and not actively supported at the moment).
The PROCESS-SPEC mini-language
------------------------------
......
;;; -*- mode: lisp -*-
(module
(:fullname "inferior-shell"
:author ("Francois-Rene Rideau")
:maintainer "Francois-Rene Rideau"
:licence "MIT" ;; MIT-style license. See LICENSE
:description "spawn local or remote processes and shell pipes"
:long-description "an eXtensible Component Verifier and Builder for Lisp.
XCVB provides a scalable system to build large software in Lisp, featuring
deterministic separate compilation and enforced locally-declared dependencies."
:build-depends-on
("/asdf" "/fare-utils" "/fare-mop"
"/fare-quasiquote" ;; includes fare-quasiquote-readtable, fare-quasiquote-optima
(:asdf "cl-ppcre") "/lambda-reader")
:depends-on
("pkgdcl" "process-spec" "utilities" "macros" "host" "run")
:supersedes-asdf ("inferior-shell")))
#+xcvb (module (:depends-on ("pkgdcl")))
(in-package :inferior-shell)
(defparameter *current-host-names* '("localhost"))
......
......@@ -2,12 +2,12 @@
#-asdf3 (error "inferior-shell requires ASDF 3.0.3 or later")
(defsystem "inferior-shell"
:version "2.0.3.4"
:version "2.0.4"
:description "spawn local or remote processes and shell pipes"
:author "Francois-Rene Rideau"
:license "MIT"
:depends-on ((:version "asdf" "3.0.3") ; input and error-output redirection
#+sbcl (:require "sb-posix")
(:feature :sbcl (:require "sb-posix"))
"alexandria" "optima"
"fare-utils" "fare-quasiquote-extras" "fare-mop")
:around-compile "uiop:call-with-safe-io-syntax" ;; ensures that quasiquote syntax doesn't escape
......@@ -17,11 +17,7 @@
(:file "utilities" :depends-on ("pkgdcl"))
(:file "macros" :depends-on ("pkgdcl"))
(:file "host" :depends-on ("pkgdcl"))
(:file "run" :depends-on ("process-spec" "macros"))
;; Disable these experiments for now:
#+(or) (:file "run-generic" :depends-on ("process-spec" "macros"))
#+(or) (:file "run-sbcl" :depends-on ("process-spec" "macros" "run-generic")
:if-feature (:and :sbcl :sb-thread :unix)))
(:file "run" :depends-on ("process-spec" "macros")))
:in-order-to ((test-op (load-op "inferior-shell/test")))
:perform (test-op (o s) ;; symbol-call will only work if loaded with ASDF3
(symbol-call :inferior-shell-test :test-suite)))
......
#+xcvb (module (:depends-on ("pkgdcl")))
(in-package :inferior-shell)
;;--- TODO: move these to FARE-UTILS ?
......
#+xcvb (module ())
(uiop/package:define-package :inferior-shell
(:mix :fare-utils :uiop :alexandria)
(:use :cl :optima :named-readtables :fare-mop)
......@@ -13,5 +11,4 @@
#:redirection #:file-redirection #:fd-redirection #:close-redirection
#:! #:- #:< #:> #:<> #:>! #:>> #:>>! #:<& #:>& #:>&! #:>>&!
#:>& #:>> #:>>& #:pipe #:or #:and #:progn #:fork
#:zglobcmd #:zglob
#:*backend*))
#:zglobcmd #:zglob))
#+xcvb (module (:depends-on ("pkgdcl")))
(cl:in-package :inferior-shell)
(in-readtable :fare-quasiquote)
......
#+xcvb (module (:depends-on ("macros" "process-spec")))
(in-package :inferior-shell)
(defgeneric process-redirection (redirection input output error))
(defgeneric generic-run-spec (spec input output error predicate rest resume))
(defgeneric process-result (result))
;; list of streams to close when finished
(defvar *streams-to-close* nil)
(defun close-streams ()
(mapcar #'close *streams-to-close*)
(setq *streams-to-close* nil))
;; interface to process a list of redirections and return redirected
;; input, output and error streams
(defun process-redirections (redirections input output error)
(let ((r-input input)
(r-output output)
(r-error error))
(loop :for r :in redirections
:do (multiple-value-setq (r-input r-output r-error)
(process-redirection r r-input r-output r-error)))
(values r-input r-output r-error)))
(defmethod process-redirection ((r file-redirection) input output error)
(with-slots (fd pathname flags) r
(let ((stream (apply #'open pathname :direction (car flags) (cdr flags))))
(push stream *streams-to-close*)
(ecase fd
(0 (values stream output error))
(1 (values input stream error))
(2 (values input output stream))))))
(defmethod process-redirection ((r fd-redirection) input output error)
(with-slots (old-fd new-fd) r
(ecase new-fd
(1 (ecase old-fd
(0 (values input input error))
(2 (values input error :output))))
(2 (ecase old-fd
(0 (values input output input))
(1 (values input output :output)))))))
(defmethod process-redirection ((r close-redirection) input output error)
(with-slots (old-fd) r
(case old-fd
(0 (values nil output error))
(1 (values input nil error))
(2 (values input output error))
(otherwise (error "Can't close arbitrary fd: ~A" old-fd)))))
(defclass result ()
((process
; :type sb-impl::process
:initform nil :initarg :process :reader result-process)
;; thread slurping output
(thread
; :type sb-thread:thread
:initform nil
:initarg :thread :reader result-thread)
;; predicate to determine whether to run the rest of the sequence
;; called with the process object, and expected to return t or nil
(predicate
:type (or function null) :initform nil
:initarg :predicate :accessor result-predicate)
(rest
:type list :initform nil
:initarg :rest :accessor result-rest)
(input
:initform nil :initarg :input :accessor result-input)
(output
:initform nil :initarg :output :accessor result-output)
(error
:initform nil :initarg :error :accessor result-error)
(resume
:initform nil :initarg :resume :accessor result-resume)))
(defmethod print-object ((result result) stream)
(print-unreadable-object (result stream :type t)
(with-slots (process predicate rest) result
(format stream "~A ~A ~A" process predicate rest))))
(defmethod generic-run-spec ((spec or-spec) input output error predicate rest resume)
(declare (ignorable predicate rest))
(list (make-instance 'result :predicate #'result-or :input input :output output
:error error :rest (sequence-processes spec) :resume resume)))
(defmethod generic-run-spec ((spec and-spec) input output error predicate rest resume)
(declare (ignorable predicate rest))
(list (make-instance 'result :predicate #'result-and :input input :output output
:error error :rest (sequence-processes spec) :resume resume)))
(defmethod generic-run-spec ((spec progn-spec) input output error predicate rest resume)
(declare (ignorable predicate rest))
(list (make-instance 'result :predicate nil :input input :output output
:error error :rest (sequence-processes spec) :resume resume)))
(defmethod generic-run-spec ((spec fork-spec) input output error predicate rest resume)
(declare (ignorable predicate rest resume))
(loop :for p :in (sequence-processes spec) :do
(generic-run-spec p input output error nil nil nil))
nil)
(defmethod generic-run-spec ((spec pipe-spec) input output error predicate rest resume)
(declare (ignorable predicate rest resume))
(let ((processes (sequence-processes spec))
(r-input)
(r-output)
(first t)
(results)
(*streams-to-close* nil))
(loop :for (p . rest) :on processes :do
(cond
((and (listp rest) first) ;; first process
(setf first nil)
(multiple-value-setq (r-output r-input) (make-pipe))
(push r-input *streams-to-close*)
(push r-output *streams-to-close*)
(push (generic-run-spec p input r-input error nil nil nil) results))
((null rest) ;; last process
(push (generic-run-spec p r-output output error nil nil nil) results))
(t ;; middle of the pipeline
(multiple-value-bind (left right) (make-pipe)
(push left *streams-to-close*)
(push right *streams-to-close*)
(push (generic-run-spec p r-output right error nil nil nil) results)
(setf r-output left)))))
(close-streams)
results))
(defmethod process-result ((r result))
(labels ((eval-pred (pred rest)
(and (consp rest)
(or (null pred)
(and (functionp pred) (funcall pred r))))))
(with-slots (process predicate rest input output error resume) r
(when process
(process-wait process))
(if (or (not process)
(eval-pred predicate rest))
(let ((next (car rest)))
(generic-run-spec next input output error predicate (cdr rest)
(if (typep next 'sequence-spec)
r
resume)))
(when resume
(with-slots (predicate rest resume input output error) resume
(when (and (consp rest) (consp (cdr rest)))
(let ((remainder (cdr rest)))
(when (eval-pred predicate remainder)
(generic-run-spec (second rest) input output error
predicate (cddr rest) resume))))))))))
(defun process-result-list (rl)
(if (listp rl)
(mapcar #'process-result-list rl)
(let ((next (process-result rl)))
(when next
(alexandria:flatten (list next (process-result-list next)))))))
#+xcvb (module (:depends-on ("macros" "process-spec" "run-generic")))
(in-package :inferior-shell)
(defgeneric result-or (result))
(defgeneric result-and (result))
(defmethod result-or ((r result))
(not (zerop (sb-ext:process-exit-code (result-process r)))))
(defmethod result-and ((r result))
(zerop (sb-ext:process-exit-code (result-process r))))
(defmethod generic-run-spec ((spec command-spec) input output error predicate rest resume)
(multiple-value-bind (r-input r-output r-error)
(process-redirections (command-redirections spec) input output error)
(labels ((run (out)
(sb-ext:run-program (car (command-arguments spec))
(cdr (command-arguments spec))
:input r-input :output out :error r-error
:wait nil :search t)))
(if (keywordp r-output)
(progn
(let* ((process (run :stream))
(stream (sb-ext:process-output process))
(slurp-thread (sb-thread:make-thread (lambda ()
(unwind-protect
(slurp-input-stream output stream)
(when stream (close stream)))))))
(list (make-instance 'result :process process :thread slurp-thread
:input input :output output :error error
:predicate predicate :rest rest :resume resume))))
(list (make-instance 'result :process (run r-output)
:input input :output r-output :error error
:predicate predicate :rest rest :resume resume))))))
(defun make-pipe ()
(multiple-value-bind (fd1 fd2)
(sb-unix:unix-pipe)
(values (sb-sys:make-fd-stream fd1 :buffering :none)
(sb-sys:make-fd-stream fd2 :buffering :none))))
(defun process-wait (p)
(sb-ext:process-wait p))
(defun sbcl-run (spec &key input output error ignore-error-status)
(declare (ignore ignore-error-status)) ;; THIS IS A BUG!
(labels ((collect-threads (r)
(let ((thread (result-thread r)))
(when thread
(sb-thread:join-thread thread)))))
(let* ((first-results (generic-run-spec spec input output error nil nil nil))
(full-results (alexandria:flatten (nconc first-results
(mapcan 'process-result-list first-results)))))
(when (keywordp output)
(let ((collected (mapcar #'collect-threads full-results)))
(case output
(:string (apply #'concatenate 'string collected))
(:string/stripped (stripln (apply #'concatenate 'string collected)))
(:lines (apply #'concatenate 'list collected))
(otherwise collected)))))))
#+xcvb (module (:depends-on ("macros" "process-spec")))
(in-package :inferior-shell)
(defvar *backend* :auto)
(defun on-host-spec (host spec)
(if (current-host-name-p host)
spec
......@@ -25,13 +21,15 @@
(etypecase command
(direct-command-spec
(command-arguments spec))
(command-spec
(strcat "exec " (print-process-spec spec)))
(process-spec
(print-process-spec spec))
(string
spec))))
(apply 'run-program command keys)))
(defun run-process-spec (spec &rest keys &key host backend &allow-other-keys)
(defun run-process-spec (spec &rest keys &key host &allow-other-keys)
(etypecase host
(null
(etypecase spec
......@@ -40,12 +38,7 @@
(cons
(apply 'run-process-spec (parse-process-spec spec) keys))
(process-spec
(ecase (or backend *backend*)
#+(and sbcl sb-thread unix)
((:sbcl)
(apply 'sbcl-run spec keys))
((:auto)
(apply 'run-spec spec keys))))))
(apply 'run-spec spec keys))))
(string
(apply 'run-process-spec (on-host-spec host spec) :host nil keys))
(function
......
#+xcvb (module (:depends-on ("/inferior-shell" :asdf "hu.dwim.stefil")))
(in-package :cl)
(defpackage :inferior-shell-test
......@@ -21,8 +19,4 @@
"Hello, World!")))
(deftest test-inferior-shell ()
(let ((*backend* :auto))
(do-test-inferior-shell))
#|#+(and sbcl sb-thread unix)
(let ((*backend* :sbcl))
(do-test-inferior-shell))|#)
(do-test-inferior-shell))
#+xcvb (module (:depends-on ("pkgdcl")))
(in-package :inferior-shell)
;;--- TODO: move these to FARE-UTILS and/or XCVB-DRIVER ?
......