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

2.20.9: fix logical-pathname issue; export more utilities.

The issue fixed is that most Lisps don't like
*default-pathname-defaults* being a logical-pathname.
Added a test for logical-pathname functionality;
it all works on CCL, and works better on other Lisps after the fix,
but there are still logical-pathname issues on SBCL, CLISP and more.
Also, a package cleanup of our test suite.
parent b570623d
......@@ -14,7 +14,7 @@ endif
## MINOR FAIL: xcl (logical pathname issue in asdf-pathname-test.script)
## OCCASIONALLY TESTED BY NOT ME: allegromodern (not in my free demo version)
## OCCASIONALLY TESTED BY NOT ME: lispworks (testing requires Pro version)
## MAJOR FAIL: gclcvs -- COMPILER BUG! Upstream fixed it, but it won't compile for me.
## MAJOR FAIL: gclcvs -- COMPILER BUG! Upstream fixed it, but upstream fails to compile.
## NOT SUPPORTED BY OUR TESTS: cormancl genera rmcl. Manually tested once in a while.
lisp ?= sbcl
......
......@@ -14,7 +14,7 @@
:licence "MIT"
:description "Another System Definition Facility"
:long-description "ASDF builds Common Lisp software organized into defined systems."
:version "2.20.8" ;; to be automatically updated by bin/bump-revision
:version "2.20.9" ;; to be automatically updated by bin/bump-revision
:depends-on ()
:components
((:file "asdf")
......
;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*-
;;; This is ASDF 2.20.8: Another System Definition Facility.
;;; This is ASDF 2.20.9: Another System Definition Facility.
;;;
;;; Feedback, bug reports, and patches are all welcome:
;;; please mail to <asdf-devel@common-lisp.net>.
......@@ -115,7 +115,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.20.8")
(asdf-version "2.20.9")
(existing-asdf (find-class 'component nil))
(existing-version *asdf-version*)
(already-there (equal asdf-version existing-version)))
......@@ -340,6 +340,7 @@
#:ensure-source-registry
#:process-source-registry
#:system-registered-p
#:resolve-location
#:asdf-message
#:user-output-translations-pathname
#:system-output-translations-pathname
......@@ -354,13 +355,16 @@
#:absolute-pathname-p
;; #:aif #:it
;; #:appendf #:orf
;; #:first-char #:last-char
#:coerce-name
#:directory-pathname-p
;; #:ends-with
#:pathname-root
#:ends-with
#:ensure-directory-pathname
#:getenv
#:probe-file*
;; #:length=n-p
;; #:find-symbol*
#:find-symbol*
#:merge-pathnames* #:coerce-pathname #:subpathname
#:pathname-directory-pathname
#:read-file-forms
......@@ -1703,7 +1707,8 @@ Going forward, we recommend new users should be using the source-registry.
:condition condition))))
(let ((*package* package)
(*default-pathname-defaults*
(pathname-directory-pathname pathname)))
;; resolve logical-pathnames so they won't wreak havoc in parsing namestrings.
(translate-logical-pathname (pathname-directory-pathname pathname))))
(asdf-message (compatfmt "~&~@<; ~@;Loading system definition from ~A into ~A~@:>~%")
pathname package)
(load pathname)))
......
(in-package #:common-lisp-user)
(load (make-pathname :name "script-support" :defaults *load-pathname*))
(in-package #:asdf-test)
(declaim (optimize (speed 2) (safety 3) #-allegro (debug 3)
#+(or cmu scl) (c::brevity 2)))
(proclaim '(optimize (speed 2) (safety 3) #-allegro (debug 3)
#+(or cmu scl) (c::brevity 2)))
(load (make-pathname :name "script-support" :defaults *load-pathname*))
(defun my-compile-file (&rest args) (apply 'compile-file args))
#+ecl (trace my-compile-file)
......
(in-package #:common-lisp-user)
(defpackage :asdf-test (:use :common-lisp))
(in-package #:asdf-test)
(declaim (optimize (speed 2) (safety 3) #-allegro (debug 3)))
(proclaim '(optimize (speed 2) (safety 3) #-allegro (debug 3)))
......@@ -39,12 +41,16 @@
*asdf-lisp*))))
(defun load-asdf ()
(load *asdf-fasl*))
(load *asdf-fasl*)
(use-package :asdf :asdf-test)
(setf *package* (find-package :asdf-test)))
(defun common-lisp-user::load-asdf ()
(load-asdf))
#+allegro
(setf excl:*warn-on-nested-reader-conditionals* nil)
#-sbcl
(defun native-namestring (x)
(let ((p (pathname x)))
#+clozure (ccl:native-translated-namestring p)
......@@ -95,11 +101,14 @@ is bound, write a message and exit on an error. If
((ignore-errors (funcall (find-symbol "GETENV" :asdf) "DEBUG_ASDF_TEST"))
(break))
(t
(finish-output *standard-output*)
(finish-output *trace-output*)
(format *error-output* "~&ABORTING:~% ~S~%" c)
#+sbcl (sb-debug:backtrace 69)
#+clozure (ccl:print-call-history :count 69 :start-frame-number 1)
#+clisp (system::print-backtrace)
(format *error-output* "~&ABORTING:~% ~S~%" c)
(finish-output *error-output*)
(leave-lisp "~&Script failed~%" 1))))))
(funcall thunk)
(leave-lisp "~&Script succeeded~%" 0)))
......@@ -3,6 +3,6 @@
(load-asdf)
(quit-on-error
(setf asdf:*central-registry* '(*default-pathname-defaults*))
(asdf:load-system 'test-around-compile :force t)
(assert (= 3 (cl-user::add10 1)))) ;; add10 must have been compiled in base 2
(setf *central-registry* '(*default-pathname-defaults*))
(load-system 'test-around-compile :force t)
(assert (= 3 (add10 1)))) ;; add10 must have been compiled in base 2
;;; -*- Lisp -*-
(load "script-support.lisp")
(load-asdf)
(in-package :asdf)
(defparameter *test-directory*
(merge-pathnames* (coerce-pathname "tmp/") cl-user::*asdf-directory*))
(merge-pathnames* (coerce-pathname "tmp/") *asdf-directory*))
(defun under-test-directory (designator &optional (defaults *test-directory*))
(namestring (merge-pathnames* (coerce-pathname designator) defaults)))
......@@ -58,28 +57,28 @@
:direction :output
:if-exists :rename-and-delete
:if-does-not-exist :create)
(format s "(asdf:defsystem :foo~D)~%" i))))
(format s "(defsystem :foo~D)~%" i))))
(cl-user::quit-on-error
(quit-on-error
(assert
(equal (parse-output-translations-string "/foo:/bar::/baz:/quux")
(equal (asdf::parse-output-translations-string "/foo:/bar::/baz:/quux")
'(:output-translations
("/foo" "/bar")
:inherit-configuration
("/baz" "/quux"))))
(assert
(equal (parse-output-translations-string "/:")
(equal (asdf::parse-output-translations-string "/:")
'(:output-translations ("/" nil) :ignore-inherited-configuration)))
(assert
(equal (parse-output-translations-string "/::")
(equal (asdf::parse-output-translations-string "/::")
'(:output-translations ("/" nil) :inherit-configuration)))
(assert
(equal (parse-output-translations-string "/:/")
(equal (asdf::parse-output-translations-string "/:/")
'(:output-translations ("/" "/") :ignore-inherited-configuration)))
(assert
(equal (parse-output-translations-string
(equal (asdf::parse-output-translations-string
"(:output-translations (\"/\" \"/\") :ignore-inherited-configuration)")
'(:output-translations ("/" "/") :ignore-inherited-configuration)))
......
......@@ -2,4 +2,3 @@
(asdf:defsystem test-force
:components
((:file "file1")))
;;; -*- Lisp -*-
(load "script-support.lisp")
(load-asdf)
(setf (logical-pathname-translations "ASDF")
`(("**;*.asd.*" ,(make-pathname :type "asd" :defaults (resolve-location `(,*asdf-directory* :**/ :*.*.*))))
("**;*.asd" ,(resolve-location `(,*asdf-directory* :**/ #p"*.asd")))
("**;*.lisp.*" ,(make-pathname :type "lisp" :defaults (resolve-location `(,*asdf-directory* :**/ :*.*.*))))
("**;*.lisp" ,(resolve-location `(,*asdf-directory* :**/ #p"*.lisp")))
("**;*.*.*" ,(resolve-location
`(,*asdf-directory* "tmp/fasls" :implementation "logical-host-asdf" :**/ :*.*.*)))))
(quit-on-error
(format t "~S~%" (translate-logical-pathname "ASDF:test;test-force.asd"))
(format t "~S~%" (truename "ASDF:test;test-force.asd"))
(format t "Test logical pathnames in central registry~%")
(setf *central-registry* '("ASDF:test;"))
(initialize-source-registry '(:source-registry :ignore-inherited-configuration))
(load-system :test-force :force t)
(format t "Test logical pathnames in source-registry, non-recursive~%")
(clear-system :test-force)
(setf *central-registry* '())
(initialize-source-registry
'(:source-registry (:directory "ASDF:test;") :ignore-inherited-configuration))
(load-system :test-force :force t)
(format t "Test logical pathnames in source-registry, recursive~%")
(clear-system :test-force)
(setf *central-registry* '())
(initialize-source-registry
'(:source-registry (:tree "ASDF:") :ignore-inherited-configuration))
(load-system :test-force :force t)
(format t "Done~%"))
......@@ -3,19 +3,19 @@
(load-asdf)
(quit-on-error
(let* ((asd (asdf:merge-pathnames* (asdf:coerce-pathname "test-multiple.asd")
*test-directory*))
(tmp (asdf:merge-pathnames* (asdf:coerce-pathname "../tmp/")
*test-directory*))
(asd2 (asdf:merge-pathnames* (asdf:coerce-pathname "test-multiple-too.asd")
(let* ((asd (merge-pathnames* (coerce-pathname "test-multiple.asd")
*test-directory*))
(tmp (merge-pathnames* (coerce-pathname "../tmp/")
*test-directory*))
(asd2 (merge-pathnames* (coerce-pathname "test-multiple-too.asd")
tmp))
(file4 (asdf:compile-file-pathname* "file4")))
(setf asdf:*central-registry* `(*default-pathname-defaults* ,tmp))
(assert (= 0 (asdf:run-shell-command
(file4 (compile-file-pathname* "file4")))
(setf *central-registry* `(*default-pathname-defaults* ,tmp))
(assert (= 0 (run-shell-command
(format nil "/bin/ln -sf ~A ~A"
(cl-user::native-namestring asd)
(cl-user::native-namestring asd2)))))
(asdf:oos 'asdf:load-source-op 'test-multiple-too)
(native-namestring asd)
(native-namestring asd2)))))
(oos 'load-source-op 'test-multiple-too)
(assert (symbol-value (find-symbol (string :*file3*) :test-package)))
(asdf:load-system 'test-multiple-free)
(load-system 'test-multiple-free)
(assert (asdf::probe-file* file4))))
(in-package #:common-lisp-user)
\ No newline at end of file
(in-package #:asdf-test)
;;; -*- Mode: common-lisp; Syntax: Common-Lisp; -*-
;; copyright (c) 2006-2007 Franz Inc, Oakland, CA - All rights reserved.
;;
;; The software, data and information contained herein are proprietary
;; to, and comprise valuable trade secrets of, Franz, Inc. They are
;; given in confidence by Franz, Inc. pursuant to a written license
;; agreement, and may be stored and used only in accordance with the terms
;; of such license.
;;
;; Restricted Rights Legend
;; ------------------------
;; Use, duplication, and disclosure of the software, data and information
;; contained herein by any agency, department or entity of the U.S.
;; Government are subject to restrictions of Restricted Rights for
;; Commercial Software developed at private expense as specified in
;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable.
;;
;; $Id: db-agraph-preflight.asd,v 1.1.2.1 2009/01/16 23:58:53 gwking Exp $
;; -*- mode: common-lisp -*-
(in-package #:common-lisp-user)
(defpackage #:test-nested-components.system
......
......@@ -4,7 +4,6 @@
(load "script-support.lisp")
(load-asdf)
(in-package #:common-lisp-user)
(quit-on-error
(setf asdf:*central-registry* nil)
......
;;; -*- Lisp -*-
(in-package :cl-user)
(load "script-support.lisp")
(load-asdf)
(quit-on-error
(in-package :cl-user)
(asdf-test::quit-on-error
(defun module () 1)
(load "test-package.asd")
(defclass module () ())
......
......@@ -2,12 +2,10 @@
(load "script-support.lisp")
(load-asdf)
(in-package :asdf)
#+gcl (trace coerce-pathname)
(trace #+gcl coerce-pathname)
(cl-user::quit-on-error
(format t "dpd: ~S~%f1: ~S~%" *default-pathname-defaults* (asdf:merge-pathnames* "file1"))
(quit-on-error
(format t "dpd: ~S~%f1: ~S~%" *default-pathname-defaults* (merge-pathnames* "file1"))
(setf *central-registry* '(*default-pathname-defaults*))
......
......@@ -7,10 +7,10 @@
(defvar *caught-error* nil)
(quit-on-error
(asdf:run-shell-command "rm -f ~A"
(namestring
(compile-file-pathname "try-recompiling-1")))
(setf asdf:*central-registry* '(*default-pathname-defaults*))
(run-shell-command "rm -f ~A"
(namestring
(compile-file-pathname "try-recompiling-1")))
(setf *central-registry* '(*default-pathname-defaults*))
#-gcl
(handler-bind ((error (lambda (c)
(setf *caught-error* t)
......@@ -25,7 +25,5 @@
(print (list c restart (compute-restarts c)))
(when restart
(invoke-restart restart)))))))
(asdf:oos 'asdf:load-op 'try-recompiling-1))
(assert *caught-error*)
)
(oos 'load-op 'try-recompiling-1))
(assert *caught-error*))
;;; -*- Lisp -*-
(load "script-support.lisp")
(load-asdf)
(in-package :asdf)
(cl-user::quit-on-error
(quit-on-error
(assert
(every #'directory-pathname-p
......@@ -37,14 +37,14 @@
(assert (equal (multiple-value-list (component-name-to-pathname-components "/aa/ba" :force-directory nil))
'(:absolute ("aa") "ba")))
(assert
(asdf::version-satisfies (asdf:asdf-version) (asdf:asdf-version)))
(version-satisfies (asdf-version) (asdf-version)))
(assert
(asdf::version-satisfies (asdf:asdf-version) "2.000"))
(version-satisfies (asdf-version) "2.000"))
(assert
(not (asdf::version-satisfies (asdf:asdf-version) "666")))
(not (version-satisfies (asdf-version) "666")))
(assert
(equal (asdf::split-absolute-pathnames "/foo:/bar" "baz") '("/foo" "/bar")))
(assert (equal (mapcar 'location-function-p
(assert (equal (mapcar 'asdf::location-function-p
'((:function f)
(:function (lambda (path absolute-source)
(declare (ignore absolute-source))
......
;;; -*- Lisp -*-
(load "script-support.lisp")
(load-asdf)
(setf asdf:*central-registry* '(*default-pathname-defaults*))
(defpackage :test-version-system
(:use :cl :asdf))
(setf *central-registry* '(*default-pathname-defaults*))
(in-package :test-version-system)
(cl-user::quit-on-error
(quit-on-error
(defsystem :versioned-system-1
:pathname #.*default-pathname-defaults*
:version "1.0")
......@@ -22,10 +18,8 @@
:version "1.2")
(flet ((test (name v &optional (true t))
(or (eq true (asdf::version-satisfies (find-system name) v))
(or (eq true (version-satisfies (find-system name) v))
(error "no satisfaction: ~S version ~A not ~A" name v true))))
(test :versioned-system-1 "1.0")
(test :versioned-system-2 "1.0")
(test :versioned-system-3 "2.0" nil))
)
\ No newline at end of file
(test :versioned-system-3 "2.0" nil)))
;;;; Example lisp code.
(in-package :cl-user)
(in-package :asdf-test)
(defun tst (x)
(1+ x))
......
(in-package #:common-lisp-user)
(in-package #:asdf-test)
(setf *test6* :yes)
......@@ -2,12 +2,12 @@
#+(or f1 f2) (error "This test cannot run if :f1 or :f2 are on *features*")
(load "script-support.lisp")
(load-asdf)
(in-package :asdf)
(cl-user::quit-on-error
(quit-on-error
(let* ((fasl1 (asdf:compile-file-pathname* (truename "file1.lisp")))
(fasl2 (asdf:compile-file-pathname* (truename "file2.lisp")))
(ns1 (cl-user::native-namestring fasl1))
(ns2 (cl-user::native-namestring fasl2)))
(ns1 (native-namestring fasl1))
(ns2 (native-namestring fasl2)))
(asdf:run-shell-command "rm -f ~A ~A" ns1 ns2)
(setf asdf:*central-registry* '(*default-pathname-defaults*))
#-gcl
......
......@@ -2,8 +2,8 @@
;;; -*- Lisp -*-
(load "script-support.lisp")
(load-asdf)
(in-package :asdf)
(cl-user::quit-on-error
(quit-on-error
(setf asdf:*central-registry* '(*default-pathname-defaults*))
(assert (not (component-property (find-system 'test3) :foo)))
(assert (equal (component-property (find-system 'test3) :prop1) "value"))
......
......@@ -4,7 +4,7 @@
(load "script-support.lisp")
(load-asdf)
(in-package #:common-lisp-user)
(in-package #:asdf-test)
(quit-on-error
(setf asdf:*central-registry* '(*default-pathname-defaults*))
......
......@@ -4,7 +4,6 @@
(load "script-support.lisp")
(load-asdf)
(in-package #:common-lisp-user)
(quit-on-error
(setf asdf:*central-registry* nil)
......
;;; -*- Lisp -*-
(asdf:defsystem try-recompiling-1
:components ((:file "try-recompiling-1")))
(defsystem try-recompiling-1
:components ((:file "try-recompiling-1")))
(in-package #:common-lisp-user)
(in-package #:asdf-test)
#+clisp (eval-when (:compile-toplevel) (fmakunbound 'try-recompiling-1))
......
......@@ -3,5 +3,5 @@
(load-asdf)
(quit-on-error
(load "../wild-modules.lisp")
(setf asdf:*central-registry* '(*default-pathname-defaults*))
(asdf:operate 'asdf:load-op 'wild-module))
(setf *central-registry* '(*default-pathname-defaults*))
(load-system :wild-module))
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