+;;;; -------------------------------------------------------------------------
+;;;; Starting, Stopping, Dumping a Lisp image
+
+(uiop/package:define-package :uiop/image
+ (:nicknames :asdf/image)
+ (:recycle :uiop/image :asdf/image :xcvb-driver)
+ (:use :uiop/common-lisp :uiop/package :uiop/utility :uiop/pathname :uiop/stream :uiop/os)
+ (:export
+ #:*image-dumped-p* #:raw-command-line-arguments #:*command-line-arguments*
+ #:command-line-arguments #:raw-command-line-arguments #:setup-command-line-arguments
+ #:*lisp-interaction*
+ #:*fatal-conditions* #:fatal-condition-p #:handle-fatal-condition
+ #:call-with-fatal-condition-handler #:with-fatal-condition-handler
+ #:*image-restore-hook* #:*image-prelude* #:*image-entry-point*
+ #:*image-postlude* #:*image-dump-hook*
+ #:quit #:die #:raw-print-backtrace #:print-backtrace #:print-condition-backtrace
+ #:shell-boolean-exit
+ #:register-image-restore-hook #:register-image-dump-hook
+ #:call-image-restore-hook #:call-image-dump-hook
+ #:restore-image #:dump-image #:create-image
+))
+(in-package :uiop/image)
+
+(with-upgradability ()
+ (defvar *lisp-interaction* t
+ "Is this an interactive Lisp environment, or is it batch processing?")
+
+ (defvar *command-line-arguments* nil
+ "Command-line arguments")
+
+ (defvar *image-dumped-p* nil ; may matter as to how to get to command-line-arguments
+ "Is this a dumped image? As a standalone executable?")
+
+ (defvar *image-restore-hook* nil
+ "Functions to call (in reverse order) when the image is restored")
+
+ (defvar *image-restored-p* nil
+ "Has the image been restored? A boolean, or :in-progress while restoring, :in-regress while dumping")
+
+ (defvar *image-prelude* nil
+ "a form to evaluate, or string containing forms to read and evaluate
+when the image is restarted, but before the entry point is called.")
+
+ (defvar *image-entry-point* nil
+ "a function with which to restart the dumped image when execution is restored from it.")
+
+ (defvar *image-postlude* nil
+ "a form to evaluate, or string containing forms to read and evaluate
+before the image dump hooks are called and before the image is dumped.")
+
+ (defvar *image-dump-hook* nil
+ "Functions to call (in order) when before an image is dumped")
+
+ (defvar *fatal-conditions* '(error)
+ "conditions that cause the Lisp image to enter the debugger if interactive,
+or to die if not interactive"))
+
+
+;;; Exiting properly or im-
+(with-upgradability ()
+ (defun quit (&optional (code 0) (finish-output t))
+ "Quits from the Lisp world, with the given exit status if provided.
+This is designed to abstract away the implementation specific quit forms."
+ (when finish-output ;; essential, for ClozureCL, and for standard compliance.
+ (finish-outputs))
+ #+(or abcl xcl) (ext:quit :status code)
+ #+allegro (excl:exit code :quiet t)
+ #+clisp (ext:quit code)
+ #+clozure (ccl:quit code)
+ #+cormanlisp (win32:exitprocess code)
+ #+(or cmu scl) (unix:unix-exit code)
+ #+ecl (si:quit code)
+ #+gcl (lisp:quit code)
+ #+genera (error "You probably don't want to Halt the Machine. (code: ~S)" code)
+ #+lispworks (lispworks:quit :status code :confirm nil :return nil :ignore-errors-p t)
+ #+mcl (progn code (ccl:quit)) ;; or should we use FFI to call libc's exit(3) ?
+ #+mkcl (mk-ext:quit :exit-code code)
+ #+sbcl #.(let ((exit (find-symbol* :exit :sb-ext nil))
+ (quit (find-symbol* :quit :sb-ext nil)))
+ (cond
+ (exit `(,exit :code code :abort (not finish-output)))
+ (quit `(,quit :unix-status code :recklessly-p (not finish-output)))))
+ #-(or abcl allegro clisp clozure cmu ecl gcl genera lispworks mcl mkcl sbcl scl xcl)
+ (error "~S called with exit code ~S but there's no quitting on this implementation" 'quit code))
+
+ (defun die (code format &rest arguments)
+ "Die in error with some error message"
+ (with-safe-io-syntax ()
+ (ignore-errors
+ (format! *stderr* "~&~?~&" format arguments)))
+ (quit code))
+
+ (defun raw-print-backtrace (&key (stream *debug-io*) count)
+ "Print a backtrace, directly accessing the implementation"
+ (declare (ignorable stream count))
+ #+abcl
+ (let ((*debug-io* stream)) (top-level::backtrace-command count))
+ #+allegro
+ (let ((*terminal-io* stream)
+ (*standard-output* stream)
+ (tpl:*zoom-print-circle* *print-circle*)
+ (tpl:*zoom-print-level* *print-level*)
+ (tpl:*zoom-print-length* *print-length*))
+ (tpl:do-command "zoom"
+ :from-read-eval-print-loop nil
+ :count t
+ :all t))
+ #+clisp
+ (system::print-backtrace :out stream :limit count)
+ #+(or clozure mcl)
+ (let ((*debug-io* stream))
+ #+clozure (ccl:print-call-history :count count :start-frame-number 1)
+ #+mcl (ccl:print-call-history :detailed-p nil)
+ (finish-output stream))
+ #+(or cmu scl)
+ (let ((debug:*debug-print-level* *print-level*)
+ (debug:*debug-print-length* *print-length*))
+ (debug:backtrace most-positive-fixnum stream))
+ #+ecl
+ (si::tpl-backtrace)
+ #+lispworks
+ (let ((dbg::*debugger-stack*
+ (dbg::grab-stack nil :how-many (or count most-positive-fixnum)))
+ (*debug-io* stream)
+ (dbg:*debug-print-level* *print-level*)
+ (dbg:*debug-print-length* *print-length*))
+ (dbg:bug-backtrace nil))
+ #+sbcl
+ (sb-debug:backtrace
+ #.(if (find-symbol* "*VERBOSITY*" "SB-DEBUG" nil) :stream '(or count most-positive-fixnum))
+ stream))
+
+ (defun print-backtrace (&rest keys &key stream count)
+ (declare (ignore stream count))
+ (with-safe-io-syntax (:package :cl)
+ (let ((*print-readably* nil)
+ (*print-circle* t)
+ (*print-miser-width* 75)
+ (*print-length* nil)
+ (*print-level* nil)
+ (*print-pretty* t))
+ (ignore-errors (apply 'raw-print-backtrace keys)))))
+
+ (defun print-condition-backtrace (condition &key (stream *stderr*) count)
+ ;; We print the condition *after* the backtrace,
+ ;; for the sake of who sees the backtrace at a terminal.
+ ;; It is up to the caller to print the condition *before*, with some context.
+ (print-backtrace :stream stream :count count)
+ (when condition
+ (safe-format! stream "~&Above backtrace due to this condition:~%~A~&"
+ condition)))
+
+ (defun fatal-condition-p (condition)
+ (match-any-condition-p condition *fatal-conditions*))
+
+ (defun handle-fatal-condition (condition)
+ "Depending on whether *LISP-INTERACTION* is set, enter debugger or die"
+ (cond
+ (*lisp-interaction*
+ (invoke-debugger condition))
+ (t
+ (safe-format! *stderr* "~&Fatal condition:~%~A~%" condition)
+ (print-condition-backtrace condition :stream *stderr*)
+ (die 99 "~A" condition))))
+
+ (defun call-with-fatal-condition-handler (thunk)
+ (handler-bind (((satisfies fatal-condition-p) #'handle-fatal-condition))
+ (funcall thunk)))
+
+ (defmacro with-fatal-condition-handler ((&optional) &body body)
+ `(call-with-fatal-condition-handler #'(lambda () ,@body)))
+
+ (defun shell-boolean-exit (x)
+ "Quit with a return code that is 0 iff argument X is true"
+ (quit (if x 0 1))))
+
+
+;;; Using image hooks
+(with-upgradability ()
+ (defun register-image-restore-hook (hook &optional (call-now-p t))
+ (register-hook-function '*image-restore-hook* hook call-now-p))
+
+ (defun register-image-dump-hook (hook &optional (call-now-p nil))
+ (register-hook-function '*image-dump-hook* hook call-now-p))
+
+ (defun call-image-restore-hook ()
+ (call-functions (reverse *image-restore-hook*)))
+
+ (defun call-image-dump-hook ()
+ (call-functions *image-dump-hook*)))
+
+
+;;; Proper command-line arguments
+(with-upgradability ()
+ (defun raw-command-line-arguments ()
+ "Find what the actual command line for this process was."
+ #+abcl ext:*command-line-argument-list* ; Use 1.0.0 or later!
+ #+allegro (sys:command-line-arguments) ; default: :application t
+ #+clisp (coerce (ext:argv) 'list)
+ #+clozure (ccl::command-line-arguments)
+ #+(or cmu scl) extensions:*command-line-strings*
+ #+ecl (loop :for i :from 0 :below (si:argc) :collect (si:argv i))
+ #+gcl si:*command-args*
+ #+(or genera mcl) nil
+ #+lispworks sys:*line-arguments-list*
+ #+sbcl sb-ext:*posix-argv*
+ #+xcl system:*argv*
+ #-(or abcl allegro clisp clozure cmu ecl gcl genera lispworks mcl sbcl scl xcl)
+ (error "raw-command-line-arguments not implemented yet"))
+
+ (defun command-line-arguments (&optional (arguments (raw-command-line-arguments)))
+ "Extract user arguments from command-line invocation of current process.
+Assume the calling conventions of a generated script that uses --
+if we are not called from a directly executable image."
+ #+abcl arguments
+ #-abcl
+ (let* (#-(or sbcl allegro)
+ (arguments
+ (if (eq *image-dumped-p* :executable)
+ arguments
+ (member "--" arguments :test 'string-equal))))
+ (rest arguments)))
+
+ (defun setup-command-line-arguments ()
+ (setf *command-line-arguments* (command-line-arguments)))
+
+ (defun restore-image (&key
+ ((:lisp-interaction *lisp-interaction*) *lisp-interaction*)
+ ((:restore-hook *image-restore-hook*) *image-restore-hook*)
+ ((:prelude *image-prelude*) *image-prelude*)
+ ((:entry-point *image-entry-point*) *image-entry-point*)
+ (if-already-restored '(cerror "RUN RESTORE-IMAGE ANYWAY")))
+ (when *image-restored-p*
+ (if if-already-restored
+ (call-function if-already-restored "Image already ~:[being ~;~]restored" (eq *image-restored-p* t))
+ (return-from restore-image)))
+ (with-fatal-condition-handler ()
+ (setf *image-restored-p* :in-progress)
+ (call-image-restore-hook)
+ (standard-eval-thunk *image-prelude*)
+ (setf *image-restored-p* t)
+ (let ((results (multiple-value-list
+ (if *image-entry-point*
+ (call-function *image-entry-point*)
+ t))))
+ (if *lisp-interaction*
+ (apply 'values results)
+ (shell-boolean-exit (first results)))))))
+
+
+;;; Dumping an image
+
+(with-upgradability ()
+ (defun dump-image (filename &key output-name executable
+ ((:postlude *image-postlude*) *image-postlude*)
+ ((:dump-hook *image-dump-hook*) *image-dump-hook*)
+ #+clozure prepend-symbols #+clozure (purify t))
+ (declare (ignorable filename output-name executable))
+ (setf *image-dumped-p* (if executable :executable t))
+ (setf *image-restored-p* :in-regress)
+ (standard-eval-thunk *image-postlude*)
+ (call-image-dump-hook)
+ (setf *image-restored-p* nil)
+ #-(or clisp clozure cmu lispworks sbcl scl)
+ (when executable
+ (error "Dumping an executable is not supported on this implementation! Aborting."))
+ #+allegro
+ (progn
+ (sys:resize-areas :global-gc t :pack-heap t :sift-old-areas t :tenure t) ; :new 5000000
+ (excl:dumplisp :name filename :suppress-allegro-cl-banner t))
+ #+clisp
+ (apply #'ext:saveinitmem filename
+ :quiet t
+ :start-package *package*
+ :keep-global-handlers nil
+ :executable (if executable 0 t) ;--- requires clisp 2.48 or later, still catches --clisp-x
+ (when executable
+ (list
+ ;; :parse-options nil ;--- requires a non-standard patch to clisp.
+ :norc t :script nil :init-function #'restore-image)))
+ #+clozure
+ (flet ((dump (prepend-kernel)
+ (ccl:save-application filename :prepend-kernel prepend-kernel :purify purify
+ :toplevel-function (when executable #'restore-image))))
+ ;;(setf ccl::*application* (make-instance 'ccl::lisp-development-system))
+ (if prepend-symbols
+ (with-temporary-file (:prefix "ccl-symbols-" :direction :output :pathname path)
+ (require 'elf)
+ (funcall (fdefinition 'ccl::write-elf-symbols-to-file) path)
+ (dump path))
+ (dump t)))
+ #+(or cmu scl)
+ (progn
+ (ext:gc :full t)
+ (setf ext:*batch-mode* nil)
+ (setf ext::*gc-run-time* 0)
+ (apply 'ext:save-lisp filename #+cmu :executable #+cmu t
+ (when executable '(:init-function restore-image :process-command-line nil))))
+ #+gcl
+ (progn
+ (si::set-hole-size 500) (si::gbc nil) (si::sgc-on t)
+ (si::save-system filename))
+ #+lispworks
+ (if executable
+ (lispworks:deliver 'restore-image filename 0 :interface nil)
+ (hcl:save-image filename :environment nil))
+ #+sbcl
+ (progn
+ ;;(sb-pcl::precompile-random-code-segments) ;--- it is ugly slow at compile-time (!) when the initial core is a big CLOS program. If you want it, do it yourself
+ (setf sb-ext::*gc-run-time* 0)
+ (apply 'sb-ext:save-lisp-and-die filename
+ :executable t ;--- always include the runtime that goes with the core
+ (when executable (list :toplevel #'restore-image :save-runtime-options t)))) ;--- only save runtime-options for standalone executables
+ #-(or allegro clisp clozure cmu gcl lispworks sbcl scl)
+ (error "Can't ~S ~S: UIOP doesn't support image dumping with ~A.~%"
+ 'dump-image filename (nth-value 1 (implementation-type))))
+
+ (defun create-image (destination object-files
+ &key kind output-name prologue-code epilogue-code
+ (prelude () preludep) (postlude () postludep)
+ (entry-point () entry-point-p) build-args)
+ (declare (ignorable destination object-files kind output-name prologue-code epilogue-code
+ prelude preludep postlude postludep entry-point entry-point-p build-args))
+ ;; Is it meaningful to run these in the current environment?
+ ;; only if we also track the object files that constitute the "current" image,
+ ;; and otherwise simulate dump-image, including quitting at the end.
+ #-ecl (error "~S not implemented for your implementation (yet)" 'create-image)
+ #+ecl
+ (progn
+ (check-type kind (member :binary :dll :lib :static-library :program :object :fasl :program))
+ (apply 'c::builder
+ kind (pathname destination)
+ :lisp-files object-files
+ :init-name (c::compute-init-name (or output-name destination) :kind kind)
+ :prologue-code prologue-code
+ :epilogue-code
+ `(progn
+ ,epilogue-code
+ ,@(when (eq kind :program)
+ `((setf *image-dumped-p* :executable)
+ (restore-image ;; default behavior would be (si::top-level)
+ ,@(when preludep `(:prelude ',prelude))
+ ,@(when entry-point-p `(:entry-point ',entry-point))))))
+ build-args))))
+
+
+;;; Some universal image restore hooks
+(with-upgradability ()
+ (map () 'register-image-restore-hook
+ '(setup-temporary-directory setup-stderr setup-command-line-arguments
+ #+abcl detect-os)))
+;;;; -------------------------------------------------------------------------
+;;;; run-program initially from xcvb-driver.
+
+(uiop/package:define-package :uiop/run-program
+ (:nicknames :asdf/run-program)
+ (:recycle :uiop/run-program :asdf/run-program :xcvb-driver)
+ (:use :uiop/common-lisp :uiop/utility :uiop/pathname :uiop/os :uiop/filesystem :uiop/stream)
+ (:export
+ ;;; Escaping the command invocation madness
+ #:easy-sh-character-p #:escape-sh-token #:escape-sh-command
+ #:escape-windows-token #:escape-windows-command
+ #:escape-token #:escape-command
+
+ ;;; run-program
+ #:slurp-input-stream
+ #:run-program
+ #:subprocess-error
+ #:subprocess-error-code #:subprocess-error-command #:subprocess-error-process
+ ))
+(in-package :uiop/run-program)
+
+;;;; ----- Escaping strings for the shell -----
+
+(with-upgradability ()
+ (defun requires-escaping-p (token &key good-chars bad-chars)
+ "Does this token require escaping, given the specification of
+either good chars that don't need escaping or bad chars that do need escaping,
+as either a recognizing function or a sequence of characters."
+ (some
+ (cond
+ ((and good-chars bad-chars)
+ (error "only one of good-chars and bad-chars can be provided"))
+ ((functionp good-chars)
+ (complement good-chars))
+ ((functionp bad-chars)
+ bad-chars)
+ ((and good-chars (typep good-chars 'sequence))
+ #'(lambda (c) (not (find c good-chars))))
+ ((and bad-chars (typep bad-chars 'sequence))
+ #'(lambda (c) (find c bad-chars)))
+ (t (error "requires-escaping-p: no good-char criterion")))
+ token))
+
+ (defun escape-token (token &key stream quote good-chars bad-chars escaper)
+ "Call the ESCAPER function on TOKEN string if it needs escaping as per
+REQUIRES-ESCAPING-P using GOOD-CHARS and BAD-CHARS, otherwise output TOKEN,
+using STREAM as output (or returning result as a string if NIL)"
+ (if (requires-escaping-p token :good-chars good-chars :bad-chars bad-chars)
+ (with-output (stream)
+ (apply escaper token stream (when quote `(:quote ,quote))))
+ (output-string token stream)))
+
+ (defun escape-windows-token-within-double-quotes (x &optional s)
+ "Escape a string token X within double-quotes
+for use within a MS Windows command-line, outputing to S."
+ (labels ((issue (c) (princ c s))
+ (issue-backslash (n) (loop :repeat n :do (issue #\\))))
+ (loop
+ :initially (issue #\") :finally (issue #\")
+ :with l = (length x) :with i = 0
+ :for i+1 = (1+ i) :while (< i l) :do
+ (case (char x i)
+ ((#\") (issue-backslash 1) (issue #\") (setf i i+1))
+ ((#\\)
+ (let* ((j (and (< i+1 l) (position-if-not
+ #'(lambda (c) (eql c #\\)) x :start i+1)))
+ (n (- (or j l) i)))
+ (cond
+ ((null j)
+ (issue-backslash (* 2 n)) (setf i l))
+ ((and (< j l) (eql (char x j) #\"))
+ (issue-backslash (1+ (* 2 n))) (issue #\") (setf i (1+ j)))
+ (t
+ (issue-backslash n) (setf i j)))))
+ (otherwise
+ (issue (char x i)) (setf i i+1))))))
+
+ (defun escape-windows-token (token &optional s)
+ "Escape a string TOKEN within double-quotes if needed
+for use within a MS Windows command-line, outputing to S."
+ (escape-token token :stream s :bad-chars #(#\space #\tab #\") :quote nil
+ :escaper 'escape-windows-token-within-double-quotes))
+
+ (defun escape-sh-token-within-double-quotes (x s &key (quote t))
+ "Escape a string TOKEN within double-quotes
+for use within a POSIX Bourne shell, outputing to S;
+omit the outer double-quotes if key argument :QUOTE is NIL"
+ (when quote (princ #\" s))
+ (loop :for c :across x :do
+ (when (find c "$`\\\"") (princ #\\ s))
+ (princ c s))
+ (when quote (princ #\" s)))
+
+ (defun easy-sh-character-p (x)
+ (or (alphanumericp x) (find x "+-_.,%@:/")))
+
+ (defun escape-sh-token (token &optional s)
+ "Escape a string TOKEN within double-quotes if needed
+for use within a POSIX Bourne shell, outputing to S."
+ (escape-token token :stream s :quote #\" :good-chars
+ #'easy-sh-character-p
+ :escaper 'escape-sh-token-within-double-quotes))
+
+ (defun escape-shell-token (token &optional s)
+ (cond
+ ((os-unix-p) (escape-sh-token token s))
+ ((os-windows-p) (escape-windows-token token s))))
+
+ (defun escape-command (command &optional s
+ (escaper 'escape-shell-token))
+ "Given a COMMAND as a list of tokens, return a string of the
+spaced, escaped tokens, using ESCAPER to escape."
+ (etypecase command
+ (string (output-string command s))
+ (list (with-output (s)
+ (loop :for first = t :then nil :for token :in command :do
+ (unless first (princ #\space s))
+ (funcall escaper token s))))))
+
+ (defun escape-windows-command (command &optional s)
+ "Escape a list of command-line arguments into a string suitable for parsing
+by CommandLineToArgv in MS Windows"
+ ;; http://msdn.microsoft.com/en-us/library/bb776391(v=vs.85).aspx
+ ;; http://msdn.microsoft.com/en-us/library/17w5ykft(v=vs.85).aspx
+ (escape-command command s 'escape-windows-token))
+
+ (defun escape-sh-command (command &optional s)
+ "Escape a list of command-line arguments into a string suitable for parsing
+by /bin/sh in POSIX"
+ (escape-command command s 'escape-sh-token))
+
+ (defun escape-shell-command (command &optional stream)
+ "Escape a command for the current operating system's shell"
+ (escape-command command stream 'escape-shell-token)))
+
+
+;;;; Slurping a stream, typically the output of another program
+(with-upgradability ()
+ (defgeneric slurp-input-stream (processor input-stream &key &allow-other-keys))
+
+ #-(or gcl2.6 genera)
+ (defmethod slurp-input-stream ((function function) input-stream &key &allow-other-keys)
+ (funcall function input-stream))
+
+ (defmethod slurp-input-stream ((list cons) input-stream &key &allow-other-keys)
+ (apply (first list) (cons input-stream (rest list))))
+
+ #-(or gcl2.6 genera)
+ (defmethod slurp-input-stream ((output-stream stream) input-stream
+ &key linewise prefix (element-type 'character) buffer-size &allow-other-keys)
+ (copy-stream-to-stream
+ input-stream output-stream
+ :linewise linewise :prefix prefix :element-type element-type :buffer-size buffer-size))
+
+ (defmethod slurp-input-stream ((x (eql 'string)) stream &key &allow-other-keys)
+ (declare (ignorable x))
+ (slurp-stream-string stream))
+
+ (defmethod slurp-input-stream ((x (eql :string)) stream &key &allow-other-keys)
+ (declare (ignorable x))
+ (slurp-stream-string stream))
+
+ (defmethod slurp-input-stream ((x (eql :lines)) stream &key count &allow-other-keys)
+ (declare (ignorable x))
+ (slurp-stream-lines stream :count count))
+
+ (defmethod slurp-input-stream ((x (eql :line)) stream &key (at 0) &allow-other-keys)
+ (declare (ignorable x))
+ (slurp-stream-line stream :at at))
+
+ (defmethod slurp-input-stream ((x (eql :forms)) stream &key count &allow-other-keys)
+ (declare (ignorable x))
+ (slurp-stream-forms stream :count count))
+
+ (defmethod slurp-input-stream ((x (eql :form)) stream &key (at 0) &allow-other-keys)
+ (declare (ignorable x))
+ (slurp-stream-form stream :at at))
+
+ (defmethod slurp-input-stream ((x (eql t)) stream &rest keys &key &allow-other-keys)
+ (declare (ignorable x))
+ (apply 'slurp-input-stream *standard-output* stream keys))
+
+ (defmethod slurp-input-stream ((pathname pathname) input
+ &key
+ (element-type *default-stream-element-type*)
+ (external-format *utf-8-external-format*)
+ (if-exists :rename-and-delete)
+ (if-does-not-exist :create)
+ buffer-size
+ linewise)
+ (with-output-file (output pathname
+ :element-type element-type
+ :external-format external-format
+ :if-exists if-exists
+ :if-does-not-exist if-does-not-exist)
+ (copy-stream-to-stream
+ input output
+ :element-type element-type :buffer-size buffer-size :linewise linewise)))
+
+ (defmethod slurp-input-stream (x stream
+ &key linewise prefix (element-type 'character) buffer-size
+ &allow-other-keys)
+ (declare (ignorable stream linewise prefix element-type buffer-size))
+ (cond
+ #+(or gcl2.6 genera)
+ ((functionp x) (funcall x stream))
+ #+(or gcl2.6 genera)
+ ((output-stream-p x)
+ (copy-stream-to-stream
+ input-stream output-stream
+ :linewise linewise :prefix prefix :element-type element-type :buffer-size buffer-size))
+ (t
+ (error "Invalid ~S destination ~S" 'slurp-input-stream x)))))
+
+
+;;;; ----- Running an external program -----
+;;; Simple variant of run-program with no input, and capturing output
+;;; On some implementations, may output to a temporary file...
+(with-upgradability ()
+ (define-condition subprocess-error (error)
+ ((code :initform nil :initarg :code :reader subprocess-error-code)
+ (command :initform nil :initarg :command :reader subprocess-error-command)
+ (process :initform nil :initarg :process :reader subprocess-error-process))
+ (:report (lambda (condition stream)
+ (format stream "Subprocess~@[ ~S~]~@[ run with command ~S~] exited with error~@[ code ~D~]"
+ (subprocess-error-process condition)
+ (subprocess-error-command condition)
+ (subprocess-error-code condition)))))
+
+ (defun run-program (command
+ &key output ignore-error-status force-shell
+ (element-type *default-stream-element-type*)
+ (external-format :default)
+ &allow-other-keys)
+ "Run program specified by COMMAND,
+either a list of strings specifying a program and list of arguments,
+or a string specifying a shell command (/bin/sh on Unix, CMD.EXE on Windows).
+
+Always call a shell (rather than directly execute the command)
+if FORCE-SHELL is specified.
+
+Signal a SUBPROCESS-ERROR if the process wasn't successful (exit-code 0),
+unless IGNORE-ERROR-STATUS is specified.
+
+If OUTPUT is either NIL or :INTERACTIVE, then
+return the exit status code of the process that was called.
+if it was NIL, the output is discarded;
+if it was :INTERACTIVE, the output and the input are inherited from the current process.
+
+Otherwise, OUTPUT should be a value that is a suitable first argument to
+SLURP-INPUT-STREAM. In this case, RUN-PROGRAM will create a temporary stream
+for the program output. The program output, in that stream, will be processed
+by SLURP-INPUT-STREAM, according to the using OUTPUT as the first argument.
+RUN-PROGRAM will return whatever SLURP-INPUT-STREAM returns. E.g., using
+:OUTPUT :STRING will have it return the entire output stream as a string. Use
+ELEMENT-TYPE and EXTERNAL-FORMAT for the stream passed to the OUTPUT processor."
+
+ ;; TODO: The current version does not honor :OUTPUT NIL on Allegro. Setting
+ ;; the :INPUT and :OUTPUT arguments to RUN-SHELL-COMMAND on ACL actually do
+ ;; what :OUTPUT :INTERACTIVE is advertised to do here. To get the behavior
+ ;; specified for :OUTPUT NIL, one would have to grab up the process output
+ ;; into a stream and then throw it on the floor. The consequences of
+ ;; getting this wrong seemed so much worse than having excess output that it
+ ;; is not currently implemented.
+
+ ;; TODO: specially recognize :output pathname ?
+ (declare (ignorable ignore-error-status element-type external-format))
+ #-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl lispworks mcl sbcl scl xcl)
+ (error "RUN-PROGRAM not implemented for this Lisp")
+ (labels (#+(or allegro clisp clozure cmu ecl (and lispworks os-unix) sbcl scl)
+ (run-program (command &key pipe interactive)
+ "runs the specified command (a list of program and arguments).
+ If using a pipe, returns two values: process and stream
+ If not using a pipe, returns one values: the process result;
+ also, inherits the output stream."
+ ;; NB: these implementations have unix vs windows set at compile-time.
+ (assert (not (and pipe interactive)))
+ (let* ((wait (not pipe))
+ #-(and clisp os-windows)
+ (command
+ (etypecase command
+ #+os-unix (string `("/bin/sh" "-c" ,command))
+ #+os-unix (list command)
+ #+os-windows
+ (string
+ ;; NB: We do NOT add cmd /c here. You might want to.
+ #+allegro command
+ ;; On ClozureCL for Windows, we assume you are using
+ ;; r15398 or later in 1.9 or later,
+ ;; so that bug 858 is fixed http://trac.clozure.com/ccl/ticket/858
+ #+clozure (cons "cmd" (strcat "/c " command))
+ ;; NB: On other Windows implementations, this is utterly bogus
+ ;; except in the most trivial cases where no quoting is needed.
+ ;; Use at your own risk.
+ #-(or allegro clozure) (list "cmd" "/c" command))
+ #+os-windows
+ (list
+ #+(or allegro clozure) (escape-windows-command command)
+ #-(or allegro clozure) command)))
+ #+(and clozure os-windows) (command (list command))
+ (process*
+ (multiple-value-list
+ #+allegro
+ (excl:run-shell-command
+ #+os-unix (coerce (cons (first command) command) 'vector)
+ #+os-windows command
+ :input nil
+ :output (and pipe :stream) :wait wait
+ #+os-windows :show-window #+os-windows (and (or (null output) pipe) :hide))
+ #+clisp
+ (flet ((run (f &rest args)
+ (apply f `(,@args :input ,(when interactive :terminal) :wait ,wait :output
+ ,(if pipe :stream :terminal)))))
+ (etypecase command
+ #+os-windows (run 'ext:run-shell-command command)
+ (list (run 'ext:run-program (car command)
+ :arguments (cdr command)))))
+ #+lispworks
+ (system:run-shell-command
+ (cons "/usr/bin/env" command) ; lispworks wants a full path.
+ :input interactive :output (or (and pipe :stream) interactive)
+ :wait wait :save-exit-status (and pipe t))
+ #+(or clozure cmu ecl sbcl scl)
+ (#+(or cmu ecl scl) ext:run-program
+ #+clozure ccl:run-program
+ #+sbcl sb-ext:run-program
+ (car command) (cdr command)
+ :input interactive :wait wait
+ :output (if pipe :stream t)
+ . #.(append
+ #+(or clozure cmu ecl sbcl scl) '(:error t)
+ ;; note: :external-format requires a recent SBCL
+ #+sbcl '(:search t :external-format external-format)))))
+ (process
+ #+allegro (if pipe (third process*) (first process*))
+ #+ecl (third process*)
+ #-(or allegro ecl) (first process*))
+ (stream
+ (when pipe
+ #+(or allegro lispworks ecl) (first process*)
+ #+clisp (first process*)
+ #+clozure (ccl::external-process-output process)
+ #+(or cmu scl) (ext:process-output process)
+ #+sbcl (sb-ext:process-output process))))
+ (values process stream)))
+ #+(or allegro clisp clozure cmu ecl (and lispworks os-unix) sbcl scl)
+ (process-result (process pipe)
+ (declare (ignorable pipe))
+ ;; 1- wait
+ #+(and clozure os-unix) (ccl::external-process-wait process)
+ #+(or cmu scl) (ext:process-wait process)
+ #+(and ecl os-unix) (ext:external-process-wait process)
+ #+sbcl (sb-ext:process-wait process)
+ ;; 2- extract result
+ #+allegro (if pipe (sys:reap-os-subprocess :pid process :wait t) process)
+ #+clisp process
+ #+clozure (nth-value 1 (ccl:external-process-status process))
+ #+(or cmu scl) (ext:process-exit-code process)
+ #+ecl (nth-value 1 (ext:external-process-status process))
+ #+lispworks (if pipe (system:pipe-exit-status process :wait t) process)
+ #+sbcl (sb-ext:process-exit-code process))
+ (check-result (exit-code process)
+ #+clisp
+ (setf exit-code
+ (typecase exit-code (integer exit-code) (null 0) (t -1)))
+ (unless (or ignore-error-status
+ (equal exit-code 0))
+ (error 'subprocess-error :command command :code exit-code :process process))
+ exit-code)
+ (use-run-program ()
+ #-(or abcl cormanlisp gcl (and lispworks os-windows) mcl mkcl xcl)
+ (let* ((interactive (eq output :interactive))
+ (pipe (and output (not interactive))))
+ (multiple-value-bind (process stream)
+ (run-program command :pipe pipe :interactive interactive)
+ (if (and output (not interactive))
+ (unwind-protect
+ (slurp-input-stream output stream)
+ (when stream (close stream))
+ (check-result (process-result process pipe) process))
+ (unwind-protect
+ (check-result
+ #+(or allegro lispworks) ; when not capturing, returns the exit code!
+ process
+ #-(or allegro lispworks) (process-result process pipe)
+ process))))))
+ (system-command (command)
+ (etypecase command
+ (string (if (os-windows-p) (format nil "cmd /c ~A" command) command))
+ (list (escape-shell-command
+ (if (os-unix-p) (cons "exec" command) command)))))
+ (redirected-system-command (command out)
+ (format nil (if (os-unix-p) "exec > ~*~A ; ~2:*~A" "~A > ~A")
+ (system-command command) (native-namestring out)))
+ (system (command &key interactive)
+ (declare (ignorable interactive))
+ #+(or abcl xcl) (ext:run-shell-command command)
+ #+allegro
+ (excl:run-shell-command
+ command
+ :input nil
+ :output nil
+ :error-output :output ; write STDERR to output, too
+ :wait t
+ #+os-windows :show-window #+os-windows (unless (or interactive (eq output t)) :hide))
+ #+(or clisp clozure cmu (and lispworks os-unix) sbcl scl)
+ (process-result (run-program command :pipe nil :interactive interactive) nil)
+ #+ecl (ext:system command)
+ #+cormanlisp (win32:system command)
+ #+gcl (lisp:system command)
+ #+(and lispworks os-windows)
+ (system:call-system-showing-output
+ command :show-cmd (or interactive (eq output t)) :prefix "" :output-stream nil)
+ #+mcl (ccl::with-cstrs ((%command command)) (_system %command))
+ #+mkcl (nth-value 2
+ (mkcl:run-program #+windows command #+windows ()
+ #-windows "/bin/sh" (list "-c" command)
+ :input nil :output nil)))
+ (call-system (command-string &key interactive)
+ (check-result (system command-string :interactive interactive) nil))
+ (use-system ()
+ (let ((interactive (eq output :interactive)))
+ (if (and output (not interactive))
+ (with-temporary-file (:pathname tmp :direction :output)
+ (call-system (redirected-system-command command tmp))
+ (with-open-file (stream tmp
+ :direction :input
+ :if-does-not-exist :error
+ :element-type element-type
+ #-gcl2.6 :external-format #-gcl2.6 external-format)
+ (slurp-input-stream output stream)))
+ (call-system (system-command command) :interactive interactive)))))
+ (if (and (not force-shell)
+ #+(or clisp ecl) ignore-error-status
+ #+(or abcl cormanlisp gcl (and lispworks os-windows) mcl mkcl xcl) nil)
+ (use-run-program)
+ (use-system)))))