/
/portch.lisp
  1 ; PORTCH
  2 ;
  3 ; `PORTCH' is a small framework for organizing and running tests written with the
  4 ; `PTESTER' library. It is especially useful when each test or group of tests
  5 ; requires its own files or directories
  6 ;
  7 ; OVERVIEW
  8 ;
  9 ; A "group folder" is a folder containing zero or more "test folders". Each of these
 10 ; test folders is considered to contain some tests that need to be run in a specific
 11 ; way.
 12 ; 
 13 ; If the name of subfolder of a group folder contains the substring "group" then that
 14 ; subfolder is considered to be a nested group folder, not a test folder
 15 ; 
 16 ; A group folder might have a file "load.lisp" [which contains lisp code to be loaded
 17 ; before any of the tests in its test folders can be run] and/or a file "run.lisp"
 18 ; [which contains a single function designator for a function that takes a pathname
 19 ; pointing to a test folder and runs all the tests in it].
 20 ;  
 21 ; the function LOAD-TEST-GROUP loads the "load.lisp" forms in a group folder and its
 22 ; nested group folders. the function RUN-TEST-GROUP runs all the tests in a group 
 23 ; folder and its nested group folders with the appropriate "run.lisp" form
 24 ; ["appropriate" as in nearest ancestor or sibling].
 25 ;
 26 ; if the name of a test folder contains the string "dont-run", or is prepended with an
 27 ; underscore (_), then the folder is skipped by both LOAD-TEST-GROUP and
 28 ; RUN-TEST-GROUP.
 29 ;
 30 ; note: `portch' also exports all the symbols from `ptester' [the portable version of
 31 ;       Franz's `tester' library]:
 32 ;
 33 ;    http://www.franz.com/support/documentation/6.1/doc/test-harness.htm
 34 ;
 35 ; API
 36 ;
 37 ;    function:
 38 ;    LOAD-TEST-GROUP (FOLDER)
 39 ;
 40 ;      -- runs all the "load.lisp" files `FOLDER' or any of `FOLDER's ancenstors that
 41 ;         are recognized as being a group folder. `GROUP-FOLDER' is searched in
 42 ;         depth-first, alphabetical order. "Load.lisp" files in group folders marked
 43 ;         "dont-run" are not loaded.
 44 ;
 45 ;    function:
 46 ;    RUN-TEST-GROUP (FOLDER &REST PATTERNS)
 47 ;
 48 ;      -- runs all the tests in the group-folder `FOLDER' that match `PATTERNS' [I will
 49 ;         document `PATTERNS' when I get a chance --nick]. Tests are run in depth
 50 ;         first, alphabetical order.
 51 ;
 52 ;         Running !RUN-TESTS with no `PATTERNS'
 53 ;
 54 ;            (!run-tests folder)
 55 ;
 56 ;         runs all the tests in `FOLDER', in order.
 57 ;
 58 ;    function:
 59 ;    DEF-TEST-GROUP (FOLDER RUN-FUNCTION-NAME LOAD-FUNCTION-NAME &KEY RUN-TESTS)
 60 ;
 61 ;      -- a convenience function. creates a function named `RUN-FUNCTION-NAME' that
 62 ;         runs all the tests in `FOLDER'.
 63 ;
 64 ;         if `LOAD-FUNCTION-NAME' is non-NULL, it also creates a function named
 65 ;         `LOAD-FUNCTION-NAME' that loads all the tests in `FOLDER'
 66 ;
 67 ;         by default, `DEF-TEST-GROUP' loads all the tests in `FOLDER'. if `RUN-TESTS'
 68 ;         is non-NULL then it runs all the tests in `FOLDER', as well
 69 ;
 70 ; todo: -regexps instead of strings for patterns
 71 ;       -regexps for directory boring-ness, etc
 72 
 73 (defpackage :portch
 74   (:use :cl :ptester)
 75   (:export :load-test-group
 76 	   :run-test-group
 77 	   :def-test-group))
 78 
 79 (do-external-symbols (s :ptester)
 80   (export s :portch))
 81 
 82 (in-package :portch)
 83 
 84 ; util
 85 
 86 (defun .foldername (folder)
 87 "
 88    (.foldername \"/foo/bar/baz/\")
 89 
 90    -> \"baz\"
 91 "
 92   (first (last (pathname-directory folder))))
 93 
 94 (defun .boring-folder-p (folder)
 95   (equal (mismatch "_" (.foldername folder))
 96 	 1))
 97 
 98 (defun .sort-paths-alphabetically (paths)
 99   (sort paths
100 	#'string<
101 	:key (lambda (p)
102 	       (if (cl-fad:directory-pathname-p p)
103 		   (.foldername p)
104 		   (pathname-name p)))))
105 
106 (defun .alphabetical-directories (folder)
107   (.sort-paths-alphabetically (remove-if-not 'cl-fad:directory-pathname-p
108 					     (cl-fad:list-directory folder))))
109 
110 ; special
111 
112 (defvar *group*)
113 
114 (defvar *subgroup-stack*)
115 
116 (defvar *run-stack*)
117 
118 ; dont run
119 
120 (defun .marked-dont-run-p (folder)
121   (search "dont-run" (.foldername folder)))
122 
123 ; reckognizing groups
124 
125 (defun .group-folder-p (folder)
126   (search "group" (.foldername folder)))
127 
128 ; load-test-group
129 
130 (defun .get-load-file (folder)
131   (cl-fad:file-exists-p (merge-pathnames "load.lisp" folder)))
132 
133 (defun load-test-group (folder)
134   (if (.get-load-file folder)
135       (load (compile-file (.get-load-file folder))))
136   (mapc 'load-test-group
137 	(remove-if '.marked-dont-run-p
138 		   (remove-if-not '.group-folder-p
139 				  (.alphabetical-directories folder)))))
140 
141 ; run-test-group
142 
143 (defun .get-run-form (group-folder)
144   (let ((f (cl-fad:file-exists-p (merge-pathnames "run.lisp" group-folder))))
145     (when f
146       (with-open-file (in f)
147 	(read in)))))
148 
149 (defun .folder-matches-pattern-p (pattern folder)
150   (typecase pattern
151     (list (some (lambda (p) (.folder-matches-pattern-p p folder))
152 		pattern))
153     (string (search pattern (.foldername folder)))
154     (otherwise (eql pattern t))))
155 
156 (defun .nice-path-for-debugging (path)
157   (enough-namestring path *group*))
158 
159 (defun .format-test (fmt-string &rest fmt-args)
160   (format t
161 	  "~%~A~A"
162 	  (make-string (* 3 (length *subgroup-stack*)) :initial-element #\space)
163 	  (apply 'format nil fmt-string fmt-args)))
164 
165 (defun .run-test-group (folder &rest patterns)
166   (if #1=(search "group" (.foldername folder))
167       (.format-test "~A" (replace (copy-seq (.foldername folder))
168 				  "GROUP"
169 				  :start1 #1#)))
170   (let ((*subgroup-stack* (cons folder *subgroup-stack*)))
171     (let* ((new-run (.get-run-form folder))
172 	   (*run-stack* (if new-run
173 			    (cons new-run *run-stack*)
174 			    *run-stack*)))
175       (dolist (f (.alphabetical-directories folder))
176 	(if (.boring-folder-p f)
177 	    (.format-test "<<<ignoring boring directory ~S>>>"
178 			  (.nice-path-for-debugging f))
179 	    (if (.group-folder-p f)
180 		(apply '.maybe-run-test-group f patterns)
181 		(when (or (null patterns)
182 			  (.folder-matches-pattern-p (first patterns) f))
183 		  (.format-test "~A" (.foldername f))
184 		  (if (not (first *run-stack*))
185 		      (.format-test "<<<hmm... ~S must not be a test because I haven't seen a \"run.lisp\" files yet>>>"
186 				    (.nice-path-for-debugging f))
187 		      (if (.marked-dont-run-p f)
188 			  (.format-test "<<<Not running test ~S>>>"
189 					(replace (copy-seq (.foldername f))
190 						 "DONT-RUN"
191 						 :start1 (search "dont-run" (.foldername f))))
192 			  (funcall (first *run-stack*) f))))))))))
193 
194 (defun .maybe-run-test-group (folder &optional (pattern t) &rest patterns)
195   (if (.folder-matches-pattern-p pattern folder)
196       (if (.marked-dont-run-p folder)
197 	  (.format-test "<<<Not running test group ~A because it's marked \"dont-run\">>>" (.foldername folder))
198 	  (apply '.run-test-group folder patterns))))
199 
200 (defun run-test-group (group-folder &rest patterns)
201   (let ((*group* group-folder)
202 	*subgroup-stack*
203 	*run-stack*)
204     (ptester:with-tests (:name (namestring group-folder))
205       (apply '.run-test-group group-folder patterns))))
206 
207 ; def-test-group
208 
209 (defun def-test-group (folder run-function-name load-function-name &key run-tests)
210 
211     ; define run-function
212     (setf (symbol-function run-function-name)
213 	  (lambda (&rest patterns) (apply 'run-test-group folder patterns)))
214 
215     ; maybe define load-function
216     (if load-function-name
217 	(setf (symbol-function load-function-name)
218 	      (lambda () (load-test-group folder))))
219 
220     ; load test group
221     (load-test-group folder)
222 
223     ; maybe run tests
224     (if run-tests
225 	(run-test-group folder)))