mock.lisp

   1 (in-package #:cl-user)
   2 \f
   3 ;;; dynamic rebinding of functions
   4
   5 (defun maybe-fdefinition (name)
   6   "If NAME is FBOUNDP, return its FDEFINITION, else NIL."
   7   (and (fboundp name) (fdefinition name)))
   8
   9 (defun set-fdefinition (name value)
  10   "FUNCALLABLE expansion of (SETF (FDEFINITION NAME) VALUE)."
  11   (setf (fdefinition name) value))
  12
  13 (defun set-or-unbind-fdefinition (name value)
  14   "If VALUE is true, set the FDEFINITION of NAME to it, else FMAKUNBOUND
  15 it completely."
  16   (if value (set-fdefinition name value) (fmakunbound name)))
  17
  18 (defun call-with-function-bindings (functions values function
  19                                     &optional (previous (mapcar #'maybe-fdefinition functions)))
  20   "Calls FUNCTION while temporarily binding all FUNCTIONS to VALUES.
  21 See PROGF and PROGV."
  22   (unwind-protect
  23        (progn
  24          (mapc #'set-fdefinition functions values)
  25          (funcall function))
  26     (mapc #'set-or-unbind-fdefinition functions previous)))
  27
  28 (defmacro progf (functions values &body body)
  29   "Like PROGV, but for FUNCTIONS."
  30   `(call-with-function-bindings ,functions ,values (lambda () ,@body)))
  31
  32 (defmacro dflet ((&rest definitions) &body body)
  33   "Like FLET, but dynamically sets the FDEFINITIONS during the duration of
  34 the BODY."
  35   `(progf
  36        ',(mapcar #'car definitions)
  37        (list
  38         ,.(mapcar (lambda (definition)
  39                     `(lambda ,(cadr definition)
  40                        ,@(cddr definition)))
  41                   definitions))
  42      ,@body))
  43
  44 (def-test dflet.calls-binding ()
  45   (dflet ((foo () 23))
  46     (is (eql 23 (foo)))))
  47
  48 (def-test dflet.notinline.works ()
  49   (declare (notinline foo bar))
  50   (defun foo () 23)
  51   (dflet ((foo () 42))
  52     (is (eql 42 (foo)))))
  53
  54 (def-test dflet.simple-mock ()
  55   (defun foo (&optional (string "Hello, World!"))
  56     (1+ (bar string)))
  57   (defun bar (string)
  58     (length string))
  59   (dflet ((bar (string)
  60             (cond
  61               ((equalp string "Hello, World!")
  62                42))))
  63     (is (eql 43 (foo)))
  64     (is (eql 43 (foo "HELLO, WORLD!")))))
  65
  66 (def-test dflet.package-locks ()
  67   "Either we can rebind LIST, or an error occurs and the binding is not
  68 modified."
  69   (let ((list #'list))
  70     (handler-case (dflet ((list ()))
  71                     (is (eql 42 (list))))
  72       (error ()
  73         (is (eq #'list list))))))
  74
  75 (def-test dflet.package-locks.order.1 ()
  76   (defun foo ()
  77     23)
  78   (let ((list #'list)
  79         (foo #'foo))
  80     (handler-case (dflet
  81                       ((foo () 13)
  82                        (list () 42))
  83                     (is (eql 42 (list)))
  84                     (is (eql 13 (foo))))
  85       (error ()
  86         (is (eq #'list list))
  87         (is (eq #'foo foo))))))
  88
  89 (def-test dflet.package-locks.order.2 ()
  90   (defun foo ()
  91     23)
  92   (let ((list #'list)
  93         (foo #'foo))
  94     (handler-case (dflet
  95                       ((list () 42)
  96                        (foo () 13))
  97                     (is (eql 42 (list)))
  98                     (is (eql 13 (foo))))
  99       (error ()
 100         (is (eq #'list list))
 101         (is (eq #'foo foo))))))
 102 \f
 103 ;;; mocking of regular functions
 104
 105 (defstruct mock-bindings
 106   mocks)
 107
 108 (defvar *previous*)
 109 (defvar *arguments*)
 110
 111 (defun call-previous (&rest args)
 112   (apply *previous* (or args *arguments*)))
 113
 114 (defun find-and-invoke-mock (*previous* cases *arguments*)
 115   (dolist (case cases (values))
 116     (when (ignore-errors (apply (car case) *arguments*))
 117       (return (apply (cdr case) *arguments*)))))
 118
 119 (defun call-with-mocks (mock-bindings function &key (recordp T))
 120   "Calls FUNCTION with the given MOCK-BINDINGS established and returns
 121 its first return value, if any.  If RECORDP is set, all invocations will
 122 be recorded and returned as the second return value, else NIL."
 123   (let* ((mocks (mock-bindings-mocks mock-bindings))
 124          (functions (mapcar #'car mocks))
 125          (previous (mapcar #'maybe-fdefinition functions))
 126          invocations)
 127     (call-with-function-bindings
 128      functions
 129      (mapcar (lambda (binding previous &aux (name (car binding)) (cases (cdr binding)))
 130                (lambda (&rest args)
 131                  (when recordp
 132                    (push (cons name args) invocations))
 133                  (find-and-invoke-mock previous cases args)))
 134              mocks previous)
 135      (lambda ()
 136        (values
 137         (funcall function)
 138         (nreverse invocations)))
 139      previous)))
 140
 141 (defun register-mock (mock-bindings name)
 142   (let ((found (member name (mock-bindings-mocks mock-bindings) :key #'car :test #'eq)))
 143     (or (car found)
 144         (let ((binding (list name)))
 145           (push binding (mock-bindings-mocks mock-bindings))
 146           binding))))
 147
 148 (defun if-called (mock-bindings name test function &key at-start)
 149   (let ((binding (register-mock mock-bindings name))
 150         (case (cons test function)))
 151     (if at-start
 152         (push case (cdr binding))
 153         (setf (cdr binding) (append (cdr binding) (list case))))))
 154 \f
 155 ;;; syntactic sugar for defining the mock interactions
 156
 157 (defun make-lambda-pattern (literal-pattern)
 158   (let (lambda-pattern values)
 159     (loop
 160       for (car . cdr) = literal-pattern
 161       while car
 162       do (let ((sym (gensym)))
 163            (setf lambda-pattern (append lambda-pattern (list sym)))
 164            (push `(,sym . ,(if (or (symbolp car) (listp car)) `(quote ,car) car)) values)
 165            (pop literal-pattern)))
 166     (values lambda-pattern values)))
 167
 168 (defun make-test-pattern (values)
 169   `(and ,.(mapcar (lambda (value)
 170                     `(equal ,(car value) ,(cdr value)))
 171                   values)))
 172
 173 (defmacro when-called (mock-bindings call &body forms)
 174   (let ((name (if (listp call) (car call) call))
 175         (sym (gensym)))
 176     `(if-called
 177       ,mock-bindings
 178       ',name
 179       ,(if (listp call)
 180            (multiple-value-bind (lambda-pattern values)
 181                (make-lambda-pattern (cdr call))
 182              `(lambda (&rest args)
 183                 (destructuring-bind ,lambda-pattern args
 184                   ,(make-test-pattern values))))
 185            '(constantly T))
 186       (let ((,sym (fdefinition ',name)))
 187         (declare (ignorable ,sym))
 188         ,(if (cdr forms)
 189              `(let ((times 0))
 190                 (lambda (&rest args)
 191                   (declare (ignorable args))
 192                   (case (prog1 times (incf times))
 193                     ,.(loop
 194                         for i from 0
 195                         for (form . rest) on forms
 196                         collect `(,(if rest i T) ,form)))))
 197              `(lambda (&rest args)
 198                 (declare (ignorable args))
 199                 ,@forms))))))
 200
 201 (defun invocation-count (name invocations)
 202   (count name invocations :key #'car :test #'eq))
 203
 204 (defun was-called-p (name invocations)
 205   (member name invocations :key #'car :test #'eq))
 206
 207 (def-test call-with-mocks.empty ()
 208   (is (eq T (call-with-mocks
 209              (make-mock-bindings)
 210              (constantly T)))))
 211
 212 (def-test call-with-mocks.discards-values ()
 213   (is (equal
 214        '(1 NIL)
 215        (multiple-value-list
 216         (call-with-mocks
 217          (make-mock-bindings)
 218          (lambda ()
 219            (values 1 2 3)))))))
 220
 221 (def-test call-with-mocks.simple ()
 222   (declare (notinline foo))
 223   (defun foo ()
 224     (fail "original function binding ~A was called" 'foo))
 225   (let ((mock-bindings (make-mock-bindings)))
 226     (register-mock mock-bindings 'foo)
 227     (call-with-mocks
 228      mock-bindings
 229      (lambda ()
 230        (foo)
 231        (pass)))))
 232
 233 (def-test call-with-mocks.default-values ()
 234   (declare (notinline foo))
 235   (defun foo () 'foo)
 236   (let ((mock-bindings (make-mock-bindings)))
 237     (register-mock mock-bindings 'foo)
 238     (call-with-mocks
 239      mock-bindings
 240      (lambda ()
 241        (is (null (multiple-value-list (foo))))))))
 242
 243 (def-test if-called.simple ()
 244   (declare (notinline foo))
 245   (defun foo () 'foo)
 246   (let ((mock-bindings (make-mock-bindings)))
 247     (if-called mock-bindings 'foo (constantly T) (constantly 42))
 248     (call-with-mocks
 249      mock-bindings
 250      (lambda ()
 251        (is (eql 42 (foo)))))))
 252
 253 (def-test call-with-mocks.invocations ()
 254   (declare (notinline foo))
 255   (defun foo () 'foo)
 256   (let ((mock-bindings (make-mock-bindings)))
 257     (register-mock mock-bindings 'foo)
 258     (is (equal
 259          '(NIL ((foo 1) (foo 2) (foo 3)))
 260          (multiple-value-list
 261           (call-with-mocks
 262            mock-bindings
 263            (lambda ()
 264              (foo 1)
 265              (foo 2)
 266              (foo 3))))))))
 267
 268 (def-test when-called.simple ()
 269   (declare (notinline foo))
 270   (defun foo () 'foo)
 271   (let ((mock-bindings (make-mock-bindings)))
 272     (when-called mock-bindings foo 42)
 273     (when-called mock-bindings foo 23)
 274     (call-with-mocks
 275      mock-bindings
 276      (lambda ()
 277        (is (eql 42 (foo)))))))
 278
 279 (def-test when-called.literal ()
 280   (declare (notinline foo))
 281   (defun foo () 'foo)
 282   (let ((mock-bindings (make-mock-bindings)))
 283     (when-called mock-bindings (foo 1) 2)
 284     (when-called mock-bindings (foo 2) 3)
 285     (when-called mock-bindings foo 42)
 286     (call-with-mocks
 287      mock-bindings
 288      (lambda ()
 289        (is (eql 2 (foo 1)))
 290        (is (eql 2 (foo 1)))
 291        (is (eql 3 (foo 2)))
 292        (is (eql 3 (foo 2)))
 293        (is (eql 42 (foo)))
 294        (is (eql 42 (foo 'foo)))))))
 295
 296 (def-test when-called.times ()
 297   (declare (notinline foo))
 298   (defun foo () 'foo)
 299   (let ((mock-bindings (make-mock-bindings)))
 300     (when-called mock-bindings foo 1 2 3)
 301     (call-with-mocks
 302      mock-bindings
 303      (lambda ()
 304        (is (eql 1 (foo)))
 305        (is (eql 2 (foo)))
 306        (is (eql 3 (foo)))
 307        (is (eql 3 (foo)))))))
 308
 309 (def-test when-called.call-previous ()
 310   (declare (notinline foo))
 311   (defun foo () 'foo)
 312   (let ((mock-bindings (make-mock-bindings)))
 313     (when-called mock-bindings foo 3 (call-previous))
 314     (call-with-mocks
 315      mock-bindings
 316      (lambda ()
 317        (is (eql 3 (foo)))
 318        (is (eq 'foo (foo)))))))
 319 \f
 320 ;;; mocking of generic methods and objects
 321
 322 (defun find-methods (methods)
 323   (mapcar (lambda (method)
 324             (destructuring-bind (generic-function qualifiers specializers) method
 325               (cons
 326                generic-function
 327                (find-method generic-function qualifiers specializers NIL))))
 328           methods))
 329
 330 ;; TODO: because we use ENSURE-METHOD, each value is a FORM rather than a
 331 ;; FUNCTION, so not quite the same as PROGF; judging by the implementation-
 332 ;; specific code in CLOSER-MOP, we also can just create method objects
 333 ;; ourselves reliably, so either we duplicate the cases or just use SBCL
 334
 335 (defun call-with-method-bindings* (methods values function
 336                                    &optional (previous (find-methods methods)))
 337   (mapc (lambda (previous)
 338           (destructuring-bind (generic-function . method) previous
 339             (when method
 340               (remove-method generic-function method))))
 341         previous)
 342   (let ((new-methods
 343           (mapcar (lambda (method previous value)
 344                     (destructuring-bind (generic-function qualifiers specializers) method
 345                       (destructuring-bind (generic-function . method) previous
 346                         (cons
 347                          generic-function
 348                          (if method
 349                              (ensure-method generic-function value
 350                                             :method-class (class-of method)
 351                                             :qualifiers (method-qualifiers method)
 352                                             :lambda-list (method-lambda-list method)
 353                                             :specializers (method-specializers method))
 354                              (ensure-method generic-function value
 355                                             :qualifiers qualifiers
 356                                             :specializers specializers))))))
 357                   methods previous values)))
 358     (unwind-protect (funcall function)
 359       (mapc (lambda (new-method)
 360               (destructuring-bind (generic-function . method) new-method
 361                 (remove-method generic-function method)))
 362             new-methods)
 363       (mapc (lambda (previous)
 364               (destructuring-bind (generic-function . method) previous
 365                 (when method
 366                   (add-method generic-function method))))
 367             previous))))
 368
 369 (defmacro progm* (methods values &body body)
 370   `(call-with-method-bindings* ,methods ,values (lambda () ,@body)))
 371
 372 (defun call-with-method-bindings (methods values function
 373                                   &optional previous)
 374   (let ((methods
 375           (mapcar (lambda (method)
 376                     (destructuring-bind (generic-function qualifiers specializers) method
 377                       (list
 378                        (if (functionp generic-function)
 379                            generic-function
 380                            (fdefinition generic-function))
 381                        qualifiers
 382                        (mapcar (lambda (specializer)
 383                                  (if (classp specializer)
 384                                      specializer
 385                                      (find-class specializer)))
 386                                specializers))))
 387                   methods)))
 388     (call-with-method-bindings* methods values function (or previous (find-methods methods)))))
 389
 390 (defmacro progm (methods values &body body)
 391   `(call-with-method-bindings ,methods ,values (lambda () ,@body)))
 392
 393 (defclass foo ()
 394   ())
 395
 396 (defgeneric bar (foo)
 397   (:method ((foo foo))
 398     42))
 399
 400 (def-test gf.simple ()
 401   (progm
 402       '((bar NIL (list)))
 403       '((lambda (list) list))
 404     (is (equal '(1 2 3) (bar '(1 2 3))))
 405     (signals error (equal T (bar T)))
 406     (is (equal 42 (bar (make-instance 'foo))))))