Commit 0b681897 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau
Browse files

2.26.104: some more pathname munging.

parent 7ba708cb
...@@ -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.104" ;; to be automatically updated by bin/bump-revision :version "2.26.105" ;; to be automatically updated by bin/bump-revision
: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 generate-asdf)))) :in-order-to (#+asdf2.27 (compile-op (monolithic-load-concatenated-source-op generate-asdf))))
......
...@@ -13,33 +13,37 @@ ...@@ -13,33 +13,37 @@
(describe (find-system :asdf)) (describe (find-system :asdf))
(defparameter *ad* (find-system :asdf-driver)) (defparameter *ad* (find-system :asdf-driver))
(defparameter *asdf-directory* (system-source-directory *ad*)) (defparameter *asdf-dir*
(defparameter *version* (ensure-pathname (system-source-directory *ad*)
(safe-read-first-file-form (subpathname *asdf-directory* "version.lisp-expr"))) :want-existing t :want-absolute t))
(defun apath (x) (subpathname *asdf-dir* x))
(DBG :foo *ad* *version* (asdf-version)) (defun ann (x) (native-namestring (apath x)))
(defparameter *build-dir* (apath "build/"))
(defparameter /build-dir/ (ann "build/"))
(defun bpath (x) (subpathname *build-dir* x))
(defun bnn (x) (native-namestring (bpath x)))
(defparameter *files* (defparameter *files*
(append (list* "asdf-driver.asd" "version.lisp-expr"
(loop :for c :in (operated-components *ad* (loop :for c :in (operated-components
:goal-operation 'load-op *ad* :goal-operation 'load-op
:keep-operation 'load-op) :keep-operation 'load-op)
:for n = (enough-namestring (component-pathname c) *asdf-directory*) :for n = (enough-namestring (component-pathname c)
:when (typep c 'cl-source-file) *asdf-directory*)
:collect n) :when (typep c 'cl-source-file)
(list "version.lisp-expr" "asdf-driver.asd"))) :collect n)))
(defparameter *version*
;; make asdf: (safe-read-first-file-form (apath "version.lisp-expr")))
;;;(run-program/ (list "make" "-C" (native-namestring *asdf-directory*) "build/asdf.lisp")) (defparameter *name* (format nil "asdf-driver-~A" *version*))
(defparameter *tarname* (strcat *name* ".tar.gz"))
#| (defparameter dirname/ (strcat *name* "/"))
if [ -d "tmp" ]; then (defparameter *destination*
rm -r tmp (ensure-pathname (bpath dirname/)
fi :want-directory t :want-absolute t))
mkdir tmp (assert (< 6 (length (pathname-directory *destination*))))
(defparameter /destination/ (native-namestring *destination*))
archive_file="tmp/asdf-$tag.tar.gz" (run-program/ `("rm" "-rf" ,/destination/))
echo "Create tmp/asdf.tar.gz with tag $tag" (ensure-directory-exists *destination*)
git archive $tag --prefix="asdf/" --format=tar | \ (run-program/ `("ln" ,@(mapcar 'ann *files*) ,/destination/))
gzip > $archive_file (run-program/ (format nil "cd ~S && tar zcf ~S ~S"
|# ,/build-dir/, ,*tarname* ,dirname/))
\ No newline at end of file (run-program/ `("rm" "-rf" ,/destination/))
...@@ -152,35 +152,34 @@ values of TAG include :source-registry and :output-translations." ...@@ -152,35 +152,34 @@ values of TAG include :source-registry and :output-translations."
:inherit-configuration))) :inherit-configuration)))
(defun* resolve-relative-location-component (x &key want-directory wilden) (defun* resolve-relative-location-component (x &key want-directory wilden)
(let* ((r (etypecase x (ensure-pathname
(pathname x) (etypecase x
(string (parse-unix-namestring (pathname x)
x :want-directory want-directory)) (string (parse-unix-namestring
(cons x :want-directory want-directory))
(if (null (cdr x)) (cons
(resolve-relative-location-component (if (null (cdr x))
(car x) :want-directory want-directory :wilden wilden) (resolve-relative-location-component
(let* ((car (resolve-relative-location-component (car x) :want-directory want-directory :wilden wilden)
(car x) :want-directory t :wilden nil))) (let* ((car (resolve-relative-location-component
(merge-pathnames* (car x) :want-directory t :wilden nil)))
(resolve-relative-location-component (merge-pathnames*
(cdr x) :want-directory want-directory :wilden wilden) (resolve-relative-location-component
car)))) (cdr x) :want-directory want-directory :wilden wilden)
((eql :*/) *wild-directory*) car))))
((eql :**/) *wild-inferiors*) ((eql :*/) *wild-directory*)
((eql :*.*.*) *wild-file*) ((eql :**/) *wild-inferiors*)
((eql :implementation) ((eql :*.*.*) *wild-file*)
(parse-unix-namestring ((eql :implementation)
(implementation-identifier) :want-directory t)) (parse-unix-namestring
((eql :implementation-type) (implementation-identifier) :want-directory t))
(parse-unix-namestring ((eql :implementation-type)
(string-downcase (implementation-type)) :want-directory t)) (parse-unix-namestring
((eql :hostname) (string-downcase (implementation-type)) :want-directory t))
(parse-unix-namestring (hostname) :want-directory t)))) ((eql :hostname)
(w (if (and wilden (not (pathnamep x)) (not (member x '(:*/ :**/ :*.*.*)))) (parse-unix-namestring (hostname) :want-directory t)))
(wilden r) :wilden (and wilden (not (pathnamep x)) (not (member x '(:*/ :**/ :*.*.*))))
r))) :want-relative t))
(ensure-pathname w :want-relative t)))
(defvar *here-directory* nil (defvar *here-directory* nil
"This special variable is bound to the currect directory during calls to "This special variable is bound to the currect directory during calls to
...@@ -203,39 +202,38 @@ directive.") ...@@ -203,39 +202,38 @@ directive.")
(register-image-restore-hook 'compute-user-cache) (register-image-restore-hook 'compute-user-cache)
(defun* resolve-absolute-location-component (x &key want-directory wilden) (defun* resolve-absolute-location-component (x &key want-directory wilden)
(let* ((r (etypecase x (ensure-pathname
(pathname x) (etypecase x
(string (pathname x)
(let ((p #-mcl (parse-namestring x) (string
#+mcl (probe-posix x))) (let ((p #-mcl (parse-namestring x)
#+mcl (unless p (error "POSIX pathname ~S does not exist" x)) #+mcl (probe-posix x)))
(if want-directory (ensure-directory-pathname p) p))) #+mcl (unless p (error "POSIX pathname ~S does not exist" x))
(cons (if want-directory (ensure-directory-pathname p) p)))
(return-from resolve-absolute-location-component (cons
(if (null (cdr x)) (return-from resolve-absolute-location-component
(resolve-absolute-location-component (if (null (cdr x))
(car x) :want-directory want-directory :wilden wilden) (resolve-absolute-location-component
(merge-pathnames* (car x) :want-directory want-directory :wilden wilden)
(resolve-relative-location-component (merge-pathnames*
(cdr x) :want-directory want-directory :wilden wilden) (resolve-relative-location-component
(resolve-absolute-location-component (cdr x) :want-directory want-directory :wilden wilden)
(car x) :want-directory t :wilden nil))))) (resolve-absolute-location-component
((eql :root) (car x) :want-directory t :wilden nil)))))
;; special magic! we return a relative pathname, ((eql :root)
;; but what it means to the output-translations is ;; special magic! we return a relative pathname,
;; "relative to the root of the source pathname's host and device". ;; but what it means to the output-translations is
(return-from resolve-absolute-location-component ;; "relative to the root of the source pathname's host and device".
(let ((p (make-pathname* :directory '(:relative)))) (return-from resolve-absolute-location-component
(if wilden (wilden p) p)))) (let ((p (make-pathname* :directory '(:relative))))
((eql :home) (user-homedir)) (if wilden (wilden p) p))))
((eql :here) (resolve-absolute-location-component ((eql :home) (user-homedir))
*here-directory* :want-directory t :wilden nil)) ((eql :here) (resolve-absolute-location-component
((eql :user-cache) (resolve-absolute-location-component *here-directory* :want-directory t :wilden nil))
*user-cache* :want-directory t :wilden nil)))) ((eql :user-cache) (resolve-absolute-location-component
(w (if (and wilden (not (pathnamep x))) *user-cache* :want-directory t :wilden nil)))
(wilden r) :wilden (and wilden (not (pathnamep x)))
r))) :want-absolute t))
(ensure-pathname w :want-absolute t)))
(defun* resolve-location (x &key want-directory wilden directory) (defun* resolve-location (x &key want-directory wilden directory)
(when directory (setf want-directory t)) ;; :directory backward compatibility, until 2014-01-16. (when directory (setf want-directory t)) ;; :directory backward compatibility, until 2014-01-16.
......
;; -*- 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.104: Another System Definition Facility. ;;; This is ASDF 2.26.105: 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>.
......
...@@ -931,9 +931,11 @@ Otherwise, this will be the root of some implementation-dependent filesystem hos ...@@ -931,9 +931,11 @@ Otherwise, this will be the root of some implementation-dependent filesystem hos
(defun* ensure-pathname (defun* ensure-pathname
(pathname &key want-pathname want-existing (pathname &key want-pathname want-existing
want-absolute want-relative want-directory want-file want-absolute want-relative
want-wild want-non-wild want-truename truenamize want-logical want-physical ensure-physical
error-arguments) want-wild want-non-wild wilden
ensure-directory want-directory want-file
want-truename truenamize error-arguments)
"Coerces its argument into a PATHNAME, and checks specified constraints. "Coerces its argument into a PATHNAME, and checks specified constraints.
If the argument is NIL, then NIL is returned unless the WANT-PATHNAME constraint is specified. If the argument is NIL, then NIL is returned unless the WANT-PATHNAME constraint is specified.
If the argument is a STRING, it is first converted to a pathname via PARSE-NAMESTRING. If the argument is a STRING, it is first converted to a pathname via PARSE-NAMESTRING.
...@@ -968,30 +970,42 @@ in case you use the long variant." ...@@ -968,30 +970,42 @@ in case you use the long variant."
(string (string
(setf pathname (parse-namestring pathname))) (setf pathname (parse-namestring pathname)))
(pathname)) (pathname))
(when want-logical
(unless (typep pathname 'logical-pathname)
(err want-logical "Expected a logical pathname, got")))
(when want-physical
(unless (physical-pathname-p pathname)
(err want-physical "Expected a physical pathname, got")))
(when ensure-physical
(setf pathname (translate-logical-pathname pathname)))
(when want-absolute (when want-absolute
(unless (absolute-pathname-p pathname) (unless (absolute-pathname-p pathname)
(err want-absolute "Expected an absolute pathname, got"))) (err want-absolute "Expected an absolute pathname, got")))
(when want-relative (when want-relative
(when (absolute-pathname-p pathname) (when (absolute-pathname-p pathname)
(err want-relative "Expected a relative pathname, got"))) (err want-relative "Expected a relative pathname, got")))
(when want-directory
(unless (directory-pathname-p pathname)
(err want-directory "Expected a directory pathname, got")))
(when want-file
(unless (pathname-name pathname)
(err want-file "Expected a file pathname, got")))
(when want-wild (when want-wild
(unless (wild-pathname-p pathname) (unless (wild-pathname-p pathname)
(err want-wild "Expected a wildcard pathname, got"))) (err want-wild "Expected a wildcard pathname, got")))
(when (or want-non-wild want-existing) (when (or want-non-wild want-existing)
(when (wild-pathname-p pathname) (when (wild-pathname-p pathname)
(err want-non-wild "Expected a non-wildcard pathname, got"))) (err want-non-wild "Expected a non-wildcard pathname, got")))
(when (and wilden (not (wild-pathname-p pathname)))
(setf pathname (wilden pathname)))
(when ensure-directory
(setf pathname (ensure-directory-pathname pathname)))
(when want-directory
(unless (directory-pathname-p pathname)
(err want-directory "Expected a directory pathname, got")))
(when want-file
(unless (pathname-name pathname)
(err want-file "Expected a file pathname, got")))
(when want-existing (when want-existing
(let ((existing (probe-file* pathname))) (let ((existing (probe-file* pathname)))
(if existing (if existing
(err want-existing "Expected an existing pathname, got")
(when (or want-truename truenamize) (when (or want-truename truenamize)
(return existing))))) (return existing))
(err want-existing "Expected an existing pathname, got"))))
(when want-truename (when want-truename
(let ((truename (truename* pathname))) (let ((truename (truename* pathname)))
(if truename (if truename
......
...@@ -45,7 +45,7 @@ ...@@ -45,7 +45,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.104") (asdf-version "2.26.105")
(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)))
......
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