Commit eceb8c10 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau

2.26.111: fix embarrassing bugs in ensure-pathname

parent c13fac5c
......@@ -53,10 +53,13 @@ load: build/asdf.lisp
install: archive-copy
archive:
${SBCL} --userinit /dev/null --sysinit /dev/null --load bin/make-helper.lisp \
--eval "(rewrite-license)" --eval "(quit)"
bin/make-tarball
bump-version: build/asdf.lisp
./bin/bump-version
archive: build/asdf.lisp
#${SBCL} --userinit /dev/null --sysinit /dev/null --load bin/make-helper.lisp \
# --eval "(rewrite-license)" --eval "(quit)"
./bin/make-tarball
archive-copy: archive build/asdf.lisp
git checkout release
......
......@@ -11,8 +11,6 @@
#:action
#:explain #:operation-description
#:downward-operation #:upward-operation
#:source-file #:c-source-file #:java-source-file
#:static-file #:doc-file #:html-file
#:operation-error #:error-component #:error-operation
#:component-depends-on #:component-self-dependencies
#:input-files #:output-files #:output-file #:operation-done-p
......@@ -136,21 +134,6 @@ You can put together sentences using this phrase."))
(declare (ignorable o c))
nil)
;;;; File components
(defclass source-file (file-component)
((type :initform nil))) ;; NB: many systems have come to rely on this default.
(defclass c-source-file (source-file)
((type :initform "c")))
(defclass java-source-file (source-file)
((type :initform "java")))
(defclass static-file (source-file)
((type :initform nil)))
(defclass doc-file (static-file) ())
(defclass html-file (doc-file)
((type :initform "html")))
(defmethod input-files ((o operation) (c file-component))
(or (loop :for (dep-o) :in (component-self-dependencies o c)
:append (or (output-files dep-o c) (input-files dep-o c)))
......
......@@ -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.110" ;; to be automatically updated by bin/bump-revision
:version "2.26.111" ;; to be automatically updated by bin/bump-revision
:depends-on ()
:components ((:module "build" :components ((:file "asdf"))))
:in-order-to (#+asdf2.27 (compile-op (monolithic-load-concatenated-source-op generate-asdf))))
......
......@@ -7,6 +7,8 @@
(in-package :fare-utils)
(asdf-debug)
(defparameter *versioned-files*
'(("version.lisp-expr" "\"" "\"")
("asdf.asd" " :version \"" "\" ;; to be automatically updated by bin/bump-revision")
......
This diff is collapsed.
......@@ -8,8 +8,6 @@
(in-package :asdf)
(asdf-debug)
;;; Make sure asdf.lisp is built.
(asdf:build-system :asdf/generate)
......@@ -17,7 +15,7 @@
(defparameter *asdf-dir*
(ensure-pathname (system-relative-pathname :asdf ())
:want-physical t :want-absolute t
:want-existing t :truename t))
:want-existing t :ensure-truename t))
(defparameter /asdf-dir/
(native-namestring *asdf-dir*))
......@@ -31,20 +29,20 @@
(native-namestring *build-dir*))
(defparameter *version*
(safe-read-first-file-form
(safe-read-file-form
(subpathname *asdf-dir* "version.lisp-expr")))
(defparameter *asdf-driver* (format nil "asdf-driver-~A" *version*))
(defun enough-namestring! (base pathname)
(let ((e (enough-namestring b p)))
(assert (relative-pathname e))
(let ((e (enough-namestring base pathname)))
(assert (relative-pathname-p e))
e))
(defun enough-namestrings (base pathnames)
(loop :with b = (ensure-pathname base :want-absolute t :want-directory t)
:for p :in pathnames
:collect (enough-namestring! base p)))
:collect (enough-namestring! p base)))
(defun system-source-files (system)
(let* ((sys (find-system system))
......@@ -55,7 +53,8 @@
(operated-components
sys :other-systems nil
:goal-operation 'load-op
:keep-operation 'load-op))
:keep-operation 'load-op
:keep-component 'file-component))
(pathnames (mapcar 'component-pathname components)))
(enough-namestrings dir pathnames)))
......@@ -71,13 +70,21 @@
(defun tarname (name) (strcat name ".tar.gz"))
(defun run-program* (x)
(format t "~A~%" x)
(run-program/ x))
(defun make-tarball-under-build (name base files)
(check-type name string)
(ensure-pathname base :want-absolute t :want-existing t :want-directory t)
(dolist (f files)
(check-type f string))
(let* ((/base/
(native-namestring
(ensure-pathname
base
:want-absolute t :want-directory t
:want-existing t :want-truename t)))
:want-existing t :ensure-truename t)))
(destination
(ensure-pathname
name
......@@ -97,16 +104,18 @@
(/files/
(mapcar 'native-namestring files)))
(assert (< 6 (length (pathname-directory destination))))
(run-program/ `("rm" "-rf" ,/destination/))
(when (probe-file* destination)
(error "Destination ~S already exists, not taking chances - you can delete it yourself."
destination))
(ensure-directories-exist destination)
(run-program/ (format nil "cd ~S && cp -lax --parents ~{~S ~} ~S"
(run-program* (format nil "cd ~S && cp -lax --parents ~{~S ~} ~S"
/base/ /files/ /destination/))
(run-program/ (format nil "tar zcvfC ~S ~S ~S/"
/tarball/ /build/ name))
(run-program/ `("rm" "-rf" ,/destination/))))
(run-program* (format nil "tar zcvfC ~S ~S ~S/"
/tarball/ /build-dir/ name))
(run-program* `("rm" "-rf" ,/destination/))))
(make-tarball-under-build *asdf-driver* *asdf-directory* *asdf-driver-files*)
(make-tarball-under-build *asdf-only* *asdf-directory* *asdf-only-files*)
(make-tarball-under-build *asdf-driver* *asdf-dir* *driver-files*)
(make-tarball-under-build *asdf-only* *asdf-dir* *asdf-only-files*)
(run-program/ (format nil "cd ~S && tar zcf build/asdf-~A.tar.gz build/asdf.lisp $(git ls-files)"
(run-program* (format nil "cd ~S && tar zcf build/asdf-~A.tar.gz build/asdf.lisp $(git ls-files)"
/asdf-dir/ *version*))
......@@ -218,7 +218,7 @@
#+(or allegro clisp clozure cmu lispworks sbcl scl xcl) (equal type (compile-file-type)))))
(defun* operated-components (system &key (goal-operation 'load-op) (keep-operation goal-operation)
(component-type t) other-systems)
(component-type t) (keep-component t) other-systems)
(let ((goal-op (make-operation goal-operation)))
(flet ((filter (o c)
(declare (ignore o))
......@@ -227,7 +227,7 @@
(loop :for (o . c) :in (gather-actions goal-op system
:other-systems other-systems
:filter #'filter)
:when (typep o keep-operation)
:when (and (typep o keep-operation) (typep c keep-component))
:collect c))))
(defgeneric* trivial-system-p (component))
......
......@@ -10,6 +10,8 @@
#:component-parent #:component-system #:component-parent-pathname
#:child-component #:parent-component #:module
#:file-component
#:source-file #:c-source-file #:java-source-file
#:static-file #:doc-file #:html-file
#:source-file-type ;; backward-compatibility
#:component-in-order-to #:component-sibling-dependencies
#:component-if-feature #:around-compile-hook
......@@ -131,6 +133,17 @@ another pathname in a degenerate way."))
(defclass file-component (child-component)
((type :accessor file-type :initarg :type))) ; no default
(defclass source-file (file-component)
((type :initform nil))) ;; NB: many systems have come to rely on this default.
(defclass c-source-file (source-file)
((type :initform "c")))
(defclass java-source-file (source-file)
((type :initform "java")))
(defclass static-file (source-file)
((type :initform nil)))
(defclass doc-file (static-file) ())
(defclass html-file (doc-file)
((type :initform "html")))
(defclass parent-component (component)
((children
......
;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; coding: utf-8 -*-
;;; This is ASDF 2.26.110: Another System Definition Facility.
;;; This is ASDF 2.26.111: Another System Definition Facility.
;;;
;;; Feedback, bug reports, and patches are all welcome:
;;; please mail to <asdf-devel@common-lisp.net>.
......
......@@ -123,16 +123,16 @@ a CL pathname satisfying all the specified constraints as per ENSURE-PATHNAME"
(defun* split-native-pathnames-string (string &rest constraints &key &allow-other-keys)
(loop :for namestring :in (split-string string :separator (string (inter-directory-separator)))
:collect (apply 'parse-native-namestring namestring constraints)))
(defun* getenv-pathname (x &rest constraints &key (error-arguments () eap) &allow-other-keys)
(declare (ignore error-arguments))
(defun* getenv-pathname (x &rest constraints &key on-error &allow-other-keys)
(apply 'parse-native-namestring (getenvp x)
(if eap constraints
(list* :error-arguments '("~? from (getenv ~S)") constraints))))
(defun* getenv-pathnames (x &rest constraints &key (error-arguments () eap) &allow-other-keys)
(declare (ignore error-arguments))
:on-error (or on-error
`(error "In (~S ~S), invalid pathname ~*~S: ~*~?" getenv-pathname ,x))
constraints))
(defun* getenv-pathnames (x &rest constraints &key on-error &allow-other-keys)
(apply 'split-native-pathnames-string (getenvp x)
(if eap constraints
(list* :error-arguments '("~? from (getenv ~S)") constraints))))
:on-error (or on-error
`(error "In (~S ~S), invalid pathname ~*~S: ~*~?" getenv-pathnames ,x))
constraints))
(defun* getenv-absolute-directory (x)
(getenv-pathname x :want-absolute t :ensure-directory t))
(defun* getenv-absolute-directories (x)
......
This diff is collapsed.
......@@ -45,7 +45,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.110")
(asdf-version "2.26.111")
(existing-asdf (find-class (find-symbol* :component :asdf nil) nil))
(existing-version *asdf-version*)
(already-there (equal asdf-version existing-version)))
......
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