From: Olof-Joachim Frahm Date: Mon, 22 Dec 2014 02:21:04 +0000 (+0000) Subject: Overhaul and version bump. X-Git-Tag: 1.0.0~1 X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=e8b227cbde3cf3eeb9b28f347f9ff78acb0cf0a8;p=cl-mock.git Overhaul and version bump. Add better functionality for matching via OPTIMA. New documentation for split packages (because of OPTIMA dependency). Drop all mention of generic functions for now. --- diff --git a/README.md b/README.md index d453b5a..650a7be 100644 --- a/README.md +++ b/README.md @@ -1,6 +1,6 @@ -*- mode: markdown; coding: utf-8-unix; -*- -CL-MOCK - Mocking (generic) functions. +CL-MOCK - Mocking functions. Copyright (C) 2013-14 Olof-Joachim Frahm @@ -8,65 +8,92 @@ Release under a Simplified BSD license. 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 @@ -97,3 +124,5 @@ standard `PROG`: > (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 diff --git a/cl-mock-basic.asd b/cl-mock-basic.asd new file mode 100644 index 0000000..03d3006 --- /dev/null +++ b/cl-mock-basic.asd @@ -0,0 +1,23 @@ +;; -*- mode: lisp; syntax: common-lisp; coding: utf-8-unix; package: cl-user; -*- + +(in-package #:cl-user) + +(asdf:defsystem #:cl-mock-basic + :description "Mocking library" + :long-description "Mocking library to test plain functions." + :author "Olof-Joachim Frahm " + :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"))))) diff --git a/cl-mock-tests-basic.asd b/cl-mock-tests-basic.asd new file mode 100644 index 0000000..37da5ac --- /dev/null +++ b/cl-mock-tests-basic.asd @@ -0,0 +1,18 @@ +;; -*- mode: lisp; syntax: common-lisp; coding: utf-8-unix; package: cl-user; -*- + +(in-package #:cl-user) + +(asdf:defsystem #:cl-mock-tests-basic + :description "Tests for CL-MOCK" + :author "Olof-Joachim Frahm " + :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"))))) diff --git a/cl-mock-tests.asd b/cl-mock-tests.asd index 5c82c9a..9bf4406 100644 --- a/cl-mock-tests.asd +++ b/cl-mock-tests.asd @@ -3,17 +3,13 @@ (in-package #:cl-user) (asdf:defsystem #:cl-mock-tests - :description "Tests for CL-MOCK" + :description "Tests for CL-MOCK (extended version)" :author "Olof-Joachim Frahm " :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"))))) diff --git a/cl-mock.asd b/cl-mock.asd index fac28ae..7b71beb 100644 --- a/cl-mock.asd +++ b/cl-mock.asd @@ -4,22 +4,18 @@ (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 " :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"))))) diff --git a/src/facade.lisp b/src/facade.lisp index e14c4ea..a16e88f 100644 --- a/src/facade.lisp +++ b/src/facade.lisp @@ -4,52 +4,28 @@ ;;; 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)))))))) diff --git a/src/functions.lisp b/src/functions.lisp index 803a3f2..b1dfb4c 100644 --- a/src/functions.lisp +++ b/src/functions.lisp @@ -18,14 +18,16 @@ it completely." (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." diff --git a/src/methods.lisp b/src/methods.lisp deleted file mode 100644 index 4688d2b..0000000 --- a/src/methods.lisp +++ /dev/null @@ -1,76 +0,0 @@ -;; -*- mode: lisp; syntax: common-lisp; coding: utf-8-unix; package: cl-mock; -*- - -(in-package #:cl-mock) - -;;; 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))) diff --git a/src/mock.lisp b/src/mock.lisp index e10bb32..fab5f73 100644 --- a/src/mock.lisp +++ b/src/mock.lisp @@ -4,71 +4,77 @@ ;;; 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)) diff --git a/src/package.lisp b/src/package.lisp index a499a26..8f802ae 100644 --- a/src/package.lisp +++ b/src/package.lisp @@ -3,12 +3,26 @@ (in-package #:cl-user) (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 + )) diff --git a/tests/facade.lisp b/tests/facade.lisp index c8534cf..ff4840f 100644 --- a/tests/facade.lisp +++ b/tests/facade.lisp @@ -4,115 +4,34 @@ (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))))) diff --git a/tests/functions.lisp b/tests/functions.lisp index 21761f2..507ae38 100644 --- a/tests/functions.lisp +++ b/tests/functions.lisp @@ -11,24 +11,37 @@ (def-test dflet.calls-binding () (dflet ((foo () 23)) (is (eql 23 (foo))))) + +(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))))) + +(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 @@ -39,30 +52,19 @@ modified." (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)))))) diff --git a/tests/methods.lisp b/tests/methods.lisp deleted file mode 100644 index 681712c..0000000 --- a/tests/methods.lisp +++ /dev/null @@ -1,27 +0,0 @@ -;; -*- mode: lisp; syntax: common-lisp; coding: utf-8-unix; package: cl-mock-tests; -*- - -(in-package #:cl-mock-tests) - -(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))))) diff --git a/tests/mock.lisp b/tests/mock.lisp new file mode 100644 index 0000000..c935e8e --- /dev/null +++ b/tests/mock.lisp @@ -0,0 +1,60 @@ +;; -*- mode: lisp; syntax: common-lisp; coding: utf-8-unix; package: cl-mock-tests; -*- + +(in-package #:cl-mock-tests) + +(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))))) diff --git a/tests/package.lisp b/tests/package.lisp index 1198756..dd74ae4 100644 --- a/tests/package.lisp +++ b/tests/package.lisp @@ -6,8 +6,8 @@ (:use #:cl #:cl-mock #:fiveam) (:import-from #:cl-mock #:call-with-mocks + #:with-mocks #:progm - #:make-mock-bindings #:if-called #:when-called #:call-previous