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 (file)
--- a/README.md
+++ b/README.md
@@ -1,6 +1,6 @@
 -*- mode: markdown; coding: utf-8-unix; -*-
 
 -*- mode: markdown; coding: utf-8-unix; -*-
 

-CL-MOCK - Mocking (generic) functions.
+CL-MOCK - Mocking functions.

 
 Copyright (C) 2013-14 Olof-Joachim Frahm
 
 
 Copyright (C) 2013-14 Olof-Joachim Frahm
 

@@ -8,65 +8,92 @@ Release under a Simplified BSD license.
 
 Working, but unfinished.
 
 
 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
 
 
 # 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,
 
 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
 
 
 # UTILITIES

@@ -97,3 +124,5 @@ standard `PROG`:
     > (OR) => 42, if FOO was inlined
 
 [1]: http://common-lisp.net/project/closer/closer-mop.html
     > (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 (file)
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)
+\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")))))

diff --git a/cl-mock-tests-basic.asd b/cl-mock-tests-basic.asd
new file mode 100644 (file)
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)
+\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")))))

diff --git a/cl-mock-tests.asd b/cl-mock-tests.asd
index 5c82c9a..9bf4406 100644 (file)
--- a/cl-mock-tests.asd
+++ b/cl-mock-tests.asd
@@ -3,17 +3,13 @@
 (in-package #:cl-user)
 \f
 (asdf:defsystem #:cl-mock-tests
 (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"
   :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
   #+asdf-unicode :encoding #+asdf-unicode :utf-8

-  :depends-on (#:cl-mock #:fiveam)
+  :depends-on (#:cl-mock-tests-basic)

   :serial T
   :components ((:module "tests"
                 :components
   :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 (file)
--- a/cl-mock.asd
+++ b/cl-mock.asd
@@ -4,22 +4,18 @@
 \f
 (asdf:defsystem #:cl-mock
   :description "Mocking library"
 \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"
   :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
   #+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
   :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
                 :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 (file)
--- a/src/facade.lisp
+++ b/src/facade.lisp
@@ -4,52 +4,28 @@
 \f
 ;;; syntactic sugar for defining the mock interactions
 
 \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
   (let ((name (if (listp call) (car call) call))
         (sym (gensym)))
     `(if-called

-      ,mock-bindings

       ',name
       ',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))
       (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 (file)
--- 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
   (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."
 
 (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 (file)
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)
-\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)))

diff --git a/src/mock.lisp b/src/mock.lisp
index e10bb32..fab5f73 100644 (file)
--- a/src/mock.lisp
+++ b/src/mock.lisp
@@ -4,71 +4,77 @@
 \f
 ;;; mocking of regular functions
 
 \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*)
 
 
 (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 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."
   "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."
   "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)
     (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))))
 
           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
     (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 (file)
--- a/src/package.lisp
+++ b/src/package.lisp
@@ -3,12 +3,26 @@
 (in-package #:cl-user)
 \f
 (defpackage #:cl-mock
 (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
+   ))

diff --git a/tests/facade.lisp b/tests/facade.lisp
index c8534cf..ff4840f 100644 (file)
--- a/tests/facade.lisp
+++ b/tests/facade.lisp
@@ -4,115 +4,34 @@
 \f
 (in-suite cl-mock)
 
 \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)))))

diff --git a/tests/functions.lisp b/tests/functions.lisp
index 21761f2..507ae38 100644 (file)
--- a/tests/functions.lisp
+++ b/tests/functions.lisp
@@ -11,24 +11,37 @@
 (def-test dflet.calls-binding ()
   (dflet ((foo () 23))
     (is (eql 23 (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 ()
 
 (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 ()
 
 (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))))
             (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
 
 (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))))))
 
       (error ()
         (is (eq #'list list))))))
 

+(defun foo/lock ()
+  23)
+

 (def-test dflet.package-locks.order.1 ()
 (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)
   (let ((list #'list)

-        (foo #'foo))
+        (foo/lock #'foo/lock))

     (handler-case (dflet
     (handler-case (dflet

-                      ((foo () 13)
+                      ((foo/lock () 13)

                        (list () 42))
                     (is (eql 42 (list)))
                        (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))
       (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 (file)
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)
-\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)))))

diff --git a/tests/mock.lisp b/tests/mock.lisp
new file mode 100644 (file)
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)
+\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)))))

diff --git a/tests/package.lisp b/tests/package.lisp
index 1198756..dd74ae4 100644 (file)
--- a/tests/package.lisp
+++ b/tests/package.lisp
@@ -6,8 +6,8 @@
   (:use #:cl #:cl-mock #:fiveam)
   (:import-from #:cl-mock
                 #:call-with-mocks
   (:use #:cl #:cl-mock #:fiveam)
   (:import-from #:cl-mock
                 #:call-with-mocks

+                #:with-mocks

                 #:progm
                 #:progm

-                #:make-mock-bindings

                 #:if-called
                 #:when-called
                 #:call-previous
                 #:if-called
                 #:when-called
                 #:call-previous