481de1233cbdaa27b6eb462a0fe50121f84f0282
[cl-mock.git] / src / mock.lisp
1 ;;; -*- mode: lisp; syntax: common-lisp; coding: utf-8-unix; package: cl-mock; -*-
2
3 (in-package #:cl-mock)
4
5 ;;; mocking of regular functions
6
7 (defstruct mock-bindings
8   mocks)
9
10 (defvar *previous*)
11 (defvar *arguments*)
12
13 (defun call-previous (&rest args)
14   (apply *previous* (or args *arguments*)))
15
16 (defun find-and-invoke-mock (*previous* cases *arguments*)
17   (dolist (case cases (values))
18     (when (ignore-errors (apply (car case) *arguments*))
19       (return (apply (cdr case) *arguments*)))))
20
21 (defun call-with-mocks (mock-bindings function &key (recordp T))
22   "Calls FUNCTION with the given MOCK-BINDINGS established and returns
23 its first return value, if any.  If RECORDP is set, all invocations will
24 be recorded and returned as the second return value, else NIL."
25   (let* ((mocks (mock-bindings-mocks mock-bindings))
26          (functions (mapcar #'car mocks))
27          (previous (mapcar #'maybe-fdefinition functions))
28          invocations)
29     (call-with-function-bindings
30      functions
31      (mapcar (lambda (binding previous &aux (name (car binding)) (cases (cdr binding)))
32                (lambda (&rest args)
33                  (when recordp
34                    (push (cons name args) invocations))
35                  (find-and-invoke-mock previous cases args)))
36              mocks previous)
37      (lambda ()
38        (values
39         (funcall function)
40         (nreverse invocations)))
41      previous)))
42
43 (defun register-mock (mock-bindings name)
44   (let ((found (member name (mock-bindings-mocks mock-bindings) :key #'car :test #'eq)))
45     (or (car found)
46         (let ((binding (list name)))
47           (push binding (mock-bindings-mocks mock-bindings))
48           binding))))
49
50 (defun if-called (mock-bindings name test function &key at-start)
51   (let ((binding (register-mock mock-bindings name))
52         (case (cons test function)))
53     (if at-start
54         (push case (cdr binding))
55         (setf (cdr binding) (append (cdr binding) (list case))))))