diff --git a/cache.lisp b/cache.lisp index 729a184e2de1b844c15d45373a05a8f875480902..dac44e2f17a4b2ea8d7dfe14bceb36c331f4ff0a 100644 --- a/cache.lisp +++ b/cache.lisp @@ -4,7 +4,8 @@ (uiop/package:define-package :asdf/cache (:use :uiop/common-lisp :uiop :asdf/upgrade) (: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*)) (in-package :asdf/cache) @@ -22,6 +23,10 @@ (setf (gethash key *asdf-cache*) value-list) value-list))) + (defun unset-asdf-cache-entry (key) + (when *asdf-cache* + (remhash key *asdf-cache*))) + (defun consult-asdf-cache (key &optional thunk) (if *asdf-cache* (multiple-value-bind (results foundp) (gethash key *asdf-cache*) diff --git a/find-component.lisp b/find-component.lisp index 89108aedc702347518c181bb2fae558e9d52780c..4395648b8492af087aa4d9b14badb8708868fc94 100644 --- a/find-component.lisp +++ b/find-component.lisp @@ -3,7 +3,7 @@ (uiop/package:define-package :asdf/find-component (: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) (:export #:find-component @@ -106,7 +106,12 @@ (or (null c) (and (typep c 'missing-dependency) (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) (let ((component (find-component () component))) diff --git a/find-system.lisp b/find-system.lisp index 897eb9951d0b3f96c845fa41074cf6099da544ec..fde016c3dc59793d97ab4b57cc639eb68b40b768 100644 --- a/find-system.lisp +++ b/find-system.lisp @@ -18,7 +18,7 @@ #:find-system-if-being-defined #:contrib-sysdef-search #:sysdef-find-asdf ;; backward compatibility symbols, functions removed #:sysdef-preloaded-system-search #:register-preloaded-system #:*preloaded-systems* - #:clear-defined-systems #:*defined-systems* + #:clear-defined-system #:clear-defined-systems #:*defined-systems* #:*immutable-systems* ;; defined in source-registry, but specially mentioned here: #:initialize-source-registry #:sysdef-source-registry-search)) @@ -89,15 +89,18 @@ of which is a system object.") (get-file-stamp file)) 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 () ;; Invalidate all systems but ASDF itself, if registered. - (let ((asdf (cdr (system-registered-p :asdf)))) - (setf *defined-systems* (make-hash-table :test 'equal)) - (when asdf - (setf (component-version asdf) *asdf-version*) - (setf (builtin-system-p asdf) t) - (register-system asdf))) - (values)) + (loop :for name :being :the :hash-keys :of *defined-systems* + :unless (equal name "asdf") + :do (clear-defined-system name))) (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. (defun find-system-if-being-defined (name) ;; 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*)) ;; 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. (multiple-value-bind (foundp found-system pathname previous previous-time) (locate-system name) (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*)))) (return found-system)) (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. (reinitialize-source-registry-and-retry () :report (lambda (s) (format s (compatfmt "~@<Retry finding system ~A after reinitializing the source-registry.~@:>") name)) + (unset-asdf-cache-entry `(locate-system ,name)) (initialize-source-registry))))))) diff --git a/test/make-hello-world.lisp b/test/make-hello-world.lisp index cddb2ce603c9dbbdc89d14653976f6a6f8290baa..48cfd706f044a14c41fdf0420ec93ba24abe7245 100644 --- a/test/make-hello-world.lisp +++ b/test/make-hello-world.lisp @@ -23,4 +23,3 @@ (exe (asdf::output-file 'program-op :hello-world-example)) (dll-dest (subpathname exe dll-orig))) (copy-file dll-orig dll-dest))) - diff --git a/test/test-program.script b/test/test-program.script index a7a641805088ee516fabf3479cf9aeb9d053e04f..14d2b4e785afb930e9cc8e3846fa90f142fd3939 100644 --- a/test/test-program.script +++ b/test/test-program.script @@ -2,7 +2,7 @@ (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") (leave-test "Skipping test" 0)) @@ -38,24 +38,29 @@ 0) (assert (probe-file* img) () "Can't find image file ~S" img) -(assert-equal (run-program - (symbol-call :lisp-invocation :lisp-invocation-arglist - :image-path (native-namestring img) - :eval "(uiop:restore-image :entry-point 'hello:entry-point :lisp-interaction nil)") - :output :lines) - '("hello, world")) +(assert-equal + (nest + #+lispworks (last) + (run-program + (symbol-call :lisp-invocation :lisp-invocation-arglist + :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 - (symbol-call :lisp-invocation :lisp-invocation-arglist - :image-path (native-namestring img) - :eval "(uiop:restore-image :entry-point 'hello:entry-point :lisp-interaction nil)" - :arguments '("a" "b c" "d")) - :output :lines) - '("hello, world" - "You passed 3 arguments:" - " \"a\"" - " \"b c\"" - " \"d\"")) +#-(or lispworks scl) ;; These can't be passed arguments the normal way +(assert-equal + (run-program + (symbol-call :lisp-invocation :lisp-invocation-arglist + :image-path (native-namestring img) + :eval "(uiop:restore-image :entry-point 'hello:entry-point :lisp-interaction nil)" + :arguments '("a" "b c" "d")) + :output :lines :error-output t) + '("hello, world" + "You passed 3 arguments:" + " \"a\"" + " \"b c\"" + " \"d\"")) (DBG "test program-op") (unless (or #+(or clisp clozure (and ecl (not ecl-bytecmp)) lispworks mkcl sbcl) t @@ -80,10 +85,10 @@ (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")) -(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" "You passed 3 arguments:" " \"a\"" diff --git a/test/test-retry-loading-component-1.script b/test/test-retry-loading-component-1.script index ee4486f7ffcd2f78a675b27126d6ff5d8b9a00dc..2097ce06e1bb84ca25dcc1e1176b69f16baeebf2 100644 --- a/test/test-retry-loading-component-1.script +++ b/test/test-retry-loading-component-1.script @@ -4,10 +4,11 @@ (defvar *caught-error* nil) (delete-file-if-exists "try-reloading-dependency.asd") -(asdf::clear-defined-systems) +(with-asdf-cache (:override t) (handler-bind ((error #'(lambda (c) (format t "~&Caught error ~s" c) + (assert (not *caught-error*) () "Déjà vu") (setf *caught-error* t) (concatenate-files '("try-reloading-dependency.hidden") "try-reloading-dependency.asd") (DBG "trlc1 5") @@ -17,4 +18,4 @@ (assert restart) (when restart (invoke-restart restart))))))) (load-system 'try-reloading-1)) -(assert *caught-error*) +(assert *caught-error*)) diff --git a/test/test-sysdef-asdf.script b/test/test-sysdef-asdf.script index 337acf81b7c4315c5a841ec2e109cb96410635ae..63cae2192bfcfa227dd8f06353cb71669ed8e6da 100644 --- a/test/test-sysdef-asdf.script +++ b/test/test-sysdef-asdf.script @@ -15,22 +15,25 @@ (declare (ignore system)) (subpathname *test-directory* "always-error.lisp")) +(asdf::clear-defined-system "asdf") (let ((*system-definition-search-functions* '(sysdef-bogus-test-search)) (state "Didn't catch warning")) (DBG "Bogus attempt at loading an old ASDF: should issue a warning and ignore") (handler-bind ((simple-warning - #'(lambda (c) - (when (search "ASDF will ignore this configured system rather than downgrade itself." - (simple-condition-format-control c)) - (setf state "Caught warning"))))) - (upgrade-asdf)) + #'(lambda (c) + (when (search "ASDF will ignore this configured system rather than downgrade itself." + (simple-condition-format-control c)) + (setf state "Caught warning"))))) + (asdf::clear-defined-system "asdf") + (upgrade-asdf)) (assert-equal state "Caught warning") (DBG "2nd bogus attempt at loading same old ASDF: should ignore without a warning") (handler-bind ((simple-warning - #'(lambda (c) - (error "Should not have issued warning, but did issue:~% ~A" c)))) + #'(lambda (c) + (error "Should not have issued warning, but did issue:~% ~A" c)))) + (asdf::clear-defined-system "asdf") (upgrade-asdf))) (DBG "Load ASDF with proper configuration: should find asdf.asd from the source above") @@ -39,14 +42,18 @@ (:directory ,*asdf-directory*) (:directory ,*uiop-directory*) :ignore-inherited-configuration)) +(asdf::clear-defined-system "asdf") (load-system :asdf) ;; This time we found it, but it was skipped because the version was the same (assert-equal nil (system-source-file (find-system :asdf))) + ;; But if we cheat on our version, that should work (setf asdf::*asdf-version* "3.0") +(asdf::clear-defined-system "asdf") +#-xcl ;; XCL has trouble with the ASDF upgrade (load-system :asdf) (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") (defun system-lisp-files (system) diff --git a/test/test-touch-system-1.script b/test/test-touch-system-1.script index f648080ad75f8a87eb92ea6bdf4d4e856683c3ca..a8b1e72d09679bb510241d8f3e8f855ae573ae07 100644 --- a/test/test-touch-system-1.script +++ b/test/test-touch-system-1.script @@ -2,9 +2,9 @@ ;;; test system def reloading if touched ;;; system that can be found using *system-definition-search-functions* - (defun system-registered-time (name) (car (asdf::system-registered-p name))) + (defparameter test1.asd (nth-value 2 (locate-system :test1))) (assert-pathname-equal test1.asd (test-source "test1.asd")) (defparameter file1.lisp (test-source "file1.lisp")) @@ -14,11 +14,13 @@ (defparameter date1 (get-file-stamp test1.asd)) (defparameter date2 (- date1 600)) (defparameter date3 (- date1 300)) + +(asdf::clear-defined-system :test1) (touch-file test1.asd :timestamp date2) (touch-file file1.lisp :timestamp date3) (touch-file file2.lisp :timestamp date3) (assert-equal nil (system-registered-time :test1)) -(find-system :test1) +(load-system :test1) (defparameter date4 (get-file-stamp file2.fasl)) (defparameter date5 (system-registered-time :test1)) (DBG :blah date1 date2 date3 date4 date5) @@ -26,6 +28,8 @@ (assert-equal date2 date5) (assert-compare (>= date4 date3)) (sleep 1) + +(asdf::clear-defined-system :test1) (touch-file test1.asd) (find-system :test1) (defparameter date6 (system-registered-time :test1)) diff --git a/test/test-touch-system-2.script b/test/test-touch-system-2.script index b13593973304cae2889f714443202e7d4491e78a..7cc05e4060d071cff31e102126435b77eab308e1 100644 --- a/test/test-touch-system-2.script +++ b/test/test-touch-system-2.script @@ -10,12 +10,16 @@ (assert-pathname-equal test1.asd (test-source "test1.asd")) (assert test1.asd) +(asdf::clear-defined-systems) (setf asdf:*central-registry* nil) (load test1.asd) (assert (find-system :test1)) (defparameter date1 (system-registered-time :test1)) (assert date1) + +(asdf::clear-defined-systems) (touch-file test1.asd :timestamp date1 :offset +2) +(load test1.asd) (find-system :test1) (defparameter date2 (system-registered-time :test1)) (assert date2) diff --git a/test/test1.asd b/test/test1.asd index 862f2ad4cbc95dd31b1d1dfcf61aadc486cd9512..b699e64464e0bc4879292f465bd7122abfd5a707 100644 --- a/test/test1.asd +++ b/test/test1.asd @@ -1,5 +1,5 @@ ;;; -*- Lisp -*- -(asdf:defsystem test1 +(defsystem test1 :components ((:file "file2" :in-order-to ((compile-op (load-op "file1")) (load-op (load-op "file1")))) (:file "file1")))