;;; gnus-registry.el --- article registry for Gnus
-;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007 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:
;; Put this in your startup file (~/.gnus.el for instance)
+;; (require 'nnregistry) ;; optional, or see below (automatically calls `gnus-registry-install-nnregistry' when `gnus-registry-initialize' is called)
;; (setq gnus-registry-max-entries 2500
;; gnus-registry-use-long-group-names t)
;; (gnus-registry-initialize)
+;; (gnus-registry-install-nnregistry) ;; optional, or see above (loading nnregistry makes it unnecessary)
;; Then use this in your fancy-split:
(require 'gnus-sum)
(require 'gnus-util)
(require 'nnmail)
+(require 'easymenu)
+
+(defvar gnus-adaptive-word-syntax-table)
(defvar gnus-registry-dirty t
"Boolean set to t when the registry is modified")
: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-unfollowed-groups '("delayed$" "drafts$" "queue$" "INBOX$")
+(defcustom gnus-registry-marks
+ '((Important
+ :char ?i
+ :image "summary_important")
+ (Work
+ :char ?w
+ :image "summary_work")
+ (Personal
+ :char ?p
+ :image "summary_personal")
+ (To-Do
+ :char ?t
+ :image "summary_todo")
+ (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.
+
+Each entry must have a character to be useful for summary mode
+line display and for keyboard shortcuts.
+
+Each entry must have an image string to be useful for visual
+display."
+ :group 'gnus-registry
+ :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
+ '("delayed$" "drafts$" "queue$" "INBOX$" "^nnmairix:")
"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
qualified. This parameter tells the Registry 'never split a
message into a group that matches one of these, regardless of
-references.'"
+references.'
+
+nnmairix groups are specifically excluded because they are ephemeral."
: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.
: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
(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
:group 'gnus-registry
:type 'boolean)
-(defcustom gnus-registry-cache-file
- (nnheader-concat
- (or gnus-dribble-directory gnus-home-directory "~/")
+(defcustom gnus-registry-extra-entries-precious '(marks)
+ "What extra entries are precious, meaning they won't get trimmed.
+When you save the Gnus registry, it's trimmed to be no longer
+than `gnus-registry-max-entries' (which is nil by default, so no
+trimming happens). Any entries with extra data in this list (by
+default, marks are included, so articles with marks are
+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 "~/")
".gnus.registry.eld")
"File where the Gnus registry will be stored."
:group 'gnus-registry
"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)
(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 t "gnus registry startup file" 'gnus-registry-alist)
+ (gnus-gnus-to-quick-newsrc-format
+ t "gnus registry startup file" 'gnus-registry-alist)
(gnus-registry-cache-whitespace file)
(save-buffer))
(let ((coding-system-for-write gnus-ding-file-coding-system)
(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 t "gnus registry startup file" 'gnus-registry-alist))
+ (gnus-gnus-to-quick-newsrc-format
+ t "gnus registry startup file" 'gnus-registry-alist))
;; These bindings will mislead the current buffer
;; into thinking that it is visiting the startup
(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
(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)))
(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))
(defun gnus-registry-trim (alist)
"Trim alist to size, using gnus-registry-max-entries.
-Also, drop all gnus-registry-ignored-groups matches."
+Any entries with extra data (marks, currently) are left alone."
(if (null gnus-registry-max-entries)
alist ; just return the alist
;; else, when given max-entries, trim the alist
(let* ((timehash (make-hash-table
- :size 4096
+ :size 20000
+ :test 'equal))
+ (precious (make-hash-table
+ :size 20000
:test 'equal))
(trim-length (- (length alist) gnus-registry-max-entries))
- (trim-length (if (natnump trim-length) trim-length 0)))
+ (trim-length (if (natnump trim-length) trim-length 0))
+ precious-list junk-list)
(maphash
(lambda (key value)
- (puthash key (gnus-registry-fetch-extra key 'mtime) timehash))
+ (let ((extra (gnus-registry-fetch-extra key)))
+ (dolist (item gnus-registry-extra-entries-precious)
+ (dolist (e extra)
+ (when (equal (nth 0 e) item)
+ (puthash key t precious)
+ (return))))
+ (puthash key (gnus-registry-fetch-extra key 'mtime) timehash)))
gnus-registry-hashtb)
-
+
+ (dolist (item alist)
+ (let ((key (nth 0 item)))
+ (if (gethash key precious)
+ (push item precious-list)
+ (push item junk-list))))
+
+ (sort
+ junk-list
+ (lambda (a b)
+ (let ((t1 (or (cdr (gethash (car a) timehash))
+ '(0 0 0)))
+ (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
- (nthcdr
- trim-length
- (sort alist
- (lambda (a b)
- (time-less-p
- (or (cdr (gethash (car a) timehash)) '(0 0 0))
- (or (cdr (gethash (car b) timehash)) '(0 0 0))))))))))
+ (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 (mail-header-from data-header)))
+ (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))
(to-name (if to to "the Bit Bucket"))
For a message to be split, it looks for the parent message in the
References or In-Reply-To header and then looks in the registry
to see which group that message was put in. This group is
-returned, unless it matches one of the entries in
-gnus-registry-unfollowed-groups or
-nnmail-split-fancy-with-parent-ignore-groups.
+returned, unless `gnus-registry-follow-group-p' return nil for
+that group.
See the Info node `(gnus)Fancy Mail Splitting' for more details."
- (let* ((refstr (or (message-fetch-field "references") "")) ; guarantee string
- (reply-to (message-fetch-field "in-reply-to")) ; grab reply-to
+ (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))
- (nnmail-split-fancy-with-parent-ignore-groups
- (if (listp nnmail-split-fancy-with-parent-ignore-groups)
- nnmail-split-fancy-with-parent-ignore-groups
- (list nnmail-split-fancy-with-parent-ignore-groups)))
- res)
- ;; the references string must be valid and parse to valid references
- (if (and refstr (gnus-extract-references refstr))
- (dolist (reference (nreverse (gnus-extract-references refstr)))
- (setq res (or (gnus-registry-fetch-group reference) res))
- (when (or (gnus-registry-grep-in-list
- res
- gnus-registry-unfollowed-groups)
- (gnus-registry-grep-in-list
- res
- nnmail-split-fancy-with-parent-ignore-groups))
- (setq res nil)))
-
- ;; else: there were no references, now try the extra tracking
- (let ((sender (gnus-string-remove-all-properties(message-fetch-field "from")))
- (subject (gnus-string-remove-all-properties
- (gnus-registry-simplify-subject
- (message-fetch-field "subject"))))
- (single-match t))
- (when (and single-match
- (gnus-registry-track-sender-p)
- sender)
- (maphash
- (lambda (key value)
- (let ((this-sender (cdr
- (gnus-registry-fetch-extra key 'sender))))
- (when (and single-match
- this-sender
- (equal sender this-sender))
- ;; too many matches, bail
- (unless (equal res (gnus-registry-fetch-group key))
- (setq single-match nil))
- (setq res (gnus-registry-fetch-group key))
- (when (and sender res)
- (gnus-message
- ;; raise level of messaging if gnus-registry-track-extra
- (if gnus-registry-track-extra 7 9)
- "%s (extra tracking) traced sender %s to group %s"
- "gnus-registry-split-fancy-with-parent"
- sender
- res)))))
- gnus-registry-hashtb))
- (when (and single-match
- (gnus-registry-track-subject-p)
- subject
- (< gnus-registry-minimum-subject-length (length subject)))
- (maphash
- (lambda (key value)
- (let ((this-subject (cdr
- (gnus-registry-fetch-extra key 'subject))))
- (when (and single-match
- this-subject
- (equal subject this-subject))
- ;; too many matches, bail
- (unless (equal res (gnus-registry-fetch-group key))
- (setq single-match nil))
- (setq res (gnus-registry-fetch-group key))
- (when (and subject res)
- (gnus-message
- ;; raise level of messaging if gnus-registry-track-extra
- (if gnus-registry-track-extra 7 9)
- "%s (extra tracking) traced subject %s to group %s"
- "gnus-registry-split-fancy-with-parent"
- subject
- res)))))
- gnus-registry-hashtb))
- (unless single-match
- (gnus-message
- 3
- "gnus-registry-split-fancy-with-parent: too many extra matches for %s"
- refstr)
- (setq res nil))))
- (when (and refstr res)
- (gnus-message
- 5
- "gnus-registry-split-fancy-with-parent traced %s to group %s"
- refstr res))
-
- (when (and res gnus-registry-use-long-group-names)
- (let ((m1 (gnus-find-method-for-group res))
- (m2 (or gnus-command-method
- (gnus-find-method-for-group gnus-newsgroup-name)))
- (short-res (gnus-group-short-name res)))
- (if (gnus-methods-equal-p m1 m2)
- (progn
+ ;; these may not be used, but the code is cleaner having them up here
+ (sender (gnus-string-remove-all-properties
+ (message-fetch-field "from")))
+ (subject (gnus-string-remove-all-properties
+ (gnus-registry-simplify-subject
+ (message-fetch-field "subject"))))
+
+ (nnmail-split-fancy-with-parent-ignore-groups
+ (if (listp nnmail-split-fancy-with-parent-ignore-groups)
+ 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-full)
+
+ ;; this is a big if-else statement. it uses
+ ;; gnus-registry-post-process-groups to filter the results after
+ ;; every step.
+ (cond
+ ;; the references string must be valid and parse to valid references
+ ((and refstr (gnus-extract-references refstr))
+ (dolist (reference (nreverse (gnus-extract-references refstr)))
+ (gnus-message
+ 9
+ "%s is looking for matches for reference %s from [%s]"
+ log-agent reference refstr)
+ (dolist (group (gnus-registry-fetch-groups
+ reference
+ gnus-registry-max-track-groups))
+ (when (and group (gnus-registry-follow-group-p group))
(gnus-message
- 9
- "gnus-registry-split-fancy-with-parent stripped group %s to %s"
- res
- short-res)
- (setq res short-res))
- ;; else...
+ 7
+ "%s traced the reference %s from [%s] to group %s"
+ log-agent reference refstr group)
+ (push group found))))
+ ;; filter the found groups and return them
+ ;; 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
+ (not (equal (gnus-extract-address-component-email sender)
+ user-mail-address)))
+ (maphash
+ (lambda (key value)
+ (let ((this-sender (cdr
+ (gnus-registry-fetch-extra key 'sender)))
+ matches)
+ (when (and this-sender
+ (equal sender this-sender))
+ (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
+ (if gnus-registry-track-extra 7 9)
+ "%s (extra tracking) traced sender %s to groups %s (keys %s)"
+ log-agent sender found matches))))
+ gnus-registry-hashtb)
+ ;; filter the found groups and return them
+ ;; 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
+ (< gnus-registry-minimum-subject-length (length subject)))
+ (maphash
+ (lambda (key value)
+ (let ((this-subject (cdr
+ (gnus-registry-fetch-extra key 'subject)))
+ matches)
+ (when (and this-subject
+ (equal subject this-subject))
+ (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
+ (if gnus-registry-track-extra 7 9)
+ "%s (extra tracking) traced subject %s to groups %s (keys %s)"
+ log-agent subject found matches))))
+ gnus-registry-hashtb)
+ ;; filter the found groups and return them
+ ;; 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 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
+value by which MODE was searched.
+
+Transforms each group name to the equivalent short name.
+
+Checks if the current Gnus method (from `gnus-command-method' or
+from `gnus-newsgroup-name') is the same as the group's method.
+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. 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))
+ (m2 (or gnus-command-method
+ (gnus-find-method-for-group gnus-newsgroup-name)))
+ (short-name (gnus-group-short-name group)))
+ (if (gnus-methods-equal-p m1 m2)
+ (progn
+ ;; this is REALLY just for debugging
+ (gnus-message
+ 10
+ "%s stripped group %s to %s"
+ log-agent group short-name)
+ (unless (member short-name out)
+ (push short-name out)))
+ ;; else...
+ (gnus-message
+ 7
+ "%s ignored foreign group %s"
+ log-agent group))))
+ (setq out groups))
+ (when (cdr-safe out)
(gnus-message
- 7
- "gnus-registry-split-fancy-with-parent ignored foreign group %s"
- res)
- (setq res nil))))
- res))
+ 5
+ "%s: too many extra matches (%s) for %s %s. Returning none."
+ log-agent out mode key)
+ (setq out nil))
+ out))
+
+(defun gnus-registry-follow-group-p (group)
+ "Determines if a group name should be followed.
+Consults `gnus-registry-unfollowed-groups' and
+`nnmail-split-fancy-with-parent-ignore-groups'."
+ (not (or (gnus-grep-in-list
+ group
+ gnus-registry-unfollowed-groups)
+ (gnus-grep-in-list
+ group
+ nnmail-split-fancy-with-parent-ignore-groups))))
(defun gnus-registry-wash-for-keywords (&optional force)
(interactive)
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
(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))
(unless (gnus-parameter-registry-ignore gnus-newsgroup-name)
(dolist (article gnus-newsgroup-articles)
(let ((id (gnus-registry-fetch-message-id-fast article)))
- (unless (gnus-registry-fetch-group id)
+ (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
- (gnus-registry-fetch-message-id-fast article)
+ id
gnus-newsgroup-name
(gnus-registry-fetch-simplified-message-subject-fast article)
(gnus-registry-fetch-sender-fast article)))))))
(assoc article (gnus-data-list nil)))))
nil))
-(defun gnus-registry-grep-in-list (word list)
- (when word
- (memq nil
- (mapcar 'not
- (mapcar
- (lambda (x)
- (string-match word x))
- list)))))
-
-;;; if this extends to more than 'flags, it should be improved to be more generic.
-(defun gnus-registry-fetch-extra-flags (id)
- "Get the flags of a message, based on the message ID.
-Returns a list of symbol flags or nil."
- (car-safe (cdr (gnus-registry-fetch-extra id 'flags))))
-
-(defun gnus-registry-has-extra-flag (id flag)
- "Checks if a message has `flag', based on the message ID."
- (memq flag (gnus-registry-fetch-extra-flags id)))
-
-(defun gnus-registry-store-extra-flags (id &rest flag-list)
- "Set the flags of a message, based on the message ID.
-The `flag-list' can be nil, in which case no flags are left."
- (gnus-registry-store-extra-entry id 'flags (list flag-list)))
-
-(defun gnus-registry-delete-extra-flags (id &rest flag-delete-list)
- "Delete the message flags in `flag-delete-list', based on the message ID."
- (let ((flags (gnus-registry-fetch-extra-flags id)))
- (when flags
- (dolist (flag flag-delete-list)
- (setq flags (delq flag flags))))
- (gnus-registry-store-extra-flags id (car flags))))
-
-(defun gnus-registry-delete-all-extra-flags (id)
- "Delete all the flags for a message ID."
- (gnus-registry-store-extra-flags id nil))
+(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))
+ (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
+(defun gnus-registry-install-shortcuts ()
+ "Install the keyboard shortcuts and menus for the registry.
+Uses `gnus-registry-marks' to find what shortcuts to install."
+ (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)
+;;; "Apply the Important mark to process-marked ARTICLES."
+;;; (interactive (gnus-summary-work-articles current-prefix-arg))
+;;; (gnus-registry-set-article-mark-internal 'Important articles nil t))
+;;; (defun gnus-registry-remove-article-Important-mark (&rest articles)
+;;; "Apply the Important mark to process-marked ARTICLES."
+;;; (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 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
+ "Label"
+ (mapcar 'symbol-name (mapcar 'car gnus-registry-marks))
+ nil nil nil
+ (symbol-name gnus-registry-default-mark))))
+ (when (stringp mark)
+ (intern mark))))
+
+(defun gnus-registry-set-article-mark (&rest articles)
+ "Apply a mark to process-marked ARTICLES."
+ (interactive (gnus-summary-work-articles current-prefix-arg))
+ (gnus-registry-set-article-mark-internal (gnus-registry-read-mark) articles nil t))
+
+(defun gnus-registry-remove-article-mark (&rest articles)
+ "Remove a mark from process-marked ARTICLES."
+ (interactive (gnus-summary-work-articles current-prefix-arg))
+ (gnus-registry-set-article-mark-internal (gnus-registry-read-mark) articles t t))
+
+(defun gnus-registry-set-article-mark-internal (mark articles &optional remove show-message)
+ "Apply a mark to a list of ARTICLES."
+ (let ((article-id-list
+ (mapcar 'gnus-registry-fetch-message-id-fast articles)))
+ (dolist (id article-id-list)
+ (let* (
+ ;; all the marks for this article without the mark of
+ ;; interest
+ (marks
+ (delq mark (gnus-registry-fetch-extra-marks id)))
+ ;; the new marks we want to use
+ (new-marks (if remove
+ marks
+ (cons mark marks))))
+ (when show-message
+ (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)))))
+
+(defun gnus-registry-get-article-marks (&rest articles)
+ "Get the Gnus registry marks for ARTICLES and show them if interactive.
+Uses process/prefix conventions. For multiple articles,
+only the last one's marks are returned."
+ (interactive (gnus-summary-work-articles 1))
+ (let (marks)
+ (dolist (article articles)
+ (let ((article-id
+ (gnus-registry-fetch-message-id-fast article)))
+ (setq marks (gnus-registry-fetch-extra-marks article-id))))
+ (when (interactive-p)
+ (gnus-message 1 "Marks are %S" marks))
+ marks))
+
+;;; if this extends to more than 'marks, it should be improved to be more generic.
+(defun gnus-registry-fetch-extra-marks (id)
+ "Get the marks of a message, based on the message ID.
+Returns a list of symbol marks or nil."
+ (car-safe (cdr (gnus-registry-fetch-extra id 'marks))))
+
+(defun gnus-registry-has-extra-mark (id mark)
+ "Checks if a message has `mark', based on the message ID `id'."
+ (memq mark (gnus-registry-fetch-extra-marks id)))
+
+(defun gnus-registry-store-extra-marks (id &rest mark-list)
+ "Set the marks of a message, based on the message ID.
+The `mark-list' can be nil, in which case no marks are left."
+ (gnus-registry-store-extra-entry id 'marks (list mark-list)))
+
+(defun gnus-registry-delete-extra-marks (id &rest mark-delete-list)
+ "Delete the message marks in `mark-delete-list', based on the message ID."
+ (let ((marks (gnus-registry-fetch-extra-marks id)))
+ (when marks
+ (dolist (mark mark-delete-list)
+ (setq marks (delq mark marks))))
+ (gnus-registry-store-extra-marks id (car marks))))
+
+(defun gnus-registry-delete-all-extra-marks (id)
+ "Delete all the marks for a message ID."
+ (gnus-registry-store-extra-marks id nil))
(defun gnus-registry-fetch-extra (id &optional entry)
"Get the extra data of a message, based on the message ID.
"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)
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))
;;;###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)
+ (when (featurep 'nnregistry)
+ (gnus-registry-install-nnregistry))
(gnus-registry-read))
;;;###autoload
(add-hook 'gnus-summary-prepare-hook 'gnus-registry-register-message-ids))
+;;;###autoload
+(defun gnus-registry-install-nnregistry ()
+ "Install the nnregistry refer method in `gnus-refer-article-method'."
+ (interactive)
+ (cond ((eq 'nnregistry gnus-refer-article-method))
+ ((null gnus-refer-article-method)
+ (setq gnus-refer-article-method 'nnregistry))
+ ((consp gnus-refer-article-method)
+ (unless (memq 'nnregistry gnus-refer-article-method)
+ (setq gnus-refer-article-method
+ (append gnus-refer-article-method '(nnregistry)))))
+ (t
+ (setq gnus-refer-article-method
+ (list gnus-refer-article-method 'nnregistry)))))
+
(defun gnus-registry-unload-hook ()
"Uninstall the registry hooks."
(interactive)
(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
projects / gnus / blobdiff