475391ceb2ff222a9a40e06932c37f7e6c52c53b
[gnus] / lisp / tests / gnustest-registry.el
1 ;;; gnustest-registry.el --- Registry and Gnus registry testing for Gnus
2 ;; Copyright (C) 2011-2015 Free Software Foundation, Inc.
3
4 ;; Author: Ted Zlatanov <tzz@lifelogs.com>
5
6 ;; This file is not part of GNU Emacs.
7
8 ;; GNU Emacs is free software; you can redistribute it and/or modify
9 ;; it under the terms of the GNU General Public License as published by
10 ;; the Free Software Foundation; either version 3, or (at your option)
11 ;; any later version.
12
13 ;; GNU Emacs is distributed in the hope that it will be useful,
14 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
15 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
16 ;; GNU General Public License for more details.
17
18 ;; You should have received a copy of the GNU General Public License
19 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
20
21 ;;; Commentary:
22
23 ;;; Code:
24
25 (eval-when-compile
26   (when (null (ignore-errors (require 'ert)))
27     (defmacro* ert-deftest (name () &body docstring-keys-and-body))))
28
29 (ignore-errors
30   (require 'ert))
31
32 (require 'registry)
33 (require 'gnus-registry)
34
35 (ert-deftest gnustest-registry-instantiation-test ()
36   (should (registry-db "Testing")))
37
38 (ert-deftest gnustest-registry-match-test ()
39   (let ((entry '((hello "goodbye" "bye") (blank))))
40
41     (message "Testing :regex matching")
42     (should (registry--match :regex entry '((hello "nye" "bye"))))
43     (should (registry--match :regex entry '((hello "good"))))
44     (should-not (registry--match :regex entry '((hello "nye"))))
45     (should-not (registry--match :regex entry '((hello))))
46
47     (message "Testing :member matching")
48     (should (registry--match :member entry '((hello "bye"))))
49     (should (registry--match :member entry '((hello "goodbye"))))
50     (should-not (registry--match :member entry '((hello "good"))))
51     (should-not (registry--match :member entry '((hello "nye"))))
52     (should-not (registry--match :member entry '((hello)))))
53   (message "Done with matching testing."))
54
55 (defun gnustest-registry-sort-function (l r)
56   "Sort lower values of sort-field earlier."
57   (< (cadr (assq 'sort-field l))
58      (cadr (assq 'sort-field r))))
59
60 (defun gnustest-registry-make-testable-db (n &optional prune-factor name file)
61   (let* ((db (registry-db
62               (or name "Testing")
63               :file (or file "unused")
64               :max-size n
65               :prune-factor (or prune-factor 0.1)
66               :precious '(extra more-extra)
67               :tracked '(sender subject groups))))
68     (dotimes (i n)
69       (registry-insert db i `((sender "me")
70                               (subject "about you")
71                               (more-extra) ; Empty data key should be pruned.
72                               ;; First 5 entries will NOT have this extra data.
73                               ,@(when (< 4 i) (list (list 'extra "more data")))
74                               (sort-field ,(- n i))
75                               (groups ,(number-to-string i)))))
76     db))
77
78 (ert-deftest gnustest-registry-usage-test ()
79   (let* ((n 100)
80          (db (gnustest-registry-make-testable-db n)))
81     (message "size %d" n)
82     (should (= n (registry-size db)))
83     (message "max-hard test")
84     (should-error (registry-insert db "new" '()))
85     (message "Individual lookup")
86     (should (= 58 (caadr (registry-lookup db '(1 58 99)))))
87     (message "Grouped individual lookup")
88     (should (= 3 (length (registry-lookup db '(1 58 99)))))
89     (when (boundp 'lexical-binding)
90       (message "Individual lookup (breaks before lexbind)")
91       (should (= 58
92                  (caadr (registry-lookup-breaks-before-lexbind db '(1 58 99)))))
93       (message "Grouped individual lookup (breaks before lexbind)")
94       (should (= 3
95                  (length (registry-lookup-breaks-before-lexbind db
96                                                                 '(1 58 99))))))
97     (message "Search")
98     (should (= n (length (registry-search db :all t))))
99     (should (= n (length (registry-search db :member '((sender "me"))))))
100     (message "Secondary index search")
101     (should (= n (length (registry-lookup-secondary-value db 'sender "me"))))
102     (should (equal '(74) (registry-lookup-secondary-value db 'groups "74")))
103     (message "Delete")
104     (should (registry-delete db '(1) t))
105     (decf n)
106     (message "Search after delete")
107     (should (= n (length (registry-search db :all t))))
108     (message "Secondary search after delete")
109     (should (= n (length (registry-lookup-secondary-value db 'sender "me"))))
110     (message "Done with usage testing.")))
111
112 (ert-deftest gnustest-registry-pruning-test ()
113   "Check that precious entries are never pruned."
114   (let ((dbs (list
115               ;; Can prune fully without touching precious entries.
116               (gnustest-registry-make-testable-db 10 0.1)
117               ;; Pruning limited by precious entries.
118               (gnustest-registry-make-testable-db 10 0.6))))
119     (dolist (db dbs)
120       (message "Pruning")
121       (let* ((size (registry-size db))
122              (limit (- (oref db :max-size)
123                        (* (oref db :max-size)
124                           (oref db :prune-factor))))
125              (keepers (registry-search db :member '((extra "more data"))))
126              (expected-prune-count (min (- size (length keepers))
127                                         (- size limit)))
128              (actual-prune-count (registry-prune db)))
129         (ert-info
130             ((format "Expected to prune %d entries but pruned %d"
131                      expected-prune-count actual-prune-count)
132              :prefix "Error: ")
133           (should (= expected-prune-count actual-prune-count)))))))
134
135 (ert-deftest gnustest-registry-pruning-sort-test ()
136   "Check that entries are sorted properly before pruning."
137   (let ((db (gnustest-registry-make-testable-db 10 0.4))
138         ;; These entries have the highest 'sort-field values.  Pruning
139         ;; sorts by lowest values first, then prunes from the front of
140         ;; the list, so these entries survive
141         (expected-survivors '(5 6 7 8 9 0))
142         actual-survivors disjunct)
143     (registry-prune
144      db #'gnustest-registry-sort-function)
145     (maphash (lambda (k v) (push k actual-survivors))
146              (oref db :data))
147     (setq disjunct (cl-set-exclusive-or
148                     expected-survivors
149                     actual-survivors))
150     (ert-info
151         ((format "Incorrect pruning: %s" disjunct)
152          :prefix "Error: ")
153       (should (null disjunct)))))
154
155 (ert-deftest gnustest-registry-persistence-test ()
156   (let* ((n 100)
157          (tempfile (make-temp-file "registry-persistence-"))
158          (name "persistence tester")
159          (db (gnustest-registry-make-testable-db n nil name tempfile))
160          size back)
161     (message "Saving to %s" tempfile)
162     (eieio-persistent-save db)
163     (setq size (nth 7 (file-attributes tempfile)))
164     (message "Saved to %s: size %d" tempfile size)
165     (should (< 0 size))
166     (with-temp-buffer
167       (insert-file-contents-literally tempfile)
168       (should (looking-at (concat ";; Object "
169                                   name
170                                   "\n;; EIEIO PERSISTENT OBJECT"))))
171     (message "Reading object back")
172     (setq back (eieio-persistent-read tempfile))
173     (should back)
174     (message "Read object back: %d keys, expected %d==%d"
175              (registry-size back) n (registry-size db))
176     (should (= (registry-size back) n))
177     (should (= (registry-size back) (registry-size db)))
178     (delete-file tempfile))
179   (message "Done with persistence testing."))
180
181 (ert-deftest gnustest-gnus-registry-misc-test ()
182   (should-error (gnus-registry-extract-addresses '("" "")))
183
184   (should (equal '("Ted Zlatanov <tzz@lifelogs.com>"
185                    "noname <ed@you.me>"
186                    "noname <cyd@stupidchicken.com>"
187                    "noname <tzz@lifelogs.com>")
188                  (gnus-registry-extract-addresses
189                   (concat "Ted Zlatanov <tzz@lifelogs.com>, "
190                           "ed <ed@you.me>, " ; "ed" is not a valid name here
191                           "cyd@stupidchicken.com, "
192                           "tzz@lifelogs.com")))))
193
194 (ert-deftest gnustest-gnus-registry-usage-test ()
195   (let* ((n 100)
196          (tempfile (make-temp-file "gnus-registry-persist"))
197          (db (gnus-registry-make-db tempfile))
198          (gnus-registry-db db)
199          back size)
200     (message "Adding %d keys to the test Gnus registry" n)
201     (dotimes (i n)
202       (let ((id (number-to-string i)))
203         (gnus-registry-handle-action id
204                                      (if (>= 50 i) "fromgroup" nil)
205                                      "togroup"
206                                      (when (>= 70 i)
207                                        (format "subject %d" (mod i 10)))
208                                      (when (>= 80 i)
209                                        (format "sender %d" (mod i 10))))))
210     (message "Testing Gnus registry size is %d" n)
211     (should (= n (registry-size db)))
212     (message "Looking up individual keys (registry-lookup)")
213     (should (equal (loop for e
214                          in (mapcar 'cadr
215                                     (registry-lookup db '("20" "83" "72")))
216                          collect (assq 'subject e)
217                          collect (assq 'sender e)
218                          collect (assq 'group e))
219                    '((subject "subject 0") (sender "sender 0") (group "togroup")
220                      (subject) (sender) (group "togroup")
221                      (subject) (sender "sender 2") (group "togroup"))))
222
223     (message "Looking up individual keys (gnus-registry-id-key)")
224     (should (equal (gnus-registry-get-id-key "34" 'group) '("togroup")))
225     (should (equal (gnus-registry-get-id-key "34" 'subject) '("subject 4")))
226     (message "Trying to insert a duplicate key")
227     (should-error (gnus-registry-insert db "55" '()))
228     (message "Looking up individual keys (gnus-registry-get-or-make-entry)")
229     (should (gnus-registry-get-or-make-entry "22"))
230     (message "Saving the Gnus registry to %s" tempfile)
231     (should (gnus-registry-save tempfile db))
232     (setq size (nth 7 (file-attributes tempfile)))
233     (message "Saving the Gnus registry to %s: size %d" tempfile size)
234     (should (< 0 size))
235     (with-temp-buffer
236       (insert-file-contents-literally tempfile)
237       (should (looking-at (concat ";; Object "
238                                   "Gnus Registry"
239                                   "\n;; EIEIO PERSISTENT OBJECT"))))
240     (message "Reading Gnus registry back")
241     (setq back (eieio-persistent-read tempfile))
242     (should back)
243     (message "Read Gnus registry back: %d keys, expected %d==%d"
244              (registry-size back) n (registry-size db))
245     (should (= (registry-size back) n))
246     (should (= (registry-size back) (registry-size db)))
247     (delete-file tempfile)
248     (message "Pruning Gnus registry to 0 by setting :max-size")
249     (oset db :max-size 0)
250     (registry-prune db)
251     (should (= (registry-size db) 0)))
252   (message "Done with Gnus registry usage testing."))
253
254 (provide 'gnustest-registry)
255
256 ;; Local Variables:
257 ;; no-byte-compile: t
258 ;; no-update-autoloads: t
259 ;; End: