d4764c08fde110e7cafe8f87d21c01884d22d385
[gnus] / lisp / gnus-registry.el
1 ;;; gnus-registry.el --- article registry for Gnus
2
3 ;; Copyright (C) 2002-2013 Free Software Foundation, Inc.
4
5 ;; Author: Ted Zlatanov <tzz@lifelogs.com>
6 ;; Keywords: news registry
7
8 ;; This file is part of GNU Emacs.
9
10 ;; GNU Emacs is free software: you can redistribute it and/or modify
11 ;; it under the terms of the GNU General Public License as published by
12 ;; the Free Software Foundation, either version 3 of the License, or
13 ;; (at your option) any later version.
14
15 ;; GNU Emacs is distributed in the hope that it will be useful,
16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
18 ;; GNU General Public License for more details.
19
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
22
23 ;;; Commentary:
24
25 ;; This is the gnus-registry.el package, which works with all
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
28 ;; nnml:sys and you see a reference to it in nnimap splitting, the
29 ;; article will end up in nnimap:sys
30
31 ;; gnus-registry.el intercepts article respooling, moving, deleting,
32 ;; and copying for all backends.  If it doesn't work correctly for
33 ;; you, submit a bug report and I'll be glad to fix it.  It needs
34 ;; better documentation in the manual (also on my to-do list).
35
36 ;; If you want to track recipients (and you should to make the
37 ;; gnus-registry splitting work better), you need the To and Cc
38 ;; headers collected by Gnus.  Note that in more recent Gnus versions
39 ;; this is already the case: look at `gnus-extra-headers' to be sure.
40
41 ;; ;;; you may also want Gcc Newsgroups Keywords X-Face
42 ;; (add-to-list 'gnus-extra-headers 'To)
43 ;; (add-to-list 'gnus-extra-headers 'Cc)
44 ;; (setq nnmail-extra-headers gnus-extra-headers)
45
46 ;; Put this in your startup file (~/.gnus.el for instance) or use Customize:
47
48 ;; (setq gnus-registry-max-entries 2500
49 ;;       gnus-registry-track-extra '(sender subject recipient))
50
51 ;; (gnus-registry-initialize)
52
53 ;; Then use this in your fancy-split:
54
55 ;; (: gnus-registry-split-fancy-with-parent)
56
57 ;; You should also consider using the nnregistry backend to look up
58 ;; articles.  See the Gnus manual for more information.
59
60 ;; Finally, you can put %uM in your summary line format to show the
61 ;; registry marks if you do this:
62
63 ;; show the marks as single characters (see the :char property in
64 ;; `gnus-registry-marks'):
65 ;; (defalias 'gnus-user-format-function-M 'gnus-registry-article-marks-to-chars)
66
67 ;; show the marks by name (see `gnus-registry-marks'):
68 ;; (defalias 'gnus-user-format-function-M 'gnus-registry-article-marks-to-names)
69
70 ;; TODO:
71
72 ;; - get the correct group on spool actions
73
74 ;; - articles that are spooled to a different backend should be moved
75 ;;   after splitting
76
77 ;;; Code:
78
79 (eval-when-compile (require 'cl))
80
81 (require 'gnus)
82 (require 'gnus-int)
83 (require 'gnus-sum)
84 (require 'gnus-art)
85 (require 'gnus-util)
86 (require 'nnmail)
87 (require 'easymenu)
88 (require 'registry)
89
90 (defvar gnus-adaptive-word-syntax-table)
91
92 (defvar gnus-registry-dirty t
93  "Boolean set to t when the registry is modified.")
94
95 (defgroup gnus-registry nil
96   "The Gnus registry."
97   :version "22.1"
98   :group 'gnus)
99
100 (defvar gnus-registry-marks
101   '((Important
102      :char ?i
103      :image "summary_important")
104     (Work
105      :char ?w
106      :image "summary_work")
107     (Personal
108      :char ?p
109      :image "summary_personal")
110     (To-Do
111      :char ?t
112      :image "summary_todo")
113     (Later
114      :char ?l
115      :image "summary_later"))
116
117   "List of registry marks and their options.
118
119 `gnus-registry-mark-article' will offer symbols from this list
120 for completion.
121
122 Each entry must have a character to be useful for summary mode
123 line display and for keyboard shortcuts.
124
125 Each entry must have an image string to be useful for visual
126 display.")
127
128 (defcustom gnus-registry-default-mark 'To-Do
129   "The default mark.  Should be a valid key for `gnus-registry-marks'."
130   :group 'gnus-registry
131   :type 'symbol)
132
133 (defcustom gnus-registry-unfollowed-addresses
134   (list (regexp-quote user-mail-address))
135   "List of addresses that gnus-registry-split-fancy-with-parent won't trace.
136 The addresses are matched, they don't have to be fully qualified.
137 In the messages, these addresses can be the sender or the
138 recipients."
139   :version "24.1"
140   :group 'gnus-registry
141   :type '(repeat regexp))
142
143 (defcustom gnus-registry-unfollowed-groups
144   '("delayed$" "drafts$" "queue$" "INBOX$" "^nnmairix:" "archive")
145   "List of groups that gnus-registry-split-fancy-with-parent won't return.
146 The group names are matched, they don't have to be fully
147 qualified.  This parameter tells the Gnus registry 'never split a
148 message into a group that matches one of these, regardless of
149 references.'
150
151 nnmairix groups are specifically excluded because they are ephemeral."
152   :group 'gnus-registry
153   :type '(repeat regexp))
154
155 (defcustom gnus-registry-install 'ask
156   "Whether the registry should be installed."
157   :group 'gnus-registry
158   :type '(choice (const :tag "Never Install" nil)
159                  (const :tag "Always Install" t)
160                  (const :tag "Ask Me" ask)))
161
162 (defvar gnus-registry-enabled nil)
163
164 (defvar gnus-summary-misc-menu) ;; Avoid byte compiler warning.
165
166 (defvar gnus-registry-misc-menus nil)   ; ugly way to keep the menus
167
168 (make-obsolete-variable 'gnus-registry-clean-empty nil "23.4")
169 (make-obsolete-variable 'gnus-registry-use-long-group-names nil "23.4")
170 (make-obsolete-variable 'gnus-registry-max-track-groups nil "23.4")
171 (make-obsolete-variable 'gnus-registry-entry-caching nil "23.4")
172 (make-obsolete-variable 'gnus-registry-trim-articles-without-groups nil "23.4")
173
174 (defcustom gnus-registry-track-extra '(subject sender recipient)
175   "Whether the registry should track extra data about a message.
176 The subject, recipients (To: and Cc:), and Sender (From:) headers
177 are tracked this way by default."
178   :group 'gnus-registry
179   :type
180   '(set :tag "Tracking choices"
181     (const :tag "Track by subject (Subject: header)" subject)
182     (const :tag "Track by recipient (To: and Cc: headers)" recipient)
183     (const :tag "Track by sender (From: header)"  sender)))
184
185 (defcustom gnus-registry-split-strategy nil
186   "The splitting strategy applied to the keys in `gnus-registry-track-extra'.
187
188 Given a set of unique found groups G and counts for each element
189 of G, and a key K (typically 'sender or 'subject):
190
191 When nil, if G has only one element, use it.  Otherwise give up.
192 This is the fastest but also least useful strategy.
193
194 When 'majority, use the majority by count.  So if there is a
195 group with the most articles counted by K, use that.  Ties are
196 resolved in no particular order, simply the first one found wins.
197 This is the slowest strategy but also the most accurate one.
198
199 When 'first, the first element of G wins.  This is fast and
200 should be OK if your senders and subjects don't \"bleed\" across
201 groups."
202   :group 'gnus-registry
203   :type
204   '(choice :tag "Splitting strategy"
205            (const :tag "Only use single choices, discard multiple matches" nil)
206            (const :tag "Majority of matches wins" majority)
207            (const :tag "First found wins"  first)))
208
209 (defcustom gnus-registry-minimum-subject-length 5
210   "The minimum length of a subject before it's considered trackable."
211   :group 'gnus-registry
212   :type 'integer)
213
214 (defcustom gnus-registry-extra-entries-precious '(mark)
215   "What extra keys are precious, meaning entries with them won't get pruned.
216 By default, 'mark is included, so articles with marks are
217 considered precious.
218
219 Before you save the Gnus registry, it's pruned.  Any entries with
220 keys in this list will not be pruned.  All other entries go to
221 the Bit Bucket."
222   :group 'gnus-registry
223   :type '(repeat symbol))
224
225 (defcustom gnus-registry-cache-file
226   (nnheader-concat
227    (or gnus-dribble-directory gnus-home-directory "~/")
228    ".gnus.registry.eioio")
229   "File where the Gnus registry will be stored."
230   :group 'gnus-registry
231   :type 'file)
232
233 (defcustom gnus-registry-max-entries nil
234   "Maximum number of entries in the registry, nil for unlimited."
235   :group 'gnus-registry
236   :type '(radio (const :format "Unlimited " nil)
237                 (integer :format "Maximum number: %v")))
238
239 (defcustom gnus-registry-max-pruned-entries nil
240   "Maximum number of pruned entries in the registry, nil for unlimited."
241   :version "24.1"
242   :group 'gnus-registry
243   :type '(radio (const :format "Unlimited " nil)
244                 (integer :format "Maximum number: %v")))
245
246 (defun gnus-registry-fixup-registry (db)
247   (when db
248     (let ((old (oref db :tracked)))
249       (oset db :precious
250             (append gnus-registry-extra-entries-precious
251                     '()))
252       (oset db :max-hard
253             (or gnus-registry-max-entries
254                 most-positive-fixnum))
255       (oset db :prune-factor
256             0.1)
257       (oset db :max-soft
258             (or gnus-registry-max-pruned-entries
259                 most-positive-fixnum))
260       (oset db :tracked
261             (append gnus-registry-track-extra
262                     '(mark group keyword)))
263       (when (not (equal old (oref db :tracked)))
264         (gnus-message 9 "Reindexing the Gnus registry (tracked change)")
265         (registry-reindex db))))
266   db)
267
268 (defun gnus-registry-make-db (&optional file)
269   (interactive "fGnus registry persistence file: \n")
270   (gnus-registry-fixup-registry
271    (registry-db
272     "Gnus Registry"
273     :file (or file gnus-registry-cache-file)
274     ;; these parameters are set in `gnus-registry-fixup-registry'
275     :max-hard most-positive-fixnum
276     :max-soft most-positive-fixnum
277     :precious nil
278     :tracked nil)))
279
280 (defvar gnus-registry-db (gnus-registry-make-db)
281   "The article registry by Message ID.  See `registry-db'.")
282
283 ;; top-level registry data management
284 (defun gnus-registry-remake-db (&optional forsure)
285   "Remake the registry database after customization.
286 This is not required after changing `gnus-registry-cache-file'."
287   (interactive (list (y-or-n-p "Remake and CLEAR the Gnus registry? ")))
288   (when forsure
289     (gnus-message 4 "Remaking the Gnus registry")
290     (setq gnus-registry-db (gnus-registry-make-db))))
291
292 (defun gnus-registry-read ()
293   "Read the registry cache file."
294   (interactive)
295   (let ((file gnus-registry-cache-file))
296     (condition-case nil
297         (progn
298           (gnus-message 5 "Reading Gnus registry from %s..." file)
299           (setq gnus-registry-db
300                 (gnus-registry-fixup-registry
301                  (condition-case nil
302                      (with-no-warnings
303                        (eieio-persistent-read file 'registry-db))
304                    ;; Older EIEIO versions do not check the class name.
305                    ('wrong-number-of-arguments
306                     (eieio-persistent-read file)))))
307           (gnus-message 5 "Reading Gnus registry from %s...done" file))
308       (error
309        (gnus-message
310         1
311         "The Gnus registry could not be loaded from %s, creating a new one"
312         file)
313        (gnus-registry-remake-db t)))))
314
315 (defun gnus-registry-save (&optional file db)
316   "Save the registry cache file."
317   (interactive)
318   (let ((file (or file gnus-registry-cache-file))
319         (db (or db gnus-registry-db)))
320     (gnus-message 5 "Saving Gnus registry (%d entries) to %s..."
321                   (registry-size db) file)
322     (registry-prune db)
323     ;; TODO: call (gnus-string-remove-all-properties v) on all elements?
324     (eieio-persistent-save db file)
325     (gnus-message 5 "Saving Gnus registry (size %d) to %s...done"
326                   (registry-size db) file)))
327
328 (defun gnus-registry-remove-ignored ()
329   (interactive)
330   (let* ((db gnus-registry-db)
331          (grouphashtb (registry-lookup-secondary db 'group))
332          (old-size (registry-size db)))
333     (registry-reindex db)
334     (loop for k being the hash-keys of grouphashtb
335           using (hash-values v)
336           when (gnus-registry-ignore-group-p k)
337           do (registry-delete db v nil))
338     (registry-reindex db)
339     (gnus-message 4 "Removed %d ignored entries from the Gnus registry"
340                   (- old-size (registry-size db)))))
341
342 ;; article move/copy/spool/delete actions
343 (defun gnus-registry-action (action data-header from &optional to method)
344   (let* ((id (mail-header-id data-header))
345          (subject (mail-header-subject data-header))
346          (extra (mail-header-extra data-header))
347          (recipients (gnus-registry-sort-addresses
348                       (or (cdr-safe (assq 'Cc extra)) "")
349                       (or (cdr-safe (assq 'To extra)) "")))
350          (sender (nth 0 (gnus-registry-extract-addresses
351                          (mail-header-from data-header))))
352          (from (gnus-group-guess-full-name-from-command-method from))
353          (to (if to (gnus-group-guess-full-name-from-command-method to) nil))
354          (to-name (if to to "the Bit Bucket")))
355     (gnus-message 7 "Gnus registry: article %s %s from %s to %s"
356                   id (if method "respooling" "going") from to)
357
358     (gnus-registry-handle-action
359      id
360      ;; unless copying, remove the old "from" group
361      (if (not (equal 'copy action)) from nil)
362      to subject sender recipients)))
363
364 (defun gnus-registry-spool-action (id group &optional subject sender recipients)
365   (let ((to (gnus-group-guess-full-name-from-command-method group))
366         (recipients (or recipients
367                         (gnus-registry-sort-addresses
368                          (or (message-fetch-field "cc") "")
369                          (or (message-fetch-field "to") ""))))
370         (subject (or subject (message-fetch-field "subject")))
371         (sender (or sender (message-fetch-field "from"))))
372     (when (and (stringp id) (string-match "\r$" id))
373       (setq id (substring id 0 -1)))
374     (gnus-message 7 "Gnus registry: article %s spooled to %s"
375                   id
376                   to)
377     (gnus-registry-handle-action id nil to subject sender recipients)))
378
379 (defun gnus-registry-handle-action (id from to subject sender
380                                        &optional recipients)
381   (gnus-message
382    10
383    "gnus-registry-handle-action %S" (list id from to subject sender recipients))
384   (let ((db gnus-registry-db)
385         ;; if the group is ignored, set the destination to nil (same as delete)
386         (to (if (gnus-registry-ignore-group-p to) nil to))
387         ;; safe if not found
388         (entry (gnus-registry-get-or-make-entry id))
389         (subject (gnus-string-remove-all-properties
390                   (gnus-registry-simplify-subject subject)))
391         (sender (gnus-string-remove-all-properties sender)))
392
393     ;; this could be done by calling `gnus-registry-set-id-key'
394     ;; several times but it's better to bunch the transactions
395     ;; together
396
397     (registry-delete db (list id) nil)
398     (when from
399       (setq entry (cons (delete from (assoc 'group entry))
400                         (assq-delete-all 'group entry))))
401
402     (dolist (kv `((group ,to)
403                   (sender ,sender)
404                   (recipient ,@recipients)
405                   (subject ,subject)))
406       (when (second kv)
407         (let ((new (or (assq (first kv) entry)
408                        (list (first kv)))))
409           (dolist (toadd (cdr kv))
410             (add-to-list 'new toadd t))
411           (setq entry (cons new
412                             (assq-delete-all (first kv) entry))))))
413     (gnus-message 10 "Gnus registry: new entry for %s is %S"
414                   id
415                   entry)
416     (gnus-registry-insert db id entry)))
417
418 ;; Function for nn{mail|imap}-split-fancy: look up all references in
419 ;; the cache and if a match is found, return that group.
420 (defun gnus-registry-split-fancy-with-parent ()
421   "Split this message into the same group as its parent.
422 The parent is obtained from the registry.  This function can be used as an
423 entry in `nnmail-split-fancy' or `nnimap-split-fancy', for example like
424 this: (: gnus-registry-split-fancy-with-parent)
425
426 This function tracks ALL backends, unlike
427 `nnmail-split-fancy-with-parent' which tracks only nnmail
428 messages.
429
430 For a message to be split, it looks for the parent message in the
431 References or In-Reply-To header and then looks in the registry
432 to see which group that message was put in.  This group is
433 returned, unless `gnus-registry-follow-group-p' return nil for
434 that group.
435
436 See the Info node `(gnus)Fancy Mail Splitting' for more details."
437   (let* ((refstr (or (message-fetch-field "references") "")) ; guaranteed
438          (reply-to (message-fetch-field "in-reply-to"))      ; may be nil
439          ;; now, if reply-to is valid, append it to the References
440          (refstr (if reply-to
441                      (concat refstr " " reply-to)
442                    refstr))
443          (references (and refstr (gnus-extract-references refstr)))
444          ;; these may not be used, but the code is cleaner having them up here
445          (sender (gnus-string-remove-all-properties
446                   (message-fetch-field "from")))
447          (recipients (gnus-registry-sort-addresses
448                       (or (message-fetch-field "cc") "")
449                       (or (message-fetch-field "to") "")))
450          (subject (gnus-string-remove-all-properties
451                    (gnus-registry-simplify-subject
452                     (message-fetch-field "subject"))))
453
454          (nnmail-split-fancy-with-parent-ignore-groups
455           (if (listp nnmail-split-fancy-with-parent-ignore-groups)
456               nnmail-split-fancy-with-parent-ignore-groups
457             (list nnmail-split-fancy-with-parent-ignore-groups))))
458     (gnus-registry--split-fancy-with-parent-internal
459      :references references
460      :refstr refstr
461      :sender sender
462      :recipients recipients
463      :subject subject
464      :log-agent "Gnus registry fancy splitting with parent")))
465
466 (defun* gnus-registry--split-fancy-with-parent-internal
467     (&rest spec
468            &key references refstr sender subject recipients log-agent
469            &allow-other-keys)
470   (gnus-message
471    10
472    "gnus-registry--split-fancy-with-parent-internal %S" spec)
473   (let ((db gnus-registry-db)
474         found)
475     ;; this is a big chain of statements.  it uses
476     ;; gnus-registry-post-process-groups to filter the results after
477     ;; every step.
478     ;; the references string must be valid and parse to valid references
479     (when references
480       (gnus-message
481        9
482        "%s is tracing references %s"
483        log-agent refstr)
484       (dolist (reference (nreverse references))
485         (gnus-message 9 "%s is looking up %s" log-agent reference)
486         (loop for group in (gnus-registry-get-id-key reference 'group)
487               when (gnus-registry-follow-group-p group)
488               do
489               (progn
490                 (gnus-message 7 "%s traced %s to %s" log-agent reference group)
491                 (push group found))))
492       ;; filter the found groups and return them
493       ;; the found groups are the full groups
494       (setq found (gnus-registry-post-process-groups
495                    "references" refstr found)))
496
497      ;; else: there were no matches, now try the extra tracking by subject
498      (when (and (null found)
499                 (memq 'subject gnus-registry-track-extra)
500                 subject
501                 (< gnus-registry-minimum-subject-length (length subject)))
502        (let ((groups (apply
503                       'append
504                       (mapcar
505                        (lambda (reference)
506                          (gnus-registry-get-id-key reference 'group))
507                        (registry-lookup-secondary-value db 'subject subject)))))
508          (setq found
509                (loop for group in groups
510                      when (gnus-registry-follow-group-p group)
511                      do (gnus-message
512                          ;; warn more if gnus-registry-track-extra
513                          (if gnus-registry-track-extra 7 9)
514                          "%s (extra tracking) traced subject '%s' to %s"
515                          log-agent subject group)
516                     and collect group))
517          ;; filter the found groups and return them
518          ;; the found groups are NOT the full groups
519          (setq found (gnus-registry-post-process-groups
520                       "subject" subject found))))
521
522      ;; else: there were no matches, try the extra tracking by sender
523      (when (and (null found)
524                 (memq 'sender gnus-registry-track-extra)
525                 sender
526                 (not (gnus-grep-in-list
527                       sender
528                       gnus-registry-unfollowed-addresses)))
529        (let ((groups (apply
530                       'append
531                       (mapcar
532                        (lambda (reference)
533                          (gnus-registry-get-id-key reference 'group))
534                        (registry-lookup-secondary-value db 'sender sender)))))
535          (setq found
536                (loop for group in groups
537                      when (gnus-registry-follow-group-p group)
538                      do (gnus-message
539                          ;; warn more if gnus-registry-track-extra
540                          (if gnus-registry-track-extra 7 9)
541                          "%s (extra tracking) traced sender '%s' to %s"
542                          log-agent sender group)
543                      and collect group)))
544
545        ;; filter the found groups and return them
546        ;; the found groups are NOT the full groups
547        (setq found (gnus-registry-post-process-groups
548                     "sender" sender found)))
549
550      ;; else: there were no matches, try the extra tracking by recipient
551      (when (and (null found)
552                 (memq 'recipient gnus-registry-track-extra)
553                 recipients)
554        (dolist (recp recipients)
555          (when (and (null found)
556                     (not (gnus-grep-in-list
557                           recp
558                           gnus-registry-unfollowed-addresses)))
559            (let ((groups (apply 'append
560                                 (mapcar
561                                  (lambda (reference)
562                                    (gnus-registry-get-id-key reference 'group))
563                                  (registry-lookup-secondary-value
564                                   db 'recipient recp)))))
565              (setq found
566                    (loop for group in groups
567                          when (gnus-registry-follow-group-p group)
568                          do (gnus-message
569                              ;; warn more if gnus-registry-track-extra
570                              (if gnus-registry-track-extra 7 9)
571                              "%s (extra tracking) traced recipient '%s' to %s"
572                              log-agent recp group)
573                         and collect group)))))
574
575        ;; filter the found groups and return them
576        ;; the found groups are NOT the full groups
577        (setq found (gnus-registry-post-process-groups
578                     "recipients" (mapconcat 'identity recipients ", ") found)))
579
580      ;; after the (cond) we extract the actual value safely
581      (car-safe found)))
582
583 (defun gnus-registry-post-process-groups (mode key groups)
584   "Inspects GROUPS found by MODE for KEY to determine which ones to follow.
585
586 MODE can be 'subject' or 'sender' for example.  The KEY is the
587 value by which MODE was searched.
588
589 Transforms each group name to the equivalent short name.
590
591 Checks if the current Gnus method (from `gnus-command-method' or
592 from `gnus-newsgroup-name') is the same as the group's method.
593 Foreign methods are not supported so they are rejected.
594
595 Reduces the list to a single group, or complains if that's not
596 possible.  Uses `gnus-registry-split-strategy'."
597   (let ((log-agent "gnus-registry-post-process-group")
598         (desc (format "%d groups" (length groups)))
599         out chosen)
600     ;; the strategy can be nil, in which case chosen is nil
601     (setq chosen
602           (case gnus-registry-split-strategy
603             ;; default, take only one-element lists into chosen
604             ((nil)
605              (and (= (length groups) 1)
606                   (car-safe groups)))
607
608             ((first)
609              (car-safe groups))
610
611             ((majority)
612              (let ((freq (make-hash-table
613                           :size 256
614                           :test 'equal)))
615                (mapc (lambda (x) (let ((x (gnus-group-short-name x)))
616                               (puthash x (1+ (gethash x freq 0)) freq)))
617                      groups)
618                (setq desc (format "%d groups, %d unique"
619                                   (length groups)
620                                   (hash-table-count freq)))
621                (car-safe
622                 (sort groups
623                       (lambda (a b)
624                         (> (gethash (gnus-group-short-name a) freq 0)
625                            (gethash (gnus-group-short-name b) freq 0)))))))))
626
627     (if chosen
628         (gnus-message
629          9
630          "%s: strategy %s on %s produced %s"
631          log-agent gnus-registry-split-strategy desc chosen)
632       (gnus-message
633        9
634        "%s: strategy %s on %s did not produce an answer"
635        log-agent
636        (or gnus-registry-split-strategy "default")
637        desc))
638
639     (setq groups (and chosen (list chosen)))
640
641     (dolist (group groups)
642       (let ((m1 (gnus-find-method-for-group group))
643             (m2 (or gnus-command-method
644                     (gnus-find-method-for-group gnus-newsgroup-name)))
645             (short-name (gnus-group-short-name group)))
646         (if (gnus-methods-equal-p m1 m2)
647             (progn
648               ;; this is REALLY just for debugging
649               (when (not (equal group short-name))
650                 (gnus-message
651                  10
652                  "%s: stripped group %s to %s"
653                  log-agent group short-name))
654               (add-to-list 'out short-name))
655           ;; else...
656           (gnus-message
657            7
658            "%s: ignored foreign group %s"
659            log-agent group))))
660
661     (setq out (delq nil out))
662
663     (cond
664      ((= (length out) 1) out)
665      ((null out)
666       (gnus-message
667        5
668        "%s: no matches for %s '%s'."
669        log-agent mode key)
670       nil)
671      (t (gnus-message
672          5
673          "%s: too many extra matches (%s) for %s '%s'.  Returning none."
674          log-agent out mode key)
675         nil))))
676
677 (defun gnus-registry-follow-group-p (group)
678   "Determines if a group name should be followed.
679 Consults `gnus-registry-unfollowed-groups' and
680 `nnmail-split-fancy-with-parent-ignore-groups'."
681   (and group
682        (not (or (gnus-grep-in-list
683                  group
684                  gnus-registry-unfollowed-groups)
685                 (gnus-grep-in-list
686                  group
687                  nnmail-split-fancy-with-parent-ignore-groups)))))
688
689 ;; note that gnus-registry-ignored-groups is defined in gnus.el as a
690 ;; group/topic parameter and an associated variable!
691
692 ;; we do special logic for ignoring to accept regular expressions and
693 ;; nnmail-split-fancy-with-parent-ignore-groups as well
694 (defun gnus-registry-ignore-group-p (group)
695   "Determines if a group name should be ignored.
696 Consults `gnus-registry-ignored-groups' and
697 `nnmail-split-fancy-with-parent-ignore-groups'."
698   (and group
699        (or (gnus-grep-in-list
700             group
701             (delq nil (mapcar (lambda (g)
702                                 (cond
703                                  ((stringp g) g)
704                                  ((and (listp g) (nth 1 g))
705                                   (nth 0 g))
706                                  (t nil))) gnus-registry-ignored-groups)))
707            ;; only use `gnus-parameter-registry-ignore' if
708            ;; `gnus-registry-ignored-groups' is a list of lists
709            ;; (it can be a list of regexes)
710            (and (listp (nth 0 gnus-registry-ignored-groups))
711                 (get-buffer "*Group*")  ; in automatic tests this is false
712                 (gnus-parameter-registry-ignore group))
713            (gnus-grep-in-list
714             group
715             nnmail-split-fancy-with-parent-ignore-groups))))
716
717 (defun gnus-registry-wash-for-keywords (&optional force)
718   "Get the keywords of the current article.
719 Overrides existing keywords with FORCE set non-nil."
720   (interactive)
721   (let ((id (gnus-registry-fetch-message-id-fast gnus-current-article))
722         word words)
723     (if (or (not (gnus-registry-get-id-key id 'keyword))
724             force)
725         (with-current-buffer gnus-article-buffer
726           (article-goto-body)
727           (save-window-excursion
728             (save-restriction
729               (narrow-to-region (point) (point-max))
730               (with-syntax-table gnus-adaptive-word-syntax-table
731                 (while (re-search-forward "\\b\\w+\\b" nil t)
732                   (setq word (gnus-string-remove-all-properties
733                               (downcase (buffer-substring
734                                          (match-beginning 0) (match-end 0)))))
735                   (if (> (length word) 2)
736                       (push word words))))))
737           (gnus-registry-set-id-key id 'keyword words)))))
738
739 (defun gnus-registry-keywords ()
740   (let ((table (registry-lookup-secondary gnus-registry-db 'keyword)))
741     (when table (maphash (lambda (k v) k) table))))
742
743 (defun gnus-registry-find-keywords (keyword)
744   (interactive (list
745                 (completing-read "Keyword: " (gnus-registry-keywords) nil t)))
746   (registry-lookup-secondary-value gnus-registry-db 'keyword keyword))
747
748 (defun gnus-registry-register-message-ids ()
749   "Register the Message-ID of every article in the group."
750   (unless (gnus-parameter-registry-ignore gnus-newsgroup-name)
751     (dolist (article gnus-newsgroup-articles)
752       (let* ((id (gnus-registry-fetch-message-id-fast article))
753              (groups (gnus-registry-get-id-key id 'group)))
754         (unless (member gnus-newsgroup-name groups)
755           (gnus-message 9 "Registry: Registering article %d with group %s"
756                         article gnus-newsgroup-name)
757           (gnus-registry-handle-action id nil gnus-newsgroup-name
758            (gnus-registry-fetch-simplified-message-subject-fast article)
759            (gnus-registry-fetch-sender-fast article)
760            (gnus-registry-fetch-recipients-fast article)))))))
761
762 ;; message field fetchers
763 (defun gnus-registry-fetch-message-id-fast (article)
764   "Fetch the Message-ID quickly, using the internal gnus-data-list function."
765   (if (and (numberp article)
766            (assoc article (gnus-data-list nil)))
767       (mail-header-id (gnus-data-header (assoc article (gnus-data-list nil))))
768     nil))
769
770 (defun gnus-registry-extract-addresses (text)
771   "Extract all the addresses in a normalized way from TEXT.
772 Returns an unsorted list of strings in the name <address> format.
773 Addresses without a name will say \"noname\"."
774   (mapcar (lambda (add)
775             (gnus-string-remove-all-properties
776              (let* ((name (or (nth 0 add) "noname"))
777                     (addr (nth 1 add))
778                     (addr (if (bufferp addr)
779                               (with-current-buffer addr
780                                 (buffer-string))
781                             addr)))
782                (format "%s <%s>" name addr))))
783           (mail-extract-address-components text t)))
784
785 (defun gnus-registry-sort-addresses (&rest addresses)
786   "Return a normalized and sorted list of ADDRESSES."
787   (sort (apply 'nconc (mapcar 'gnus-registry-extract-addresses addresses))
788         'string-lessp))
789
790 (defun gnus-registry-simplify-subject (subject)
791   (if (stringp subject)
792       (gnus-simplify-subject subject)
793     nil))
794
795 (defun gnus-registry-fetch-simplified-message-subject-fast (article)
796   "Fetch the Subject quickly, using the internal gnus-data-list function."
797   (if (and (numberp article)
798            (assoc article (gnus-data-list nil)))
799       (gnus-string-remove-all-properties
800        (gnus-registry-simplify-subject
801         (mail-header-subject (gnus-data-header
802                               (assoc article (gnus-data-list nil))))))
803     nil))
804
805 (defun gnus-registry-fetch-sender-fast (article)
806   (gnus-registry-fetch-header-fast "from" article))
807
808 (defun gnus-registry-fetch-recipients-fast (article)
809   (gnus-registry-sort-addresses
810    (or (ignore-errors (gnus-registry-fetch-header-fast "Cc" article)) "")
811    (or (ignore-errors (gnus-registry-fetch-header-fast "To" article)) "")))
812
813 (defun gnus-registry-fetch-header-fast (article header)
814   "Fetch the HEADER quickly, using the internal gnus-data-list function."
815   (if (and (numberp article)
816            (assoc article (gnus-data-list nil)))
817       (gnus-string-remove-all-properties
818        (cdr (assq header (gnus-data-header
819                           (assoc article (gnus-data-list nil))))))
820     nil))
821
822 ;; registry marks glue
823 (defun gnus-registry-do-marks (type function)
824   "For each known mark, call FUNCTION for each cell of type TYPE.
825
826 FUNCTION should take two parameters, a mark symbol and the cell value."
827   (dolist (mark-info gnus-registry-marks)
828     (let* ((mark (car-safe mark-info))
829            (data (cdr-safe mark-info))
830            (cell-data (plist-get data type)))
831       (when cell-data
832         (funcall function mark cell-data)))))
833
834 ;; FIXME: Why not merge gnus-registry--set/remove-mark and
835 ;; gnus-registry-set-article-mark-internal?
836 (defun gnus-registry--set/remove-mark (remove mark articles)
837   "Set/remove the MARK over process-marked ARTICLES."
838   ;; If this is called and the user doesn't want the
839   ;; registry enabled, we'll ask anyhow.
840   (unless gnus-registry-install
841     (let ((gnus-registry-install 'ask))
842       (gnus-registry-install-p)))
843
844   ;; Now the user is asked if gnus-registry-install is `ask'.
845   (when (gnus-registry-install-p)
846     (gnus-registry-set-article-mark-internal
847      ;; All this just to get the mark, I must be doing it wrong.
848      mark articles remove t)
849     ;; FIXME: Why do we do the above only here and not directly inside
850     ;; gnus-registry-set-article-mark-internal?  I.e. we wouldn't we want to do
851     ;; the things below when gnus-registry-set-article-mark-internal is called
852     ;; from gnus-registry-set-article-mark or
853     ;; gnus-registry-remove-article-mark?
854     (gnus-message 9 "Applying mark %s to %d articles"
855                   mark (length articles))
856     (dolist (article articles)
857       (gnus-summary-update-article
858        article
859        (assoc article (gnus-data-list nil))))))
860
861 ;; This is ugly code, but I don't know how to do it better.
862 (defun gnus-registry-install-shortcuts ()
863   "Install the keyboard shortcuts and menus for the registry.
864 Uses `gnus-registry-marks' to find what shortcuts to install."
865   (let (keys-plist)
866     (setq gnus-registry-misc-menus nil)
867     (gnus-registry-do-marks
868      :char
869      (lambda (mark data)
870        (let ((function-format
871               (format "gnus-registry-%%s-article-%s-mark" mark)))
872
873 ;;;  The following generates these functions:
874 ;;;  (defun gnus-registry-set-article-Important-mark (&rest articles)
875 ;;;    "Apply the Important mark to process-marked ARTICLES."
876 ;;;    (interactive (gnus-summary-work-articles current-prefix-arg))
877 ;;;    (gnus-registry-set-article-mark-internal 'Important articles nil t))
878 ;;;  (defun gnus-registry-remove-article-Important-mark (&rest articles)
879 ;;;    "Apply the Important mark to process-marked ARTICLES."
880 ;;;    (interactive (gnus-summary-work-articles current-prefix-arg))
881 ;;;    (gnus-registry-set-article-mark-internal 'Important articles t t))
882
883          (dolist (remove '(t nil))
884            (let* ((variant-name (if remove "remove" "set"))
885                   (function-name
886                    (intern (format function-format variant-name)))
887                   (shortcut (format "%c" (if remove (upcase data) data))))
888              (defalias function-name
889                ;; If it weren't for the function's docstring, we could
890                ;; use a closure, with lexical-let :-(
891                `(lambda (&rest articles)
892                   ,(format
893                     "%s the %s mark over process-marked ARTICLES."
894                     (upcase-initials variant-name)
895                     mark)
896                   (interactive
897                    (gnus-summary-work-articles current-prefix-arg))
898                   (gnus-registry--set/remove-mark ',mark ',remove articles)))
899              (push function-name keys-plist)
900              (push shortcut keys-plist)
901              (push (vector (format "%s %s"
902                                    (upcase-initials variant-name)
903                                    (symbol-name mark))
904                            function-name t)
905                    gnus-registry-misc-menus)
906              (gnus-message 9 "Defined mark handling function %s"
907                            function-name))))))
908     (gnus-define-keys-1
909      '(gnus-registry-mark-map "M" gnus-summary-mark-map)
910      keys-plist)
911     (add-hook 'gnus-summary-menu-hook
912               (lambda ()
913                 (easy-menu-add-item
914                  gnus-summary-misc-menu
915                  nil
916                  (cons "Registry Marks" gnus-registry-misc-menus))))))
917
918 (make-obsolete 'gnus-registry-user-format-function-M
919                'gnus-registry-article-marks-to-chars "24.1") ?
920
921 (defalias 'gnus-registry-user-format-function-M
922   'gnus-registry-article-marks-to-chars)
923
924 ;; use like this:
925 ;; (defalias 'gnus-user-format-function-M 'gnus-registry-article-marks-to-chars)
926 (defun gnus-registry-article-marks-to-chars (headers)
927   "Show the marks for an article by the :char property."
928   (let* ((id (mail-header-message-id headers))
929          (marks (when id (gnus-registry-get-id-key id 'mark))))
930     (mapconcat (lambda (mark)
931                  (plist-get
932                   (cdr-safe
933                    (assoc mark gnus-registry-marks))
934                   :char))
935                marks "")))
936
937 ;; use like this:
938 ;; (defalias 'gnus-user-format-function-M 'gnus-registry-article-marks-to-names)
939 (defun gnus-registry-article-marks-to-names (headers)
940   "Show the marks for an article by name."
941   (let* ((id (mail-header-message-id headers))
942          (marks (when id (gnus-registry-get-id-key id 'mark))))
943     (mapconcat (lambda (mark) (symbol-name mark)) marks ",")))
944
945 (defun gnus-registry-read-mark ()
946   "Read a mark name from the user with completion."
947   (let ((mark (gnus-completing-read
948                "Label"
949                (mapcar 'symbol-name (mapcar 'car gnus-registry-marks))
950                nil nil nil
951                (symbol-name gnus-registry-default-mark))))
952     (when (stringp mark)
953       (intern mark))))
954
955 (defun gnus-registry-set-article-mark (&rest articles)
956   "Apply a mark to process-marked ARTICLES."
957   (interactive (gnus-summary-work-articles current-prefix-arg))
958   (gnus-registry-set-article-mark-internal (gnus-registry-read-mark)
959                                            articles nil t))
960
961 (defun gnus-registry-remove-article-mark (&rest articles)
962   "Remove a mark from process-marked ARTICLES."
963   (interactive (gnus-summary-work-articles current-prefix-arg))
964   (gnus-registry-set-article-mark-internal (gnus-registry-read-mark)
965                                            articles t t))
966
967 (defun gnus-registry-set-article-mark-internal (mark
968                                                 articles
969                                                 &optional remove
970                                                 show-message)
971   "Apply or remove MARK across a list of ARTICLES."
972   (let ((article-id-list
973          (mapcar 'gnus-registry-fetch-message-id-fast articles)))
974     (dolist (id article-id-list)
975       (let* ((marks (delq mark (gnus-registry-get-id-key id 'mark)))
976              (marks (if remove marks (cons mark marks))))
977         (when show-message
978           (gnus-message 1 "%s mark %s with message ID %s, resulting in %S"
979                         (if remove "Removing" "Adding")
980                         mark id marks))
981         (gnus-registry-set-id-key id 'mark marks)))))
982
983 (defun gnus-registry-get-article-marks (&rest articles)
984   "Get the Gnus registry marks for ARTICLES and show them if interactive.
985 Uses process/prefix conventions.  For multiple articles,
986 only the last one's marks are returned."
987   (interactive (gnus-summary-work-articles 1))
988   (let* ((article (last articles))
989          (id (gnus-registry-fetch-message-id-fast article))
990          (marks (when id (gnus-registry-get-id-key id 'mark))))
991     (when (gmm-called-interactively-p 'any)
992       (gnus-message 1 "Marks are %S" marks))
993     marks))
994
995 (defun gnus-registry-group-count (id)
996   "Get the number of groups of a message, based on the message ID."
997   (length (gnus-registry-get-id-key id 'group)))
998
999 (defun gnus-registry-get-or-make-entry (id)
1000   (let* ((db gnus-registry-db)
1001          ;; safe if not found
1002          (entries (registry-lookup db (list id))))
1003
1004     (when (null entries)
1005       (gnus-registry-insert db id (list (list 'creation-time (current-time))
1006                                         '(group) '(sender) '(subject)))
1007       (setq entries (registry-lookup db (list id))))
1008
1009     (nth 1 (assoc id entries))))
1010
1011 (defun gnus-registry-delete-entries (idlist)
1012   (registry-delete gnus-registry-db idlist nil))
1013
1014 (defun gnus-registry-get-id-key (id key)
1015   (cdr-safe (assq key (gnus-registry-get-or-make-entry id))))
1016
1017 (defun gnus-registry-set-id-key (id key vals)
1018   (let* ((db gnus-registry-db)
1019          (entry (gnus-registry-get-or-make-entry id)))
1020     (registry-delete db (list id) nil)
1021     (setq entry (cons (cons key vals) (assq-delete-all key entry)))
1022     (gnus-registry-insert db id entry)
1023     entry))
1024
1025 (defun gnus-registry-insert (db id entry)
1026   "Just like `registry-insert' but tries to prune on error."
1027   (when (registry-full db)
1028     (message "Trying to prune the registry because it's full")
1029     (registry-prune db))
1030   (registry-insert db id entry)
1031   entry)
1032
1033 (defun gnus-registry-import-eld (file)
1034   (interactive "fOld registry file to import? ")
1035   ;; example content:
1036   ;;   (setq gnus-registry-alist '(
1037   ;; ("<messageID>" ((marks nil)
1038   ;;                 (mtime 19365 1776 440496)
1039   ;;                 (sender . "root (Cron Daemon)")
1040   ;;                 (subject . "Cron"))
1041   ;;  "cron" "nnml+private:cron")
1042   (load file t)
1043   (when (boundp 'gnus-registry-alist)
1044     (let* ((old (symbol-value 'gnus-registry-alist))
1045            (count 0)
1046            (expected (length old))
1047            entry)
1048       (while (car-safe old)
1049         (incf count)
1050         ;; don't use progress reporters for backwards compatibility
1051         (when (and (< 0 expected)
1052                    (= 0 (mod count 100)))
1053           (message "importing: %d of %d (%.2f%%)"
1054                    count expected (/ (* 100 count) expected)))
1055         (setq entry (car-safe old)
1056               old (cdr-safe old))
1057         (let* ((id (car-safe entry))
1058                (new-entry (gnus-registry-get-or-make-entry id))
1059                (rest (cdr-safe entry))
1060                (groups (loop for p in rest
1061                              when (stringp p)
1062                              collect p))
1063                extra-cell key val)
1064           ;; remove all the strings from the entry
1065           (dolist (elem rest)
1066             (if (stringp elem) (setq rest (delq elem rest))))
1067           (gnus-registry-set-id-key id 'group groups)
1068           ;; just use the first extra element
1069           (setq rest (car-safe rest))
1070           (while (car-safe rest)
1071             (setq extra-cell (car-safe rest)
1072                   key (car-safe extra-cell)
1073                   val (cdr-safe extra-cell)
1074                   rest (cdr-safe rest))
1075             (when (and val (atom val))
1076               (setq val (list val)))
1077             (gnus-registry-set-id-key id key val))))
1078       (message "Import done, collected %d entries" count))))
1079
1080 ;;;###autoload
1081 (defun gnus-registry-initialize ()
1082   "Initialize the Gnus registry."
1083   (interactive)
1084   (gnus-message 5 "Initializing the registry")
1085   (gnus-registry-install-hooks)
1086   (gnus-registry-install-shortcuts)
1087   (gnus-registry-read))
1088
1089 ;; FIXME: Why autoload this function?
1090 ;;;###autoload
1091 (defun gnus-registry-install-hooks ()
1092   "Install the registry hooks."
1093   (interactive)
1094   (setq gnus-registry-enabled t)
1095   (add-hook 'gnus-summary-article-move-hook 'gnus-registry-action)
1096   (add-hook 'gnus-summary-article-delete-hook 'gnus-registry-action)
1097   (add-hook 'gnus-summary-article-expire-hook 'gnus-registry-action)
1098   (add-hook 'nnmail-spool-hook 'gnus-registry-spool-action)
1099
1100   (add-hook 'gnus-save-newsrc-hook 'gnus-registry-save)
1101   (add-hook 'gnus-read-newsrc-el-hook 'gnus-registry-read)
1102
1103   (add-hook 'gnus-summary-prepare-hook 'gnus-registry-register-message-ids))
1104
1105 (defun gnus-registry-unload-hook ()
1106   "Uninstall the registry hooks."
1107   (interactive)
1108   (remove-hook 'gnus-summary-article-move-hook 'gnus-registry-action)
1109   (remove-hook 'gnus-summary-article-delete-hook 'gnus-registry-action)
1110   (remove-hook 'gnus-summary-article-expire-hook 'gnus-registry-action)
1111   (remove-hook 'nnmail-spool-hook 'gnus-registry-spool-action)
1112
1113   (remove-hook 'gnus-save-newsrc-hook 'gnus-registry-save)
1114   (remove-hook 'gnus-read-newsrc-el-hook 'gnus-registry-read)
1115
1116   (remove-hook 'gnus-summary-prepare-hook 'gnus-registry-register-message-ids)
1117   (setq gnus-registry-enabled nil))
1118
1119 (add-hook 'gnus-registry-unload-hook 'gnus-registry-unload-hook)
1120
1121 (defun gnus-registry-install-p ()
1122   "If the registry is not already enabled, and `gnus-registry-install' is t,
1123 the registry is enabled.  If `gnus-registry-install' is `ask',
1124 the user is asked first.  Returns non-nil iff the registry is enabled."
1125   (interactive)
1126   (unless gnus-registry-enabled
1127     (when (if (eq gnus-registry-install 'ask)
1128               (gnus-y-or-n-p
1129                (concat "Enable the Gnus registry?  "
1130                        "See the variable `gnus-registry-install' "
1131                        "to get rid of this query permanently. "))
1132             gnus-registry-install)
1133       (gnus-registry-initialize)))
1134   gnus-registry-enabled)
1135
1136 ;; largely based on nnir-warp-to-article
1137 (defun gnus-try-warping-via-registry ()
1138   "Try to warp via the registry.
1139 This will be done via the current article's source group based on
1140 data stored in the registry."
1141   (interactive)
1142   (when (gnus-summary-article-header)
1143     (let* ((message-id (mail-header-id (gnus-summary-article-header)))
1144            ;; Retrieve the message's group(s) from the registry
1145            (groups (gnus-registry-get-id-key message-id 'group))
1146            ;; If starting from an ephemeral group, this describes
1147            ;; how to restore the window configuration
1148            (quit-config
1149             (gnus-ephemeral-group-p gnus-newsgroup-name))
1150            (seen-groups (list (gnus-group-group-name))))
1151
1152       (catch 'found
1153         (dolist (group (mapcar 'gnus-simplify-group-name groups))
1154
1155           ;; skip over any groups we really don't want to warp to.
1156           (unless (or (member group seen-groups)
1157                       (gnus-ephemeral-group-p group) ;; any ephemeral group
1158                       (memq (car (gnus-find-method-for-group group))
1159                             ;; Specific methods; this list may need to expand.
1160                             '(nnir)))
1161
1162             ;; remember that we've seen this group already
1163             (push group seen-groups)
1164
1165             ;; first exit from any ephemeral summary buffer.
1166             (when quit-config
1167               (gnus-summary-exit)
1168               ;; and if the ephemeral summary buffer in turn came from
1169               ;; another summary buffer we have to clean that summary
1170               ;; up too.
1171               (when (eq (cdr quit-config) 'summary)
1172                 (gnus-summary-exit))
1173               ;; remember that we've already done this part
1174               (setq quit-config nil))
1175
1176             ;; Try to activate the group.  If that fails, just move
1177             ;; along.  We may have more groups to work with
1178             (when
1179                 (ignore-errors
1180                   (gnus-select-group-with-message-id group message-id) t)
1181               (throw 'found t))))))))
1182
1183 ;; TODO: a few things
1184
1185 (provide 'gnus-registry)
1186
1187 ;;; gnus-registry.el ends here