From 4993cd552cc06b6889a2b1898448cb2687ed0b6c Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Mon, 30 May 2011 00:21:03 +0000 Subject: [PATCH] 1.0.48.33: --script bits and pieces * Leaving out the script name means to read the script from standard input. In this case the shebang line is _not_ handle -- simply because I ran out steam. (Our shebang line processing assumes a seekable stream.) * Stream errors on standard streams cause scripts to exit silently. lp#770222. * Scripts no longer us *TTY* for *TERMINAL-IO*, but make up a two-way stream from *STDIN* and *STDOUT*. Similarly for *DEBUG-IO* but using *STDERR*. This means that backtraces from errors are now neatly captured in the standard error stream. --- NEWS | 8 +++++++ doc/manual/start-stop.texinfo | 14 ++++++++++- src/code/early-impl.lisp | 4 ++++ src/code/load.lisp | 52 +++++++++++++++++++++-------------------- src/code/toplevel.lisp | 32 ++++++++++++++++++------- tests/script.test.sh | 40 ++++++++++++++++++++++++++++--- version.lisp-expr | 2 +- 7 files changed, 114 insertions(+), 38 deletions(-) diff --git a/NEWS b/NEWS index a12c740..f8eb769 100644 --- a/NEWS +++ b/NEWS @@ -22,6 +22,14 @@ changes relative to sbcl-1.0.48: * enhancement: SB-POSIX improvements: ** WNOHANG and WUNTRACED are exported. ** SYSCALL-ERROR now also provides the name of the failing system call. + * enhancement: --script improvements: + ** errors on standard input, output, and error streams are handled and + cause scripts to exit silently, making them easier to use in shell + pipelines. + ** backtraces from scripts now go to standard error instead of the + terminal even if one is available. + ** --script can be an argument, causing the script to be loaded from + standard input. * optimization: using a &REST argument only in APPLY or VALUES-LIST calls allows the compiler to automatically elide rest-list allocation so long as the call sites are in functions that the compiler knows cannot escape. diff --git a/doc/manual/start-stop.texinfo b/doc/manual/start-stop.texinfo index 6edab55..362ad40 100644 --- a/doc/manual/start-stop.texinfo +++ b/doc/manual/start-stop.texinfo @@ -234,7 +234,9 @@ error SBCL will invoke ldb (if present and enabled) or else exit. As a runtime option this is equivalent to @code{--noinform} @code{--disable-ldb} @code{--lose-on-corruption} @code{--end-runtime-options} @code{--script} @var{filename}. See the -description of @code{--script} as a toplevel option below. +description of @code{--script} as a toplevel option below. If there +are no other commandline arguments following @code{--script}, the +filename argument can be omitted. @item --help Print some basic information about SBCL, then exit. @@ -308,6 +310,16 @@ Causes the system to load the specified file instead of entering the read-eval-print-loop, and exit afterwards. If the file begins with a shebang line, it is ignored. +If there are no other command line arguments following, the filename +can be omitted: this causes the script to be loaded from standard +input instead. Shebang lines in standard input script are currently +@emph{not} ignored. + +In either case, if there is an unhandled error (eg. end of file, or a +broken pipe) on either standard input, standard output, or standard +error, the script silently exits with code 0. This allows eg. safely +piping output from SBCL to @code{head -n1} or similar. + @end table @node Initialization Files diff --git a/src/code/early-impl.lisp b/src/code/early-impl.lisp index 51fe656..c5319a0 100644 --- a/src/code/early-impl.lisp +++ b/src/code/early-impl.lisp @@ -17,6 +17,10 @@ ;;; slightly differently) elsewhere. (declaim (special *posix-argv* *core-string* + *stdin* + *stdout* + *stderr* + *tty* *read-only-space-free-pointer* sb!vm:*static-space-free-pointer* sb!vm::*current-catch-block* diff --git a/src/code/load.lisp b/src/code/load.lisp index 3b2a82f..dc85504 100644 --- a/src/code/load.lisp +++ b/src/code/load.lisp @@ -285,31 +285,33 @@ ;;; Returns T if the stream is a binary input stream with a FASL header. (defun fasl-header-p (stream &key errorp) - (let ((p (file-position stream))) - (unwind-protect - (let* ((header *fasl-header-string-start-string*) - (buffer (make-array (length header) :element-type '(unsigned-byte 8))) - (n 0)) - (flet ((scan () - (maybe-skip-shebang-line stream) - (setf n (read-sequence buffer stream)))) - (if errorp - (scan) - (or (ignore-errors (scan)) - ;; no a binary input stream - (return-from fasl-header-p nil)))) - (if (mismatch buffer header - :test #'(lambda (code char) (= code (char-code char)))) - ;; Immediate EOF is valid -- we want to match what - ;; CHECK-FASL-HEADER does... - (or (zerop n) - (when errorp - (error 'fasl-header-missing - :stream stream - :fhsss buffer - :expected header))) - t)) - (file-position stream p)))) + (unless (member (stream-element-type stream) '(character base-char)) + (let ((p (file-position stream))) + (unwind-protect + (let* ((header *fasl-header-string-start-string*) + (buffer (make-array (length header) :element-type '(unsigned-byte 8))) + (n 0)) + (flet ((scan () + (maybe-skip-shebang-line stream) + (setf n (read-sequence buffer stream)))) + (if errorp + (scan) + (or (ignore-errors (scan)) + ;; no a binary input stream + (return-from fasl-header-p nil)))) + (if (mismatch buffer header + :test #'(lambda (code char) (= code (char-code char)))) + ;; Immediate EOF is valid -- we want to match what + ;; CHECK-FASL-HEADER does... + (or (zerop n) + (when errorp + (error 'fasl-header-missing + :stream stream + :fhsss buffer + :expected header))) + t)) + (file-position stream p))))) + ;;;; LOAD-AS-FASL ;;;; diff --git a/src/code/toplevel.lisp b/src/code/toplevel.lisp index e4cd7be..c9986bf 100644 --- a/src/code/toplevel.lisp +++ b/src/code/toplevel.lisp @@ -294,14 +294,30 @@ any non-negative real number." (process-1 option))))) (defun process-script (script) - (let ((pathname (native-pathname script))) + (flet ((load-script (stream) + ;; Scripts don't need to be stylish or fast, but silence is usually a + ;; desirable quality... + (handler-bind (((or style-warning compiler-note) #'muffle-warning) + (stream-error (lambda (e) + ;; Shell-style. + (when (member (stream-error-stream e) + (list *stdout* *stdin* *stderr*)) + (quit))))) + ;; Let's not use the *TTY* for scripts, ok? Also, normally we use + ;; synonym streams, but in order to have the broken pipe/eof error + ;; handling right we want to bind them for scripts. + (let ((*terminal-io* (make-two-way-stream *stdin* *stdout*)) + (*debug-io* (make-two-way-stream *stdin* *stderr*)) + (*standard-input* *stdin*) + (*standard-output* *stdout*) + (*error-output* *stderr*)) + (load stream :verbose nil :print nil))))) (handling-end-of-the-world - (with-open-file (f pathname :element-type :default) - (sb!fasl::maybe-skip-shebang-line f) - ;; Scripts don't need to be stylish or fast, but silence is usually a - ;; desirable quality... - (handler-bind (((or style-warning compiler-note) #'muffle-warning)) - (load f :verbose nil :print nil)))))) + (if (eq t script) + (load-script *stdin*) + (with-open-file (f (native-pathname script) :element-type :default) + (sb!fasl::maybe-skip-shebang-line f) + (load-script f)))))) ;; Errors while processing the command line cause the system to QUIT, ;; instead of trying to go into the Lisp debugger, because trying to @@ -365,7 +381,7 @@ any non-negative real number." (setf disable-debugger t no-userinit t no-sysinit t - script (pop-option)) + script (if options (pop-option) t)) (return)) ((string= option "--sysinit") (pop-option) diff --git a/tests/script.test.sh b/tests/script.test.sh index 89693ff..e17761a 100644 --- a/tests/script.test.sh +++ b/tests/script.test.sh @@ -18,14 +18,20 @@ use_test_subdirectory tmpscript=$TEST_FILESTEM.lisp-script +tmpout=$TEST_FILESTEM.lisp-out +tmperr=$TEST_FILESTEM.lisp-err echo '(quit :unix-status 7)' > $tmpscript run_sbcl --script $tmpscript check_status_maybe_lose "--script exit status from QUIT" $? 7 "(quit status good)" echo '(error "oops")' > $tmpscript -run_sbcl --script $tmpscript 2> /dev/null +run_sbcl --script $tmpscript 1> $tmpout 2> $tmperr check_status_maybe_lose "--script exit status from ERROR" $? 1 "(error implies 1)" +grep BACKTRACE $tmpout > /dev/null +check_status_maybe_lose "--script backtrace not to stdout" $? 1 "(ok)" +grep BACKTRACE $tmperr > /dev/null +check_status_maybe_lose "--script backtrace to stderr" $? 0 "(ok)" echo 'nil'> $tmpscript run_sbcl --script $tmpscript @@ -36,12 +42,40 @@ cat > $tmpscript < $tmpscript < $tmpout 2> $tmperr +check_status_maybe_lose "--script exit status when stdin closed" $? 0 "(as given)" +if [ -s $tmperr ] || [ "ONE" != `cat $tmpout` ] +then + echo "--script outputs wrong" + exit $EXIT_LOSE +fi + +cat > $tmpscript < $tmperr | head -n1 > $tmpout +check_status_maybe_lose "--script exit status when stdout closed" $? 0 "(as given)" +if [ -s $tmperr ] || [ "foo" != `cat $tmpout` ] +then + echo "--script unexpected error output" + exit $EXIT_LOSE +fi +echo '(write-line "Ok!")' | run_sbcl --script 1>$tmpout 2>$tmperr +check_status_maybe_lose "--script exit status script from stdin" $? 0 "(ok)" +if [ -s $tmperr ] || [ "Ok!" != `cat $tmpout` ] +then + echo "--script unexpected error output" + exit $EXIT_LOSE +fi + +rm -f $tmpscript $tmpout $tmperr exit $EXIT_TEST_WIN diff --git a/version.lisp-expr b/version.lisp-expr index 2207dc1..fa4e04c 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -20,4 +20,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"1.0.48.32" +"1.0.48.33" -- 1.7.10.4