diff options
Diffstat (limited to 'lisp/gnus/gnus-registry.el')
| -rw-r--r-- | lisp/gnus/gnus-registry.el | 703 |
1 files changed, 703 insertions, 0 deletions
diff --git a/lisp/gnus/gnus-registry.el b/lisp/gnus/gnus-registry.el new file mode 100644 index 00000000000..9a8d77d3b24 --- /dev/null +++ b/lisp/gnus/gnus-registry.el @@ -0,0 +1,703 @@ +;;; gnus-registry.el --- article registry for Gnus +;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003 +;; Free Software Foundation, Inc. + +;; Author: Ted Zlatanov <tzz@lifelogs.com> +;; Keywords: news + +;; This file is part of GNU Emacs. + +;; 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. + +;; 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 +;; 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., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; This is the gnus-registry.el package, works with other backends +;; besides nnmail. The major issue is that it doesn't go across +;; backends, so for instance if an article is in nnml:sys and you see +;; a reference to it in nnimap splitting, the article will end up in +;; nnimap:sys + +;; gnus-registry.el intercepts article respooling, moving, deleting, +;; and copying for all backends. If it doesn't work correctly for +;; you, submit a bug report and I'll be glad to fix it. It needs +;; documentation in the manual (also on my to-do list). + +;; Put this in your startup file (~/.gnus.el for instance) + +;; (setq gnus-registry-max-entries 2500 +;; gnus-registry-use-long-group-names t) + +;; (gnus-registry-initialize) + +;; Then use this in your fancy-split: + +;; (: gnus-registry-split-fancy-with-parent) + +;; TODO: + +;; - get the correct group on spool actions + +;; - articles that are spooled to a different backend should be handled + +;;; Code: + +(eval-when-compile (require 'cl)) + +(require 'gnus) +(require 'gnus-int) +(require 'gnus-sum) +(require 'nnmail) + +(defvar gnus-registry-dirty t + "Boolean set to t when the registry is modified") + +(defgroup gnus-registry nil + "The Gnus registry." + :group 'gnus) + +(defvar gnus-registry-hashtb nil + "*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." + :group 'gnus-registry + :type '(repeat string)) + +(defcustom gnus-registry-install nil + "Whether the registry should be installed." + :group 'gnus-registry + :type 'boolean) + +(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)." + :group 'gnus-registry + :type 'boolean) + +(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 +way." + :group 'gnus-registry + :type + '(set :tag "Tracking choices" + (const :tag "Track by subject (Subject: header)" subject) + (const :tag "Track by sender (From: header)" sender))) + +(defcustom gnus-registry-entry-caching t + "Whether the registry should cache extra information." + :group 'gnus-registry + :type 'boolean) + +(defcustom gnus-registry-minimum-subject-length 5 + "The minimum length of a subject before it's considered trackable." + :group 'gnus-registry + :type 'integer) + +(defcustom gnus-registry-trim-articles-without-groups t + "Whether the registry should clean out message IDs without groups." + :group 'gnus-registry + :type 'boolean) + +(defcustom gnus-registry-cache-file "~/.gnus.registry.eld" + "File where the Gnus registry will be stored." + :group 'gnus-registry + :type 'file) + +(defcustom gnus-registry-max-entries nil + "Maximum number of entries in the registry, nil for unlimited." + :group 'gnus-registry + :type '(radio (const :format "Unlimited " nil) + (integer :format "Maximum number: %v\n" :size 0))) + +;; Function(s) missing in Emacs 20 +(when (memq nil (mapcar 'fboundp '(puthash))) + (require 'cl) + (unless (fboundp 'puthash) + ;; alias puthash is missing from Emacs 20 cl-extra.el + (defalias 'puthash 'cl-puthash))) + +(defun gnus-registry-track-subject-p () + (memq 'subject gnus-registry-track-extra)) + +(defun gnus-registry-track-sender-p () + (memq 'sender gnus-registry-track-extra)) + +(defun gnus-registry-cache-read () + "Read the registry cache file." + (interactive) + (let ((file gnus-registry-cache-file)) + (when (file-exists-p file) + (gnus-message 5 "Reading %s..." file) + (gnus-load file) + (gnus-message 5 "Reading %s...done" file)))) + +(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*")) + (make-local-variable 'version-control) + (setq version-control gnus-backup-startup-file) + (setq buffer-file-name file) + (setq default-directory (file-name-directory buffer-file-name)) + (buffer-disable-undo) + (erase-buffer) + (gnus-message 5 "Saving %s..." 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-registry-cache-whitespace file) + (save-buffer)) + (let ((coding-system-for-write gnus-ding-file-coding-system) + (version-control gnus-backup-startup-file) + (startup-file file) + (working-dir (file-name-directory file)) + working-file + (i -1)) + ;; Generate the name of a non-existent file. + (while (progn (setq working-file + (format + (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")) + 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)) + + ;; These bindings will mislead the current buffer + ;; into thinking that it is visiting the startup + ;; file. + (let ((buffer-backed-up nil) + (buffer-file-name startup-file) + (file-precious-flag t) + (setmodes (file-modes startup-file))) + ;; Backup the current version of the startup file. + (backup-buffer) + + ;; Replace the existing startup file with the temp file. + (rename-file working-file startup-file t) + (set-file-modes startup-file setmodes))) + (condition-case nil + (delete-file working-file) + (file-error nil))))) + + (gnus-kill-buffer (current-buffer)) + (gnus-message 5 "Saving %s...done" file)))) + +;; Idea from Dan Christensen <jdc@chow.mat.jhu.edu> +;; Save the gnus-registry file with extra line breaks. +(defun gnus-registry-cache-whitespace (filename) + (gnus-message 5 "Adding whitespace to %s" filename) + (save-excursion + (goto-char (point-min)) + (while (re-search-forward "^(\\|(\\\"" nil t) + (replace-match "\n\\&" t)) + (goto-char (point-min)) + (while (re-search-forward " $" nil t) + (replace-match "" t t)))) + +(defun gnus-registry-save (&optional force) + (when (or gnus-registry-dirty force) + (let ((caching gnus-registry-entry-caching)) + ;; turn off entry caching, so mtime doesn't get recorded + (setq gnus-registry-entry-caching nil) + ;; remove entry caches + (maphash + (lambda (key value) + (if (hash-table-p value) + (remhash key gnus-registry-hashtb))) + gnus-registry-hashtb) + ;; 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))) + ;; really save + (gnus-registry-cache-save) + (setq gnus-registry-entry-caching caching) + (setq gnus-registry-dirty nil)))) + +(defun gnus-registry-clean-empty-function () + "Remove all empty entries from the registry. Returns count thereof." + (let ((count 0)) + (maphash + (lambda (key value) + (unless (gnus-registry-fetch-group key) + (incf count) + (remhash key gnus-registry-hashtb))) + 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-dirty nil)) + +(defun gnus-registry-trim (alist) + "Trim alist to size, using 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 + :size 4096 + :test 'equal))) + (maphash + (lambda (key value) + (puthash key (gnus-registry-fetch-extra key 'mtime) timehash)) + gnus-registry-hashtb) + + ;; we use the return value of this setq, which is the trimmed alist + (setq alist + (nthcdr + (- (length alist) gnus-registry-max-entries) + (sort alist + (lambda (a b) + (time-less-p + (cdr (gethash (car a) timehash)) + (cdr (gethash (car b) timehash)))))))))) + +(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)) + +(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)) + (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")) + (old-entry (gethash id gnus-registry-hashtb))) + (gnus-message 5 "Registry: article %s %s from %s to %s" + id + (if method "respooling" "going") + from + to) + + ;; All except copy will need a delete + (gnus-registry-delete-group id from) + + (when (equal 'copy action) + (gnus-registry-add-group id from subject sender)) ; undo the delete + + (gnus-registry-add-group id to subject sender))) + +(defun gnus-registry-spool-action (id group &optional subject sender) + (let ((group (gnus-group-guess-full-name-from-command-method group))) + (when (and (stringp id) (string-match "\r$" id)) + (setq id (substring id 0 -1))) + (gnus-message 5 "Registry: article %s spooled to %s" + id + group) + (gnus-registry-add-group id group subject sender))) + +;; Function for nn{mail|imap}-split-fancy: look up all references in +;; the cache and if a match is found, return that group. +(defun gnus-registry-split-fancy-with-parent () + "Split this message into the same group as its parent. The parent +is obtained from the registry. This function can be used as an entry +in `nnmail-split-fancy' or `nnimap-split-fancy', for example like +this: (: gnus-registry-split-fancy-with-parent) + +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. + +See the Info node `(gnus)Fancy Mail Splitting' for more details." + (let ((refstr (or (message-fetch-field "references") + (message-fetch-field "in-reply-to"))) + (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))) + references res) + (if refstr + (progn + (setq references (nreverse (gnus-split-references refstr))) + (mapcar (lambda (x) + (setq res (or (gnus-registry-fetch-group x) 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))) + references)) + + ;; else: there were no references, now try the extra tracking + (let ((sender (message-fetch-field "from")) + (subject (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)) + (gnus-message + ;; raise level of messaging if gnus-registry-track-extra + (if gnus-registry-track-extra 5 9) + "%s (extra tracking) traced sender %s to group %s" + "gnus-registry-split-fancy-with-parent" + sender + (if res res "nil"))))) + 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)) + (gnus-message + ;; raise level of messaging if gnus-registry-track-extra + (if gnus-registry-track-extra 5 9) + "%s (extra tracking) traced subject %s to group %s" + "gnus-registry-split-fancy-with-parent" + subject + (if res res "nil"))))) + gnus-registry-hashtb)) + (unless single-match + (gnus-message + 5 + "gnus-registry-split-fancy-with-parent: too many extra matches for %s" + refstr) + (setq res nil)))) + (gnus-message + 5 + "gnus-registry-split-fancy-with-parent traced %s to group %s" + refstr (if res res "nil")) + + (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 + (gnus-message + 9 + "gnus-registry-split-fancy-with-parent stripped group %s to %s" + res + short-res) + (setq res short-res)) + ;; else... + (gnus-message + 5 + "gnus-registry-split-fancy-with-parent ignored foreign group %s" + res) + (setq res nil)))) + res)) + +(defun gnus-registry-register-message-ids () + "Register the Message-ID of every article in the group" + (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) + (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) + gnus-newsgroup-name + (gnus-registry-fetch-simplified-message-subject-fast article) + (gnus-registry-fetch-sender-fast article))))))) + +(defun gnus-registry-fetch-message-id-fast (article) + "Fetch the Message-ID quickly, using the internal gnus-data-list function" + (if (and (numberp article) + (assoc article (gnus-data-list nil))) + (mail-header-id (gnus-data-header (assoc article (gnus-data-list nil)))) + nil)) + +(defun gnus-registry-simplify-subject (subject) + (if (stringp subject) + (gnus-simplify-subject subject) + nil)) + +(defun gnus-registry-fetch-simplified-message-subject-fast (article) + "Fetch the Subject quickly, using the internal gnus-data-list function" + (if (and (numberp article) + (assoc article (gnus-data-list nil))) + (gnus-registry-simplify-subject + (mail-header-subject (gnus-data-header + (assoc article (gnus-data-list nil))))) + nil)) + +(defun gnus-registry-fetch-sender-fast (article) + "Fetch the Sender quickly, using the internal gnus-data-list function" + (if (and (numberp article) + (assoc article (gnus-data-list nil))) + (mail-header-from (gnus-data-header + (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 x word)) + list))))) + +(defun gnus-registry-fetch-extra (id &optional entry) + "Get the extra data of a message, based on the message ID. +Returns the first place where the trail finds a nonstring." + (let ((entry-cache (gethash entry gnus-registry-hashtb))) + (if (and entry + (hash-table-p entry-cache) + (gethash id entry-cache)) + (gethash id entry-cache) + ;; else, if there is no caching possible... + (let ((trail (gethash id gnus-registry-hashtb))) + (when (listp trail) + (dolist (crumb trail) + (unless (stringp crumb) + (return (gnus-registry-fetch-extra-entry crumb entry id))))))))) + +(defun gnus-registry-fetch-extra-entry (alist &optional entry id) + "Get the extra data of a message, or a specific entry in it. +Update the entry cache if needed." + (if (and entry id) + (let ((entry-cache (gethash entry gnus-registry-hashtb)) + entree) + (when gnus-registry-entry-caching + ;; create the hash table + (unless (hash-table-p entry-cache) + (setq entry-cache (make-hash-table + :size 4096 + :test 'equal)) + (puthash entry entry-cache gnus-registry-hashtb)) + + ;; get the entree from the hash table or from the alist + (setq entree (gethash id entry-cache))) + + (unless entree + (setq entree (assq entry alist)) + (when gnus-registry-entry-caching + (puthash id entree entry-cache))) + entree) + alist)) + +(defun gnus-registry-store-extra (id extra) + "Store the extra data of a message, based on the message ID. +The message must have at least one group name." + (when (gnus-registry-group-count id) + ;; we now know the trail has at least 1 group name, so it's not empty + (let ((trail (gethash id gnus-registry-hashtb)) + (old-extra (gnus-registry-fetch-extra id)) + entry-cache) + (dolist (crumb trail) + (unless (stringp crumb) + (dolist (entry crumb) + (setq entry-cache (gethash (car entry) gnus-registry-hashtb)) + (when entry-cache + (remhash id entry-cache)))) + (puthash id (cons extra (delete old-extra trail)) + gnus-registry-hashtb) + (setq gnus-registry-dirty t))))) + +(defun gnus-registry-store-extra-entry (id key value) + "Put a specific entry in the extras field of the registry entry for id." + (let* ((extra (gnus-registry-fetch-extra id)) + (alist (cons (cons key value) + (gnus-assq-delete-all key (gnus-registry-fetch-extra id))))) + (gnus-registry-store-extra id alist))) + +(defun gnus-registry-fetch-group (id) + "Get the group of a message, based on the message ID. +Returns the first place where the trail finds a group name." + (when (gnus-registry-group-count id) + ;; we now know the trail has at least 1 group name + (let ((trail (gethash id gnus-registry-hashtb))) + (dolist (crumb trail) + (when (stringp crumb) + (return (if gnus-registry-use-long-group-names + crumb + (gnus-group-short-name crumb)))))))) + +(defun gnus-registry-group-count (id) + "Get the number of groups of a message, based on the message ID." + (let ((trail (gethash id gnus-registry-hashtb))) + (if (and trail (listp trail)) + (apply '+ (mapcar (lambda (x) (if (stringp x) 1 0)) trail)) + 0))) + +(defun gnus-registry-delete-group (id group) + "Delete a group for a message, based on the message ID." + (when group + (when id + (let ((trail (gethash id gnus-registry-hashtb)) + (group (gnus-group-short-name group))) + (puthash id (if trail + (delete group trail) + nil) + gnus-registry-hashtb)) + ;; now, clear the entry if there are no more groups + (when gnus-registry-trim-articles-without-groups + (unless (gnus-registry-group-count id) + (gnus-registry-delete-id id))) + (gnus-registry-store-extra-entry id 'mtime (current-time))))) + +(defun gnus-registry-delete-id (id) + "Delete a message ID from the registry." + (when (stringp id) + (remhash id gnus-registry-hashtb) + (maphash + (lambda (key value) + (when (hash-table-p value) + (remhash id value))) + gnus-registry-hashtb))) + +(defun gnus-registry-add-group (id group &optional subject sender) + "Add a group for a message, based on the message ID." + (when group + (when (and id + (not (string-match "totally-fudged-out-message-id" id))) + (let ((full-group group) + (group (if gnus-registry-use-long-group-names + group + (gnus-group-short-name group)))) + (gnus-registry-delete-group id group) + + (unless gnus-registry-use-long-group-names ;; unnecessary in this case + (gnus-registry-delete-group id full-group)) + + (let ((trail (gethash id gnus-registry-hashtb))) + (puthash id (if trail + (cons group trail) + (list group)) + gnus-registry-hashtb) + + (when (and (gnus-registry-track-subject-p) + subject) + (gnus-registry-store-extra-entry + id + 'subject + (gnus-registry-simplify-subject subject))) + (when (and (gnus-registry-track-sender-p) + sender) + (gnus-registry-store-extra-entry + id + 'sender + sender)) + + (gnus-registry-store-extra-entry id 'mtime (current-time))))))) + +(defun gnus-registry-clear () + "Clear the Gnus registry." + (interactive) + (setq gnus-registry-alist nil) + (setq gnus-registry-hashtb (alist-to-hashtable gnus-registry-alist)) + (setq gnus-registry-dirty t)) + +;;;###autoload +(defun gnus-registry-initialize () + (interactive) + (setq gnus-registry-install t) + (gnus-registry-install-hooks) + (gnus-registry-read)) + +;;;###autoload +(defun gnus-registry-install-hooks () + "Install the registry hooks." + (interactive) + (add-hook 'gnus-summary-article-move-hook 'gnus-registry-action) + (add-hook 'gnus-summary-article-delete-hook 'gnus-registry-action) + (add-hook 'gnus-summary-article-expire-hook 'gnus-registry-action) + (add-hook 'nnmail-spool-hook 'gnus-registry-spool-action) + + (add-hook 'gnus-save-newsrc-hook 'gnus-registry-save) + (add-hook 'gnus-read-newsrc-el-hook 'gnus-registry-read) + + (add-hook 'gnus-summary-prepare-hook 'gnus-registry-register-message-ids)) + +(defun gnus-registry-unload-hook () + "Uninstall the registry hooks." + (interactive) + (remove-hook 'gnus-summary-article-move-hook 'gnus-registry-action) + (remove-hook 'gnus-summary-article-delete-hook 'gnus-registry-action) + (remove-hook 'gnus-summary-article-expire-hook 'gnus-registry-action) + (remove-hook 'nnmail-spool-hook 'gnus-registry-spool-action) + + (remove-hook 'gnus-save-newsrc-hook 'gnus-registry-save) + (remove-hook 'gnus-read-newsrc-el-hook 'gnus-registry-read) + + (remove-hook 'gnus-summary-prepare-hook 'gnus-registry-register-message-ids)) + +(when gnus-registry-install + (gnus-registry-install-hooks) + (gnus-registry-read)) + +;; TODO: a lot of things + +(provide 'gnus-registry) + +;;; arch-tag: 5cba0a32-718a-4a97-8c91-0a15af21da94 +;;; gnus-registry.el ends here |