Mercurial > emacs

;;; 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.

;; 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 3, 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, which works with all
;; backends, not just nnmail (e.g. NNTP).  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-adaptive-word-syntax-table)

(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 (make-hash-table
			      :size 256
			      :test 'equal)
  "*The article registry by Message ID.")

(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
qualified.  This parameter tells the Registry 'never split a
message into a group that matches one of these, regardless of
references.'"
  :group 'gnus-registry
  :type '(repeat regexp))

(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
and no extra data."
  :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
  (nnheader-concat
   (or gnus-dribble-directory gnus-home-directory "~/")
   ".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")))

(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))))

;; 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*"))
      (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)
		(gnus-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 7 "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 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)
      (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)
       (when (stringp key)
	 (dolist (group (gnus-registry-fetch-groups key))
	   (when (gnus-parameter-registry-ignore group)
	     (gnus-message
	      10
	      "gnus-registry: deleted ignored group %s from key %s"
	      group key)
	     (gnus-registry-delete-group key group)))

	 (unless (gnus-registry-group-count key)
	   (gnus-registry-delete-id key))

	 (unless (or
		  (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))
	   (incf count)
	   (gnus-registry-delete-id key))

	 (unless (stringp key)
	   (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 (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."
  (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
		      (or (cdr (gethash (car a) timehash)) '(0 0 0))
		      (or (cdr (gethash (car b) timehash)) '(0 0 0))))))))))

(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 (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 7 "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 7 "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)

This function tracks ALL backends, unlike
`nnmail-split-fancy-with-parent' which tracks only nnmail
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, unless it matches one of the entries in
gnus-registry-unfollowed-groups or
nnmail-split-fancy-with-parent-ignore-groups.

See the Info node `(gnus)Fancy Mail Splitting' for more details."
  (let* ((refstr (or (message-fetch-field "references") "")) ; guarantee string
	 (reply-to (message-fetch-field "in-reply-to"))	     ; grab reply-to
	 ;; now, if reply-to is valid, append it to the References
	 (refstr (if reply-to
		     (concat refstr " " reply-to)
		   refstr))
	(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)))
	res)
    ;; the references string must be valid and parse to valid references
    (if (and refstr (gnus-extract-references refstr))
	(dolist (reference (nreverse (gnus-extract-references refstr)))
	  (setq res (or (gnus-registry-fetch-group reference) 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)))

      ;; else: there were no references, now try the extra tracking
      (let ((sender (gnus-string-remove-all-properties(message-fetch-field "from")))
	    (subject (gnus-string-remove-all-properties
		      (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))
		 (when (and sender res)
		   (gnus-message
		    ;; raise level of messaging if gnus-registry-track-extra
		    (if gnus-registry-track-extra 7 9)
		    "%s (extra tracking) traced sender %s to group %s"
		    "gnus-registry-split-fancy-with-parent"
		    sender
		    res)))))
	   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))
		 (when (and subject res)
		   (gnus-message
		    ;; raise level of messaging if gnus-registry-track-extra
		    (if gnus-registry-track-extra 7 9)
		    "%s (extra tracking) traced subject %s to group %s"
		    "gnus-registry-split-fancy-with-parent"
		    subject
		    res)))))
	   gnus-registry-hashtb))
	(unless single-match
	  (gnus-message
	   3
	   "gnus-registry-split-fancy-with-parent: too many extra matches for %s"
	   refstr)
	  (setq res nil))))
    (when (and refstr res)
      (gnus-message
       5
       "gnus-registry-split-fancy-with-parent traced %s to group %s"
       refstr res))

    (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
	 7
	 "gnus-registry-split-fancy-with-parent ignored foreign group %s"
	 res)
	(setq res nil))))
    res))

