cgit.sxemacs.org Git - gnus/blob - lisp/tests/gnustest-registry.el

   1 ;;; gnustest-registry.el --- Registry and Gnus registry testing for Gnus
   2 ;; Copyright (C) 2011-2014 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: