71e00967548beaf70d22c462d885c7cd9f05c68b
[gnus] / lisp / gnus-registry.el
1 ;;; gnus-registry.el --- article registry for Gnus
2
3 ;; Copyright (C) 2002-2012  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 (gnus-registry-fixup-registry
300                                   (eieio-persistent-read file)))
301           (gnus-message 5 "Reading Gnus registry from %s...done" file))
302       (error
303        (gnus-message
304         1
305         "The Gnus registry could not be loaded from %s, creating a new one"
306         file)
307        (gnus-registry-remake-db t)))))
308
309 (defun gnus-registry-save (&optional file db)
310   "Save the registry cache file."
311   (interactive)
312   (let ((file (or file gnus-registry-cache-file))
313         (db (or db gnus-registry-db)))
314     (gnus-message 5 "Saving Gnus registry (%d entries) to %s..."
315                   (registry-size db) file)
316     (registry-prune db)
317     ;; TODO: call (gnus-string-remove-all-properties v) on all elements?
318     (eieio-persistent-save db file)
319     (gnus-message 5 "Saving Gnus registry (size %d) to %s...done"
320                   (registry-size db) file)))
321
322 (defun gnus-registry-remove-ignored ()
323   (interactive)
324   (let* ((db gnus-registry-db)
325          (grouphashtb (registry-lookup-secondary db 'group))
326          (old-size (registry-size db)))
327     (registry-reindex db)
328     (loop for k being the hash-keys of grouphashtb
329           using (hash-values v)
330           when (gnus-registry-ignore-group-p k)
331           do (registry-delete db v nil))
332     (registry-reindex db)
333     (gnus-message 4 "Removed %d ignored entries from the Gnus registry"
334                   (- old-size (registry-size db)))))
335
336 ;; article move/copy/spool/delete actions
337 (defun gnus-registry-action (action data-header from &optional to method)
338   (let* ((id (mail-header-id data-header))
339          (subject (mail-header-subject data-header))
340          (extra (mail-header-extra data-header))
341          (recipients (gnus-registry-sort-addresses
342                       (or (cdr-safe (assq 'Cc extra)) "")
343                       (or (cdr-safe (assq 'To extra)) "")))
344          (sender (nth 0 (gnus-registry-extract-addresses
345                          (mail-header-from data-header))))
346          (from (gnus-group-guess-full-name-from-command-method from))
347          (to (if to (gnus-group-guess-full-name-from-command-method to) nil))
348          (to-name (if to to "the Bit Bucket")))
349     (gnus-message 7 "Gnus registry: article %s %s from %s to %s"
350                   id (if method "respooling" "going") from to)
351
352     (gnus-registry-handle-action
353      id
354      ;; unless copying, remove the old "from" group
355      (if (not (equal 'copy action)) from nil)
356      to subject sender recipients)))
357
358 (defun gnus-registry-spool-action (id group &optional subject sender recipients)
359   (let ((to (gnus-group-guess-full-name-from-command-method group))
360         (recipients (or recipients
361                         (gnus-registry-sort-addresses
362                          (or (message-fetch-field "cc") "")
363                          (or (message-fetch-field "to") ""))))
364         (subject (or subject (message-fetch-field "subject")))
365         (sender (or sender (message-fetch-field "from"))))
366     (when (and (stringp id) (string-match "\r$" id))
367       (setq id (substring id 0 -1)))
368     (gnus-message 7 "Gnus registry: article %s spooled to %s"
369                   id
370                   to)
371     (gnus-registry-handle-action id nil to subject sender recipients)))
372
373 (defun gnus-registry-handle-action (id from to subject sender
374                                        &optional recipients)
375   (gnus-message
376    10
377    "gnus-registry-handle-action %S" (list id from to subject sender recipients))
378   (let ((db gnus-registry-db)
379         ;; if the group is ignored, set the destination to nil (same as delete)
380         (to (if (gnus-registry-ignore-group-p to) nil to))
381         ;; safe if not found
382         (entry (gnus-registry-get-or-make-entry id))
383         (subject (gnus-string-remove-all-properties
384                   (gnus-registry-simplify-subject subject)))
385         (sender (gnus-string-remove-all-properties sender)))
386
387     ;; this could be done by calling `gnus-registry-set-id-key'
388     ;; several times but it's better to bunch the transactions
389     ;; together
390
391     (registry-delete db (list id) nil)
392     (when from
393       (setq entry (cons (delete from (assoc 'group entry))
394                         (assq-delete-all 'group entry))))
395
396     (dolist (kv `((group ,to)
397                   (sender ,sender)
398                   (recipient ,@recipients)
399                   (subject ,subject)))
400       (when (second kv)
401         (let ((new (or (assq (first kv) entry)
402                        (list (first kv)))))
403           (dolist (toadd (cdr kv))
404             (add-to-list 'new toadd t))
405           (setq entry (cons new
406                             (assq-delete-all (first kv) entry))))))
407     (gnus-message 10 "Gnus registry: new entry for %s is %S"
408                   id
409                   entry)
410     (gnus-registry-insert db id entry)))
411
412 ;; Function for nn{mail|imap}-split-fancy: look up all references in
413 ;; the cache and if a match is found, return that group.
414 (defun gnus-registry-split-fancy-with-parent ()
415   "Split this message into the same group as its parent.
416 The parent is obtained from the registry.  This function can be used as an
417 entry in `nnmail-split-fancy' or `nnimap-split-fancy', for example like
418 this: (: gnus-registry-split-fancy-with-parent)
419
420 This function tracks ALL backends, unlike
421 `nnmail-split-fancy-with-parent' which tracks only nnmail
422 messages.
423
424 For a message to be split, it looks for the parent message in the
425 References or In-Reply-To header and then looks in the registry
426 to see which group that message was put in.  This group is
427 returned, unless `gnus-registry-follow-group-p' return nil for
428 that group.
429
430 See the Info node `(gnus)Fancy Mail Splitting' for more details."
431   (let* ((refstr (or (message-fetch-field "references") "")) ; guaranteed
432          (reply-to (message-fetch-field "in-reply-to"))      ; may be nil
433          ;; now, if reply-to is valid, append it to the References
434          (refstr (if reply-to
435                      (concat refstr " " reply-to)
436                    refstr))
437          (references (and refstr (gnus-extract-references refstr)))
438          ;; these may not be used, but the code is cleaner having them up here
439          (sender (gnus-string-remove-all-properties
440                   (message-fetch-field "from")))
441          (recipients (gnus-registry-sort-addresses
442                       (or (message-fetch-field "cc") "")
443                       (or (message-fetch-field "to") "")))
444          (subject (gnus-string-remove-all-properties
445                    (gnus-registry-simplify-subject
446                     (message-fetch-field "subject"))))
447
448          (nnmail-split-fancy-with-parent-ignore-groups
449           (if (listp nnmail-split-fancy-with-parent-ignore-groups)
450               nnmail-split-fancy-with-parent-ignore-groups
451             (list nnmail-split-fancy-with-parent-ignore-groups))))
452     (gnus-registry--split-fancy-with-parent-internal
453      :references references
454      :refstr refstr
455      :sender sender
456      :recipients recipients
457      :subject subject
458      :log-agent "Gnus registry fancy splitting with parent")))
459
460 (defun* gnus-registry--split-fancy-with-parent-internal
461     (&rest spec
462            &key references refstr sender subject recipients log-agent
463            &allow-other-keys)
464   (gnus-message
465    10
466    "gnus-registry--split-fancy-with-parent-internal %S" spec)
467   (let ((db gnus-registry-db)
468         found)
469     ;; this is a big chain of statements.  it uses
470     ;; gnus-registry-post-process-groups to filter the results after
471     ;; every step.
472     ;; the references string must be valid and parse to valid references
473     (when references
474       (gnus-message
475        9
476        "%s is tracing references %s"
477        log-agent refstr)
478       (dolist (reference (nreverse references))
479         (gnus-message 9 "%s is looking up %s" log-agent reference)
480         (loop for group in (gnus-registry-get-id-key reference 'group)
481               when (gnus-registry-follow-group-p group)
482               do
483               (progn
484                 (gnus-message 7 "%s traced %s to %s" log-agent reference group)
485                 (push group found))))
486       ;; filter the found groups and return them
487       ;; the found groups are the full groups
488       (setq found (gnus-registry-post-process-groups
489                    "references" refstr found)))
490
491      ;; else: there were no matches, now try the extra tracking by subject
492      (when (and (null found)
493                 (memq 'subject gnus-registry-track-extra)
494                 subject
495                 (< gnus-registry-minimum-subject-length (length subject)))
496        (let ((groups (apply
497                       'append
498                       (mapcar
499                        (lambda (reference)
500                          (gnus-registry-get-id-key reference 'group))
501                        (registry-lookup-secondary-value db 'subject subject)))))
502          (setq found
503                (loop for group in groups
504                      when (gnus-registry-follow-group-p group)
505                      do (gnus-message
506                          ;; warn more if gnus-registry-track-extra
507                          (if gnus-registry-track-extra 7 9)
508                          "%s (extra tracking) traced subject '%s' to %s"
509                          log-agent subject group)
510                     and collect group))
511          ;; filter the found groups and return them
512          ;; the found groups are NOT the full groups
513          (setq found (gnus-registry-post-process-groups
514                       "subject" subject found))))
515
516      ;; else: there were no matches, try the extra tracking by sender
517      (when (and (null found)
518                 (memq 'sender gnus-registry-track-extra)
519                 sender
520                 (not (gnus-grep-in-list
521                       sender
522                       gnus-registry-unfollowed-addresses)))
523        (let ((groups (apply
524                       'append
525                       (mapcar
526                        (lambda (reference)
527                          (gnus-registry-get-id-key reference 'group))
528                        (registry-lookup-secondary-value db 'sender sender)))))
529          (setq found
530                (loop for group in groups
531                      when (gnus-registry-follow-group-p group)
532                      do (gnus-message
533                          ;; warn more if gnus-registry-track-extra
534                          (if gnus-registry-track-extra 7 9)
535                          "%s (extra tracking) traced sender '%s' to %s"
536                          log-agent sender group)
537                      and collect group)))
538
539        ;; filter the found groups and return them
540        ;; the found groups are NOT the full groups
541        (setq found (gnus-registry-post-process-groups
542                     "sender" sender found)))
543
544      ;; else: there were no matches, try the extra tracking by recipient
545      (when (and (null found)
546                 (memq 'recipient gnus-registry-track-extra)
547                 recipients)
548        (dolist (recp recipients)
549          (when (and (null found)
550                     (not (gnus-grep-in-list
551                           recp
552                           gnus-registry-unfollowed-addresses)))
553            (let ((groups (apply 'append
554                                 (mapcar
555                                  (lambda (reference)
556                                    (gnus-registry-get-id-key reference 'group))
557                                  (registry-lookup-secondary-value
558                                   db 'recipient recp)))))
559              (setq found
560                    (loop for group in groups
561                          when (gnus-registry-follow-group-p group)
562                          do (gnus-message
563                              ;; warn more if gnus-registry-track-extra
564                              (if gnus-registry-track-extra 7 9)
565                              "%s (extra tracking) traced recipient '%s' to %s"
566                              log-agent recp group)
567                         and collect group)))))
568
569        ;; filter the found groups and return them
570        ;; the found groups are NOT the full groups
571        (setq found (gnus-registry-post-process-groups
572                     "recipients" (mapconcat 'identity recipients ", ") found)))
573
574      ;; after the (cond) we extract the actual value safely
575      (car-safe found)))
576
577 (defun gnus-registry-post-process-groups (mode key groups)
578   "Inspects GROUPS found by MODE for KEY to determine which ones to follow.
579
580 MODE can be 'subject' or 'sender' for example.  The KEY is the
581 value by which MODE was searched.
582
583 Transforms each group name to the equivalent short name.
584
585 Checks if the current Gnus method (from `gnus-command-method' or
586 from `gnus-newsgroup-name') is the same as the group's method.
587 Foreign methods are not supported so they are rejected.
588
589 Reduces the list to a single group, or complains if that's not
590 possible.  Uses `gnus-registry-split-strategy'."
591   (let ((log-agent "gnus-registry-post-process-group")
592         (desc (format "%d groups" (length groups)))
593         out chosen)
594     ;; the strategy can be nil, in which case chosen is nil
595     (setq chosen
596           (case gnus-registry-split-strategy
597             ;; default, take only one-element lists into chosen
598             ((nil)
599              (and (= (length groups) 1)
600                   (car-safe groups)))
601
602             ((first)
603              (car-safe groups))
604
605             ((majority)
606              (let ((freq (make-hash-table
607                           :size 256
608                           :test 'equal)))
609                (mapc (lambda (x) (let ((x (gnus-group-short-name x)))
610                               (puthash x (1+ (gethash x freq 0)) freq)))
611                      groups)
612                (setq desc (format "%d groups, %d unique"
613                                   (length groups)
614                                   (hash-table-count freq)))
615                (car-safe
616                 (sort groups
617                       (lambda (a b)
618                         (> (gethash (gnus-group-short-name a) freq 0)
619                            (gethash (gnus-group-short-name b) freq 0)))))))))
620
621     (if chosen
622         (gnus-message
623          9
624          "%s: strategy %s on %s produced %s"
625          log-agent gnus-registry-split-strategy desc chosen)
626       (gnus-message
627        9
628        "%s: strategy %s on %s did not produce an answer"
629        log-agent
630        (or gnus-registry-split-strategy "default")
631        desc))
632
633     (setq groups (and chosen (list chosen)))
634
635     (dolist (group groups)
636       (let ((m1 (gnus-find-method-for-group group))
637             (m2 (or gnus-command-method
638                     (gnus-find-method-for-group gnus-newsgroup-name)))
639             (short-name (gnus-group-short-name group)))
640         (if (gnus-methods-equal-p m1 m2)
641             (progn
642               ;; this is REALLY just for debugging
643               (when (not (equal group short-name))
644                 (gnus-message
645                  10
646                  "%s: stripped group %s to %s"
647                  log-agent group short-name))
648               (add-to-list 'out short-name))
649           ;; else...
650           (gnus-message
651            7
652            "%s: ignored foreign group %s"
653            log-agent group))))
654
655     (setq out (delq nil out))
656
657     (cond
658      ((= (length out) 1) out)
659      ((null out)
660       (gnus-message
661        5
662        "%s: no matches for %s '%s'."
663        log-agent mode key)
664       nil)
665      (t (gnus-message
666          5
667          "%s: too many extra matches (%s) for %s '%s'.  Returning none."
668          log-agent out mode key)
669         nil))))
670
671 (defun gnus-registry-follow-group-p (group)
672   "Determines if a group name should be followed.
673 Consults `gnus-registry-unfollowed-groups' and
674 `nnmail-split-fancy-with-parent-ignore-groups'."
675   (and group
676        (not (or (gnus-grep-in-list
677                  group
678                  gnus-registry-unfollowed-groups)
679                 (gnus-grep-in-list
680                  group
681                  nnmail-split-fancy-with-parent-ignore-groups)))))
682
683 ;; note that gnus-registry-ignored-groups is defined in gnus.el as a
684 ;; group/topic parameter and an associated variable!
685
686 ;; we do special logic for ignoring to accept regular expressions and
687 ;; nnmail-split-fancy-with-parent-ignore-groups as well
688 (defun gnus-registry-ignore-group-p (group)
689   "Determines if a group name should be ignored.
690 Consults `gnus-registry-ignored-groups' and
691 `nnmail-split-fancy-with-parent-ignore-groups'."
692   (and group
693        (or (gnus-grep-in-list
694             group
695             (delq nil (mapcar (lambda (g)
696                                 (cond
697                                  ((stringp g) g)
698                                  ((and (listp g) (nth 1 g))
699                                   (nth 0 g))
700                                  (t nil))) gnus-registry-ignored-groups)))
701            ;; only use `gnus-parameter-registry-ignore' if
702            ;; `gnus-registry-ignored-groups' is a list of lists
703            ;; (it can be a list of regexes)
704            (and (listp (nth 0 gnus-registry-ignored-groups))
705                 (get-buffer "*Group*")  ; in automatic tests this is false
706                 (gnus-parameter-registry-ignore group))
707            (gnus-grep-in-list
708             group
709             nnmail-split-fancy-with-parent-ignore-groups))))
710
711 (defun gnus-registry-wash-for-keywords (&optional force)
712   "Get the keywords of the current article.
713 Overrides existing keywords with FORCE set non-nil."
714   (interactive)
715   (let ((id (gnus-registry-fetch-message-id-fast gnus-current-article))
716         word words)
717     (if (or (not (gnus-registry-get-id-key id 'keyword))
718             force)
719         (with-current-buffer gnus-article-buffer
720           (article-goto-body)
721           (save-window-excursion
722             (save-restriction
723               (narrow-to-region (point) (point-max))
724               (with-syntax-table gnus-adaptive-word-syntax-table
725                 (while (re-search-forward "\\b\\w+\\b" nil t)
726                   (setq word (gnus-string-remove-all-properties
727                               (downcase (buffer-substring
728                                          (match-beginning 0) (match-end 0)))))
729                   (if (> (length word) 2)
730                       (push word words))))))
731           (gnus-registry-set-id-key id 'keyword words)))))
732
733 (defun gnus-registry-keywords ()
734   (let ((table (registry-lookup-secondary gnus-registry-db 'keyword)))
735     (when table (maphash (lambda (k v) k) table))))
736
737 (defun gnus-registry-find-keywords (keyword)
738   (interactive (list
739                 (completing-read "Keyword: " (gnus-registry-keywords) nil t)))
740   (registry-lookup-secondary-value gnus-registry-db 'keyword keyword))
741
742 (defun gnus-registry-register-message-ids ()
743   "Register the Message-ID of every article in the group."
744   (unless (gnus-parameter-registry-ignore gnus-newsgroup-name)
745     (dolist (article gnus-newsgroup-articles)
746       (let* ((id (gnus-registry-fetch-message-id-fast article))
747              (groups (gnus-registry-get-id-key id 'group)))
748         (unless (member gnus-newsgroup-name groups)
749           (gnus-message 9 "Registry: Registering article %d with group %s"
750                         article gnus-newsgroup-name)
751           (gnus-registry-handle-action id nil gnus-newsgroup-name
752            (gnus-registry-fetch-simplified-message-subject-fast article)
753            (gnus-registry-fetch-sender-fast article)
754            (gnus-registry-fetch-recipients-fast article)))))))
755
756 ;; message field fetchers
757 (defun gnus-registry-fetch-message-id-fast (article)
758   "Fetch the Message-ID quickly, using the internal gnus-data-list function."
759   (if (and (numberp article)
760            (assoc article (gnus-data-list nil)))
761       (mail-header-id (gnus-data-header (assoc article (gnus-data-list nil))))
762     nil))
763
764 (defun gnus-registry-extract-addresses (text)
765   "Extract all the addresses in a normalized way from TEXT.
766 Returns an unsorted list of strings in the name <address> format.
767 Addresses without a name will say \"noname\"."
768   (mapcar (lambda (add)
769             (gnus-string-remove-all-properties
770              (let* ((name (or (nth 0 add) "noname"))
771                     (addr (nth 1 add))
772                     (addr (if (bufferp addr)
773                               (with-current-buffer addr
774                                 (buffer-string))
775                             addr)))
776                (format "%s <%s>" name addr))))
777           (mail-extract-address-components text t)))
778
779 (defun gnus-registry-sort-addresses (&rest addresses)
780   "Return a normalized and sorted list of ADDRESSES."
781   (sort (apply 'nconc (mapcar 'gnus-registry-extract-addresses addresses))
782         'string-lessp))
783
784 (defun gnus-registry-simplify-subject (subject)
785   (if (stringp subject)
786       (gnus-simplify-subject subject)
787     nil))
788
789 (defun gnus-registry-fetch-simplified-message-subject-fast (article)
790   "Fetch the Subject quickly, using the internal gnus-data-list function."
791   (if (and (numberp article)
792            (assoc article (gnus-data-list nil)))
793       (gnus-string-remove-all-properties
794        (gnus-registry-simplify-subject
795         (mail-header-subject (gnus-data-header
796                               (assoc article (gnus-data-list nil))))))
797     nil))
798
799 (defun gnus-registry-fetch-sender-fast (article)
800   (gnus-registry-fetch-header-fast "from" article))
801
802 (defun gnus-registry-fetch-recipients-fast (article)
803   (gnus-registry-sort-addresses
804    (or (ignore-errors (gnus-registry-fetch-header-fast "Cc" article)) "")
805    (or (ignore-errors (gnus-registry-fetch-header-fast "To" article)) "")))
806
807 (defun gnus-registry-fetch-header-fast (article header)
808   "Fetch the HEADER quickly, using the internal gnus-data-list function."
809   (if (and (numberp article)
810            (assoc article (gnus-data-list nil)))
811       (gnus-string-remove-all-properties
812        (cdr (assq header (gnus-data-header
813                           (assoc article (gnus-data-list nil))))))
814     nil))
815
816 ;; registry marks glue
817 (defun gnus-registry-do-marks (type function)
818   "For each known mark, call FUNCTION for each cell of type TYPE.
819
820 FUNCTION should take two parameters, a mark symbol and the cell value."
821   (dolist (mark-info gnus-registry-marks)
822     (let* ((mark (car-safe mark-info))
823            (data (cdr-safe mark-info))
824            (cell-data (plist-get data type)))
825       (when cell-data
826         (funcall function mark cell-data)))))
827
828 ;; FIXME: Why not merge gnus-registry--set/remove-mark and
829 ;; gnus-registry-set-article-mark-internal?
830 (defun gnus-registry--set/remove-mark (remove mark articles)
831   "Set/remove the MARK over process-marked ARTICLES."
832   ;; If this is called and the user doesn't want the
833   ;; registry enabled, we'll ask anyhow.
834   (unless gnus-registry-install
835     (let ((gnus-registry-install 'ask))
836       (gnus-registry-install-p)))
837
838   ;; Now the user is asked if gnus-registry-install is `ask'.
839   (when (gnus-registry-install-p)
840     (gnus-registry-set-article-mark-internal
841      ;; All this just to get the mark, I must be doing it wrong.
842      mark articles remove t)
843     ;; FIXME: Why do we do the above only here and not directly inside
844     ;; gnus-registry-set-article-mark-internal?  I.e. we wouldn't we want to do
845     ;; the things below when gnus-registry-set-article-mark-internal is called
846     ;; from gnus-registry-set-article-mark or
847     ;; gnus-registry-remove-article-mark?
848     (gnus-message 9 "Applying mark %s to %d articles"
849                   mark (length articles))
850     (dolist (article articles)
851       (gnus-summary-update-article
852        article
853        (assoc article (gnus-data-list nil))))))
854
855 ;; This is ugly code, but I don't know how to do it better.
856 (defun gnus-registry-install-shortcuts ()
857   "Install the keyboard shortcuts and menus for the registry.
858 Uses `gnus-registry-marks' to find what shortcuts to install."
859   (let (keys-plist)
860     (setq gnus-registry-misc-menus nil)
861     (gnus-registry-do-marks
862      :char
863      (lambda (mark data)
864        (let ((function-format
865               (format "gnus-registry-%%s-article-%s-mark" mark)))
866
867 ;;;  The following generates these functions:
868 ;;;  (defun gnus-registry-set-article-Important-mark (&rest articles)
869 ;;;    "Apply the Important mark to process-marked ARTICLES."
870 ;;;    (interactive (gnus-summary-work-articles current-prefix-arg))
871 ;;;    (gnus-registry-set-article-mark-internal 'Important articles nil t))
872 ;;;  (defun gnus-registry-remove-article-Important-mark (&rest articles)
873 ;;;    "Apply the Important mark to process-marked ARTICLES."
874 ;;;    (interactive (gnus-summary-work-articles current-prefix-arg))
875 ;;;    (gnus-registry-set-article-mark-internal 'Important articles t t))
876
877          (dolist (remove '(t nil))
878            (let* ((variant-name (if remove "remove" "set"))
879                   (function-name
880                    (intern (format function-format variant-name)))
881                   (shortcut (format "%c" (if remove (upcase data) data))))
882              (defalias function-name
883                ;; If it weren't for the function's docstring, we could
884                ;; use a closure, with lexical-let :-(
885                `(lambda (&rest articles)
886                   ,(format
887                     "%s the %s mark over process-marked ARTICLES."
888                     (upcase-initials variant-name)
889                     mark)
890                   (interactive
891                    (gnus-summary-work-articles current-prefix-arg))
892                   (gnus-registry--set/remove-mark ',mark ',remove articles)))
893              (push function-name keys-plist)
894              (push shortcut keys-plist)
895              (push (vector (format "%s %s"
896                                    (upcase-initials variant-name)
897                                    (symbol-name mark))
898                            function-name t)
899                    gnus-registry-misc-menus)
900              (gnus-message 9 "Defined mark handling function %s"
901                            function-name))))))
902     (gnus-define-keys-1
903      '(gnus-registry-mark-map "M" gnus-summary-mark-map)
904      keys-plist)
905     (add-hook 'gnus-summary-menu-hook
906               (lambda ()
907                 (easy-menu-add-item
908                  gnus-summary-misc-menu
909                  nil
910                  (cons "Registry Marks" gnus-registry-misc-menus))))))
911
912 (make-obsolete 'gnus-registry-user-format-function-M
913                'gnus-registry-article-marks-to-chars "24.1") ?
914
915 (defalias 'gnus-registry-user-format-function-M
916   'gnus-registry-article-marks-to-chars)
917
918 ;; use like this:
919 ;; (defalias 'gnus-user-format-function-M 'gnus-registry-article-marks-to-chars)
920 (defun gnus-registry-article-marks-to-chars (headers)
921   "Show the marks for an article by the :char property."
922   (let* ((id (mail-header-message-id headers))
923          (marks (when id (gnus-registry-get-id-key id 'mark))))
924     (mapconcat (lambda (mark)
925                  (plist-get
926                   (cdr-safe
927                    (assoc mark gnus-registry-marks))
928                   :char))
929                marks "")))
930
931 ;; use like this:
932 ;; (defalias 'gnus-user-format-function-M 'gnus-registry-article-marks-to-names)
933 (defun gnus-registry-article-marks-to-names (headers)
934   "Show the marks for an article by name."
935   (let* ((id (mail-header-message-id headers))
936          (marks (when id (gnus-registry-get-id-key id 'mark))))
937     (mapconcat (lambda (mark) (symbol-name mark)) marks ",")))
938
939 (defun gnus-registry-read-mark ()
940   "Read a mark name from the user with completion."
941   (let ((mark (gnus-completing-read
942                "Label"
943                (mapcar 'symbol-name (mapcar 'car gnus-registry-marks))
944                nil nil nil
945                (symbol-name gnus-registry-default-mark))))
946     (when (stringp mark)
947       (intern mark))))
948
949 (defun gnus-registry-set-article-mark (&rest articles)
950   "Apply a mark to process-marked ARTICLES."
951   (interactive (gnus-summary-work-articles current-prefix-arg))
952   (gnus-registry-set-article-mark-internal (gnus-registry-read-mark)
953                                            articles nil t))
954
955 (defun gnus-registry-remove-article-mark (&rest articles)
956   "Remove a mark from 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 t t))
960
961 (defun gnus-registry-set-article-mark-internal (mark
962                                                 articles
963                                                 &optional remove
964                                                 show-message)
965   "Apply or remove MARK across a list of ARTICLES."
966   (let ((article-id-list
967          (mapcar 'gnus-registry-fetch-message-id-fast articles)))
968     (dolist (id article-id-list)
969       (let* ((marks (delq mark (gnus-registry-get-id-key id 'mark)))
970              (marks (if remove marks (cons mark marks))))
971         (when show-message
972           (gnus-message 1 "%s mark %s with message ID %s, resulting in %S"
973                         (if remove "Removing" "Adding")
974                         mark id marks))
975         (gnus-registry-set-id-key id 'mark marks)))))
976
977 (defun gnus-registry-get-article-marks (&rest articles)
978   "Get the Gnus registry marks for ARTICLES and show them if interactive.
979 Uses process/prefix conventions.  For multiple articles,
980 only the last one's marks are returned."
981   (interactive (gnus-summary-work-articles 1))
982   (let* ((article (last articles))
983          (id (gnus-registry-fetch-message-id-fast article))
984          (marks (when id (gnus-registry-get-id-key id 'mark))))
985     (when (interactive-p)
986       (gnus-message 1 "Marks are %S" marks))
987     marks))
988
989 (defun gnus-registry-group-count (id)
990   "Get the number of groups of a message, based on the message ID."
991   (length (gnus-registry-get-id-key id 'group)))
992
993 (defun gnus-registry-get-or-make-entry (id)
994   (let* ((db gnus-registry-db)
995          ;; safe if not found
996          (entries (registry-lookup db (list id))))
997
998     (when (null entries)
999       (gnus-registry-insert db id (list (list 'creation-time (current-time))
1000                                         '(group) '(sender) '(subject)))
1001       (setq entries (registry-lookup db (list id))))
1002
1003     (nth 1 (assoc id entries))))
1004
1005 (defun gnus-registry-delete-entries (idlist)
1006   (registry-delete gnus-registry-db idlist nil))
1007
1008 (defun gnus-registry-get-id-key (id key)
1009   (cdr-safe (assq key (gnus-registry-get-or-make-entry id))))
1010
1011 (defun gnus-registry-set-id-key (id key vals)
1012   (let* ((db gnus-registry-db)
1013          (entry (gnus-registry-get-or-make-entry id)))
1014     (registry-delete db (list id) nil)
1015     (setq entry (cons (cons key vals) (assq-delete-all key entry)))
1016     (gnus-registry-insert db id entry)
1017     entry))
1018
1019 (defun gnus-registry-insert (db id entry)
1020   "Just like `registry-insert' but tries to prune on error."
1021   (when (registry-full db)
1022     (message "Trying to prune the registry because it's full")
1023     (registry-prune db))
1024   (registry-insert db id entry)
1025   entry)
1026
1027 (defun gnus-registry-import-eld (file)
1028   (interactive "fOld registry file to import? ")
1029   ;; example content:
1030   ;;   (setq gnus-registry-alist '(
1031   ;; ("<messageID>" ((marks nil)
1032   ;;                 (mtime 19365 1776 440496)
1033   ;;                 (sender . "root (Cron Daemon)")
1034   ;;                 (subject . "Cron"))
1035   ;;  "cron" "nnml+private:cron")
1036   (load file t)
1037   (when (boundp 'gnus-registry-alist)
1038     (let* ((old (symbol-value 'gnus-registry-alist))
1039            (count 0)
1040            (expected (length old))
1041            entry)
1042       (while (car-safe old)
1043         (incf count)
1044         ;; don't use progress reporters for backwards compatibility
1045         (when (and (< 0 expected)
1046                    (= 0 (mod count 100)))
1047           (message "importing: %d of %d (%.2f%%)"
1048                    count expected (/ (* 100 count) expected)))
1049         (setq entry (car-safe old)
1050               old (cdr-safe old))
1051         (let* ((id (car-safe entry))
1052                (new-entry (gnus-registry-get-or-make-entry id))
1053                (rest (cdr-safe entry))
1054                (groups (loop for p in rest
1055                              when (stringp p)
1056                              collect p))
1057                extra-cell key val)
1058           ;; remove all the strings from the entry
1059           (dolist (elem rest)
1060             (if (stringp elem) (setq rest (delq elem rest))))
1061           (gnus-registry-set-id-key id 'group groups)
1062           ;; just use the first extra element
1063           (setq rest (car-safe rest))
1064           (while (car-safe rest)
1065             (setq extra-cell (car-safe rest)
1066                   key (car-safe extra-cell)
1067                   val (cdr-safe extra-cell)
1068                   rest (cdr-safe rest))
1069             (when (and val (atom val))
1070               (setq val (list val)))
1071             (gnus-registry-set-id-key id key val))))
1072       (message "Import done, collected %d entries" count))))
1073
1074 ;;;###autoload
1075 (defun gnus-registry-initialize ()
1076   "Initialize the Gnus registry."
1077   (interactive)
1078   (gnus-message 5 "Initializing the registry")
1079   (gnus-registry-install-hooks)
1080   (gnus-registry-install-shortcuts)
1081   (gnus-registry-read))
1082
1083 ;; FIXME: Why autoload this function?
1084 ;;;###autoload
1085 (defun gnus-registry-install-hooks ()
1086   "Install the registry hooks."
1087   (interactive)
1088   (setq gnus-registry-enabled t)
1089   (add-hook 'gnus-summary-article-move-hook 'gnus-registry-action)
1090   (add-hook 'gnus-summary-article-delete-hook 'gnus-registry-action)
1091   (add-hook 'gnus-summary-article-expire-hook 'gnus-registry-action)
1092   (add-hook 'nnmail-spool-hook 'gnus-registry-spool-action)
1093
1094   (add-hook 'gnus-save-newsrc-hook 'gnus-registry-save)
1095   (add-hook 'gnus-read-newsrc-el-hook 'gnus-registry-read)
1096
1097   (add-hook 'gnus-summary-prepare-hook 'gnus-registry-register-message-ids))
1098
1099 (defun gnus-registry-unload-hook ()
1100   "Uninstall the registry hooks."
1101   (interactive)
1102   (remove-hook 'gnus-summary-article-move-hook 'gnus-registry-action)
1103   (remove-hook 'gnus-summary-article-delete-hook 'gnus-registry-action)
1104   (remove-hook 'gnus-summary-article-expire-hook 'gnus-registry-action)
1105   (remove-hook 'nnmail-spool-hook 'gnus-registry-spool-action)
1106
1107   (remove-hook 'gnus-save-newsrc-hook 'gnus-registry-save)
1108   (remove-hook 'gnus-read-newsrc-el-hook 'gnus-registry-read)
1109
1110   (remove-hook 'gnus-summary-prepare-hook 'gnus-registry-register-message-ids)
1111   (setq gnus-registry-enabled nil))
1112
1113 (add-hook 'gnus-registry-unload-hook 'gnus-registry-unload-hook)
1114
1115 (defun gnus-registry-install-p ()
1116   "If the registry is not already enabled, and `gnus-registry-install' is t,
1117 the registry is enabled.  If `gnus-registry-install' is `ask',
1118 the user is asked first.  Returns non-nil iff the registry is enabled."
1119   (interactive)
1120   (unless gnus-registry-enabled
1121     (when (if (eq gnus-registry-install 'ask)
1122               (gnus-y-or-n-p
1123                (concat "Enable the Gnus registry?  "
1124                        "See the variable `gnus-registry-install' "
1125                        "to get rid of this query permanently. "))
1126             gnus-registry-install)
1127       (gnus-registry-initialize)))
1128   gnus-registry-enabled)
1129
1130 ;; largely based on nnir-warp-to-article
1131 (defun gnus-try-warping-via-registry ()
1132   "Try to warp via the registry.
1133 This will be done via the current article's source group based on
1134 data stored in the registry."
1135   (interactive)
1136   (when (gnus-summary-article-header)
1137     (let* ((message-id (mail-header-id (gnus-summary-article-header)))
1138            ;; Retrieve the message's group(s) from the registry
1139            (groups (gnus-registry-get-id-key message-id 'group))
1140            ;; If starting from an ephemeral group, this describes
1141            ;; how to restore the window configuration
1142            (quit-config
1143             (gnus-ephemeral-group-p gnus-newsgroup-name))
1144            (seen-groups (list (gnus-group-group-name))))
1145
1146       (catch 'found
1147         (dolist (group (mapcar 'gnus-simplify-group-name groups))
1148
1149           ;; skip over any groups we really don't want to warp to.
1150           (unless (or (member group seen-groups)
1151                       (gnus-ephemeral-group-p group) ;; any ephemeral group
1152                       (memq (car (gnus-find-method-for-group group))
1153                             ;; Specific methods; this list may need to expand.
1154                             '(nnir)))
1155
1156             ;; remember that we've seen this group already
1157             (push group seen-groups)
1158
1159             ;; first exit from any ephemeral summary buffer.
1160             (when quit-config
1161               (gnus-summary-exit)
1162               ;; and if the ephemeral summary buffer in turn came from
1163               ;; another summary buffer we have to clean that summary
1164               ;; up too.
1165               (when (eq (cdr quit-config) 'summary)
1166                 (gnus-summary-exit))
1167               ;; remember that we've already done this part
1168               (setq quit-config nil))
1169
1170             ;; Try to activate the group.  If that fails, just move
1171             ;; along.  We may have more groups to work with
1172             (when
1173                 (ignore-errors
1174                   (gnus-select-group-with-message-id group message-id) t)
1175               (throw 'found t))))))))
1176
1177 ;; TODO: a few things
1178
1179 (provide 'gnus-registry)
1180
1181 ;;; gnus-registry.el ends here