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 (defvar gnus-registry-dirty t
  37  "Boolean set to t when the registry is modified")
  38
  39 (defgroup gnus-registry nil
  40   "The Gnus registry."
  41   :group 'gnus)
  42
  43 (defvar gnus-registry-hashtb nil
  44   "*The article registry by Message ID.")
  45
  46 (defcustom gnus-registry-unfollowed-groups '("delayed" "drafts" "queue")
  47   "List of groups that gnus-registry-split-fancy-with-parent won't follow.
  48 The group names are matched, they don't have to be fully qualified."
  49   :group 'gnus-registry
  50   :type '(repeat string))
  51
  52 (defcustom gnus-registry-install nil
  53   "Whether the registry should be installed."
  54   :group 'gnus-registry
  55   :type 'boolean)
  56
  57 (defcustom gnus-registry-use-long-group-names nil
  58   "Whether the registry should use long group names (BUGGY)."
  59   :group 'gnus-registry
  60   :type 'boolean)
  61
  62 (defcustom gnus-registry-trim-articles-without-groups t
  63   "Whether the registry should clean out message IDs without groups."
  64   :group 'gnus-registry
  65   :type 'boolean)
  66
  67 (defcustom gnus-registry-cache-file "~/.gnus.registry.eld"
  68   "File where the Gnus registry will be stored."
  69   :group 'gnus-registry
  70   :type 'file)
  71
  72 (defcustom gnus-registry-max-entries nil
  73   "Maximum number of entries in the registry, nil for unlimited."
  74   :group 'gnus-registry
  75   :type 'integer)
  76
  77 ;; Function(s) missing in Emacs 20
  78 (when (memq nil (mapcar 'fboundp '(puthash)))
  79   (require 'cl)
  80   (unless (fboundp 'puthash)
  81     ;; alias puthash is missing from Emacs 20 cl-extra.el
  82     (defalias 'puthash 'cl-puthash)))
  83
  84 (defun gnus-registry-cache-read ()
  85   "Read the registry cache file."
  86   (interactive)
  87   (let ((file gnus-registry-cache-file))
  88     (when (file-exists-p file)
  89       (gnus-message 5 "Reading %s..." file)
  90       (gnus-load file)
  91       (gnus-message 5 "Reading %s...done" file))))
  92
  93 (defun gnus-registry-cache-save ()
  94   "Save the registry cache file."
  95   (interactive)
  96   (let ((file gnus-registry-cache-file))
  97     (save-excursion
  98       (set-buffer (gnus-get-buffer-create " *Gnus-registry-cache*"))
  99       (make-local-variable 'version-control)
 100     (setq version-control gnus-backup-startup-file)
 101     (setq buffer-file-name file)
 102     (setq default-directory (file-name-directory buffer-file-name))
 103     (buffer-disable-undo)
 104     (erase-buffer)
 105     (gnus-message 5 "Saving %s..." file)
 106     (if gnus-save-startup-file-via-temp-buffer
 107         (let ((coding-system-for-write gnus-ding-file-coding-system)
 108               (standard-output (current-buffer)))
 109           (gnus-gnus-to-quick-newsrc-format t "gnus registry startup file" 'gnus-registry-alist)
 110           (gnus-registry-cache-whitespace file)
 111           (save-buffer))
 112       (let ((coding-system-for-write gnus-ding-file-coding-system)
 113             (version-control gnus-backup-startup-file)
 114             (startup-file file)
 115             (working-dir (file-name-directory file))
 116             working-file
 117             (i -1))
 118         ;; Generate the name of a non-existent file.
 119         (while (progn (setq working-file
 120                             (format
 121                              (if (and (eq system-type 'ms-dos)
 122                                       (not (gnus-long-file-names)))
 123                                  "%s#%d.tm#" ; MSDOS limits files to 8+3
 124                                (if (memq system-type '(vax-vms axp-vms))
 125                                    "%s$tmp$%d"
 126                                  "%s#tmp#%d"))
 127                              working-dir (setq i (1+ i))))
 128                       (file-exists-p working-file)))
 129
 130         (unwind-protect
 131             (progn
 132               (gnus-with-output-to-file working-file
 133                 (gnus-gnus-to-quick-newsrc-format t "gnus registry startup file" 'gnus-registry-alist))
 134
 135               ;; These bindings will mislead the current buffer
 136               ;; into thinking that it is visiting the startup
 137               ;; file.
 138               (let ((buffer-backed-up nil)
 139                     (buffer-file-name startup-file)
 140                     (file-precious-flag t)
 141                     (setmodes (file-modes startup-file)))
 142                 ;; Backup the current version of the startup file.
 143                 (backup-buffer)
 144
 145                 ;; Replace the existing startup file with the temp file.
 146                 (rename-file working-file startup-file t)
 147                 (set-file-modes startup-file setmodes)))
 148           (condition-case nil
 149               (delete-file working-file)
 150             (file-error nil)))))
 151
 152     (gnus-kill-buffer (current-buffer))
 153     (gnus-message 5 "Saving %s...done" file))))
 154
 155 ;; Idea from Dan Christensen <jdc@chow.mat.jhu.edu>
 156 ;; Save the gnus-registry file with extra line breaks.
 157 (defun gnus-registry-cache-whitespace (filename)
 158   (gnus-message 4 "Adding whitespace to %s" filename)
 159   (save-excursion
 160     (goto-char (point-min))
 161     (while (re-search-forward "^(\\|(\\\"" nil t)
 162       (replace-match "\n\\&" t))
 163     (goto-char (point-min))
 164     (while (re-search-forward " $" nil t)
 165       (replace-match "" t t))))
 166
 167 (defun gnus-registry-save (&optional force)
 168 ;; TODO: delete entries with 0 groups
 169   (when (or gnus-registry-dirty force)
 170     (setq gnus-registry-alist (gnus-registry-trim
 171                                (hashtable-to-alist gnus-registry-hashtb)))
 172     (gnus-registry-cache-save)
 173     (setq gnus-registry-dirty nil)))
 174
 175 (defun gnus-registry-read ()
 176   (gnus-registry-cache-read)
 177   (setq gnus-registry-hashtb (alist-to-hashtable gnus-registry-alist))
 178   (setq gnus-registry-dirty nil))
 179
 180 (defun gnus-registry-trim (alist)
 181   "Trim alist to size, using gnus-registry-max-entries."
 182   (unless (null gnus-registry-max-entries)
 183     (let ((timehash (make-hash-table
 184                      :size 4096
 185                      :test 'equal)))
 186       (maphash
 187        (lambda (key value)
 188          (puthash key (gnus-registry-fetch-extra key 'mtime) timehash))
 189        gnus-registry-hashtb)
 190
 191       (setq alist
 192             (nthcdr
 193              (- (length alist) gnus-registry-max-entries)
 194              (sort alist
 195                    (lambda (a b)
 196                      (time-less-p
 197                       (cdr (gethash (car a) timehash))
 198                       (cdr (gethash (car b) timehash))))))))))
 199
 200 (defun alist-to-hashtable (alist)
 201   "Build a hashtable from the values in ALIST."
 202   (let ((ht (make-hash-table
 203              :size 4096
 204              :test 'equal)))
 205     (mapc
 206      (lambda (kv-pair)
 207        (puthash (car kv-pair) (cdr kv-pair) ht))
 208      alist)
 209      ht))
 210
 211 (defun hashtable-to-alist (hash)
 212   "Build an alist from the values in HASH."
 213   (let ((list nil))
 214     (maphash
 215      (lambda (key value)
 216        (setq list (cons (cons key value) list)))
 217      hash)
 218     list))
 219
 220 (defun gnus-register-action (action data-header from &optional to method)
 221   (let* ((id (mail-header-id data-header))
 222         (from (gnus-group-guess-full-name from))
 223         (to (if to (gnus-group-guess-full-name to) nil))
 224         (to-name (if to to "the Bit Bucket"))
 225         (old-entry (gethash id gnus-registry-hashtb)))
 226     (gnus-message 5 "Registry: article %s %s from %s to %s"
 227                   id
 228                   (if method "respooling" "going")
 229                   from
 230                   to)
 231
 232     ;; All except copy will need a delete
 233     (gnus-registry-delete-group id from)
 234
 235     (when (equal 'copy action)
 236       (gnus-registry-add-group id from)) ; undo the delete
 237
 238     (gnus-registry-add-group id to)))
 239
 240 (defun gnus-register-spool-action (id group)
 241   ;; do not process the draft IDs
 242 ;  (unless (string-match "totally-fudged-out-message-id" id)
 243 ;    (let ((group (gnus-group-guess-full-name group)))
 244   (when (string-match "\r$" id)
 245     (setq id (substring id 0 -1)))
 246   (gnus-message 5 "Registry: article %s spooled to %s"
 247                 id
 248                 group)
 249   (gnus-registry-add-group id group))
 250 ;)
 251
 252 ;; Function for nn{mail|imap}-split-fancy: look up all references in
 253 ;; the cache and if a match is found, return that group.
 254 (defun gnus-registry-split-fancy-with-parent ()
 255   "Split this message into the same group as its parent.  The parent
 256 is obtained from the registry.  This function can be used as an entry
 257 in `nnmail-split-fancy' or `nnimap-split-fancy', for example like
 258 this: (: gnus-registry-split-fancy-with-parent)
 259
 260 For a message to be split, it looks for the parent message in the
 261 References or In-Reply-To header and then looks in the registry to
 262 see which group that message was put in.  This group is returned.
 263
 264 See the Info node `(gnus)Fancy Mail Splitting' for more details."
 265   (let ((refstr (or (message-fetch-field "references")
 266                     (message-fetch-field "in-reply-to")))
 267         (nnmail-split-fancy-with-parent-ignore-groups
 268          (if (listp nnmail-split-fancy-with-parent-ignore-groups)
 269              nnmail-split-fancy-with-parent-ignore-groups
 270            (list nnmail-split-fancy-with-parent-ignore-groups)))
 271         references res)
 272     (when refstr
 273       (setq references (nreverse (gnus-split-references refstr)))
 274       (mapcar (lambda (x)
 275                 (setq res (or (gnus-registry-fetch-group x) res))
 276                 (when (or (gnus-registry-grep-in-list
 277                            res
 278                            gnus-registry-unfollowed-groups)
 279                           (gnus-registry-grep-in-list
 280                            res
 281                            nnmail-split-fancy-with-parent-ignore-groups))
 282                   (setq res nil)))
 283               references)
 284       (gnus-message
 285        5
 286        "gnus-registry-split-fancy-with-parent traced %s to group %s"
 287        refstr (if res res "nil"))
 288       res)))
 289
 290 (defun gnus-registry-register-message-ids ()
 291   "Register the Message-ID of every article in the group"
 292   (unless (gnus-parameter-registry-ignore gnus-newsgroup-name)
 293     (dolist (article gnus-newsgroup-articles)
 294       (let ((id (gnus-registry-fetch-message-id-fast article)))
 295         (unless (gnus-registry-fetch-group id)
 296           (gnus-message 9 "Registry: Registering article %d with group %s"
 297                         article gnus-newsgroup-name)
 298           (gnus-registry-add-group (gnus-registry-fetch-message-id-fast article)
 299                                    gnus-newsgroup-name))))))
 300
 301 (defun gnus-registry-fetch-message-id-fast (article)
 302   "Fetch the Message-ID quickly, using the internal gnus-data-list function"
 303   (if (and (numberp article)
 304            (assoc article (gnus-data-list nil)))
 305       (mail-header-id (gnus-data-header (assoc article (gnus-data-list nil))))
 306     nil))
 307
 308 (defun gnus-registry-grep-in-list (word list)
 309   (when word
 310     (memq nil
 311           (mapcar 'not
 312                   (mapcar
 313                    (lambda (x)
 314                      (string-match x word))
 315                    list)))))
 316
 317 (defun gnus-registry-fetch-extra (id &optional entry)
 318   "Get the extra data of a message, based on the message ID.
 319 Returns the first place where the trail finds a nonstring."
 320   (let ((trail (gethash id gnus-registry-hashtb)))
 321     (dolist (crumb trail)
 322       (unless (stringp crumb)
 323         (return (gnus-registry-fetch-extra-entry crumb entry))))))
 324
 325 (defun gnus-registry-fetch-extra-entry (alist &optional entry)
 326   "Get the extra data of a message, or a specific entry in it."
 327   (if entry
 328       (assq entry alist)
 329     alist))
 330
 331 (defun gnus-registry-store-extra (id extra)
 332   "Store the extra data of a message, based on the message ID.
 333 The message must have at least one group name."
 334   (when (gnus-registry-group-count id)
 335     ;; we now know the trail has at least 1 group name, so it's not empty
 336     (let ((trail (gethash id gnus-registry-hashtb))
 337           (old-extra (gnus-registry-fetch-extra id)))
 338       (puthash id (cons extra (delete old-extra trail))
 339                gnus-registry-hashtb)
 340       (setq gnus-registry-dirty t))))
 341
 342 (defun gnus-registry-store-extra-entry (id key value)
 343   "Put a specific entry in the extras field of the registry entry for id."
 344   (let* ((extra (gnus-registry-fetch-extra id))
 345          (alist (cons (cons key value)
 346                  (gnus-assq-delete-all key (gnus-registry-fetch-extra id)))))
 347     (gnus-registry-store-extra id alist)))
 348
 349 (defun gnus-registry-fetch-group (id)
 350   "Get the group of a message, based on the message ID.
 351 Returns the first place where the trail finds a group name."
 352   (when (gnus-registry-group-count id)
 353     ;; we now know the trail has at least 1 group name
 354     (let ((trail (gethash id gnus-registry-hashtb)))
 355       (dolist (crumb trail)
 356         (when (stringp crumb)
 357           (return crumb))))))
 358
 359 (defun gnus-registry-group-count (id)
 360   "Get the number of groups of a message, based on the message ID."
 361   (let ((trail (gethash id gnus-registry-hashtb)))
 362     (if (and trail (listp trail))
 363         (apply '+ (mapcar (lambda (x) (if (stringp x) 1 0)) trail))
 364       0)))
 365
 366 (defun gnus-registry-delete-group (id group)
 367   "Delete a group for a message, based on the message ID."
 368   (when group
 369     (when id
 370       (let ((trail (gethash id gnus-registry-hashtb))
 371             (group (gnus-group-short-name group)))
 372         (puthash id (if trail
 373                         (delete group trail)
 374                       nil)
 375                  gnus-registry-hashtb))
 376       ;; now, clear the entry if there are no more groups
 377       (when gnus-registry-trim-articles-without-groups
 378         (unless (gnus-registry-group-count id)
 379           (remhash id gnus-registry-hashtb)))
 380       (gnus-registry-store-extra-entry id 'mtime (current-time)))))
 381
 382 (defun gnus-registry-add-group (id group &rest extra)
 383   "Add a group for a message, based on the message ID."
 384   ;; make sure there are no duplicate entries
 385   (when group
 386     (when (and id
 387                (not (string-match "totally-fudged-out-message-id" id)))
 388       (let ((full-group group)
 389             (group (if gnus-registry-use-long-group-names
 390                        group
 391                      (gnus-group-short-name group))))
 392         (gnus-registry-delete-group id group)
 393         (unless gnus-registry-use-long-group-names
 394           (gnus-registry-delete-group id full-group))
 395         (let ((trail (gethash id gnus-registry-hashtb)))
 396           (puthash id (if trail
 397                           (cons group trail)
 398                         (list group))
 399                    gnus-registry-hashtb)
 400           (when extra (gnus-registry-store-extra id extra))
 401           (gnus-registry-store-extra-entry id 'mtime (current-time)))))))
 402
 403 (defun gnus-registry-clear ()
 404   "Clear the Gnus registry."
 405   (interactive)
 406   (setq gnus-registry-alist nil)
 407   (setq gnus-registry-hashtb (alist-to-hashtable gnus-registry-alist))
 408   (setq gnus-registry-dirty t))
 409
 410 (defun gnus-registry-install-hooks ()
 411   "Install the registry hooks."
 412   (interactive)
 413   (add-hook 'gnus-summary-article-move-hook 'gnus-register-action)
 414   (add-hook 'gnus-summary-article-delete-hook 'gnus-register-action)
 415   (add-hook 'gnus-summary-article-expire-hook 'gnus-register-action)
 416   (add-hook 'nnmail-spool-hook 'gnus-register-spool-action)
 417
 418   (add-hook 'gnus-save-newsrc-hook 'gnus-registry-save)
 419   (add-hook 'gnus-read-newsrc-el-hook 'gnus-registry-read)
 420
 421   (add-hook 'gnus-summary-prepare-hook 'gnus-registry-register-message-ids))
 422
 423 (defun gnus-registry-unload-hook ()
 424   "Uninstall the registry hooks."
 425   (interactive)
 426   (remove-hook 'gnus-summary-article-move-hook 'gnus-register-action)
 427   (remove-hook 'gnus-summary-article-delete-hook 'gnus-register-action)
 428   (remove-hook 'gnus-summary-article-expire-hook 'gnus-register-action)
 429   (remove-hook 'nnmail-spool-hook 'gnus-register-spool-action)
 430
 431   (remove-hook 'gnus-save-newsrc-hook 'gnus-registry-save)
 432   (remove-hook 'gnus-read-newsrc-el-hook 'gnus-registry-read)
 433
 434   (remove-hook 'gnus-summary-prepare-hook 'gnus-registry-register-message-ids))
 435
 436 (when gnus-registry-install
 437   (gnus-registry-install-hooks))
 438
 439 ;; TODO: a lot of things
 440
 441 (provide 'gnus-registry)
 442
 443 ;;; gnus-registry.el ends here