Skip to content
Snippets Groups Projects
Commit 0b8b4838 authored by Nathan Hawkins's avatar Nathan Hawkins
Browse files

Add support for sequences of commands

parent f3821dc7
No related branches found
No related tags found
No related merge requests found
......@@ -7,8 +7,9 @@
(:export
#:run #:run/s #:run/ss #:run/lines
#:process-spec #:command-spec #:pipe-spec
#:or-spec #:and-spec #:progn-spec #:fork-spec
#:print-process-spec #:parse-process-spec
#:command-arguments #:command-redirections
#:redirection #:file-redirection #:fd-redirection #:close-redirection
#:! #:- #:< #:> #:<> #:>! #:>> #:>>! #:<& #:>& #:>&! #:>>&!
#:>& #:>> #:>>& #:pipe))
#:>& #:>> #:>>& #:pipe #:or #:and #:progn #:fork))
......@@ -6,10 +6,20 @@
(defclass process-spec (simple-print-object-mixin) ())
(defclass pipe-spec (process-spec)
(defclass sequence-spec (process-spec)
((processes
:type list
:initarg :processes :reader pipe-processes)))
:initarg :processes :reader sequence-processes)))
(defclass pipe-spec (sequence-spec) ())
(defclass or-spec (sequence-spec) ())
(defclass and-spec (sequence-spec) ())
(defclass progn-spec (sequence-spec) ())
(defclass fork-spec (sequence-spec) ())
(defclass redirection (simple-print-object-mixin) ())
......@@ -156,21 +166,32 @@
(clps-current-argument c) nil)))
(defun parse-process-spec (spec)
(match spec
(`(pipe ,@args)
(make-instance
'pipe-spec :processes
(loop :for process :in (mapcar 'parse-process-spec args)
:nconc (if (typep process 'pipe-spec)
(pipe-processes process)
(list process)))))
(`(,* ,@*)
(let ((c (make-instance 'command-parse)))
(dolist (elem spec)
(parse-command-spec-top-token c elem))
(command-parse-results c)))
(*
(error "Invalid process spec ~S" spec))))
(macrolet ((make-sequence-instance (spec-type args)
`(make-instance
',spec-type :processes
(loop :for process :in (mapcar 'parse-process-spec ,args)
:nconc (etypecase process
(,spec-type (sequence-processes process))
(sequence-spec (list process))
(command-spec (list process)))))))
(match spec
(`(pipe ,@args)
(make-sequence-instance pipe-spec args))
(`(or ,@args)
(make-sequence-instance or-spec args))
(`(and ,@args)
(make-sequence-instance and-spec args))
(`(progn ,@args)
(make-sequence-instance progn-spec args))
(`(fork ,@args)
(make-sequence-instance fork-spec args))
(`(,* ,@*)
(let ((c (make-instance 'command-parse)))
(dolist (elem spec)
(parse-command-spec-top-token c elem))
(command-parse-results c)))
(*
(error "Invalid process spec ~S" spec)))))
(defun parse-command-spec-top-token (c x)
(labels
......@@ -246,6 +267,7 @@
(null ())
(keyword (a (format nil "--~(~a~)" x)))
(symbol (a (string-downcase x)))
(pathname (a (namestring (translate-logical-pathname x))))
(cons (c x)))))
(defun parse-command-spec-token (c x)
......@@ -259,6 +281,7 @@
(null ())
(keyword (e (format nil "--~(~a~)" x)))
(symbol (e (string-downcase x)))
(pathname (e (namestring (translate-logical-pathname x))))
(cons (c x))))
(c (x)
(match x
......@@ -289,13 +312,32 @@
(loop :for r :in redirections :do
(princ " " s) (print-process-spec r s))))))
(defmethod print-process-spec ((spec pipe-spec) &optional s)
(defun print-process-sequence-joined (spec separator empty s &optional tail)
(with-output-stream (s)
(let ((processes (pipe-processes spec)))
(let ((processes (sequence-processes spec)))
(if processes
(loop :for (p . rest) :on processes :do
(print-process-spec p s) (when rest (princ " | " s)))
(princ "cat" s)))))
(progn
(princ "(" s)
(loop :for (p . rest) :on processes :do
(print-process-spec p s) (when rest (princ separator s)))
(princ ")" s)
(when tail (princ tail s)))
(princ empty s)))))
(defmethod print-process-spec ((spec pipe-spec) &optional s)
(print-process-sequence-joined spec " | " "cat" s))
(defmethod print-process-spec ((spec or-spec) &optional s)
(print-process-sequence-joined spec " || " "false" s))
(defmethod print-process-spec ((spec and-spec) &optional s)
(print-process-sequence-joined spec " && " "true" s))
(defmethod print-process-spec ((spec progn-spec) &optional s)
(print-process-sequence-joined spec "; " "true" s))
(defmethod print-process-spec ((spec fork-spec) &optional s)
(print-process-sequence-joined spec "; " "true" s " &"))
(defmethod print-process-spec ((spec string) &optional s)
(xcvb-driver::output-string spec s))
......
......@@ -23,6 +23,27 @@
spec
`(ssh ,host ,(print-process-spec spec))))
(defmethod run-spec ((spec process-spec) &rest keys &key ignore-error-status output)
(let ((command
(if (and (typep spec 'command-spec)
(null (command-redirections spec)))
(command-arguments spec)
(print-process-spec spec))))
(run-program/ command
:ignore-error-status ignore-error-status
:output output)))
;; This only works with run because run-program/ doesn't return an
;; exit code if :output is set.
;; (defmethod run-spec ((spec or-spec) &rest keys &key ignore-error-status output)
;; (let ((processes (sequence-processes spec))
;; (return-code 1))
;; (loop :for p :in processes :do
;; (setf return-code (run-spec p :ignore-error-status ignore-error-status :output output))
;; :until (and (numberp return-code) (= return-code 0)))
;; return-code))
(defun run-process-spec (spec &rest keys &key ignore-error-status output host)
(declare (ignore ignore-error-status output))
(etypecase host
......@@ -33,14 +54,7 @@
(cons
(apply 'run-process-spec (parse-process-spec spec) keys))
(process-spec
(let ((command
(if (and (typep spec 'command-spec)
(null (command-redirections spec)))
(command-arguments spec)
(print-process-spec spec))))
(run-program/ command
:ignore-error-status ignore-error-status
:output output)))))
(run-spec spec :ignore-error-status ignore-error-status :output output))))
(string
(apply 'run-process-spec (on-host-spec host spec) :host nil keys))
(function
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment