Strip Injection-* headers before superseding.
[gnus] / lisp / gnus-registry.el
index 2803cd9..c7dd012 100644 (file)
@@ -1,27 +1,25 @@
 ;;; gnus-registry.el --- article registry for Gnus
 
-;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
-;;   2005, 2006, 2007, 2008 Free Software Foundation, Inc.
+;;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
+;;; Free Software Foundation, Inc.
 
 ;; Author: Ted Zlatanov <tzz@lifelogs.com>
-;; Keywords: news
+;; Keywords: news registry
 
 ;; This file is part of GNU Emacs.
 
-;; GNU Emacs is free software; you can redistribute it and/or modify
+;; GNU Emacs is free software: you can redistribute it and/or modify
 ;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 3, or (at your option)
-;; any later version.
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
 
 ;; GNU Emacs is distributed in the hope that it will be useful,
 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.         See the
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 ;; GNU General Public License for more details.
 
 ;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs; see the file COPYING.  If not, write to the
-;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
-;; Boston, MA 02110-1301, USA.
+;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
 
 ;;; Commentary:
 
@@ -62,6 +60,7 @@
 (require 'gnus-sum)
 (require 'gnus-util)
 (require 'nnmail)
+(require 'easymenu)
 
 (defvar gnus-adaptive-word-syntax-table)
 
   :version "22.1"
   :group 'gnus)
 
-(defvar gnus-registry-hashtb (make-hash-table                      
+(defvar gnus-registry-hashtb (make-hash-table
                              :size 256
                              :test 'equal)
   "*The article registry by Message ID.")
 
 (defcustom gnus-registry-marks
   '((Important
-     (char . ?i)
-     (image . "summary_important"))
+     :char ?i
+     :image "summary_important")
     (Work
-     (char . ?w)
-     (image . "summary_work"))
+     :char ?w
+     :image "summary_work")
     (Personal
-     (char . ?p)
-     (image . "summary_personal"))
+     :char ?p
+     :image "summary_personal")
     (To-Do
-     (char . ?t)
-     (image . "summary_todo"))
+     :char ?t
+     :image "summary_todo")
     (Later
-     (char . ?l)
-     (image . "summary_later")))
+     :char ?l
+     :image "summary_later"))
 
   "List of registry marks and their options.
 
 `gnus-registry-mark-article' will offer symbols from this list
-for completion.  
+for completion.
 
 Each entry must have a character to be useful for summary mode
 line display and for keyboard shortcuts.
@@ -106,21 +105,23 @@ line display and for keyboard shortcuts.
 Each entry must have an image string to be useful for visual
 display."
   :group 'gnus-registry
-  :type '(alist :key-type symbol
-               :value-type (set :tag "Mark details"
-                                 (cons :tag "Shortcut" 
-                                       (const :tag "Character code" char)
-                                       character)
-                                 (cons :tag "Visual" 
-                                       (const :tag "Image" image) 
-                                       string))))
+  :type '(repeat :tag "Registry Marks"
+                (cons :tag "Mark"
+                      (symbol :tag "Name")
+                      (checklist :tag "Options" :greedy t
+                                 (group :inline t
+                                        (const :format "" :value :char)
+                                        (character :tag "Character code"))
+                                 (group :inline t
+                                        (const :format "" :value :image)
+                                        (string :tag "Image"))))))
 
 (defcustom gnus-registry-default-mark 'To-Do
   "The default mark.  Should be a valid key for `gnus-registry-marks'."
   :group 'gnus-registry
   :type 'symbol)
 
