From fbef96f3ab74165dd4df013c0b0d6115506a5389 Mon Sep 17 00:00:00 2001
From: Francois-Rene Rideau <tunes@google.com>
Date: Thu, 19 Dec 2013 19:13:27 -0500
Subject: [PATCH] Make asdf-pathname-test more verbose in case of failures, in
 the hope that it's easier to understand what's going on.

---
 test/asdf-pathname-test.script | 113 ++++++++++++++++++---------------
 1 file changed, 61 insertions(+), 52 deletions(-)

diff --git a/test/asdf-pathname-test.script b/test/asdf-pathname-test.script
index fbadd485..677dfba2 100644
--- a/test/asdf-pathname-test.script
+++ b/test/asdf-pathname-test.script
@@ -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/")
-- 
GitLab