asdf-pathname-test.script 21.2 KB
Newer Older
1
;;; -*- Lisp -*-
2
(load "script-support.lisp")
3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32
(load-asdf)

;;; test asdf pathname specifications
;;;
;;; this is intended to run in a directory like '/test/20100310T000000Z/sbcl', in which it creates a
;;; test transcript. the tests construct a simple system/module/source-file system definition and
;;; verify that component pathname specifications refere to lisp source files in the directories
;;;   '/test/{system1,system2}/'
;;; any failure is recorded as a transcript entry which indicates
;;;   ( ( system-pathname module-pathname file-pathname ) missing-pathnames )
;;; where missing pathnames is a list of the component-pathname values which failed to designate an intended file.
;;; of there, if the pathname is logical, both the logical and physical pathname appears.
;;; where NIL appears, the probe-file succeeded.
;;;
;;; the test creates the logical host "ASDFTEST" and the system "test-system".
;;; both are removed at the conclusion.
;;;
;;; 20100314:
;;; (:module "a/b/c.d") => (make-pathname :directory '(:relative "a" "b" "c.d"))
;;; (:file "a/b/c.d") => (make-pathname :directory '(:relative "a" "b") :name "c.d" :type "lisp"))
;;; (:static-file "a/b/c.d") => (make-pathname :directory '(:relative "a" "b") :name "c" :type "d"))
;;; (:module "/a/b/c.d") => (make-pathname :directory '(:absolute "a" "b" "c.d"))
;;; (:file "/a/b/c.d") => (make-pathname :directory '(:absolute "a" "b") :name "c.d" :type "lisp"))
;;; (:static-file "/a/b/c.d") => (make-pathname :directory '(:absolute "a" "b") :name "c" :type "d"))
;;;
;;; (:file "file2.lisp") means #p"file2.lisp.lisp"
;;; (:static-file "file2.lisp") means #p"file2.lisp"
;;; (:file "module1-1/file3.lisp") means #p"module1-1/file3.lisp.lisp" (assuming /)
;;; (:static-file "module1-1/file3.lisp") means #p"module1-1/file3.lisp"

33
(defun test-component-pathnames (&key (root (asdf::pathname-directory-pathname *asdf-fasl*))
34
                                 (delete-host t)
35 36
                                 (support-string-pathnames nil)
                                 (support-absolute-string-pathnames nil))
37 38 39 40 41 42 43 44 45 46 47 48
  (unwind-protect
    (let* ((bin-type (pathname-type (compile-file-pathname "test.lisp")))
           (root-directory-namestring (format nil "~{/~a~}/" (rest (pathname-directory root))))
           (system-count 0)
           (system-failures 0)
           (file-count 0)
           (file-failures 0)
           (directory-count 0)
           (directory-failures 0)
           (*print-pretty* nil)
           (start-time 0))

49 50 51
      (with-open-file (result-stream (asdf::merge-pathnames* "output.txt" root)
                                     :direction :output
                                     :if-exists :supersede :if-does-not-exist :create)
52 53 54 55
        (flet ((src-dir (&rest path) (append (pathname-directory root) (cons "asdf-src" path)))
               (bin-dir (&rest path) (append (pathname-directory root) (cons "asdf-bin" path))))
          (setf (logical-pathname-translations "ASDFTEST")
                `((,(format nil "**;*.~a" bin-type)
56 57
                   ,(make-pathname :directory (bin-dir :wild-inferiors)
                                   :name :wild :type bin-type :version nil))
58
                  (,(format nil "**;*.~a.*" bin-type)
59 60
                   ,(make-pathname :directory (bin-dir :wild-inferiors)
                                   :name :wild :type bin-type))
61
                  ("**;*.*"
62 63
                   ,(make-pathname :directory (src-dir :wild-inferiors)
                                   :name :wild :type :wild :version nil))
64
                  ("**;*.*.*"
65 66
                   ,(make-pathname :directory (src-dir :wild-inferiors)
                                   :name :wild :type :wild))))
67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86
          (let ((failures nil)
                (systems `(,(make-pathname :directory (src-dir "system1") :name nil :type nil)
                           ,(make-pathname :host "ASDFTEST" :directory '(:absolute "system1"))
                           ,(parse-namestring "ASDFTEST:system1;")
                           ,@(when support-string-pathnames
                               `(,(format nil "~{/~a~}/asdf-src/system1" (rest (pathname-directory root)))))))

                (modules `(nil
                           ,(make-pathname :directory '(:relative) :name nil :type nil)
                           ,(make-pathname :directory '(:relative "module2") :name nil :type nil)
                           ,(make-pathname :directory '(:relative "module2" "module3") :name nil :type nil)
                           ,(make-pathname :directory (src-dir "system2" "module4") :name nil :type nil)
                           ,(make-pathname :host "ASDFTEST" :directory '(:absolute "system2" "module4") :name nil :type nil)
                           ,(parse-namestring "ASDFTEST:system2;module4;")
                           ,@(when support-string-pathnames
                               `(""
                                 "module2"
                                 "module2/"
                                 "module2/module3"
                                 "module2/module3/"
87 88 89 90 91 92
                                 ,@(when support-absolute-string-pathnames
                                     `(,(concatenate 'string root-directory-namestring "asdf-src/system1/module1")
                                       ,(concatenate 'string root-directory-namestring "asdf-src/system1/module1/")
                                       ,(concatenate 'string root-directory-namestring "asdf-src/system1/module2/")
                                       ,(concatenate 'string root-directory-namestring "asdf-src/system1/module2/module3/")
                                       ,(concatenate 'string root-directory-namestring "asdf-src/system2/module4/")))))))
93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110
                (files `(nil
                         ,(make-pathname :directory '(:relative) :name "untyped-file" :type nil)
                         "file"
                         ,(make-pathname :directory '(:relative) :name "file" :type "lisp")
                         "typed-file.type"
                         ,(make-pathname :directory '(:relative "module2") :name  "untyped-file" :type nil)
                         ,(make-pathname :directory '(:relative "module2") :name  "file" :type "lisp")
                         ,(make-pathname :directory '(:relative "module2" "module3") :name  "file" :type "lisp")
                         ,(make-pathname :directory (src-dir "system1" "module1") :name "untyped-file" :type nil)
                         ,(make-pathname :directory (src-dir "system1" "module1") :name "file" :type "lisp")
                         ,(make-pathname :directory (src-dir "system1" "module2") :name "untyped-file" :type nil)
                         ,(make-pathname :directory (src-dir "system1" "module2") :name "file" :type "lisp")
                         ,(make-pathname :directory (src-dir "system1" "module2" "module3") :name "file" :type "lisp")
                         ,(make-pathname :directory (src-dir "system2" "module4") :name "file" :type "lisp")
                         ,(make-pathname :host "ASDFTEST" :directory '(:absolute "system2" "module4") :name "file" :type "lisp")
                         ,(parse-namestring "ASDFTEST:system2;module4;file.lisp")
                         ,@(when support-string-pathnames
                             `(,(concatenate 'string root-directory-namestring "asdf-src/system1/module1/file.lisp")))))
111

112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133
                (test-files (remove-duplicates
                             (sort (loop
                                     ;; enumerate (system x module x file) pathname variations for relative
                                     ;; file component names. no additions for the absolute specifications,
                                     ;; as they should reiterate one of the relative names
                                     for directory in (list (src-dir "system1")
                                                            (src-dir "system1" "module1")
                                                            (src-dir "system1" "module2")
                                                            (src-dir "system1" "module2" "module3")
                                                            (src-dir "system2" "module4"))
                                     ;; :pathname #p"untyped-file"
                                     collect (make-pathname :directory directory :name "untyped-file" :type nil)
                                     ;; :file "file"
                                     collect (make-pathname :directory directory :name "file" :type "lisp")     ; for source files
                                     collect (make-pathname :directory directory :name "file" :type nil)        ; for static files
                                     ;; :file "typed-file.type"
                                     collect (make-pathname :directory directory :name "typed-file.type" :type "lisp")  ; for source files
                                     collect (make-pathname :directory directory :name "typed-file" :type "type")       ; for static files for :pathname arg
                                     ;; :static-file "static-file.type"
                                     collect (make-pathname :directory directory :name "static-file" :type "type")
                                     ;; :file "module2/file"
                                     collect (make-pathname :directory directory :name "file" :type "lisp")
134
                                     ;; :file "module2/typed-file.type"
135
                                     collect (make-pathname :directory directory :name "typed-file.type" :type "lisp")          ; for source files
136
                                     ;;collect (make-pathname :directory directory :name "typed-file.type" :type nil)          ; for static files ;; invalid as static file, unlike the below.
137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160
                                     ;; :static-file "module2/static-file.type"
                                     collect (make-pathname :directory directory :name "static-file" :type "type")

                                     ;;; source file pathname variations
                                     collect (make-pathname :directory (append directory '("module2")) :name  "untyped-file" :type nil)
                                     collect (make-pathname :directory (append directory '("module2")) :name  "file" :type "lisp")
                                         collect (make-pathname :directory (append directory '("module2")) :name  "typed-file.type" :type "lisp")
                                     collect (make-pathname :directory (append directory '("module2")) :name  "static-file" :type "type")
                                     collect (make-pathname :directory (append directory '("module2" "module3")) :name  "file" :type "lisp")
                                     collect (make-pathname :directory (append directory '("module2" "module3")) :name  "file" :type "lisp"))
                                   #'string-lessp
                                   ;; generate an alternative key in case namestring fails on a name w/ a dot
                                   :key #'(lambda (p) (format nil "~{~a~^.~}~@[.~a~]~@[.~a~]" (rest (pathname-directory p)) (pathname-name p) (pathname-type p))))
                             :test #'equalp :from-end t)))

            (dolist (file test-files)
              (ensure-directories-exist file)
              (with-open-file (stream file :direction :output :if-exists :supersede :if-does-not-exist :create) stream))

            (multiple-value-bind (second minute hour day month year) (decode-universal-time (setf start-time (get-universal-time)) 0)
              (let ((header (format nil "~4,'0d~2,'0d~2,'0dT~2,'0d~2,'0d~2,'0dZ : ~a ~a ~a"
                                    year month day hour minute second
                                    (lisp-implementation-type)
                                    (lisp-implementation-version)
161
                                    (asdf:asdf-version))))
162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179
                (format result-stream ";;; ~a~%~%" header)
                (format *trace-output* "~%;;; ~a~%~%" header)))
            (sleep 1)

            (dolist (system-pathname systems)
              (dolist (module-pathname modules)
                (dolist (file-pathname files)
                  (let ((configuration (list system-pathname module-pathname file-pathname))
                        (system-definition `(asdf:defsystem :system1 :pathname ,system-pathname
                                             :components ((:module :module1 :pathname ,module-pathname
                                                           :components ((:file "file" :pathname ,file-pathname)
                                                                        (:file "module2/file" :pathname ,file-pathname)
                                                                        ,@(unless (or (typep system-pathname 'logical-pathname)
                                                                                      (typep module-pathname 'logical-pathname))
                                                                            `((:file "typed-file.type" :pathname ,file-pathname)
                                                                              (:static-file "static-file.type" :pathname ,file-pathname)
                                                                              (:file "module2/typed-file.type" :pathname ,file-pathname)
                                                                              (:static-file "module2/static-file.type" :pathname ,file-pathname)
180 181
                                                                              ,@(when support-absolute-string-pathnames
                                                                                      `((:static-file ,(concatenate 'string root-directory-namestring
182
                                                                                                          "asdf-src/system1/module1/file.lisp")
183
                                                                                            :pathname ,file-pathname)))))))))))
184 185 186 187 188

                    (block :test-system
                      (handler-bind
                        ((error (lambda (c)
                                  (incf system-failures)
189
                                  (format *error-output* "~&error! ~a~%sysdef:~% ~S~%" c system-definition)
190 191 192
                                  #+sbcl (sb-debug:backtrace 69)
                                  #+clozure (ccl:print-call-history :count 69 :start-frame-number 1)
                                  #+clisp (system::print-backtrace)
193
                                  (format result-stream "~&~%***~%error: ~a~%~s"
194
                                          c system-definition)
195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210
                                  (return-from :test-system))))
                        (unless (and (or (typep system-pathname 'logical-pathname)
                                         (typep module-pathname 'logical-pathname))
                                     (and (stringp file-pathname) (find #\. file-pathname)))
                          (incf system-count)
                          (let* ((system (eval system-definition))
                                 (module (first (asdf:module-components system)))
                                 (file-components (asdf:module-components module)))
                            (incf file-count (length file-components))
                            (incf directory-count 2)
                            (labels ((translate-if-needed (pathname)
                                       (if (typep pathname 'logical-pathname)
                                         (cons (translate-logical-pathname pathname) pathname)
                                         pathname))
                                     (test-module (module)
                                       (incf directory-count)
211
                                       (unless (asdf::probe-file* (asdf:component-pathname module))
212 213 214 215
                                         (incf directory-failures)
                                         (push (list (type-of module) (asdf:component-name module)
                                                     (translate-if-needed (asdf:component-pathname module))
                                                     configuration
216
                                                     (list (when (asdf:component-parent module) (asdf:component-pathname (asdf:component-parent module)))))
217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243
                                               failures)))
                                     (test-file (file)
                                       (incf file-count)
                                       (unless (ignore-errors
                                                (with-open-file (stream (asdf:component-pathname file) :direction :output :if-exists :supersede :if-does-not-exist :error)
                                                  (print start-time stream)))
                                         (incf file-failures)
                                         (push (list (type-of file) (asdf:component-name file)
                                                     (translate-if-needed (asdf:component-pathname file))
                                                     configuration
                                                     (list (asdf:component-pathname  (asdf:component-system file))
                                                           (asdf:component-pathname  (asdf:component-parent file))))
                                               failures))))
                              (test-module system)
                              (test-module module)
                              (dolist (file file-components) (test-file file)))))))))))

            (format result-stream "~% target files [~s]~:{~% ~s -> ~s~}~%"
                    (length test-files)
                    (mapcar #'(lambda (file)
                                (list file (if (probe-file file)
                                             (if (> (file-write-date file) start-time)
                                               :ok
                                               :untouched)
                                             :missing)))
                            test-files))

244
            (format result-stream "~&~%~% translations: ~a: ~s" "ASDFTEST" (logical-pathname-translations "ASDFTEST"))
245

246
            (format result-stream "~&~%~% variations:~% systems: ~s~% modules: ~s~% files: ~s"
247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275
                    systems modules files)

            (let ((homogeneous-failures 0) (*print-length* nil))
              (format result-stream "~&~%~% pathname failures [~s]:" (length failures))
              (dolist (failure failures)
                (destructuring-bind (type name intended-pathname configuration parent-pathnames) failure
                  (format result-stream "~&~%~:[ ~;!~]~a~24T~s~%  missing:~24T~s~%  configuration:~24T~s~%  parent pathnames:~24T~s"
                          (flet ((logical-p (p) (typep p 'logical-pathname)))
                            (when (or (every #'logical-p configuration) (notany #'logical-p configuration))
                              (incf homogeneous-failures)))
                          type name intended-pathname configuration parent-pathnames)))
              (terpri result-stream)
              (print (print `(:result :type ,(lisp-implementation-type) :version ,(lisp-implementation-version)
                                      :file ,(pathname result-stream)
                                      :system-failures (,system-failures ,system-count)
                                      :directory-failures (,directory-failures ,directory-count)
                                      :file-failures (,file-failures ,file-count)
                                      :homogeneous ,homogeneous-failures)
                            result-stream)
                     *trace-output*)
              (terpri *trace-output*)
              (force-output *trace-output*)
              (and (zerop system-failures) (zerop directory-failures)
                   (zerop file-failures) (zerop homogeneous-failures)))))))
    (when delete-host
      (setf (logical-pathname-translations "ASDFTEST") nil))
    (remhash "test-system" asdf::*defined-systems*)))

(quit-on-error
Francois-Rene Rideau's avatar
1.647:  
Francois-Rene Rideau committed
276 277 278 279 280
 (asdf:initialize-source-registry)
 (format t "source registry: ~S~%" (asdf::source-registry))
 (asdf:initialize-output-translations)
 (format t "output translations: ~S~%" (asdf::output-translations))

281 282
 #+gcl (format t "~&~A~&" (progn (defvar *x* -1) (incf *x*)))

283 284 285 286 287 288 289 290
 (progn ; 1- we're testing with unix, are we not?
   (assert (equal (asdf::resolve-location '(:home)) (truename (user-homedir-pathname))))
   (assert (equal (asdf::resolve-location '("/foo" "bar" "baz")) #p"/foo/bar/baz"))
   (assert (equal (asdf::resolve-location '("/foo" "bar" "baz") :directory t) #p"/foo/bar/baz/"))
   (assert (equal (asdf::resolve-location '("/foo" "bar" "baz") :directory t :wilden t) (asdf::wilden #p"/foo/bar/baz/")))
   (assert (equal (asdf::resolve-location '("/foo" "bar" "baz") :directory nil :wilden t) (asdf::wilden #p"/foo/bar/")))
   (assert (equal (asdf::resolve-location '("/foo" "bar" #p"**/" "baz" #p"*.*") :directory nil :wilden t) #p"/foo/bar/**/baz/*.*")))

291 292 293 294 295 296
 (or (test-component-pathnames :delete-host t :support-string-pathnames nil)
     (leave-lisp "test failed" 1)))

;;; (load "LIBRARY:de;setf;utility;asdf;cp-test.lisp")
;;; (logical-pathname-translations "ASDFTEST")
;;; (gethash "test-system" asdf::*defined-systems*)