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 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."
  28   (when *recordp*
  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)))
  37       (catch 'unhandled
  38         (return (apply case *arguments*))))))
  39
  40 (defun unhandled ()
  41   (throw 'unhandled (values)))
  42
  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)))
  47     (or (car found)
  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)
  54           binding))))
  55
  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)))
  61     (if at-start
  62         (push function (cdddr binding))
  63         (setf (cdddr binding) (append (cdddr binding) (list function))))))
  64
  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)."
  68   (let (*mock-bindings*
  69         (*invocations* (list NIL)))
  70     (unwind-protect (funcall function)
  71       (mapc (lambda (binding)
  72               (set-or-unbind-fdefinition (car binding) (cadr binding)))
  73             *mock-bindings*))))
  74
  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)."
  78   `(call-with-mocks
  79     (lambda () ,@body)
  80     :recordp ,recordp))