branch: externals/debbugs
commit d014e21f9e6bd058ef5722abcd0679a83f57c4db
Author: Morgan Smith <morgan.j.sm...@outlook.com>
Commit: Michael Albinus <michael.albi...@gmx.de>
Factor cache accesses into dedicated functions
* debbugs.el (debbugs-get-cache, debbugs-put-cache): New functions.
(debbugs-newest-bugs, debbugs-get-status): Use new functions.
* test/debbugs-tests.el: Use advice to set the `cache_time' around
the new functions. (Bug#75789)
(debbugs-test-newest-bug-cached): New test.
(debbugs-test-get-status): Add test for caching behavior.
---
debbugs.el | 107 ++++++++++++++++++++++++++------------------------
test/debbugs-tests.el | 57 ++++++++++++++++++++++-----
2 files changed, 103 insertions(+), 61 deletions(-)
diff --git a/debbugs.el b/debbugs.el
index 5ab1dfc4ba..dd9b6dc09f 100644
--- a/debbugs.el
+++ b/debbugs.el
@@ -118,6 +118,33 @@ t or 0 disables caching, nil disables expiring."
(const :tag "Forever" nil)
(integer :tag "Seconds")))
+(defun debbugs-get-cache (bug-number)
+ "Return the cached status entry for the bug identified by BUG-NUMBER."
+ (let ((status (gethash bug-number debbugs-cache-data)))
+ (when (and status
+ (or (null debbugs-cache-expiry)
+ (and
+ (natnump debbugs-cache-expiry)
+ (> (alist-get 'cache_time status)
+ (- (float-time) debbugs-cache-expiry)))))
+ status)))
+
+(defun debbugs-put-cache (bug-number status &optional ttl)
+ "Put the STATUS entry for the bug BUG-NUMBER in the cache.
+Return STATUS."
+ (if (or (null debbugs-cache-expiry)
+ (and (natnump debbugs-cache-expiry)
+ (not (zerop debbugs-cache-expiry))))
+ (let ((cache-time (float-time)))
+ ;; Kind of a hack for TTL that assume that `debbugs-cache-expiry'
+ ;; doesn't change
+ (when (and ttl (natnump debbugs-cache-expiry))
+ (setq cache-time (+ ttl (- cache-time debbugs-cache-expiry))))
+ (puthash bug-number
+ (cons (cons 'cache_time cache-time) status)
+ debbugs-cache-data))
+ status))
+
(defun debbugs-soap-invoke (operation-name &rest parameters)
"Invoke the SOAP connection.
OPERATION-NAME and PARAMETERS are as described in `soap-invoke'."
@@ -325,41 +352,29 @@ patch:
(defun debbugs-newest-bugs (amount)
"Return the list of bug numbers, according to AMOUNT (a number) latest bugs."
(if (= amount 1)
- ;; We cache it as bug "0" in `debbugs-cache-data'.
- (let ((status (gethash 0 debbugs-cache-data)))
- (unless (and
- status
- (or
- (null debbugs-cache-expiry)
- (and
- (natnump debbugs-cache-expiry)
- (> (alist-get 'cache_time status)
- (- (float-time) debbugs-cache-expiry)))))
- ;; Due to `debbugs-gnu-completion-table', this function
- ;; could be called in rapid sequence. We cache temporarily
- ;; the value nil, therefore.
- (when (natnump debbugs-cache-expiry)
- (puthash
- 0
- (list (cons 'cache_time (1+ (- (float-time) debbugs-cache-expiry)))
- (list 'newest_bug))
- debbugs-cache-data))
- ;; Compute the value.
- (setq
- status
- (list
- (cons 'cache_time (float-time))
- (cons 'newest_bug
- (caar
- (debbugs-soap-invoke
- debbugs-wsdl debbugs-port "newest_bugs" amount)))))
-
- ;; Cache it.
- (when (or (null debbugs-cache-expiry) (natnump debbugs-cache-expiry))
- (puthash 0 status debbugs-cache-data)))
-
- ;; Return the value, as list.
- (list (alist-get 'newest_bug status)))
+ ;; We cache it as bug "0"
+ (let ((status (debbugs-get-cache 0)))
+ (unless status
+ ;; Due to `debbugs-gnu-completion-table', this function
+ ;; could be called in rapid sequence. We cache temporarily
+ ;; the value nil, therefore.
+ (when (natnump debbugs-cache-expiry)
+ (debbugs-put-cache 0 (list 'newest_bug) 1))
+
+ ;; Compute the value.
+ (setq
+ status
+ (list
+ (cons 'newest_bug
+ (caar
+ (debbugs-soap-invoke
+ debbugs-wsdl debbugs-port "newest_bugs" amount)))))
+
+ ;; Cache it.
+ (debbugs-put-cache 0 status))
+
+ ;; Return the value, as list.
+ (list (alist-get 'newest_bug status)))
(sort
(car (debbugs-soap-invoke
@@ -477,15 +492,8 @@ Example:
(delq nil
(mapcar
(lambda (bug)
- (let ((status (gethash bug debbugs-cache-data)))
- (if (and
- status
- (or
- (null debbugs-cache-expiry)
- (and
- (natnump debbugs-cache-expiry)
- (> (alist-get 'cache_time status)
- (- (float-time) debbugs-cache-expiry)))))
+ (let ((status (debbugs-get-cache bug)))
+ (if status
(progn
(setq cached-bugs (append cached-bugs (list status)))
nil)
@@ -582,14 +590,9 @@ Example:
(when (stringp (cdr y))
(setcdr y (split-string (cdr y) ",\\| " t))))
;; Cache the result, and return.
- (if (or (null debbugs-cache-expiry) (natnump debbugs-cache-expiry))
- (puthash
- (alist-get 'key x)
- ;; Put also a time stamp.
- (cons (cons 'cache_time (float-time)) (alist-get 'value x))
- debbugs-cache-data)
- ;; Don't cache.
- (alist-get 'value x))))
+ (debbugs-put-cache
+ (alist-get 'key x)
+ (alist-get 'value x))))
debbugs-soap-invoke-async-object))))
(defun debbugs-get-usertag (&rest query)
diff --git a/test/debbugs-tests.el b/test/debbugs-tests.el
index 8402a4fff9..f3abea2837 100644
--- a/test/debbugs-tests.el
+++ b/test/debbugs-tests.el
@@ -89,6 +89,12 @@
nil)
return)))
+(defun debbugs-test--override-float-time (func &rest rest)
+ "Override `float-time' for FUNC with args REST."
+ (cl-letf (((symbol-function #'float-time)
+ (lambda (&optional _specified-time) 5000)))
+ (apply func rest)))
+
(defun debbugs-test--setup ()
"Mock network and time functions.
These mock functions are needed to make the tests reproducible."
@@ -97,7 +103,15 @@ These mock functions are needed to make the tests
reproducible."
(add-function
:override (symbol-function #'soap-invoke-internal)
- #'debbugs-test--soap-invoke-internal))
+ #'debbugs-test--soap-invoke-internal)
+
+ (add-function
+ :around (symbol-function #'debbugs-get-cache)
+ #'debbugs-test--override-float-time)
+
+ (add-function
+ :around (symbol-function #'debbugs-put-cache)
+ #'debbugs-test--override-float-time))
(defun debbugs-test--teardown ()
"Restore functions to as they where before."
@@ -106,7 +120,15 @@ These mock functions are needed to make the tests
reproducible."
(remove-function
(symbol-function #'soap-invoke-internal)
- #'debbugs-test--soap-invoke-internal))
+ #'debbugs-test--soap-invoke-internal)
+
+ (remove-function
+ (symbol-function #'debbugs-get-cache)
+ #'debbugs-test--override-float-time)
+
+ (remove-function
+ (symbol-function #'debbugs-put-cache)
+ #'debbugs-test--override-float-time))
(defmacro ert-deftest--debbugs (name args docstring &rest body)
"The same as `ert-deftest' but runs setup and teardown functions."
@@ -138,15 +160,32 @@ These mock functions are needed to make the tests
reproducible."
(should (string-equal debbugs-test--soap-operation-name "newest_bugs"))
(should (equal debbugs-test--soap-parameters '(4))))
+(ert-deftest--debbugs debbugs-test-newest-bug-cached ()
+ "Test getting the newest bug from the cache."
+ ;; First time we get it from the server.
+ (should (equal (debbugs-newest-bugs 1) '(0)))
+ (should (equal debbugs-test--soap-operation-name "newest_bugs"))
+ (should (equal debbugs-test--soap-parameters '(1)))
+ (setq debbugs-test--soap-operation-name nil)
+ (setq debbugs-test--soap-parameters nil)
+ ;; Now it's cached
+ (should (equal (debbugs-newest-bugs 1) '(0)))
+ (should (equal debbugs-test--soap-operation-name nil))
+ (should (equal debbugs-test--soap-parameters nil)))
+
(ert-deftest--debbugs debbugs-test-get-status ()
"Test \"get_status\"."
- (cl-letf (((symbol-function #'float-time)
- (lambda (&optional _specified-time) 5000)))
- (should (= (float-time) 5000))
- (should (equal (sort (car (debbugs-get-status 64064)))
- (sort (car debbugs-test--bug-status))))
- (should (string-equal debbugs-test--soap-operation-name "get_status"))
- (should (equal debbugs-test--soap-parameters '([64064])))))
+ (should (equal (sort (car (debbugs-get-status 64064)))
+ (sort (car debbugs-test--bug-status))))
+ (should (string-equal debbugs-test--soap-operation-name "get_status"))
+ (should (equal debbugs-test--soap-parameters '([64064])))
+ (setq debbugs-test--soap-operation-name nil)
+ (setq debbugs-test--soap-parameters nil)
+ ;; cached
+ (should (equal (sort (car (debbugs-get-status 64064)))
+ (sort (car debbugs-test--bug-status))))
+ (should (equal debbugs-test--soap-operation-name nil))
+ (should (equal debbugs-test--soap-parameters nil)))
(ert-deftest--debbugs debbugs-test-get-usertag ()
"Test \"get_usertag\"."
