Current state.

diff --git a/.gitattributes b/.gitattributes
new file mode 100644 (file)
index 0000000..4058346
--- /dev/null
+++ b/.gitattributes
@@ -0,0 +1 @@
+*.lisp diff=lisp

diff --git a/README.md b/README.md
index a873afe..ad9bcb6 100644 (file)
--- a/README.md
+++ b/README.md
@@ -19,6 +19,32 @@ e.g. dynamic `FLET` and method bindings with `PROGM` may be of general
 interest.
 
 
+# GENERIC FUNCTIONS
+
+Since behaviour isn't bound to classes, but to generic functions,
+creating new classes on the fly isn't particularly interesting.
+
+We provide the form `PROGM` to bind a number of methods during the
+execution of its contained 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)
+
+
 # UTILITIES
 
 `DFLET` dynamically rebinds functions similar to `FLET`:
@@ -43,5 +69,4 @@ The underlying function `PROGF` may be used as well similarly to standard
     > => 23
     > (OR) => 42, if FOO was inlined
 
-
 [1]: http://common-lisp.net/project/closer/closer-mop.html

diff --git a/cl-mock-tests.asd b/cl-mock-tests.asd
new file mode 100644 (file)
index 0000000..dcb0eb4
--- /dev/null
+++ b/cl-mock-tests.asd
@@ -0,0 +1,19 @@
+;;; -*- mode: lisp; syntax: common-lisp; coding: utf-8-unix; package: cl-user; -*-
+
+(in-package #:cl-user)
+\f
+(asdf:defsystem #:cl-mock-tests
+  :description "Tests for CL-MOCK"
+  :author "Olof-Joachim Frahm <olof@macrolet.net>"
+  :license "Simplified BSD License"
+  :version "0.0.1"
+  #+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 "facade")
+                 (:file "methods")))))
\ No newline at end of file

