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   (apply *previous* (or args *arguments*)))
  15
  16 (defun find-and-invoke-mock (*previous* cases *arguments*)
  17   (dolist (case cases (values))
  18     (when (ignore-errors (apply (car case) *arguments*))
  19       (return (apply (cdr case) *arguments*)))))
  20
  21 (defun call-with-mocks (mock-bindings function &key (recordp T))
  22   "Calls FUNCTION with the given MOCK-BINDINGS established and returns
  23 its first return value, if any.  If RECORDP is set, all invocations will
  24 be recorded and returned as the second return value, else NIL."
  25   (let* ((mocks (mock-bindings-mocks mock-bindings))
  26          (functions (mapcar #'car mocks))
  27          (previous (mapcar #'maybe-fdefinition functions))
  28          invocations)
  29     (call-with-function-bindings
  30      functions
  31      (mapcar (lambda (binding previous &aux (name (car binding)) (cases (cdr binding)))
  32                (lambda (&rest args)
  33                  (when recordp
  34                    (push (cons name args) invocations))
  35                  (find-and-invoke-mock previous cases args)))
  36              mocks previous)
  37      (lambda ()
  38        (values
  39         (funcall function)
  40         (nreverse invocations)))
  41      previous)))
  42
  43 (defun register-mock (mock-bindings name)
  44   (let ((found (member name (mock-bindings-mocks mock-bindings) :key #'car :test #'eq)))
  45     (or (car found)
  46         (let ((binding (list name)))
  47           (push binding (mock-bindings-mocks mock-bindings))
  48           binding))))
  49
  50 (defun if-called (mock-bindings name test function &key at-start)
  51   (let ((binding (register-mock mock-bindings name))
  52         (case (cons test function)))
  53     (if at-start
  54         (push case (cdr binding))
  55         (setf (cdr binding) (append (cdr binding) (list case))))))