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 @@
:licence "MIT"
:description "Another System Definition Facility"
: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 ()
:components ((:module "build" :components ((:file "asdf"))))
:in-order-to (#+asdf2.27 (compile-op (monolithic-load-concatenated-source-op asdf/defsystem))))
......@@ -38,7 +38,6 @@
:class :bundle-system
:build-operation monolithic-concatenate-source-op
:bundle-pathname "build/asdf"
:translate-output-p nil
:serial t
:around-compile call-without-redefinition-warnings ;; be the same as 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.")
;;;; run-shell-command
;;
;; 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)
"Interpolate ARGS into CONTROL-STRING as if by FORMAT, and
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)))
(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 @@
#+ecl #:make-build
#:register-pre-built-system
#:build-args #:name-suffix #:prologue-code #:epilogue-code #:static-library
#:component-translate-output-p #:translate-output-p
#:component-bundle-pathname #:bundle-pathname
#:component-entry-point #:entry-point))
(in-package :asdf/bundle)
......@@ -80,15 +79,11 @@
((bundle-type :initform :program)))
(defgeneric* component-bundle-pathname (component))
(defgeneric* component-translate-output-p (component))
(defgeneric* component-entry-point (component))
(defmethod component-bundle-pathname ((c component))
(declare (ignorable c))
nil)
(defmethod component-translate-output-p ((c component))
(declare (ignorable c))
t)
(defmethod component-entry-point ((c component))
(declare (ignorable c))
nil)
......@@ -97,9 +92,7 @@
((bundle-pathname
:initform nil :initarg :bundle-pathname :accessor component-bundle-pathname)
(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)))
:initform nil :initarg :entry-point :accessor component-entry-point)))
(defun* bundle-pathname-type (bundle-type)
(etypecase bundle-type
......@@ -121,7 +114,7 @@
(format nil "~A~@[~A~]" (component-name c) (slot-value o 'name-suffix))))
(type (bundle-pathname-type bundle-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))
(bundle-output-files o c))
......
......@@ -90,8 +90,8 @@
(cons
(ecase (first form)
((:read-file-form)
(destructuring-bind (subpath &key (path 0)) (rest form)
(safe-read-file-form (subpathname pathname subpath) :path path)))))))
(destructuring-bind (subpath &key (at 0)) (rest form)
(safe-read-file-form (subpathname pathname subpath) :at at)))))))
;;; Main parsing function
......
This diff is collapsed.
;; -*- 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:
;;; please mail to <asdf-devel@common-lisp.net>.
......
......@@ -33,7 +33,7 @@
#:input-files #:output-files #:output-file #:perform
#:operation-done-p #:explain #:component-sibling-dependencies
#: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
#:bundle-op #:precompiled-system #:compiled-file #:bundle-system
#+ecl #:make-build
......
......@@ -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?
#+ecl (ext:getcwd)
#+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!
#+lispworks (system:current-directory)
#+mkcl (mk-ext:getcwd)
......
;;;; -------------------------------------------------------------------------
;;;; run-program/ initially from xcvb-driver.
;;;; run-program initially from xcvb-driver.
(asdf/package:define-package :asdf/run-program
(:recycle :asdf/run-program :xcvb-driver)
......@@ -10,9 +10,9 @@
#:escape-windows-token #:escape-windows-command
#:escape-token #:escape-command
;;; run-program/
;;; run-program
#:slurp-input-stream
#:run-program/
#:run-program
#:subprocess-error
#:subprocess-error-code #:subprocess-error-command #:subprocess-error-process
))
......@@ -145,9 +145,10 @@ by /bin/sh in POSIX"
#-(or gcl<2.7 genera)
(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
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)
(declare (ignorable x))
......@@ -157,29 +158,34 @@ by /bin/sh in POSIX"
(declare (ignorable x))
(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))
(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))
(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))
(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))
(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)
(declare (ignorable stream element-type))
(defmethod slurp-input-stream (x stream
&key linewise prefix (element-type 'character) buffer-size
&allow-other-keys)
(declare (ignorable linewise prefix element-type buffer-size))
(cond
#+(or gcl<2.7 genera)
((functionp x) (funcall x stream))
#+(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
(error "Invalid ~S destination ~S" 'slurp-input-stream x))))
......@@ -198,7 +204,7 @@ by /bin/sh in POSIX"
(subprocess-error-command condition)
(subprocess-error-code condition)))))
(defun* run-program/ (command
(defun* run-program (command
&key output ignore-error-status force-shell
(element-type *default-stream-element-type*)
(external-format :default)
......@@ -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."
(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")
(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).
......
......@@ -153,16 +153,27 @@ Useful for portably flushing I/O before user input or program exit."
;;; 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,
using WRITE-SEQUENCE and a sensibly sized buffer."
(defun* copy-stream-to-stream (input output &key element-type buffer-size linewise prefix)
"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)
(loop
:for buffer = (make-array (list buffer-size) :element-type element-type)
:for end = (read-sequence buffer input)
:until (zerop end)
:do (write-sequence buffer output :end end)
(when (< end buffer-size) (return)))))
(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
: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)
:until (zerop end)
:do (write-sequence buffer output :end end)
(when (< end buffer-size) (return))))))
(defun* concatenate-files (inputs output)
(with-open-file (o output :element-type '(unsigned-byte 8)
......@@ -172,18 +183,6 @@ using WRITE-SEQUENCE and a sensibly sized buffer."
:direction :input :if-does-not-exist :error)
(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))
"Read the contents of the INPUT stream as a string"
(with-open-stream (input input)
......@@ -201,9 +200,9 @@ Read no more than COUNT lines."
(read-line input nil nil))
: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,
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 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.
......@@ -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,
where N is the index specified by path
if path is either an integer or a list that starts with an integer."
(let* ((count (cond
((integerp path)
(1+ path))
((and (consp path) (integerp (first path)))
(1+ (first path)))))
(forms (slurp-stream-lines input :count count)))
(sub-object forms path)))
(access-at (slurp-stream-lines input :count (access-at-count at)) at))
(defun* slurp-stream-forms (input &key count)
"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"
(read-preserving-whitespace input nil eof))
: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,
then return the SUB-OBJECT of these forms following the PATH.
PATH defaults to 0, i.e. return the first form.
PATH is typically a list of integers.
If PATH is NIL, it will return all the forms in the file.
then return the ACCESS-AT of these forms following the AT.
AT defaults to 0, i.e. return the first form.
AT is typically a list of integers.
If AT is NIL, it will return all the forms in the file.
The stream will not be read beyond the Nth form,
where N is the index specified by path,
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"
(let* ((count (cond
((integerp path)
(1+ path))
((and (consp path) (integerp (first path)))
(1+ (first path)))))
(forms (slurp-stream-forms input :count count)))
(sub-object forms path)))
(access-at (slurp-stream-forms input :count (access-at-count at)) at))
(defun* read-file-string (file &rest keys)
"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"
#'(lambda (input) (slurp-stream-forms input :count count))
(remove-plist-key :count keys)))
(defun* read-file-form (file &rest keys &key (path 0) &allow-other-keys)
"Open input FILE with option KEYS (except path),
and read its contents as per SLURP-STREAM-FORM with given PATH.
(defun* read-file-form (file &rest keys &key (at 0) &allow-other-keys)
"Open input FILE with option KEYS (except AT),
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"
(apply 'call-with-input-file file
#'(lambda (input) (slurp-stream-form input :path path))
(remove-plist-key :path keys)))
#'(lambda (input) (slurp-stream-form input :at at))
(remove-plist-key :at 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.
......
......@@ -5,5 +5,4 @@
:build-operation program-op
:entry-point "hello:entry-point"
:depends-on (:asdf-driver)
:translate-output-p nil
:components ((:file "hello")))
......@@ -165,7 +165,7 @@ Some constraints:
(defun touch-file (file &key (offset 0) timestamp)
(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)
(acall :run-program/
(acall :run-program
`("touch" "-t" ,(format nil "~4,'0D~2,'0D~2,'0D~2,'0D~2,'0D.~2,'0D"
year month day hr min sec)
,(namestring file)))
......
......@@ -22,8 +22,7 @@
(assert-equal
(output-file mcso sys)
(apply-output-translations
(subpathname *test-directory*
"test-concatenate-source.all-systems.lisp")))
(resolve-output "asdf/test/test-concatenate-source.all-systems.lisp")))
(assert-equal
(output-files mcso sys)
(input-files mccso sys))
......
......@@ -10,7 +10,7 @@
(defparameter asd2 (subpathname tmp "test-multiple-too.asd"))
(defparameter file4 (test-fasl "file4"))
(setf *central-registry* `(,*test-directory* ,tmp))
(run-program/
(run-program
(format nil "/bin/ln -sf ~A ~A 2>&1"
(native-namestring asd)
(native-namestring asd2)))
......
......@@ -28,15 +28,15 @@
(initialize-source-registry `(:source-registry :ignore-inherited-configuration))
(delete-file-if-exists exe)
(run-program/
(run-program
(symbol-call :lisp-invocation :lisp-invocation-arglist
:load (native-namestring (subpathname *test-directory* "make-hello-world.lisp"))))
(assert (probe-file* exe))
(assert-equal (run-program/ `(,(native-namestring exe)) :output :lines)
(assert-equal (run-program `(,(native-namestring exe)) :output :lines)
'("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"
"You passed 3 arguments:"
" \"a\""
......
;;; -*- 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
;;; test asdf run-shell-command function
(progn
(when (asdf::os-unix-p)
(setf asdf::*verbose-out* nil)
(assert-equal 1 (asdf:run-shell-command "false"))
(assert-equal 0 (asdf:run-shell-command "true"))
(unless (< 0 (asdf:run-shell-command "./bad-shell-command"))
(error "Failed to capture exit status indicating shell command failure."))
(unless (equal 0 (asdf:run-shell-command "./good-shell-command"))
(error "Failed to capture exit status indicating shell command failure."))
;; 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.
;; 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") (asdf::run-program/ '("echo" "ok 1") :output :lines))
))
(when (asdf::os-unix-p)
(setf asdf::*verbose-out* nil)
(assert-equal 1 (run-shell-command "false"))
(assert-equal 0 (run-shell-command "true"))
(unless (< 0 (asdf:run-shell-command "./bad-shell-command"))
(error "Failed to capture exit status indicating shell command failure."))
(unless (equal 0 (run-shell-command "./good-shell-command"))
(error "Failed to capture exit status indicating shell command failure."))
;; 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.
;; If you want 2>&1 redirection, you know where to find it.
(assert-equal '("ok 1") (run-program "echo ok 1" :output :lines))
(assert-equal '("ok 1") (run-program '("echo" "ok 1") :output :lines))
t)
......@@ -35,7 +35,7 @@
;; "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.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-version *asdf-version*)
(already-there (equal asdf-version existing-version))
......
......@@ -19,7 +19,7 @@
#:earlier-stamp #:stamps-earliest #:earliest-stamp
#:later-stamp #:stamps-latest #:latest-stamp #:latest-stamp-f
#: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
#:match-condition-p #:match-any-condition-p ;; conditions
#:call-with-muffled-conditions #:with-muffled-conditions
......@@ -262,23 +262,37 @@ and EVAL that in a (FUNCTION ...) context."
(let ((*package* (find-package package)))
(read-from-string fun))))))))
(defun* sub-object (object path)
"Given an OBJECT and a PATH, list of successive accessors,
(defun* access-at (object at)
"Given an OBJECT and an AT specifier, list of successive accessors,
call each accessor on the result of the previous calls.
An accessor may be an integer, meaning a call to ELT,
a function or symbol, meaning itself,
or a list of a function and arguments, interpreted as per ENSURE-FUNCTION.
As a degenerate case, the PATH may be an atom of a single such accessor
a keyword, meaning a call to GETF,
NIL, meaning identity,
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."
(flet ((access (object accessor)
(etypecase accessor
(function (funcall accessor object))
(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)))))
(if (listp path)
(dolist (accessor path object)
(if (listp at)
(dolist (accessor at object)
(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)
(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