From 8bf304364d6925fa3e3e368fe801d7cadbe642ad Mon Sep 17 00:00:00 2001
From: Francois-Rene Rideau <tunes@google.com>
Date: Mon, 11 Aug 2014 12:28:00 -0400
Subject: [PATCH] Fix various asdf-tools issues. Don't pipe into tee, as it
 squashes errors. Fix error handling by test-scripts. Fix wc. Fix some test
 logging. Make tests runnable from any directory, and run from the asdf
 directory (not the test directory).

---
 test/test-cache.script                     |  3 +-
 test/test-package.script                   | 12 ++--
 test/test-retry-loading-component-1.script |  8 ++-
 test/test-run-program.script               |  6 +-
 test/test-utilities.script                 |  5 ++
 test/test-version.script                   |  2 +-
 tools/build.lisp                           | 15 ++--
 tools/invoke-lisp.lisp                     |  7 +-
 tools/test-environment.lisp                | 14 ++--
 tools/test-scripts.lisp                    | 81 +++++++++++-----------
 10 files changed, 84 insertions(+), 69 deletions(-)

diff --git a/test/test-cache.script b/test/test-cache.script
index 81e8ff727..4ac015f71 100644
--- a/test/test-cache.script
+++ b/test/test-cache.script
@@ -2,8 +2,7 @@
 
 ;;; test to check that the cache doesn't upset error signaling from FIND-SYSTEM
 
