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 (defstruct mock-bindings
   8   "Contains a set of mocked functions and their behaviour."
   9   mocks)
  10
  11 (defvar *previous*)
  12 (defvar *arguments*)
  13
  14 (defun call-previous (&rest args)
  15   "Invokes the previous binding either with the current arguments or with
  16 the given ones.  Use *PREVIOUS*/*ARGUMENTS* directly in edge cases."
  17   (apply *previous* (or args *arguments*)))
  18
  19 (defun find-and-invoke-mock (*previous* cases *arguments*)
  20   "Looks for a compatible mock (i.e. calls the TEST until one returns true)
  21 and executes it.  If no mock was found, no values are returned instead."
  22   (dolist (case cases (values))
  23     (when (ignore-errors (apply (car case) *arguments*))
  24       (return (apply (cdr case) *arguments*)))))
  25
  26 (defun call-with-mocks (mock-bindings function &key (recordp T))
  27   "Calls FUNCTION with the given MOCK-BINDINGS established and returns
  28 its return values as a LIST.  If RECORDP is set, all invocations will be
  29 recorded and returned as the second return value, else NIL."
  30   (let* ((mocks (mock-bindings-mocks mock-bindings))
  31          (functions (mapcar #'car mocks))
  32          (previous (mapcar #'maybe-fdefinition functions)))
  33     (with-collector (invocations)
  34       (call-with-function-bindings
  35        functions
  36        (mapcar (lambda (binding previous &aux (name (car binding)) (cases (cdr binding)))
  37                  (lambda (&rest args)
  38                    (when recordp
  39                      (invocations (cons name args)))
  40                    (find-and-invoke-mock previous cases args)))
  41                mocks previous)
  42        (lambda ()
  43          (values
  44           (multiple-value-list
  45            (funcall function))
  46           (invocations)))
  47        previous))))
  48
  49 (defmacro with-mocks ((mock-bindings &key (recordp T)) form &body body)
  50   `(multiple-value-bind (,values ,calls)
  51        (call-with-mocks
  52         ,mock-bindings
  53         (lambda () ,form)
  54         :recordp ,recordp)
  55      ,@body))
  56
  57 (defun register-mock (mock-bindings name)
  58   "Registers a mocked function under NAME.  The mocked function will
  59 return no values.  See IF-CALLED to add some behaviour to it."
  60   (let ((found (member name (mock-bindings-mocks mock-bindings) :key #'car :test #'eq)))
  61     (or (car found)
  62         (let ((binding (list name)))
  63           (push binding (mock-bindings-mocks mock-bindings))
  64           binding))))
  65
  66 (defun if-called (mock-bindings name test function &key at-start)
  67   "Registers a new binding to be called when the TEST function returns
  68 true.  If AT-START is set, the binding is put at the start of the bindings
  69 list instead.  Calls REGISTER-MOCK automatically."
  70   (let ((binding (register-mock mock-bindings name))
  71         (case (cons test function)))
  72     (if at-start
  73         (push case (cdr binding))
  74         (setf (cdr binding) (append (cdr binding) (list case))))))