emacs-diffs
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

[Emacs-diffs] Changes to emacs/lisp/gnus/gnus-registry.el [lexbind]


From: Miles Bader
Subject: [Emacs-diffs] Changes to emacs/lisp/gnus/gnus-registry.el [lexbind]
Date: Wed, 15 Sep 2004 20:36:44 -0400

Index: emacs/lisp/gnus/gnus-registry.el
diff -c /dev/null emacs/lisp/gnus/gnus-registry.el:1.3.2.1
*** /dev/null   Thu Sep 16 00:12:57 2004
--- emacs/lisp/gnus/gnus-registry.el    Thu Sep 16 00:12:15 2004
***************
*** 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 <address@hidden>
+ ;; 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 <address@hidden>
+ ;; 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




reply via email to

[Prev in Thread] Current Thread [Next in Thread]