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   (if (null gnus-registry-max-entries)
 183       alist                             ; just return the alist
 184     ;; else, when given max-entries, trim the alist
 185     (let ((timehash (make-hash-table
 186                      :size 4096
 187                      :test 'equal)))
 188       (maphash
 189        (lambda (key value)
 190          (puthash key (gnus-registry-fetch-extra key 'mtime) timehash))
 191        gnus-registry-hashtb)
 192
 193       ;; we use the return value of this setq, which is the trimmed alist
 194       (setq alist
 195             (nthcdr
 196              (- (length alist) gnus-registry-max-entries)
 197              (sort alist
 198                    (lambda (a b)
 199                      (time-less-p
 200                       (cdr (gethash (car a) timehash))
 201                       (cdr (gethash (car b) timehash))))))))))
 202
 203 (defun alist-to-hashtable (alist)
 204   "Build a hashtable from the values in ALIST."
 205   (let ((ht (make-hash-table
 206              :size 4096
 207              :test 'equal)))
 208     (mapc
 209      (lambda (kv-pair)
 210        (puthash (car kv-pair) (cdr kv-pair) ht))
 211      alist)
 212      ht))
 213
 214 (defun hashtable-to-alist (hash)
 215   "Build an alist from the values in HASH."
 216   (let ((list nil))
 217     (maphash
 218      (lambda (key value)
 219        (setq list (cons (cons key value) list)))
 220      hash)
 221     list))
 222
 223 (defun gnus-register-action (action data-header from &optional to method)
 224   (let* ((id (mail-header-id data-header))
 225         (from (gnus-group-guess-full-name from))
 226         (to (if to (gnus-group-guess-full-name to) nil))
 227         (to-name (if to to "the Bit Bucket"))
 228         (old-entry (gethash id gnus-registry-hashtb)))
 229     (gnus-message 5 "Registry: article %s %s from %s to %s"
 230                   id
 231                   (if method "respooling" "going")
 232                   from
 233                   to)
 234
 235     ;; All except copy will need a delete
 236     (gnus-registry-delete-group id from)
 237
 238     (when (equal 'copy action)
 239       (gnus-registry-add-group id from)) ; undo the delete
 240
 241     (gnus-registry-add-group id to)))
 242
 243 (defun gnus-register-spool-action (id group)
 244   ;; do not process the draft IDs
 245 ;  (unless (string-match "totally-fudged-out-message-id" id)
 246 ;    (let ((group (gnus-group-guess-full-name group)))
 247   (when (string-match "\r$" id)
 248     (setq id (substring id 0 -1)))
 249   (gnus-message 5 "Registry: article %s spooled to %s"
 250                 id
 251                 group)
 252   (gnus-registry-add-group id group))
 253 ;)
 254
 255 ;; Function for nn{mail|imap}-split-fancy: look up all references in
 256 ;; the cache and if a match is found, return that group.
 257 (defun gnus-registry-split-fancy-with-parent ()
 258   "Split this message into the same group as its parent.  The parent
 259 is obtained from the registry.  This function can be used as an entry
 260 in `nnmail-split-fancy' or `nnimap-split-fancy', for example like
 261 this: (: gnus-registry-split-fancy-with-parent)
 262
 263 For a message to be split, it looks for the parent message in the
 264 References or In-Reply-To header and then looks in the registry to
 265 see which group that message was put in.  This group is returned.
 266
 267 See the Info node `(gnus)Fancy Mail Splitting' for more details."
 268   (let ((refstr (or (message-fetch-field "references")
 269                     (message-fetch-field "in-reply-to")))
 270         (nnmail-split-fancy-with-parent-ignore-groups
 271          (if (listp nnmail-split-fancy-with-parent-ignore-groups)
 272              nnmail-split-fancy-with-parent-ignore-groups
 273            (list nnmail-split-fancy-with-parent-ignore-groups)))
 274         references res)
 275     (when refstr
 276       (setq references (nreverse (gnus-split-references refstr)))
 277       (mapcar (lambda (x)
 278                 (setq res (or (gnus-registry-fetch-group x) res))
 279                 (when (or (gnus-registry-grep-in-list
 280                            res
 281                            gnus-registry-unfollowed-groups)
 282                           (gnus-registry-grep-in-list
 283                            res
 284                            nnmail-split-fancy-with-parent-ignore-groups))
 285                   (setq res nil)))
 286               references)
 287       (gnus-message
 288        5
 289        "gnus-registry-split-fancy-with-parent traced %s to group %s"
 290        refstr (if res res "nil"))
 291       res)))
 292
 293 (defun gnus-registry-register-message-ids ()
 294   "Register the Message-ID of every article in the group"
 295   (unless (gnus-parameter-registry-ignore gnus-newsgroup-name)
 296     (dolist (article gnus-newsgroup-articles)
 297       (let ((id (gnus-registry-fetch-message-id-fast article)))
 298         (unless (gnus-registry-fetch-group id)
 299           (gnus-message 9 "Registry: Registering article %d with group %s"
 300                         article gnus-newsgroup-name)
 301           (gnus-registry-add-group (gnus-registry-fetch-message-id-fast article)
 302                                    gnus-newsgroup-name))))))
 303
 304 (defun gnus-registry-fetch-message-id-fast (article)
 305   "Fetch the Message-ID quickly, using the internal gnus-data-list function"
 306   (if (and (numberp article)
 307            (assoc article (gnus-data-list nil)))
 308       (mail-header-id (gnus-data-header (assoc article (gnus-data-list nil))))
 309     nil))
 310
 311 (defun gnus-registry-grep-in-list (word list)
 312   (when word
 313     (memq nil
 314           (mapcar 'not
 315                   (mapcar
 316                    (lambda (x)
 317                      (string-match x word))
 318                    list)))))
 319
 320 (defun gnus-registry-fetch-extra (id &optional entry)
 321   "Get the extra data of a message, based on the message ID.
 322 Returns the first place where the trail finds a nonstring."
 323   (let ((trail (gethash id gnus-registry-hashtb)))
 324     (dolist (crumb trail)
 325       (unless (stringp crumb)
 326         (return (gnus-registry-fetch-extra-entry crumb entry))))))
 327
 328 (defun gnus-registry-fetch-extra-entry (alist &optional entry)
 329   "Get the extra data of a message, or a specific entry in it."
 330   (if entry
 331       (assq entry alist)
 332     alist))
 333
 334 (defun gnus-registry-store-extra (id extra)
 335   "Store the extra data of a message, based on the message ID.
 336 The message must have at least one group name."
 337   (when (gnus-registry-group-count id)
 338     ;; we now know the trail has at least 1 group name, so it's not empty
 339     (let ((trail (gethash id gnus-registry-hashtb))
 340           (old-extra (gnus-registry-fetch-extra id)))
 341       (puthash id (cons extra (delete old-extra trail))
 342                gnus-registry-hashtb)
 343       (setq gnus-registry-dirty t))))
 344
 345 (defun gnus-registry-store-extra-entry (id key value)
 346   "Put a specific entry in the extras field of the registry entry for id."
 347   (let* ((extra (gnus-registry-fetch-extra id))
 348          (alist (cons (cons key value)
 349                  (gnus-assq-delete-all key (gnus-registry-fetch-extra id)))))
 350     (gnus-registry-store-extra id alist)))
 351
 352 (defun gnus-registry-fetch-group (id)
 353   "Get the group of a message, based on the message ID.
 354 Returns the first place where the trail finds a group name."
 355   (when (gnus-registry-group-count id)
 356     ;; we now know the trail has at least 1 group name
 357     (let ((trail (gethash id gnus-registry-hashtb)))
 358       (dolist (crumb trail)
 359         (when (stringp crumb)
 360           (return (gnus-group-short-name crumb)))))))
 361
 362 (defun gnus-registry-group-count (id)
 363   "Get the number of groups of a message, based on the message ID."
 364   (let ((trail (gethash id gnus-registry-hashtb)))
 365     (if (and trail (listp trail))
 366         (apply '+ (mapcar (lambda (x) (if (stringp x) 1 0)) trail))
 367       0)))
 368
 369 (defun gnus-registry-delete-group (id group)
 370   "Delete a group for a message, based on the message ID."
 371   (when group
 372     (when id
 373       (let ((trail (gethash id gnus-registry-hashtb))
 374             (group (gnus-group-short-name group)))
 375         (puthash id (if trail
 376                         (delete group trail)
 377                       nil)
 378                  gnus-registry-hashtb))
 379       ;; now, clear the entry if there are no more groups
 380       (when gnus-registry-trim-articles-without-groups
 381         (unless (gnus-registry-group-count id)
 382           (remhash id gnus-registry-hashtb)))
 383       (gnus-registry-store-extra-entry id 'mtime (current-time)))))
 384
 385 (defun gnus-registry-add-group (id group &rest extra)
 386   "Add a group for a message, based on the message ID."
 387   ;; make sure there are no duplicate entries
 388   (when group
 389     (when (and id
 390                (not (string-match "totally-fudged-out-message-id" id)))
 391       (let ((full-group group)
 392             (group (if gnus-registry-use-long-group-names
 393                        group
 394                      (gnus-group-short-name group))))
 395         (gnus-registry-delete-group id group)
 396         (unless gnus-registry-use-long-group-names
 397           (gnus-registry-delete-group id full-group))
 398         (let ((trail (gethash id gnus-registry-hashtb)))
 399           (puthash id (if trail
 400                           (cons group trail)
 401                         (list group))
 402                    gnus-registry-hashtb)
 403           (when extra (gnus-registry-store-extra id extra))
 404           (gnus-registry-store-extra-entry id 'mtime (current-time)))))))
 405
 406 (defun gnus-registry-clear ()
 407   "Clear the Gnus registry."
 408   (interactive)
 409   (setq gnus-registry-alist nil)
 410   (setq gnus-registry-hashtb (alist-to-hashtable gnus-registry-alist))
 411   (setq gnus-registry-dirty t))
 412
 413 (defun gnus-registry-install-hooks ()
 414   "Install the registry hooks."
 415   (interactive)
 416   (add-hook 'gnus-summary-article-move-hook 'gnus-register-action)
 417   (add-hook 'gnus-summary-article-delete-hook 'gnus-register-action)
 418   (add-hook 'gnus-summary-article-expire-hook 'gnus-register-action)
 419   (add-hook 'nnmail-spool-hook 'gnus-register-spool-action)
 420
 421   (add-hook 'gnus-save-newsrc-hook 'gnus-registry-save)
 422   (add-hook 'gnus-read-newsrc-el-hook 'gnus-registry-read)
 423
 424   (add-hook 'gnus-summary-prepare-hook 'gnus-registry-register-message-ids))
 425
 426 (defun gnus-registry-unload-hook ()
 427   "Uninstall the registry hooks."
 428   (interactive)
 429   (remove-hook 'gnus-summary-article-move-hook 'gnus-register-action)
 430   (remove-hook 'gnus-summary-article-delete-hook 'gnus-register-action)
 431   (remove-hook 'gnus-summary-article-expire-hook 'gnus-register-action)
 432   (remove-hook 'nnmail-spool-hook 'gnus-register-spool-action)
 433
 434   (remove-hook 'gnus-save-newsrc-hook 'gnus-registry-save)
 435   (remove-hook 'gnus-read-newsrc-el-hook 'gnus-registry-read)
 436
 437   (remove-hook 'gnus-summary-prepare-hook 'gnus-registry-register-message-ids))
 438
 439 (when gnus-registry-install
 440   (gnus-registry-install-hooks))
 441
 442 ;; TODO: a lot of things
 443
 444 (provide 'gnus-registry)
 445
 446 ;;; gnus-registry.el ends here