test-unitaire.lisp (6978B)
1 ;; *all-tests* : <module-struct> 2 ;; <module-struct> : (<alist-of-submodules> executed-bit variables tests) 3 ;; <alist-of-submodules> : ((nom-module . <module-struct>) (nom-module2 . <module>) ...) 4 (defvar *all-tests* (list nil nil nil nil) "Liste de tous les tests") 5 6 (defun test-get-module (module &optional (from *all-tests*)) 7 (unless (listp module) (setq module (list module))) 8 (if (endp module) 9 from 10 (let ((association (assoc (car module) (car from)))) 11 (unless association 12 (let ((new-assoc (list (car module) nil nil nil nil))) 13 (push new-assoc (car from)) 14 (setq association new-assoc))) 15 (test-get-module (cdr module) (cdr association))))) 16 17 (defun test-get-submodules (module) (first (test-get-module module))) 18 (defun test-get-executed (module) (second (test-get-module module))) 19 (defun test-get-variables (module) (third (test-get-module module))) 20 (defun test-get-tests (module) (fourth (test-get-module module))) 21 22 (defun test-collect-down-tree (fn module &optional (from *all-tests*)) 23 (unless (listp module) (setq module (list module))) 24 (if (endp module) 25 (cons (funcall fn from) nil) 26 (cons (funcall fn from) 27 (test-collect-down-tree fn (cdr module) 28 (cdr (assoc (car module) (car from))))))) 29 30 (defun test-get-variables-and-above (module &optional (from *all-tests*)) 31 (remove-duplicates (apply #'append (mapcar #'reverse (test-collect-down-tree #'third module from))) :key #'car)) 32 33 (defun test-set-executed (from &optional (value t)) 34 (setf (second from) value)) 35 36 (defun test-clear-all-executed (&optional (from *all-tests*)) 37 (setf (second from) nil) 38 (mapcar #'test-clear-all-executed 39 (mapcar #'cdr (first from)))) 40 41 (defun test-add-variable (module variable) 42 (push variable (third (test-get-module module))) 43 t) 44 45 (defun test-add-test (module test) 46 (push test (fourth (test-get-module module))) 47 t) 48 49 (defun test-remove-module (module) 50 (if (null module) 51 (setf *all-tests* (list nil nil nil nil)) 52 (let ((from (test-get-module (butlast module)))) 53 (setf (first from) 54 (delete (car (last module)) 55 (first from) 56 :key #'car))))) 57 58 (defun booleq (a b) 59 (if a b (not b))) 60 61 (defmacro deftest (module test expected &optional (compare #'equal)) 62 (let ((vars (test-get-variables-and-above module))) 63 `(test-add-test 64 ',module 65 (lambda () 66 (let* ((state-1 (make-random-state)) 67 (state-2 (make-random-state state-1)) 68 (res (labels ((random-test (n) (random n state-1))) 69 (let* ,vars ,@(mapcar #'car vars) ,test))) 70 (exp (labels ((random-test (n) (random n state-2))) 71 (let* ,vars ,@(mapcar #'car vars) ,expected)))) 72 (if (funcall ,compare res exp) 73 (progn 74 (format t "~& [SUCCESS] ~w~&" ',test) 75 t) 76 (progn 77 (format t "~& [FAILURE] Test : ~w~&" ',test) 78 (format t "~& got : ~w~&" res) 79 (format t "~& expected : ~w~&" exp) 80 (format t "~& comparison : ~w~&" ,compare) 81 nil))))))) 82 83 (defmacro generates-error-p (code) 84 `(car (handler-case (cons nil ,code) 85 (error (e) (cons t e))))) 86 87 (defmacro deftest-error (module test &optional (expected t)) 88 `(deftest ,module (generates-error-p ,test) 89 ,expected)) 90 91 (defmacro deftestvar (module name value) 92 `(test-add-variable ',module 93 (list ',name ',value))) 94 95 (defvar *run-tests-counter* 0) 96 97 (declaim (ftype function real-run-tests)) ;; récursion mutuelle real-run-tests / run-tests-submodules 98 (defun run-tests-submodules (module-name submodules) 99 (if (endp submodules) 100 t 101 (and (real-run-tests (append module-name (list (caar submodules))) (cdar submodules)) 102 (run-tests-submodules module-name (cdr submodules))))) 103 104 (defun real-run-tests (module-name from) 105 (if (second from) 106 (progn 107 (format t "~&~%-~{ ~w~}~& [Déjà vu]~&" (or module-name '(*all-tests*))) 108 t) 109 (progn 110 (format t "~&~%>~{ ~w~}~&" (or module-name '(*all-tests*))) 111 (setf (second from) t) ;; marquer comme exécuté. 112 (let ((nb-fail (count-if-not #'funcall (reverse (fourth from))))) 113 (if (= nb-fail 0) 114 (progn 115 (incf *run-tests-counter* (length (fourth from))) 116 (run-tests-submodules module-name (reverse (first from)))) 117 (format t "Module ~w failed ~w tests. Stopping.~&" module-name nb-fail)))))) 118 119 (defmacro run-tests (&rest modules) 120 (when (null modules) (setq modules '(nil))) 121 (setq modules (substitute nil t modules)) 122 (setq *run-tests-counter* 0) 123 `(progn 124 (test-clear-all-executed) 125 (if (every #'real-run-tests 126 ',(mapcar (lambda (x) (if (listp x) x (list x))) modules) 127 ',(mapcar #'test-get-module modules)) 128 (progn (format t "~a tests passed sucessfully." *run-tests-counter*) 129 t) 130 nil))) 131 132 (defun count-nb-tests (from) 133 (apply #'+ 134 (length (fourth from)) 135 (mapcar (lambda (x) (count-nb-tests (cdr x))) (car from)))) 136 137 (defun real-show-tests (module-name from) 138 (format t "~&~4@<~d~> ~4@<~d~> >~{ ~w~}~&" 139 (length (fourth from)) 140 (count-nb-tests from) 141 (or module-name '(*all-tests*))) 142 (mapcar (lambda (x) (real-show-tests (append module-name (list (car x))) (cdr x))) 143 (first from)) 144 nil) 145 146 (defmacro show-tests (&optional module) 147 (unless (listp module) (setq module (list module))) 148 `(let ((mod (test-get-module ',module))) 149 (real-show-tests ',module mod) 150 (format t "~a tests." (count-nb-tests mod)) 151 t)) 152 153 (defmacro erase-tests (&optional module) 154 (unless (listp module) (setq module (list module))) 155 `(progn (test-remove-module ',module) t)) 156 157 (erase-tests test-unitaire) 158 (deftest (test-unitaire copy-all) 159 (let* ((foo #(a b (1 #(2 4 6) 3) c)) 160 (copy-of-foo (copy-all foo))) 161 copy-of-foo 162 (setf (aref (cadr (aref copy-of-foo 2)) 1) (cons 'MODIFIED (random-test 42))) 163 (equalp foo #(a b (1 #(2 4 6) 3) c))) 164 t #'booleq) 165 166 ;;; Exemples d'utilisation. 167 168 ;; (erase-tests (a sub-1)) 169 ;; (erase-tests b) 170 ;; (erase-tests) 171 172 ;; (deftestvar a foo 'bar) 173 ;; (deftest a nil nil) 174 ;; (deftest a (eq 42 42) t) 175 ;; (deftest (a) (eq 'bar 'bar) t) 176 ;; (deftest (a) (eq 'baz 'quux) nil) 177 ;; (deftest (a sub-1) (eq 'x 'y) nil) 178 ;; (deftest (a sub-1) (eq 'x 'x) t) 179 ;; (deftest (a sub-2) (eq 'x 'x) t) 180 ;; (deftest (b sub-1) (eq 'y 'y) t) 181 ;; (deftest c (eq 'foo 'foo) t) 182 ;; (deftest-error c (if (eq 42 42) (error "foo") (error "bar"))) 183 184 ;; Pour lancer les tests : 185 ;; (run-tests (a sub-1) b t) 186 ;; (run-tests ()) 187 ;; (run-tests t) 188 ;; (run-tests) 189 190 (provide 'test-unitaire)