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