diff --git a/Makefile b/Makefile index 8b55b95751d4419e6dc2bc3e6fdff94133e1f4d1..15afc71095c058abeb48dce4c67bfb5e44d58faf 100644 --- a/Makefile +++ b/Makefile @@ -38,17 +38,17 @@ XCL ?= xcl header_lisp := header.lisp driver_lisp := package.lisp compatibility.lisp utility.lisp pathname.lisp stream.lisp os.lisp image.lisp run-program.lisp lisp-build.lisp configuration.lisp backward-driver.lisp driver.lisp -asdf_lisp := upgrade.lisp component.lisp system.lisp find-system.lisp find-component.lisp operation.lisp action.lisp lisp-action.lisp plan.lisp operate.lisp output-translations.lisp source-registry.lisp backward-internals.lisp defsystem.lisp bundle.lisp concatenate-source.lisp backward-interface.lisp interface.lisp footer.lisp +defsystem_lisp := upgrade.lisp component.lisp system.lisp find-system.lisp find-component.lisp operation.lisp action.lisp lisp-action.lisp plan.lisp operate.lisp output-translations.lisp source-registry.lisp backward-internals.lisp defsystem.lisp bundle.lisp concatenate-source.lisp backward-interface.lisp interface.lisp footer.lisp # Making ASDF itself should be our first, default, target: build/asdf.lisp: $(wildcard *.lisp) mkdir -p build - cat $(header_lisp) $(driver_lisp) $(asdf_lisp) > $@ + cat $(header_lisp) $(driver_lisp) $(defsystem_lisp) > $@ # This quickly locates such mistakes as unbalanced parentheses: load: build/asdf.lisp rlwrap sbcl \ - `for i in $(driver_lisp) $(asdf_lisp) ; do echo --load $$i ; done` \ + `for i in $(driver_lisp) $(defsystem_lisp) ; do echo --load $$i ; done` \ --eval '(in-package :asdf)' install: archive-copy @@ -60,10 +60,13 @@ bump-version: build/asdf.lisp driver-files: @echo $(driver_lisp) +defsystem-files: + @echo $(defsystem_lisp) + archive: build/asdf.lisp #${SBCL} --userinit /dev/null --sysinit /dev/null --load bin/make-helper.lisp \ # --eval "(rewrite-license)" --eval "(quit)" - ./bin/asdf-builder make-tarballs + ./bin/asdf-builder make-and-publish-archive archive-copy: archive build/asdf.lisp git checkout release @@ -76,9 +79,9 @@ archive-copy: archive build/asdf.lisp ### Count lines separately for asdf-driver and asdf itself: wc: @wc $(driver_lisp) | sort -n ; echo ; \ - wc $(header_lisp) $(asdf_lisp) | sort -n ; \ + wc $(header_lisp) $(defsystem_lisp) | sort -n ; \ echo ; \ - wc $(driver_lisp) $(asdf_lisp) | tail -n 1 + wc $(header_lisp) $(driver_lisp) $(defsystem_lisp) | tail -n 1 push: git status diff --git a/action.lisp b/action.lisp index aae1ad5270bc5929333504557cc541a2458f96dc..fa9e5dd8154070910011cb3619e1921cfc8fcc1b 100644 --- a/action.lisp +++ b/action.lisp @@ -113,9 +113,9 @@ You can put together sentences using this phrase.")) ;; 1- Make sure we have absolute pathnames (let* ((directory (pathname-directory-pathname (component-pathname component))) (absolute-pathnames - (loop :for pathname :in pathnames - :collect (ensure-pathname - (subpathname directory pathname) :want-absolute t)))) + (loop + :for pathname :in pathnames + :collect (ensure-pathname-absolute pathname directory)))) ;; 2- Translate those pathnames as required (if fixedp absolute-pathnames diff --git a/asdf.asd b/asdf.asd index dc0a39cad4d933abd32e2495334bf20144b13ea5..bea38902dfee590a9e9f2c078c6d89e8fcfb1cf7 100644 --- a/asdf.asd +++ b/asdf.asd @@ -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.118" ;; to be automatically updated by bin/bump-revision + :version "2.26.119" ;; 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)))) diff --git a/bin/asdf-builder b/bin/asdf-builder index 0b9ab2537241116d547ea35138a953f5bee9da27..d99af889d01ca712db2121f00369522d6d9f41dd 100755 --- a/bin/asdf-builder +++ b/bin/asdf-builder @@ -20,7 +20,7 @@ (defvar *asdf-dir* (ensure-pathname (system-relative-pathname :asdf ()) :want-physical t :want-absolute t - :want-existing t :ensure-truename t)) + :want-existing t :truename t)) (defparameter /asdf-dir/ (native-namestring *asdf-dir*)) (defun apath (x &rest keys) (apply 'subpathname *asdf-dir* x keys)) @@ -34,6 +34,7 @@ :ensure-subpath t)) (defparameter /build-dir/ (native-namestring *build-dir*)) +(defun bpath (x &rest keys) (apply 'subpathname *build-dir* x keys)) (defparameter *version* (safe-read-file-form @@ -65,11 +66,6 @@ (defun tarname (name) (strcat name ".tar.gz")) -(defun run-program* (x) - (format t "~A~%" x) - (run-program/ x) - (values)) - (defun make-tarball-under-build (name base files) (check-type name string) (ensure-pathname base :want-absolute t :want-existing t :want-directory t) @@ -80,7 +76,7 @@ (ensure-pathname base :want-absolute t :want-directory t - :want-existing t :ensure-truename t))) + :want-existing t :truename t))) (destination (ensure-pathname name @@ -104,12 +100,12 @@ (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" - /base/ /files/ /destination/)) - (run-program* (format nil "tar zcfC ~S ~S ~S/" - /tarball/ /build-dir/ name)) - (run-program* `("rm" "-rf" ,/destination/))) - (values)) + (run (format nil "cd ~S && cp -lax --parents ~{~S ~} ~S" + /base/ /files/ /destination/) :show t) + (run (format nil "tar zcfC ~S ~S ~S/" + /tarball/ /build-dir/ name) :show t) + (run `("rm" "-rf" ,/destination/) :show t) + (values))) (defun driver-files () (list* "asdf-driver.asd" "version.lisp-expr" @@ -123,7 +119,7 @@ (list* "asdf.asd" "build/asdf.lisp" "version.lisp-expr" "header.lisp" (system-source-files :asdf/defsystem))) (defun asdf-defsystem-name () - (format nil "asdf-system-~A" *version*)) + (format nil "asdf-defsystem-~A" *version*)) (defun make-asdf-defsystem-tarball () (build-asdf) (make-tarball-under-build (asdf-defsystem-name) *asdf-dir* (asdf-defsystem-files))) @@ -132,28 +128,47 @@ (format nil "asdf-~A" *version*)) (defun make-git-tarball () (build-asdf) - (run-program* (format nil "cd ~S && tar zcf build/~A.tar.gz build/asdf.lisp $(git ls-files)" - /asdf-dir/ (asdf-git-name))) + (run (format nil "cd ~S && tar zcf build/~A.tar.gz build/asdf.lisp $(git ls-files)" + /asdf-dir/ (asdf-git-name)) :show t) (values)) -(defun make-tarballs () +(defun asdf-lisp-name () + (format nil "asdf-~A.lisp" *version*)) + +(defun make-asdf-lisp () + (build-asdf) + (concatenate-files (list (apath "build/asdf.lisp")) + (bpath (asdf-lisp-name)))) + +(defun make-archive () (make-driver-tarball) - (make-asdf-system-tarball) + (make-asdf-defsystem-tarball) (make-git-tarball) + (make-asdf-lisp) (values)) -(defun publish-tarballs () +(defvar *clnet* "clnet") +(defvar *clnet-asdf-public* "/project/asdf/public_html/") + +(defun publish-archive () (let ((tarballs (mapcar 'tarname (list (driver-name) (asdf-defsystem-name) (asdf-git-name))))) - (run-program* (format nil "cd ~S && rsync ~{~S ~}clnet:/project/asdf/public_html/archives/" - /build-dir/ tarballs))) + (run (format nil "cd ~S && rsync ~{~S ~}~S clnet:/project/asdf/public_html/archives/" + /build-dir/ tarballs (asdf-lisp-name)) :show t)) (format t "~&To download the tarballs, point your browser at:~% http://common-lisp.net/project/asdf/archives/ ~%") (values)) -(defun make-and-publish-tarballs () - (make-tarballs) - (publish-tarballs)) +(defun link-archive () + (run `(ln -sf ,(tarname (driver-name)) + (,*clnet-asdf-public* "archives/asdf-driver.tar.gz")) + :show t :host *clnet*) + (values)) + +(defun make-and-publish-archive () + (make-archive) + (publish-archive) + (link-archive)) (defparameter *versioned-files* '(("version.lisp-expr" "\"" "\"") @@ -248,7 +263,8 @@ (build-asdf))) (defun git-version () - (first (run-program/ '("git" "describe" "--tags" "--match" "[0-9].[0-9][0-9]") :output :lines))) + (first (run '("git" "describe" "--tags" "--match" "[0-9].[0-9][0-9]") :output :lines + :show t))) ;;;; Main entry point diff --git a/bundle.lisp b/bundle.lisp index e3661b4a4753fa8d3b3de2dd258b19252dd48863..5fee75c1bc1eb8a8225479c5c6d0feccc4deb595 100644 --- a/bundle.lisp +++ b/bundle.lisp @@ -337,7 +337,7 @@ (files (and system (output-files operation system)))) (if (or move-here (and (null move-here-p) (member operation-name '(:program :binary)))) - (loop :with dest-path = (truename* (ensure-directories-exist move-here-path)) + (loop :with dest-path = (resolve-symlinks* (ensure-directories-exist move-here-path)) :for f :in files :for new-f = (make-pathname :name (pathname-name f) :type (pathname-type f) diff --git a/defsystem.lisp b/defsystem.lisp index d9efc53c5525e80c12f444646487da09c575a8fc..630b496510893c9df9baf181d3f842dd909cc693 100644 --- a/defsystem.lisp +++ b/defsystem.lisp @@ -32,10 +32,16 @@ ;; and may be from within the EVAL-WHEN of a file compilation. ;; If no absolute pathname was found, we return NIL. (check-type pathname (or null string pathname)) - (or (and (pathnamep pathname) (absolute-pathname-p pathname) (resolve-symlinks* pathname)) - (let* ((load-pathname (resolve-symlinks* (load-pathname)))) - (when (absolute-pathname-p load-pathname) - (subpathname load-pathname pathname :type :directory))))) + (or (and (absolute-pathname-p pathname) (resolve-symlinks* pathname)) + (let* ((load-pathname (load-pathname)) + (load-absolute + (or (absolute-pathname-p load-pathname) + (let ((defaults (resolve-symlinks* *default-pathname-defaults*))) + (and (absolute-pathname-p defaults) + (merge-pathnames* load-pathname defaults)))))) + (when (absolute-pathname-p load-absolute) + (resolve-symlinks* + (subpathname load-absolute pathname :type :directory)))))) ;;; Component class diff --git a/find-system.lisp b/find-system.lisp index 3206de4e11530463ea99e982b809dace298b120c..4e38e37894f7c338ab2aeff53740f4b68f0883a7 100644 --- a/find-system.lisp +++ b/find-system.lisp @@ -148,14 +148,14 @@ which evaluates to a pathname. For example: #p\"/home/me/cl/systems/\" #p\"/usr/share/common-lisp/systems/\")) -This is for backward compatibilily. +This is for backward compatibility. Going forward, we recommend new users should be using the source-registry. ") -(defun* probe-asd (name defaults) +(defun* probe-asd (name defaults &key truename) (block nil (when (directory-pathname-p defaults) - (let* ((file (probe-file* (subpathname defaults name :type "asd")))) + (let* ((file (probe-file* (subpathname defaults name :type "asd") :truename truename))) (when file (return file))) #-(or clisp genera) ; clisp doesn't need it, plain genera doesn't have read-sequence(!) @@ -177,10 +177,12 @@ Going forward, we recommend new users should be using the source-registry. (block nil (unwind-protect (dolist (dir *central-registry*) - (let ((defaults (eval dir))) + (let ((defaults (resolve-symlinks* (eval dir))) + directorized truenamized) (when defaults - (cond ((directory-pathname-p defaults) - (let ((file (probe-asd name defaults))) + (cond ((and (directory-pathname-p defaults) + (absolute-pathname-p defaults)) + (let* ((file (probe-asd name defaults :truename *resolve-symlinks*))) (when file (return file)))) (t @@ -188,17 +190,29 @@ Going forward, we recommend new users should be using the source-registry. (let* ((*print-circle* nil) (message (format nil - (compatfmt "~@<While searching for system ~S: ~3i~_~S evaluated to ~S which is not a directory.~@:>") + (compatfmt "~@<While searching for system ~S: ~3i~_~S evaluated to ~S which is not an absolute directory.~@:>") system dir defaults))) (error message)) (remove-entry-from-registry () :report "Remove entry from *central-registry* and continue" (push dir to-remove)) + (coerce-to-truename () + :test (lambda (c) (declare (ignore c)) + (setf truenamized (truename* defaults))) + :report (lambda (s) + (format s (compatfmt "~@<Coerce entry to truename ~S and continue.~@:>") + truenamized)) + (push dir to-remove)) (coerce-entry-to-directory () + :test (lambda (c) (declare (ignore c)) + (and (not (directory-pathname-p defaults)) + (directory-pathname-p + (setf directorized + (ensure-directory-pathname defaults))))) :report (lambda (s) (format s (compatfmt "~@<Coerce entry to ~a, replace ~a and continue.~@:>") - (ensure-directory-pathname defaults) dir)) - (push (cons dir (ensure-directory-pathname defaults)) to-replace)))))))) + directorized dir)) + (push (cons dir directorized) to-replace)))))))) ;; cleanup (dolist (dir to-remove) (setf *central-registry* (remove dir *central-registry*))) diff --git a/header.lisp b/header.lisp index 1ab8840e7dfbdf76b243767756866e66f618158d..1d83da9f3615b6fc28a4d5821fec738764899129 100644 --- a/header.lisp +++ b/header.lisp @@ -1,5 +1,5 @@ ;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; coding: utf-8 -*- -;;; This is ASDF 2.26.118: Another System Definition Facility. +;;; This is ASDF 2.26.119: Another System Definition Facility. ;;; ;;; Feedback, bug reports, and patches are all welcome: ;;; please mail to <asdf-devel@common-lisp.net>. diff --git a/output-translations.lisp b/output-translations.lisp index 2fc67842a04aa2a1d8165cdd66d4fe64115b1e90..71af94aab343fdfdff58c04f20aa2b0c5b28890b 100644 --- a/output-translations.lisp +++ b/output-translations.lisp @@ -138,7 +138,8 @@ and the order is by decreasing length of namestring of the source pathname.") ;; Some implementations have precompiled ASDF systems, ;; so we must disable translations for implementation paths. #+(or #|clozure|# ecl mkcl sbcl) - ,@(let ((h (lisp-implementation-directory :truename t))) (when h `(((,h ,*wild-path*) ())))) + ,@(let ((h (resolve-symlinks* (lisp-implementation-directory)))) + (when h `(((,h ,*wild-path*) ())))) #+mkcl (,(translate-logical-pathname "CONTRIB:") ()) ;; All-import, here is where we want user stuff to be: :inherit-configuration @@ -187,7 +188,7 @@ and the order is by decreasing length of namestring of the source pathname.") (when src (let ((trusrc (or (eql src t) (let ((loc (resolve-location src :ensure-directory t :wilden t))) - (if (absolute-pathname-p loc) (truenamize loc) loc))))) + (if (absolute-pathname-p loc) (resolve-symlinks* loc) loc))))) (cond ((location-function-p dst) (funcall collect @@ -213,7 +214,7 @@ and the order is by decreasing length of namestring of the source pathname.") ((directory-pathname-p pathname) (process-output-translations (validate-output-translations-directory pathname) :inherit inherit :collect collect)) - ((probe-file* pathname) + ((probe-file* pathname :truename *resolve-symlinks*) (process-output-translations (validate-output-translations-file pathname) :inherit inherit :collect collect)) (t @@ -260,13 +261,13 @@ effectively disabling the output translation facility." (initialize-output-translations))) (defun* apply-output-translations (path) - #+cormanlisp (truenamize path) #-cormanlisp + #+cormanlisp (resolve-symlinks* path) #-cormanlisp (etypecase path (logical-pathname path) ((or pathname string) (ensure-output-translations) - (loop :with p = (truenamize path) + (loop :with p = (resolve-symlinks* path) :for (source destination) :in (car *output-translations*) :for root = (when (or (eq source t) (and (pathnamep source) diff --git a/pathname.lisp b/pathname.lisp index 1a92f0003188b6a6896bbc437782ec4da63aef2b..a20285650cff812af0c03bbdbcbafbe1e579b155 100644 --- a/pathname.lisp +++ b/pathname.lisp @@ -23,7 +23,7 @@ #:component-name-to-pathname-components #:split-name-type #:parse-unix-namestring #:unix-namestring #:split-unix-namestring-directory-components - #:subpathname #:subpathname* + #:subpathname #:subpathname* #:subpathp ;; Resolving symlinks somewhat #:truenamize #:resolve-symlinks #:resolve-symlinks* ;; Wildcard pathnames @@ -362,27 +362,35 @@ Returns the (parsed) PATHNAME when true" (defun* truename* (p) ;; avoids both logical-pathname merging and physical resolution issues - (ignore-errors (with-pathname-defaults () (truename p)))) + (and p (ignore-errors (with-pathname-defaults () (truename p))))) -(defun* probe-file* (p) - "when given a pathname P, probes the filesystem for a file or directory -with given pathname and if it exists return its truename." +(defun* probe-file* (p &key truename) + "when given a pathname P (designated by a string as per PARSE-NAMESTRING), +probes the filesystem for a file or directory with given pathname. +If it exists, return its truename is ENSURE-PATHNAME is true, +or the original (parsed) pathname if it is false (the default)." (with-pathname-defaults () ;; avoids logical-pathname issues on some implementations (etypecase p (null nil) - (string (probe-file* (parse-namestring p))) + (string (probe-file* (parse-namestring p) :truename truename)) (pathname (unless (wild-pathname-p p) - #.(or #+(or allegro clozure cmu cormanlisp ecl lispworks mkcl sbcl scl) - '(probe-file p) - #+clisp (if-let (it (find-symbol* '#:probe-pathname :ext nil)) - `(ignore-errors (,it p))) - #+gcl<2.7 - '(or (probe-file p) - (and (directory-pathname-p p) - (ignore-errors - (ensure-directory-pathname - (truename* (subpathname (ensure-directory-pathname p) ".")))))) - '(truename* p))))))) + (let ((foundtrue + #.(or #+(or allegro clozure cmu cormanlisp ecl lispworks mkcl sbcl scl) + '(probe-file p) + #+clisp (if-let (it (find-symbol* '#:probe-pathname :ext nil)) + `(ignore-errors (,it p))) + #+gcl<2.7 + '(or (probe-file p) + (and (directory-pathname-p p) + (ignore-errors + (ensure-directory-pathname + (truename* (subpathname + (ensure-directory-pathname p) ".")))))) + '(truename* p)))) + (cond + (truename foundtrue) + (foundtrue p) + (t nil)))))))) (defun* safe-file-write-date (pathname) ;; If FILE-WRITE-DATE returns NIL, it's possible that @@ -597,8 +605,8 @@ even though the OS may not be Unixish, we recommend you use :WANT-RELATIVE T to throw an error if the pathname is absolute" (block nil (check-type type (or null string (eql :directory))) - (when (eq type :directory) - (setf ensure-directory t)) + (when ensure-directory + (setf type :directory)) (etypecase name ((or null pathname) (return name)) (symbol @@ -606,10 +614,10 @@ to throw an error if the pathname is absolute" (string)) (multiple-value-bind (relative path filename file-only) (split-unix-namestring-directory-components - name :dot-dot dot-dot :ensure-directory ensure-directory) + name :dot-dot dot-dot :ensure-directory (eq type :directory)) (multiple-value-bind (name type) (cond - ((or ensure-directory (null filename)) + ((or (eq type :directory) (null filename)) (values nil nil)) (type (values filename type)) @@ -680,6 +688,14 @@ then it is merged with the PATHNAME-DIRECTORY-PATHNAME of PATHNAME." (and pathname (subpathname (ensure-directory-pathname pathname) subpath :type type))) +(defun* subpathp (maybe-subpath base-pathname) + (and (pathnamep maybe-subpath) (pathnamep base-pathname) + (absolute-pathname-p maybe-subpath) (absolute-pathname-p base-pathname) + (directory-pathname-p base-pathname) (not (wild-pathname-p base-pathname)) + (with-pathname-defaults () + (let ((enough (enough-namestring maybe-subpath base-pathname))) + (and (relative-pathname-p enough) (pathname enough)))))) + ;;; Pathname host and its root (defun* pathname-root (pathname) (make-pathname* :directory '(:absolute) @@ -795,16 +811,16 @@ then it is merged with the PATHNAME-DIRECTORY-PATHNAME of PATHNAME." ;;; absolute vs relative -(defun* ensure-pathname-absolute (path) +(defun* ensure-pathname-absolute (path &optional defaults) (cond ((absolute-pathname-p path) path) - ((stringp path) (ensure-pathname-absolute (pathname path))) + ((stringp path) (ensure-pathname-absolute (pathname path) defaults)) ((not (pathnamep path)) (error "not a valid pathname designator ~S" path)) - (t (let ((resolved (resolve-symlinks path))) - (assert (absolute-pathname-p resolved)) - resolved)))) + ((absolute-pathname-p defaults) (merge-pathnames* path defaults)) + (t (error "Cannot ensure ~S is evaluated as an absolute pathname with defaults ~S" + path defaults)))) -(defun* relativize-directory-component (directory-component) +(defun relativize-directory-component (directory-component) (let ((directory (normalize-pathname-directory-component directory-component))) (cond ((stringp directory) @@ -998,7 +1014,7 @@ Otherwise, this will be the root of some implementation-dependent filesystem hos want-non-wild want-wild wilden want-file want-directory ensure-directory want-existing ensure-directories-exist - ensure-truename truenamize + truename resolve-symlinks truenamize &aux (p pathname)) ;; mutable working copy, preserve original "Coerces its argument into a PATHNAME, optionally doing some transformations and checking specified constraints. @@ -1047,7 +1063,8 @@ WANT-WILD checks that pathname is a wild pathname WILDEN merges the pathname with **/*.*.* if it is not wild WANT-EXISTING checks that a file (or directory) exists with that pathname. ENSURE-DIRECTORIES-EXIST creates any parent directory with ENSURE-DIRECTORIES-EXIST. -ENSURE-TRUENAME replaces the pathname by its truename, or errors if not possible. +TRUENAME replaces the pathname by its truename, or errors if not possible. +RESOLVE-SYMLINKS replaces the pathname by a variant with symlinks resolved by RESOLVE-SYMLINKS. TRUENAMIZE uses TRUENAMIZE to resolve as many symlinks as possible." (block nil (flet ((report-error (keyword description &rest arguments) @@ -1082,8 +1099,7 @@ TRUENAMIZE uses TRUENAMIZE to resolve as many symlinks as possible." "Could not make into an absolute pathname even after merging with ~S" defaults) (check ensure-subpath (absolute-pathname-p defaults) "cannot be checked to be a subpath of non-absolute pathname ~S" defaults) - (check ensure-subpath (not (absolute-pathname-p (enough-namestring p defaults))) - "is not a sub pathname of ~S" defaults) + (check ensure-subpath (subpathp p defaults) "is not a sub pathname of ~S" defaults) (check want-file (file-pathname-p p) "Expected a file pathname") (check want-directory (directory-pathname-p p) "Expected a directory pathname") (transform ensure-directory (not (directory-pathname-p p)) (ensure-directory-pathname p)) @@ -1091,17 +1107,18 @@ TRUENAMIZE uses TRUENAMIZE to resolve as many symlinks as possible." (check want-wild (wild-pathname-p p) "Expected a wildcard pathname") (transform wilden (not (wild-pathname-p p)) (wilden p)) (when want-existing - (let ((existing (probe-file* p))) + (let ((existing (probe-file* p :truename truename))) (if existing - (when (or ensure-truename truenamize) + (when truename (return existing)) (err want-existing "Expected an existing pathname")))) (when ensure-directories-exist (ensure-directories-exist p)) - (when ensure-truename + (when truename (let ((truename (truename* p))) (if truename (return truename) (err truename "Can't get a truename for pathname")))) + (transform resolve-symlinks () (resolve-symlinks p)) (transform truenamize () (truenamize p)) p)))) diff --git a/source-registry.lisp b/source-registry.lisp index 98d284be4494d2c153f4220036c9fa7be54fe47a..09e8b9268f4c183feab8c92ffde7e0f0ada918bf 100644 --- a/source-registry.lisp +++ b/source-registry.lisp @@ -153,7 +153,7 @@ system names to pathnames of .asd files") (defun* wrapping-source-registry () `(:source-registry - #+(or ecl sbcl) (:tree ,(lisp-implementation-directory :truename t)) + #+(or ecl sbcl) (:tree ,(resolve-symlinks* (lisp-implementation-directory))) #+mkcl (:tree ,(translate-logical-pathname "CONTRIB:")) :inherit-configuration #+cmu (:tree #p"modules:") @@ -221,10 +221,10 @@ system names to pathnames of .asd files") (defmethod process-source-registry ((pathname #-gcl<2.7 pathname #+gcl<2.7 t) &key inherit register) (cond ((directory-pathname-p pathname) - (let ((*here-directory* (truenamize pathname))) + (let ((*here-directory* (resolve-symlinks* pathname))) (process-source-registry (validate-source-registry-directory pathname) :inherit inherit :register register))) - ((probe-file* pathname) + ((probe-file* pathname :truename *resolve-symlinks*) (let ((*here-directory* (pathname-directory-pathname pathname))) (process-source-registry (validate-source-registry-file pathname) :inherit inherit :register register))) diff --git a/system.lisp b/system.lisp index 5e3e27bd8f8702cabec555e6ceb114ebedfd517d..14135d626be6aa9031180891c2fc9aad4a495ea6 100644 --- a/system.lisp +++ b/system.lisp @@ -71,7 +71,9 @@ in which the system specification (.asd file) is located." (defmethod builtin-system-p ((s system)) (let* ((system (find-system s nil)) (sysdir (and system (component-pathname system))) - (truesysdir (and sysdir (truename* sysdir))) - (impdir (lisp-implementation-directory :truename t))) - (and truesysdir impdir (pathname-match-p truesysdir (wilden impdir)) t))) - + (truesysdir (truename* sysdir)) + (impdir (lisp-implementation-directory)) + (trueimpdir (truename* impdir))) + (and sysdir impdir + (or (subpathp sysdir impdir) + (subpathp truesysdir trueimpdir))))) diff --git a/test/test-bundle.script b/test/test-bundle.script index cb5ea453ec1f7666f11f5a9470aeb4b7991fffc4..4622a5bbb6a44ef06aa514f41e5c39ba43100aec 100644 --- a/test/test-bundle.script +++ b/test/test-bundle.script @@ -22,12 +22,12 @@ (bundle-1 (asdf:output-file op (find-system :test-bundle-1))) (bundle-2 (asdf:output-file op (find-system :test-bundle-2)))) (DBG :test-bundle bundle-1 bundle-2) - (asdf::delete-file-if-exists bundle-1) - (asdf::delete-file-if-exists bundle-2) - (asdf:operate 'asdf:load-fasl-op :test-bundle-2) + (delete-file-if-exists bundle-1) + (delete-file-if-exists bundle-2) + (operate 'load-fasl-op :test-bundle-2) ;; Check that the bundles were indeed created. (assert (probe-file bundle-1)) (assert (probe-file bundle-2)) ;; Check that the files were indeed loaded. - (assert (symbol-value (asdf::find-symbol* :*file1* :test-package))) - (assert (symbol-value (asdf::find-symbol* :*file3* :test-package))))) + (assert (symbol-value (find-symbol* :*file1* :test-package))) + (assert (symbol-value (find-symbol* :*file3* :test-package))))) diff --git a/test/test-force.script b/test/test-force.script index 5fdb32092e97111e52f7f9479553e68ab2afc07d..52fc9035ee017664d1678cdf07dbbb55f2ee44a6 100644 --- a/test/test-force.script +++ b/test/test-force.script @@ -3,7 +3,6 @@ (load-asdf) (with-test () - (setf asdf:*central-registry* '(*default-pathname-defaults*)) (asdf:operate 'asdf:load-op 'test-force) (let* ((file1 (asdf:compile-file-pathname* "file1")) diff --git a/test/test-missing-lisp-file.script b/test/test-missing-lisp-file.script index cc9bb33d0e740919e1af285b45d48af055ab3d86..a6b7664844543ee10052fad47a424a142c77b47f 100644 --- a/test/test-missing-lisp-file.script +++ b/test/test-missing-lisp-file.script @@ -18,12 +18,12 @@ (make-pathname :name "fileMissing" :type "lisp" :defaults - *default-pathname-defaults*))) + *test-directory*))) (template-file (namestring (make-pathname :name "file1" :type "lisp" :defaults - *default-pathname-defaults*)))) + *test-directory*)))) (asdf::concatenate-files (list template-file) missing-name) (unless (probe-file missing-name) (format t "File copy failed.~%")) diff --git a/test/test-module-depend.script b/test/test-module-depend.script index ab05ca20a97798f571d6acf1c2bdbb643ba8336e..536d4a70405141bfdf87557d57f154656e7e13b7 100644 --- a/test/test-module-depend.script +++ b/test/test-module-depend.script @@ -3,7 +3,6 @@ (load-asdf) (with-test () - (setf asdf:*central-registry* '(*default-pathname-defaults*)) (asdf:load-system 'test-module-depend) ;; test that it compiled diff --git a/test/test-nested-components.script b/test/test-nested-components.script index 7783099378401d0898ed5cb4bc94511dd318674f..2877604213b3344225f259d94a6538734cff59fd 100644 --- a/test/test-nested-components.script +++ b/test/test-nested-components.script @@ -7,7 +7,7 @@ (with-test () (setf asdf:*central-registry* nil) - (load (merge-pathnames "test-nested-components-1.asd")) + (load "test-nested-components-1.asd") (print (list :a diff --git a/test/test-redundant-recompile.script b/test/test-redundant-recompile.script index 499d7ac05881759cd9db5038f12af11595da0ba7..2ed920f2ad67762c738228eb2569be910764ddff 100644 --- a/test/test-redundant-recompile.script +++ b/test/test-redundant-recompile.script @@ -3,7 +3,6 @@ (load-asdf) (with-test () - (setf asdf:*central-registry* '(*default-pathname-defaults*)) (asdf:operate 'asdf:load-op 'test-redundant-recompile) ;; test that it compiled (let* ((file1 (asdf:compile-file-pathname* "file1")) diff --git a/test/test-samedir-modules.script b/test/test-samedir-modules.script index 3abaf9c92f9a21ea90c6a6dff9e33b920ac693d4..343aee3e7b5899a21ae8a079610bb506191f9cbb 100644 --- a/test/test-samedir-modules.script +++ b/test/test-samedir-modules.script @@ -3,7 +3,6 @@ (load-asdf) (with-test () - (setf asdf:*central-registry* '(*default-pathname-defaults*)) (DBG "loading test-samedir-modules") (asdf:operate 'asdf:load-op 'test-samedir-modules) (let* ((file1 (asdf:compile-file-pathname* "file1")) diff --git a/test/test-source-file-type.script b/test/test-source-file-type.script index 494afc66116aa4e5b3ceb11d511ee5c9d58e6926..c85c4677b03e00b46e9a1d63f49a4a9371568e61 100644 --- a/test/test-source-file-type.script +++ b/test/test-source-file-type.script @@ -5,7 +5,6 @@ ;;(trace asdf::source-file-type asdf::source-file-explicit-type) (with-test () - (setf asdf:*central-registry* '(*default-pathname-defaults*)) (asdf:load-system 'test-source-file-type-1 :verbose t) (assert (symbol-value (read-from-string "test-package::*test-tmp-cl*"))) (assert diff --git a/test/test-urls-1.script b/test/test-urls-1.script index 1b120b87889d9e4d17b0722a181817f25670d026..47f26ed14d3ab8e3f417b17656e0a3d472fba584 100644 --- a/test/test-urls-1.script +++ b/test/test-urls-1.script @@ -5,7 +5,6 @@ (require :http-library) (with-test () - (setf asdf:*central-registry* '(*default-pathname-defaults*)) ;; Compare the source files with local versions before loading them. #+(and (or abcl scl) trust-the-net) (flet ((compare (url local) diff --git a/test/test-version.script b/test/test-version.script index 0cff0028be249768e14363c47e79f8a87caf2123..c2e160a53487f756215282b5cdd6785ea358fc92 100644 --- a/test/test-version.script +++ b/test/test-version.script @@ -2,19 +2,17 @@ (load "script-support.lisp") (load-asdf) -(setf *central-registry* '(*default-pathname-defaults*)) - (with-test () (def-test-system :versioned-system-1 - :pathname #.*default-pathname-defaults* + :pathname #.*test-directory* :version "1.0") (def-test-system :versioned-system-2 - :pathname #.*default-pathname-defaults* + :pathname #.*test-directory* :version "1.1") (def-test-system :versioned-system-3 - :pathname #.*default-pathname-defaults* + :pathname #.*test-directory* :version "1.2") (flet ((test (name v &optional (true t)) diff --git a/test/test-weakly-depends-on-present.script b/test/test-weakly-depends-on-present.script index 992ae48c58449aff4771f0cf11e953e67f53ec93..63e42619cfb4e024b515bb7cddfc9b470f173338 100644 --- a/test/test-weakly-depends-on-present.script +++ b/test/test-weakly-depends-on-present.script @@ -9,7 +9,6 @@ (with-test () - (setf asdf:*central-registry* '(*default-pathname-defaults*)) (asdf:load-system 'test-weakly-depends-on-present) ;; The weakly-depended-on system, file3-only, should be loaded... (let* ((file3 (asdf:compile-file-pathname* "file3")) diff --git a/test/test-weakly-depends-on-unpresent.script b/test/test-weakly-depends-on-unpresent.script index ffab4cd180484cafaeba8804bd251949e8d5f19e..791d7dc0c3350b05b2673f97e7457de9d96788f5 100644 --- a/test/test-weakly-depends-on-unpresent.script +++ b/test/test-weakly-depends-on-unpresent.script @@ -10,7 +10,6 @@ (load-asdf) (with-test () - (setf asdf:*central-registry* '(*default-pathname-defaults*)) (asdf:load-system 'test-weakly-depends-on-unpresent) ;; test that it compiled (let* ((file1 (asdf:compile-file-pathname* "file1")) diff --git a/test/test2.script b/test/test2.script index 6a6fbafb7f5bcac2ad12ef54a0d52357fe9df9e2..ca0613e0d2777d4265bb56523b4ef3a89b640eac 100644 --- a/test/test2.script +++ b/test/test2.script @@ -2,7 +2,6 @@ (load "script-support.lisp") (load-asdf) (with-test () - (setf asdf:*central-registry* '(*default-pathname-defaults*)) (DBG "test2: loading test2b1") (asdf:load-system 'test2b1) (DBG "test2: file3 and file4 were compiled") diff --git a/test/test3.script b/test/test3.script index fc6b234cc683ca2cc8ed71c87d772cc7db952671..ad32ffc52dc2d3130ca7da85c2c4c87756f06784 100644 --- a/test/test3.script +++ b/test/test3.script @@ -7,7 +7,6 @@ (ns1 (asdf::native-namestring fasl1)) (ns2 (asdf::native-namestring fasl2))) (asdf:run-shell-command "rm -f ~A ~A" ns1 ns2) - (setf asdf:*central-registry* '(*default-pathname-defaults*)) (DBG "should load file1 but not file2") (asdf:load-system :test3) (assert (probe-file fasl1)) diff --git a/test/test8.script b/test/test8.script index 6719d1778835e8e5eec3d7853cc85d6ebabb3bb4..09a87f5bdf796e2d9690026e607f9820ba881632 100644 --- a/test/test8.script +++ b/test/test8.script @@ -7,7 +7,6 @@ (in-package :asdf-test) (with-test () - (setf asdf:*central-registry* '(*default-pathname-defaults*)) (handler-case (asdf:oos 'asdf:load-op 'system-does-not-exist) (asdf:missing-component-of-version (c) diff --git a/upgrade.lisp b/upgrade.lisp index 143175096bf8993576f9b10d02677e2a8942516f..4a5ebdf110411222e13a5db7a6235defc7828579 100644 --- a/upgrade.lisp +++ b/upgrade.lisp @@ -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.118") + (asdf-version "2.26.119") (existing-asdf (find-class (find-symbol* :component :asdf nil) nil)) (existing-version *asdf-version*) (already-there (equal asdf-version existing-version))) diff --git a/version.lisp-expr b/version.lisp-expr index 57fb1b796689a16f0f6d49731fadedbcb275c3cb..35cc57af53f848b7750f6854c2f91e5467992741 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -1 +1 @@ -"2.26.118" +"2.26.119"