1 ;; -*- mode: lisp; syntax: common-lisp; coding: utf-8-unix; package: cl-mock; -*-
5 ;;; mocking of regular functions
7 (defvar *mock-bindings*)
14 (defun invocations (&optional name)
15 (let ((invocations (car *invocations*)))
17 (remove name invocations :key #'car :test-not #'eq)
20 (defun call-previous (&rest args)
21 "Invokes the previous binding either with the current arguments or with
22 the given ones. Use *PREVIOUS*/*ARGUMENTS* directly in edge cases."
23 (apply *previous* (or args *arguments*)))
25 (defun find-and-invoke-mock (binding *arguments*)
26 "Looks for a compatible mock (i.e. calls the TEST until one returns true)
27 and executes it. If no mock was found, no values are returned instead."
29 (let ((record (list (cons (car binding) *arguments*))))
30 (if (null (car *invocations*))
31 (setf (cdr *invocations*)
32 (setf (car *invocations*) record))
33 (setf (cdr *invocations*)
34 (setf (cddr *invocations*) record)))))
35 (dolist (case (cdddr binding) (values))
36 (let ((*previous* (cadr binding)))
38 (return (apply case *arguments*))))))
41 (throw 'unhandled (values)))
43 (defun register-mock (name)
44 "Registers a mocked function under NAME. The mocked function will
45 return no values. See IF-CALLED to add some behaviour to it."
46 (let ((found (member name *mock-bindings* :key #'car :test #'eq)))
48 (let* ((binding (list name (maybe-fdefinition name) NIL))
49 (function (lambda (&rest arguments)
50 (find-and-invoke-mock binding arguments))))
51 (setf (caddr binding) function)
52 (push binding *mock-bindings*)
53 (set-fdefinition name function)
56 (defun if-called (name function &key at-start)
57 "Registers a new binding, which should return true if it handled the
58 invocation. If AT-START is set, the binding is put at the start of the
59 bindings list instead. Calls REGISTER-MOCK automatically."
60 (let ((binding (register-mock name)))
62 (push function (cdddr binding))
63 (setf (cdddr binding) (append (cdddr binding) (list function))))))
65 (defun call-with-mocks (function &key ((:recordp *recordp*) T))
66 "Call FUNCTION with a new mocking context. Invocations will be
67 recorded if RECORDP is set (default true)."
69 (*invocations* (list NIL)))
70 (unwind-protect (funcall function)
71 (mapc (lambda (binding)
72 (set-or-unbind-fdefinition (car binding) (cadr binding)))
75 (defmacro with-mocks ((&key (recordp T)) &body body)
76 "Execute BODY in a new mocking context. Invocations will be recorded
77 if RECORDP is set (default true)."