ert-with-function-mocked: New macro

* lisp/emacs-lisp/ert-x.el (ert-with-function-mocked): New macro which
allows evaluating code while particular function is replaced with
a mock.  The original definition of said function is restored once the
macro finishes.

3 files changed, 86 insertions, 0 deletions

diff --git a/etc/NEWS b/etc/NEWS
index 9e000be4a7a..04c1ee83aba 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -104,6 +104,9 @@ different group ID.
 ** Autoload files can be generated without timestamps,
 by setting `autoload-timestamps' to nil.
 
+** `ert-with-function-mocked' of 'ert-x package allows mocking of functions
+in unit tests.
+
 
 * Changes in Emacs 25.2 on Non-Free Operating Systems
 
diff --git a/lisp/emacs-lisp/ert-x.el b/lisp/emacs-lisp/ert-x.el
index 2a2418fa7d2..eb10c845d3f 100644
--- a/lisp/emacs-lisp/ert-x.el
+++ b/lisp/emacs-lisp/ert-x.el
@@ -285,6 +285,46 @@ BUFFER defaults to current buffer.  Does not modify BUFFER."
             (kill-buffer clone)))))))
 
 
+(defmacro ert-with-function-mocked (name mock &rest body)
+  "Mocks function NAME with MOCK and run BODY.
+
+Once BODY finishes (be it normally by returning a value or
+abnormally by throwing or signalling), the old definition of
+function NAME is restored.
+
+BODY may further change the mock with `fset'.
+
+If MOCK is nil, the function NAME is mocked with a function
+`ert-fail'ing when called.
+
+For example:
+
+    ;; Regular use, function is mocked inside the BODY:
+    (should (eq 2 (+ 1 1)))
+    (ert-with-function-mocked ((+ (lambda (a b) (- a b))))
+      (should (eq 0 (+ 1 1))))
+    (should (eq 2 (+ 1 1)))
+
+    ;; Macro correctly recovers from a throw or signal:
+    (should
+      (catch 'done
+        (ert-with-function-mocked ((+ (lambda (a b) (- a b))))
+          (should (eq 0 (+ 1 1))))
+          (throw 'done t)))
+    (should (eq 2 (+ 1 1)))
+"
+  (declare (indent 2))
+  (let ((old-var (make-symbol "old-var"))
+        (mock-var (make-symbol "mock-var")))
+    `(let ((,old-var (symbol-function (quote ,name))) (,mock-var ,mock))
+       (fset (quote ,name)
+             (or ,mock-var (lambda (&rest _)
+                             (ert-fail (concat "`" ,(symbol-name name)
+                                               "' unexpectedly called.")))))
+       (unwind-protect
+           (progn ,@body)
+         (fset (quote ,name) ,old-var)))))
+
 (provide 'ert-x)
 
 ;;; ert-x.el ends here
diff --git a/test/lisp/emacs-lisp/ert-x-tests.el b/test/lisp/emacs-lisp/ert-x-tests.el
index ef8642aebfb..a2665e7c390 100644
--- a/test/lisp/emacs-lisp/ert-x-tests.el
+++ b/test/lisp/emacs-lisp/ert-x-tests.el
@@ -275,6 +275,49 @@ desired effect."
              (should (equal (c x) (lisp x))))))
 
 
+(defun ert--dummy-id (a)
+  "Identity function.  Used for tests only."
+  a)
+
+(ert-deftest ert-with-function-mocked ()
+  (let ((mock-id  (lambda (_) 21)))
+    (should (eq 42 (ert--dummy-id 42)))
+
+    (ert-with-function-mocked ert--dummy-id nil
+       (fset 'ert--dummy-id mock-id)
+       (should (eq 21 (ert--dummy-id 42))))
+    (should (eq 42 (ert--dummy-id 42)))
+
+    (ert-with-function-mocked ert--dummy-id mock-id
+       (should (eq 21 (ert--dummy-id 42))))
+    (should (eq 42 (ert--dummy-id 42)))
+
+    (should
+     (catch 'exit
+       (ert-with-function-mocked ert--dummy-id mock-id
+         (should (eq 21 (ert--dummy-id 42))))
+         (throw 'exit t)))
+    (should (eq 42 (ert--dummy-id 42)))
+
+    (should
+     (string= "Foo"
+              (condition-case err
+                  (progn
+                    (ert-with-function-mocked ert--dummy-id mock-id
+                      (should (eq 21 (ert--dummy-id 42))))
+                    (user-error "Foo"))
+                (user-error (cadr err)))))
+    (should (eq 42 (ert--dummy-id 42)))
+
+    (should
+     (string= "`ert--dummy-id' unexpectedly called."
+              (condition-case err
+                  (ert-with-function-mocked ert--dummy-id nil
+                    (ert--dummy-id 42))
+                (ert-test-failed (cadr err)))))
+    (should (eq 42 (ert--dummy-id 42)))))
+
+
 (provide 'ert-x-tests)
 
 ;;; ert-x-tests.el ends here