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 first return value, if any.  If RECORDP is set, all invocations will
  29 be 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           (funcall function)
  45           (invocations)))
  46        previous))))
  47
  48 (defun register-mock (mock-bindings name)
  49   "Registers a mocked function under NAME.  The mocked function will
  50 return no values.  See IF-CALLED to add some behaviour to it."
  51   (let ((found (member name (mock-bindings-mocks mock-bindings) :key #'car :test #'eq)))
  52     (or (car found)
  53         (let ((binding (list name)))
  54           (push binding (mock-bindings-mocks mock-bindings))
  55           binding))))
  56
  57 (defun if-called (mock-bindings name test function &key at-start)
  58   "Registers a new binding to be called when the TEST function returns
  59 true.  If AT-START is set, the binding is put at the start of the bindings
  60 list instead.  Calls REGISTER-MOCK automatically."
  61   (let ((binding (register-mock mock-bindings name))
  62         (case (cons test function)))
  63     (if at-start
  64         (push case (cdr binding))
  65         (setf (cdr binding) (append (cdr binding) (list case))))))