Skip to content
Snippets Groups Projects
Commit 694579f0 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau
Browse files

Simplify run so it's compatible with the new uiop:run-program and its :error-output

parent 7b4928b4
No related branches found
No related tags found
No related merge requests found
......@@ -16,9 +16,7 @@
(and (typep spec 'command-spec)
(null (command-redirections spec))))
(defun run-spec (spec &rest keys
&key ignore-error-status output element-type external-format &allow-other-keys)
(declare (ignore ignore-error-status element-type external-format))
(defun run-spec (spec &rest keys &key &allow-other-keys)
(let* ((command
(if (consp spec)
(parse-process-spec spec)
......@@ -31,40 +29,37 @@
(print-process-spec spec))
(string
spec))))
(apply 'run-program command :output (case output ((t) nil) (otherwise output)) keys)))
(apply 'run-program command keys)))
(defun run-process-spec (spec &rest keys &key ignore-error-status output host backend)
(defun run-process-spec (spec &rest keys &key host backend &allow-other-keys)
(etypecase host
(null
(etypecase spec
(string
(run-spec spec :ignore-error-status ignore-error-status :output output))
(apply 'run-spec spec keys))
(cons
(apply 'run-process-spec (parse-process-spec spec) keys))
(process-spec
(ecase (or backend *backend*)
#+(and sbcl sb-thread unix)
((:sbcl)
(let ((interactive (eq :output :interactive)))
(sbcl-run
spec :input interactive :output (or interactive output) :error t
:ignore-error-status ignore-error-status)))
(apply 'sbcl-run spec keys))
((:auto)
(run-spec spec :ignore-error-status ignore-error-status :output output))))))
(apply 'run-spec spec keys))))))
(string
(apply 'run-process-spec (on-host-spec host spec) :host nil keys))
(function
(apply 'run-process-spec (funcall host spec) :host nil keys))))
(defun run (cmd &key time (output t) show host (on-error (list "Command ~S failed~@[ on ~A~]" cmd host)))
(defun run (cmd &rest keys
&key time show host (on-error (list "Command ~S failed~@[ on ~A~]" cmd host)) &allow-other-keys)
(labels ((process-time ()
(if time (time (process-command)) (process-command)))
(process-command ()
(handler-case
(run-process-spec
cmd
:ignore-error-status nil :output output :host host)
(subprocess-error () (error-behavior on-error)))))
(handler-bind
((subprocess-error #'(lambda (c) (error-behavior on-error c))))
(apply 'run-process-spec cmd
:ignore-error-status nil :host host keys))))
(when show
(format *trace-output* "; ~A~%" (print-process-spec cmd)))
(process-time)))
......
......@@ -40,11 +40,9 @@
(with-input-from-string (stream string)
(do-stream-lines fun stream)))
(defun println (x)
(princ x) (terpri) (values))
(defun writeln (x &rest keys)
(apply 'write x keys) (terpri) (values))
(defvar *cr* (coerce #(#\cr) 'string))
(defvar *lf* (coerce #(#\newline) 'string))
(defvar *crlf* (coerce #(#\cr #\newline) 'string))
(defun stripln (x)
(check-type x string)
......@@ -53,9 +51,36 @@
(endcrlfp (and endlfp (<= 2 len) (eql (char x (- len 2)) #\return)))
(endcrp (equal (last-char x) #\return)))
(cond
((or endlfp endcrp) (subseq x 0 (- len 1)))
(endcrlfp (subseq x 0 (- len 2)))
(t x))))
(endlfp (values (subseq x 0 (- len 1)) *lf*))
(endcrp (values (subseq x 0 (- len 1)) *cr*))
(endcrlfp (values (subseq x 0 (- len 2)) *crlf*))
(t (values x nil)))))
(defun read-line* (&optional (stream *standard-input*) eof-error-p eof-value recursive-p cr lf)
"Similar to READ-LINE, this function also returns as additional values the state about
whether CR or LF were read. CR, LF and CR+LF are accepted only.
Partial state accepted as input, too, for parsing in chunks."
(loop
:with eof = '#:eof
:with datap = nil
:with out = (make-string-output-stream)
:for char = (read-char stream nil eof recursive-p) :do
(labels ((out (c) (setf datap t) (write-char c out))
(unpeek () (unread-char char stream))
(done () (return (values (get-output-stream-string out) cr lf)))
(unpeek-done () (unpeek) (done)))
(cond
((eql char #\newline)
(if lf (unpeek-done) (setf lf t)))
((eql char #\cr)
(if (or cr lf) (unpeek-done) (setf cr t)))
((eql char eof)
(cond
(eof-error-p (read-char stream eof-error-p eof-value recursive-p))
(datap (done))
(t (return (values eof-value nil nil)))))
(t
(out char))))))
(defun add-days (year month date days)
(multiple-value-bind (sec min hr d m y dlsp tz)
......
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