From 587765cf1a479f9fb40a47cedebdeed1f671971b Mon Sep 17 00:00:00 2001 From: Olof-Joachim Frahm 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