aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorTeodor Zlatanov2011-04-05 22:35:05 +0000
committerKatsumi Yamaoka2011-04-05 22:35:05 +0000
commit11a3174d87f3a09fe0d9d36d41669cf5d66e3019 (patch)
treece1a4b5aef0e8bab5f6e11aa1ddd13d36101cf1a
parent41ea9e48373c689eae6a72684a4d26d5ccd41af0 (diff)
downloademacs-11a3174d87f3a09fe0d9d36d41669cf5d66e3019.tar.gz
emacs-11a3174d87f3a09fe0d9d36d41669cf5d66e3019.zip
Merge changes made in Gnus trunk.
gnus-registry.el (gnus-registry-fixup-registry): New function to fixup the parameters that can be customized by the user between save/read cycles. (gnus-registry-read): Use it. (gnus-registry-make-db): Use it. (gnus-registry-spool-action, gnus-registry-handle-action): Fix messaging. (gnus-registry--split-fancy-with-parent-internal): Fix loop. Map references to actual group names with sender and subject tracking. (gnus-registry-post-process-groups): Use `cond' for better messaging. (gnus-registry-usage-test): Add subject lookup test. registry.el (registry-db, initialize-instance): Set up constructor instead of :initform arguments for the sake of older Emacsen. (registry-lookup-breaks-before-lexbind): New method to demonstrate pre-lexbind merge bug. (registry-usage-test): Use it. (initialize-instance, registry-db): Move the non-function initforms back to the class definition. registry.el: New library to manage gnus-registry-style data. gnus-registry.el: Use it (major rewrite). nnregistry.el: Use it. spam.el: Use it.
Diffstat
-rw-r--r--lisp/gnus/ChangeLog32
-rw-r--r--lisp/gnus/gnus-registry.el1364
-rw-r--r--lisp/gnus/nnregistry.el2
-rw-r--r--lisp/gnus/spam.el27
4 files changed, 601 insertions, 824 deletions
diff --git a/lisp/gnus/ChangeLog b/lisp/gnus/ChangeLog
index 64cc6eb4f8b..35acbfdb4bb 100644
--- a/lisp/gnus/ChangeLog
+++ b/lisp/gnus/ChangeLog
@@ -1,3 +1,35 @@
12011-04-05 Teodor Zlatanov <tzz@lifelogs.com>
2
3 * gnus-registry.el (gnus-registry-fixup-registry): New function to
4 fixup the parameters that can be customized by the user between
5 save/read cycles.
6 (gnus-registry-read): Use it.
7 (gnus-registry-make-db): Use it.
8 (gnus-registry-spool-action, gnus-registry-handle-action): Fix
9 messaging.
10 (gnus-registry--split-fancy-with-parent-internal): Fix loop. Map
11 references to actual group names with sender and subject tracking.
12 (gnus-registry-post-process-groups): Use `cond' for better messaging.
13 (gnus-registry-usage-test): Add subject lookup test.
14
15 * registry.el (registry-db, initialize-instance): Set up constructor
16 instead of :initform arguments for the sake of older Emacsen.
17 (registry-lookup-breaks-before-lexbind): New method to demonstrate
18 pre-lexbind merge bug.
19 (registry-usage-test): Use it.
20 (initialize-instance, registry-db): Move the non-function initforms
21 back to the class definition.
22
232011-04-03 Teodor Zlatanov <tzz@lifelogs.com>
24
25 * registry.el: New library to manage gnus-registry-style data.
26
27 * gnus-registry.el: Use it (major rewrite).
28
29 * nnregistry.el: Use it.
30
31 * spam.el: Use it.
32
12011-04-03 Lars Magne Ingebrigtsen <larsi@gnus.org> 332011-04-03 Lars Magne Ingebrigtsen <larsi@gnus.org>
2 34
3 * gnus-sum.el (gnus-update-marks): Reinstate the code to not alter 35 * gnus-sum.el (gnus-update-marks): Reinstate the code to not alter
diff --git a/lisp/gnus/gnus-registry.el b/lisp/gnus/gnus-registry.el
index db3cc06e9aa..3ab8400a500 100644
--- a/lisp/gnus/gnus-registry.el
+++ b/lisp/gnus/gnus-registry.el
@@ -23,7 +23,7 @@
23;;; Commentary: 23;;; Commentary:
24 24
25;; This is the gnus-registry.el package, which works with all 25;; This is the gnus-registry.el package, which works with all
26;; backends, not just nnmail (e.g. NNTP). The major issue is that it 26;; Gnus backends, not just nnmail. The major issue is that it
27;; doesn't go across backends, so for instance if an article is in 27;; doesn't go across backends, so for instance if an article is in
28;; nnml:sys and you see a reference to it in nnimap splitting, the 28;; nnml:sys and you see a reference to it in nnimap splitting, the
29;; article will end up in nnimap:sys 29;; article will end up in nnimap:sys
@@ -35,8 +35,7 @@
35 35
36;; Put this in your startup file (~/.gnus.el for instance) 36;; Put this in your startup file (~/.gnus.el for instance)
37 37
38;; (setq gnus-registry-max-entries 2500 38;; (setq gnus-registry-max-entries 2500)
39;; gnus-registry-use-long-group-names t)
40 39
41;; (gnus-registry-initialize) 40;; (gnus-registry-initialize)
42 41
@@ -51,18 +50,22 @@
51 50
52;; - get the correct group on spool actions 51;; - get the correct group on spool actions
53 52
54;; - articles that are spooled to a different backend should be handled 53;; - articles that are spooled to a different backend should be moved
54;; after splitting
55 55
56;;; Code: 56;;; Code:
57 57
58(eval-when-compile (require 'cl)) 58(eval-when-compile (require 'cl))
59 59
60(require 'ert)
60(require 'gnus) 61(require 'gnus)
61(require 'gnus-int) 62(require 'gnus-int)
62(require 'gnus-sum) 63(require 'gnus-sum)
64(require 'gnus-art)
63(require 'gnus-util) 65(require 'gnus-util)
64(require 'nnmail) 66(require 'nnmail)
65(require 'easymenu) 67(require 'easymenu)
68(require 'registry)
66 69
67(defvar gnus-adaptive-word-syntax-table) 70(defvar gnus-adaptive-word-syntax-table)
68 71
@@ -74,12 +77,7 @@
74 :version "22.1" 77 :version "22.1"
75 :group 'gnus) 78 :group 'gnus)
76 79
77(defvar gnus-registry-hashtb (make-hash-table 80(defvar gnus-registry-marks
78 :size 256
79 :test 'equal)
80 "*The article registry by Message ID.")
81
82(defcustom gnus-registry-marks
83 '((Important 81 '((Important
84 :char ?i 82 :char ?i
85 :image "summary_important") 83 :image "summary_important")
@@ -105,29 +103,25 @@ Each entry must have a character to be useful for summary mode
105line display and for keyboard shortcuts. 103line display and for keyboard shortcuts.
106 104
107Each entry must have an image string to be useful for visual 105Each entry must have an image string to be useful for visual
108display." 106display.")
109 :group 'gnus-registry
110 :type '(repeat :tag "Registry Marks"
111 (cons :tag "Mark"
112 (symbol :tag "Name")
113 (checklist :tag "Options" :greedy t
114 (group :inline t
115 (const :format "" :value :char)
116 (character :tag "Character code"))
117 (group :inline t
118 (const :format "" :value :image)
119 (string :tag "Image"))))))
120 107
121(defcustom gnus-registry-default-mark 'To-Do 108(defcustom gnus-registry-default-mark 'To-Do
122 "The default mark. Should be a valid key for `gnus-registry-marks'." 109 "The default mark. Should be a valid key for `gnus-registry-marks'."
123 :group 'gnus-registry 110 :group 'gnus-registry
124 :type 'symbol) 111 :type 'symbol)
125 112
113(defcustom gnus-registry-unfollowed-addresses
114 (list (regexp-quote user-mail-address))
115 "List of addresses that gnus-registry-split-fancy-with-parent won't trace.
116The addresses are matched, they don't have to be fully qualified."
117 :group 'gnus-registry
118 :type '(repeat regexp))
119
126(defcustom gnus-registry-unfollowed-groups 120(defcustom gnus-registry-unfollowed-groups
127 '("delayed$" "drafts$" "queue$" "INBOX$" "^nnmairix:" "archive") 121 '("delayed$" "drafts$" "queue$" "INBOX$" "^nnmairix:" "archive")
128 "List of groups that gnus-registry-split-fancy-with-parent won't return. 122 "List of groups that gnus-registry-split-fancy-with-parent won't return.
129The group names are matched, they don't have to be fully 123The group names are matched, they don't have to be fully
130qualified. This parameter tells the Registry 'never split a 124qualified. This parameter tells the Gnus registry 'never split a
131message into a group that matches one of these, regardless of 125message into a group that matches one of these, regardless of
132references.' 126references.'
133 127
@@ -139,35 +133,23 @@ nnmairix groups are specifically excluded because they are ephemeral."
139 "Whether the registry should be installed." 133 "Whether the registry should be installed."
140 :group 'gnus-registry 134 :group 'gnus-registry
141 :type '(choice (const :tag "Never Install" nil) 135 :type '(choice (const :tag "Never Install" nil)
142 (const :tag "Always Install" t) 136 (const :tag "Always Install" t)
143 (const :tag "Ask Me" ask))) 137 (const :tag "Ask Me" ask)))
144 138
145(defvar gnus-summary-misc-menu) ;; Avoid byte compiler warning. 139(defvar gnus-summary-misc-menu) ;; Avoid byte compiler warning.
146 140
147(defvar gnus-registry-misc-menus nil) ; ugly way to keep the menus 141(defvar gnus-registry-misc-menus nil) ; ugly way to keep the menus
148
149(defcustom gnus-registry-clean-empty t
150 "Whether the empty registry entries should be deleted.
151Registry entries are considered empty when they have no groups
152and no extra data."
153 :group 'gnus-registry
154 :type 'boolean)
155
156(defcustom gnus-registry-use-long-group-names t
157 "Whether the registry should use long group names."
158 :group 'gnus-registry
159 :type 'boolean)
160 142
161(defcustom gnus-registry-max-track-groups 20 143(make-obsolete-variable 'gnus-registry-clean-empty nil "23.4")
162 "The maximum number of non-unique group matches to check for a message ID." 144(make-obsolete-variable 'gnus-registry-use-long-group-names nil "23.4")
163 :group 'gnus-registry 145(make-obsolete-variable 'gnus-registry-max-track-groups nil "23.4")
164 :type '(radio (const :format "Unlimited " nil) 146(make-obsolete-variable 'gnus-registry-entry-caching nil "23.4")
165 (integer :format "Maximum non-unique matches: %v"))) 147(make-obsolete-variable 'gnus-registry-trim-articles-without-groups nil "23.4")
166 148
167(defcustom gnus-registry-track-extra nil 149(defcustom gnus-registry-track-extra '(subject sender)
168 "Whether the registry should track extra data about a message. 150 "Whether the registry should track extra data about a message.
169The Subject and Sender (From:) headers are currently tracked this 151The Subject and Sender (From:) headers are tracked this way by
170way." 152default."
171 :group 'gnus-registry 153 :group 'gnus-registry
172 :type 154 :type
173 '(set :tag "Tracking choices" 155 '(set :tag "Tracking choices"
@@ -175,45 +157,49 @@ way."
175 (const :tag "Track by sender (From: header)" sender))) 157 (const :tag "Track by sender (From: header)" sender)))
176 158
177(defcustom gnus-registry-split-strategy nil 159(defcustom gnus-registry-split-strategy nil
178 "Whether the registry should track extra data about a message. 160 "The splitting strategy applied to the keys in `gnus-registry-track-extra'.
179The Subject and Sender (From:) headers are currently tracked this
180way."
181 :group 'gnus-registry
182 :type
183 '(choice :tag "Tracking choices"
184 (const :tag "Only use single choices, discard multiple matches" nil)
185 (const :tag "Majority of matches wins" majority)
186 (const :tag "First found wins" first)))
187 161
188(defcustom gnus-registry-entry-caching t 162Given a set of unique found groups G and counts for each element
189 "Whether the registry should cache extra information." 163of G, and a key K (typically 'sender or 'subject):
164
165When nil, if G has only one element, use it. Otherwise give up.
166This is the fastest but also least useful strategy.
167
168When 'majority, use the majority by count. So if there is a
169group with the most articles counted by K, use that. Ties are
170resolved in no particular order, simply the first one found wins.
171This is the slowest strategy but also the most accurate one.
172
173When 'first, the first element of G wins. This is fast and
174should be OK if your senders and subjects don't \"bleed\" across
175groups."
190 :group 'gnus-registry 176 :group 'gnus-registry
191 :type 'boolean) 177 :type
178 '(choice :tag "Splitting strategy"
179 (const :tag "Only use single choices, discard multiple matches" nil)
180 (const :tag "Majority of matches wins" majority)
181 (const :tag "First found wins" first)))
192 182
193(defcustom gnus-registry-minimum-subject-length 5 183(defcustom gnus-registry-minimum-subject-length 5
194 "The minimum length of a subject before it's considered trackable." 184 "The minimum length of a subject before it's considered trackable."
195 :group 'gnus-registry 185 :group 'gnus-registry
196 :type 'integer) 186 :type 'integer)
197 187
198(defcustom gnus-registry-trim-articles-without-groups t 188(defcustom gnus-registry-extra-entries-precious '(mark)
199 "Whether the registry should clean out message IDs without groups." 189 "What extra keys are precious, meaning entries with them won't get pruned.
200 :group 'gnus-registry 190By default, 'mark is included, so articles with marks are
201 :type 'boolean) 191considered precious.
202 192
203(defcustom gnus-registry-extra-entries-precious '(marks) 193Before you save the Gnus registry, it's pruned. Any entries with
204 "What extra entries are precious, meaning they won't get trimmed. 194keys in this list will not be pruned. All other entries go to
205When you save the Gnus registry, it's trimmed to be no longer 195the Bit Bucket."
206than `gnus-registry-max-entries' (which is nil by default, so no
207trimming happens). Any entries with extra data in this list (by
208default, marks are included, so articles with marks are
209considered precious) will not be trimmed."
210 :group 'gnus-registry 196 :group 'gnus-registry
211 :type '(repeat symbol)) 197 :type '(repeat symbol))
212 198
213(defcustom gnus-registry-cache-file 199(defcustom gnus-registry-cache-file
214 (nnheader-concat 200 (nnheader-concat
215 (or gnus-dribble-directory gnus-home-directory "~/") 201 (or gnus-dribble-directory gnus-home-directory "~/")
216 ".gnus.registry.eld") 202 ".gnus.registry.eioio")
217 "File where the Gnus registry will be stored." 203 "File where the Gnus registry will be stored."
218 :group 'gnus-registry 204 :group 'gnus-registry
219 :type 'file) 205 :type 'file)
@@ -222,253 +208,138 @@ considered precious) will not be trimmed."
222 "Maximum number of entries in the registry, nil for unlimited." 208 "Maximum number of entries in the registry, nil for unlimited."
223 :group 'gnus-registry 209 :group 'gnus-registry
224 :type '(radio (const :format "Unlimited " nil) 210 :type '(radio (const :format "Unlimited " nil)
225 (integer :format "Maximum number: %v"))) 211 (integer :format "Maximum number: %v")))
226
227(defun gnus-registry-track-subject-p ()
228 (memq 'subject gnus-registry-track-extra))
229 212
230(defun gnus-registry-track-sender-p () 213(defcustom gnus-registry-max-pruned-entries nil
231 (memq 'sender gnus-registry-track-extra)) 214 "Maximum number of pruned entries in the registry, nil for unlimited."
215 :group 'gnus-registry
216 :type '(radio (const :format "Unlimited " nil)
217 (integer :format "Maximum number: %v")))
218
219(defun gnus-registry-fixup-registry (db)
220 (when db
221 (oset db :precious
222 (append gnus-registry-extra-entries-precious
223 '()))
224 (oset db :max-hard
225 (or gnus-registry-max-entries
226 most-positive-fixnum))
227 (oset db :max-soft
228 (or gnus-registry-max-pruned-entries
229 most-positive-fixnum))
230 (oset db :tracked
231 (append gnus-registry-track-extra
232 '(mark group keyword))))
233 db)
234
235(defun gnus-registry-make-db (&optional file)
236 (interactive "fGnus registry persistence file: \n")
237 (gnus-registry-fixup-registry
238 (registry-db
239 "Gnus Registry"
240 :file (or file gnus-registry-cache-file)
241 ;; these parameters are set in `gnus-registry-fixup-registry'
242 :max-hard most-positive-fixnum
243 :max-soft most-positive-fixnum
244 :precious nil
245 :tracked nil)))
246
247(defvar gnus-registry-db (gnus-registry-make-db)
248 "*The article registry by Message ID. See `registry-db'")
249
250;; top-level registry data management
251(defun gnus-registry-remake-db (&optional forsure)
252 "Remake the registry database after customization.
253This is not required after changing `gnus-registry-cache-file'."
254 (interactive (list (y-or-n-p "Remake and CLEAR the Gnus registry? ")))
255 (when forsure
256 (gnus-message 1 "Remaking the Gnus registry")
257 (setq gnus-registry-db (gnus-registry-make-db))))
232 258
233(defun gnus-registry-cache-read () 259(defun gnus-registry-read ()
234 "Read the registry cache file." 260 "Read the registry cache file."
235 (interactive) 261 (interactive)
236 (let ((file gnus-registry-cache-file)) 262 (let ((file gnus-registry-cache-file))
237 (when (file-exists-p file) 263 (condition-case nil
238 (gnus-message 5 "Reading %s..." file) 264 (progn
239 (gnus-load file) 265 (gnus-message 5 "Reading Gnus registry from %s..." file)
240 (gnus-message 5 "Reading %s...done" file)))) 266 (setq gnus-registry-db (gnus-registry-fixup-registry
241 267 (eieio-persistent-read file)))
242;; FIXME: Get rid of duplicated code, cf. `gnus-save-newsrc-file' in 268 (gnus-message 5 "Reading Gnus registry from %s...done" file))
243;; `gnus-start.el'. --rsteib 269 (error
244(defun gnus-registry-cache-save () 270 (gnus-message
271 1
272 "The Gnus registry could not be loaded from %s, creating a new one"
273 file)
274 (gnus-registry-remake-db t)))))
275
276(defun gnus-registry-save (&optional file db)
245 "Save the registry cache file." 277 "Save the registry cache file."
246 (interactive) 278 (interactive)
247 (let ((file gnus-registry-cache-file)) 279 (let ((file (or file gnus-registry-cache-file))
248 (with-current-buffer (gnus-get-buffer-create " *Gnus-registry-cache*") 280 (db (or db gnus-registry-db)))
249 (make-local-variable 'version-control) 281 (gnus-message 5 "Saving Gnus registry (%d entries) to %s..."
250 (setq version-control gnus-backup-startup-file) 282 (registry-size db) file)
251 (setq buffer-file-name file) 283 (registry-prune db)
252 (setq default-directory (file-name-directory buffer-file-name)) 284 ;; TODO: call (gnus-string-remove-all-properties v) on all elements?
253 (buffer-disable-undo) 285 (eieio-persistent-save db file)
254 (erase-buffer) 286 (gnus-message 5 "Saving Gnus registry (size %d) to %s...done"
255 (gnus-message 5 "Saving %s..." file) 287 (registry-size db) file)))
256 (if gnus-save-startup-file-via-temp-buffer 288
257 (let ((coding-system-for-write gnus-ding-file-coding-system) 289;; article move/copy/spool/delete actions
258 (standard-output (current-buffer)))
259 (gnus-gnus-to-quick-newsrc-format
260 t "gnus registry startup file" 'gnus-registry-alist)
261 (gnus-registry-cache-whitespace file)
262 (save-buffer))
263 (let ((coding-system-for-write gnus-ding-file-coding-system)
264 (version-control gnus-backup-startup-file)
265 (startup-file file)
266 (working-dir (file-name-directory file))
267 working-file
268 (i -1))
269 ;; Generate the name of a non-existent file.
270 (while (progn (setq working-file
271 (format
272 (if (and (eq system-type 'ms-dos)
273 (not (gnus-long-file-names)))
274 "%s#%d.tm#" ; MSDOS limits files to 8+3
275 "%s#tmp#%d")
276 working-dir (setq i (1+ i))))
277 (file-exists-p working-file)))
278
279 (unwind-protect
280 (progn
281 (gnus-with-output-to-file working-file
282 (gnus-gnus-to-quick-newsrc-format
283 t "gnus registry startup file" 'gnus-registry-alist))
284
285 ;; These bindings will mislead the current buffer
286 ;; into thinking that it is visiting the startup
287 ;; file.
288 (let ((buffer-backed-up nil)
289 (buffer-file-name startup-file)
290 (file-precious-flag t)
291 (setmodes (file-modes startup-file)))
292 ;; Backup the current version of the startup file.
293 (backup-buffer)
294
295 ;; Replace the existing startup file with the temp file.
296 (rename-file working-file startup-file t)
297 (gnus-set-file-modes startup-file setmodes)))
298 (condition-case nil
299 (delete-file working-file)
300 (file-error nil)))))
301
302 (gnus-kill-buffer (current-buffer))
303 (gnus-message 5 "Saving %s...done" file))))
304
305;; Idea from Dan Christensen <jdc@chow.mat.jhu.edu>
306;; Save the gnus-registry file with extra line breaks.
307(defun gnus-registry-cache-whitespace (filename)
308 (gnus-message 7 "Adding whitespace to %s" filename)
309 (save-excursion
310 (goto-char (point-min))
311 (while (re-search-forward "^(\\|(\\\"" nil t)
312 (replace-match "\n\\&" t))
313 (goto-char (point-min))
314 (while (re-search-forward " $" nil t)
315 (replace-match "" t t))))
316
317(defun gnus-registry-save (&optional force)
318 (when (or gnus-registry-dirty force)
319 (let ((caching gnus-registry-entry-caching))
320 ;; turn off entry caching, so mtime doesn't get recorded
321 (setq gnus-registry-entry-caching nil)
322 ;; remove entry caches
323 (maphash
324 (lambda (key value)
325 (if (hash-table-p value)
326 (remhash key gnus-registry-hashtb)))
327 gnus-registry-hashtb)
328 ;; remove empty entries
329 (when gnus-registry-clean-empty
330 (gnus-registry-clean-empty-function))
331 ;; now trim and clean text properties from the registry appropriately
332 (setq gnus-registry-alist
333 (gnus-registry-remove-alist-text-properties
334 (gnus-registry-trim
335 (gnus-hashtable-to-alist
336 gnus-registry-hashtb))))
337 ;; really save
338 (gnus-registry-cache-save)
339 (setq gnus-registry-entry-caching caching)
340 (setq gnus-registry-dirty nil))))
341
342(defun gnus-registry-clean-empty-function ()
343 "Remove all empty entries from the registry. Returns count thereof."
344 (let ((count 0))
345
346 (maphash
347 (lambda (key value)
348 (when (stringp key)
349 (dolist (group (gnus-registry-fetch-groups key))
350 (when (gnus-parameter-registry-ignore group)
351 (gnus-message
352 10
353 "gnus-registry: deleted ignored group %s from key %s"
354 group key)
355 (gnus-registry-delete-group key group)))
356
357 (unless (gnus-registry-group-count key)
358 (gnus-registry-delete-id key))
359
360 (unless (or
361 (gnus-registry-fetch-group key)
362 ;; TODO: look for specific extra data here!
363 ;; in this example, we look for 'label
364 (gnus-registry-fetch-extra key 'label))
365 (incf count)
366 (gnus-registry-delete-id key))
367
368 (unless (stringp key)
369 (gnus-message
370 10
371 "gnus-registry key %s was not a string, removing"
372 key)
373 (gnus-registry-delete-id key))))
374
375 gnus-registry-hashtb)
376 count))
377
378(defun gnus-registry-read ()
379 (gnus-registry-cache-read)
380 (setq gnus-registry-hashtb (gnus-alist-to-hashtable gnus-registry-alist))
381 (setq gnus-registry-dirty nil))
382
383(defun gnus-registry-remove-alist-text-properties (v)
384 "Remove text properties from all strings in alist."
385 (if (stringp v)
386 (gnus-string-remove-all-properties v)
387 (if (and (listp v) (listp (cdr v)))
388 (mapcar 'gnus-registry-remove-alist-text-properties v)
389 (if (and (listp v) (stringp (cdr v)))
390 (cons (gnus-registry-remove-alist-text-properties (car v))
391 (gnus-registry-remove-alist-text-properties (cdr v)))
392 v))))
393
394(defun gnus-registry-trim (alist)
395 "Trim alist to size, using gnus-registry-max-entries.
396Any entries with extra data (marks, currently) are left alone."
397 (if (null gnus-registry-max-entries)
398 alist ; just return the alist
399 ;; else, when given max-entries, trim the alist
400 (let* ((timehash (make-hash-table
401 :size 20000
402 :test 'equal))
403 (precious (make-hash-table
404 :size 20000
405 :test 'equal))
406 (trim-length (- (length alist) gnus-registry-max-entries))
407 (trim-length (if (natnump trim-length) trim-length 0))
408 precious-list junk-list)
409 (maphash
410 (lambda (key value)
411 (let ((extra (gnus-registry-fetch-extra key)))
412 (dolist (item gnus-registry-extra-entries-precious)
413 (dolist (e extra)
414 (when (equal (nth 0 e) item)
415 (puthash key t precious)
416 (return))))
417 (puthash key (gnus-registry-fetch-extra key 'mtime) timehash)))
418 gnus-registry-hashtb)
419
420 (dolist (item alist)
421 (let ((key (nth 0 item)))
422 (if (gethash key precious)
423 (push item precious-list)
424 (push item junk-list))))
425
426 (sort
427 junk-list
428 (lambda (a b)
429 (let ((t1 (or (cdr (gethash (car a) timehash))
430 '(0 0 0)))
431 (t2 (or (cdr (gethash (car b) timehash))
432 '(0 0 0))))
433 (time-less-p t1 t2))))
434
435 ;; we use the return value of this setq, which is the trimmed alist
436 (setq alist (append precious-list
437 (nthcdr trim-length junk-list))))))
438
439(defun gnus-registry-action (action data-header from &optional to method) 290(defun gnus-registry-action (action data-header from &optional to method)
440 (let* ((id (mail-header-id data-header)) 291 (let* ((id (mail-header-id data-header))
441 (subject (gnus-string-remove-all-properties 292 (subject (gnus-string-remove-all-properties
442 (gnus-registry-simplify-subject 293 (gnus-registry-simplify-subject
443 (mail-header-subject data-header)))) 294 (mail-header-subject data-header))))
444 (sender (gnus-string-remove-all-properties 295 (sender (gnus-string-remove-all-properties
445 (mail-header-from data-header))) 296 (mail-header-from data-header)))
446 (from (gnus-group-guess-full-name-from-command-method from)) 297 (from (gnus-group-guess-full-name-from-command-method from))
447 (to (if to (gnus-group-guess-full-name-from-command-method to) nil)) 298 (to (if to (gnus-group-guess-full-name-from-command-method to) nil))
448 (to-name (if to to "the Bit Bucket")) 299 (to-name (if to to "the Bit Bucket")))
449 (old-entry (gethash id gnus-registry-hashtb))) 300 (gnus-message 7 "Gnus registry: article %s %s from %s to %s"
450 (gnus-message 7 "Registry: article %s %s from %s to %s" 301 id (if method "respooling" "going") from to)
451 id 302
452 (if method "respooling" "going") 303 (gnus-registry-handle-action
453 from 304 id
454 to) 305 ;; unless copying, remove the old "from" group
455 306 (if (not (equal 'copy action)) from nil)
456 ;; All except copy will need a delete 307 to subject sender)))
457 (gnus-registry-delete-group id from)
458
459 (when (equal 'copy action)
460 (gnus-registry-add-group id from subject sender)) ; undo the delete
461
462 (gnus-registry-add-group id to subject sender)))
463 308
464(defun gnus-registry-spool-action (id group &optional subject sender) 309(defun gnus-registry-spool-action (id group &optional subject sender)
465 (let ((group (gnus-group-guess-full-name-from-command-method group))) 310 (let ((to (gnus-group-guess-full-name-from-command-method group)))
466 (when (and (stringp id) (string-match "\r$" id)) 311 (when (and (stringp id) (string-match "\r$" id))
467 (setq id (substring id 0 -1))) 312 (setq id (substring id 0 -1)))
468 (gnus-message 7 "Registry: article %s spooled to %s" 313 (gnus-message 7 "Gnus registry: article %s spooled to %s"
469 id 314 id
470 group) 315 to)
471 (gnus-registry-add-group id group subject sender))) 316 (gnus-registry-handle-action id nil to subject sender)))
317
318(defun gnus-registry-handle-action (id from to subject sender)
319 (let ((db gnus-registry-db)
320 ;; safe if not found
321 (entry (gnus-registry-get-or-make-entry id)))
322
323 ;; this could be done by calling `gnus-registry-set-id-key'
324 ;; several times but it's better to bunch the transactions
325 ;; together
326
327 (registry-delete db (list id) nil)
328 (when from
329 (setq entry (cons (delete from (assoc 'group entry))
330 (assq-delete-all 'group entry))))
331
332 (dolist (kv `((group ,to) (sender ,sender) (subject ,subject)))
333 (when (second kv)
334 (let ((new (or (assq (first kv) entry)
335 (list (first kv)))))
336 (add-to-list 'new (second kv) t)
337 (setq entry (cons new
338 (assq-delete-all (first kv) entry))))))
339 (gnus-message 10 "Gnus registry: new entry for %s is %S"
340 id
341 entry)
342 (registry-insert db id entry)))
472 343
473;; Function for nn{mail|imap}-split-fancy: look up all references in 344;; Function for nn{mail|imap}-split-fancy: look up all references in
474;; the cache and if a match is found, return that group. 345;; the cache and if a match is found, return that group.
@@ -490,117 +361,118 @@ that group.
490 361
491See the Info node `(gnus)Fancy Mail Splitting' for more details." 362See the Info node `(gnus)Fancy Mail Splitting' for more details."
492 (let* ((refstr (or (message-fetch-field "references") "")) ; guaranteed 363 (let* ((refstr (or (message-fetch-field "references") "")) ; guaranteed
493 (reply-to (message-fetch-field "in-reply-to")) ; may be nil 364 (reply-to (message-fetch-field "in-reply-to")) ; may be nil
494 ;; now, if reply-to is valid, append it to the References 365 ;; now, if reply-to is valid, append it to the References
495 (refstr (if reply-to 366 (refstr (if reply-to
496 (concat refstr " " reply-to) 367 (concat refstr " " reply-to)
497 refstr)) 368 refstr))
498 ;; these may not be used, but the code is cleaner having them up here 369 (references (and refstr (gnus-extract-references refstr)))
499 (sender (gnus-string-remove-all-properties 370 ;; these may not be used, but the code is cleaner having them up here
500 (message-fetch-field "from"))) 371 (sender (gnus-string-remove-all-properties
501 (subject (gnus-string-remove-all-properties 372 (message-fetch-field "from")))
502 (gnus-registry-simplify-subject 373 (subject (gnus-string-remove-all-properties
503 (message-fetch-field "subject")))) 374 (gnus-registry-simplify-subject
504 375 (message-fetch-field "subject"))))
505 (nnmail-split-fancy-with-parent-ignore-groups 376
506 (if (listp nnmail-split-fancy-with-parent-ignore-groups) 377 (nnmail-split-fancy-with-parent-ignore-groups
507 nnmail-split-fancy-with-parent-ignore-groups 378 (if (listp nnmail-split-fancy-with-parent-ignore-groups)
508 (list nnmail-split-fancy-with-parent-ignore-groups))) 379 nnmail-split-fancy-with-parent-ignore-groups
509 (log-agent "gnus-registry-split-fancy-with-parent") 380 (list nnmail-split-fancy-with-parent-ignore-groups))))
510 found found-full) 381 (gnus-registry--split-fancy-with-parent-internal
511 382 :references references
383 :refstr refstr
384 :sender sender
385 :subject subject
386 :log-agent "Gnus registry fancy splitting with parent")))
387
388(defun* gnus-registry--split-fancy-with-parent-internal
389 (&rest spec
390 &key references refstr sender subject log-agent
391 &allow-other-keys)
392 (gnus-message
393 10
394 "gnus-registry--split-fancy-with-parent-internal: %S" spec)
395 (let ((db gnus-registry-db)
396 found)
512 ;; this is a big if-else statement. it uses 397 ;; this is a big if-else statement. it uses
513 ;; gnus-registry-post-process-groups to filter the results after 398 ;; gnus-registry-post-process-groups to filter the results after
514 ;; every step. 399 ;; every step.
515 (cond 400 (cond
516 ;; the references string must be valid and parse to valid references 401 ;; the references string must be valid and parse to valid references
517 ((and refstr (gnus-extract-references refstr)) 402 (references
518 (dolist (reference (nreverse (gnus-extract-references refstr))) 403 (dolist (reference (nreverse references))
519 (gnus-message 404 (gnus-message
520 9 405 9
521 "%s is looking for matches for reference %s from [%s]" 406 "%s is looking for matches for reference %s from [%s]"
522 log-agent reference refstr) 407 log-agent reference refstr)
523 (dolist (group (gnus-registry-fetch-groups 408 (setq found
524 reference 409 (loop for group in (gnus-registry-get-id-key reference 'group)
525 gnus-registry-max-track-groups)) 410 when (gnus-registry-follow-group-p group)
526 (when (and group (gnus-registry-follow-group-p group)) 411 do (gnus-message
527 (gnus-message 412 7
528 7 413 "%s traced the reference %s from [%s] to group %s"
529 "%s traced the reference %s from [%s] to group %s" 414 log-agent reference refstr group)
530 log-agent reference refstr group) 415 collect group)))
531 (push group found))))
532 ;; filter the found groups and return them 416 ;; filter the found groups and return them
533 ;; the found groups are the full groups 417 ;; the found groups are the full groups
534 (setq found (gnus-registry-post-process-groups 418 (setq found (gnus-registry-post-process-groups
535 "references" refstr found found))) 419 "references" refstr found)))
536 420
537 ;; else: there were no matches, now try the extra tracking by sender 421 ;; else: there were no matches, try the extra tracking by sender
538 ((and (gnus-registry-track-sender-p) 422 ((and (memq 'sender gnus-registry-track-extra)
539 sender 423 sender
540 (not (equal (gnus-extract-address-component-email sender) 424 (gnus-grep-in-list
541 user-mail-address))) 425 sender
542 (maphash 426 gnus-registry-unfollowed-addresses))
543 (lambda (key value) 427 (let ((groups (apply
544 ;; don't use more than gnus-registry-max-track-groups 428 'append
545 (when (< (length found-full) gnus-registry-max-track-groups) 429 (mapcar
546 (let ((this-sender 430 (lambda (reference)
547 (cdr (gnus-registry-fetch-extra key 'sender))) 431 (gnus-registry-get-id-key reference 'group))
548 matches) 432 (registry-lookup-secondary-value db 'sender sender)))))
549 (when (and this-sender 433 (setq found
550 (equal sender this-sender)) 434 (loop for group in groups
551 (let ((groups (gnus-registry-fetch-groups 435 when (gnus-registry-follow-group-p group)
552 key 436 do (gnus-message
553 gnus-registry-max-track-groups))) 437 ;; raise level of messaging if gnus-registry-track-extra
554 (dolist (group groups) 438 (if gnus-registry-track-extra 7 9)
555 (when (and group (gnus-registry-follow-group-p group)) 439 "%s (extra tracking) traced sender '%s' to groups %s"
556 (push group found-full) 440 log-agent sender found)
557 (setq found (append (list group) (delete group found)))))) 441 collect group)))
558 (push key matches) 442
559 (gnus-message
560 ;; raise level of messaging if gnus-registry-track-extra
561 (if gnus-registry-track-extra 7 9)
562 "%s (extra tracking) traced sender %s to groups %s (keys %s)"
563 log-agent sender found matches)))))
564 gnus-registry-hashtb)
565 ;; filter the found groups and return them 443 ;; filter the found groups and return them
566 ;; the found groups are NOT the full groups 444 ;; the found groups are NOT the full groups
567 (setq found (gnus-registry-post-process-groups 445 (setq found (gnus-registry-post-process-groups
568 "sender" sender found found-full))) 446 "sender" sender found)))
569 447
570 ;; else: there were no matches, now try the extra tracking by subject 448 ;; else: there were no matches, now try the extra tracking by subject
571 ((and (gnus-registry-track-subject-p) 449 ((and (memq 'subject gnus-registry-track-extra)
572 subject 450 subject
573 (< gnus-registry-minimum-subject-length (length subject))) 451 (< gnus-registry-minimum-subject-length (length subject)))
574 (maphash 452 (let ((groups (apply
575 (lambda (key value) 453 'append
576 (let ((this-subject (cdr 454 (mapcar
577 (gnus-registry-fetch-extra key 'subject))) 455 (lambda (reference)
578 matches) 456 (gnus-registry-get-id-key reference 'group))
579 (when (and this-subject 457 (registry-lookup-secondary-value db 'subject subject)))))
580 (equal subject this-subject)) 458 (setq found
581 (let ((groups (gnus-registry-fetch-groups 459 (loop for group in groups
582 key 460 when (gnus-registry-follow-group-p group)
583 gnus-registry-max-track-groups))) 461 do (gnus-message
584 (dolist (group groups) 462 ;; raise level of messaging if gnus-registry-track-extra
585 (when (and group (gnus-registry-follow-group-p group)) 463 (if gnus-registry-track-extra 7 9)
586 (push group found-full) 464 "%s (extra tracking) traced subject '%s' to groups %s"
587 (setq found (append (list group) (delete group found)))))) 465 log-agent subject found)
588 (push key matches) 466 collect group))
589 (gnus-message
590 ;; raise level of messaging if gnus-registry-track-extra
591 (if gnus-registry-track-extra 7 9)
592 "%s (extra tracking) traced subject %s to groups %s (keys %s)"
593 log-agent subject found matches))))
594 gnus-registry-hashtb)
595 ;; filter the found groups and return them 467 ;; filter the found groups and return them
596 ;; the found groups are NOT the full groups 468 ;; the found groups are NOT the full groups
597 (setq found (gnus-registry-post-process-groups 469 (setq found (gnus-registry-post-process-groups
598 "subject" subject found found-full)))) 470 "subject" subject found)))))
599 ;; after the (cond) we extract the actual value safely 471 ;; after the (cond) we extract the actual value safely
600 (car-safe found))) 472 (car-safe found)))
601 473
602(defun gnus-registry-post-process-groups (mode key groups groups-full) 474(defun gnus-registry-post-process-groups (mode key groups)
603 "Modifies GROUPS found by MODE for KEY to determine which ones to follow. 475 "Inspects GROUPS found by MODE for KEY to determine which ones to follow.
604 476
605MODE can be 'subject' or 'sender' for example. The KEY is the 477MODE can be 'subject' or 'sender' for example. The KEY is the
606value by which MODE was searched. 478value by which MODE was searched.
@@ -609,121 +481,126 @@ Transforms each group name to the equivalent short name.
609 481
610Checks if the current Gnus method (from `gnus-command-method' or 482Checks if the current Gnus method (from `gnus-command-method' or
611from `gnus-newsgroup-name') is the same as the group's method. 483from `gnus-newsgroup-name') is the same as the group's method.
612This is not possible if gnus-registry-use-long-group-names is 484Foreign methods are not supported so they are rejected.
613false. Foreign methods are not supported so they are rejected.
614 485
615Reduces the list to a single group, or complains if that's not 486Reduces the list to a single group, or complains if that's not
616possible. Uses `gnus-registry-split-strategy' and GROUPS-FULL if 487possible. Uses `gnus-registry-split-strategy'."
617necessary."
618 (let ((log-agent "gnus-registry-post-process-group") 488 (let ((log-agent "gnus-registry-post-process-group")
619 out) 489 out)
620 490
621 ;; the strategy can be 'first, 'majority, or nil 491 ;; the strategy can be nil, in which case groups is nil
622 (when (eq gnus-registry-split-strategy 'first) 492 (setq groups
623 (when groups 493 (case gnus-registry-split-strategy
624 (setq groups (list (car-safe groups))))) 494 ;; first strategy
625 495 ((first)
626 (when (eq gnus-registry-split-strategy 'majority) 496 (and groups (list (car-safe groups))))
627 (let ((freq (make-hash-table 497
628 :size 256 498 ((majority)
629 :test 'equal))) 499 (let ((freq (make-hash-table
630 (mapc (lambda(x) (puthash x (1+ (gethash x freq 0)) freq)) groups-full) 500 :size 256
631 (setq groups (list (car-safe 501 :test 'equal)))
632 (sort 502 (mapc (lambda (x) (puthash x (1+ (gethash x freq 0)) freq))
633 groups 503 groups)
634 (lambda (a b) 504 (list (car-safe
635 (> (gethash a freq 0) 505 (sort groups (lambda (a b)
636 (gethash b freq 0))))))))) 506 (> (gethash a freq 0)
637 507 (gethash b freq 0))))))))))
638 (if gnus-registry-use-long-group-names 508
639 (dolist (group groups) 509 (dolist (group groups)
640 (let ((m1 (gnus-find-method-for-group group)) 510 (let ((m1 (gnus-find-method-for-group group))
641 (m2 (or gnus-command-method 511 (m2 (or gnus-command-method
642 (gnus-find-method-for-group gnus-newsgroup-name))) 512 (gnus-find-method-for-group gnus-newsgroup-name)))
643 (short-name (gnus-group-short-name group))) 513 (short-name (gnus-group-short-name group)))
644 (if (gnus-methods-equal-p m1 m2) 514 (if (gnus-methods-equal-p m1 m2)
645 (progn 515 (progn
646 ;; this is REALLY just for debugging 516 ;; this is REALLY just for debugging
647 (gnus-message 517 (gnus-message
648 10 518 10
649 "%s stripped group %s to %s" 519 "%s stripped group %s to %s"
650 log-agent group short-name) 520 log-agent group short-name)
651 (unless (member short-name out) 521 (add-to-list 'out short-name))
652 (push short-name out))) 522 ;; else...
653 ;; else... 523 (gnus-message
654 (gnus-message 524 7
655 7 525 "%s ignored foreign group %s"
656 "%s ignored foreign group %s" 526 log-agent group))))
657 log-agent group)))) 527
658 (setq out groups)) 528 ;; is there just one group?
659 (when (cdr-safe out) 529 (cond
660 (gnus-message 530 ((= (length out) 1) out)
661 5 531 ((null out)
662 "%s: too many extra matches (%s) for %s %s. Returning none." 532 (gnus-message
663 log-agent out mode key) 533 5
664 (setq out nil)) 534 "%s: no matches for %s %s."
665 out)) 535 log-agent out mode key)
536 nil)
537 (t (gnus-message
538 5
539 "%s: too many extra matches (%s) for %s %s. Returning none."
540 log-agent out mode key)
541 nil))))
666 542
667(defun gnus-registry-follow-group-p (group) 543(defun gnus-registry-follow-group-p (group)
668 "Determines if a group name should be followed. 544 "Determines if a group name should be followed.
669Consults `gnus-registry-unfollowed-groups' and 545Consults `gnus-registry-unfollowed-groups' and
670`nnmail-split-fancy-with-parent-ignore-groups'." 546`nnmail-split-fancy-with-parent-ignore-groups'."
671 (not (or (gnus-grep-in-list 547 (and group
672 group 548 (not (or (gnus-grep-in-list
673 gnus-registry-unfollowed-groups) 549 group
674 (gnus-grep-in-list 550 gnus-registry-unfollowed-groups)
675 group 551 (gnus-grep-in-list
676 nnmail-split-fancy-with-parent-ignore-groups)))) 552 group
553 nnmail-split-fancy-with-parent-ignore-groups)))))
677 554
678(defun gnus-registry-wash-for-keywords (&optional force) 555(defun gnus-registry-wash-for-keywords (&optional force)
556 "Get the keywords of the current article.
557Overrides existing keywords with FORCE set non-nil."
679 (interactive) 558 (interactive)
680 (let ((id (gnus-registry-fetch-message-id-fast gnus-current-article)) 559 (let ((id (gnus-registry-fetch-message-id-fast gnus-current-article))
681 word words) 560 word words)
682 (if (or (not (gnus-registry-fetch-extra id 'keywords)) 561 (if (or (not (gnus-registry-get-id-key id 'keyword))
683 force) 562 force)
684 (with-current-buffer gnus-article-buffer 563 (with-current-buffer gnus-article-buffer
685 (article-goto-body) 564 (article-goto-body)
686 (save-window-excursion 565 (save-window-excursion
687 (save-restriction 566 (save-restriction
688 (narrow-to-region (point) (point-max)) 567 (narrow-to-region (point) (point-max))
689 (with-syntax-table gnus-adaptive-word-syntax-table 568 (with-syntax-table gnus-adaptive-word-syntax-table
690 (while (re-search-forward "\\b\\w+\\b" nil t) 569 (while (re-search-forward "\\b\\w+\\b" nil t)
691 (setq word (gnus-registry-remove-alist-text-properties 570 (setq word (gnus-string-remove-all-properties
692 (downcase (buffer-substring 571 (downcase (buffer-substring
693 (match-beginning 0) (match-end 0))))) 572 (match-beginning 0) (match-end 0)))))
694 (if (> (length word) 3) 573 (if (> (length word) 2)
695 (push word words)))))) 574 (push word words))))))
696 (gnus-registry-store-extra-entry id 'keywords words))))) 575 (gnus-registry-set-id-key id 'keyword words)))))
576
577(defun gnus-registry-keywords ()
578 (let ((table (registry-lookup-secondary gnus-registry-db 'keyword)))
579 (when table (maphash (lambda (k v) k) table))))
697 580
698(defun gnus-registry-find-keywords (keyword) 581(defun gnus-registry-find-keywords (keyword)
699 (interactive "skeyword: ") 582 (interactive (list
700 (let (articles) 583 (completing-read "Keyword: " (gnus-registry-keywords) nil t)))
701 (maphash 584 (registry-lookup-secondary-value gnus-registry-db 'keyword keyword))
702 (lambda (key value)
703 (when (member keyword
704 (cdr-safe (gnus-registry-fetch-extra key 'keywords)))
705 (push key articles)))
706 gnus-registry-hashtb)
707 articles))
708 585
709(defun gnus-registry-register-message-ids () 586(defun gnus-registry-register-message-ids ()
710 "Register the Message-ID of every article in the group" 587 "Register the Message-ID of every article in the group"
711 (unless (gnus-parameter-registry-ignore gnus-newsgroup-name) 588 (unless (gnus-parameter-registry-ignore gnus-newsgroup-name)
712 (dolist (article gnus-newsgroup-articles) 589 (dolist (article gnus-newsgroup-articles)
713 (let ((id (gnus-registry-fetch-message-id-fast article))) 590 (let* ((id (gnus-registry-fetch-message-id-fast article))
714 (unless (member gnus-newsgroup-name (gnus-registry-fetch-groups id)) 591 (groups (gnus-registry-get-id-key id 'group)))
715 (gnus-message 9 "Registry: Registering article %d with group %s" 592 (unless (member gnus-newsgroup-name groups)
716 article gnus-newsgroup-name) 593 (gnus-message 9 "Registry: Registering article %d with group %s"
717 (gnus-registry-add-group 594 article gnus-newsgroup-name)
718 id 595 (gnus-registry-handle-action id nil gnus-newsgroup-name
719 gnus-newsgroup-name 596 (gnus-registry-fetch-simplified-message-subject-fast article)
720 (gnus-registry-fetch-simplified-message-subject-fast article) 597 (gnus-registry-fetch-sender-fast article)))))))
721 (gnus-registry-fetch-sender-fast article))))))) 598
722 599;; message field fetchers
723(defun gnus-registry-fetch-message-id-fast (article) 600(defun gnus-registry-fetch-message-id-fast (article)
724 "Fetch the Message-ID quickly, using the internal gnus-data-list function" 601 "Fetch the Message-ID quickly, using the internal gnus-data-list function"
725 (if (and (numberp article) 602 (if (and (numberp article)
726 (assoc article (gnus-data-list nil))) 603 (assoc article (gnus-data-list nil)))
727 (mail-header-id (gnus-data-header (assoc article (gnus-data-list nil)))) 604 (mail-header-id (gnus-data-header (assoc article (gnus-data-list nil))))
728 nil)) 605 nil))
729 606
@@ -735,32 +612,33 @@ Consults `gnus-registry-unfollowed-groups' and
735(defun gnus-registry-fetch-simplified-message-subject-fast (article) 612(defun gnus-registry-fetch-simplified-message-subject-fast (article)
736 "Fetch the Subject quickly, using the internal gnus-data-list function" 613 "Fetch the Subject quickly, using the internal gnus-data-list function"
737 (if (and (numberp article) 614 (if (and (numberp article)
738 (assoc article (gnus-data-list nil))) 615 (assoc article (gnus-data-list nil)))
739 (gnus-string-remove-all-properties 616 (gnus-string-remove-all-properties
740 (gnus-registry-simplify-subject 617 (gnus-registry-simplify-subject
741 (mail-header-subject (gnus-data-header 618 (mail-header-subject (gnus-data-header
742 (assoc article (gnus-data-list nil)))))) 619 (assoc article (gnus-data-list nil))))))
743 nil)) 620 nil))
744 621
745(defun gnus-registry-fetch-sender-fast (article) 622(defun gnus-registry-fetch-sender-fast (article)
746 "Fetch the Sender quickly, using the internal gnus-data-list function" 623 "Fetch the Sender quickly, using the internal gnus-data-list function"
747 (if (and (numberp article) 624 (if (and (numberp article)
748 (assoc article (gnus-data-list nil))) 625 (assoc article (gnus-data-list nil)))
749 (gnus-string-remove-all-properties 626 (gnus-string-remove-all-properties
750 (mail-header-from (gnus-data-header 627 (mail-header-from (gnus-data-header
751 (assoc article (gnus-data-list nil))))) 628 (assoc article (gnus-data-list nil)))))
752 nil)) 629 nil))
753 630
631;; registry marks glue
754(defun gnus-registry-do-marks (type function) 632(defun gnus-registry-do-marks (type function)
755 "For each known mark, call FUNCTION for each cell of type TYPE. 633 "For each known mark, call FUNCTION for each cell of type TYPE.
756 634
757FUNCTION should take two parameters, a mark symbol and the cell value." 635FUNCTION should take two parameters, a mark symbol and the cell value."
758 (dolist (mark-info gnus-registry-marks) 636 (dolist (mark-info gnus-registry-marks)
759 (let* ((mark (car-safe mark-info)) 637 (let* ((mark (car-safe mark-info))
760 (data (cdr-safe mark-info)) 638 (data (cdr-safe mark-info))
761 (cell-data (plist-get data type))) 639 (cell-data (plist-get data type)))
762 (when cell-data 640 (when cell-data
763 (funcall function mark cell-data))))) 641 (funcall function mark cell-data)))))
764 642
765;;; this is ugly code, but I don't know how to do it better 643;;; this is ugly code, but I don't know how to do it better
766(defun gnus-registry-install-shortcuts () 644(defun gnus-registry-install-shortcuts ()
@@ -772,7 +650,7 @@ Uses `gnus-registry-marks' to find what shortcuts to install."
772 :char 650 :char
773 (lambda (mark data) 651 (lambda (mark data)
774 (let ((function-format 652 (let ((function-format
775 (format "gnus-registry-%%s-article-%s-mark" mark))) 653 (format "gnus-registry-%%s-article-%s-mark" mark)))
776 654
777;;; The following generates these functions: 655;;; The following generates these functions:
778;;; (defun gnus-registry-set-article-Important-mark (&rest articles) 656;;; (defun gnus-registry-set-article-Important-mark (&rest articles)
@@ -784,84 +662,84 @@ Uses `gnus-registry-marks' to find what shortcuts to install."
784;;; (interactive (gnus-summary-work-articles current-prefix-arg)) 662;;; (interactive (gnus-summary-work-articles current-prefix-arg))
785;;; (gnus-registry-set-article-mark-internal 'Important articles t t)) 663;;; (gnus-registry-set-article-mark-internal 'Important articles t t))
786 664
787 (dolist (remove '(t nil)) 665 (dolist (remove '(t nil))
788 (let* ((variant-name (if remove "remove" "set")) 666 (let* ((variant-name (if remove "remove" "set"))
789 (function-name (format function-format variant-name)) 667 (function-name (format function-format variant-name))
790 (shortcut (format "%c" data)) 668 (shortcut (format "%c" data))
791 (shortcut (if remove (upcase shortcut) shortcut))) 669 (shortcut (if remove (upcase shortcut) shortcut)))
792 (unintern function-name obarray) 670 (unintern function-name obarray)
793 (eval 671 (eval
794 `(defun 672 `(defun
795 ;; function name 673 ;; function name
796 ,(intern function-name) 674 ,(intern function-name)
797 ;; parameter definition 675 ;; parameter definition
798 (&rest articles) 676 (&rest articles)
799 ;; documentation 677 ;; documentation
800 ,(format 678 ,(format
801 "%s the %s mark over process-marked ARTICLES." 679 "%s the %s mark over process-marked ARTICLES."
802 (upcase-initials variant-name) 680 (upcase-initials variant-name)
803 mark) 681 mark)
804 ;; interactive definition 682 ;; interactive definition
805 (interactive 683 (interactive
806 (gnus-summary-work-articles current-prefix-arg)) 684 (gnus-summary-work-articles current-prefix-arg))
807 ;; actual code 685 ;; actual code
808 686
809 ;; if this is called and the user doesn't want the 687 ;; if this is called and the user doesn't want the
810 ;; registry enabled, we'll ask anyhow 688 ;; registry enabled, we'll ask anyhow
811 (when (eq gnus-registry-install nil) 689 (when (eq gnus-registry-install nil)
812 (setq gnus-registry-install 'ask)) 690 (setq gnus-registry-install 'ask))
813 691
814 ;; now the user is asked if gnus-registry-install is 'ask 692 ;; now the user is asked if gnus-registry-install is 'ask
815 (when (gnus-registry-install-p) 693 (when (gnus-registry-install-p)
816 (gnus-registry-set-article-mark-internal 694 (gnus-registry-set-article-mark-internal
817 ;; all this just to get the mark, I must be doing it wrong 695 ;; all this just to get the mark, I must be doing it wrong
818 (intern ,(symbol-name mark)) 696 (intern ,(symbol-name mark))
819 articles ,remove t) 697 articles ,remove t)
820 (gnus-message 698 (gnus-message
821 9 699 9
822 "Applying mark %s to %d articles" 700 "Applying mark %s to %d articles"
823 ,(symbol-name mark) (length articles)) 701 ,(symbol-name mark) (length articles))
824 (dolist (article articles) 702 (dolist (article articles)
825 (gnus-summary-update-article 703 (gnus-summary-update-article
826 article 704 article
827 (assoc article (gnus-data-list nil))))))) 705 (assoc article (gnus-data-list nil)))))))
828 (push (intern function-name) keys-plist) 706 (push (intern function-name) keys-plist)
829 (push shortcut keys-plist) 707 (push shortcut keys-plist)
830 (push (vector (format "%s %s" 708 (push (vector (format "%s %s"
831 (upcase-initials variant-name) 709 (upcase-initials variant-name)
832 (symbol-name mark)) 710 (symbol-name mark))
833 (intern function-name) t) 711 (intern function-name) t)
834 gnus-registry-misc-menus) 712 gnus-registry-misc-menus)
835 (gnus-message 713 (gnus-message
836 9 714 9
837 "Defined mark handling function %s" 715 "Defined mark handling function %s"
838 function-name)))))) 716 function-name))))))
839 (gnus-define-keys-1 717 (gnus-define-keys-1
840 '(gnus-registry-mark-map "M" gnus-summary-mark-map) 718 '(gnus-registry-mark-map "M" gnus-summary-mark-map)
841 keys-plist) 719 keys-plist)
842 (add-hook 'gnus-summary-menu-hook 720 (add-hook 'gnus-summary-menu-hook
843 (lambda () 721 (lambda ()
844 (easy-menu-add-item 722 (easy-menu-add-item
845 gnus-summary-misc-menu 723 gnus-summary-misc-menu
846 nil 724 nil
847 (cons "Registry Marks" gnus-registry-misc-menus)))))) 725 (cons "Registry Marks" gnus-registry-misc-menus))))))
848 726
849;;; use like this: 727;;; use like this:
850;;; (defalias 'gnus-user-format-function-M 728;;; (defalias 'gnus-user-format-function-M
851;;; 'gnus-registry-user-format-function-M) 729;;; 'gnus-registry-user-format-function-M)
852(defun gnus-registry-user-format-function-M (headers) 730(defun gnus-registry-user-format-function-M (headers)
853 (let* ((id (mail-header-message-id headers)) 731 (let* ((id (mail-header-message-id headers))
854 (marks (when id (gnus-registry-fetch-extra-marks id)))) 732 (marks (when id (gnus-registry-get-id-key id 'mark))))
855 (apply 'concat (mapcar (lambda(mark) 733 (apply 'concat (mapcar (lambda (mark)
856 (let ((c 734 (let ((c
857 (plist-get 735 (plist-get
858 (cdr-safe 736 (cdr-safe
859 (assoc mark gnus-registry-marks)) 737 (assoc mark gnus-registry-marks))
860 :char))) 738 :char)))
861 (if c 739 (if c
862 (list c) 740 (list c)
863 nil))) 741 nil)))
864 marks)))) 742 marks))))
865 743
866(defun gnus-registry-read-mark () 744(defun gnus-registry-read-mark ()
867 "Read a mark name from the user with completion." 745 "Read a mark name from the user with completion."
@@ -869,270 +747,144 @@ Uses `gnus-registry-marks' to find what shortcuts to install."
869 "Label" 747 "Label"
870 (mapcar 'symbol-name (mapcar 'car gnus-registry-marks)) 748 (mapcar 'symbol-name (mapcar 'car gnus-registry-marks))
871 nil nil nil 749 nil nil nil
872 (symbol-name gnus-registry-default-mark)))) 750 (symbol-name gnus-registry-default-mark))))
873 (when (stringp mark) 751 (when (stringp mark)
874 (intern mark)))) 752 (intern mark))))
875 753
876(defun gnus-registry-set-article-mark (&rest articles) 754(defun gnus-registry-set-article-mark (&rest articles)
877 "Apply a mark to process-marked ARTICLES." 755 "Apply a mark to process-marked ARTICLES."
878 (interactive (gnus-summary-work-articles current-prefix-arg)) 756 (interactive (gnus-summary-work-articles current-prefix-arg))
879 (gnus-registry-set-article-mark-internal (gnus-registry-read-mark) articles nil t)) 757 (gnus-registry-set-article-mark-internal (gnus-registry-read-mark)
758 articles nil t))
880 759
881(defun gnus-registry-remove-article-mark (&rest articles) 760(defun gnus-registry-remove-article-mark (&rest articles)
882 "Remove a mark from process-marked ARTICLES." 761 "Remove a mark from process-marked ARTICLES."
883 (interactive (gnus-summary-work-articles current-prefix-arg)) 762 (interactive (gnus-summary-work-articles current-prefix-arg))
884 (gnus-registry-set-article-mark-internal (gnus-registry-read-mark) articles t t)) 763 (gnus-registry-set-article-mark-internal (gnus-registry-read-mark)
885 764 articles t t))
886(defun gnus-registry-set-article-mark-internal (mark articles &optional remove show-message) 765
887 "Apply a mark to a list of ARTICLES." 766(defun gnus-registry-set-article-mark-internal (mark
767 articles
768 &optional remove
769 show-message)
770 "Apply or remove MARK across a list of ARTICLES."
888 (let ((article-id-list 771 (let ((article-id-list
889 (mapcar 'gnus-registry-fetch-message-id-fast articles))) 772 (mapcar 'gnus-registry-fetch-message-id-fast articles)))
890 (dolist (id article-id-list) 773 (dolist (id article-id-list)
891 (let* ( 774 (let* ((marks (delq mark (gnus-registry-get-id-key id 'mark)))
892 ;; all the marks for this article without the mark of 775 (marks (if remove marks (cons mark marks))))
893 ;; interest 776 (when show-message
894 (marks 777 (gnus-message 1 "%s mark %s with message ID %s, resulting in %S"
895 (delq mark (gnus-registry-fetch-extra-marks id))) 778 (if remove "Removing" "Adding")
896 ;; the new marks we want to use 779 mark id marks))
897 (new-marks (if remove 780 (gnus-registry-set-id-key id 'mark marks)))))
898 marks
899 (cons mark marks))))
900 (when show-message
901 (gnus-message 1 "%s mark %s with message ID %s, resulting in %S"
902 (if remove "Removing" "Adding")
903 mark id new-marks))
904
905 (apply 'gnus-registry-store-extra-marks ; set the extra marks
906 id ; for the message ID
907 new-marks)))))
908 781
909(defun gnus-registry-get-article-marks (&rest articles) 782(defun gnus-registry-get-article-marks (&rest articles)
910 "Get the Gnus registry marks for ARTICLES and show them if interactive. 783 "Get the Gnus registry marks for ARTICLES and show them if interactive.
911Uses process/prefix conventions. For multiple articles, 784Uses process/prefix conventions. For multiple articles,
912only the last one's marks are returned." 785only the last one's marks are returned."
913 (interactive (gnus-summary-work-articles 1)) 786 (interactive (gnus-summary-work-articles 1))
914 (let (marks) 787 (let* ((article (last articles))
915 (dolist (article articles) 788 (id (gnus-registry-fetch-message-id-fast article))
916 (let ((article-id 789 (marks (when id (gnus-registry-get-id-key id 'mark))))
917 (gnus-registry-fetch-message-id-fast article)))
918 (setq marks (gnus-registry-fetch-extra-marks article-id))))
919 (when (interactive-p) 790 (when (interactive-p)
920 (gnus-message 1 "Marks are %S" marks)) 791 (gnus-message 1 "Marks are %S" marks))
921 marks)) 792 marks))
922 793
923;;; if this extends to more than 'marks, it should be improved to be more generic.
924(defun gnus-registry-fetch-extra-marks (id)
925 "Get the marks of a message, based on the message ID.
926Returns a list of symbol marks or nil."
927 (car-safe (cdr (gnus-registry-fetch-extra id 'marks))))
928
929(defun gnus-registry-has-extra-mark (id mark)
930 "Checks if a message has `mark', based on the message ID `id'."
931 (memq mark (gnus-registry-fetch-extra-marks id)))
932
933(defun gnus-registry-store-extra-marks (id &rest mark-list)
934 "Set the marks of a message, based on the message ID.
935The `mark-list' can be nil, in which case no marks are left."
936 (gnus-registry-store-extra-entry id 'marks (list mark-list)))
937
938(defun gnus-registry-delete-extra-marks (id &rest mark-delete-list)
939 "Delete the message marks in `mark-delete-list', based on the message ID."
940 (let ((marks (gnus-registry-fetch-extra-marks id)))
941 (when marks
942 (dolist (mark mark-delete-list)
943 (setq marks (delq mark marks))))
944 (gnus-registry-store-extra-marks id (car marks))))
945
946(defun gnus-registry-delete-all-extra-marks (id)
947 "Delete all the marks for a message ID."
948 (gnus-registry-store-extra-marks id nil))
949
950(defun gnus-registry-fetch-extra (id &optional entry)
951 "Get the extra data of a message, based on the message ID.
952Returns the first place where the trail finds a nonstring."
953 (let ((entry-cache (gethash entry gnus-registry-hashtb)))
954 (if (and entry
955 (hash-table-p entry-cache)
956 (gethash id entry-cache))
957 (gethash id entry-cache)
958 ;; else, if there is no caching possible...
959 (let ((trail (gethash id gnus-registry-hashtb)))
960 (when (listp trail)
961 (dolist (crumb trail)
962 (unless (stringp crumb)
963 (return (gnus-registry-fetch-extra-entry crumb entry id)))))))))
964
965(defun gnus-registry-fetch-extra-entry (alist &optional entry id)
966 "Get the extra data of a message, or a specific entry in it.
967Update the entry cache if needed."
968 (if (and entry id)
969 (let ((entry-cache (gethash entry gnus-registry-hashtb))
970 entree)
971 (when gnus-registry-entry-caching
972 ;; create the hash table
973 (unless (hash-table-p entry-cache)
974 (setq entry-cache (make-hash-table
975 :size 4096
976 :test 'equal))
977 (puthash entry entry-cache gnus-registry-hashtb))
978
979 ;; get the entree from the hash table or from the alist
980 (setq entree (gethash id entry-cache)))
981
982 (unless entree
983 (setq entree (assq entry alist))
984 (when gnus-registry-entry-caching
985 (puthash id entree entry-cache)))
986 entree)
987 alist))
988
989(defun gnus-registry-store-extra (id extra)
990 "Store the extra data of a message, based on the message ID.
991The message must have at least one group name."
992 (when (gnus-registry-group-count id)
993 ;; we now know the trail has at least 1 group name, so it's not empty
994 (let ((trail (gethash id gnus-registry-hashtb))
995 (old-extra (gnus-registry-fetch-extra id))
996 entry-cache)
997 (dolist (crumb trail)
998 (unless (stringp crumb)
999 (dolist (entry crumb)
1000 (setq entry-cache (gethash (car entry) gnus-registry-hashtb))
1001 (when entry-cache
1002 (remhash id entry-cache))))
1003 (puthash id (cons extra (delete old-extra trail))
1004 gnus-registry-hashtb)
1005 (setq gnus-registry-dirty t)))))
1006
1007(defun gnus-registry-delete-extra-entry (id key)
1008 "Delete a specific entry in the extras field of the registry entry for id."
1009 (gnus-registry-store-extra-entry id key nil))
1010
1011(defun gnus-registry-store-extra-entry (id key value)
1012 "Put a specific entry in the extras field of the registry entry for id."
1013 (let* ((extra (gnus-registry-fetch-extra id))
1014 ;; all the entries except the one for `key'
1015 (the-rest (gnus-assq-delete-all key (gnus-registry-fetch-extra id)))
1016 (alist (if value
1017 (gnus-registry-remove-alist-text-properties
1018 (cons (cons key value)
1019 the-rest))
1020 the-rest)))
1021 (gnus-registry-store-extra id alist)))
1022
1023(defun gnus-registry-fetch-group (id)
1024 "Get the group of a message, based on the message ID.
1025Returns the first place where the trail finds a group name."
1026 (when (gnus-registry-group-count id)
1027 ;; we now know the trail has at least 1 group name
1028 (let ((trail (gethash id gnus-registry-hashtb)))
1029 (dolist (crumb trail)
1030 (when (stringp crumb)
1031 (return (if gnus-registry-use-long-group-names
1032 crumb
1033 (gnus-group-short-name crumb))))))))
1034
1035(defun gnus-registry-fetch-groups (id &optional max)
1036 "Get the groups (up to MAX, if given) of a message, based on the message ID."
1037 (let ((trail (gethash id gnus-registry-hashtb))
1038 groups)
1039 (dolist (crumb trail)
1040 (when (stringp crumb)
1041 ;; push the group name into the list
1042 (setq
1043 groups
1044 (cons
1045 (if (or (not (stringp crumb)) gnus-registry-use-long-group-names)
1046 crumb
1047 (gnus-group-short-name crumb))
1048 groups))
1049 (when (and max (> (length groups) max))
1050 (return))))
1051 ;; return the list of groups
1052 groups))
1053
1054(defun gnus-registry-group-count (id) 794(defun gnus-registry-group-count (id)
1055 "Get the number of groups of a message, based on the message ID." 795 "Get the number of groups of a message, based on the message ID."
1056 (let ((trail (gethash id gnus-registry-hashtb))) 796 (length (gnus-registry-get-id-key id 'group)))
1057 (if (and trail (listp trail)) 797
1058 (apply '+ (mapcar (lambda (x) (if (stringp x) 1 0)) trail)) 798(defun gnus-registry-get-or-make-entry (id)
1059 0))) 799 (let* ((db gnus-registry-db)
1060 800 ;; safe if not found
1061(defun gnus-registry-delete-group (id group) 801 (entries (registry-lookup db (list id))))
1062 "Delete a group for a message, based on the message ID." 802
1063 (when (and group id) 803 (when (null entries)
1064 (let ((trail (gethash id gnus-registry-hashtb)) 804 (registry-insert db id (list (list 'creation-time (current-time))
1065 (short-group (gnus-group-short-name group))) 805 '(group) '(sender) '(subject)))
1066 (puthash id (if trail 806 (setq entries (registry-lookup db (list id))))
1067 (delete short-group (delete group trail)) 807
1068 nil) 808 (nth 1 (assoc id entries))))
1069 gnus-registry-hashtb)) 809
1070 ;; now, clear the entry if there are no more groups 810(defun gnus-registry-get-id-key (id key)
1071 (when gnus-registry-trim-articles-without-groups 811 (cdr-safe (assq key (gnus-registry-get-or-make-entry id))))
1072 (unless (gnus-registry-group-count id) 812
1073 (gnus-registry-delete-id id))) 813(defun gnus-registry-set-id-key (id key vals)
1074 ;; is this ID still in the registry? 814 (let* ((db gnus-registry-db)
1075 (when (gethash id gnus-registry-hashtb) 815 (entry (gnus-registry-get-or-make-entry id)))
1076 (gnus-registry-store-extra-entry id 'mtime (current-time))))) 816 (registry-delete db (list id) nil)
1077 817 (setq entry (cons (cons key vals) (assq-delete-all key entry)))
1078(defun gnus-registry-delete-id (id) 818 (registry-insert db id entry)
1079 "Delete a message ID from the registry." 819 entry))
1080 (when (stringp id) 820
1081 (remhash id gnus-registry-hashtb) 821
1082 (maphash 822(ert-deftest gnus-registry-usage-test ()
1083 (lambda (key value) 823 (let* ((n 100)
1084 (when (hash-table-p value) 824 (tempfile (make-temp-file "gnus-registry-persist"))
1085 (remhash id value))) 825 (db (gnus-registry-make-db tempfile))
1086 gnus-registry-hashtb))) 826 (gnus-registry-db db)
1087 827 back size)
1088(defun gnus-registry-add-group (id group &optional subject sender) 828 (message "Adding %d keys to the test Gnus registry" n)
1089 "Add a group for a message, based on the message ID." 829 (dotimes (i n)
1090 (when group 830 (let ((id (number-to-string i)))
1091 (when (and id 831 (gnus-registry-handle-action id
1092 (not (string-match "totally-fudged-out-message-id" id))) 832 (if (>= 50 i) "fromgroup" nil)
1093 (let ((full-group group) 833 "togroup"
1094 (group (if gnus-registry-use-long-group-names 834 (when (>= 70 i)
1095 group 835 (format "subject %d" (mod i 10)))
1096 (gnus-group-short-name group)))) 836 (when (>= 80 i)
1097 (gnus-registry-delete-group id group) 837 (format "sender %d" (mod i 10))))))
1098 838 (message "Testing Gnus registry size is %d" n)
1099 (unless gnus-registry-use-long-group-names ;; unnecessary in this case 839 (should (= n (registry-size db)))
1100 (gnus-registry-delete-group id full-group)) 840 (message "Looking up individual keys (registry-lookup)")
1101 841 (should (equal (loop for e
1102 (let ((trail (gethash id gnus-registry-hashtb))) 842 in (mapcar 'cadr
1103 (puthash id (if trail 843 (registry-lookup db '("20" "83" "72")))
1104 (cons group trail) 844 collect (assq 'subject e)
1105 (list group)) 845 collect (assq 'sender e)
1106 gnus-registry-hashtb) 846 collect (assq 'group e))
1107 847 '((subject "subject 0") (sender "sender 0") (group "togroup")
1108 (when (and (gnus-registry-track-subject-p) 848 (subject) (sender) (group "togroup")
1109 subject) 849 (subject) (sender "sender 2") (group "togroup"))))
1110 (gnus-registry-store-extra-entry 850
1111 id 851 (message "Looking up individual keys (gnus-registry-id-key)")
1112 'subject 852 (should (equal (gnus-registry-get-id-key "34" 'group) '("togroup")))
1113 (gnus-registry-simplify-subject subject))) 853 (should (equal (gnus-registry-get-id-key "34" 'subject) '("subject 4")))
1114 (when (and (gnus-registry-track-sender-p) 854 (message "Trying to insert a duplicate key")
1115 sender) 855 (should-error (registry-insert db "55" '()))
1116 (gnus-registry-store-extra-entry 856 (message "Looking up individual keys (gnus-registry-get-or-make-entry)")
1117 id 857 (should (gnus-registry-get-or-make-entry "22"))
1118 'sender 858 (message "Saving the Gnus registry to %s" tempfile)
1119 sender)) 859 (should (gnus-registry-save tempfile db))
1120 860 (setq size (nth 7 (file-attributes tempfile)))
1121 (gnus-registry-store-extra-entry id 'mtime (current-time))))))) 861 (message "Saving the Gnus registry to %s: size %d" tempfile size)
1122 862 (should (< 0 size))
1123(defun gnus-registry-clear () 863 (with-temp-buffer
1124 "Clear the Gnus registry." 864 (insert-file-contents-literally tempfile)
1125 (interactive) 865 (should (looking-at (concat ";; Object "
1126 (setq gnus-registry-alist nil) 866 "Gnus Registry"
1127 (setq gnus-registry-hashtb (gnus-alist-to-hashtable gnus-registry-alist)) 867 "\n;; EIEIO PERSISTENT OBJECT"))))
1128 (setq gnus-registry-dirty t)) 868 (message "Reading Gnus registry back")
869 (setq back (eieio-persistent-read tempfile))
870 (should back)
871 (message "Read Gnus registry back: %d keys, expected %d==%d"
872 (registry-size back) n (registry-size db))
873 (should (= (registry-size back) n))
874 (should (= (registry-size back) (registry-size db)))
875 (delete-file tempfile)
876 (message "Pruning Gnus registry to 0 by setting :max-soft")
877 (oset db :max-soft 0)
878 (registry-prune db)
879 (should (= (registry-size db) 0)))
880 (message "Done with Gnus registry usage testing."))
1129 881
1130;;;###autoload 882;;;###autoload
1131(defun gnus-registry-initialize () 883(defun gnus-registry-initialize ()
1132"Initialize the Gnus registry." 884"Initialize the Gnus registry."
1133 (interactive) 885 (interactive)
1134 (gnus-message 5 "Initializing the registry") 886 (gnus-message 5 "Initializing the registry")
1135 (setq gnus-registry-install t) ; in case it was 'ask or nil 887 (setq gnus-registry-install t) ; in case it was 'ask or nil
1136 (gnus-registry-install-hooks) 888 (gnus-registry-install-hooks)
1137 (gnus-registry-install-shortcuts) 889 (gnus-registry-install-shortcuts)
1138 (gnus-registry-read)) 890 (gnus-registry-read))
@@ -1170,10 +922,10 @@ Returns the first place where the trail finds a group name."
1170 (interactive) 922 (interactive)
1171 (when (eq gnus-registry-install 'ask) 923 (when (eq gnus-registry-install 'ask)
1172 (setq gnus-registry-install 924 (setq gnus-registry-install
1173 (gnus-y-or-n-p 925 (gnus-y-or-n-p
1174 (concat "Enable the Gnus registry? " 926 (concat "Enable the Gnus registry? "
1175 "See the variable `gnus-registry-install' " 927 "See the variable `gnus-registry-install' "
1176 "to get rid of this query permanently. "))) 928 "to get rid of this query permanently. ")))
1177 (when gnus-registry-install 929 (when gnus-registry-install
1178 ;; we just set gnus-registry-install to t, so initialize the registry! 930 ;; we just set gnus-registry-install to t, so initialize the registry!
1179 (gnus-registry-initialize))) 931 (gnus-registry-initialize)))
diff --git a/lisp/gnus/nnregistry.el b/lisp/gnus/nnregistry.el
index 947ba4b236b..359050c356c 100644
--- a/lisp/gnus/nnregistry.el
+++ b/lisp/gnus/nnregistry.el
@@ -53,7 +53,7 @@
53(deffoo nnregistry-request-article (id &optional group server buffer) 53(deffoo nnregistry-request-article (id &optional group server buffer)
54 (and (not nnregistry-within-nnregistry) 54 (and (not nnregistry-within-nnregistry)
55 (let* ((nnregistry-within-nnregistry t) 55 (let* ((nnregistry-within-nnregistry t)
56 (group (gnus-registry-fetch-group id)) 56 (group (nth 0 (gnus-registry-get-id-key id 'group)))
57 (gnus-override-method nil)) 57 (gnus-override-method nil))
58 (message "nnregistry: requesting article `%s' in group `%s'" 58 (message "nnregistry: requesting article `%s' in group `%s'"
59 id group) 59 id group)
diff --git a/lisp/gnus/spam.el b/lisp/gnus/spam.el
index 2ebf0ba1e1d..cbffeeab69e 100644
--- a/lisp/gnus/spam.el
+++ b/lisp/gnus/spam.el
@@ -68,9 +68,9 @@
68 68
69;; autoload gnus-registry 69;; autoload gnus-registry
70(autoload 'gnus-registry-group-count "gnus-registry") 70(autoload 'gnus-registry-group-count "gnus-registry")
71(autoload 'gnus-registry-add-group "gnus-registry") 71(autoload 'gnus-registry-get-id-key "gnus-registry")
72(autoload 'gnus-registry-store-extra-entry "gnus-registry") 72(autoload 'gnus-registry-set-id-key "gnus-registry")
73(autoload 'gnus-registry-fetch-extra "gnus-registry") 73(autoload 'gnus-registry-handle-action "gnus-registry")
74 74
75;; autoload dns-query 75;; autoload dns-query
76(autoload 'dns-query "dns") 76(autoload 'dns-query "dns")
@@ -1764,8 +1764,7 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details."
1764 1764
1765 (when (and id split-return spam-log-to-registry) 1765 (when (and id split-return spam-log-to-registry)
1766 (when (zerop (gnus-registry-group-count id)) 1766 (when (zerop (gnus-registry-group-count id))
1767 (gnus-registry-add-group 1767 (gnus-registry-handle-action id nil group subject sender))
1768 id group subject sender))
1769 1768
1770 (unless registry-lookup 1769 (unless registry-lookup
1771 (spam-log-processing-to-registry 1770 (spam-log-processing-to-registry
@@ -1894,13 +1893,10 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details."
1894 (spam-process-type-valid-p type) 1893 (spam-process-type-valid-p type)
1895 (spam-classification-valid-p classification) 1894 (spam-classification-valid-p classification)
1896 (spam-backend-valid-p backend)) 1895 (spam-backend-valid-p backend))
1897 (let ((cell-list (cdr-safe (gnus-registry-fetch-extra id type))) 1896 (let ((cell-list (gnus-registry-get-id-key id type))
1898 (cell (list classification backend group))) 1897 (cell (list classification backend group)))
1899 (push cell cell-list) 1898 (push cell cell-list)
1900 (gnus-registry-store-extra-entry 1899 (gnus-registry-set-id-key id type cell-list))
1901 id
1902 type
1903 cell-list))
1904 1900
1905 (gnus-error 1901 (gnus-error
1906 7 1902 7
@@ -1913,7 +1909,7 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details."
1913 (when spam-log-to-registry 1909 (when spam-log-to-registry
1914 (if (and (stringp id) 1910 (if (and (stringp id)
1915 (spam-process-type-valid-p type)) 1911 (spam-process-type-valid-p type))
1916 (cdr-safe (gnus-registry-fetch-extra id type)) 1912 (gnus-registry-get-id-key id type)
1917 (progn 1913 (progn
1918 (gnus-error 1914 (gnus-error
1919 7 1915 7
@@ -1945,7 +1941,7 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details."
1945 (spam-process-type-valid-p type) 1941 (spam-process-type-valid-p type)
1946 (spam-classification-valid-p classification) 1942 (spam-classification-valid-p classification)
1947 (spam-backend-valid-p backend)) 1943 (spam-backend-valid-p backend))
1948 (let ((cell-list (cdr-safe (gnus-registry-fetch-extra id type))) 1944 (let ((cell-list (gnus-registry-get-id-key id type))
1949 found) 1945 found)
1950 (dolist (cell cell-list) 1946 (dolist (cell cell-list)
1951 (unless found 1947 (unless found
@@ -1970,16 +1966,13 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details."
1970 (spam-process-type-valid-p type) 1966 (spam-process-type-valid-p type)
1971 (spam-classification-valid-p classification) 1967 (spam-classification-valid-p classification)
1972 (spam-backend-valid-p backend)) 1968 (spam-backend-valid-p backend))
1973 (let ((cell-list (cdr-safe (gnus-registry-fetch-extra id type))) 1969 (let ((cell-list (gnus-registry-get-id-key id type))
1974 new-cell-list found) 1970 new-cell-list found)
1975 (dolist (cell cell-list) 1971 (dolist (cell cell-list)
1976 (unless (and (eq classification (nth 0 cell)) 1972 (unless (and (eq classification (nth 0 cell))
1977 (eq backend (nth 1 cell))) 1973 (eq backend (nth 1 cell)))
1978 (push cell new-cell-list))) 1974 (push cell new-cell-list)))
1979 (gnus-registry-store-extra-entry 1975 (gnus-registry-set-id-key id type new-cell-list))
1980 id
1981 type
1982 new-cell-list))
1983 (progn 1976 (progn
1984 (gnus-error 7 (format 1977 (gnus-error 7 (format
1985 "%s call with bad ID, type, spam-backend, or group" 1978 "%s call with bad ID, type, spam-backend, or group"
generated by cgit v1.2.1 (git 2.18.0) at 2026-01-28 16:39:00 +0000