cgit.sxemacs.org Git - gnus/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-cache-file "~/.gnus.registry.eld"
  50   "File where the Gnus registry will be stored."
  51   :group 'gnus-registry
  52   :type 'file)
  53
  54 (defcustom gnus-registry-unregistered-group-regex "^nntp"
  55   "Group name regex that gnus-registry-register-message-ids won't process."
  56   :group 'gnus-registry
  57   :type 'regexp)
  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 (and gnus-registry-unregistered-group-regex
 251                (string-match gnus-registry-unregistered-group-regex gnus-newsgroup-name))
 252     (dolist (article gnus-newsgroup-articles)
 253       (let ((id (gnus-registry-fetch-message-id-fast article)))
 254         (unless (gnus-registry-fetch-group id)
 255           (gnus-message 9 "Registry: Registering article %d with group %s"
 256                         article gnus-newsgroup-name)
 257           (gnus-registry-add-group (gnus-registry-fetch-message-id-fast article)
 258                                    gnus-newsgroup-name))))))
 259
 260 (defun gnus-registry-fetch-message-id-fast (article)
 261   "Fetch the Message-ID quickly, using the internal gnus-data-list function"
 262   (if (and (numberp article)
 263            (assoc article (gnus-data-list nil)))
 264       (mail-header-id (gnus-data-header (assoc article (gnus-data-list nil))))
 265     nil))
 266
 267 (defun gnus-registry-grep-in-list (word list)
 268   (when word
 269     (memq nil
 270           (mapcar 'not
 271                   (mapcar
 272                    (lambda (x)
 273                      (string-match x word))
 274                    list)))))
 275
 276 (defun gnus-registry-fetch-extra (id)
 277   "Get the extra data of a message, based on the message ID.
 278 Returns the first place where the trail finds a nonstring."
 279   (let ((trail (gethash id gnus-registry-hashtb)))
 280     (dolist (crumb trail)
 281       (unless (stringp crumb)
 282         (return crumb)))))
 283
 284 (defun gnus-registry-store-extra (id extra)
 285   "Store the extra data of a message, based on the message ID.
 286 The message must have at least one group name."
 287   (when (gnus-registry-group-count id)
 288     ;; we now know the trail has at least 1 group name, so it's not empty
 289     (let ((trail (gethash id gnus-registry-hashtb))
 290           (old-extra (gnus-registry-fetch-extra id)))
 291       (puthash id (cons extra (delete old-extra trail))
 292                gnus-registry-hashtb))))
 293
 294 (defun gnus-registry-fetch-group (id)
 295   "Get the group of a message, based on the message ID.
 296 Returns the first place where the trail finds a group name."
 297   (when (gnus-registry-group-count id)
 298     ;; we now know the trail has at least 1 group name
 299     (let ((trail (gethash id gnus-registry-hashtb)))
 300       (dolist (crumb trail)
 301         (when (stringp crumb)
 302           (return crumb))))))
 303
 304 (defun gnus-registry-group-count (id)
 305   "Get the number of groups of a message, based on the message ID."
 306   (let ((trail (gethash id gnus-registry-hashtb)))
 307     (if (and trail (listp trail))
 308         (apply '+ (mapcar (lambda (x) (if (stringp x) 1 0)) trail))
 309       0)))
 310
 311 (defun gnus-registry-delete-group (id group)
 312   "Delete a group for a message, based on the message ID."
 313   (when group
 314     (when id
 315       (let ((trail (gethash id gnus-registry-hashtb))
 316             (group (gnus-group-short-name group)))
 317         (puthash id (if trail
 318                         (delete group trail)
 319                       nil)
 320                  gnus-registry-hashtb))
 321       ;; now, clear the entry if there are no more groups
 322       (unless (gnus-registry-group-count id)
 323         (remhash id gnus-registry-hashtb)))))
 324
 325 (defun gnus-registry-add-group (id group &rest extra)
 326   "Add a group for a message, based on the message ID."
 327   ;; make sure there are no duplicate entries
 328   (when group
 329     (when (and id
 330                (not (string-match "totally-fudged-out-message-id" id)))
 331       (let ((group (gnus-group-short-name group)))
 332         (gnus-registry-delete-group id group)
 333         (let ((trail (gethash id gnus-registry-hashtb)))
 334           (puthash id (if trail
 335                           (cons group trail)
 336                         (list group))
 337                    gnus-registry-hashtb)
 338           (when extra (gnus-registry-store-extra id extra)))))))
 339
 340 (defun gnus-registry-clear ()
 341   "Clear the Gnus registry."
 342   (interactive)
 343   (setq gnus-registry-alist nil)
 344   (setq gnus-registry-hashtb (alist-to-hashtable gnus-registry-alist)))
 345
 346 ; also does copy, respool, and crosspost
 347 (add-hook 'gnus-summary-article-move-hook 'gnus-register-action)
 348 (add-hook 'gnus-summary-article-delete-hook 'gnus-register-action)
 349 (add-hook 'gnus-summary-article-expire-hook 'gnus-register-action)
 350 (add-hook 'nnmail-spool-hook 'gnus-register-spool-action)
 351
 352 (add-hook 'gnus-save-newsrc-hook 'gnus-registry-save)
 353 (add-hook 'gnus-read-newsrc-el-hook 'gnus-registry-read)
 354
 355 (add-hook 'gnus-summary-prepare-hook 'gnus-registry-register-message-ids)
 356
 357 ;; TODO: a lot of things
 358
 359 (provide 'gnus-registry)
 360
 361 ;;; gnus-registry.el ends here