test suite

test-framework.lisp

@@ -0,0 +1,62 @@
+(defpackage trivial-gray-streams-test 
+  (:use :cl :trivial-gray-streams))
+
+(in-package :trivial-gray-streams-test)
+
+;;; test framework
+
+(defclass test-result ()
+  ((name :type symbol
+         :initarg :name
+         :initform (error ":name is requierd")
+         :accessor name)
+   (status :type (or (eql :ok) (eql :fail))
+           :initform :ok
+           :initarg :status
+           :accessor status)
+   (cause :type (or null condition)
+          :initform nil
+          :initarg :cause
+          :accessor cause)))
+
+(defun failed-p (test-result)
+  (eq (status test-result) :ok))
+
+(defmethod print-object ((r test-result) stream)
+  (print-unreadable-object (r stream :type t)
+    (format stream "~S ~S~@[ ~A~]" (name r) (status r) (cause r))))
+
+(defparameter *allow-debugger* nil)
+
+(defun test-impl (name body-fn)
+  (flet ((make-result (status &optional cause)
+           (make-instance 'test-result :name name :status status :cause cause)))
+    (handler-bind ((serious-condition
+                    (lambda (c)
+                      (unless *allow-debugger*
+                        (format t "FAIL: ~A~%" c)
+                        (return-from test-impl                          
+                          (make-result :fail c))))))
+      (format t "Running test ~S... " name)
+      (funcall body-fn)
+      (format t "OK~%")
+      (make-result :ok))))
+
+(defmacro test ((name) &body body)
+  "If the BODY signals a SERIOUS-CONDITION
+this macro returns a failed TEST-RESULT; otherwise
+returns a successfull TEST-RESULT."
+  `(test-impl (quote ,name) (lambda () ,@body)))
+
+
+#|
+  Used like this:
+
+  (list (test (a) (assert (= 1 2)))
+        (test (b) (assert (= 2 2)))
+        (test (c) (assert (= 2 3))))
+
+  => ;; list of test results, 2 failed 1 passed
+     (#<TEST-RESULT A :FAIL Failed assertion: (= 1 2)> #<TEST-RESULT B :OK> #<TEST-RESULT C :FAIL Failed assertion: (= 2 3)>)
+
+|#

test.lisp

@@ -0,0 +1,209 @@
+(in-package :trivial-gray-streams-test)
+
+;;; assert-invoked - a tool to check that specified method with parameters has
+;;; been invoked during execution of a code body
+
+(define-condition invoked ()
+  ((method :type (or symbol cons) ;; cons is for (setf method)
+           :accessor method
+           :initarg :method
+           :initform (error ":method is required"))
+   (args :type list
+         :accessor args
+         :initarg :args
+         :initform nil)))
+
+(defun assert-invoked-impl (method args body-fn)
+  (let ((expected-invocation (cons method args))
+        (actual-invocations nil))
+    (handler-bind ((invoked (lambda (i)
+                              (let ((invocation (cons (method i) (args i))))
+                                (when (equalp invocation expected-invocation)
+                                  (return-from assert-invoked-impl nil))
+                                (push invocation actual-invocations)))))
+      (funcall body-fn))
+    (let ((*package* (find-package :keyword))) ; ensures package prefixes are printed
+      (error "expected invocation: ~(~S~) actual: ~{~(~S~)~^, ~}"
+             expected-invocation (reverse actual-invocations)))))
+
+(defmacro assert-invoked ((method &rest args) &body body)
+  "If during execution of the BODY the specified METHOD with ARGS
+hasn't been invoked, signals an ERROR."
+  `(assert-invoked-impl (quote ,method) (list ,@args) (lambda () ,@body)))
+
+(defun invoked (method &rest args)
+  (signal 'invoked :method method :args args))
+
+;;; end assert-invoked
+
+(defclass test-stream (fundamental-binary-input-stream
+                       fundamental-binary-output-stream
+                       fundamental-character-input-stream
+                       fundamental-character-output-stream)
+  ())
+
+(defclass test-stream2 (test-stream) ())
+
+(defmethod stream-read-char ((stream test-stream))
+  (invoked 'stream-read-char stream))
+
+(defmethod stream-unread-char ((stream test-stream) char)
+  (invoked 'stream-unread-char stream char))
+
+(defmethod stream-read-char-no-hang ((stream test-stream))
+  (invoked 'stream-read-char-no-hang stream))
+
+(defmethod stream-peek-char ((stream test-stream))
+  (invoked 'stream-peek-char stream))
+
+(defmethod stream-listen ((stream test-stream))
+  (invoked 'stream-listen stream))
+
+(defmethod stream-read-line ((stream test-stream))
+  (invoked 'stream-read-line stream))
+
+(defmethod stream-clear-input ((stream test-stream))
+  (invoked 'stream-clear-input stream))
+
+(defmethod stream-write-char ((stream test-stream) char)
+  (invoked 'stream-write-char stream char))
+
+(defmethod stream-line-column ((stream test-stream))
+  (invoked 'stream-line-column stream))
+
+(defmethod stream-start-line-p ((stream test-stream))
+  (invoked 'stream-start-line-p stream))
+
+(defmethod stream-write-string ((stream test-stream) string &optional start end)
+  (invoked 'stream-write-string stream string start end))
+
+(defmethod stream-terpri ((stream test-stream))
+  (invoked 'stream-terpri stream))
+
+(defmethod stream-fresh-line ((stream test-stream2))
+  (invoked 'stream-fresh-line stream))
+
+(defmethod stream-finish-output ((stream test-stream))
+  (invoked 'stream-finish-output stream))
+
+(defmethod stream-force-output ((stream test-stream))
+  (invoked 'stream-force-output stream))
+
+(defmethod stream-clear-output ((stream test-stream))
+  (invoked 'stream-clear-output stream))
+
+(defmethod stream-advance-to-column ((stream test-stream2) column)
+  (invoked 'stream-advance-to-column stream column))
+
+(defmethod stream-read-byte ((stream test-stream))
+  (invoked 'stream-read-byte stream))
+
+(defmethod stream-write-byte ((stream test-stream) byte)
+  (invoked 'stream-write-byte stream byte))
+
+(defmethod stream-read-sequence ((s test-stream) seq start end &key)
+  (invoked 'stream-read-sequence s seq :start start :end end))
+
+(defmethod stream-write-sequence ((s test-stream) seq start end &key)
+  (invoked 'stream-write-sequence s seq :start start :end end))
+
+(defmethod stream-file-position ((s test-stream))
+  (invoked 'stream-file-position s))
+
+(defmethod (setf stream-file-position) (newval (s test-stream))
+  (invoked '(setf stream-file-position) newval s))
+
+;; Convinience macro, used when we want to name
+;; the test case with the same name as of the gray streams method we test.
+(defmacro test-invoked ((method &rest args) &body body)
+  `(test (,method)
+     (assert-invoked (,method ,@args)
+       ,@body)))
+
+#|
+  cl:format ~t or cl:pprint -> stream-advance-to-column -> stream-line-column
+                                                           stream-write-char
+  cl:fresh-line -> stream-fresh-line -> stream-start-line-p
+                                        stream-terpri
+
+
+STREAM-START-LINE-P: expected invocation: (ccl:stream-start-line-p #<trivial-gray-streams-test::test-stream #x21012fe62d>)
+                                  actual: (ccl:stream-fresh-line #<trivial-gray-streams-test::test-stream #x21012fe62d>)
+
+STREAM-TERPRI: expected invocation: (ccl:stream-terpri #<trivial-gray-streams-test::test-stream #x21012fe62d>)
+                            actual: (ccl:stream-write-char #<trivial-gray-streams-test::test-stream #x21012fe62d> #\newline)
+
+STREAM-ADVANCE-TO-COLUMN: expected invocation: (ccl:stream-advance-to-column #<trivial-gray-streams-test::test-stream #x21012fe62d> 11)
+                                       actual: (ccl:stream-line-column #<trivial-gray-streams-test::test-stream #x21012fe62d>)
+
+|#
+(defun run-tests ()
+  (let ((s (make-instance 'test-stream))
+        (s2 (make-instance 'test-stream2)))
+    (list
+     (test-invoked (stream-read-char s)
+       (read-char s))
+     (test-invoked (stream-unread-char s #\a)
+       (unread-char #\a s))
+     (test-invoked (stream-read-char-no-hang s)
+       (read-char-no-hang s))
+     (test-invoked (stream-peek-char s)
+       (peek-char nil s))
+     (test-invoked (stream-listen s)
+       (listen s))
+     (test-invoked (stream-read-line s)
+       (read-line s))
+     (test-invoked (stream-clear-input s)
+       (clear-input s))
+     (test-invoked (stream-write-char s #\b)
+       (write-char #\b s))
+     (test-invoked (stream-line-column s)
+       (format s "~10,t"))
+     (test-invoked (stream-start-line-p s)
+       (fresh-line s))
+     (test-invoked (stream-write-string s "hello" 1 7)
+       (write-string "hello" s :start 1 :end 7))
+     (test-invoked (stream-terpri s)
+       (fresh-line s))
+     (test-invoked (stream-fresh-line s2)
+       (fresh-line s2))
+     (test-invoked (stream-finish-output s)
+       (finish-output s))
+     (test-invoked (stream-force-output s)
+       (force-output s))
+     ;; sbcl bug https://bugs.launchpad.net/sbcl/+bug/1153257
+     (test-invoked (stream-clear-output s)
+       (clear-output s))
+     ;; not used by SBCL
+     (test-invoked (stream-advance-to-column s2 10)
+        (format s2 "~10,t"))
+     (test-invoked (stream-read-byte s)
+       (read-byte s))
+     (test-invoked (stream-write-byte s 1)
+       (write-byte 1 s))
+
+     ;; extensions
+     (test-invoked (stream-read-sequence s #(1 2) :start 0 :end 1)
+       (read-sequence #(1 2) s :start 0 :end 1))
+     (test-invoked (stream-write-sequence s #(1 2) :start 0 :end 1)
+       (write-sequence #(1 2) s :start 0 :end 1))
+     (test-invoked (stream-file-position s)
+       (file-position s))
+     (test (setf-stream-file-position)
+       (assert-invoked ((setf stream-file-position) 9 s)
+         (file-position s 9))))))
+
+(defun failed-tests (results)
+  (remove-if-not (complement #'failed-p) results))
+
+(defun failed-test-names (results)
+  (mapcar (lambda (result)
+            (string-downcase (name result)))
+          (failed-tests results)))
+               
+#|
+(failed-test-names (run-tests))
+
+(setf *allow-debugger* nil))
+
+|#

trivial-gray-streams-test.asd

@@ -0,0 +1,7 @@
+;;; -*- mode: lisp -*-
+
+(defsystem :trivial-gray-streams-test
+  :version "2.0"
+  :serial t
+  :depends-on (:trivial-gray-streams)
+  :components ((:file "test-framework") (:file "test")))