asdf-pathname-test.script 22 KB
Newer Older
1
;;; -*- Lisp -*-
2
(load "script-support.lisp")
3
(in-package :asdf-test)
4 5
(load-asdf)

6 7
;;(setf *unspecific-pathname-type* nil)

8 9
#+gcl (trace asdf:compile-file-pathname*)

10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37
;;; 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"

38
(defun test-component-pathnames (&key (root *build-directory*)
39
                                 (delete-host t)
40 41
                                 (support-string-pathnames nil)
                                 (support-absolute-string-pathnames nil))
42
  #+gcl (format t "root: ~S~%" root)
43 44 45 46 47 48 49 50 51 52 53 54
  (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))

55
      (with-open-file (result-stream (subpathname
56 57
                                      *build-directory*
                                      (format nil "results/~(~A~)-pathnames.txt" *implementation*))
58 59
                                     :direction :output
                                     :if-exists :supersede :if-does-not-exist :create)
60 61 62 63
        (flet ((src-dir (&rest path) (append (or (pathname-directory root) (list :relative))
                                             (cons "asdf-src" path)))
               (bin-dir (&rest path) (append (or (pathname-directory root) (list :relative))
                                             (cons "asdf-bin" path))))
64
          #-gcl<2.7
65 66
          (setf (logical-pathname-translations "ASDFTEST")
                `((,(format nil "**;*.~a" bin-type)
67
                   ,(make-pathname :directory (bin-dir :wild-inferiors)
68 69
                                   :name :wild :type bin-type :version nil
				   :defaults root))
70
                  (,(format nil "**;*.~a.*" bin-type)
71
                   ,(make-pathname :directory (bin-dir :wild-inferiors)
72 73
                                   :name :wild :type bin-type
				   :defaults root))
74
                  ("**;*.*"
75
                   ,(make-pathname :directory (src-dir :wild-inferiors)
76 77
                                   :name :wild :type :wild :version nil
				   :defaults root))
78
                  ("**;*.*.*"
79
                   ,(make-pathname :directory (src-dir :wild-inferiors)
80 81
                                   :name :wild :type :wild
				   :defaults root))))
82
          (let ((failures nil)
83 84
                (systems `(,(make-pathname :directory (src-dir "system1") :name nil :type nil
					   :defaults root)
85 86 87 88 89 90 91 92 93
                           ,(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)
94 95
                           ,(make-pathname :directory (src-dir "system2" "module4") :name nil :type nil
					   :defaults root)
96 97 98 99 100 101 102 103
                           ,(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/"
104
                                 ,@(when support-absolute-string-pathnames
105 106 107 108 109
                                     `(,(strcat root-directory-namestring "asdf-src/system1/module1")
                                       ,(strcat root-directory-namestring "asdf-src/system1/module1/")
                                       ,(strcat root-directory-namestring "asdf-src/system1/module2/")
                                       ,(strcat root-directory-namestring "asdf-src/system1/module2/module3/")
                                       ,(strcat root-directory-namestring "asdf-src/system2/module4/")))))))
110 111 112 113 114 115 116 117
                (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")
118 119 120 121 122 123 124 125 126 127 128 129
                         ,(make-pathname :directory (src-dir "system1" "module1") :name "untyped-file" :type nil
					 :defaults root)
                         ,(make-pathname :directory (src-dir "system1" "module1") :name "file" :type "lisp"
					 :defaults root)
                         ,(make-pathname :directory (src-dir "system1" "module2") :name "untyped-file" :type nil
					 :defaults root)
                         ,(make-pathname :directory (src-dir "system1" "module2") :name "file" :type "lisp"
					 :defaults root)
                         ,(make-pathname :directory (src-dir "system1" "module2" "module3") :name "file" :type "lisp"
					 :defaults root)
                         ,(make-pathname :directory (src-dir "system2" "module4") :name "file" :type "lisp"
					 :defaults root)
130
                         ,(make-pathname :host "ASDFTEST" :directory '(:absolute "system2" "module4") :name "file" :type "lisp" :version nil
131
					 :defaults root)
132 133 134
                         ,(parse-namestring "ASDFTEST:system2;module4;file.lisp")
                         ,@(when support-string-pathnames
                             `(,(concatenate 'string root-directory-namestring "asdf-src/system1/module1/file.lisp")))))
135

136 137 138 139 140 141 142 143 144 145 146
                (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"
147 148
                                     collect (make-pathname :directory directory :name "untyped-file" :type nil
							    :defaults root)
149
                                     ;; :file "file"
150 151 152 153
                                     collect (make-pathname :directory directory :name "file" :type "lisp"
							    :defaults root)     ; for source files
                                     collect (make-pathname :directory directory :name "file" :type nil
							    :defaults root)        ; for static files
154
                                     ;; :file "typed-file.type"
155 156 157 158
                                     collect (make-pathname :directory directory :name "typed-file.type" :type "lisp"
							    :defaults root)  ; for source files
                                     collect (make-pathname :directory directory :name "typed-file" :type "type"
							    :defaults root)       ; for static files for :pathname arg
159
                                     ;; :static-file "static-file.type"
160 161
                                     collect (make-pathname :directory directory :name "static-file" :type "type"
							    :defaults root)
162
                                     ;; :file "module2/file"
163 164
                                     collect (make-pathname :directory directory :name "file" :type "lisp"
							    :defaults root)
165
                                     ;; :file "module2/typed-file.type"
166 167
                                     collect (make-pathname :directory directory :name "typed-file.type" :type "lisp"
							    :defaults root)          ; for source files
168
                                     ;;collect (make-pathname :directory directory :name "typed-file.type" :type nil)          ; for static files ;; invalid as static file, unlike the below.
169
                                     ;; :static-file "module2/static-file.type"
170 171
                                     collect (make-pathname :directory directory :name "static-file" :type "type"
							    :defaults root)
172 173

                                     ;;; source file pathname variations
174 175 176 177 178 179 180 181 182 183 184 185
                                     collect (make-pathname :directory (append directory '("module2")) :name  "untyped-file" :type nil
							    :defaults root)
                                     collect (make-pathname :directory (append directory '("module2")) :name  "file" :type "lisp"
							    :defaults root)
                                         collect (make-pathname :directory (append directory '("module2")) :name  "typed-file.type" :type "lisp"
								:defaults root)
                                     collect (make-pathname :directory (append directory '("module2")) :name  "static-file" :type "type"
							    :defaults root)
                                     collect (make-pathname :directory (append directory '("module2" "module3")) :name  "file" :type "lisp"
							    :defaults root)
                                     collect (make-pathname :directory (append directory '("module2" "module3")) :name  "file" :type "lisp"
							    :defaults root))
186 187 188 189 190 191 192 193 194 195 196 197 198 199
                                   #'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)
200
                                    (asdf:asdf-version))))
201 202 203 204 205 206 207 208
                (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))
209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226
                        (system-definition
                          `(defsystem :system1
                             :pathname ,system-pathname
                             :source-file ,(subpathname system-pathname "nosuchfile.asd")
                             :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)
                                      ,@(when support-absolute-string-pathnames
                                          `((:static-file ,(strcat root-directory-namestring "asdf-src/system1/module1/file.lisp")
                                             :pathname ,file-pathname)))))))))))
227 228 229

                    (block :test-system
                      (handler-bind
230
                          ((error (lambda (c)
231
                                  (incf system-failures)
232
                                  (format *error-output* "~&error! ~a~%sysdef:~% ~S~%" c system-definition)
233
                                  (print-condition-backtrace c :stream *error-output*)
234
                                  (format result-stream "~&~%***~%error: ~a~%~s"
235
                                          c system-definition)
236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251
                                  (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)
252
                                       (unless (probe-file* (asdf:component-pathname module))
253 254 255 256
                                         (incf directory-failures)
                                         (push (list (type-of module) (asdf:component-name module)
                                                     (translate-if-needed (asdf:component-pathname module))
                                                     configuration
257
                                                     (list (when (asdf:component-parent module) (asdf:component-pathname (asdf:component-parent module)))))
258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284
                                               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))

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

287
            (format result-stream "~&~%~% variations:~% systems: ~s~% modules: ~s~% files: ~s"
288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315
                    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*)))

316
(with-test ()
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
317
 (asdf:initialize-source-registry)
318
 (format t "source registry: ~S~%" (hash-table->alist asdf::*source-registry*))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
319 320 321
 (asdf:initialize-output-translations)
 (format t "output translations: ~S~%" (asdf::output-translations))

322
 #+gcl (format t "~&~A~&" (progn (defvar *x* -1) (incf *x*)))
323
 #-(or xcl gcl<2.7) ;;---*** pathnames are known to be massively broken on XCL and GCL 2.6
324 325 326 327 328 329
 (flet ((same (s1 s2 p1 p2)
          (unless (equal (namestring p1) (namestring p2))
            (describe p1) (describe p2)
            (error "Not the same: ~S vs ~S"  s1 s2))))
   (macrolet ((x (s1 s2) `(same ',s1 ',s2 ,s1 ,s2)))
     ;; we're testing with unix, are we not?
330 331
     (x (resolve-location '(:home)) (truename (user-homedir-pathname)))
     (x (resolve-location '("/foo" "bar" "baz")) #p"/foo/bar/baz")
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
332 333 334
     (x (resolve-location '("/foo" "bar" "baz") :ensure-directory t) #p"/foo/bar/baz/")
     (x (resolve-location '("/foo" "bar" "baz") :ensure-directory t :wilden t) (wilden #p"/foo/bar/baz/"))
     (x (resolve-location '("/foo" "bar" "baz") :ensure-directory nil :wilden t) (wilden #p"/foo/bar/"))
335
     #-gcl
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
336
     (x (resolve-location '("/foo" "bar" :**/ "baz" #p"*.*") :ensure-directory nil :wilden t) #p"/foo/bar/**/baz/*.*")))
337

338
 #-(or xcl gcl<2.7) ;;---*** pathnames are known to be massively broken on XCL and GCL 2.6
339
 (or (test-component-pathnames :delete-host t :support-string-pathnames nil)
340
     (leave-test "test failed" 1)))
341 342 343 344

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