From 8e2b8ea5671d45cd1b3efdd037af289200e6e0a8 Mon Sep 17 00:00:00 2001 From: Marco Baringer Date: Tue, 26 Jun 2007 12:59:18 +0200 Subject: [PATCH] Add support for collecting profiling information during test runs. --- src/classes.lisp | 13 ++++++++++++- src/run.lisp | 33 ++++++++++++++++++++------------- src/test.lisp | 14 ++++++++------ t/tests.lisp | 2 +- 4 files changed, 41 insertions(+), 21 deletions(-) diff --git a/src/classes.lisp b/src/classes.lisp index 7d929de..0e7d836 100644 --- a/src/classes.lisp +++ b/src/classes.lisp @@ -15,7 +15,18 @@ dependencies, have passed. NIL - this test failed (either it failed or its dependecies weren't met. :circular this test has a circular depenedency - and was skipped."))) + and was skipped.") + (profiling-info :accessor profiling-info + :initform nil + :documentation "An object representing how + much time and memory where used by the + test.") + (collect-profiling-info :accessor collect-profiling-info + :initarg :collect-profiling-info + :initform nil + :documentation "When T profiling + information will be collected when the + test is run."))) (defmethod print-object ((test testable-object) stream) (print-unreadable-object (test stream :type t :identity t) diff --git a/src/run.lisp b/src/run.lisp index 6819392..c3038ef 100644 --- a/src/run.lisp +++ b/src/run.lisp @@ -149,7 +149,10 @@ run.")) (restart-case (let ((*readtable* (copy-readtable)) (*package* (runtime-package test))) - (funcall (test-lambda test))) + (if (collect-profiling-info test) + (setf (profiling-info test) + (arnesi:collect-timing (test-lambda test))) + (funcall (test-lambda test)))) (retest () :report (lambda (stream) (format stream "~@" test)) @@ -177,18 +180,22 @@ run.")) (defmethod %run ((suite test-suite)) (let ((suite-results '())) - (unwind-protect - (bind-run-state ((result-list '())) - (unwind-protect - (loop for test being the hash-values of (tests suite) - do (%run test)) - (setf suite-results result-list)) - (setf (status suite) - (every (lambda (res) - (typep res 'test-passed)) - suite-results))) - (with-run-state (result-list) - (setf result-list (nconc result-list suite-results)))))) + (flet ((run-tests () + (loop + for test being the hash-values of (tests suite) + do (%run test)))) + (unwind-protect + (bind-run-state ((result-list '())) + (unwind-protect + (if (collect-profiling-info suite) + (setf (profiling-info suite) (collect-timing #'run-tests)) + (run-tests))) + (setf suite-results result-list + (status suite) (every (lambda (res) + (typep res 'test-passed)) + suite-results))) + (with-run-state (result-list) + (setf result-list (nconc result-list suite-results))))))) (defmethod %run ((test-name symbol)) (when-bind test (get-test test-name) diff --git a/src/test.lisp b/src/test.lisp index 9aa1039..9190003 100644 --- a/src/test.lisp +++ b/src/test.lisp @@ -24,7 +24,7 @@ "Create a test named NAME. If NAME is a list it must be of the form: - (name &key depends-on suite fixture compile-at) + (name &key depends-on suite fixture compile-at profile) NAME is the symbol which names the test. @@ -45,8 +45,9 @@ If DEPENDS-ON is a symbol it is interpreted as `(AND ,depends-on), this is accomadate the common case of one test depending on another. -FIXTURE specifies a fixtrue to wrap the body in." - +FIXTURE specifies a fixtrue to wrap the body in. + +If PROFILE is T profiling information will be collected as well." (let* ((tmp (gensym)) (suite-arg (getf (cdr (ensure-list name)) :suite tmp)) (suite (cond @@ -54,7 +55,7 @@ FIXTURE specifies a fixtrue to wrap the body in." (t (get-test suite-arg))))) (when (consp name) (remf (cdr name) :suite)) - (destructuring-bind (name &key depends-on (compile-at :run-time) fixture) + (destructuring-bind (name &key depends-on (compile-at :run-time) fixture profile) (append (ensure-list name) (default-test-args suite)) (declare (type (member :run-time :definition-time) compile-at)) (let ((description (if (stringp (car body)) @@ -78,8 +79,9 @@ FIXTURE specifies a fixtrue to wrap the body in." ,@effective-body)))))) (:definition-time effective-body))) :description ,description - :depends-on ',depends-on)) - (setf (gethash ',name (tests ,suite)) ',name) + :depends-on ',depends-on + :collect-profiling-info ,profile)) + (setf (gethash ',name (tests (get-test ',(name suite)))) ',name) (when *run-test-when-defined* (run! ',name)) ',name))))) diff --git a/t/tests.lisp b/t/tests.lisp index 47a92fc..601c2fd 100644 --- a/t/tests.lisp +++ b/t/tests.lisp @@ -33,7 +33,7 @@ (is-true nil) (is-false t)) -(test is +(test (is :profile t) (with-test-results (results is1) (is (= 6 (length results))) (is (every #'test-passed-p results))) -- 1.7.10.4