Commit 26714b10 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau
Browse files

Tweak ASDF and tests to fix previous commit.

parent 65d72494
...@@ -4,7 +4,8 @@ ...@@ -4,7 +4,8 @@
(uiop/package:define-package :asdf/cache (uiop/package:define-package :asdf/cache
(:use :uiop/common-lisp :uiop :asdf/upgrade) (:use :uiop/common-lisp :uiop :asdf/upgrade)
(:export #:get-file-stamp #:compute-file-stamp #:register-file-stamp (:export #:get-file-stamp #:compute-file-stamp #:register-file-stamp
#:set-asdf-cache-entry #:consult-asdf-cache #:do-asdf-cache #:normalize-namestring #:set-asdf-cache-entry #:unset-asdf-cache-entry #:consult-asdf-cache
#:do-asdf-cache #:normalize-namestring
#:call-with-asdf-cache #:with-asdf-cache #:*asdf-cache*)) #:call-with-asdf-cache #:with-asdf-cache #:*asdf-cache*))
(in-package :asdf/cache) (in-package :asdf/cache)
...@@ -22,6 +23,10 @@ ...@@ -22,6 +23,10 @@
(setf (gethash key *asdf-cache*) value-list) (setf (gethash key *asdf-cache*) value-list)
value-list))) value-list)))
(defun unset-asdf-cache-entry (key)
(when *asdf-cache*
(remhash key *asdf-cache*)))
(defun consult-asdf-cache (key &optional thunk) (defun consult-asdf-cache (key &optional thunk)
(if *asdf-cache* (if *asdf-cache*
(multiple-value-bind (results foundp) (gethash key *asdf-cache*) (multiple-value-bind (results foundp) (gethash key *asdf-cache*)
......
...@@ -3,7 +3,7 @@ ...@@ -3,7 +3,7 @@
(uiop/package:define-package :asdf/find-component (uiop/package:define-package :asdf/find-component
(:recycle :asdf/find-component :asdf) (:recycle :asdf/find-component :asdf)
(:use :uiop/common-lisp :uiop :asdf/upgrade (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/cache
:asdf/component :asdf/system :asdf/find-system) :asdf/component :asdf/system :asdf/find-system)
(:export (:export
#:find-component #:find-component
...@@ -106,7 +106,12 @@ ...@@ -106,7 +106,12 @@
(or (null c) (or (null c)
(and (typep c 'missing-dependency) (and (typep c 'missing-dependency)
(eq (missing-required-by c) component) (eq (missing-required-by c) component)
(equal (missing-requires c) name)))))))) (equal (missing-requires c) name))))
(unless (component-parent component)
(let ((name (coerce-name name)))
(unset-asdf-cache-entry `(find-system ,name))
(unset-asdf-cache-entry `(locate-system ,name))))))))
(defun resolve-dependency-spec (component dep-spec) (defun resolve-dependency-spec (component dep-spec)
(let ((component (find-component () component))) (let ((component (find-component () component)))
......
...@@ -18,7 +18,7 @@ ...@@ -18,7 +18,7 @@
#:find-system-if-being-defined #:find-system-if-being-defined
#:contrib-sysdef-search #:sysdef-find-asdf ;; backward compatibility symbols, functions removed #:contrib-sysdef-search #:sysdef-find-asdf ;; backward compatibility symbols, functions removed
#:sysdef-preloaded-system-search #:register-preloaded-system #:*preloaded-systems* #:sysdef-preloaded-system-search #:register-preloaded-system #:*preloaded-systems*
#:clear-defined-systems #:*defined-systems* #:clear-defined-system #:clear-defined-systems #:*defined-systems*
#:*immutable-systems* #:*immutable-systems*
;; defined in source-registry, but specially mentioned here: ;; defined in source-registry, but specially mentioned here:
#:initialize-source-registry #:sysdef-source-registry-search)) #:initialize-source-registry #:sysdef-source-registry-search))
...@@ -89,15 +89,18 @@ of which is a system object.") ...@@ -89,15 +89,18 @@ of which is a system object.")
(get-file-stamp file)) (get-file-stamp file))
system))))) system)))))
(defun clear-defined-system (system)
(let ((name (coerce-name system)))
(remhash name *defined-systems*)
(unset-asdf-cache-entry `(locate-system ,name))
(unset-asdf-cache-entry `(find-system ,name))
nil))
(defun clear-defined-systems () (defun clear-defined-systems ()
;; Invalidate all systems but ASDF itself, if registered. ;; Invalidate all systems but ASDF itself, if registered.
(let ((asdf (cdr (system-registered-p :asdf)))) (loop :for name :being :the :hash-keys :of *defined-systems*
(setf *defined-systems* (make-hash-table :test 'equal)) :unless (equal name "asdf")
(when asdf :do (clear-defined-system name)))
(setf (component-version asdf) *asdf-version*)
(setf (builtin-system-p asdf) t)
(register-system asdf)))
(values))
(register-hook-function '*post-upgrade-cleanup-hook* 'clear-defined-systems nil) (register-hook-function '*post-upgrade-cleanup-hook* 'clear-defined-systems nil)
...@@ -256,7 +259,7 @@ Going forward, we recommend new users should be using the source-registry. ...@@ -256,7 +259,7 @@ Going forward, we recommend new users should be using the source-registry.
(defun find-system-if-being-defined (name) (defun find-system-if-being-defined (name)
;; notable side effect: mark the system as being defined, to avoid infinite loops ;; notable side effect: mark the system as being defined, to avoid infinite loops
(values (gethash `(find-system ,(coerce-name name)) *asdf-cache*))) (first (gethash `(find-system ,(coerce-name name)) *asdf-cache*)))
(defun load-asd (pathname &key name (external-format (encoding-external-format (detect-encoding pathname))) &aux (readtable *readtable*) (print-pprint-dispatch *print-pprint-dispatch*)) (defun load-asd (pathname &key name (external-format (encoding-external-format (detect-encoding pathname))) &aux (readtable *readtable*) (print-pprint-dispatch *print-pprint-dispatch*))
;; Tries to load system definition with canonical NAME from PATHNAME. ;; Tries to load system definition with canonical NAME from PATHNAME.
...@@ -389,7 +392,7 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded. ...@@ -389,7 +392,7 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded.
(multiple-value-bind (foundp found-system pathname previous previous-time) (multiple-value-bind (foundp found-system pathname previous previous-time)
(locate-system name) (locate-system name)
(when (and found-system (eq found-system previous) (when (and found-system (eq found-system previous)
(or (gethash `(find-system ,name) *asdf-cache*) (or (first (gethash `(find-system ,name) *asdf-cache*))
(and *immutable-systems* (gethash name *immutable-systems*)))) (and *immutable-systems* (gethash name *immutable-systems*))))
(return found-system)) (return found-system))
(assert (eq foundp (and (or found-system pathname previous) t))) (assert (eq foundp (and (or found-system pathname previous) t)))
...@@ -423,5 +426,6 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded. ...@@ -423,5 +426,6 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded.
(reinitialize-source-registry-and-retry () (reinitialize-source-registry-and-retry ()
:report (lambda (s) :report (lambda (s)
(format s (compatfmt "~@<Retry finding system ~A after reinitializing the source-registry.~@:>") name)) (format s (compatfmt "~@<Retry finding system ~A after reinitializing the source-registry.~@:>") name))
(unset-asdf-cache-entry `(locate-system ,name))
(initialize-source-registry))))))) (initialize-source-registry)))))))
...@@ -23,4 +23,3 @@ ...@@ -23,4 +23,3 @@
(exe (asdf::output-file 'program-op :hello-world-example)) (exe (asdf::output-file 'program-op :hello-world-example))
(dll-dest (subpathname exe dll-orig))) (dll-dest (subpathname exe dll-orig)))
(copy-file dll-orig dll-dest))) (copy-file dll-orig dll-dest)))
...@@ -2,7 +2,7 @@ ...@@ -2,7 +2,7 @@
(DBG :foo (current-lisp-file-pathname)) (DBG :foo (current-lisp-file-pathname))
(unless (or #+(or allegro clisp clozure cmu (and ecl (not ecl-bytecmp)) gcl lispworks mkcl sbcl scl) t) (unless (or #+(or allegro clisp clozure cmu (and ecl (not ecl-bytecmp)) lispworks mkcl sbcl scl) t)
(DBG "Creating images is not supported on your CL implementation") (DBG "Creating images is not supported on your CL implementation")
(leave-test "Skipping test" 0)) (leave-test "Skipping test" 0))
...@@ -38,24 +38,29 @@ ...@@ -38,24 +38,29 @@
0) 0)
(assert (probe-file* img) () "Can't find image file ~S" img) (assert (probe-file* img) () "Can't find image file ~S" img)
(assert-equal (run-program (assert-equal
(symbol-call :lisp-invocation :lisp-invocation-arglist (nest
:image-path (native-namestring img) #+lispworks (last)
:eval "(uiop:restore-image :entry-point 'hello:entry-point :lisp-interaction nil)") (run-program
:output :lines) (symbol-call :lisp-invocation :lisp-invocation-arglist
'("hello, world")) :image-path (native-namestring img)
:eval "(uiop:restore-image :entry-point 'hello:entry-point :lisp-interaction nil)")
:output :lines :error-output t))
'("hello, world"))
(assert-equal (run-program #-(or lispworks scl) ;; These can't be passed arguments the normal way
(symbol-call :lisp-invocation :lisp-invocation-arglist (assert-equal
:image-path (native-namestring img) (run-program
:eval "(uiop:restore-image :entry-point 'hello:entry-point :lisp-interaction nil)" (symbol-call :lisp-invocation :lisp-invocation-arglist
:arguments '("a" "b c" "d")) :image-path (native-namestring img)
:output :lines) :eval "(uiop:restore-image :entry-point 'hello:entry-point :lisp-interaction nil)"
'("hello, world" :arguments '("a" "b c" "d"))
"You passed 3 arguments:" :output :lines :error-output t)
" \"a\"" '("hello, world"
" \"b c\"" "You passed 3 arguments:"
" \"d\"")) " \"a\""
" \"b c\""
" \"d\""))
(DBG "test program-op") (DBG "test program-op")
(unless (or #+(or clisp clozure (and ecl (not ecl-bytecmp)) lispworks mkcl sbcl) t (unless (or #+(or clisp clozure (and ecl (not ecl-bytecmp)) lispworks mkcl sbcl) t
...@@ -80,10 +85,10 @@ ...@@ -80,10 +85,10 @@
(assert (probe-file* exe) () "Can't find executable file ~S" exe) (assert (probe-file* exe) () "Can't find executable file ~S" exe)
(assert-equal (run-program `(,(native-namestring exe)) :output :lines) (assert-equal (run-program `(,(native-namestring exe)) :output :lines :error-output t)
'("hello, world")) '("hello, world"))
(assert-equal (run-program `(,(native-namestring exe) "a" "b c" "d") :output :lines) (assert-equal (run-program `(,(native-namestring exe) "a" "b c" "d") :output :lines :error-output t)
'("hello, world" '("hello, world"
"You passed 3 arguments:" "You passed 3 arguments:"
" \"a\"" " \"a\""
......
...@@ -4,10 +4,11 @@ ...@@ -4,10 +4,11 @@
(defvar *caught-error* nil) (defvar *caught-error* nil)
(delete-file-if-exists "try-reloading-dependency.asd") (delete-file-if-exists "try-reloading-dependency.asd")
(asdf::clear-defined-systems) (with-asdf-cache (:override t)
(handler-bind (handler-bind
((error #'(lambda (c) ((error #'(lambda (c)
(format t "~&Caught error ~s" c) (format t "~&Caught error ~s" c)
(assert (not *caught-error*) () "Déjà vu")
(setf *caught-error* t) (setf *caught-error* t)
(concatenate-files '("try-reloading-dependency.hidden") "try-reloading-dependency.asd") (concatenate-files '("try-reloading-dependency.hidden") "try-reloading-dependency.asd")
(DBG "trlc1 5") (DBG "trlc1 5")
...@@ -17,4 +18,4 @@ ...@@ -17,4 +18,4 @@
(assert restart) (assert restart)
(when restart (invoke-restart restart))))))) (when restart (invoke-restart restart)))))))
(load-system 'try-reloading-1)) (load-system 'try-reloading-1))
(assert *caught-error*) (assert *caught-error*))
...@@ -15,22 +15,25 @@ ...@@ -15,22 +15,25 @@
(declare (ignore system)) (declare (ignore system))
(subpathname *test-directory* "always-error.lisp")) (subpathname *test-directory* "always-error.lisp"))
(asdf::clear-defined-system "asdf")
(let ((*system-definition-search-functions* '(sysdef-bogus-test-search)) (let ((*system-definition-search-functions* '(sysdef-bogus-test-search))
(state "Didn't catch warning")) (state "Didn't catch warning"))
(DBG "Bogus attempt at loading an old ASDF: should issue a warning and ignore") (DBG "Bogus attempt at loading an old ASDF: should issue a warning and ignore")
(handler-bind (handler-bind
((simple-warning ((simple-warning
#'(lambda (c) #'(lambda (c)
(when (search "ASDF will ignore this configured system rather than downgrade itself." (when (search "ASDF will ignore this configured system rather than downgrade itself."
(simple-condition-format-control c)) (simple-condition-format-control c))
(setf state "Caught warning"))))) (setf state "Caught warning")))))
(upgrade-asdf)) (asdf::clear-defined-system "asdf")
(upgrade-asdf))
(assert-equal state "Caught warning") (assert-equal state "Caught warning")
(DBG "2nd bogus attempt at loading same old ASDF: should ignore without a warning") (DBG "2nd bogus attempt at loading same old ASDF: should ignore without a warning")
(handler-bind (handler-bind
((simple-warning ((simple-warning
#'(lambda (c) #'(lambda (c)
(error "Should not have issued warning, but did issue:~% ~A" c)))) (error "Should not have issued warning, but did issue:~% ~A" c))))
(asdf::clear-defined-system "asdf")
(upgrade-asdf))) (upgrade-asdf)))
(DBG "Load ASDF with proper configuration: should find asdf.asd from the source above") (DBG "Load ASDF with proper configuration: should find asdf.asd from the source above")
...@@ -39,14 +42,18 @@ ...@@ -39,14 +42,18 @@
(:directory ,*asdf-directory*) (:directory ,*asdf-directory*)
(:directory ,*uiop-directory*) (:directory ,*uiop-directory*)
:ignore-inherited-configuration)) :ignore-inherited-configuration))
(asdf::clear-defined-system "asdf")
(load-system :asdf) (load-system :asdf)
;; This time we found it, but it was skipped because the version was the same ;; This time we found it, but it was skipped because the version was the same
(assert-equal nil (system-source-file (find-system :asdf))) (assert-equal nil (system-source-file (find-system :asdf)))
;; But if we cheat on our version, that should work ;; But if we cheat on our version, that should work
(setf asdf::*asdf-version* "3.0") (setf asdf::*asdf-version* "3.0")
(asdf::clear-defined-system "asdf")
#-xcl ;; XCL has trouble with the ASDF upgrade
(load-system :asdf) (load-system :asdf)
(assert-pathname-equal (subpathname *asdf-directory* "asdf.asd") (assert-pathname-equal (subpathname *asdf-directory* "asdf.asd")
(system-source-file (find-system :asdf))) (system-source-file (find-system :asdf)))
(DBG "Checking that Makefile and asdf.asd are in synch") (DBG "Checking that Makefile and asdf.asd are in synch")
(defun system-lisp-files (system) (defun system-lisp-files (system)
......
...@@ -2,9 +2,9 @@ ...@@ -2,9 +2,9 @@
;;; test system def reloading if touched ;;; test system def reloading if touched
;;; system that can be found using *system-definition-search-functions* ;;; system that can be found using *system-definition-search-functions*
(defun system-registered-time (name) (defun system-registered-time (name)
(car (asdf::system-registered-p name))) (car (asdf::system-registered-p name)))
(defparameter test1.asd (nth-value 2 (locate-system :test1))) (defparameter test1.asd (nth-value 2 (locate-system :test1)))
(assert-pathname-equal test1.asd (test-source "test1.asd")) (assert-pathname-equal test1.asd (test-source "test1.asd"))
(defparameter file1.lisp (test-source "file1.lisp")) (defparameter file1.lisp (test-source "file1.lisp"))
...@@ -14,11 +14,13 @@ ...@@ -14,11 +14,13 @@
(defparameter date1 (get-file-stamp test1.asd)) (defparameter date1 (get-file-stamp test1.asd))
(defparameter date2 (- date1 600)) (defparameter date2 (- date1 600))
(defparameter date3 (- date1 300)) (defparameter date3 (- date1 300))
(asdf::clear-defined-system :test1)
(touch-file test1.asd :timestamp date2) (touch-file test1.asd :timestamp date2)
(touch-file file1.lisp :timestamp date3) (touch-file file1.lisp :timestamp date3)
(touch-file file2.lisp :timestamp date3) (touch-file file2.lisp :timestamp date3)
(assert-equal nil (system-registered-time :test1)) (assert-equal nil (system-registered-time :test1))
(find-system :test1) (load-system :test1)
(defparameter date4 (get-file-stamp file2.fasl)) (defparameter date4 (get-file-stamp file2.fasl))
(defparameter date5 (system-registered-time :test1)) (defparameter date5 (system-registered-time :test1))
(DBG :blah date1 date2 date3 date4 date5) (DBG :blah date1 date2 date3 date4 date5)
...@@ -26,6 +28,8 @@ ...@@ -26,6 +28,8 @@
(assert-equal date2 date5) (assert-equal date2 date5)
(assert-compare (>= date4 date3)) (assert-compare (>= date4 date3))
(sleep 1) (sleep 1)
(asdf::clear-defined-system :test1)
(touch-file test1.asd) (touch-file test1.asd)
(find-system :test1) (find-system :test1)
(defparameter date6 (system-registered-time :test1)) (defparameter date6 (system-registered-time :test1))
......
...@@ -10,12 +10,16 @@ ...@@ -10,12 +10,16 @@
(assert-pathname-equal test1.asd (test-source "test1.asd")) (assert-pathname-equal test1.asd (test-source "test1.asd"))
(assert test1.asd) (assert test1.asd)
(asdf::clear-defined-systems)
(setf asdf:*central-registry* nil) (setf asdf:*central-registry* nil)
(load test1.asd) (load test1.asd)
(assert (find-system :test1)) (assert (find-system :test1))
(defparameter date1 (system-registered-time :test1)) (defparameter date1 (system-registered-time :test1))
(assert date1) (assert date1)
(asdf::clear-defined-systems)
(touch-file test1.asd :timestamp date1 :offset +2) (touch-file test1.asd :timestamp date1 :offset +2)
(load test1.asd)
(find-system :test1) (find-system :test1)
(defparameter date2 (system-registered-time :test1)) (defparameter date2 (system-registered-time :test1))
(assert date2) (assert date2)
......
;;; -*- Lisp -*- ;;; -*- Lisp -*-
(asdf:defsystem test1 (defsystem test1
:components ((:file "file2" :in-order-to ((compile-op (load-op "file1")) :components ((:file "file2" :in-order-to ((compile-op (load-op "file1"))
(load-op (load-op "file1")))) (load-op (load-op "file1"))))
(:file "file1"))) (:file "file1")))
......
Supports Markdown
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