mirror of
https://git.savannah.gnu.org/git/emacs.git
synced 2024-12-12 09:28:24 +00:00
996aa8c1e6
Patches applied: * gnus--rel--5.10 (patch 145-148) - Merge from emacs--devo--0 - Update from CVS 2006-10-04 Reiner Steib <Reiner.Steib@gmx.de> * lisp/gnus/gnus-sum.el (gnus-summary-make-menu-bar): Clarify gnus-summary-limit-to-articles. 2006-10-04 Romain Francoise <romain@orebokech.com> * lisp/gnus/gnus-util.el (gnus-alist-to-hashtable, gnus-hashtable-to-alist): Moved here (and renamed) from gnus-registry.el. * lisp/gnus/gnus-registry.el: Require gnus-util. Use `gnus-alist-to-hashtable' and `gnus-hashtable-to-alist'. 2006-10-04 Reiner Steib <Reiner.Steib@gmx.de> * lisp/gnus/pop3.el (pop3-authentication-scheme): Clarify doc. (pop3-movemail): Warn about pop3-leave-mail-on-server. 2006-10-04 Dave Love <fx@gnu.org> * lisp/gnus/pop3.el (pop3-authentication-scheme): Add custom version. 2006-10-04 Jesper Harder <harder@ifa.au.dk> * lisp/gnus/pop3.el (pop3-leave-mail-on-server): Don't quote nil in doc string. Improve doc string. 2006-10-03 Katsumi Yamaoka <yamaoka@jpl.org> * lisp/gnus/gnus-util.el (gnus-with-local-quit): New macro. * lisp/gnus/gnus-demon.el (gnus-demon): Replace with-local-quit with it. 2006-10-06 Reiner Steib <Reiner.Steib@gmx.de> * man/gnus.texi (Image Enhancements): Update for Emacs 22. * man/gnus-faq.texi ([1.3]): Update. Revision: emacs@sv.gnu.org/emacs--devo--0--patch-466
694 lines
23 KiB
EmacsLisp
694 lines
23 KiB
EmacsLisp
;;; gnus-registry.el --- article registry for Gnus
|
|
|
|
;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
|
|
;; 2005, 2006 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., 51 Franklin Street, Fifth Floor,
|
|
;; Boston, MA 02110-1301, 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 'gnus-util)
|
|
(require 'nnmail)
|
|
|
|
(defvar gnus-registry-dirty t
|
|
"Boolean set to t when the registry is modified")
|
|
|
|
(defgroup gnus-registry nil
|
|
"The Gnus registry."
|
|
:version "22.1"
|
|
: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")))
|
|
|
|
;; 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
|
|
(gnus-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 (gnus-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))
|
|
(trim-length (- (length alist) gnus-registry-max-entries))
|
|
(trim-length (if (natnump trim-length) trim-length 0)))
|
|
(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
|
|
trim-length
|
|
(sort alist
|
|
(lambda (a b)
|
|
(time-less-p
|
|
(cdr (gethash (car a) timehash))
|
|
(cdr (gethash (car b) timehash))))))))))
|
|
|
|
(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)))
|
|
;; is this ID still in the registry?
|
|
(when (gethash id gnus-registry-hashtb)
|
|
(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 (gnus-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))
|
|
|
|
(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
|
|
|
|
(provide 'gnus-registry)
|
|
|
|
;;; arch-tag: 5cba0a32-718a-4a97-8c91-0a15af21da94
|
|
;;; gnus-registry.el ends here
|