-(defcustom gnus-registry-unfollowed-groups 
+(defcustom gnus-registry-unfollowed-groups
   '("delayed$" "drafts$" "queue$" "INBOX$")
   "List of groups that gnus-registry-split-fancy-with-parent won't return.
 The group names are matched, they don't have to be fully
@@ -130,10 +131,16 @@ references.'"
   :group 'gnus-registry
   :type '(repeat regexp))
 
-(defcustom gnus-registry-install nil
+(defcustom gnus-registry-install 'ask
   "Whether the registry should be installed."
   :group 'gnus-registry
-  :type 'boolean)
+  :type '(choice (const :tag "Never Install" nil)
+                (const :tag "Always Install" t)
+                (const :tag "Ask Me" ask)))
+
+(defvar gnus-summary-misc-menu) ;; Avoid byte compiler warning.
+
+(defvar gnus-registry-misc-menus nil)  ; ugly way to keep the menus
 
 (defcustom gnus-registry-clean-empty t
   "Whether the empty registry entries should be deleted.
@@ -142,11 +149,17 @@ and no extra data."
   :group 'gnus-registry
   :type 'boolean)
 
-(defcustom gnus-registry-use-long-group-names nil
-  "Whether the registry should use long group names (BUGGY)."
+(defcustom gnus-registry-use-long-group-names t
+  "Whether the registry should use long group names."
   :group 'gnus-registry
   :type 'boolean)
 
+(defcustom gnus-registry-max-track-groups 20
+  "The maximum number of non-unique group matches to check for a message ID."
+  :group 'gnus-registry
+  :type '(radio (const :format "Unlimited " nil)
+               (integer :format "Maximum non-unique matches: %v")))
+
 (defcustom gnus-registry-track-extra nil
   "Whether the registry should track extra data about a message.
 The Subject and Sender (From:) headers are currently tracked this
@@ -157,6 +170,17 @@ way."
     (const :tag "Track by subject (Subject: header)" subject)
     (const :tag "Track by sender (From: header)"  sender)))
 
+(defcustom gnus-registry-split-strategy nil
+  "Whether the registry should track extra data about a message.
+The Subject and Sender (From:) headers are currently tracked this
+way."
+  :group 'gnus-registry
+  :type
+  '(choice :tag "Tracking choices"
+          (const :tag "Only use single choices, discard multiple matches" nil)
+          (const :tag "Majority of matches wins" majority)
+          (const :tag "First found wins"  first)))
+
 (defcustom gnus-registry-entry-caching t
   "Whether the registry should cache extra information."
   :group 'gnus-registry
@@ -182,9 +206,9 @@ considered precious) will not be trimmed."
   :group 'gnus-registry
   :type '(repeat symbol))
 
-(defcustom gnus-registry-cache-file 
-  (nnheader-concat 
-   (or gnus-dribble-directory gnus-home-directory "~/") 
+(defcustom gnus-registry-cache-file
+  (nnheader-concat
+   (or gnus-dribble-directory gnus-home-directory "~/")
    ".gnus.registry.eld")
   "File where the Gnus registry will be stored."
   :group 'gnus-registry
@@ -217,8 +241,7 @@ considered precious) will not be trimmed."
   "Save the registry cache file."
   (interactive)
   (let ((file gnus-registry-cache-file))
-    (save-excursion
-      (set-buffer (gnus-get-buffer-create " *Gnus-registry-cache*"))
+    (with-current-buffer (gnus-get-buffer-create " *Gnus-registry-cache*")
       (make-local-variable 'version-control)
     (setq version-control gnus-backup-startup-file)
     (setq buffer-file-name file)
@@ -229,7 +252,7 @@ considered precious) will not be trimmed."
     (if gnus-save-startup-file-via-temp-buffer
        (let ((coding-system-for-write gnus-ding-file-coding-system)
              (standard-output (current-buffer)))
-         (gnus-gnus-to-quick-newsrc-format 
+         (gnus-gnus-to-quick-newsrc-format
           t "gnus registry startup file" 'gnus-registry-alist)
          (gnus-registry-cache-whitespace file)
          (save-buffer))
@@ -245,16 +268,14 @@ considered precious) will not be trimmed."
                             (if (and (eq system-type 'ms-dos)
                                      (not (gnus-long-file-names)))
                                 "%s#%d.tm#" ; MSDOS limits files to 8+3
-                              (if (memq system-type '(vax-vms axp-vms))
-                                  "%s$tmp$%d"
-                                "%s#tmp#%d"))
+                              "%s#tmp#%d")
                             working-dir (setq i (1+ i))))
                      (file-exists-p working-file)))
 
        (unwind-protect
            (progn
              (gnus-with-output-to-file working-file
-               (gnus-gnus-to-quick-newsrc-format 
+               (gnus-gnus-to-quick-newsrc-format
                 t "gnus registry startup file" 'gnus-registry-alist))
 
              ;; These bindings will mislead the current buffer
@@ -304,7 +325,7 @@ considered precious) will not be trimmed."
       (when gnus-registry-clean-empty
        (gnus-registry-clean-empty-function))
       ;; now trim and clean text properties from the registry appropriately
-      (setq gnus-registry-alist 
+      (setq gnus-registry-alist
            (gnus-registry-remove-alist-text-properties
             (gnus-registry-trim
              (gnus-hashtable-to-alist
@@ -324,7 +345,7 @@ considered precious) will not be trimmed."
         (dolist (group (gnus-registry-fetch-groups key))
           (when (gnus-parameter-registry-ignore group)
             (gnus-message
-             10 
+             10
              "gnus-registry: deleted ignored group %s from key %s"
              group key)
             (gnus-registry-delete-group key group)))
@@ -339,14 +360,14 @@ considered precious) will not be trimmed."
                  (gnus-registry-fetch-extra key 'label))
           (incf count)
           (gnus-registry-delete-id key))
-        
+
         (unless (stringp key)
-          (gnus-message 
-           10 
-           "gnus-registry key %s was not a string, removing" 
+          (gnus-message
+           10
+           "gnus-registry key %s was not a string, removing"
            key)
           (gnus-registry-delete-id key))))
-       
+
      gnus-registry-hashtb)
     count))
 
@@ -369,7 +390,7 @@ considered precious) will not be trimmed."
 (defun gnus-registry-trim (alist)
   "Trim alist to size, using gnus-registry-max-entries.
 Any entries with extra data (marks, currently) are left alone."
-  (if (null gnus-registry-max-entries)      
+  (if (null gnus-registry-max-entries)
       alist                             ; just return the alist
     ;; else, when given max-entries, trim the alist
     (let* ((timehash (make-hash-table
@@ -398,25 +419,25 @@ Any entries with extra data (marks, currently) are left alone."
              (push item precious-list)
            (push item junk-list))))
 
-      (sort 
+      (sort
        junk-list
        (lambda (a b)
-        (let ((t1 (or (cdr (gethash (car a) timehash)) 
+        (let ((t1 (or (cdr (gethash (car a) timehash))
                       '(0 0 0)))
-              (t2 (or (cdr (gethash (car b) timehash)) 
+              (t2 (or (cdr (gethash (car b) timehash))
                       '(0 0 0))))
           (time-less-p t1 t2))))
 
       ;; we use the return value of this setq, which is the trimmed alist
       (setq alist (append precious-list
                          (nthcdr trim-length junk-list))))))
-  
+
 (defun gnus-registry-action (action data-header from &optional to method)
   (let* ((id (mail-header-id data-header))
         (subject (gnus-string-remove-all-properties
                   (gnus-registry-simplify-subject
                    (mail-header-subject data-header))))
-        (sender (gnus-string-remove-all-properties 
+        (sender (gnus-string-remove-all-properties
                  (mail-header-from data-header)))
         (from (gnus-group-guess-full-name-from-command-method from))
         (to (if to (gnus-group-guess-full-name-from-command-method to) nil))
@@ -467,7 +488,7 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details."
   (let* ((refstr (or (message-fetch-field "references") "")) ; guaranteed
         (reply-to (message-fetch-field "in-reply-to"))      ; may be nil
         ;; now, if reply-to is valid, append it to the References
-        (refstr (if reply-to 
+        (refstr (if reply-to
                     (concat refstr " " reply-to)
                   refstr))
         ;; these may not be used, but the code is cleaner having them up here
@@ -482,7 +503,7 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details."
              nnmail-split-fancy-with-parent-ignore-groups
            (list nnmail-split-fancy-with-parent-ignore-groups)))
         (log-agent "gnus-registry-split-fancy-with-parent")
-        found)
+        found found-full)
 
     ;; this is a big if-else statement.  it uses
     ;; gnus-registry-post-process-groups to filter the results after
@@ -495,7 +516,9 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details."
         9
         "%s is looking for matches for reference %s from [%s]"
         log-agent reference refstr)
-       (dolist (group (gnus-registry-fetch-groups reference))
+       (dolist (group (gnus-registry-fetch-groups
+                       reference
+                       gnus-registry-max-track-groups))
          (when (and group (gnus-registry-follow-group-p group))
            (gnus-message
             7
@@ -503,12 +526,15 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details."
             log-agent reference refstr group)
            (push group found))))
       ;; filter the found groups and return them
-      (setq found (gnus-registry-post-process-groups 
-                  "references" refstr found)))
+      ;; the found groups are the full groups
+      (setq found (gnus-registry-post-process-groups
+                  "references" refstr found found)))
 
      ;; else: there were no matches, now try the extra tracking by sender
-     ((and (gnus-registry-track-sender-p) 
-          sender)
+     ((and (gnus-registry-track-sender-p)
+          sender
+          (not (equal (gnus-extract-address-component-email sender)
+                      user-mail-address)))
       (maphash
        (lambda (key value)
         (let ((this-sender (cdr
@@ -516,7 +542,12 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details."
               matches)
           (when (and this-sender
                      (equal sender this-sender))
-            (setq found (append (gnus-registry-fetch-groups key) found))
+            (let ((groups (gnus-registry-fetch-groups
+                           key
+                           gnus-registry-max-track-groups)))
+              (dolist (group groups)
+                (push group found-full)
+                (setq found (append (list group) (delete group found)))))
             (push key matches)
             (gnus-message
              ;; raise level of messaging if gnus-registry-track-extra
@@ -525,8 +556,10 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details."
              log-agent sender found matches))))
        gnus-registry-hashtb)
       ;; filter the found groups and return them
-      (setq found (gnus-registry-post-process-groups "sender" sender found)))
-      
+      ;; the found groups are NOT the full groups
+      (setq found (gnus-registry-post-process-groups
+                  "sender" sender found found-full)))
+
      ;; else: there were no matches, now try the extra tracking by subject
      ((and (gnus-registry-track-subject-p)
           subject
@@ -538,7 +571,12 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details."
               matches)
           (when (and this-subject
                      (equal subject this-subject))
-            (setq found (append (gnus-registry-fetch-groups key) found))
+            (let ((groups (gnus-registry-fetch-groups
+                           key
+                           gnus-registry-max-track-groups)))
+              (dolist (group groups)
+                (push group found-full)
+                (setq found (append (list group) (delete group found)))))
             (push key matches)
             (gnus-message
              ;; raise level of messaging if gnus-registry-track-extra
@@ -547,10 +585,13 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details."
              log-agent subject found matches))))
        gnus-registry-hashtb)
       ;; filter the found groups and return them
-      (setq found (gnus-registry-post-process-groups 
-                  "subject" subject found))))))
+      ;; the found groups are NOT the full groups
+      (setq found (gnus-registry-post-process-groups
+                  "subject" subject found found-full))))
+    ;; after the (cond) we extract the actual value safely
+    (car-safe found)))
 
-(defun gnus-registry-post-process-groups (mode key groups)
+(defun gnus-registry-post-process-groups (mode key groups groups-full)
   "Modifies GROUPS found by MODE for KEY to determine which ones to follow.
 
 MODE can be 'subject' or 'sender' for example.  The KEY is the
@@ -564,9 +605,28 @@ This is not possible if gnus-registry-use-long-group-names is
 false.  Foreign methods are not supported so they are rejected.
 
 Reduces the list to a single group, or complains if that's not
-possible."
+possible.  Uses `gnus-registry-split-strategy' and GROUPS-FULL if
+necessary."
   (let ((log-agent "gnus-registry-post-process-group")
        out)
+
+    ;; the strategy can be 'first, 'majority, or nil
+    (when (eq gnus-registry-split-strategy 'first)
+      (when groups
+       (setq groups (list (car-safe groups)))))
+
+    (when (eq gnus-registry-split-strategy 'majority)
+      (let ((freq (make-hash-table
+                  :size 256
+                  :test 'equal)))
+       (mapc (lambda(x) (puthash x (1+ (gethash x freq 0)) freq)) groups-full)
+       (setq groups (list (car-safe
+                           (sort
+                            groups
+                            (lambda (a b)
+                              (> (gethash a freq 0)
+                                 (gethash b freq 0)))))))))
+
     (if gnus-registry-use-long-group-names
        (dolist (group groups)
          (let ((m1 (gnus-find-method-for-group group))
@@ -600,10 +660,10 @@ possible."
   "Determines if a group name should be followed.
 Consults `gnus-registry-unfollowed-groups' and
 `nnmail-split-fancy-with-parent-ignore-groups'."
-  (not (or (gnus-registry-grep-in-list
+  (not (or (gnus-grep-in-list
            group
            gnus-registry-unfollowed-groups)
-          (gnus-registry-grep-in-list
+          (gnus-grep-in-list
            group
            nnmail-split-fancy-with-parent-ignore-groups))))
 
@@ -613,8 +673,7 @@ Consults `gnus-registry-unfollowed-groups' and
        word words)
     (if (or (not (gnus-registry-fetch-extra id 'keywords))
            force)
-       (save-excursion
-         (set-buffer gnus-article-buffer)
+       (with-current-buffer gnus-article-buffer
          (article-goto-body)
          (save-window-excursion
            (save-restriction
@@ -633,9 +692,8 @@ Consults `gnus-registry-unfollowed-groups' and
   (let (articles)
     (maphash
      (lambda (key value)
-       (when (gnus-registry-grep-in-list
-             keyword
-             (cdr (gnus-registry-fetch-extra key 'keywords)))
+       (when (member keyword
+                  (cdr-safe (gnus-registry-fetch-extra key 'keywords)))
         (push key articles)))
      gnus-registry-hashtb)
     articles))
@@ -648,8 +706,8 @@ Consults `gnus-registry-unfollowed-groups' and
        (unless (member gnus-newsgroup-name (gnus-registry-fetch-groups id))
          (gnus-message 9 "Registry: Registering article %d with group %s"
                        article gnus-newsgroup-name)
-         (gnus-registry-add-group 
-          id 
+         (gnus-registry-add-group
+          id
           gnus-newsgroup-name
           (gnus-registry-fetch-simplified-message-subject-fast article)
           (gnus-registry-fetch-sender-fast article)))))))
@@ -685,39 +743,28 @@ Consults `gnus-registry-unfollowed-groups' and
                          (assoc article (gnus-data-list nil)))))
     nil))
 
-;;; this should be redone with catch/throw
-(defun gnus-registry-grep-in-list (word list)
-  (when word
-    (memq nil
-         (mapcar 'not
-                 (mapcar
-                  (lambda (x)
-                    (string-match word x))
-                  list)))))
-
 (defun gnus-registry-do-marks (type function)
   "For each known mark, call FUNCTION for each cell of type TYPE.
 
 FUNCTION should take two parameters, a mark symbol and the cell value."
   (dolist (mark-info gnus-registry-marks)
-    (let ((mark (car-safe mark-info))
-         (data (cdr-safe mark-info)))
-      (dolist (cell data)
-       (let ((cell-type (car-safe cell))
-             (cell-data (cdr-safe cell)))
-         (when (equal type cell-type)
-           (funcall function mark cell-data)))))))
+    (let* ((mark (car-safe mark-info))
+          (data (cdr-safe mark-info))
+          (cell-data (plist-get data type)))
+      (when cell-data
+       (funcall function mark cell-data)))))
 
 ;;; this is ugly code, but I don't know how to do it better
-;;; TODO: clear the gnus-registry-mark-map before running
-(defun gnus-registry-install-shortcuts-and-menus ()
+(defun gnus-registry-install-shortcuts ()
   "Install the keyboard shortcuts and menus for the registry.
 Uses `gnus-registry-marks' to find what shortcuts to install."
-  (gnus-registry-do-marks 
-   'char
-   (lambda (mark data)
-     (let ((function-format
-           (format "gnus-registry-%%s-article-%s-mark" mark)))
+  (let (keys-plist)
+    (setq gnus-registry-misc-menus nil)
+    (gnus-registry-do-marks
+     :char
+     (lambda (mark data)
+       (let ((function-format
+             (format "gnus-registry-%%s-article-%s-mark" mark)))
 
 ;;; The following generates these functions:
 ;;; (defun gnus-registry-set-article-Important-mark (&rest articles)
@@ -729,53 +776,92 @@ Uses `gnus-registry-marks' to find what shortcuts to install."
 ;;;   (interactive (gnus-summary-work-articles current-prefix-arg))
 ;;;   (gnus-registry-set-article-mark-internal 'Important articles t t))
 
-       (dolist (remove '(t nil))
-        (let* ((variant-name (if remove "remove" "set"))
-               (function-name (format function-format variant-name))
-               (shortcut (format "%c" data))
-               (shortcut (if remove (upcase shortcut) shortcut)))
-          (unintern function-name)
-          (eval
-           `(defun 
-              ;; function name
-              ,(intern function-name) 
-              ;; parameter definition
-              (&rest articles)
-              ;; documentation
-              ,(format 
-                "%s the %s mark over process-marked ARTICLES."
-                (upcase-initials variant-name)
-                mark)
-              ;; interactive definition
-              (interactive 
-               (gnus-summary-work-articles current-prefix-arg))
-              ;; actual code
-              (gnus-registry-set-article-mark-internal 
-               ;; all this just to get the mark, I must be doing it wrong
-               (intern ,(symbol-name mark))
-               articles ,remove t))))))))
-  ;; I don't know how to do this inside the loop above, because
-  ;; gnus-define-keys is a macro
-  (gnus-define-keys (gnus-registry-mark-map "M" gnus-summary-mark-map)
-    "i" gnus-registry-set-article-Important-mark
-    "I" gnus-registry-remove-article-Important-mark
-    "w" gnus-registry-set-article-Work-mark
-    "W" gnus-registry-remove-article-Work-mark
-    "l" gnus-registry-set-article-Later-mark
-    "L" gnus-registry-remove-article-Later-mark
-    "p" gnus-registry-set-article-Personal-mark
-    "P" gnus-registry-remove-article-Personal-mark
-    "t" gnus-registry-set-article-To-Do-mark
-    "T" gnus-registry-remove-article-To-Do-mark))
+        (dolist (remove '(t nil))
+          (let* ((variant-name (if remove "remove" "set"))
+                 (function-name (format function-format variant-name))
+                 (shortcut (format "%c" data))
+                 (shortcut (if remove (upcase shortcut) shortcut)))
+            (unintern function-name obarray)
+            (eval
+             `(defun
+                ;; function name
+                ,(intern function-name)
+                ;; parameter definition
+                (&rest articles)
+                ;; documentation
+                ,(format
+                  "%s the %s mark over process-marked ARTICLES."
+                  (upcase-initials variant-name)
+                  mark)
+                ;; interactive definition
+                (interactive
+                 (gnus-summary-work-articles current-prefix-arg))
+                ;; actual code
+
+                ;; if this is called and the user doesn't want the
+                ;; registry enabled, we'll ask anyhow
+                (when (eq gnus-registry-install nil)
+                  (setq gnus-registry-install 'ask))
+
+                ;; now the user is asked if gnus-registry-install is 'ask
+                (when (gnus-registry-install-p)
+                  (gnus-registry-set-article-mark-internal
+                   ;; all this just to get the mark, I must be doing it wrong
+                   (intern ,(symbol-name mark))
+                   articles ,remove t)
+                  (gnus-message
+                   9
+                   "Applying mark %s to %d articles"
+                   ,(symbol-name mark) (length articles))
+                  (dolist (article articles)
+                    (gnus-summary-update-article
+                     article
+                     (assoc article (gnus-data-list nil)))))))
+            (push (intern function-name) keys-plist)
+            (push shortcut keys-plist)
+            (push (vector (format "%s %s"
+                                  (upcase-initials variant-name)
+                                  (symbol-name mark))
+                          (intern function-name) t)
+                  gnus-registry-misc-menus)
+            (gnus-message
+             9
+             "Defined mark handling function %s"
+             function-name))))))
+    (gnus-define-keys-1
+     '(gnus-registry-mark-map "M" gnus-summary-mark-map)
+     keys-plist)
+    (add-hook 'gnus-summary-menu-hook
+             (lambda ()
+               (easy-menu-add-item
+                gnus-summary-misc-menu
+                nil
+                (cons "Registry Marks" gnus-registry-misc-menus))))))
+
+;;; use like this:
+;;; (defalias 'gnus-user-format-function-M
+;;;           'gnus-registry-user-format-function-M)
+(defun gnus-registry-user-format-function-M (headers)
+  (let* ((id (mail-header-message-id headers))
+        (marks (when id (gnus-registry-fetch-extra-marks id))))
+    (apply 'concat (mapcar (lambda(mark)
+                            (let ((c
+                                   (plist-get
+                                    (cdr-safe
+                                     (assoc mark gnus-registry-marks))
+                                    :char)))
+                              (if c
+                                  (list c)
+                                nil)))
+                          marks))))
 
 (defun gnus-registry-read-mark ()
   "Read a mark name from the user with completion."
-  (let ((mark (gnus-completing-read-with-default 
-              (symbol-name gnus-registry-default-mark)
-              "Label" 
-              (mapcar (lambda (x)      ; completion list
-                        (cons (symbol-name (car-safe x)) (car-safe x)))
-                      gnus-registry-marks))))
+  (let ((mark (gnus-completing-read
+               "Label"
+               (mapcar 'symbol-name (mapcar 'car gnus-registry-marks))
+               nil nil nil
+              (symbol-name gnus-registry-default-mark))))
     (when (stringp mark)
       (intern mark))))
 
@@ -807,7 +893,7 @@ Uses `gnus-registry-marks' to find what shortcuts to install."
          (gnus-message 1 "%s mark %s with message ID %s, resulting in %S"
                        (if remove "Removing" "Adding")
                        mark id new-marks))
-       
+
        (apply 'gnus-registry-store-extra-marks ; set the extra marks
               id                               ; for the message ID
               new-marks)))))
@@ -918,7 +1004,7 @@ The message must have at least one group name."
   "Put a specific entry in the extras field of the registry entry for id."
   (let* ((extra (gnus-registry-fetch-extra id))
         ;; all the entries except the one for `key'
-        (the-rest (gnus-assq-delete-all key (gnus-registry-fetch-extra id))) 
+        (the-rest (gnus-assq-delete-all key (gnus-registry-fetch-extra id)))
         (alist (if value
                    (gnus-registry-remove-alist-text-properties
                     (cons (cons key value)
@@ -938,20 +1024,22 @@ Returns the first place where the trail finds a group name."
                       crumb
                     (gnus-group-short-name crumb))))))))
 
-(defun gnus-registry-fetch-groups (id)
-  "Get the groups of a message, based on the message ID."
+(defun gnus-registry-fetch-groups (id &optional max)
+  "Get the groups (up to MAX, if given) of a message, based on the message ID."
   (let ((trail (gethash id gnus-registry-hashtb))
        groups)
     (dolist (crumb trail)
       (when (stringp crumb)
        ;; push the group name into the list
-       (setq 
+       (setq
         groups
         (cons
          (if (or (not (stringp crumb)) gnus-registry-use-long-group-names)
              crumb
            (gnus-group-short-name crumb))
-        groups))))
+        groups))
+       (when (and max (> (length groups) max))
+         (return))))
     ;; return the list of groups
     groups))
 
@@ -1033,10 +1121,12 @@ Returns the first place where the trail finds a group name."
 
 ;;;###autoload
 (defun gnus-registry-initialize ()
+"Initialize the Gnus registry."
   (interactive)
-  (setq gnus-registry-install t)
+  (gnus-message 5 "Initializing the registry")
+  (setq gnus-registry-install t)       ; in case it was 'ask or nil
   (gnus-registry-install-hooks)
-  (gnus-registry-install-shortcuts-and-menus)
+  (gnus-registry-install-shortcuts)
   (gnus-registry-read))
 
 ;;;###autoload
@@ -1068,13 +1158,22 @@ Returns the first place where the trail finds a group name."
 
 (add-hook 'gnus-registry-unload-hook 'gnus-registry-unload-hook)
 
-(when gnus-registry-install
-  (gnus-registry-install-hooks)
-  (gnus-registry-read))
-
-;; TODO: a lot of things
+(defun gnus-registry-install-p ()
+  (interactive)
+  (when (eq gnus-registry-install 'ask)
+    (setq gnus-registry-install
+         (gnus-y-or-n-p
+          (concat "Enable the Gnus registry?  "
+                  "See the variable `gnus-registry-install' "
+                  "to get rid of this query permanently. ")))
+    (when gnus-registry-install
+      ;; we just set gnus-registry-install to t, so initialize the registry!
+      (gnus-registry-initialize)))
+;;; we could call it here: (customize-variable 'gnus-registry-install)
+  gnus-registry-install)
+
+;; TODO: a few things
 
 (provide 'gnus-registry)
 
-;;; arch-tag: 5cba0a32-718a-4a97-8c91-0a15af21da94
 ;;; gnus-registry.el ends here