Skip to content
Snippets Groups Projects
Commit fbef96f3 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau
Browse files

Make asdf-pathname-test more verbose in case of failures,

in the hope that it's easier to understand what's going on.
parent 77efd607
No related branches found
No related tags found
No related merge requests found
......@@ -59,7 +59,7 @@
(system-failures :initform 0)
(directory-failures :initform 0)
(file-failures :initform 0)
(failures :initform ())))
(all-tests :initform ())))
(defparameter *test-status* (make-instance 'test-status))
......@@ -85,53 +85,58 @@
:pathname ,file-pathname))))))))))
(defun translate-if-needed (pathname)
(if (typep pathname 'logical-pathname)
(if (logical-pathname-p pathname)
(cons (translate-logical-pathname pathname) pathname)
pathname))
(defun test-module (module &key configuration (test-status *test-status*))
(with-slots (system-count directory-count file-count
system-failures directory-failures file-failures failures) test-status
system-failures directory-failures file-failures all-tests) test-status
(incf directory-count)
(cond
((probe-file* (component-pathname module))
t)
(t
(incf directory-failures)
(push (list (type-of module) (component-find-path module)
(translate-if-needed (component-pathname module))
configuration
(list (if-let (parent (component-parent module))
(component-pathname parent))))
failures)
nil))))
(let ((success (and (probe-file* (component-pathname module)) t)))
(unless success
(incf directory-failures))
(push (list success (type-of module) (component-find-path module)
(translate-if-needed (component-pathname module))
configuration
(list (if-let (parent (component-parent module))
(component-pathname parent))))
all-tests)
success)))
(defparameter *backtraces* 0)
(defparameter *max-backtraces* 2)
(defparameter *max-backtraces* 4)
(defun test-file (file &key configuration (test-status *test-status*) (start-time 0))
(with-slots (system-count directory-count file-count
system-failures directory-failures file-failures failures) test-status
(incf file-count)
(unless (block nil
system-failures directory-failures file-failures all-tests) test-status
(let ((success
(block nil
(handler-bind ((error #'(lambda (c)
(incf *backtraces*)
(when (<= *backtraces* *max-backtraces*)
(print-condition-backtrace c))
(dolist (o (list *trace-output*))
(format o "BACKTRACES: ~S (max ~S)~%"
*backtraces* *max-backtraces*)
(when (<= *backtraces* *max-backtraces*)
(print-condition-backtrace c :stream o)))
(return nil))))
(assert (probe-file* (component-pathname file)))
(with-open-file (stream (component-pathname file)
:direction :output :if-exists
(or #+(and sbcl os-windows) :rename-and-delete :supersede)
:if-does-not-exist :error)
(print start-time stream)
t)))
(incf file-failures)
(push (list (type-of file) (component-find-path file)
(assert stream)
(println start-time stream)))
t)))
(incf file-count)
(unless success
(incf file-failures))
(push (list success (type-of file) (component-find-path file)
(translate-if-needed (component-pathname file))
configuration
(list (component-pathname (component-system file))
(component-pathname (component-parent file))))
failures))))
all-tests))))
(defun test-pathname-configuration (&key system-pathname module-pathname file-pathname
(start-time (get-universal-time))
......@@ -139,8 +144,7 @@
(support-absolute-string-pathnames t)
(root-directory-namestring (namestring *build-directory*))
(result-stream *standard-output*))
(with-slots (system-count directory-count file-count
system-failures directory-failures file-failures failures) test-status
(with-slots (system-count directory-count file-count system-failures) test-status
(let ((configuration (list system-pathname module-pathname file-pathname))
(system-definition (pathname-defsystem
:system-pathname system-pathname
......@@ -151,13 +155,12 @@
(handler-bind
((error (lambda (c)
(incf system-failures)
(format *error-output* "~&error! ~a~%sysdef:~% ~S~%" c system-definition)
(print-condition-backtrace c :stream *error-output*)
(format result-stream "~&~%***~%error: ~a~%~s"
c system-definition)
(dolist (o (list *trace-output* result-stream))
(format o "~&error during sysdef:~% ~S~%" system-definition)
(print-condition-backtrace c :stream o))
(return-from test-pathname-configuration test-status))))
(unless (and (or (typep system-pathname 'logical-pathname)
(typep module-pathname 'logical-pathname))
(unless (and (or (logical-pathname-p system-pathname)
(logical-pathname-p module-pathname))
(and (stringp file-pathname) (find #\. file-pathname)))
(incf system-count)
(with-asdf-cache (:override t)
......@@ -166,8 +169,6 @@
(eval system-definition)))
(module (first (component-children system)))
(file-components (component-children module)))
(incf file-count (length file-components))
(incf directory-count 2)
(test-module system :test-status test-status :configuration configuration)
(test-module module :test-status test-status :configuration configuration)
(dolist (file file-components)
......@@ -177,7 +178,7 @@
(defun print-test-report (&key (test-status *test-status*) (result-stream *standard-output*)
(start-time 0) test-files files modules systems)
(with-slots (system-count directory-count file-count
system-failures directory-failures file-failures failures) test-status
system-failures directory-failures file-failures all-tests) test-status
(format result-stream "~% target files [~s]~:{~% ~s -> ~s~}~%"
(length test-files)
(mapcar #'(lambda (file)
......@@ -191,15 +192,24 @@
(format result-stream "~&~%~% variations:~% systems: ~s~% modules: ~s~% files: ~s"
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)))
(let ((homogeneous-failures 0)
(failures (+ system-failures directory-failures file-failures))
(*print-length* nil))
(format result-stream "~&~%~% pathname failures [~s]:" failures)
(dolist (tst (and (plusp failures) all-tests))
(destructuring-bind (success type name intended-pathname configuration parent-pathnames) tst
(format result-stream "~&~%~:[FAILURE~;SUCCESS~] ~:[ ~;!~]~a~24T~s~% ~:[missing: ~;found: ~]~24T~s~% configuration:~24T~s~% parent pathnames:~24T~s"
success
(let ((homogeneousp
(let ((f (first configuration)))
(assert f)
(let ((logicalp (logical-pathname-p f)))
(loop for p in (rest configuration)
always (or (null p) (eq logicalp (logical-pathname-p p))))))))
(when (and (not success) homogeneousp)
(incf homogeneous-failures))
homogeneousp)
type name success intended-pathname configuration parent-pathnames)))
(terpri result-stream)
(print (print `(:result :type ,(lisp-implementation-type) :version ,(lisp-implementation-version)
:file ,(pathname result-stream)
......@@ -211,8 +221,7 @@
*trace-output*)
(terpri *trace-output*)
(force-output *trace-output*)
(and (zerop system-failures) (zerop directory-failures)
(zerop file-failures) (zerop homogeneous-failures)))))
(zerop failures))))
(defun make-test-files (&key (root *build-directory*) (support-string-pathnames t)
(support-absolute-string-pathnames t)
......@@ -352,8 +361,8 @@
(dolist (file test-files)
(ensure-directories-exist file)
(with-open-file (stream file :direction :output :if-exists :supersede :if-does-not-exist :create)
stream))
(println ":dummy-content" stream)
(format t "Created test file ~S~%" file)))
(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"
......@@ -396,9 +405,9 @@
(asdf:initialize-output-translations)
(format t "output translations: ~S~%" (asdf::output-translations))
#-xcl ;;---*** pathnames are known to be massively broken on XCL
;;#-xcl ;;---*** pathnames are known to be massively broken on XCL
(progn
;; we're testing with unix, are we not?
;; we're testing with unix or some emulation, are we not?
(assert-pathname-equal (resolve-location '(:home)) (truename (user-homedir-pathname)))
(assert-pathname-equal (resolve-location '("/foo" "bar" "baz")) #p"/foo/bar/baz")
(assert-pathname-equal (resolve-location '("/foo" "bar" "baz") :ensure-directory t) #p"/foo/bar/baz/")
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment