;;; gnus-registry.el --- article registry for Gnus
-;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004
-;; Free Software Foundation, Inc.
+
+;; Copyright (C) 2002-2011 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 2, 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:
;; (: gnus-registry-split-fancy-with-parent)
+;; You should also consider using the nnregistry backend to look up
+;; articles. See the Gnus manual for more information.
+
;; TODO:
;; - get the correct group on spool actions
(require 'gnus)
(require 'gnus-int)
(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")
- "List of groups that gnus-registry-split-fancy-with-parent won't follow.
-The group names are matched, they don't have to be fully qualified."
+(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.'
+
+nnmairix groups are specifically excluded because they are ephemeral."
:group 'gnus-registry
- :type '(repeat string))
+ :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
(gnus-load file)
(gnus-message 5 "Reading %s...done" file))))
+;; FIXME: Get rid of duplicated code, cf. `gnus-save-newsrc-file' in
+;; `gnus-start.el'. --rsteib
(defun gnus-registry-cache-save ()
"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
;; remove empty entries
(when gnus-registry-clean-empty
(gnus-registry-clean-empty-function))
- ;; now trim the registry appropriately
- (setq gnus-registry-alist (gnus-registry-trim
- (hashtable-to-alist gnus-registry-hashtb)))
+ ;; now trim and clean text properties from the registry appropriately
+ (setq gnus-registry-alist
+ (gnus-registry-remove-alist-text-properties
+ (gnus-registry-trim
+ (gnus-hashtable-to-alist
+ gnus-registry-hashtb))))
;; really save
(gnus-registry-cache-save)
(setq gnus-registry-entry-caching caching)
(when (stringp key)
(dolist (group (gnus-registry-fetch-groups key))
(when (gnus-parameter-registry-ignore group)
- (gnus-message
- 10
+ (gnus-message
+ 10
"gnus-registry: deleted ignored group %s from key %s"
group key)
(gnus-registry-delete-group key group)))
(gnus-registry-fetch-group key)
;; TODO: look for specific extra data here!
;; in this example, we look for 'label
- (gnus-registry-fetch-extra key 'label)
- (stringp key))
+ (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-read ()
(gnus-registry-cache-read)
- (setq gnus-registry-hashtb (alist-to-hashtable gnus-registry-alist))
+ (setq gnus-registry-hashtb (gnus-alist-to-hashtable gnus-registry-alist))
(setq gnus-registry-dirty nil))
+(defun gnus-registry-remove-alist-text-properties (v)
+ "Remove text properties from all strings in alist."
+ (if (stringp v)
+ (gnus-string-remove-all-properties v)
+ (if (and (listp v) (listp (cdr v)))
+ (mapcar 'gnus-registry-remove-alist-text-properties v)
+ (if (and (listp v) (stringp (cdr v)))
+ (cons (gnus-registry-remove-alist-text-properties (car v))
+ (gnus-registry-remove-alist-text-properties (cdr v)))
+ v))))
+
(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))))))))))
-
-(defun alist-to-hashtable (alist)
- "Build a hashtable from the values in ALIST."
- (let ((ht (make-hash-table
- :size 4096
- :test 'equal)))
- (mapc
- (lambda (kv-pair)
- (puthash (car kv-pair) (cdr kv-pair) ht))
- alist)
- ht))
-
-(defun hashtable-to-alist (hash)
- "Build an alist from the values in HASH."
- (let ((list nil))
- (maphash
- (lambda (key value)
- (setq list (cons (cons key value) list)))
- hash)
- list))
+ (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-registry-simplify-subject
- (mail-header-subject data-header)))
- (sender (mail-header-from 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)))
(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"))
messages.
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.
+References or In-Reply-To header and then looks in the registry
+to see which group that message was put in. This group is
+returne
projects / gnus / blobdiff