cgit.sxemacs.org Git - gnus/blob - lisp/gnus-cache.el

   1 ;;; gnus-cache.el --- cache interface for Gnus
   2 ;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003
   3 ;;        Free Software Foundation, Inc.
   4
   5 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
   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-range)
  34 (require 'gnus-start)
  35 (eval-when-compile
  36   (if (not (fboundp 'gnus-agent-load-alist))
  37       (defun gnus-agent-load-alist (group)))
  38   (require 'gnus-sum))
  39
  40 (defcustom gnus-cache-active-file
  41   (expand-file-name "active" gnus-cache-directory)
  42   "*The cache active file."
  43   :group 'gnus-cache
  44   :type 'file)
  45
  46 (defcustom gnus-cache-enter-articles '(ticked dormant)
  47   "Classes of articles to enter into the cache."
  48   :group 'gnus-cache
  49   :type '(set (const ticked) (const dormant) (const unread) (const read)))
  50
  51 (defcustom gnus-cache-remove-articles '(read)
  52   "Classes of articles to remove from the cache."
  53   :group 'gnus-cache
  54   :type '(set (const ticked) (const dormant) (const unread) (const read)))
  55
  56 (defcustom gnus-cacheable-groups nil
  57   "*Groups that match this regexp will be cached.
  58
  59 If you only want to cache your nntp groups, you could set this
  60 variable to \"^nntp\".
  61
  62 If a group matches both gnus-cacheable-groups and gnus-uncacheable-groups
  63 it's not cached."
  64   :group 'gnus-cache
  65   :type '(choice (const :tag "off" nil)
  66                  regexp))
  67
  68 (defcustom gnus-uncacheable-groups nil
  69   "*Groups that match this regexp will not be cached.
  70
  71 If you want to avoid caching your nnml groups, you could set this
  72 variable to \"^nnml\".
  73
  74 If a group matches both gnus-cacheable-groups and gnus-uncacheable-groups
  75 it's not cached."
  76   :group 'gnus-cache
  77   :type '(choice (const :tag "off" nil)
  78                  regexp))
  79
  80 (defvar gnus-cache-overview-coding-system 'raw-text
  81   "Coding system used on Gnus cache files.")
  82
  83 (defvar gnus-cache-coding-system 'raw-text
  84   "Coding system used on Gnus cache files.")
  85
  86 \f
  87
  88 ;;; Internal variables.
  89
  90 (defvar gnus-cache-removable-articles nil)
  91 (defvar gnus-cache-buffer nil)
  92 (defvar gnus-cache-active-hashtb nil)
  93 (defvar gnus-cache-active-altered nil)
  94
  95 (eval-and-compile
  96   (autoload 'nnml-generate-nov-databases-1 "nnml")
  97   (autoload 'nnvirtual-find-group-art "nnvirtual"))
  98
  99 \f
 100
 101 ;;; Functions called from Gnus.
 102
 103 (defun gnus-cache-open ()
 104   "Initialize the cache."
 105   (when (or (file-exists-p gnus-cache-directory)
 106             (and gnus-use-cache
 107                  (not (eq gnus-use-cache 'passive))))
 108     (gnus-cache-read-active)))
 109
 110 ;; Complexities of byte-compiling make this kludge necessary.  Eeek.
 111 (ignore-errors
 112   (gnus-add-shutdown 'gnus-cache-close 'gnus))
 113
 114 (defun gnus-cache-close ()
 115   "Shut down the cache."
 116   (gnus-cache-write-active)
 117   (gnus-cache-save-buffers)
 118   (setq gnus-cache-active-hashtb nil))
 119
 120 (defun gnus-cache-save-buffers ()
 121   ;; save the overview buffer if it exists and has been modified
 122   ;; delete empty cache subdirectories
 123   (when gnus-cache-buffer
 124     (let ((buffer (cdr gnus-cache-buffer))
 125           (overview-file (gnus-cache-file-name
 126                           (car gnus-cache-buffer) ".overview")))
 127       ;; write the overview only if it was modified
 128       (when (buffer-modified-p buffer)
 129         (save-excursion
 130           (set-buffer buffer)
 131           (if (> (buffer-size) 0)
 132               ;; Non-empty overview, write it to a file.
 133               (let ((coding-system-for-write
 134                      gnus-cache-overview-coding-system))
 135                 (gnus-write-buffer overview-file))
 136             ;; Empty overview file, remove it
 137             (when (file-exists-p overview-file)
 138               (delete-file overview-file))
 139             ;; If possible, remove group's cache subdirectory.
 140             (condition-case nil
 141                 ;; FIXME: we can detect the error type and warn the user
 142                 ;; of any inconsistencies (articles w/o nov entries?).
 143                 ;; for now, just be conservative...delete only if safe -- sj
 144                 (delete-directory (file-name-directory overview-file))
 145               (error nil)))))
 146       ;; Kill the buffer -- it's either unmodified or saved.
 147       (gnus-kill-buffer buffer)
 148       (setq gnus-cache-buffer nil))))
 149
 150 (defun gnus-cache-possibly-enter-article
 151   (group article ticked dormant unread &optional force)
 152   (when (and (or force (not (eq gnus-use-cache 'passive)))
 153              (numberp article)
 154              (> article 0))             ; This might be a dummy article.
 155     (let ((number article) file headers)
 156       ;; If this is a virtual group, we find the real group.
 157       (when (gnus-virtual-group-p group)
 158         (let ((result (nnvirtual-find-group-art
 159                        (gnus-group-real-name group) article)))
 160           (setq group (car result)
 161                 number (cdr result))))
 162       (when (and number
 163                  (> number 0)           ; Reffed article.
 164                  (or force
 165                      (and (gnus-cache-fully-p group)
 166                           (gnus-cache-member-of-class
 167                            gnus-cache-enter-articles ticked dormant unread)))
 168                  (not (file-exists-p (setq file (gnus-cache-file-name
 169                                                  group number)))))
 170         ;; Possibly create the cache directory.
 171         (gnus-make-directory (file-name-directory file))
 172         ;; Save the article in the cache.
 173         (if (file-exists-p file)
 174             t                           ; The article already is saved.
 175           (save-excursion
 176             (set-buffer nntp-server-buffer)
 177             (require 'gnus-art)
 178             (let ((gnus-use-cache nil)
 179                   (gnus-article-decode-hook nil))
 180               (gnus-request-article-this-buffer number group))
 181             (when (> (buffer-size) 0)
 182               (let ((coding-system-for-write gnus-cache-coding-system))
 183                 (gnus-write-buffer file))
 184               (nnheader-remove-body)
 185               (setq headers (nnheader-parse-naked-head))
 186               (mail-header-set-number headers number)
 187               (gnus-cache-change-buffer group)
 188               (set-buffer (cdr gnus-cache-buffer))
 189               (goto-char (point-max))
 190               (forward-line -1)
 191               (while (condition-case ()
 192                          (when (not (bobp))
 193                            (> (read (current-buffer)) number))
 194                        (error
 195                         ;; The line was malformed, so we just remove it!!
 196                         (gnus-delete-line)
 197                         t))
 198                 (forward-line -1))
 199               (if (bobp)
 200                   (if (not (eobp))
 201                       (progn
 202                         (beginning-of-line)
 203                         (when (< (read (current-buffer)) number)
 204                           (forward-line 1)))
 205                     (beginning-of-line))
 206                 (forward-line 1))
 207               (beginning-of-line)
 208               (nnheader-insert-nov headers)
 209               ;; Update the active info.
 210               (set-buffer gnus-summary-buffer)
 211               (gnus-cache-possibly-update-active group (cons number number))
 212               (setq gnus-newsgroup-cached
 213                     (gnus-add-to-sorted-list gnus-newsgroup-cached article))
 214               (gnus-summary-update-secondary-mark article))
 215             t))))))
 216
 217 (defun gnus-cache-enter-remove-article (article)
 218   "Mark ARTICLE for later possible removal."
 219   (when article
 220     (push article gnus-cache-removable-articles)))
 221
 222 (defun gnus-cache-possibly-remove-articles ()
 223   "Possibly remove some of the removable articles."
 224   (if (not (gnus-virtual-group-p gnus-newsgroup-name))
 225       (gnus-cache-possibly-remove-articles-1)
 226     (let ((arts gnus-cache-removable-articles)
 227           ga)