ellusive bug
Annotate for file /portch.lisp
2008-07-03 nallen05 1 ; PORTCH
12:49:19 ' 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))
2009-01-10 nallen05 167 (.format-test "~A" (replace (copy-seq (.foldername folder))
2008-07-03 nallen05 168 "GROUP"
12:49:19 ' 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>>>"
2009-01-10 nallen05 189 (replace (copy-seq (.foldername f))
2008-07-03 nallen05 190 "DONT-RUN"
12:49:19 ' 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)))