test-read-depends.script 6.15 KB
Newer Older
1 2 3 4 5 6 7
;;; -*- Lisp -*-
;;; ---------------------------------------------------------------------------
;;; Test to make sure that an update to included files causes a reload
;;; of the system definition.
;;; ---------------------------------------------------------------------------

(in-package :asdf-test)
Robert Goldman's avatar
Robert Goldman committed
8

9 10 11
;; I don't know what this does or when it's necessary
;; (setf asdf::*asdf-session* (make-instance asdf::*asdf-session-class*))
(defparameter *tmp-directory* (subpathname *asdf-directory* "build/"))
Robert Goldman's avatar
Robert Goldman committed
12 13
;;(defparameter *test-directory* (subpathname *asdf-directory* "test/"))
(push *test-directory* *central-registry*)
14 15
(defun under-tmp-directory (designator &optional (defaults *tmp-directory*))
  (namestring (subpathname defaults designator)))
16 17 18
(defun under-test-directory (designator &optional (defaults *test-directory*))
  (namestring (subpathname defaults designator)))

Robert Goldman's avatar
Robert Goldman committed
19 20 21 22 23 24 25 26
(defun copy-file-the-hard-way (source dest)
  (with-open-file (sourcestr source)
    (with-open-file (deststr dest :direction :output :if-exists :supersede)
      (loop :for line = (read-line sourcestr nil nil)
            :while line
            :do (format deststr "~a~%" line))))
  (values))

27 28 29
(defparameter *version-file*
  (under-tmp-directory "random-version.lisp-expr"))

Robert Goldman's avatar
Robert Goldman committed
30 31
;; (trace asdf/component:additional-input-files asdf/parse-defsystem::record-additional-system-input-file)

32
;;; write an initial version file
Robert Goldman's avatar
Robert Goldman committed
33 34 35 36 37
(unwind-protect
     (progn
       (with-open-file (str *version-file* :direction :output
                                           :if-exists :supersede)
         (format str "\"1.0\"~%"))
Robert Goldman's avatar
Robert Goldman committed
38 39 40 41
       (copy-file-the-hard-way (under-test-directory "test-include1.asd")
                               (under-test-directory "test-include.asd"))
       (DBG "Set up test-include system definition:"
            (probe-file (under-test-directory "test-include.asd")))
Robert Goldman's avatar
Robert Goldman committed
42 43 44 45 46 47 48 49
       (asdf:load-system "test-include")
       (let ((system (asdf:find-system "test-include")))
         (DBG "On initial load, the system version is" (component-version system))
         (DBG "After initial load the input files for the define op are:"
              (input-files (make-operation 'define-op) system))

         ;; read the initial version information correctly...
         (assert-equal (asdf:component-version system) "1.0"))
50
       (DBG "*******Initial load successful*******")
Robert Goldman's avatar
Robert Goldman committed
51 52 53 54 55 56 57 58 59
       (sleep 2)
       (DBG "*******Reloading*******")
       ;;(trace asdf/plan::action-up-to-date-p)
       ;; (trace asdf/action::component-operation-time)
       ;; #+allegro #+allegro
       ;; (trace (asdf:input-files :inside asdf/plan::compute-action-stamp)
       ;;        (asdf/plan::stamp<= :inside asdf/plan::compute-action-stamp)
       ;;        (asdf/plan::get-file-stamp :inside asdf/plan::compute-action-stamp))

60
;;; bump the version
Robert Goldman's avatar
Robert Goldman committed
61 62 63 64 65
       (with-open-file (str *version-file* :direction :output
                                           :if-exists :supersede)
         (format str "\"2.0\"~%"))
       (asdf:load-system "test-include")
       (let ((system (asdf:find-system "test-include")))
Robert Goldman's avatar
Robert Goldman committed
66
         (DBG "After reload, system version is" (asdf:component-version system))
Robert Goldman's avatar
Robert Goldman committed
67 68
         ;; read the initial version information correctly...
         (assert-equal (asdf:component-version system) "2.0")))
69 70 71 72 73 74 75
  (sleep 2)
  (DBG "*******Using new input file*******")
  (let ((version-file
          (under-tmp-directory "random-version2.lisp-expr")))
    (unwind-protect
         ;; swap system definitions with different read file versions
         (progn
Robert Goldman's avatar
Robert Goldman committed
76
           (copy-file-the-hard-way
77 78 79 80 81
            (under-test-directory "test-include2.asd")
            (under-test-directory "test-include.asd"))
           (with-open-file (str version-file :direction :output
                                             :if-exists :supersede)
             (format str "\"3.0\"~%"))
Robert Goldman's avatar
Robert Goldman committed
82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114
           (DBG "Test-include ASDF file write date"
                (uiop:safe-file-write-date (under-test-directory "test-include.asd")))
           (DBG "version file write date"
                (uiop:safe-file-write-date (under-tmp-directory "random-version2.lisp-expr")))

           ;;; the following establishes that it is NOT the fault of
           ;;; DEFINITION-DEPENDENCIES-UP-TO-DATE-P [2017/07/12:rpg]
           #+allegro
           (trace (asdf/find-system::definition-dependencies-up-to-date-p
                   :inside asdf:find-system)
                  (asdf/find-system::get-file-stamp
                   :inside find-system)
                  (asdf/find-system::stamp<=
                                    :inside find-system))
           ;; AFAICT, the :WHEREIN in SBCL TRACE does not work
           ;; properly.  In my copious free time, I should see if I
           ;; can find a minimal test case. [2017/07/12:rpg]
           #+sbcl
           (trace asdf/find-system::definition-dependencies-up-to-date-p
                  ;; :wherein asdf:find-system
                  )

           (DBG "operation time stamp for define-op before reload"
                (asdf/action:component-operation-time
                 (asdf:make-operation 'define-op)
                 (asdf:find-system "test-include")))
           ;; this is NOT why this is broken on ACL...
           #+ignore
           (DBG "ASDF thinks the operation is done?"
                (asdf:operation-done-p (make-operation 'define-op)
                                       (find-system "test-include")))
           ;; (trace asdf/action:compute-action-stamp asdf:make-plan)
           ;; (trace asdf/plan::perform-plan asdf/plan::action-already-done-p)
115 116 117 118 119 120 121 122 123 124
           (asdf:load-system "test-include")
           (let ((system (find-system "test-include")))
             (assert-equal (asdf:component-version system) "3.0")
             (assert-pathnames-equal (asdf:input-files
                            (asdf:make-operation 'asdf:define-op)
                            system)
                           (mapcar 'parse-namestring
                                   (list (under-test-directory "test-include.asd")
                                         (under-tmp-directory "random-version2.lisp-expr"))))))
      (uiop:delete-file-if-exists version-file)))
Robert Goldman's avatar
Robert Goldman committed
125
  (uiop:delete-file-if-exists (under-test-directory "test-include.asd"))
Robert Goldman's avatar
Robert Goldman committed
126
  (uiop:delete-file-if-exists *version-file*))