[Sbcl-commits] master: tests: better reports when /bin/ed is not present.

[stassats <sta...@us...>]

The branch "master" has been updated in SBCL:
       via  c0f9314af1b6f7aa67e6c5db523d6ddef735986c (commit)
      from  5728601f88c400d2992b6b8c70d8971d07de9029 (commit)

- Log -----------------------------------------------------------------
commit c0f9314af1b6f7aa67e6c5db523d6ddef735986c
Author: Stas Boukarev <sta...@gm...>
Date:   Fri Nov 1 16:34:27 2013 +0400

    tests: better reports when /bin/ed is not present.
    
    When /bin/ed is not present the test failed with a confusing "unhandled
    error".
    * Wrap the whole run-program-ed test into with-test, renaming it to run-program-/bin/ed.
    * Add before it a test named :is-/bin/ed-installed?.
    
    Making the report more self-describing:
     Failure:            run-program.impure.lisp / IS-/BIN/ED-INSTALLED?
     Failure:            run-program.impure.lisp / RUN-PROGRAM-/BIN/ED
---
 tests/run-program.impure.lisp |   88 +++++++++++++++++++----------------------
 tests/run-tests.lisp          |   50 ++++++++++++-----------
 2 files changed, 67 insertions(+), 71 deletions(-)

diff --git a/tests/run-program.impure.lisp b/tests/run-program.impure.lisp
index 0088c56..32d7606 100644
--- a/tests/run-program.impure.lisp
+++ b/tests/run-program.impure.lisp
@@ -160,53 +160,47 @@
 ;;; buffering of stdin and stdout depends on their TTYness, and ed isn't sufficiently
 ;;; agressive about flushing them. So, here's another test using :PTY.
 
