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