Newer
Older
;;; -*- Lisp -*-
(load "script-support")
(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"
Francois-Rene Rideau
committed
(defun test-component-pathnames (&key (root (asdf::pathname-directory-pathname *asdf-fasl*))
(delete-host t)
(support-string-pathnames nil))
(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))
Francois-Rene Rideau
committed
(with-open-file (result-stream (asdf::merge-pathnames* "output.txt" root)
:direction :output
:if-exists :supersede :if-does-not-exist :create)
(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)
Francois-Rene Rideau
committed
,(make-pathname :directory (bin-dir :wild-inferiors)
:name :wild :type bin-type :version nil))
(,(format nil "**;*.~a.*" bin-type)
Francois-Rene Rideau
committed
,(make-pathname :directory (bin-dir :wild-inferiors)
:name :wild :type bin-type))
Francois-Rene Rideau
committed
,(make-pathname :directory (src-dir :wild-inferiors)
:name :wild :type :wild :version nil))
Francois-Rene Rideau
committed
,(make-pathname :directory (src-dir :wild-inferiors)
:name :wild :type :wild))))
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
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
(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/"
,(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/")))))
(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")))))
Francois-Rene Rideau
committed
(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")
Francois-Rene Rideau
committed
;; :file "module2/typed-file.type"
collect (make-pathname :directory directory :name "typed-file.type" :type "lisp") ; for source files
Francois-Rene Rideau
committed
;;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
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
;; :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)
asdf::*asdf-version*)))
(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)
(:static-file ,(concatenate 'string root-directory-namestring
"asdf-src/system1/module1/file.lisp")
:pathname ,file-pathname)))))))))
(block :test-system
(handler-bind
((error (lambda (c)
(incf system-failures)
(format *error-output* "~&error! ~a~%sysdef:~% ~W~%" c system-definition)
#+sbcl (sb-debug:backtrace 69)
#+clozure (ccl:print-call-history :count 69 :start-frame-number 1)
#+clisp (system::print-backtrace)
(format result-stream "~&~%***~%error: ~a~%~:w"
c system-definition)
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
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
244
245
246
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
(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)
(unless #-clisp (probe-file (asdf:component-pathname module))
#+clisp (ext:probe-directory (asdf:component-pathname module))
(incf directory-failures)
(push (list (type-of module) (asdf:component-name module)
(translate-if-needed (asdf:component-pathname module))
configuration
(list (when (asdf:component-parent module) (asdf:component-pathname (asdf:component-parent module)))))
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))
(format result-stream "~&~%~% translations: ~a: ~:w" "ASDFTEST" (logical-pathname-translations "ASDFTEST"))
(format result-stream "~&~%~% variations:~% systems: ~:w~% modules: ~:w~% files: ~:w"
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
(asdf:initialize-source-registry)
(format t "source registry: ~S~%" (asdf::source-registry))
(asdf:initialize-output-translations)
(format t "output translations: ~S~%" (asdf::output-translations))
(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*)