-#-win32 (progn ;; kludge: It would be nicer to disable individual test cases,
-               ;; but we are not using WITH-TEST yet here.
-
-(defparameter *tmpfile* "run-program-ed-test.tmp")
-
-(with-open-file (f *tmpfile*
-                   :direction :output
-                   :if-exists :supersede)
-  (write-line "bar" f))
-
-(defparameter *ed*
-  (run-program "/bin/ed" (list *tmpfile*) :wait nil :pty t))
-
-(defparameter *ed-pipe* (make-two-way-stream (process-pty *ed*) (process-pty *ed*)))
-(defparameter *ed-in* (make-synonym-stream '*ed-pipe*))
-(defparameter *ed-out* (make-synonym-stream '*ed-pipe*))
-
-(defun read-linish (stream)
-  (with-output-to-string (s)
-    (loop for c = (read-char stream)
-          while (and c (not (eq #\newline c)))
-             ;; Some eds like to send \r\n
-          do (unless (eq #\return c)
-               (write-char c s)))))
-
-(defun assert-ed (command response)
-  (when command
-    (write-line command *ed-in*)
-    (force-output *ed-in*))
-  (when response
-    (let ((got (read-linish *ed-out*)))
-      (unless (equal response got)
-        (error "wanted '~A' from ed, got '~A'" response got))))
-  *ed*)
-
-(unwind-protect
-     (with-test (:name :run-program-ed)
-       (assert-ed nil "4")
-       (assert-ed ".s/bar/baz/g" nil)
-       (assert-ed "w" "4")
-       (assert-ed "q" nil)
-       (process-wait *ed*)
-       (with-open-file (f *tmpfile*)
-         (assert (equal "baz" (read-line f)))))
-  (delete-file *tmpfile*))
-
-) ;; #-win32
+#-win32
+(with-test (:name :is-/bin/ed-installed?)
+  (assert (probe-file "/bin/ed")))
+
+#-win32
+(progn
+  (defparameter *tmpfile* "run-program-ed-test.tmp")
+
+  (with-test (:name :run-program-/bin/ed)
+    (with-open-file (f *tmpfile*
+                       :direction :output
+                       :if-exists :supersede)
+      (write-line "bar" f))
+    (unwind-protect
+         (let* ((ed (run-program "/bin/ed" (list *tmpfile*) :wait nil :pty t))
+                (ed-in (process-pty ed))
+                (ed-out (process-pty ed)))
+           (labels ((read-linish (stream)
+                      (with-output-to-string (s)
+                        (loop for c = (read-char stream)
+                              while (and c (not (eq #\newline c)))
+                              ;; Some eds like to send \r\n
+                              do (unless (eq #\return c)
+                                   (write-char c s)))))
+                    (assert-ed (command response)
+                      (when command
+                        (write-line command ed-in)
+                        (force-output ed-in))
+                      (when response
+                        (let ((got (read-linish ed-out)))
+                          (unless (equal response got)
+                            (error "wanted '~A' from ed, got '~A'" response got))))
+                      ed))
+             (assert-ed nil "4")
+             (assert-ed ".s/bar/baz/g" nil)
+             (assert-ed "w" "4")
+             (assert-ed "q" nil)
+             (process-wait ed)
+             (with-open-file (f *tmpfile*)
+               (assert (equal "baz" (read-line f))))))
+      (delete-file *tmpfile*)))) ;; #-win32
 
 ;; Around 1.0.12 there was a regression when :INPUT or :OUTPUT was a
 ;; pathname designator.  Since these use the same code, it should
diff --git a/tests/run-tests.lisp b/tests/run-tests.lisp
index 68cc941..3d8c3d4 100644
--- a/tests/run-tests.lisp
+++ b/tests/run-tests.lisp
@@ -15,7 +15,7 @@
 (defvar *all-failures* nil)
 (defvar *break-on-error* nil)
 (defvar *report-skipped-tests* nil)
-(defvar *accept-files* nil)
+(defvar *explicit-test-files* nil)
 
 (defun run-all ()
   (dolist (arg (cdr *posix-argv*))
@@ -28,7 +28,7 @@
            (setf *report-skipped-tests* t))
           ((string= arg "--no-color"))
           (t
-           (push (truename (parse-namestring arg)) *accept-files*))))
+           (push (truename (parse-namestring arg)) *explicit-test-files*))))
   (pure-runner (pure-load-files) #'load-test)
   (pure-runner (pure-cload-files) #'cload-test)
   (impure-runner (impure-load-files) #'load-test)
@@ -84,18 +84,18 @@
            (format t "All tests succeeded~%")))))
 
 (defun pure-runner (files test-fun)
-  (format t "// Running pure tests (~a)~%" test-fun)
-  (let ((*package* (find-package :cl-user))
-        (*failures* nil))
-    (setup-cl-user)
-    (dolist (file files)
-      (when (accept-test-file file)
+  (when files
+    (format t "// Running pure tests (~a)~%" test-fun)
+    (let ((*package* (find-package :cl-user))
+          (*failures* nil))
+      (setup-cl-user)
+      (dolist (file files)
         (format t "// Running ~a~%" file)
         (restart-case
             (handler-bind ((error (make-error-handler file)))
               (eval (funcall test-fun file)))
-          (skip-file ()))))
-    (append-failures)))
+          (skip-file ())))
+      (append-failures))))
 
 (defun run-in-child-sbcl (load-forms forms)
   ;; We used to fork() for POSIX platforms, and use this for Windows.
@@ -153,11 +153,11 @@
         (sb-ext:exit :code 104)))))
 
 (defun impure-runner (files test-fun)
-  (format t "// Running impure tests (~a)~%" test-fun)
-  (let ((*package* (find-package :cl-user)))
-    (setup-cl-user)
-    (dolist (file files)
-      (when (accept-test-file file)
+  (when files
+    (format t "// Running impure tests (~a)~%" test-fun)
+    (let ((*package* (find-package :cl-user)))
+      (setup-cl-user)
+      (dolist (file files)
         (force-output)
         (let ((exit-code (run-impure-in-child-sbcl file
                                                    (funcall test-fun file))))
@@ -216,22 +216,24 @@
        (test-util:report-test-status))
      (sb-ext:exit :code (process-exit-code process))))
 
-(defun accept-test-file (file)
-  (if *accept-files*
-      (find (truename file) *accept-files* :test #'equalp)
-      t))
+(defun filter-test-files (wild-mask)
+  (if *explicit-test-files*
+      (loop for file in *explicit-test-files*
+            when (pathname-match-p file wild-mask)
+            collect file)
+      (directory wild-mask)))
 
 (defun pure-load-files ()
-  (directory "*.pure.lisp"))
+  (filter-test-files "*.pure.lisp"))
 
 (defun pure-cload-files ()
-  (directory "*.pure-cload.lisp"))
+  (filter-test-files "*.pure-cload.lisp"))
 
 (defun impure-load-files ()
-  (directory "*.impure.lisp"))
+  (filter-test-files "*.impure.lisp"))
 
 (defun impure-cload-files ()
-  (directory "*.impure-cload.lisp"))
+  (filter-test-files "*.impure-cload.lisp"))
 
 (defun sh-files ()
-  (directory "*.test.sh"))
+  (filter-test-files "*.test.sh"))

-----------------------------------------------------------------------


hooks/post-receive
-- 
SBCL