From 694579f0c896b41a19b9f6b7a1e0b7e97f280e4e Mon Sep 17 00:00:00 2001 From: Francois-Rene Rideau <tunes@google.com> Date: Thu, 10 Oct 2013 20:48:37 -0400 Subject: [PATCH] Simplify run so it's compatible with the new uiop:run-program and its :error-output --- run.lisp | 29 ++++++++++++----------------- utilities.lisp | 41 +++++++++++++++++++++++++++++++++-------- 2 files changed, 45 insertions(+), 25 deletions(-) diff --git a/run.lisp b/run.lisp index 0f29f6a..627df2a 100644 --- a/run.lisp +++ b/run.lisp @@ -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))) diff --git a/utilities.lisp b/utilities.lisp index e08c409..aa564a9 100644 --- a/utilities.lisp +++ b/utilities.lisp @@ -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) -- GitLab