Commit 2c31e053 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau

2.26.137: API cleanup in preparation for release

Rename RUN-PROGRAM/ to RUN-PROGRAM.
Can't export it from ASDF because it causes a clash in SB-GROVEL.

Rename SUB-OBJECT and :PATH to ACCESS-AT and :AT.

Get rid of TRANSLATE-OUTPUT-P.
Instead, check whether the component's BUILD-OPERATION
is the same as the current operation.
parent a3f8080e
...@@ -15,7 +15,7 @@ ...@@ -15,7 +15,7 @@
:licence "MIT" :licence "MIT"
:description "Another System Definition Facility" :description "Another System Definition Facility"
:long-description "ASDF builds Common Lisp software organized into defined systems." :long-description "ASDF builds Common Lisp software organized into defined systems."
:version "2.26.136" ;; to be automatically updated by make bump-version :version "2.26.137" ;; to be automatically updated by make bump-version
:depends-on () :depends-on ()
:components ((:module "build" :components ((:file "asdf")))) :components ((:module "build" :components ((:file "asdf"))))
:in-order-to (#+asdf2.27 (compile-op (monolithic-load-concatenated-source-op asdf/defsystem)))) :in-order-to (#+asdf2.27 (compile-op (monolithic-load-concatenated-source-op asdf/defsystem))))
...@@ -38,7 +38,6 @@ ...@@ -38,7 +38,6 @@
:class :bundle-system :class :bundle-system
:build-operation monolithic-concatenate-source-op :build-operation monolithic-concatenate-source-op
:bundle-pathname "build/asdf" :bundle-pathname "build/asdf"
:translate-output-p nil
:serial t :serial t
:around-compile call-without-redefinition-warnings ;; be the same as asdf-driver :around-compile call-without-redefinition-warnings ;; be the same as asdf-driver
:depends-on (:asdf/header :asdf-driver) :depends-on (:asdf/header :asdf-driver)
......
...@@ -113,12 +113,16 @@ call that function where you would otherwise have loaded and configured A-B-L.") ...@@ -113,12 +113,16 @@ call that function where you would otherwise have loaded and configured A-B-L.")
;;;; run-shell-command ;;;; run-shell-command
;; ;;
;; WARNING! The function below is dysfunctional and deprecated. ;; WARNING! The function below is dysfunctional and deprecated.
;; Please use asdf/run-program:run-program/ instead. ;; Please use asdf/run-program:run-program instead.
;;
(defun* run-shell-command (control-string &rest args) (defun* run-shell-command (control-string &rest args)
"Interpolate ARGS into CONTROL-STRING as if by FORMAT, and "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and
synchronously execute the result using a Bourne-compatible shell, with synchronously execute the result using a Bourne-compatible shell, with
output to *VERBOSE-OUT*. Returns the shell's exit code." output to *VERBOSE-OUT*. Returns the shell's exit code.
PLEASE DO NOT USE.
Deprecated function, for backward-compatibility only.
Please use ASDF-DRIVER:RUN-PROGRAM instead."
(let ((command (apply 'format nil control-string args))) (let ((command (apply 'format nil control-string args)))
(asdf-message "; $ ~A~%" command) (asdf-message "; $ ~A~%" command)
(run-program/ command :force-shell t :ignore-error-status t :output *verbose-out*))) (run-program command :force-shell t :ignore-error-status t :output *verbose-out*)))
...@@ -18,7 +18,6 @@ ...@@ -18,7 +18,6 @@
#+ecl #:make-build #+ecl #:make-build
#:register-pre-built-system #:register-pre-built-system
#:build-args #:name-suffix #:prologue-code #:epilogue-code #:static-library #:build-args #:name-suffix #:prologue-code #:epilogue-code #:static-library
#:component-translate-output-p #:translate-output-p
#:component-bundle-pathname #:bundle-pathname #:component-bundle-pathname #:bundle-pathname
#:component-entry-point #:entry-point)) #:component-entry-point #:entry-point))
(in-package :asdf/bundle) (in-package :asdf/bundle)
...@@ -80,15 +79,11 @@ ...@@ -80,15 +79,11 @@
((bundle-type :initform :program))) ((bundle-type :initform :program)))
(defgeneric* component-bundle-pathname (component)) (defgeneric* component-bundle-pathname (component))
(defgeneric* component-translate-output-p (component))
(defgeneric* component-entry-point (component)) (defgeneric* component-entry-point (component))
(defmethod component-bundle-pathname ((c component)) (defmethod component-bundle-pathname ((c component))
(declare (ignorable c)) (declare (ignorable c))
nil) nil)
(defmethod component-translate-output-p ((c component))
(declare (ignorable c))
t)
(defmethod component-entry-point ((c component)) (defmethod component-entry-point ((c component))
(declare (ignorable c)) (declare (ignorable c))
nil) nil)
...@@ -97,9 +92,7 @@ ...@@ -97,9 +92,7 @@
((bundle-pathname ((bundle-pathname
:initform nil :initarg :bundle-pathname :accessor component-bundle-pathname) :initform nil :initarg :bundle-pathname :accessor component-bundle-pathname)
(entry-point (entry-point
:initform nil :initarg :entry-point :accessor component-entry-point) :initform nil :initarg :entry-point :accessor component-entry-point)))
(translate-output-p
:initform nil :initarg :translate-output-p :accessor component-translate-output-p)))
(defun* bundle-pathname-type (bundle-type) (defun* bundle-pathname-type (bundle-type)
(etypecase bundle-type (etypecase bundle-type
...@@ -121,7 +114,7 @@ ...@@ -121,7 +114,7 @@
(format nil "~A~@[~A~]" (component-name c) (slot-value o 'name-suffix)))) (format nil "~A~@[~A~]" (component-name c) (slot-value o 'name-suffix))))
(type (bundle-pathname-type bundle-type))) (type (bundle-pathname-type bundle-type)))
(values (list (subpathname (component-pathname c) name :type type)) (values (list (subpathname (component-pathname c) name :type type))
(not (component-translate-output-p c))))))) (eq (type-of o) (component-build-operation c)))))))
(defmethod output-files ((o bundle-op) (c system)) (defmethod output-files ((o bundle-op) (c system))
(bundle-output-files o c)) (bundle-output-files o c))
......
...@@ -90,8 +90,8 @@ ...@@ -90,8 +90,8 @@
(cons (cons
(ecase (first form) (ecase (first form)
((:read-file-form) ((:read-file-form)
(destructuring-bind (subpath &key (path 0)) (rest form) (destructuring-bind (subpath &key (at 0)) (rest form)
(safe-read-file-form (subpathname pathname subpath) :path path))))))) (safe-read-file-form (subpathname pathname subpath) :at at)))))))
;;; Main parsing function ;;; Main parsing function
......
This diff is collapsed.
;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; coding: utf-8 -*- ;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; coding: utf-8 -*-
;;; This is ASDF 2.26.136: Another System Definition Facility. ;;; This is ASDF 2.26.137: Another System Definition Facility.
;;; ;;;
;;; Feedback, bug reports, and patches are all welcome: ;;; Feedback, bug reports, and patches are all welcome:
;;; please mail to <asdf-devel@common-lisp.net>. ;;; please mail to <asdf-devel@common-lisp.net>.
......
...@@ -33,7 +33,7 @@ ...@@ -33,7 +33,7 @@
#:input-files #:output-files #:output-file #:perform #:input-files #:output-files #:output-file #:perform
#:operation-done-p #:explain #:component-sibling-dependencies #:operation-done-p #:explain #:component-sibling-dependencies
#:needed-in-image-p #:needed-in-image-p
#:run-program/ ; the recommended replacement for run-shell-command ;; #:run-program ; we can't export it, because SB-GROVEL :use's both ASDF and SB-EXT.
#:component-load-dependencies #:run-shell-command ; deprecated, do not use #:component-load-dependencies #:run-shell-command ; deprecated, do not use
#:bundle-op #:precompiled-system #:compiled-file #:bundle-system #:bundle-op #:precompiled-system #:compiled-file #:bundle-system
#+ecl #:make-build #+ecl #:make-build
......
...@@ -282,7 +282,7 @@ a CL pathname satisfying all the specified constraints as per ENSURE-PATHNAME" ...@@ -282,7 +282,7 @@ a CL pathname satisfying all the specified constraints as per ENSURE-PATHNAME"
#+cormanlisp (pathname (pl::get-current-directory)) ;; Q: what type does it return? #+cormanlisp (pathname (pl::get-current-directory)) ;; Q: what type does it return?
#+ecl (ext:getcwd) #+ecl (ext:getcwd)
#+gcl (parse-native-namestring ;; this is a joke. Isn't there a better way? #+gcl (parse-native-namestring ;; this is a joke. Isn't there a better way?
(first (symbol-call :asdf/driver :run-program/ '("/bin/pwd") :output :lines))) (first (symbol-call :asdf/driver :run-program '("/bin/pwd") :output :lines)))
#+genera *default-pathname-defaults* ;; on a Lisp OS, it *is* canonical! #+genera *default-pathname-defaults* ;; on a Lisp OS, it *is* canonical!
#+lispworks (system:current-directory) #+lispworks (system:current-directory)
#+mkcl (mk-ext:getcwd) #+mkcl (mk-ext:getcwd)
......
;;;; ------------------------------------------------------------------------- ;;;; -------------------------------------------------------------------------
;;;; run-program/ initially from xcvb-driver. ;;;; run-program initially from xcvb-driver.
(asdf/package:define-package :asdf/run-program (asdf/package:define-package :asdf/run-program
(:recycle :asdf/run-program :xcvb-driver) (:recycle :asdf/run-program :xcvb-driver)
...@@ -10,9 +10,9 @@ ...@@ -10,9 +10,9 @@
#:escape-windows-token #:escape-windows-command #:escape-windows-token #:escape-windows-command
#:escape-token #:escape-command #:escape-token #:escape-command
;;; run-program/ ;;; run-program
#:slurp-input-stream #:slurp-input-stream
#:run-program/ #:run-program
#:subprocess-error #:subprocess-error
#:subprocess-error-code #:subprocess-error-command #:subprocess-error-process #:subprocess-error-code #:subprocess-error-command #:subprocess-error-process
)) ))
...@@ -145,9 +145,10 @@ by /bin/sh in POSIX" ...@@ -145,9 +145,10 @@ by /bin/sh in POSIX"
#-(or gcl<2.7 genera) #-(or gcl<2.7 genera)
(defmethod slurp-input-stream ((output-stream stream) input-stream (defmethod slurp-input-stream ((output-stream stream) input-stream
&key (element-type 'character) &allow-other-keys) &key linewise prefix (element-type 'character) buffer-size &allow-other-keys)
(copy-stream-to-stream (copy-stream-to-stream
input-stream output-stream :element-type element-type)) 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) (defmethod slurp-input-stream ((x (eql 'string)) stream &key &allow-other-keys)
(declare (ignorable x)) (declare (ignorable x))
...@@ -157,29 +158,34 @@ by /bin/sh in POSIX" ...@@ -157,29 +158,34 @@ by /bin/sh in POSIX"
(declare (ignorable x)) (declare (ignorable x))
(slurp-stream-string stream)) (slurp-stream-string stream))
(defmethod slurp-input-stream ((x (eql :lines)) stream &rest keys &key &allow-other-keys) (defmethod slurp-input-stream ((x (eql :lines)) stream &key count &allow-other-keys)
(declare (ignorable x)) (declare (ignorable x))
(apply 'slurp-stream-lines stream keys)) (slurp-stream-lines stream :count count))
(defmethod slurp-input-stream ((x (eql :line)) stream &rest keys &key &allow-other-keys) (defmethod slurp-input-stream ((x (eql :line)) stream &key (at 0) &allow-other-keys)
(declare (ignorable x)) (declare (ignorable x))
(apply 'slurp-stream-line stream keys)) (slurp-stream-line stream :at at))
(defmethod slurp-input-stream ((x (eql :forms)) stream &rest keys &key &allow-other-keys) (defmethod slurp-input-stream ((x (eql :forms)) stream &key count &allow-other-keys)
(declare (ignorable x)) (declare (ignorable x))
(apply 'slurp-stream-forms stream keys)) (slurp-stream-forms stream :count count))
(defmethod slurp-input-stream ((x (eql :form)) stream &rest keys &key &allow-other-keys) (defmethod slurp-input-stream ((x (eql :form)) stream &key (at 0) &allow-other-keys)
(declare (ignorable x)) (declare (ignorable x))
(apply 'slurp-stream-form stream keys)) (slurp-stream-form stream :at at))
(defmethod slurp-input-stream (x stream &key (element-type 'character) &allow-other-keys) (defmethod slurp-input-stream (x stream
(declare (ignorable stream element-type)) &key linewise prefix (element-type 'character) buffer-size
&allow-other-keys)
(declare (ignorable linewise prefix element-type buffer-size))
(cond (cond
#+(or gcl<2.7 genera) #+(or gcl<2.7 genera)
((functionp x) (funcall x stream)) ((functionp x) (funcall x stream))
#+(or gcl<2.7 genera) #+(or gcl<2.7 genera)
((output-stream-p x) (copy-stream-to-stream stream x :element-type element-type)) ((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 (t
(error "Invalid ~S destination ~S" 'slurp-input-stream x)))) (error "Invalid ~S destination ~S" 'slurp-input-stream x))))
...@@ -198,7 +204,7 @@ by /bin/sh in POSIX" ...@@ -198,7 +204,7 @@ by /bin/sh in POSIX"
(subprocess-error-command condition) (subprocess-error-command condition)
(subprocess-error-code condition))))) (subprocess-error-code condition)))))
(defun* run-program/ (command (defun* run-program (command
&key output ignore-error-status force-shell &key output ignore-error-status force-shell
(element-type *default-stream-element-type*) (element-type *default-stream-element-type*)
(external-format :default) (external-format :default)
...@@ -217,7 +223,7 @@ Return the exit status code of the process that was called. ...@@ -217,7 +223,7 @@ Return the exit status code of the process that was called.
Use ELEMENT-TYPE and EXTERNAL-FORMAT for the stream passed to the OUTPUT processor." Use ELEMENT-TYPE and EXTERNAL-FORMAT for the stream passed to the OUTPUT processor."
(declare (ignorable ignore-error-status element-type external-format)) (declare (ignorable ignore-error-status element-type external-format))
#-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl lispworks mcl sbcl scl xcl) #-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl lispworks mcl sbcl scl xcl)
(error "RUN-PROGRAM/ not implemented for this Lisp") (error "RUN-PROGRAM not implemented for this Lisp")
(labels (#+(or allegro clisp clozure cmu ecl (and lispworks os-unix) sbcl scl) (labels (#+(or allegro clisp clozure cmu ecl (and lispworks os-unix) sbcl scl)
(run-program (command &key pipe interactive) (run-program (command &key pipe interactive)
"runs the specified command (a list of program and arguments). "runs the specified command (a list of program and arguments).
......
...@@ -153,16 +153,27 @@ Useful for portably flushing I/O before user input or program exit." ...@@ -153,16 +153,27 @@ Useful for portably flushing I/O before user input or program exit."
;;; Simple Whole-Stream processing ;;; Simple Whole-Stream processing
(defun* copy-stream-to-stream (input output &key (element-type 'character) (buffer-size 8192))
"Copy the contents of the INPUT stream into the OUTPUT stream, (defun* copy-stream-to-stream (input output &key element-type buffer-size linewise prefix)
using WRITE-SEQUENCE and a sensibly sized buffer." "Copy the contents of the INPUT stream into the OUTPUT stream.
If LINEWISE is true, then read and copy the stream line by line, with an optional PREFIX.
Otherwise, using WRITE-SEQUENCE using a buffer of size BUFFER-SIZE."
(with-open-stream (input input) (with-open-stream (input input)
(if linewise
(loop :for (line eof) = (multiple-value-list (read-line input nil nil))
:while line :do
(when prefix (princ prefix output))
(princ line output)
(unless eof (terpri output))
(finish-output output)
(when eof (return)))
(loop (loop
:for buffer = (make-array (list buffer-size) :element-type element-type) :with buffer-size = (or buffer-size 8192)
:for buffer = (make-array (list buffer-size) :element-type (or element-type 'character))
:for end = (read-sequence buffer input) :for end = (read-sequence buffer input)
:until (zerop end) :until (zerop end)
:do (write-sequence buffer output :end end) :do (write-sequence buffer output :end end)
(when (< end buffer-size) (return))))) (when (< end buffer-size) (return))))))
(defun* concatenate-files (inputs output) (defun* concatenate-files (inputs output)
(with-open-file (o output :element-type '(unsigned-byte 8) (with-open-file (o output :element-type '(unsigned-byte 8)
...@@ -172,18 +183,6 @@ using WRITE-SEQUENCE and a sensibly sized buffer." ...@@ -172,18 +183,6 @@ using WRITE-SEQUENCE and a sensibly sized buffer."
:direction :input :if-does-not-exist :error) :direction :input :if-does-not-exist :error)
(copy-stream-to-stream i o :element-type '(unsigned-byte 8)))))) (copy-stream-to-stream i o :element-type '(unsigned-byte 8))))))
(defun* copy-stream-to-stream-line-by-line (input output &key prefix)
"Copy the contents of the INPUT stream into the OUTPUT stream,
reading contents line by line."
(with-open-stream (input input)
(loop :for (line eof) = (multiple-value-list (read-line input nil nil))
:while line :do
(when prefix (princ prefix output))
(princ line output)
(unless eof (terpri output))
(finish-output output)
(when eof (return)))))
(defun* slurp-stream-string (input &key (element-type 'character)) (defun* slurp-stream-string (input &key (element-type 'character))
"Read the contents of the INPUT stream as a string" "Read the contents of the INPUT stream as a string"
(with-open-stream (input input) (with-open-stream (input input)
...@@ -201,9 +200,9 @@ Read no more than COUNT lines." ...@@ -201,9 +200,9 @@ Read no more than COUNT lines."
(read-line input nil nil)) (read-line input nil nil))
:while l :collect l))) :while l :collect l)))
(defun* slurp-stream-line (input &key (path 0)) (defun* slurp-stream-line (input &key (at 0))
"Read the contents of the INPUT stream as a list of lines, "Read the contents of the INPUT stream as a list of lines,
then return the SUB-OBJECT of that list of lines following the PATH. then return the ACCESS-AT of that list of lines using the AT specifier.
PATH defaults to 0, i.e. return the first line. PATH defaults to 0, i.e. return the first line.
PATH is typically an integer, or a list of an integer and a function. PATH is typically an integer, or a list of an integer and a function.
If PATH is NIL, it will return all the lines in the file. If PATH is NIL, it will return all the lines in the file.
...@@ -211,13 +210,7 @@ If PATH is NIL, it will return all the lines in the file. ...@@ -211,13 +210,7 @@ If PATH is NIL, it will return all the lines in the file.
The stream will not be read beyond the Nth lines, The stream will not be read beyond the Nth lines,
where N is the index specified by path where N is the index specified by path
if path is either an integer or a list that starts with an integer." if path is either an integer or a list that starts with an integer."
(let* ((count (cond (access-at (slurp-stream-lines input :count (access-at-count at)) at))
((integerp path)
(1+ path))
((and (consp path) (integerp (first path)))
(1+ (first path)))))
(forms (slurp-stream-lines input :count count)))
(sub-object forms path)))
(defun* slurp-stream-forms (input &key count) (defun* slurp-stream-forms (input &key count)
"Read the contents of the INPUT stream as a list of forms, "Read the contents of the INPUT stream as a list of forms,
...@@ -235,25 +228,19 @@ BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof" ...@@ -235,25 +228,19 @@ BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof"
(read-preserving-whitespace input nil eof)) (read-preserving-whitespace input nil eof))
:until (eq form eof) :collect form)) :until (eq form eof) :collect form))
(defun* slurp-stream-form (input &key (path 0)) (defun* slurp-stream-form (input &key (at 0))
"Read the contents of the INPUT stream as a list of forms, "Read the contents of the INPUT stream as a list of forms,
then return the SUB-OBJECT of these forms following the PATH. then return the ACCESS-AT of these forms following the AT.
PATH defaults to 0, i.e. return the first form. AT defaults to 0, i.e. return the first form.
PATH is typically a list of integers. AT is typically a list of integers.
If PATH is NIL, it will return all the forms in the file. If AT is NIL, it will return all the forms in the file.
The stream will not be read beyond the Nth form, The stream will not be read beyond the Nth form,
where N is the index specified by path, where N is the index specified by path,
if path is either an integer or a list that starts with an integer. if path is either an integer or a list that starts with an integer.
BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof" BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof"
(let* ((count (cond (access-at (slurp-stream-forms input :count (access-at-count at)) at))
((integerp path)
(1+ path))
((and (consp path) (integerp (first path)))
(1+ (first path)))))
(forms (slurp-stream-forms input :count count)))
(sub-object forms path)))
(defun* read-file-string (file &rest keys) (defun* read-file-string (file &rest keys)
"Open FILE with option KEYS, read its contents as a string" "Open FILE with option KEYS, read its contents as a string"
...@@ -272,13 +259,13 @@ BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof" ...@@ -272,13 +259,13 @@ BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof"
#'(lambda (input) (slurp-stream-forms input :count count)) #'(lambda (input) (slurp-stream-forms input :count count))
(remove-plist-key :count keys))) (remove-plist-key :count keys)))
(defun* read-file-form (file &rest keys &key (path 0) &allow-other-keys) (defun* read-file-form (file &rest keys &key (at 0) &allow-other-keys)
"Open input FILE with option KEYS (except path), "Open input FILE with option KEYS (except AT),
and read its contents as per SLURP-STREAM-FORM with given PATH. and read its contents as per SLURP-STREAM-FORM with given AT specifier.
BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof" BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof"
(apply 'call-with-input-file file (apply 'call-with-input-file file
#'(lambda (input) (slurp-stream-form input :path path)) #'(lambda (input) (slurp-stream-form input :at at))
(remove-plist-key :path keys))) (remove-plist-key :at keys)))
(defun* safe-read-file-form (pathname &rest keys &key (package :cl) &allow-other-keys) (defun* safe-read-file-form (pathname &rest keys &key (package :cl) &allow-other-keys)
"Reads the specified form from the top of a file using a safe standardized syntax. "Reads the specified form from the top of a file using a safe standardized syntax.
......
...@@ -5,5 +5,4 @@ ...@@ -5,5 +5,4 @@
:build-operation program-op :build-operation program-op
:entry-point "hello:entry-point" :entry-point "hello:entry-point"
:depends-on (:asdf-driver) :depends-on (:asdf-driver)
:translate-output-p nil
:components ((:file "hello"))) :components ((:file "hello")))
...@@ -165,7 +165,7 @@ Some constraints: ...@@ -165,7 +165,7 @@ Some constraints:
(defun touch-file (file &key (offset 0) timestamp) (defun touch-file (file &key (offset 0) timestamp)
(let ((timestamp (or timestamp (+ offset (get-universal-time))))) (let ((timestamp (or timestamp (+ offset (get-universal-time)))))
(multiple-value-bind (sec min hr day month year) (decode-universal-time timestamp #+gcl<2.7 -5) (multiple-value-bind (sec min hr day month year) (decode-universal-time timestamp #+gcl<2.7 -5)
(acall :run-program/ (acall :run-program
`("touch" "-t" ,(format nil "~4,'0D~2,'0D~2,'0D~2,'0D~2,'0D.~2,'0D" `("touch" "-t" ,(format nil "~4,'0D~2,'0D~2,'0D~2,'0D~2,'0D.~2,'0D"
year month day hr min sec) year month day hr min sec)
,(namestring file))) ,(namestring file)))
......
...@@ -22,8 +22,7 @@ ...@@ -22,8 +22,7 @@
(assert-equal (assert-equal
(output-file mcso sys) (output-file mcso sys)
(apply-output-translations (apply-output-translations
(subpathname *test-directory* (resolve-output "asdf/test/test-concatenate-source.all-systems.lisp")))
"test-concatenate-source.all-systems.lisp")))
(assert-equal (assert-equal
(output-files mcso sys) (output-files mcso sys)
(input-files mccso sys)) (input-files mccso sys))
......
...@@ -10,7 +10,7 @@ ...@@ -10,7 +10,7 @@
(defparameter asd2 (subpathname tmp "test-multiple-too.asd")) (defparameter asd2 (subpathname tmp "test-multiple-too.asd"))
(defparameter file4 (test-fasl "file4")) (defparameter file4 (test-fasl "file4"))
(setf *central-registry* `(,*test-directory* ,tmp)) (setf *central-registry* `(,*test-directory* ,tmp))
(run-program/ (run-program
(format nil "/bin/ln -sf ~A ~A 2>&1" (format nil "/bin/ln -sf ~A ~A 2>&1"
(native-namestring asd) (native-namestring asd)
(native-namestring asd2))) (native-namestring asd2)))
......
...@@ -28,15 +28,15 @@ ...@@ -28,15 +28,15 @@
(initialize-source-registry `(:source-registry :ignore-inherited-configuration)) (initialize-source-registry `(:source-registry :ignore-inherited-configuration))
(delete-file-if-exists exe) (delete-file-if-exists exe)
(run-program/ (run-program
(symbol-call :lisp-invocation :lisp-invocation-arglist (symbol-call :lisp-invocation :lisp-invocation-arglist
:load (native-namestring (subpathname *test-directory* "make-hello-world.lisp")))) :load (native-namestring (subpathname *test-directory* "make-hello-world.lisp"))))
(assert (probe-file* exe)) (assert (probe-file* exe))
(assert-equal (run-program/ `(,(native-namestring exe)) :output :lines) (assert-equal (run-program `(,(native-namestring exe)) :output :lines)
'("hello, world")) '("hello, world"))
(assert-equal (run-program/ `(,(native-namestring exe) "a" "b c" "d") :output :lines) (assert-equal (run-program `(,(native-namestring exe) "a" "b c" "d") :output :lines)
'("hello, world" '("hello, world"
"You passed 3 arguments:" "You passed 3 arguments:"
" \"a\"" " \"a\""
......
;;; -*- Lisp -*- ;;; -*- Lisp -*-
;;; TODO: write tests for run-program instead -- and/or
;;; TODO: write tests for run-program/ instead -- and/or
;;; import those from the original xcvb-driver-test ;;; import those from the original xcvb-driver-test
;;; test asdf run-shell-command function ;;; test asdf run-shell-command function
(progn (when (asdf::os-unix-p)
(when (asdf::os-unix-p)
(setf asdf::*verbose-out* nil) (setf asdf::*verbose-out* nil)
(assert-equal 1 (asdf:run-shell-command "false")) (assert-equal 1 (run-shell-command "false"))
(assert-equal 0 (asdf:run-shell-command "true")) (assert-equal 0 (run-shell-command "true"))
(unless (< 0 (asdf:run-shell-command "./bad-shell-command")) (unless (< 0 (asdf:run-shell-command "./bad-shell-command"))
(error "Failed to capture exit status indicating shell command failure.")) (error "Failed to capture exit status indicating shell command failure."))
(unless (equal 0 (asdf:run-shell-command "./good-shell-command")) (unless (equal 0 (run-shell-command "./good-shell-command"))
(error "Failed to capture exit status indicating shell command failure.")) (error "Failed to capture exit status indicating shell command failure."))
;; NB1: run-shell-command is deprecated. Use run-program/ instead. ;; NB1: run-shell-command is deprecated. Use run-program instead.
;; NB2: we do NOT support stderr capture to *verbose-out* anymore in run-shell-command. ;; NB2: we do NOT support stderr capture to *verbose-out* anymore in run-shell-command.
;; If you want 2>&1 redirection, you know where to find it. ;; If you want 2>&1 redirection, you know where to find it.
(assert-equal '("ok 1") (asdf::run-program/ "echo ok 1" :output :lines)) (assert-equal '("ok 1") (run-program "echo ok 1" :output :lines))
(assert-equal '("ok 1") (asdf::run-program/ '("echo" "ok 1") :output :lines)) (assert-equal '("ok 1") (run-program '("echo" "ok 1") :output :lines))
))
t)
...@@ -35,7 +35,7 @@ ...@@ -35,7 +35,7 @@
;; "2.345.6" would be a development version in the official upstream ;; "2.345.6" would be a development version in the official upstream
;; "2.345.0.7" would be your seventh local modification of official release 2.345 ;; "2.345.0.7" would be your seventh local modification of official release 2.345
;; "2.345.6.7" would be your seventh local modification of development version 2.345.6 ;; "2.345.6.7" would be your seventh local modification of development version 2.345.6
(asdf-version "2.26.136") (asdf-version "2.26.137")
(existing-asdf (find-class (find-symbol* :component :asdf nil) nil)) (existing-asdf (find-class (find-symbol* :component :asdf nil) nil))
(existing-version *asdf-version*) (existing-version *asdf-version*)
(already-there (equal asdf-version existing-version)) (already-there (equal asdf-version existing-version))
......
...@@ -19,7 +19,7 @@ ...@@ -19,7 +19,7 @@
#:earlier-stamp #:stamps-earliest #:earliest-stamp #:earlier-stamp #:stamps-earliest #:earliest-stamp
#:later-stamp #:stamps-latest #:latest-stamp #:latest-stamp-f #:later-stamp #:stamps-latest #:latest-stamp #:latest-stamp-f
#:list-to-hash-set ;; hash-table #:list-to-hash-set ;; hash-table
#:ensure-function #:sub-object ;; functions #:ensure-function #:access-at #:access-at-count ;; functions
#:call-function #:call-functions #:register-hook-function #:call-function #:call-functions #:register-hook-function
#:match-condition-p #:match-any-condition-p ;; conditions #:match-condition-p #:match-any-condition-p ;; conditions
#:call-with-muffled-conditions #:with-muffled-conditions #:call-with-muffled-conditions #:with-muffled-conditions
...@@ -262,23 +262,37 @@ and EVAL that in a (FUNCTION ...) context." ...@@ -262,23 +262,37 @@ and EVAL that in a (FUNCTION ...) context."
(let ((*package* (find-package package))) (let ((*package* (find-package package)))
(read-from-string fun)))))))) (read-from-string fun))))))))
(defun* sub-object (object path) (defun* access-at (object at)
"Given an OBJECT and a PATH, list of successive accessors, "Given an OBJECT and an AT specifier, list of successive accessors,
call each accessor on the result of the previous calls. call each accessor on the result of the previous calls.
An accessor may be an integer, meaning a call to ELT, An accessor may be an integer, meaning a call to ELT,
a function or symbol, meaning itself, a keyword, meaning a call to GETF,
or a list of a function and arguments, interpreted as per ENSURE-FUNCTION. NIL, meaning identity,
As a degenerate case, the PATH may be an atom of a single such accessor a function or other symbol, meaning itself,
or a list of a function designator and arguments, interpreted as per ENSURE-FUNCTION.
As a degenerate case, the AT specifier may be an atom of a single such accessor
instead of a list." instead of a list."
(flet ((access (object accessor) (flet ((access (object accessor)
(etypecase accessor (etypecase accessor
(function (funcall accessor object))
(integer (elt object accessor)) (integer (elt object accessor))
((or function symbol) (funcall accessor object)) (keyword (getf object accessor))
(null object)
(symbol (funcall accessor object))
(cons (funcall (ensure-function accessor) object))))) (cons (funcall (ensure-function accessor) object)))))
(if (listp path) (if (listp at)
(dolist (accessor path object) (dolist (accessor at object)
(setf object (access object accessor))) (setf object (access object accessor)))
(access object path)))) (access object at))))
(defun* access-at-count (at)
"From an AT specification, extract a COUNT of maximum number
of sub-objects to read as per ACCESS-AT"
(cond
((integerp at)
(1+ at))
((and (consp at) (integerp (first at)))
(1+ (first at)))))
(defun* call-function (function-spec &rest arguments) (defun* call-function (function-spec &rest arguments)
(apply (ensure-function function-spec) arguments)) (apply (ensure-function function-spec) arguments))
......
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