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