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 &key method)
  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* ((fdefinition (maybe-fdefinition name))
  50                (binding (list name fdefinition NIL)))
  51           #+(or)
  52           (when fdefinition
  53             (when (and (typep fdefinition '(and function (not generic-function)))
  54                        method)
  55               (warn "Rebinding regular function ~S to generic function." name))
  56             (when (and (typep fdefinition 'generic-function)
  57                        (not method))
  58               (warn "Rebinding generic function ~S to regular function." name)))
  59           (if method
  60               (let* ((qualifiers (car method))
  61                      (specializers-form (cadr method))
  62                      (specializers (mapcar #'classify specializers-form))
  63                      (method (find-method fdefinition qualifiers specializers NIL)))
  64                 (ensure-method fdefinition
  65                                `(lambda (list)
  66                                   (let ((*arguments* (list list)))
  67                                     (when *recordp*
  68                                       (record-invocation (cons ',name *arguments*)))
  69                                     (values)))
  70                                :qualifiers qualifiers))
  71               (let ((function (lambda (&rest arguments)
  72                       (find-and-invoke-mock binding arguments))))
  73                 (setf (caddr binding) function)
  74                 (push binding *mock-bindings*)
  75                 (set-fdefinition name function)))
  76           binding))))
  77
  78 (defun if-called (name function &key at-start)
  79   "Registers a new binding, which should return true if it handled the
  80 invocation.  If AT-START is set, the binding is put at the start of the
  81 bindings list instead.  Calls REGISTER-MOCK automatically."
  82   (let ((binding (register-mock name)))
  83     (if at-start
  84         (push function (cdddr binding))
  85         (setf (cdddr binding) (append (cdddr binding) (list function))))))
  86
  87 (defun call-with-mocks (function &key ((:recordp *recordp*) T))
  88   "Call FUNCTION with a new mocking context.  Invocations will be
  89 recorded if RECORDP is set (default true)."
  90   (let (*mock-bindings*
  91         (*invocations* (list NIL)))
  92     (unwind-protect (funcall function)
  93       (mapc (lambda (binding)
  94               (set-or-unbind-fdefinition (car binding) (cadr binding)))
  95             *mock-bindings*))))
  96
  97 (defmacro with-mocks ((&key (recordp T)) &body body)
  98   "Execute BODY in a new mocking context.  Invocations will be recorded
  99 if RECORDP is set (default true)."
 100   `(call-with-mocks
 101     (lambda () ,@body)
 102     :recordp ,recordp))