Commit 072692f1 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau

2.26.119: conditionalize all truenaming on *resolve-symlinks*.

jyknight will be happy. Passes test, when still resolving.
parent 5e8f210c
......@@ -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
......
......@@ -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
......
......@@ -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))))
......
......@@ -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
......
......@@ -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)
......
......@@ -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
......
......@@ -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*)))
......
;; -*- 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>.
......
......@@ -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)
......
......@@ -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))))
......
......@@ -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)))
......
......@@ -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)))))
......@@ -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)))))
......@@ -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"))
......
......@@ -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.~%"))
......
......@@ -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
......
......@@ -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
......
......@@ -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"))
......
......@@ -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"))
......
......@@ -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
......
......@@ -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)
......
......@@ -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))
......
......@@ -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"))
......
......@@ -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"))
......
......@@ -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")
......
......@@ -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))
......
......@@ -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)
......
......@@ -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)))
......
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