git.chise.org Git - elisp/gnus.git-/blob - lisp/gnus-registry.el

   1 ;;; gnus-registry.el --- article registry for Gnus
   2 ;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003
   3 ;;        Free Software Foundation, Inc.
   4
   5 ;; Author: Ted Zlatanov <tzz@lifelogs.com>
   6 ;; Keywords: news
   7
   8 ;; This file is part of GNU Emacs.
   9
  10 ;; GNU Emacs is free software; you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation; either version 2, or (at your option)
  13 ;; any later version.
  14
  15 ;; GNU Emacs is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23 ;; Boston, MA 02111-1307, USA.
  24
  25 ;;; Commentary:
  26
  27 ;;; Code:
  28
  29 (eval-when-compile (require 'cl))
  30
  31 (require 'gnus)
  32 (require 'gnus-int)
  33 (require 'gnus-sum)
  34 (require 'nnmail)
  35
  36 (defgroup gnus-registry nil
  37   "The Gnus registry."
  38   :group 'gnus)
  39
  40 (defvar gnus-registry-hashtb nil
  41   "*The article registry by Message ID.")
  42
  43 (defcustom gnus-registry-unfollowed-groups '("delayed" "drafts" "queue")
  44   "List of groups that gnus-registry-split-fancy-with-parent won't follow.
  45 The group names are matched, they don't have to be fully qualified."
  46   :group 'gnus-registry
  47   :type '(repeat string))
  48
  49 (defcustom gnus-registry-install nil
  50   "Whether the registry should be installed."
  51   :group 'gnus-registry
  52   :type 'boolean)
  53
  54 (defcustom gnus-registry-cache-file "~/.gnus.registry.eld"
  55   "File where the Gnus registry will be stored."
  56   :group 'gnus-registry
  57   :type 'file)
  58
  59 ;; Function(s) missing in Emacs 20
  60 (when (memq nil (mapcar 'fboundp '(puthash)))
  61   (require 'cl)
  62   (unless (fboundp 'puthash)
  63     ;; alias puthash is missing from Emacs 20 cl-extra.el
  64     (defalias 'puthash 'cl-puthash)))
  65
  66 (defun gnus-registry-cache-read ()
  67   "Read the registry cache file."
  68   (interactive)
  69   (let ((file gnus-registry-cache-file))
  70     (when (file-exists-p file)
  71       (gnus-message 5 "Reading %s..." file)
  72       (gnus-load file)
  73       (gnus-message 5 "Reading %s...done" file))))
  74
  75 (defun gnus-registry-cache-save ()
  76   "Save the registry cache file."
  77   (interactive)
  78   (let ((file gnus-registry-cache-file))
  79     (save-excursion
  80       ;; Save .newsrc.eld.
  81       (set-buffer (gnus-get-buffer-create " *Gnus-registry-cache*"))
  82       (make-local-variable 'version-control)
  83     (setq version-control gnus-backup-startup-file)
  84     (setq buffer-file-name file)
  85     (setq default-directory (file-name-directory buffer-file-name))
  86     (buffer-disable-undo)
  87     (erase-buffer)
  88     (gnus-message 5 "Saving %s..." file)
  89     (if gnus-save-startup-file-via-temp-buffer
  90         (let ((coding-system-for-write gnus-ding-file-coding-system)
  91               (standard-output (current-buffer)))
  92           (gnus-gnus-to-quick-newsrc-format t "gnus registry startup file" 'gnus-registry-alist)
  93           (gnus-registry-cache-whitespace file)
  94           (save-buffer))
  95       (let ((coding-system-for-write gnus-ding-file-coding-system)
  96             (version-control gnus-backup-startup-file)
  97             (startup-file file)
  98             (working-dir (file-name-directory file))
  99             working-file
 100             (i -1))
 101         ;; Generate the name of a non-existent file.
 102         (while (progn (setq working-file
 103                             (format
 104                              (if (and (eq system-type 'ms-dos)
 105                                       (not (gnus-long-file-names)))
 106                                  "%s#%d.tm#" ; MSDOS limits files to 8+3
 107                                (if (memq system-type '(vax-vms axp-vms))
 108                                    "%s$tmp$%d"
 109                                  "%s#tmp#%d"))
 110                              working-dir (setq i (1+ i))))
 111                       (file-exists-p working-file)))
 112
 113         (unwind-protect
 114             (progn
 115               (gnus-with-output-to-file working-file
 116                 (gnus-gnus-to-quick-newsrc-format t "gnus registry startup file" 'gnus-registry-alist))
 117
 118               ;; These bindings will mislead the current buffer
 119               ;; into thinking that it is visiting the startup
 120               ;; file.
 121               (let ((buffer-backed-up nil)
 122                     (buffer-file-name startup-file)
 123                     (file-precious-flag t)
 124                     (setmodes (file-modes startup-file)))
 125                 ;; Backup the current version of the startup file.
 126                 (backup-buffer)
 127
 128                 ;; Replace the existing startup file with the temp file.
 129                 (rename-file working-file startup-file t)
 130                 (set-file-modes startup-file setmodes)))
 131           (condition-case nil
 132               (delete-file working-file)
 133             (file-error nil)))))
 134
 135     (gnus-kill-buffer (current-buffer))
 136     (gnus-message 5 "Saving %s...done" file))))
 137
 138 ;; Idea from Dan Christensen <jdc@chow.mat.jhu.edu>
 139 ;; Save the gnus-registry file with extra line breaks.
 140 (defun gnus-registry-cache-whitespace (filename)
 141   (gnus-message 4 "Adding whitespace to %s" filename)
 142   (save-excursion
 143     (goto-char (point-min))
 144     (while (re-search-forward "^(\\|(\\\"" nil t)
 145       (replace-match "\n\\&" t))
 146     (goto-char (point-min))
 147     (while (re-search-forward " $" nil t)
 148       (replace-match "" t t))))
 149
 150 (defun gnus-registry-save ()
 151   (setq gnus-registry-alist (hashtable-to-alist gnus-registry-hashtb))
 152   (gnus-registry-cache-save))
 153
 154 (defun gnus-registry-read ()
 155   (gnus-registry-cache-read)
 156   (setq gnus-registry-hashtb (alist-to-hashtable gnus-registry-alist)))
 157
 158 (defun alist-to-hashtable (alist)
 159   "Build a hashtable from the values in ALIST."
 160   (let ((ht (make-hash-table
 161              :size 4096
 162              :test 'equal)))
 163     (mapc
 164      (lambda (kv-pair)
 165        (puthash (car kv-pair) (cdr kv-pair) ht))
 166      alist)
 167      ht))
 168
 169 (defun hashtable-to-alist (hash)
 170   "Build an alist from the values in HASH."
 171   (let ((list nil))
 172     (maphash
 173      (lambda (key value)
 174        (setq list (cons (cons key value) list)))
 175      hash)
 176     list))
 177
 178 (defun gnus-register-action (action data-header from &optional to method)
 179   (let* ((id (mail-header-id data-header))
 180         (from (gnus-group-guess-full-name from))
 181         (to (if to (gnus-group-guess-full-name to) nil))
 182         (to-name (if to to "the Bit Bucket"))
 183         (old-entry (gethash id gnus-registry-hashtb)))
 184     (gnus-message 5 "Registry: article %s %s from %s to %s"
 185                   id
 186                   (if method "respooling" "going")
 187                   from
 188                   to)
 189
 190     ;; All except copy will need a delete
 191     (gnus-registry-delete-group id from)
 192
 193     (when (equal 'copy action)
 194       (gnus-registry-add-group id from)) ; undo the delete
 195
 196     (gnus-registry-add-group id to)))
 197
 198 (defun gnus-register-spool-action (id group)
 199   ;; do not process the draft IDs
 200 ;  (unless (string-match "totally-fudged-out-message-id" id)
 201 ;    (let ((group (gnus-group-guess-full-name group)))
 202   (when (string-match "\r$" id)
 203     (setq id (substring id 0 -1)))
 204   (gnus-message 5 "Registry: article %s spooled to %s"
 205                 id
 206                 group)
 207   (gnus-registry-add-group id group))
 208 ;)
 209
 210 ;; Function for nn{mail|imap}-split-fancy: look up all references in
 211 ;; the cache and if a match is found, return that group.
 212 (defun gnus-registry-split-fancy-with-parent ()
 213   "Split this message into the same group as its parent.  The parent
 214 is obtained from the registry.  This function can be used as an entry
 215 in `nnmail-split-fancy' or `nnimap-split-fancy', for example like
 216 this: (: gnus-registry-split-fancy-with-parent)
 217
 218 For a message to be split, it looks for the parent message in the
 219 References or In-Reply-To header and then looks in the registry to
 220 see which group that message was put in.  This group is returned.
 221
 222 See the Info node `(gnus)Fancy Mail Splitting' for more details."
 223   (let ((refstr (or (message-fetch-field "references")
 224                     (message-fetch-field "in-reply-to")))
 225         (nnmail-split-fancy-with-parent-ignore-groups
 226          (if (listp nnmail-split-fancy-with-parent-ignore-groups)
 227              nnmail-split-fancy-with-parent-ignore-groups
 228            (list nnmail-split-fancy-with-parent-ignore-groups)))
 229         references res)
 230     (when refstr
 231       (setq references (nreverse (gnus-split-references refstr)))
 232       (mapcar (lambda (x)
 233                 (setq res (or (gnus-registry-fetch-group x) res))
 234                 (when (or (gnus-registry-grep-in-list
 235                            res
 236                            gnus-registry-unfollowed-groups)
 237                           (gnus-registry-grep-in-list
 238                            res
 239                            nnmail-split-fancy-with-parent-ignore-groups))
 240                   (setq res nil)))
 241               references)
 242       (gnus-message
 243        5
 244        "gnus-registry-split-fancy-with-parent traced %s to group %s"
 245        refstr (if res res "nil"))
 246       res)))
 247
 248 (defun gnus-registry-register-message-ids ()
 249   "Register the Message-ID of every article in the group"
 250   (unless (gnus-parameter-registry-ignore gnus-newsgroup-name)
 251     (dolist (article gnus-newsgroup-articles)
 252       (let ((id (gnus-registry-fetch-message-id-fast article)))
 253         (unless (gnus-registry-fetch-group id)
 254           (gnus-message 9 "Registry: Registering article %d with group %s"
 255                         article gnus-newsgroup-name)
 256           (gnus-registry-add-group (gnus-registry-fetch-message-id-fast article)
 257                                    gnus-newsgroup-name))))))
 258
 259 (defun gnus-registry-fetch-message-id-fast (article)
 260   "Fetch the Message-ID quickly, using the internal gnus-data-list function"
 261   (if (and (numberp article)
 262            (assoc article (gnus-data-list nil)))
 263       (mail-header-id (gnus-data-header (assoc article (gnus-data-list nil))))
 264     nil))
 265
 266 (defun gnus-registry-grep-in-list (word list)
 267   (when word
 268     (memq nil
 269           (mapcar 'not
 270                   (mapcar
 271                    (lambda (x)
 272                      (string-match x word))
 273                    list)))))
 274
 275 (defun gnus-registry-fetch-extra (id &optional entry)
 276   "Get the extra data of a message, based on the message ID.
 277 Returns the first place where the trail finds a nonstring."
 278   (let ((trail (gethash id gnus-registry-hashtb)))
 279     (dolist (crumb trail)
 280       (unless (stringp crumb)
 281         (return (gnus-registry-fetch-extra-entry crumb entry))))))
 282
 283 (defun gnus-registry-fetch-extra-entry (alist &optional entry)
 284   "Get the extra data of a message, or a specific entry in it."
 285   (if entry
 286       (assq entry alist)
 287     alist))
 288
 289 (defun gnus-registry-store-extra (id extra)
 290   "Store the extra data of a message, based on the message ID.
 291 The message must have at least one group name."
 292   (when (gnus-registry-group-count id)
 293     ;; we now know the trail has at least 1 group name, so it's not empty
 294     (let ((trail (gethash id gnus-registry-hashtb))
 295           (old-extra (gnus-registry-fetch-extra id)))
 296       (puthash id (cons extra (delete old-extra trail))
 297                gnus-registry-hashtb))))
 298
 299 (defun gnus-registry-store-extra-entry (id key value)
 300   "Put a specific entry in the extras field of the registry entry for id."
 301   (let* ((extra (gnus-registry-fetch-extra id))
 302          (alist (cons (cons key value)
 303                  (gnus-assq-delete-all key (gnus-registry-fetch-extra id)))))
 304     (gnus-registry-store-extra id alist)))
 305
 306 (defun gnus-registry-fetch-group (id)
 307   "Get the group of a message, based on the message ID.
 308 Returns the first place where the trail finds a group name."
 309   (when (gnus-registry-group-count id)
 310     ;; we now know the trail has at least 1 group name
 311     (let ((trail (gethash id gnus-registry-hashtb)))
 312       (dolist (crumb trail)
 313         (when (stringp crumb)
 314           (return crumb))))))
 315
 316 (defun gnus-registry-group-count (id)
 317   "Get the number of groups of a message, based on the message ID."
 318   (let ((trail (gethash id gnus-registry-hashtb)))
 319     (if (and trail (listp trail))
 320         (apply '+ (mapcar (lambda (x) (if (stringp x) 1 0)) trail))
 321       0)))
 322
 323 (defun gnus-registry-delete-group (id group)
 324   "Delete a group for a message, based on the message ID."
 325   (when group
 326     (when id
 327       (let ((trail (gethash id gnus-registry-hashtb))
 328             (group (gnus-group-short-name group)))
 329         (puthash id (if trail
 330                         (delete group trail)
 331                       nil)
 332                  gnus-registry-hashtb))
 333       ;; now, clear the entry if there are no more groups
 334       (unless (gnus-registry-group-count id)
 335         (remhash id gnus-registry-hashtb))
 336       (gnus-registry-store-extra-entry id 'mtime (current-time)))))
 337
 338 (defun gnus-registry-add-group (id group &rest extra)
 339   "Add a group for a message, based on the message ID."
 340   ;; make sure there are no duplicate entries
 341   (when group
 342     (when (and id
 343                (not (string-match "totally-fudged-out-message-id" id)))
 344       (let ((group (gnus-group-short-name group)))
 345         (gnus-registry-delete-group id group)
 346         (let ((trail (gethash id gnus-registry-hashtb)))
 347           (puthash id (if trail
 348                           (cons group trail)
 349                         (list group))
 350                    gnus-registry-hashtb)
 351           (when extra (gnus-registry-store-extra id extra))
 352           (gnus-registry-store-extra-entry id 'mtime (current-time)))))))
 353
 354 (defun gnus-registry-clear ()
 355   "Clear the Gnus registry."
 356   (interactive)
 357   (setq gnus-registry-alist nil)
 358   (setq gnus-registry-hashtb (alist-to-hashtable gnus-registry-alist)))
 359
 360 (defun gnus-registry-install-hooks ()
 361   "Install the registry hooks."
 362   (interactive)
 363   (add-hook 'gnus-summary-article-move-hook 'gnus-register-action)
 364   (add-hook 'gnus-summary-article-delete-hook 'gnus-register-action)
 365   (add-hook 'gnus-summary-article-expire-hook 'gnus-register-action)
 366   (add-hook 'nnmail-spool-hook 'gnus-register-spool-action)
 367
 368   (add-hook 'gnus-save-newsrc-hook 'gnus-registry-save)
 369   (add-hook 'gnus-read-newsrc-el-hook 'gnus-registry-read)
 370
 371   (add-hook 'gnus-summary-prepare-hook 'gnus-registry-register-message-ids))
 372
 373 (when gnus-registry-install
 374   (gnus-registry-install-hooks))
 375
 376 ;; TODO: a lot of things
 377
 378 (provide 'gnus-registry)
 379
 380 ;;; gnus-registry.el ends here