-
-(in-package asdf-test)
+(in-package :asdf-test)
 
 (defparameter *all-systems*
   (list
diff --git a/test/test-package.script b/test/test-package.script
index b8c1b686b..136c87b2a 100644
--- a/test/test-package.script
+++ b/test/test-package.script
@@ -1,9 +1,9 @@
 ;;; -*- Lisp -*-
-
+;;; Testing that defclass module doesn't interfere with use of :module in defsystem.
 
 (in-package :cl-user)
-(asdf-test::with-test ()
- (defun module () 1)
- (load "test-package.asd")
- (defclass module () ())
- (load "test-package.asd"))
+
+(defun module () 1)
+(asdf::load-asd (asdf-test:test-source "test-package.asd"))
+(defclass module () ())
+(asdf::load-asd (asdf-test:test-source "test-package.asd"))
diff --git a/test/test-retry-loading-component-1.script b/test/test-retry-loading-component-1.script
index 2097ce06e..35a8c13ba 100644
--- a/test/test-retry-loading-component-1.script
+++ b/test/test-retry-loading-component-1.script
@@ -1,16 +1,20 @@
 ;;; -*- Lisp -*-
 
+;; NB: this test does some evil side-effects in the test source directory itself. UGH!
+
 ;;; test asdf:try-recompiling restart
 
 (defvar *caught-error* nil)
-(delete-file-if-exists "try-reloading-dependency.asd")
+(delete-file-if-exists (test-source "try-reloading-dependency.asd"))
 (with-asdf-cache (:override t)
 (handler-bind
     ((error #'(lambda (c)
                 (format t "~&Caught error ~s" c)
 		(assert (not *caught-error*) () "Déjà vu")
                 (setf *caught-error* t)
-                (concatenate-files '("try-reloading-dependency.hidden") "try-reloading-dependency.asd")
+                ;; Evil side-effect: create a .asd file from .hidden file.
+                (concatenate-files (list (test-source "try-reloading-dependency.hidden"))
+                                   (test-source "try-reloading-dependency.asd"))
                 (DBG "trlc1 5")
                 (multiple-value-bind (name mode) (find-symbol* :retry :asdf)
                   (assert (eq mode :external) () "Mode of ~s was not external" name)
diff --git a/test/test-run-program.script b/test/test-run-program.script
index 39abbe493..227b1f536 100644
--- a/test/test-run-program.script
+++ b/test/test-run-program.script
@@ -37,9 +37,10 @@
 
 #+os-unix
 (progn
+  (chdir *test-directory*)
+
   (DBG "Testing good shell command in current directory via run-shell-command")
-  (unless (equal 0 (run-shell-command "./good-shell-command"))
-    (error "Failed to capture exit status indicating shell command success."))
+  (assert-equal 0 (run-shell-command "./good-shell-command"))
 
   ;; this test checks for a problem there was in allegro -- :output :interactive
   ;; would try to open T as a stream for INPUT.
@@ -263,4 +264,3 @@ Testing run-program
 
 
 (test/run-program)
-
diff --git a/test/test-utilities.script b/test/test-utilities.script
index ec02a68fd..d4a70dc30 100644
--- a/test/test-utilities.script
+++ b/test/test-utilities.script
@@ -1,5 +1,10 @@
 ;;; -*- Lisp -*-
 
+(chdir *asdf-directory*)
+(assert (pathname-equal *asdf-directory* (getcwd)))
+(chdir *test-directory*)
+(assert (pathname-equal *test-directory* (getcwd)))
+
 (assert
  (every #'directory-pathname-p
   (list
diff --git a/test/test-version.script b/test/test-version.script
index 092387caf..295e108a7 100644
--- a/test/test-version.script
+++ b/test/test-version.script
@@ -37,7 +37,7 @@
 (def-test-system :versioned-system-file-line
   :defsystem-depends-on ((:version :test-asdf/2 "2.1"))
   :pathname #.*test-directory*
-  :version (:read-file-line "version.lisp-expr" :at 1))
+  :version (:read-file-line #.(test-source "version.lisp-expr") :at 1))
 
 (defun vtest (name v &optional (true t))
   (or (eq true (version-satisfies (find-system name) v))
diff --git a/tools/build.lisp b/tools/build.lisp
index 0dc396825..ec54a1f0b 100644
--- a/tools/build.lisp
+++ b/tools/build.lisp
@@ -19,9 +19,12 @@
 (defun wc ()
   "count lines of lisp code in asdf and uiop"
   (with-asdf-dir ()
-    (run `(pipe (wc ,@(driver-files)) (sort -n)))
-    (terpri)
-    (run `(pipe (wc header.lisp ,@(asdf-defsystem-files)) (sort -n)))
-    (terpri)
-    (run `(pipe (wc header.lisp ,@(driver-files) ,@(asdf-defsystem-files)) (tail -n 1)))))
-
+    (flet ((lisp-only (x) (remove "lisp" x :test-not 'equal :key 'pathname-type)))
+      (let ((driver-files (mapcar #'(lambda (x) (subpathname "uiop/" x)) (lisp-only (uiop-files))))
+            (defsystem-files (lisp-only (asdf-defsystem-files))))
+        (run `(pipe (wc ,@driver-files) (sort -n)))
+        (terpri)
+        (run `(pipe (wc header.lisp ,@defsystem-files) (sort -n)))
+        (terpri)
+        (run `(pipe (wc header.lisp ,@driver-files ,@defsystem-files) (tail -n 1))))))
+  (values))
diff --git a/tools/invoke-lisp.lisp b/tools/invoke-lisp.lisp
index 203b0372e..ae07a104e 100644
--- a/tools/invoke-lisp.lisp
+++ b/tools/invoke-lisp.lisp
@@ -216,7 +216,10 @@ a preformatted string, or a LIST that specifies a program."
     (string (output-string forms s))
     (list (format s "~{~A~%~}"
                   (with-standard-io-syntax
-                    (let ((*package* (find-package :cl)))
-                      (mapcar (lambda (x) (typecase x (string x) (t (write x :stream s :case :downcase))))
+                    (let ((*package* (find-package :cl))
+                          (*print-case* :downcase))
+                      (mapcar (lambda (x)
+                                (typecase x (string x)
+                                          (t (write-to-string x))))
                               forms)))))))
 
diff --git a/tools/test-environment.lisp b/tools/test-environment.lisp
index 458238830..36f7a4167 100644
--- a/tools/test-environment.lisp
+++ b/tools/test-environment.lisp
@@ -187,7 +187,7 @@
 
 (defun run-test-lisp (activity forms &key (output t) log lisp debugger)
   ;; Activity is of the form "compiling ASDF", "running this test", etc.
-  (format t "~&Now ~A...~%" activity)
+  (format t "~&Now ~A...~@[ (log in ~A)~]~%" activity log)
   (let* ((eval (compose-eval-string forms))
          (command (lisp-invocation-arglist :implementation-type (get-lisp lisp)
                                            :eval eval :debugger debugger))
@@ -196,8 +196,8 @@
          (output (if (eq output *stdout*) :interactive output)))
     (log! log "~A" (print-process-spec command nil))
     (multiple-value-bind (okp out err code)
-        (run* `(pipe ((>& 2 1) ,@(when interactive '(rlwrap)) ,@command)
-                     ,@(when log `((tee -a ,log))))
+        (run* `((>& 2 1) ,@(when interactive '(rlwrap)) ,@command
+                ,@(when log `((>> ,log)))) ;; unhappily, | tee -a log eats error codes :-(
               :input interactive :output output :error-output (or interactive :output) :on-error nil)
       (unless interactive
         (log! log (if okp
@@ -208,7 +208,9 @@ You can retry ~A with:
 or more interactively, start with:
     ~A~%(rlwrap is optional; don't use it when in emacs; skip if not installed.)
 then copy/paste:
-    ~A")
-              activity activity (print-process-spec command nil)
-              (interactive-command) (compose-copy-paste-string forms)))
+~@<    ~@;~A~@:>~&")
+              activity activity
+              (print-process-spec command nil)
+              (print-process-spec (interactive-command) nil)
+              (compose-copy-paste-string forms)))
     (values okp out err code))))
diff --git a/tools/test-scripts.lisp b/tools/test-scripts.lisp
index 57cc931da..a20fe8269 100644
--- a/tools/test-scripts.lisp
+++ b/tools/test-scripts.lisp
@@ -31,53 +31,52 @@
   "run test scripts
 Use the preferred lisp implementation"
   (nest
-   (with-asdf-dir ("test/"))
    (let* ((log (newlogfile "test" lisp)))
      (log! log "Running the following ~D ASDF test scripts on ~(~A~):~%~{  ~A~%~}"
-           (length test-scripts) lisp test-scripts)
-    (and
-     (run-test-lisp
-      "compiling ASDF"
-      '((load "script-support.lisp") (asdf-test::compile-asdf-script))
-      :lisp lisp :log log)
-     (loop
-       :with n-tests = (length test-scripts)
-       :with test-pass = 0
-       :with test-fail = 0
-       :with failed-list = ()
-       :for i :in test-scripts
-       :for ni = (native-namestring i)
-       :for test-count :from 0
-       :do
-          ;; TODO: do we want to delete the output file cache?
-          ;; If so, we need to do it in the inferior lisp,
-          ;; because only it knows for sure its output configuration.
-          ;; Or we could do it in a more heavy handed way.
-          (if (run-test-lisp
-               (format nil "testing ~A on ~(~A~)" i lisp)
-               `((load "script-support.lisp")
-                 (asdf-test::load-asdf)
-                 (asdf-test::frob-packages)
-                 (asdf-test::run-test-script ,ni))
-               :lisp lisp :log log)
-              (incf test-pass)
-              (progn
-                (incf test-fail)
-                (push i failed-list)))
-       :finally
-          (let ((okp (zerop test-fail)))
-            (format t "~
+           (length test-scripts) lisp test-scripts))
+   (and
+    (run-test-lisp
+     "compiling ASDF"
+     '((load "test/script-support.lisp") (asdf-test::compile-asdf-script))
+     :lisp lisp :log log))
+   (loop
+     :with n-tests = (length test-scripts)
+     :with test-pass = 0
+     :with test-fail = 0
+     :with failed-list = ()
+     :for i :in test-scripts
+     :for ni = (native-namestring (subpathname "test/" i))
+     :for test-count :from 0
+     :do
+        ;; TODO: do we want to delete the output file cache?
+        ;; If so, we need to do it in the inferior lisp,
+        ;; because only it knows for sure its output configuration.
+        ;; Or we could do it in a more heavy handed way.
+        (if (run-test-lisp
+             (format nil "testing ~A on ~(~A~)" i lisp)
+             `((load "test/script-support.lisp")
+               (asdf-test::load-asdf)
+               (asdf-test::frob-packages)
+               (asdf-test::run-test-script ,ni))
+             :lisp lisp :log log)
+            (incf test-pass)
+            (progn
+              (incf test-fail)
+              (push i failed-list)))
+     :finally
+        (let ((okp (zerop test-fail)))
+          (log! log "~
 -#---------------------------------------
 Using ~A
-Ran ~D tests, ~D passed, ~D failed
-~:[All tests apparently successful.~;:~:*~{~%  ~A~}~]
+Ran ~D tests, ~D passed, ~D failed~
+~:[~%All tests apparently successful.~;:~:*~{~%  ~A~}~]
 -#---------------------------------------~%"
-                    lisp
-                    n-tests test-pass test-fail (reverse failed-list))
-            (unless okp
-              (log! log "To view full results and failures, try the following command:
+                  lisp
+                  n-tests test-pass test-fail (reverse failed-list))
+          (unless okp
+            (log! log "To view full results and failures, try the following command:
      less -p ABORTED ~A" (enough-namestring log (pn))))
-            (return okp)))))))
+          (return okp)))))
 
 (deftestcmd %test (lisp test-scripts)
   "run all normal tests but upgrade tests
-- 
GitLab