gist.lisp

   1 (defpackage #:mock
   2   (:use :cl)
   3   (:export
   4    #:mock-labels
   5    #:call-mocked-function
   6    #:mock-call-args
   7    #:mock-call-return-values
   8    #:mocked-function-called-p
   9    #:mocked-function-calls))
  10
  11 (in-package #:mock)
  12
  13 (defstruct mock-state
  14   (calls (make-hash-table :test 'eq)))
  15
  16 (defstruct mock-call
  17   args return-values)
  18
  19 (defvar *mock-state-chain* nil)
  20
  21 (defun binding-name (binding)
  22   (etypecase binding
  23     (list   (car binding))
  24     (symbol binding)))
  25
  26 (defun make-mock-lambda (binding orig-definition state)
  27   (let* ((args    (gensym "ARGS"))
  28          (results (gensym "RESULTS"))
  29          (name    (binding-name binding))
  30          (body    (etypecase binding
  31                     (list   `(apply (lambda ,(second binding) ,@(cddr binding))
  32                                     ,args))
  33                     (symbol '(call-mocked-function)))))
  34     `(lambda (&rest ,args)
  35        (macrolet ((call-mocked-function (&rest changed-args)
  36                     (if (null changed-args)
  37                       `(apply ,',orig-definition ,',args)
  38                       `(funcall ,',orig-definition ,@changed-args))))
  39          (let ((,results (multiple-value-list ,body)))
  40            (push (make-mock-call :args ,args :return-values ,results)
  41                  (gethash ',name (mock-state-calls ,state)))
  42            (values-list ,results))))))
  43
  44 (defmacro mock-labels (bindings &body body)
  45   (let ((temps (loop for b in bindings collect (gensym)))
  46         (state (gensym "MOCK-STATE")))
  47     `(let* ((,state             (make-mock-state))
  48             (*mock-state-chain* (cons ,state *mock-state-chain*))
  49            ,@temps)
  50        (unwind-protect
  51             (progn
  52               ,@(loop for binding in bindings
  53                       for temp in temps
  54                       for name = (binding-name binding)
  55                       collect `(setf ,temp (fdefinition ',name))
  56                       collect `(setf (fdefinition ',name)
  57                                      ,(make-mock-lambda binding temp state)))
  58               ,@body)
  59          ,@(loop for binding in bindings
  60                  for temp in temps
  61                  for name = (binding-name binding)
  62                  collect `(setf (fdefinition ',name) ,temp))))))
  63
  64 (defmacro call-mocked-function (&rest args)
  65   (declare (ignore args))
  66   (error "~A used outside of ~A definition"
  67          'call-mocked-function 'mock-labels))
  68
  69 (defun mocked-function-calls (name)
  70   (loop for s in *mock-state-chain*
  71         thereis (gethash name (mock-state-calls s))))
  72
  73 (defun mocked-function-called-p (name)
  74   (not (null (mocked-function-calls name))))
  75
  76
  77 ;; (defun foobar (x y)
  78 ;;   (+ x y))
  79
  80 ;; (defun mock-test-1 ()
  81 ;;   (mock-labels ((foobar (x y) (call-mocked-function x (1+ y))))
  82 ;;     (values (foobar 2 3)
  83 ;;             (foobar 1 1)
  84 ;;             (mocked-function-calls 'foobar))))
  85
  86 ;; (defun mock-test-2 ()
  87 ;;   (mock-labels (foobar)
  88 ;;     (values (foobar 2 3)
  89 ;;             (foobar 1 1)
  90 ;;             (mocked-function-calls 'foobar))))