Newer
Older
(load "script-support.lisp")
#+gcl (trace asdf:compile-file-pathname*)
;;; 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"
(defun test-component-pathnames (&key (root *build-directory*)
Francois-Rene Rideau
committed
(support-string-pathnames nil)
(support-absolute-string-pathnames nil))
#+gcl (format t "root: ~S~%" root)
(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 (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))))
Francois-Rene Rideau
committed
#-gcl<2.7
(setf (logical-pathname-translations "ASDFTEST")
`((,(format nil "**;*.~a" bin-type)
Francois-Rene Rideau
committed
,(make-pathname :directory (bin-dir :wild-inferiors)
Francois-Rene Rideau
committed
:name :wild :type bin-type :version nil
:defaults root))
(,(format nil "**;*.~a.*" bin-type)
Francois-Rene Rideau
committed
,(make-pathname :directory (bin-dir :wild-inferiors)
Francois-Rene Rideau
committed
:name :wild :type bin-type
:defaults root))
Francois-Rene Rideau
committed
,(make-pathname :directory (src-dir :wild-inferiors)
Francois-Rene Rideau
committed
:name :wild :type :wild :version nil
:defaults root))
Francois-Rene Rideau
committed
,(make-pathname :directory (src-dir :wild-inferiors)
Francois-Rene Rideau
committed
:name :wild :type :wild
:defaults root))))
(let ((failures nil)
Francois-Rene Rideau
committed
(systems `(,(make-pathname :directory (src-dir "system1") :name nil :type nil
:defaults root)
,(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)
Francois-Rene Rideau
committed
,(make-pathname :directory (src-dir "system2" "module4") :name nil :type nil
:defaults root)
,(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/"
Francois-Rene Rideau
committed
,@(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/")))))))
(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")
Francois-Rene Rideau
committed
,(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)
,(make-pathname :host "ASDFTEST" :directory '(:absolute "system2" "module4") :name "file" :type "lisp"
:defaults root)
,(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"
Francois-Rene Rideau
committed
collect (make-pathname :directory directory :name "untyped-file" :type nil
:defaults root)
Francois-Rene Rideau
committed
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
;; :file "typed-file.type"
Francois-Rene Rideau
committed
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
;; :static-file "static-file.type"
Francois-Rene Rideau
committed
collect (make-pathname :directory directory :name "static-file" :type "type"
:defaults root)
;; :file "module2/file"
Francois-Rene Rideau
committed
collect (make-pathname :directory directory :name "file" :type "lisp"
:defaults root)
Francois-Rene Rideau
committed
;; :file "module2/typed-file.type"
Francois-Rene Rideau
committed
collect (make-pathname :directory directory :name "typed-file.type" :type "lisp"
:defaults root) ; 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.
;; :static-file "module2/static-file.type"
Francois-Rene Rideau
committed
collect (make-pathname :directory directory :name "static-file" :type "type"
:defaults root)
;;; source file pathname variations
Francois-Rene Rideau
committed
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))
#'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)
Francois-Rene Rideau
committed
,@(when support-absolute-string-pathnames
`((:static-file ,(concatenate 'string root-directory-namestring
"asdf-src/system1/module1/file.lisp")
Francois-Rene Rideau
committed
:pathname ,file-pathname)))))))))))
(block :test-system
(handler-bind
((error (lambda (c)
(incf system-failures)
(format *error-output* "~&error! ~a~%sysdef:~% ~S~%" 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~%~s"
c system-definition)
(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)
Francois-Rene Rideau
committed
(unless (asdf::probe-file* (asdf:component-pathname module))
(incf directory-failures)
(push (list (type-of module) (asdf:component-name module)
(translate-if-needed (asdf:component-pathname module))
configuration
Francois-Rene Rideau
committed
(list (when (asdf:component-parent module) (asdf:component-pathname (asdf:component-parent module)))))
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
276
277
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: ~s" "ASDFTEST" (logical-pathname-translations "ASDFTEST"))
(format result-stream "~&~%~% variations:~% systems: ~s~% modules: ~s~% files: ~s"
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
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*)))
(defun hash-table->alist (table)
(loop :for key :being :the :hash-keys :of table :using (:hash-value value)
:collect (cons key value)))
(format t "source registry: ~S~%" (hash-table->alist asdf::*source-registry*))
(asdf:initialize-output-translations)
(format t "output translations: ~S~%" (asdf::output-translations))
Francois-Rene Rideau
committed
#+gcl (format t "~&~A~&" (progn (defvar *x* -1) (incf *x*)))
Francois-Rene Rideau
committed
#-(or xcl gcl<2.7) ;;---*** pathnames are known to be massively broken on XCL and GCL 2.6
(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?
(x (asdf::resolve-location '(:home)) (truename (user-homedir-pathname)))
(x (asdf::resolve-location '("/foo" "bar" "baz")) #p"/foo/bar/baz")
(x (asdf::resolve-location '("/foo" "bar" "baz") :directory t) #p"/foo/bar/baz/")
(x (asdf::resolve-location '("/foo" "bar" "baz") :directory t :wilden t) (asdf::wilden #p"/foo/bar/baz/"))
(x (asdf::resolve-location '("/foo" "bar" "baz") :directory nil :wilden t) (asdf::wilden #p"/foo/bar/"))
#-gcl
(x (asdf::resolve-location '("/foo" "bar" :**/ "baz" #p"*.*") :directory nil :wilden t) #p"/foo/bar/**/baz/*.*")))
Francois-Rene Rideau
committed
#-(or xcl gcl<2.7) ;;---*** pathnames are known to be massively broken on XCL and GCL 2.6
(or (test-component-pathnames :delete-host t :support-string-pathnames nil)
(leave-test "test failed" 1)))
;;; (load "LIBRARY:de;setf;utility;asdf;cp-test.lisp")
;;; (logical-pathname-translations "ASDFTEST")
;;; (gethash "test-system" asdf::*defined-systems*)