src/mock.lisp

   1 ;; -*- mode: lisp; syntax: common-lisp; coding: utf-8-unix; package: cl-mock; -*-
   2
   3 (in-package #:cl-mock)
   4 \f
   5 ;;; mocking of regular functions
   6
   7 (defvar *mock-bindings*)
   8 (defvar *invocations*)
   9 (defvar *recordp*)
  10
  11 (defvar *previous*)
  12 (defvar *arguments*)
  13
  14 (defun invocations (&optional name)
  15   (let ((invocations (car *invocations*)))
  16     (if name
  17         (remove name invocations :key #'car :test-not #'eq)
  18         invocations)))
  19
  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*)))
  24
  25 (defun record-invocation (record &aux (record (list record)))
  26   (setf (cdr *invocations*)
  27         (if (null (car *invocations*))
  28             (setf (car *invocations*) record)
  29             (setf (cddr *invocations*) record))))
  30
  31 (defun find-and-invoke-mock (binding *arguments*)
  32   "Looks for a compatible mock (i.e. calls the TEST until one returns true)
  33 and executes it.  If no mock was found, no values are returned instead."
  34   (when *recordp*
  35     (record-invocation (cons (car binding) *arguments*)))
  36   (dolist (case (cdddr binding) (values))
  37     (let ((*previous* (cadr binding)))
  38       (catch 'unhandled
  39         (return (apply case *arguments*))))))
  40
  41 (defun unhandled ()
  42   (throw 'unhandled (values)))
  43
  44 (defun register-mock (name)
  45   "Registers a mocked function under NAME.  The mocked function will
  46 return no values.  See IF-CALLED to add some behaviour to it."
  47   (let ((found (member name *mock-bindings* :key #'car :test #'eq)))
  48     (or (car found)
  49         (let* ((binding (list name (maybe-fdefinition name) NIL))
  50                (function (lambda (&rest arguments)
  51                            (find-and-invoke-mock binding arguments))))
  52           (setf (caddr binding) function)
  53           (push binding *mock-bindings*)
  54           (set-fdefinition name function)
  55           binding))))
  56
  57 (defun if-called (name function &key at-start)
  58   "Registers a new binding, which should return true if it handled the
  59 invocation.  If AT-START is set, the binding is put at the start of the
  60 bindings list instead.  Calls REGISTER-MOCK automatically."
  61   (let ((binding (register-mock name)))
  62     (if at-start
  63         (push function (cdddr binding))
  64         (setf (cdddr binding) (append (cdddr binding) (list function))))))
  65
  66 (defun call-with-mocks (function &key ((:recordp *recordp*) T))
  67   "Call FUNCTION with a new mocking context.  Invocations will be
  68 recorded if RECORDP is set (default true)."
  69   (let (*mock-bindings*
  70         (*invocations* (list NIL)))
  71     (unwind-protect (funcall function)
  72       (mapc (lambda (binding)
  73               (set-or-unbind-fdefinition (car binding) (cadr binding)))
  74             *mock-bindings*))))
  75
  76 (defmacro with-mocks ((&key (recordp T)) &body body)
  77   "Execute BODY in a new mocking context.  Invocations will be recorded
  78 if RECORDP is set (default true)."
  79   `(call-with-mocks
  80     (lambda () ,@body)
  81     :recordp ,recordp))