diff --git a/cl-mock.asd b/cl-mock.asd
index c6aa5f6..9111724 100644 (file)
--- a/cl-mock.asd
+++ b/cl-mock.asd
@@ -1,33 +1,25 @@
 ;;; -*- mode: lisp; syntax: common-lisp; coding: utf-8-unix; package: cl-user; -*-
 
 (in-package #:cl-user)
-
+\f
 (asdf:defsystem #:cl-mock
   :description "Mocking library"
-  :description "Mocking (generic) functions."
+  :long-description "Mocking library to test plain and generic functions."
   :author "Olof-Joachim Frahm <olof@macrolet.net>"
   :license "Simplified BSD License"
-  :depends-on (#:closer-mop #:alexandria)
+  :version "0.0.1"
+  #+asdf-unicode :encoding #+asdf-unicode :utf-8
+  :depends-on (#:closer-mop #:alexandria #:arnesi)
   :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 ((:module "src"
+  :components ((:static-file "README.md")
+               (:module "src"
                 :components
                 ((:file "package")
                  (:file "functions")
                  (:file "mock")
                  (:file "methods")
                  (:file "facade")))))
-
-(asdf:defsystem #:cl-mock-tests
-  :depends-on (#:cl-mock #:fiveam)
-  :serial T
-  :components ((:module "tests"
-                :components
-                ((:file "package")
-                 (:file "suite")
-                 (:file "functions")
-                 (:file "facade")
-                 (:file "methods")))))

diff --git a/src/facade.lisp b/src/facade.lisp
index d863988..8e73de9 100644 (file)
--- a/src/facade.lisp
+++ b/src/facade.lisp
@@ -1,7 +1,7 @@
 ;;; -*- mode: lisp; syntax: common-lisp; coding: utf-8-unix; package: cl-mock; -*-
 
 (in-package #:cl-mock)
-
+\f
 ;;; syntactic sugar for defining the mock interactions
 
 (defun make-lambda-pattern (literal-pattern)

diff --git a/src/functions.lisp b/src/functions.lisp
index f7b7479..cd8c772 100644 (file)
--- a/src/functions.lisp
+++ b/src/functions.lisp
@@ -1,7 +1,7 @@
 ;;; -*- mode: lisp; syntax: common-lisp; coding: utf-8-unix; package: cl-mock; -*-
 
 (in-package #:cl-mock)
-
+\f
 ;;; dynamic rebinding of functions
 
 (defun maybe-fdefinition (name)

diff --git a/src/methods.lisp b/src/methods.lisp
index ec9bba7..351938f 100644 (file)
--- a/src/methods.lisp
+++ b/src/methods.lisp
@@ -1,7 +1,7 @@
 ;;; -*- 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)

diff --git a/src/mock.lisp b/src/mock.lisp
index 33b4ba2..ae9522d 100644 (file)
--- a/src/mock.lisp
+++ b/src/mock.lisp
@@ -1,10 +1,11 @@
 ;;; -*- mode: lisp; syntax: common-lisp; coding: utf-8-unix; package: cl-mock; -*-
 
 (in-package #:cl-mock)
-
+\f
 ;;; mocking of regular functions
 
 (defstruct mock-bindings
+  "Contains a set of mocked functions and their behaviour."
   mocks)
 
 (defvar *previous*)
@@ -28,21 +29,21 @@ its first return value, if any.  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))
-         invocations)
-    (call-with-function-bindings
-     functions
-     (mapcar (lambda (binding previous &aux (name (car binding)) (cases (cdr binding)))
-               (lambda (&rest args)
-                 (when recordp
-                   (push (cons name args) invocations))
-                 (find-and-invoke-mock previous cases args)))
-             mocks previous)
-     (lambda ()
-       (values
-        (funcall function)
-        (nreverse invocations)))
-     previous)))
+         (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
+          (funcall function)
+          (invocations)))
+       previous))))
 
 (defun register-mock (mock-bindings name)
   "Registers a mocked function under NAME.  The mocked function will

diff --git a/src/package.lisp b/src/package.lisp
index b145b4f..498b4e1 100644 (file)
--- a/src/package.lisp
+++ b/src/package.lisp
@@ -1,9 +1,10 @@
 ;;; -*- mode: lisp; syntax: common-lisp; coding: utf-8-unix; package: cl-user; -*-
 
 (in-package #:cl-user)
-
+\f
 (defpackage #:cl-mock
   (:use #:closer-common-lisp #:alexandria)
+  (:import-from #:arnesi #:with-collector)
   (:export ;;; regular functions
            #:progf
            #:dflet

diff --git a/tests/facade.lisp b/tests/facade.lisp
index 2eeeec8..5db3530 100644 (file)
--- a/tests/facade.lisp
+++ b/tests/facade.lisp
@@ -1,7 +1,7 @@
 ;;; -*- 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 ()

diff --git a/tests/functions.lisp b/tests/functions.lisp
index c3219b2..3e5f23b 100644 (file)
--- a/tests/functions.lisp
+++ b/tests/functions.lisp
@@ -1,7 +1,7 @@
 ;;; -*- 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 progf.calls-binding ()

diff --git a/tests/methods.lisp b/tests/methods.lisp
index fa88e4a..89c0860 100644 (file)
--- a/tests/methods.lisp
+++ b/tests/methods.lisp
@@ -1,7 +1,7 @@
 ;;; -*- 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 ()
@@ -16,5 +16,12 @@
       '((baz NIL (list)))
       '((lambda (list) list))
     (is (equal '(1 2 3) (baz '(1 2 3))))
-    (signals error (equal T (baz T)))
-    (is (equal 42 (baz (make-instance 'foo))))))
+    (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/package.lisp b/tests/package.lisp
index 0faeab1..5c47243 100644 (file)
--- a/tests/package.lisp
+++ b/tests/package.lisp
@@ -1,7 +1,15 @@
 ;;; -*- mode: lisp; syntax: common-lisp; coding: utf-8-unix; package: cl-user; -*-
 
 (in-package #:cl-user)
-
+\f
 (defpackage #:cl-mock-tests
   (:use #:cl #:cl-mock #:fiveam)
-  (:import-from #:cl-mock #:call-with-mocks #:progm #:make-mock-bindings #:if-called #:when-called))
+  (:import-from
+   #:cl-mock
+   #:call-with-mocks
+   #:progm
+   #:make-mock-bindings
+   #:if-called
+   #:when-called
+   #:call-previous
+   #:register-mock))

diff --git a/tests/suite.lisp b/tests/suite.lisp
index 04d89be..8cb7144 100644 (file)
--- a/tests/suite.lisp
+++ b/tests/suite.lisp
@@ -1,3 +1,3 @@
 (in-package #:cl-mock-tests)
-
+\f
 (def-suite cl-mock)