3 ;;; dynamic rebinding of functions
5 (defun maybe-fdefinition (name)
6 "If NAME is FBOUNDP, return its FDEFINITION, else NIL."
7 (and (fboundp name) (fdefinition name)))
9 (defun set-fdefinition (name value)
10 "FUNCALLABLE expansion of (SETF (FDEFINITION NAME) VALUE)."
11 (setf (fdefinition name) value))
13 (defun set-or-unbind-fdefinition (name value)
14 "If VALUE is true, set the FDEFINITION of NAME to it, else FMAKUNBOUND
16 (if value (set-fdefinition name value) (fmakunbound name)))
18 (defun call-with-function-bindings (functions values function
19 &optional (previous (mapcar #'maybe-fdefinition functions)))
20 "Calls FUNCTION while temporarily binding all FUNCTIONS to VALUES.
24 (mapc #'set-fdefinition functions values)
26 (mapc #'set-or-unbind-fdefinition functions previous)))
28 (defmacro progf (functions values &body body)
29 "Like PROGV, but for FUNCTIONS."
30 `(call-with-function-bindings ,functions ,values (lambda () ,@body)))
32 (defmacro dflet ((&rest definitions) &body body)
33 "Like FLET, but dynamically sets the FDEFINITIONS during the duration of
36 ',(mapcar #'car definitions)
38 ,.(mapcar (lambda (definition)
39 `(lambda ,(cadr definition)
44 (def-test dflet.calls-binding ()
48 (def-test dflet.notinline.works ()
49 (declare (notinline foo bar))
54 (def-test dflet.simple-mock ()
55 (defun foo (&optional (string "Hello, World!"))
61 ((equalp string "Hello, World!")
64 (is (eql 43 (foo "HELLO, WORLD!")))))
66 (def-test dflet.package-locks ()
67 "Either we can rebind LIST, or an error occurs and the binding is not
70 (handler-case (dflet ((list ()))
73 (is (eq #'list list))))))
75 (def-test dflet.package-locks.order.1 ()
87 (is (eq #'foo foo))))))
89 (def-test dflet.package-locks.order.2 ()
100 (is (eq #'list list))
101 (is (eq #'foo foo))))))
103 ;;; mocking of regular functions
105 (defstruct mock-bindings
111 (defun call-previous (&rest args)
112 (apply *previous* (or args *arguments*)))
114 (defun find-and-invoke-mock (*previous* cases *arguments*)
115 (dolist (case cases (values))
116 (when (ignore-errors (apply (car case) *arguments*))
117 (return (apply (cdr case) *arguments*)))))
119 (defun call-with-mocks (mock-bindings function &key (recordp T))
120 "Calls FUNCTION with the given MOCK-BINDINGS established and returns
121 its first return value, if any. If RECORDP is set, all invocations will
122 be recorded and returned as the second return value, else NIL."
123 (let* ((mocks (mock-bindings-mocks mock-bindings))
124 (functions (mapcar #'car mocks))
125 (previous (mapcar #'maybe-fdefinition functions))
127 (call-with-function-bindings
129 (mapcar (lambda (binding previous &aux (name (car binding)) (cases (cdr binding)))
132 (push (cons name args) invocations))
133 (find-and-invoke-mock previous cases args)))
138 (nreverse invocations)))
141 (defun register-mock (mock-bindings name)
142 (let ((found (member name (mock-bindings-mocks mock-bindings) :key #'car :test #'eq)))
144 (let ((binding (list name)))
145 (push binding (mock-bindings-mocks mock-bindings))
148 (defun if-called (mock-bindings name test function &key at-start)
149 (let ((binding (register-mock mock-bindings name))
150 (case (cons test function)))
152 (push case (cdr binding))
153 (setf (cdr binding) (append (cdr binding) (list case))))))
155 ;;; syntactic sugar for defining the mock interactions
157 (defun make-lambda-pattern (literal-pattern)
158 (let (lambda-pattern values)
160 for (car . cdr) = literal-pattern
162 do (let ((sym (gensym)))
163 (setf lambda-pattern (append lambda-pattern (list sym)))
164 (push `(,sym . ,(if (or (symbolp car) (listp car)) `(quote ,car) car)) values)
165 (pop literal-pattern)))
166 (values lambda-pattern values)))
168 (defun make-test-pattern (values)
169 `(and ,.(mapcar (lambda (value)
170 `(equal ,(car value) ,(cdr value)))
173 (defmacro when-called (mock-bindings call &body forms)
174 (let ((name (if (listp call) (car call) call))
180 (multiple-value-bind (lambda-pattern values)
181 (make-lambda-pattern (cdr call))
182 `(lambda (&rest args)
183 (destructuring-bind ,lambda-pattern args
184 ,(make-test-pattern values))))
186 (let ((,sym (fdefinition ',name)))
187 (declare (ignorable ,sym))
191 (declare (ignorable args))
192 (case (prog1 times (incf times))
195 for (form . rest) on forms
196 collect `(,(if rest i T) ,form)))))
197 `(lambda (&rest args)
198 (declare (ignorable args))
201 (defun invocation-count (name invocations)
202 (count name invocations :key #'car :test #'eq))
204 (defun was-called-p (name invocations)
205 (member name invocations :key #'car :test #'eq))
207 (def-test call-with-mocks.empty ()
208 (is (eq T (call-with-mocks
212 (def-test call-with-mocks.discards-values ()
221 (def-test call-with-mocks.simple ()
222 (declare (notinline foo))
224 (fail "original function binding ~A was called" 'foo))
225 (let ((mock-bindings (make-mock-bindings)))
226 (register-mock mock-bindings 'foo)
233 (def-test call-with-mocks.default-values ()
234 (declare (notinline foo))
236 (let ((mock-bindings (make-mock-bindings)))
237 (register-mock mock-bindings 'foo)
241 (is (null (multiple-value-list (foo))))))))
243 (def-test if-called.simple ()
244 (declare (notinline foo))
246 (let ((mock-bindings (make-mock-bindings)))
247 (if-called mock-bindings 'foo (constantly T) (constantly 42))
251 (is (eql 42 (foo)))))))
253 (def-test call-with-mocks.invocations ()
254 (declare (notinline foo))
256 (let ((mock-bindings (make-mock-bindings)))
257 (register-mock mock-bindings 'foo)
259 '(NIL ((foo 1) (foo 2) (foo 3)))
268 (def-test when-called.simple ()
269 (declare (notinline foo))
271 (let ((mock-bindings (make-mock-bindings)))
272 (when-called mock-bindings foo 42)
273 (when-called mock-bindings foo 23)
277 (is (eql 42 (foo)))))))
279 (def-test when-called.literal ()
280 (declare (notinline foo))
282 (let ((mock-bindings (make-mock-bindings)))
283 (when-called mock-bindings (foo 1) 2)
284 (when-called mock-bindings (foo 2) 3)
285 (when-called mock-bindings foo 42)
294 (is (eql 42 (foo 'foo)))))))
296 (def-test when-called.times ()
297 (declare (notinline foo))
299 (let ((mock-bindings (make-mock-bindings)))
300 (when-called mock-bindings foo 1 2 3)
307 (is (eql 3 (foo)))))))
309 (def-test when-called.call-previous ()
310 (declare (notinline foo))
312 (let ((mock-bindings (make-mock-bindings)))
313 (when-called mock-bindings foo 3 (call-previous))
318 (is (eq 'foo (foo)))))))
320 ;;; mocking of generic methods and objects
322 (defun find-methods (methods)
323 (mapcar (lambda (method)
324 (destructuring-bind (generic-function qualifiers specializers) method
327 (find-method generic-function qualifiers specializers NIL))))
330 ;; TODO: because we use ENSURE-METHOD, each value is a FORM rather than a
331 ;; FUNCTION, so not quite the same as PROGF; judging by the implementation-
332 ;; specific code in CLOSER-MOP, we also can just create method objects
333 ;; ourselves reliably, so either we duplicate the cases or just use SBCL
335 (defun call-with-method-bindings* (methods values function
336 &optional (previous (find-methods methods)))
337 (mapc (lambda (previous)
338 (destructuring-bind (generic-function . method) previous
340 (remove-method generic-function method))))
343 (mapcar (lambda (method previous value)
344 (destructuring-bind (generic-function qualifiers specializers) method
345 (destructuring-bind (generic-function . method) previous
349 (ensure-method generic-function value
350 :method-class (class-of method)
351 :qualifiers (method-qualifiers method)
352 :lambda-list (method-lambda-list method)
353 :specializers (method-specializers method))
354 (ensure-method generic-function value
355 :qualifiers qualifiers
356 :specializers specializers))))))
357 methods previous values)))
358 (unwind-protect (funcall function)
359 (mapc (lambda (new-method)
360 (destructuring-bind (generic-function . method) new-method
361 (remove-method generic-function method)))
363 (mapc (lambda (previous)
364 (destructuring-bind (generic-function . method) previous
366 (add-method generic-function method))))
369 (defmacro progm* (methods values &body body)
370 `(call-with-method-bindings* ,methods ,values (lambda () ,@body)))
372 (defun call-with-method-bindings (methods values function
375 (mapcar (lambda (method)
376 (destructuring-bind (generic-function qualifiers specializers) method
378 (if (functionp generic-function)
380 (fdefinition generic-function))
382 (mapcar (lambda (specializer)
383 (if (classp specializer)
385 (find-class specializer)))
388 (call-with-method-bindings* methods values function (or previous (find-methods methods)))))
390 (defmacro progm (methods values &body body)
391 `(call-with-method-bindings ,methods ,values (lambda () ,@body)))
396 (defgeneric bar (foo)
400 (def-test gf.simple ()
403 '((lambda (list) list))
404 (is (equal '(1 2 3) (bar '(1 2 3))))
405 (signals error (equal T (bar T)))
406 (is (equal 42 (bar (make-instance 'foo))))))