;;; 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:
(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.")
"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.
: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
(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.
Registry entries are considered empty when they have no groups
: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
: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
"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
+ (gnus-gnus-to-quick-newsrc-format
t "gnus registry startup file" 'gnus-registry-alist)
(gnus-registry-cache-whitespace file)
(save-buffer))
(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
(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.
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
(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))
(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
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
(push group found))))
;; filter the found groups and return them
;; the found groups are the full groups
- (setq found (gnus-registry-post-process-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 sender user-mail-address)))
+ (not (equal (gnus-extract-address-component-email sender)
+ user-mail-address)))
(maphash
(lambda (key value)
(let ((this-sender (cdr
matches)
(when (and this-sender
(equal sender this-sender))
- (let ((groups (gnus-registry-fetch-groups key)))
+ (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)))))
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
+ (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
matches)
(when (and this-subject
(equal subject this-subject))
- (let ((groups (gnus-registry-fetch-groups key)))
+ (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)))))
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
+ (setq found (gnus-registry-post-process-groups
"subject" subject found found-full))))
;; after the (cond) we extract the actual value safely
(car-safe found)))
(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))
"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))))
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 (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)))))))
(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.
"Install the keyboard shortcuts and menus for the registry.
Uses `gnus-registry-marks' to find what shortcuts to install."
(let (keys-plist)
- (gnus-registry-do-marks
+ (setq gnus-registry-misc-menus nil)
+ (gnus-registry-do-marks
:char
(lambda (mark data)
(let ((function-format
(function-name (format function-format variant-name))
(shortcut (format "%c" data))
(shortcut (if remove (upcase shortcut) shortcut)))
- (unintern function-name)
+ (unintern function-name obarray)
(eval
- `(defun
+ `(defun
;; function name
- ,(intern function-name)
+ ,(intern function-name)
;; parameter definition
(&rest articles)
;; documentation
- ,(format
+ ,(format
"%s the %s mark over process-marked ARTICLES."
(upcase-initials variant-name)
mark)
;; interactive definition
- (interactive
+ (interactive
(gnus-summary-work-articles current-prefix-arg))
;; actual code
;; now the user is asked if gnus-registry-install is 'ask
(when (gnus-registry-install-p)
- (gnus-registry-set-article-mark-internal
+ (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
+ (gnus-summary-update-article
+ article
(assoc article (gnus-data-list nil)))))))
(push (intern function-name) keys-plist)
(push shortcut keys-plist)
- (gnus-message
- 9
- "Defined mark handling function %s"
+ (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)))
+ '(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
+;;; (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
+ (let ((c
(plist-get
- (cdr-safe
+ (cdr-safe
(assoc mark gnus-registry-marks))
:char)))
(if c
(defun gnus-registry-read-mark ()
"Read a mark name from the user with completion."
- (let ((mark (gnus-completing-read-with-default
+ (let ((mark (gnus-completing-read-with-default
(symbol-name gnus-registry-default-mark)
- "Label"
+ "Label"
(mapcar (lambda (x) ; completion list
(cons (symbol-name (car-safe x)) (car-safe x)))
gnus-registry-marks))))
(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)))))
"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))
(provide 'gnus-registry)
-;; arch-tag: 5cba0a32-718a-4a97-8c91-0a15af21da94
;;; gnus-registry.el ends here