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)
*asdf-directory*)
:when (typep c 'cl-source-file) :when (typep c 'cl-source-file)
:collect n) :collect n)))
(list "version.lisp-expr" "asdf-driver.asd"))) (defparameter *version*
(safe-read-first-file-form (apath "version.lisp-expr")))
;; make asdf: (defparameter *name* (format nil "asdf-driver-~A" *version*))
;;;(run-program/ (list "make" "-C" (native-namestring *asdf-directory*) "build/asdf.lisp")) (defparameter *tarname* (strcat *name* ".tar.gz"))
(defparameter dirname/ (strcat *name* "/"))
#| (defparameter *destination*
if [ -d "tmp" ]; then (ensure-pathname (bpath dirname/)
rm -r tmp :want-directory t :want-absolute t))
fi (assert (< 6 (length (pathname-directory *destination*))))
mkdir tmp (defparameter /destination/ (native-namestring *destination*))
(run-program/ `("rm" "-rf" ,/destination/))
archive_file="tmp/asdf-$tag.tar.gz" (ensure-directory-exists *destination*)
echo "Create tmp/asdf.tar.gz with tag $tag" (run-program/ `("ln" ,@(mapcar 'ann *files*) ,/destination/))
git archive $tag --prefix="asdf/" --format=tar | \ (run-program/ (format nil "cd ~S && tar zcf ~S ~S"
gzip > $archive_file ,/build-dir/, ,*tarname* ,dirname/))
|# (run-program/ `("rm" "-rf" ,/destination/))
\ No newline at end of file
...@@ -152,7 +152,8 @@ values of TAG include :source-registry and :output-translations." ...@@ -152,7 +152,8 @@ 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
(etypecase x
(pathname x) (pathname x)
(string (parse-unix-namestring (string (parse-unix-namestring
x :want-directory want-directory)) x :want-directory want-directory))
...@@ -176,11 +177,9 @@ values of TAG include :source-registry and :output-translations." ...@@ -176,11 +177,9 @@ values of TAG include :source-registry and :output-translations."
(parse-unix-namestring (parse-unix-namestring
(string-downcase (implementation-type)) :want-directory t)) (string-downcase (implementation-type)) :want-directory t))
((eql :hostname) ((eql :hostname)
(parse-unix-namestring (hostname) :want-directory t)))) (parse-unix-namestring (hostname) :want-directory t)))
(w (if (and wilden (not (pathnamep x)) (not (member x '(:*/ :**/ :*.*.*)))) :wilden (and wilden (not (pathnamep x)) (not (member x '(:*/ :**/ :*.*.*))))
(wilden r) :want-relative t))
r)))
(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,7 +202,8 @@ directive.") ...@@ -203,7 +202,8 @@ 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
(etypecase x
(pathname x) (pathname x)
(string (string
(let ((p #-mcl (parse-namestring x) (let ((p #-mcl (parse-namestring x)
...@@ -231,11 +231,9 @@ directive.") ...@@ -231,11 +231,9 @@ directive.")
((eql :here) (resolve-absolute-location-component ((eql :here) (resolve-absolute-location-component
*here-directory* :want-directory t :wilden nil)) *here-directory* :want-directory t :wilden nil))
((eql :user-cache) (resolve-absolute-location-component ((eql :user-cache) (resolve-absolute-location-component
*user-cache* :want-directory t :wilden nil)))) *user-cache* :want-directory t :wilden nil)))
(w (if (and wilden (not (pathnamep x))) :wilden (and wilden (not (pathnamep x)))
(wilden r) :want-absolute t))
r)))
(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