From 587765cf1a479f9fb40a47cedebdeed1f671971b Mon Sep 17 00:00:00 2001
From: Olof-Joachim Frahm <olof@macrolet.net>
Date: Sat, 31 Jan 2015 23:31:34 +0000
Subject: [PATCH] Some ideas about rebinding methods.

---
 src/mock.lisp      |   35 ++++++++++++++++++++++++++++-------
 src/package.lisp   |    2 ++
 tests/methods.lisp |    4 ++--
 tests/mock.lisp    |   21 ++++++++++++++++++++-
 4 files changed, 52 insertions(+), 10 deletions(-)

diff --git a/src/mock.lisp b/src/mock.lisp
index f1d38cb..7ea547f 100644
--- a/src/mock.lisp
+++ b/src/mock.lisp
@@ -41,17 +41,38 @@ and executes it.  If no mock was found, no values are returned instead."
 (defun unhandled ()
   (throw 'unhandled (values)))
 
-(defun register-mock (name)
+(defun register-mock (name &key method)
   "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* :key #'car :test #'eq)))
     (or (car found)
-        (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)
+        (let* ((fdefinition (maybe-fdefinition name))
+               (binding (list name fdefinition NIL)))
+          #+(or)
+          (when fdefinition
+            (when (and (typep fdefinition '(and function (not generic-function)))
+                       method)
+              (warn "Rebinding regular function ~S to generic function." name))
+            (when (and (typep fdefinition 'generic-function)
+                       (not method))
+              (warn "Rebinding generic function ~S to regular function." name)))
+          (if method
+              (let* ((qualifiers (car method))
+                     (specializers-form (cadr method))
+                     (specializers (mapcar #'classify specializers-form))
+                     (method (find-method fdefinition qualifiers specializers NIL)))
+                (ensure-method fdefinition
+                               `(lambda (list)
+                                  (let ((*arguments* (list list)))
+                                    (when *recordp*
+                                      (record-invocation (cons ',name *arguments*)))
+                                    (values)))
+                               :qualifiers qualifiers))
+              (let ((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 (name function &key at-start)
diff --git a/src/package.lisp b/src/package.lisp
index 8c92929..2e611de 100644
--- a/src/package.lisp
+++ b/src/package.lisp
@@ -27,4 +27,6 @@
    #:with-mocks
 
    ;; mocking of generic functions
+   #:progm
+   #:progm*
    ))
diff --git a/tests/methods.lisp b/tests/methods.lisp
index f61be50..681712c 100644
--- a/tests/methods.lisp
+++ b/tests/methods.lisp
@@ -12,7 +12,7 @@
     42))
 
 (def-test gf.simple ()
-  (cl-mock::progm
+  (progm
       '((baz NIL (list)))
       '((lambda (list) list))
     (is (equal '(1 2 3) (baz '(1 2 3))))
@@ -20,7 +20,7 @@
     (is (eql 42 (baz (make-instance 'foo))))))
 
 (def-test gf.overwrite ()
-  (cl-mock::progm
+  (progm
       '((baz NIL (foo)))
       '((lambda (foo) 23))
     (is (eql 23 (baz (make-instance 'foo)))))
diff --git a/tests/mock.lisp b/tests/mock.lisp
index c935e8e..e6f8ec0 100644
--- a/tests/mock.lisp
+++ b/tests/mock.lisp
@@ -57,4 +57,23 @@
     (register-mock 'bar)
     (foo)
     (bar)
-    (is (equal `((foo)) (invocations 'foo)))))
+    (is (equal '((foo)) (invocations 'foo)))))
+
+(def-test call-with-mocks.method.default-values ()
+  (with-mocks ()
+    (register-mock 'baz :method '(NIL (list)))
+    (is (null (multiple-value-list (baz NIL))))))
+
+(def-test invocations.method.simple ()
+  (with-mocks ()
+    (register-mock 'baz :method '(NIL (list)))
+    (is (typep #'baz 'generic-function))
+    (baz (list 1 2 3))
+    (is (equal '((baz (1 2 3))) (invocations)))))
+
+(def-test call-with-mocks.method.autodetection ()
+  (with-mocks ()
+    (register-mock 'baz)
+    (is (typep #'baz 'generic-function))
+    (baz (list 1 2 3))
+    (is (equal '((baz (1 2 3))) (invocations)))))
-- 
1.7.10.4