Add better functionality for matching via OPTIMA.
New documentation for split packages (because of OPTIMA dependency).
Drop all mention of generic functions for now.
-*- mode: markdown; coding: utf-8-unix; -*-
-CL-MOCK - Mocking (generic) functions.
+CL-MOCK - Mocking functions.
Copyright (C) 2013-14 Olof-Joachim Frahm
Working, but unfinished.
-Should be portable thanks to [`CLOSER-MOP`][1].
+Should be portable.
# INTRODUCTION
This small library provides a way to replace the actual implementation
-of either regular or generic functions with mocks. How to integrate
-this facility with a testing library is up to the user; the tests for
-the library are written in [`FIVEAM`][2] though, so most examples will
-take that into account.
+of either regular or generic functions with mocks. On the one hand how
+to integrate this facility with a testing library is up to the user; the
+tests for the library are written in [`FIVEAM`][2] though, so most
+examples will take that into account. On the other hand writing
+interactions for mocks usually relies on a bit of pattern matching,
+therefore the regular `CL-MOCK` package relies on [`OPTIMA`][3] to
+provide that facility instead of deferring to the user. Should this be
+a concern a reduced system definition is available as `CL-MOCK-BASIC`,
+which excludes the definition of `ANSWER` and the dependency on
+[`OPTIMA`][3].
Since it is pretty easy to just roll something like this on your own,
the main purpose is to develop a nice (lispy, declarative) syntax to
keep your tests readable and maintainable.
Some parts may be used independently of the testing facilities,
-e.g. dynamic `FLET` and method bindings with `PROGM` may be of general
-interest.
-
-
-# MOCKING CONTEXT
-
-In addition to having macros and functions to install bindings into the
-mocking context, the actual context object may be retrieved and passed
-around as well. This might be useful for further analysis or other
-helpers.
-
-
-# GENERIC FUNCTIONS
-
-Since behaviour isn't bound to classes, but to generic functions,
-creating new classes on the fly isn't particularly interesting. If
-necessary, additional shortcuts will be added, but until then I don't
-see the need for this. On the contrary, providing a way to temporarily
-supersede generic function bindings sounds like a more viable approach,
-especially with regards to (custom) method combinations.
-
-Thus, the form `PROGM` is provided to bind a number of methods during
-the execution of its body:
-
- > (progm
- > '((baz NIL (list)))
- > '((lambda (list) list))
- > ...)
-
-For example:
-
- > (defclass foo () ())
- > (defgeneric baz (foo)
- (:method ((foo foo))
- 42))
- > (progm '((baz NIL (list)))
- '((lambda (list) list))
- (values (baz (make-instance 'foo)) (baz '(1 2 3))))
- > => 42
- > => (1 2 3)
-
-This is implemented via [`CLOSER-MOP`][1], so compatiblity with that
-library is required.
+e.g. dynamic `FLET` may be of general interest.
+
+
+# MOCKING REGULAR FUNCTIONS
+
+Let's say we have a function `FOO`, then we can replace it for testing
+by establishing a new mocking context and then specifying how the new
+function should behave (see below in **UTILITIES** for a more primitive
+dynamic function rebinding):
+
+ > (declaim (notinline foo bar))
+ > (defun foo () 'foo)
+ > (defun bar () 'bar)
+ > (with-mocks ()
+ > (answer (foo 1) 42)
+ > (answer foo 23)
+ > (values
+ > (eql 42 (foo 1))
+ > (eql 23 (foo 'bar))))
+ > => T T
+
+The `ANSWER` macro has pattern matching (see [`OPTIMA`][3]) integrated.
+Therefore something like the following will now work as expected:
+
+ > (with-mocks ()
+ > (answer (foo x) (format T "Hello, ~A!" x))
+ > (foo "world"))
+ > => "Hello, world!"
+
+If you don't like `ANSWER` as it is, you can still use `IF-CALLED`
+directly. Note however that unless `UNHANDLED` is called, the function
+always matches and the return value is directly returned again:
+
+ > (with-mocks ()
+ > (if-called 'foo (lambda (x)
+ > (unhandled)
+ > (error "Not executed!")))
+ > (if-called 'foo (lambda (x) (format T "Hello, ~A!" x)))
+ > (foo "world"))
+ > => "Hello, world!"
+
+Be especially careful to handle all given arguments, otherwise the
+function call will fail and that error is propagated upwards.
+
+`IF-CALLED` also has another option to push a binding to the front of
+the list, which (as of now) isn't available via `ANSWER` (and should be
+treated as subject to change anyway).
+
+The function `INVOCATIONS` may be used to retrieve all recorded
+invocations of mocks (so far); the optional argument can be used to
+filter for a particular name:
+
+ > (with-mocks ()
+ > (answer foo)
+ > (foo "hello")
+ > (foo "world")
+ > (bar "test")
+ > (invocations 'foo))
+ > => ((FOO "hello")
+ > (FOO "world"))
+
+Currently there are no further predicates to check these values, this is
+however an area of investigation, so presumably either a macro like
+[`FIVEAM`][2]s `IS`, or regular predicates could appear in this place.
# UTILITIES
> (OR) => 42, if FOO was inlined
[1]: http://common-lisp.net/project/closer/closer-mop.html
+[2]: http://common-lisp.net/project/fiveam/
+[3]: https://github.com/m2ym/optima
--- /dev/null
+;; -*- mode: lisp; syntax: common-lisp; coding: utf-8-unix; package: cl-user; -*-
+
+(in-package #:cl-user)
+\f
+(asdf:defsystem #:cl-mock-basic
+ :description "Mocking library"
+ :long-description "Mocking library to test plain functions."
+ :author "Olof-Joachim Frahm <olof@macrolet.net>"
+ :license "Simplified BSD License"
+ :version "1.0.0"
+ #+asdf-unicode :encoding #+asdf-unicode :utf-8
+ :depends-on (#:closer-mop #:alexandria)
+ :in-order-to ((asdf:test-op (asdf:load-op #:cl-mock-tests-basic)))
+ :perform (asdf:test-op :after (op c)
+ (funcall (find-symbol (symbol-name '#:run!) '#:fiveam)
+ (find-symbol (symbol-name '#:cl-mock) '#:cl-mock-tests)))
+ :serial T
+ :components ((:static-file "README.md")
+ (:module "src"
+ :components
+ ((:file "package")
+ (:file "functions")
+ (:file "mock")))))
--- /dev/null
+;; -*- mode: lisp; syntax: common-lisp; coding: utf-8-unix; package: cl-user; -*-
+
+(in-package #:cl-user)
+\f
+(asdf:defsystem #:cl-mock-tests-basic
+ :description "Tests for CL-MOCK"
+ :author "Olof-Joachim Frahm <olof@macrolet.net>"
+ :license "Simplified BSD License"
+ :version "1.0.0"
+ #+asdf-unicode :encoding #+asdf-unicode :utf-8
+ :depends-on (#:cl-mock #:fiveam)
+ :serial T
+ :components ((:module "tests"
+ :components
+ ((:file "package")
+ (:file "suite")
+ (:file "functions")
+ (:file "mock")))))
(in-package #:cl-user)
\f
(asdf:defsystem #:cl-mock-tests
- :description "Tests for CL-MOCK"
+ :description "Tests for CL-MOCK (extended version)"
:author "Olof-Joachim Frahm <olof@macrolet.net>"
:license "Simplified BSD License"
- :version "0.0.1"
+ :version "1.0.0"
#+asdf-unicode :encoding #+asdf-unicode :utf-8
- :depends-on (#:cl-mock #:fiveam)
+ :depends-on (#:cl-mock-tests-basic)
:serial T
:components ((:module "tests"
:components
- ((:file "package")
- (:file "suite")
- (:file "functions")
- (:file "facade")
- (:file "methods")))))
+ ((:file "facade")))))
\f
(asdf:defsystem #:cl-mock
:description "Mocking library"
- :long-description "Mocking library to test plain and generic functions."
+ :long-description "Mocking library to test plain functions (extended
+version)."
:author "Olof-Joachim Frahm <olof@macrolet.net>"
:license "Simplified BSD License"
- :version "0.0.1"
+ :version "1.0.0"
#+asdf-unicode :encoding #+asdf-unicode :utf-8
- :depends-on (#:closer-mop #:alexandria #:arnesi)
+ :depends-on (#:cl-mock-basic #:closer-mop #:alexandria #:optima)
:in-order-to ((asdf:test-op (asdf:load-op #:cl-mock-tests)))
:perform (asdf:test-op :after (op c)
(funcall (find-symbol (symbol-name '#:run!) '#:fiveam)
(find-symbol (symbol-name '#:cl-mock) '#:cl-mock-tests)))
:serial T
- :components ((:static-file "README.md")
- (:module "src"
+ :components ((:module "src"
:components
- ((:file "package")
- (:file "functions")
- (:file "mock")
- (:file "methods")
- (:file "facade")))))
+ ((:file "facade")))))
\f
;;; syntactic sugar for defining the mock interactions
-(defun make-lambda-pattern (literal-pattern)
- (let (lambda-pattern values)
- (loop
- for (car . cdr) = literal-pattern
- while car
- do (let ((sym (gensym)))
- (setf lambda-pattern (append lambda-pattern (list sym)))
- (push `(,sym . ,(if (or (symbolp car) (listp car)) `(quote ,car) car)) values)
- (pop literal-pattern)))
- (values lambda-pattern values)))
+(defun true (&rest arguments)
+ (declare (ignore arguments))
+ T)
-(defun make-test-pattern (values)
- `(and ,.(mapcar (lambda (value)
- `(equal ,(car value) ,(cdr value)))
- values)))
-
-(defmacro when-called (mock-bindings call &body forms)
+(defmacro answer (call &body forms)
(let ((name (if (listp call) (car call) call))
(sym (gensym)))
`(if-called
- ,mock-bindings
',name
- ,(if (listp call)
- (multiple-value-bind (lambda-pattern values)
- (make-lambda-pattern (cdr call))
- `(lambda (&rest args)
- (destructuring-bind ,lambda-pattern args
- ,(make-test-pattern values))))
- '(constantly T))
(let ((,sym (fdefinition ',name)))
(declare (ignorable ,sym))
- ,(if (cdr forms)
- `(let ((times 0))
- (lambda (&rest args)
- (declare (ignorable args))
- (case (prog1 times (incf times))
- ,.(loop
- for i from 0
- for (form . rest) on forms
- collect `(,(if rest i T) ,form)))))
- `(lambda (&rest args)
- (declare (ignorable args))
- ,@forms))))))
-
-(defun invocation-count (name invocations)
- (count name invocations :key #'car :test #'eq))
-
-(defun was-called-p (name invocations)
- (member name invocations :key #'car :test #'eq))
+ (let ((times 0))
+ (lambda (&rest args)
+ (declare (ignorable args))
+ ,(let ((cases
+ `(case (prog1 times (incf times))
+ ,.(loop
+ for i from 0
+ for (form . rest) on forms
+ collect `(,(if rest i T) ,form)))))
+ (if (listp call)
+ `(match args
+ ((list . ,(cdr call)) ,cases)
+ (_ (unhandled)))
+ cases))))))))
(if value (set-fdefinition name value) (fmakunbound name)))
(defun call-with-function-bindings (functions values function
- &optional (previous (mapcar #'maybe-fdefinition functions)))
- "Calls FUNCTION while temporarily binding all FUNCTIONS to VALUES.
-See PROGF and PROGV."
- (unwind-protect
- (progn
- (mapc #'set-fdefinition functions values)
- (funcall function))
- (mapc #'set-or-unbind-fdefinition functions previous)))
+ &optional previous)
+ "Calls FUNCTION while temporarily binding all FUNCTIONS with the given
+names to VALUES. See PROGF and PROGV. If PREVIOUS is set, it has to
+be the list of original values for each function."
+ (let ((previous (or previous (mapcar #'maybe-fdefinition functions))))
+ (unwind-protect
+ (progn
+ (mapc #'set-fdefinition functions values)
+ (funcall function))
+ (mapc #'set-or-unbind-fdefinition functions previous))))
(defmacro progf (functions values &body body)
"Like PROGV, but for FUNCTIONS."
+++ /dev/null
-;; -*- mode: lisp; syntax: common-lisp; coding: utf-8-unix; package: cl-mock; -*-
-
-(in-package #:cl-mock)
-\f
-;;; mocking of generic methods and objects
-
-(defun find-methods (methods)
- (mapcar (lambda (method)
- (destructuring-bind (generic-function qualifiers specializers) method
- (cons
- generic-function
- (find-method generic-function qualifiers specializers NIL))))
- methods))
-
-;; TODO: because we use ENSURE-METHOD, each value is a FORM rather than a
-;; FUNCTION, so not quite the same as PROGF; judging by the implementation-
-;; specific code in CLOSER-MOP, we also can just create method objects
-;; ourselves reliably, so either we duplicate the cases or just use SBCL
-
-(defun call-with-method-bindings* (methods values function
- &optional (previous (find-methods methods)))
- (mapc (lambda (previous)
- (destructuring-bind (generic-function . method) previous
- (when method
- (remove-method generic-function method))))
- previous)
- (let ((new-methods
- (mapcar (lambda (method previous value)
- (destructuring-bind (generic-function qualifiers specializers) method
- (declare (ignore generic-function))
- (destructuring-bind (generic-function . method) previous
- (cons
- generic-function
- (if method
- (ensure-method generic-function value
- :method-class (class-of method)
- :qualifiers (method-qualifiers method)
- :lambda-list (method-lambda-list method)
- :specializers (method-specializers method))
- (ensure-method generic-function value
- :qualifiers qualifiers
- :specializers specializers))))))
- methods previous values)))
- (unwind-protect (funcall function)
- (mapc (lambda (new-method)
- (destructuring-bind (generic-function . method) new-method
- (remove-method generic-function method)))
- new-methods)
- (mapc (lambda (previous)
- (destructuring-bind (generic-function . method) previous
- (when method
- (add-method generic-function method))))
- previous))))
-
-(defmacro progm* (methods values &body body)
- `(call-with-method-bindings* ,methods ,values (lambda () ,@body)))
-
-(defun classify (specializer)
- (if (classp specializer)
- specializer
- (find-class specializer)))
-
-(defun call-with-method-bindings (methods values function
- &optional previous)
- (let ((methods
- (mapcar (lambda (method)
- (destructuring-bind (generic-function qualifiers specializers) method
- (list
- (ensure-function generic-function)
- qualifiers
- (mapcar #'classify specializers))))
- methods)))
- (call-with-method-bindings* methods values function (or previous (find-methods methods)))))
-
-(defmacro progm (methods values &body body)
- `(call-with-method-bindings ,methods ,values (lambda () ,@body)))
\f
;;; mocking of regular functions
-(defstruct mock-bindings
- "Contains a set of mocked functions and their behaviour."
- mocks)
+(defvar *mock-bindings*)
+(defvar *invocations*)
+(defvar *recordp*)
(defvar *previous*)
(defvar *arguments*)
+(defun invocations (&optional name)
+ (let ((invocations (car *invocations*)))
+ (if name
+ (remove name invocations :key #'car :test-not #'eq)
+ invocations)))
+
(defun call-previous (&rest args)
"Invokes the previous binding either with the current arguments or with
the given ones. Use *PREVIOUS*/*ARGUMENTS* directly in edge cases."
(apply *previous* (or args *arguments*)))
-(defun find-and-invoke-mock (*previous* cases *arguments*)
+(defun find-and-invoke-mock (binding *arguments*)
"Looks for a compatible mock (i.e. calls the TEST until one returns true)
and executes it. If no mock was found, no values are returned instead."
- (dolist (case cases (values))
- (when (ignore-errors (apply (car case) *arguments*))
- (return (apply (cdr case) *arguments*)))))
-
-(defun call-with-mocks (mock-bindings function &key (recordp T))
- "Calls FUNCTION with the given MOCK-BINDINGS established and returns
-its return values as a LIST. If RECORDP is set, all invocations will be
-recorded and returned as the second return value, else NIL."
- (let* ((mocks (mock-bindings-mocks mock-bindings))
- (functions (mapcar #'car mocks))
- (previous (mapcar #'maybe-fdefinition functions)))
- (with-collector (invocations)
- (call-with-function-bindings
- functions
- (mapcar (lambda (binding previous &aux (name (car binding)) (cases (cdr binding)))
- (lambda (&rest args)
- (when recordp
- (invocations (cons name args)))
- (find-and-invoke-mock previous cases args)))
- mocks previous)
- (lambda ()
- (values
- (multiple-value-list
- (funcall function))
- (invocations)))
- previous))))
+ (when *recordp*
+ (let ((record (list (cons (car binding) *arguments*))))
+ (if (null (car *invocations*))
+ (setf (cdr *invocations*)
+ (setf (car *invocations*) record))
+ (setf (cdr *invocations*)
+ (setf (cddr *invocations*) record)))))
+ (dolist (case (cdddr binding) (values))
+ (let ((*previous* (cadr binding)))
+ (catch 'unhandled
+ (return (apply case *arguments*))))))
-(defmacro with-mocks ((mock-bindings &key (recordp T)) form &body body)
- `(multiple-value-bind (,values ,calls)
- (call-with-mocks
- ,mock-bindings
- (lambda () ,form)
- :recordp ,recordp)
- ,@body))
+(defun unhandled ()
+ (throw 'unhandled (values)))
-(defun register-mock (mock-bindings name)
+(defun register-mock (name)
"Registers a mocked function under NAME. The mocked function will
return no values. See IF-CALLED to add some behaviour to it."
- (let ((found (member name (mock-bindings-mocks mock-bindings) :key #'car :test #'eq)))
+ (let ((found (member name *mock-bindings* :key #'car :test #'eq)))
(or (car found)
- (let ((binding (list name)))
- (push binding (mock-bindings-mocks mock-bindings))
+ (let* ((binding (list name (maybe-fdefinition name) NIL))
+ (function (lambda (&rest arguments)
+ (find-and-invoke-mock binding arguments))))
+ (setf (caddr binding) function)
+ (push binding *mock-bindings*)
+ (set-fdefinition name function)
binding))))
-(defun if-called (mock-bindings name test function &key at-start)
- "Registers a new binding to be called when the TEST function returns
-true. If AT-START is set, the binding is put at the start of the bindings
-list instead. Calls REGISTER-MOCK automatically."
- (let ((binding (register-mock mock-bindings name))
- (case (cons test function)))
+(defun if-called (name function &key at-start)
+ "Registers a new binding, which should return true if it handled the
+invocation. If AT-START is set, the binding is put at the start of the
+bindings list instead. Calls REGISTER-MOCK automatically."
+ (let ((binding (register-mock name)))
(if at-start
- (push case (cdr binding))
- (setf (cdr binding) (append (cdr binding) (list case))))))
+ (push function (cdddr binding))
+ (setf (cdddr binding) (append (cdddr binding) (list function))))))
+
+(defun call-with-mocks (function &key ((:recordp *recordp*) T))
+ "Call FUNCTION with a new mocking context. Invocations will be
+recorded if RECORDP is set (default true)."
+ (let (*mock-bindings*
+ (*invocations* (list NIL)))
+ (unwind-protect (funcall function)
+ (mapc (lambda (binding)
+ (set-or-unbind-fdefinition (car binding) (cadr binding)))
+ *mock-bindings*))))
+
+(defmacro with-mocks ((&key (recordp T)) &body body)
+ "Execute BODY in a new mocking context. Invocations will be recorded
+if RECORDP is set (default true)."
+ `(call-with-mocks
+ (lambda () ,@body)
+ :recordp ,recordp))
(in-package #:cl-user)
\f
(defpackage #:cl-mock
- (:use #:closer-common-lisp #:alexandria)
- (:import-from #:arnesi #:with-collector)
- (:export ;; regular functions
- #:progf
- #:dflet
-
- ;; mocking of regular functions
- ;; mocking of generic functions
- ))
+ (:use #:closer-common-lisp #:alexandria #:optima)
+ (:export
+ ;; regular functions
+ #:maybe-fdefinition
+ #:set-fdefinition
+ #:set-or-unbind-fdefinition
+ #:call-with-function-bindings
+
+ #:progf
+ #:dflet
+
+ ;; mocking of regular functions
+ #:call-previous
+ #:register-mock
+ #:invocations
+ #:if-called
+ #:unhandled
+ #:answer
+ #:call-with-mocks
+ #:with-mocks
+
+ ;; mocking of generic functions
+ ))
\f
(in-suite cl-mock)
-(def-test call-with-mocks.empty ()
- (is (equal '(T) (call-with-mocks
- (make-mock-bindings)
- (constantly T)))))
-
-(def-test call-with-mocks.discards-values ()
- (is (equal
- '((1 2 3) NIL)
- (multiple-value-list
- (call-with-mocks
- (make-mock-bindings)
- (lambda ()
- (values 1 2 3)))))))
-
-(def-test call-with-mocks.simple ()
- (declare (notinline foo))
- (defun foo ()
- (fail "original function binding ~A was called" 'foo))
- (let ((mock-bindings (make-mock-bindings)))
- (register-mock mock-bindings 'foo)
- (call-with-mocks
- mock-bindings
- (lambda ()
- (foo)
- (pass)))))
-
-(def-test call-with-mocks.default-values ()
- (declare (notinline foo))
- (defun foo () 'foo)
- (let ((mock-bindings (make-mock-bindings)))
- (register-mock mock-bindings 'foo)
- (call-with-mocks
- mock-bindings
- (lambda ()
- (is (null (multiple-value-list (foo))))))))
-
-(def-test if-called.simple ()
- (declare (notinline foo))
- (defun foo () 'foo)
- (let ((mock-bindings (make-mock-bindings)))
- (if-called mock-bindings 'foo (constantly T) (constantly 42))
- (call-with-mocks
- mock-bindings
- (lambda ()
- (is (eql 42 (foo)))))))
-
-(def-test call-with-mocks.invocations ()
- (declare (notinline foo))
- (defun foo () 'foo)
- (let ((mock-bindings (make-mock-bindings)))
- (register-mock mock-bindings 'foo)
- (is (equal
- '(NIL ((foo 1) (foo 2) (foo 3)))
- (multiple-value-list
- (call-with-mocks
- mock-bindings
- (lambda ()
- (foo 1)
- (foo 2)
- (foo 3))))))))
-
-(def-test when-called.simple ()
- (declare (notinline foo))
- (defun foo () 'foo)
- (let ((mock-bindings (make-mock-bindings)))
- (when-called mock-bindings foo 42)
- (when-called mock-bindings foo 23)
- (call-with-mocks
- mock-bindings
- (lambda ()
- (is (eql 42 (foo)))))))
-
-(def-test when-called.literal ()
- (declare (notinline foo))
- (defun foo () 'foo)
- (let ((mock-bindings (make-mock-bindings)))
- (when-called mock-bindings (foo 1) 2)
- (when-called mock-bindings (foo 2) 3)
- (when-called mock-bindings foo 42)
- (call-with-mocks
- mock-bindings
- (lambda ()
- (is (eql 2 (foo 1)))
- (is (eql 2 (foo 1)))
- (is (eql 3 (foo 2)))
- (is (eql 3 (foo 2)))
- (is (eql 42 (foo)))
- (is (eql 42 (foo 'foo)))))))
-
-(def-test when-called.times ()
- (declare (notinline foo))
- (defun foo () 'foo)
- (let ((mock-bindings (make-mock-bindings)))
- (when-called mock-bindings foo 1 2 3)
- (call-with-mocks
- mock-bindings
- (lambda ()
- (is (eql 1 (foo)))
- (is (eql 2 (foo)))
- (is (eql 3 (foo)))
- (is (eql 3 (foo)))))))
-
-(def-test when-called.call-previous ()
- (declare (notinline foo))
- (defun foo () 'foo)
- (let ((mock-bindings (make-mock-bindings)))
- (when-called mock-bindings foo 3 (call-previous))
- (call-with-mocks
- mock-bindings
- (lambda ()
- (is (eql 3 (foo)))
- (is (eq 'foo (foo)))))))
+(def-test answer.simple ()
+ (with-mocks ()
+ (answer (foo 1) 42)
+ (answer foo 23)
+ (is (eql 42 (foo 1)))))
+
+(def-test answer.literal ()
+ (with-mocks ()
+ (answer (foo 1) 2)
+ (answer (foo 2) 3)
+ (answer foo 42)
+ (is (eql 2 (foo 1)))
+ (is (eql 2 (foo 1)))
+ (is (eql 3 (foo 2)))
+ (is (eql 3 (foo 2)))
+ (is (eql 42 (foo)))
+ (is (eql 42 (foo 'foo)))))
+
+(def-test answer.times ()
+ (with-mocks ()
+ (answer foo 1 2 3)
+ (is (eql 1 (foo)))
+ (is (eql 2 (foo)))
+ (is (eql 3 (foo)))
+ (is (eql 3 (foo)))))
+
+(def-test answer.call-previous ()
+ (with-mocks ()
+ (answer foo 3 (call-previous))
+ (is (eql 3 (foo)))
+ (is (eq 'foo (foo)))))
(def-test dflet.calls-binding ()
(dflet ((foo () 23))
(is (eql 23 (foo)))))
+\f
+(declaim (inline foo/inline))
+(defun foo/inline ()
+ 23)
+
+(def-test dflet.inline.works ()
+ "If a function is declared INLINE (and that request is honored), DFLET
+won't work."
+ (dflet ((foo/inline () 42))
+ (is (eql 23 (foo/inline)))))
(def-test dflet.notinline.works ()
- (declare (notinline foo bar))
- (defun foo () 23)
- (dflet ((foo () 42))
- (is (eql 42 (foo)))))
+ "If a function is declared INLINE, but NOTINLINE is used locally,
+DFLET will work."
+ (declare (notinline foo/inline))
+ (dflet ((foo/inline () 42))
+ (is (eql 42 (foo/inline)))))
+\f
+(defun foo/mock (&optional (string "Hello, World!"))
+ (1+ (bar/mock string)))
+
+(defun bar/mock (string)
+ (length string))
(def-test dflet.simple-mock ()
- (defun foo (&optional (string "Hello, World!"))
- (1+ (bar string)))
- (defun bar (string)
- (length string))
- (dflet ((bar (string)
+ (dflet ((bar/mock (string)
(cond
((equalp string "Hello, World!")
42))))
- (is (eql 43 (foo)))
- (is (eql 43 (foo "HELLO, WORLD!")))))
+ (is (eql 43 (foo/mock)))
+ (is (eql 43 (foo/mock "HELLO, WORLD!")))))
(def-test dflet.package-locks ()
"Either we can rebind LIST, or an error occurs and the binding is not
(error ()
(is (eq #'list list))))))
+(defun foo/lock ()
+ 23)
+
(def-test dflet.package-locks.order.1 ()
- (defun foo ()
- 23)
+ "Either we can rebind LIST, or an error occurs and both binding are
+restored."
(let ((list #'list)
- (foo #'foo))
+ (foo/lock #'foo/lock))
(handler-case (dflet
- ((foo () 13)
+ ((foo/lock () 13)
(list () 42))
(is (eql 42 (list)))
- (is (eql 13 (foo))))
- (error ()
- (is (eq #'list list))
- (is (eq #'foo foo))))))
-
-(def-test dflet.package-locks.order.2 ()
- (defun foo ()
- 23)
- (let ((list #'list)
- (foo #'foo))
- (handler-case (dflet
- ((list () 42)
- (foo () 13))
- (is (eql 42 (list)))
- (is (eql 13 (foo))))
+ (is (eql 13 (foo/lock))))
(error ()
(is (eq #'list list))
- (is (eq #'foo foo))))))
+ (is (eq #'foo/lock foo/lock))))))
+++ /dev/null
-;; -*- mode: lisp; syntax: common-lisp; coding: utf-8-unix; package: cl-mock-tests; -*-
-
-(in-package #:cl-mock-tests)
-\f
-(in-suite cl-mock)
-
-(defclass foo ()
- ())
-
-(defgeneric baz (foo)
- (:method ((foo foo))
- 42))
-
-(def-test gf.simple ()
- (progm
- '((baz NIL (list)))
- '((lambda (list) list))
- (is (equal '(1 2 3) (baz '(1 2 3))))
- (signals error (eq T (baz T)))
- (is (eql 42 (baz (make-instance 'foo))))))
-
-(def-test gf.overwrite ()
- (progm
- '((baz NIL (foo)))
- '((lambda (foo) 23))
- (is (eql 23 (baz (make-instance 'foo)))))
- (is (eql 42 (baz (make-instance 'foo)))))
--- /dev/null
+;; -*- mode: lisp; syntax: common-lisp; coding: utf-8-unix; package: cl-mock-tests; -*-
+
+(in-package #:cl-mock-tests)
+\f
+(in-suite cl-mock)
+
+(def-test call-with-mocks.empty ()
+ (is (eq T (with-mocks () T))))
+
+(def-test call-with-mocks.discards-values ()
+ (is (equal
+ '(1 2 3)
+ (multiple-value-list
+ (with-mocks ()
+ (values 1 2 3))))))
+
+(declaim (notinline foo/simple))
+(defun foo/simple ()
+ (fail "original function binding ~A was called" 'foo/simple))
+
+(def-test call-with-mocks.simple ()
+ (with-mocks ()
+ (register-mock 'foo/simple)
+ (foo/simple)
+ (pass)))
+
+(declaim (notinline foo bar))
+(defun foo () 'foo)
+(defun bar () 'bar)
+
+(def-test call-with-mocks.default-values ()
+ (with-mocks ()
+ (register-mock 'foo)
+ (is (null (multiple-value-list (foo))))))
+
+(def-test if-called.simple ()
+ (with-mocks ()
+ (if-called 'foo (constantly 42))
+ (is (eql 42 (foo)))))
+
+(def-test invocations.length ()
+ (with-mocks ()
+ (register-mock 'foo)
+ (dotimes (i 3) (foo))
+ (is (eql 3 (length (invocations))))))
+
+(def-test invocations.arguments ()
+ (with-mocks ()
+ (register-mock 'foo)
+ (let ((sym (gensym)))
+ (foo sym)
+ (is (equal `((foo ,sym)) (invocations))))))
+
+(def-test invocations.name ()
+ (with-mocks ()
+ (register-mock 'foo)
+ (register-mock 'bar)
+ (foo)
+ (bar)
+ (is (equal `((foo)) (invocations 'foo)))))
(:use #:cl #:cl-mock #:fiveam)
(:import-from #:cl-mock
#:call-with-mocks
+ #:with-mocks
#:progm
- #:make-mock-bindings
#:if-called
#:when-called
#:call-previous
projects / cl-mock.git / commitdiff