(defun gnus-registry-wash-for-keywords (&optional force)
  (interactive)
  (let ((id (gnus-registry-fetch-message-id-fast gnus-current-article))
	word words)
    (if (or (not (gnus-registry-fetch-extra id 'keywords))
	    force)
	(save-excursion
	  (set-buffer gnus-article-buffer)
	  (article-goto-body)
	  (save-window-excursion
	    (save-restriction
	      (narrow-to-region (point) (point-max))
	      (with-syntax-table gnus-adaptive-word-syntax-table
		(while (re-search-forward "\\b\\w+\\b" nil t)
		  (setq word (gnus-registry-remove-alist-text-properties
			      (downcase (buffer-substring
					 (match-beginning 0) (match-end 0)))))
		  (if (> (length word) 3)
		      (push word words))))))
	  (gnus-registry-store-extra-entry id 'keywords words)))))

(defun gnus-registry-find-keywords (keyword)
  (interactive "skeyword: ")
  (let (articles)
    (maphash
     (lambda (key value)
       (when (gnus-registry-grep-in-list
	      keyword
	      (cdr (gnus-registry-fetch-extra key 'keywords)))
	 (push key articles)))
     gnus-registry-hashtb)
    articles))

(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-string-remove-all-properties
       (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)))
      (gnus-string-remove-all-properties
       (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 word x))
		   list)))))

(defun gnus-registry-mark-article (article &optional mark remove)
  "Mark ARTICLE with MARK in the Gnus registry or remove MARK.
MARK can be any symbol.  If ARTICLE is nil, then the
`gnus-current-article' will be marked.  If MARK is nil,
`gnus-registry-flag-default' will be used."
  (interactive "nArticle number: ")
  (let ((article (or article gnus-current-article))
	(mark (or mark 'gnus-registry-flag-default))
	article-id)
    (unless article
      (error "No article on current line"))
    (setq article-id
	  (gnus-registry-fetch-message-id-fast gnus-current-article))
    (unless article-id
      (error "No article ID could be retrieved"))
    (let* (
	   ;; all the marks for this article
	   (marks (gnus-registry-fetch-extra-flags article-id))
	   ;; the marks without the mark of interest
	   (cleaned-marks (delq mark marks))
	   ;; the new marks we want to use
	   (new-marks (if remove
			  cleaned-marks
			(cons mark cleaned-marks))))
    (apply 'gnus-registry-store-extra-flags ; set the extra flags
     article-id				    ; for the message ID
     new-marks)
    (gnus-registry-fetch-extra-flags article-id))))

(defun gnus-registry-article-marks (article)
  "Get the Gnus registry marks for ARTICLE.
If ARTICLE is nil, then the `gnus-current-article' will be
used."
  (interactive "nArticle number: ")
  (let ((article (or article gnus-current-article))
	article-id)
    (unless article
      (error "No article on current line"))
    (setq article-id
	  (gnus-registry-fetch-message-id-fast gnus-current-article))
    (unless article-id
      (error "No article ID could be retrieved"))
    (gnus-message 1
		  "Message ID %s, Registry flags: %s"
		  article-id
		  (concat (gnus-registry-fetch-extra-flags article-id)))))


;;; if this extends to more than 'flags, it should be improved to be more generic.
(defun gnus-registry-fetch-extra-flags (id)
  "Get the flags of a message, based on the message ID.
Returns a list of symbol flags or nil."
  (car-safe (cdr (gnus-registry-fetch-extra id 'flags))))

(defun gnus-registry-has-extra-flag (id flag)
  "Checks if a message has `flag', based on the message ID."
  (memq flag (gnus-registry-fetch-extra-flags id)))

(defun gnus-registry-store-extra-flags (id &rest flag-list)
  "Set the flags of a message, based on the message ID.
The `flag-list' can be nil, in which case no flags are left."
  (gnus-registry-store-extra-entry id 'flags (list flag-list)))

(defun gnus-registry-delete-extra-flags (id &rest flag-delete-list)
  "Delete the message flags in `flag-delete-list', based on the message ID."
  (let ((flags (gnus-registry-fetch-extra-flags id)))
    (when flags
      (dolist (flag flag-delete-list)
	(setq flags (delq flag flags))))
    (gnus-registry-store-extra-flags id (car flags))))

(defun gnus-registry-delete-all-extra-flags (id)
  "Delete all the flags for a message ID."
  (gnus-registry-store-extra-flags id nil))

(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-delete-extra-entry (id key)
  "Delete a specific entry in the extras field of the registry entry for id."
  (gnus-registry-store-extra-entry id key nil))

(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))
	 ;; all the entries except the one for `key'
	 (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)
			   the-rest))
		  the-rest)))
    (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-fetch-groups (id)
  "Get the groups 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
	 groups
	 (cons
	  (if (or (not (stringp crumb)) gnus-registry-use-long-group-names)
	      crumb
	    (gnus-group-short-name crumb))
	 groups))))
    ;; return the list of groups
    groups))

(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 (and group id)
      (let ((trail (gethash id gnus-registry-hashtb))
	    (short-group (gnus-group-short-name group)))
	(puthash id (if trail
			(delete short-group (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
author	Kenichi Handa <handa@m17n.org>
date	Mon, 14 Jan 2008 01:33:15 +0000 (2008-01-14)
parents	107ccd98fa12
children	1bb83c2fe524