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

2.26.104: some more pathname munging.

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