Newer
Older
#+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))
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
;; 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
Francois-Rene Rideau
committed
:type (or function null) :initform nil
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
: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))))
; (defgeneric result-or ((result r)))
; (defgeneric result-and ((result r)))
(defmethod generic-run-spec ((spec or-spec) input output error predicate rest resume)
(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)
(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)
(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)
(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)
(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)))))))