Commit 4caf0cc7 by Francois-Rene Rideau

Another reimplementation of run-program. New:

* it handles INPUT and ERROR-OUTPUT, not just OUTPUT.
* it accepts PATHNAMEs as I/O designators
* it works on ECL under SLIME (fixes lp#1232225)
* SLIGHT API CHANGE!
  At the suggestion of stassats, we're always returning an exit code,
  and in a predictable return value position.
  However, both for backward compatibility and usability,
  the OUTPUT slurping results remain the primary return value,
  followed by the ERROR-OUTPUT slurping results, followed by the exit code.
  So far, no one was using multiple values in SLURP-INPUT-STREAM methods,
  so no one will regret that, except people who might have somehow expected
  the old weird behavior of a return code when OUTPUT is NIL or :INTERACTIVE.
* As another API tweak and improvement, keyword options are now specified
  separately for each of your I/O designators, by putting them your designator
  in a list. A list also distinguishes a string as input from a namestring
  to designate a pathname, i.e. :input '("bar") is the string literal,
  whereas :input "bar" is the file named bar.

Several fixes and extensions to stream support.

Only tested so far on Linux x64 with
ccl clisp sbcl ecl ecl_bytecodes cmucl abcl allegro allegromodern xcl
parent 95b71bcf
......@@ -145,15 +145,12 @@ Deprecated function, for backward-compatibility only.
Please use UIOP:RUN-PROGRAM instead."
(let ((command (apply 'format nil control-string args)))
(asdf-message "; $ ~A~%" command)
(handler-case
(progn
(run-program command :force-shell t :ignore-error-status nil :output *verbose-out*)
0)
(subprocess-error (c)
(let ((code (subprocess-error-code c)))
(typecase code
(integer code)
(t 255))))))))
(let ((exit-code
(nth-value 2 (run-program command :force-shell t :ignore-error-status t
:output *verbose-out*))))
(typecase exit-code
((integer 0 255) exit-code)
(t 255))))))
(with-upgradability ()
(defvar *asdf-verbose* nil)) ;; backward-compatibility with ASDF2 only. Unused.
......
......@@ -29,9 +29,12 @@
(initialize-source-registry `(:source-registry :ignore-inherited-configuration))
(delete-file-if-exists exe)
(run-program
(symbol-call :lisp-invocation :lisp-invocation-arglist
:load (native-namestring (subpathname *test-directory* "make-hello-world.lisp"))))
(assert-equal
(multiple-value-list
(run-program
(symbol-call :lisp-invocation :lisp-invocation-arglist
:load (native-namestring (subpathname *test-directory* "make-hello-world.lisp")))))
'(nil nil 0))
(assert (probe-file* exe))
(assert-equal (run-program `(,(native-namestring exe)) :output :lines)
......
......@@ -56,10 +56,10 @@
(assert-equal (format nil "ok 1~%") (remove-cr (run-program '("echo" "ok 1") :output :string)))
;; this test checks for a problem there was in allegro -- :output :interactive
;; would try to open T as a stream for INPUT.
(assert-equal 0 (run-program "true" :force-shell t :output :interactive))
(assert-equal 0 (run-program "true" :force-shell nil :output :interactive))
(assert-equal 1 (run-program "false" :force-shell t :output :interactive :ignore-error-status t))
(assert-equal 1 (run-program "false" :force-shell nil :output :interactive :ignore-error-status t))
(assert-equal '(nil nil 0) (multiple-value-list (run-program "true" :force-shell t :output :interactive)))
(assert-equal '(nil nil 0) (multiple-value-list (run-program "true" :force-shell nil :output :interactive)))
(assert-equal '(nil nil 1) (multiple-value-list (run-program "false" :force-shell t :output :interactive :ignore-error-status t)))
(assert-equal '(nil nil 1) (multiple-value-list (run-program "false" :force-shell nil :output :interactive :ignore-error-status t)))
;;#+allegro (trace excl:run-shell-command sys:reap-os-subprocess)
......@@ -195,16 +195,16 @@ Testing run-program
(signals error (run-program '("does-not-exist") :output :lines))
(signals error (run-program "does-not-exist" :output :lines))
(is (equal 0 (run-program "echo ok" :output nil)))
(is (equal 0 (run-program '("echo" "ok") :output nil)))
(is (equal '(nil nil 0) (multiple-value-list (run-program "echo ok" :output nil))))
(is (equal '(nil nil 0) (multiple-value-list (run-program '("echo" "ok") :output nil))))
t)
(defun unix-only-test/run-program ()
(is (equal 0 (run-program "true")))
(is (equal '(nil nil 0) (multiple-value-list (run-program "true"))))
(signals subprocess-error (run-program "false"))
(is (equal 1 (run-program "false" :ignore-error-status t)))
(is (equal '(nil nil 1) (multiple-value-list (run-program "false" :ignore-error-status t))))
(let ((tf (native-namestring (test-source "test-file"))))
......
......@@ -11,13 +11,15 @@ according to its topic: e.g pathname.lisp will define package UIOP/PATHNAME
and contain utilities related to the handling of pathname objects.
All exported symbols are reexported in a convenience package UIOP.
The files that constitute UIOP are, in order:
The files that constitute UIOP are, in loading order:
* package: to deal with packages and their symbols, most notably including
DEFINE-PACKAGE, a variant of defpackage capable of hot-upgrade.
* common-lisp: to let you paper over various sub-standard implementations
Corman, GCL, Genera, MCL are the biggest (unmaintained) offenders.
Supported without much any issues are:
ABCL, Allegro, CCL, CMUCL, CLISP, ECL, LispWorks, MKCL, SBCL, XCL.
* utility: to provide macros and functions that do not involve I/O, handling
control-flow, (p)lists, character, strings, functions, classes, conditions,
......@@ -46,6 +48,7 @@ The files that constitute UIOP are, in order:
accessing command line arguments or quitting the process.
* run-program: to portably spawn external processes and capture their output.
Can also capture error-output, inject input, or let it all be interactive.
* lisp-build: to portably compile common-lisp code, handle compilation results,
muffle uninteresting conditions, save and restore deferred warnings,
......
......@@ -148,6 +148,12 @@
;;;; compatfmt: avoid fancy format directives when unsupported
(eval-when (:load-toplevel :compile-toplevel :execute)
(defun frob-substrings (string substrings &optional frob)
"for each substring in SUBSTRINGS, find occurrences of it within STRING
that don't use parts of matched occurrences of previous strings, and
FROB them, that is to say, remove them if FROB is NIL,
replace by FROB if FROB is a STRING, or if FROB is a FUNCTION,
call FROB with the match and a function that emits a string in the output.
Return a string made of the parts not omitted or emitted by FROB."
(declare (optimize (speed 0) (safety 3) (debug 3)))
(let ((length (length string)) (stream nil))
(labels ((emit-string (x &optional (start 0) (end (length x)))
......@@ -184,5 +190,3 @@
#+(or gcl genera)
(frob-substrings format `("~3i~_" #+(or genera gcl2.6) ,@'("~@<" "~@;" "~@:>" "~:>")))
#-(or gcl genera) format))
......@@ -410,8 +410,8 @@ TRUENAMIZE uses TRUENAMIZE to resolve as many symlinks as possible."
(defun call-with-current-directory (dir thunk)
(if dir
(let* ((dir (resolve-symlinks* (get-pathname-defaults (pathname-directory-pathname dir))))
(*default-pathname-defaults* dir)
(cwd (getcwd)))
(cwd (getcwd))
(*default-pathname-defaults* dir))
(chdir dir)
(unwind-protect
(funcall thunk)
......
......@@ -347,5 +347,6 @@ if we are not called from a directly executable image."
;;; Some universal image restore hooks
(with-upgradability ()
(map () 'register-image-restore-hook
'(setup-temporary-directory setup-stderr setup-command-line-arguments
'(setup-stdin setup-stdout setup-stderr
setup-command-line-arguments setup-temporary-directory
#+abcl detect-os)))
......@@ -6,13 +6,16 @@
(:recycle :uiop/stream :asdf/stream :asdf)
(:use :uiop/common-lisp :uiop/package :uiop/utility :uiop/os :uiop/pathname :uiop/filesystem)
(:export
#:*default-stream-element-type* #:*stderr* #:setup-stderr
#:*default-stream-element-type*
#:*stdin* #:setup-stdin #:*stdout* #:setup-stdout #:*stderr* #:setup-stderr
#:detect-encoding #:*encoding-detection-hook* #:always-default-encoding
#:encoding-external-format #:*encoding-external-format-hook* #:default-encoding-external-format
#:*default-encoding* #:*utf-8-external-format*
#:with-safe-io-syntax #:call-with-safe-io-syntax #:safe-read-from-string
#:with-output #:output-string #:with-input
#:with-input-file #:call-with-input-file #:with-output-file #:call-with-output-file
#:null-device-pathname #:call-with-null-input #:with-null-input
#:call-with-null-output #:with-null-output
#:finish-outputs #:format! #:safe-format!
#:copy-stream-to-stream #:concatenate-files #:copy-file
#:slurp-stream-string #:slurp-stream-lines #:slurp-stream-line
......@@ -32,6 +35,18 @@
(defvar *default-stream-element-type* (or #+(or abcl cmu cormanlisp scl xcl) 'character :default)
"default element-type for open (depends on the current CL implementation)")
(defvar *stdin* *standard-input*
"the original standard input stream at startup")
(defun setup-stdin ()
(setf *stdin* #+clozure ccl::*stdin* #-clozure *standard-input*))
(defvar *stdout* *standard-output*
"the original standard output stream at startup")
(defun setup-stdout ()
(setf *stdout* #+clozure ccl::*stdout* #-clozure *standard-output*))
(defvar *stderr* *error-output*
"the original error output stream at startup")
......@@ -40,7 +55,8 @@
#+allegro excl::*stderr*
#+clozure ccl::*stderr*
#-(or allegro clozure) *error-output*))
(setup-stderr))
(setup-stdin) (setup-stdout) (setup-stderr))
;;; Encodings (mostly hooks only; full support requires asdf-encodings)
......@@ -118,7 +134,6 @@ and implementation-defined external-format's")
(with-safe-io-syntax (:package package)
(read-from-string string eof-error-p eof-value :start start :end end :preserve-whitespace preserve-whitespace))))
;;; Output to a stream or string, FORMAT-style
(with-upgradability ()
(defun call-with-output (output function)
......@@ -215,6 +230,36 @@ Other keys are accepted but discarded."
(declare (ignore element-type external-format if-exists if-does-not-exist))
`(call-with-output-file ,pathname #'(lambda (,var) ,@body) ,@keys)))
;;; Null device
(with-upgradability ()
(defun null-device-pathname ()
(cond
((os-unix-p) #p"/dev/null")
((os-windows-p) #p"NUL") ;; Q: how many Lisps accept the #p"NUL:" syntax?
(t (error "No /dev/null on your OS"))))
(defun call-with-null-input (fun &rest keys &key element-type external-format if-does-not-exist)
(declare (ignore element-type external-format if-does-not-exist))
(apply 'call-with-input-file (null-device-pathname) fun keys))
(defmacro with-null-input ((var &rest keys
&key element-type external-format if-does-not-exist)
&body body)
(declare (ignore element-type external-format if-does-not-exist))
`(call-with-null-input #'(lambda (,var) ,@body) ,@keys))
(defun call-with-null-output (fun
&key (element-type *default-stream-element-type*)
(external-format *utf-8-external-format*)
(if-exists :overwrite)
(if-does-not-exist :error))
(call-with-output-file
(null-device-pathname) fun
:element-type element-type :external-format external-format
:if-exists if-exists :if-does-not-exist if-does-not-exist))
(defmacro with-null-output ((var &rest keys
&key element-type external-format if-does-not-exist if-exists)
&body body)
(declare (ignore element-type external-format if-exists if-does-not-exist))
`(call-with-null-output #'(lambda (,var) ,@body) ,@keys)))
;;; Ensure output buffers are flushed
(with-upgradability ()
(defun finish-outputs (&rest streams)
......@@ -222,8 +267,8 @@ Other keys are accepted but discarded."
Useful for portably flushing I/O before user input or program exit."
;; CCL notably buffers its stream output by default.
(dolist (s (append streams
(list *stderr* *error-output* *standard-output* *trace-output*
*debug-io* *terminal-io* *debug-io* *query-io*)))
(list *stdout* *stderr* *error-output* *standard-output* *trace-output*
*debug-io* *terminal-io* *query-io*)))
(ignore-errors (finish-output s)))
(values))
......@@ -231,7 +276,7 @@ Useful for portably flushing I/O before user input or program exit."
"Just like format, but call finish-outputs before and after the output."
(finish-outputs stream)
(apply 'format stream format args)
(finish-output stream))
(finish-outputs stream))
(defun safe-format! (stream format &rest args)
(with-safe-io-syntax ()
......@@ -435,7 +480,7 @@ If a string, repeatedly read and evaluate from it, returning the last values."
(thunk &key
prefix keep (direction :io)
(element-type *default-stream-element-type*)
(external-format :default))
(external-format *utf-8-external-format*))
#+gcl2.6 (declare (ignorable external-format))
(check-type direction (member :output :io))
(loop
......@@ -478,7 +523,7 @@ ready for I/O. Unless KEEP is specified, delete the file afterwards."
,@(when prefix `(:prefix ,prefix))
,@(when keep `(:keep ,keep))
,@(when element-type `(:element-type ,element-type))
,@(when external-format `(:external-format external-format)))))
,@(when external-format `(:external-format ,external-format)))))
;; Temporary pathnames in simple cases where no contention is assumed
(defun add-pathname-suffix (pathname suffix)
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment