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

   1 ;;; gnus-cache.el --- cache interface for Gnus
   2 ;; Copyright (C) 1995,96,97,98,99 Free Software Foundation, Inc.
   3
   4 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
   5 ;; Keywords: news
   6
   7 ;; This file is part of GNU Emacs.
   8
   9 ;; GNU Emacs is free software; you can redistribute it and/or modify
  10 ;; it under the terms of the GNU General Public License as published by
  11 ;; the Free Software Foundation; either version 2, or (at your option)
  12 ;; any later version.
  13
  14 ;; GNU Emacs is distributed in the hope that it will be useful,
  15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 ;; GNU General Public License for more details.
  18
  19 ;; You should have received a copy of the GNU General Public License
  20 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  21 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  22 ;; Boston, MA 02111-1307, USA.
  23
  24 ;;; Commentary:
  25
  26 ;;; Code:
  27
  28 (eval-when-compile (require 'cl))
  29
  30 (require 'gnus)
  31 (require 'gnus-int)
  32 (require 'gnus-range)
  33 (require 'gnus-start)
  34 (eval-when-compile
  35   (require 'gnus-sum))
  36
  37 (defcustom gnus-cache-active-file
  38   (concat (file-name-as-directory gnus-cache-directory) "active")
  39   "*The cache active file."
  40   :group 'gnus-cache
  41   :type 'file)
  42
  43 (defcustom gnus-cache-enter-articles '(ticked dormant)
  44   "Classes of articles to enter into the cache."
  45   :group 'gnus-cache
  46   :type '(set (const ticked) (const dormant) (const unread) (const read)))
  47
  48 (defcustom gnus-cache-remove-articles '(read)
  49   "Classes of articles to remove from the cache."
  50   :group 'gnus-cache
  51   :type '(set (const ticked) (const dormant) (const unread) (const read)))
  52
  53 (defcustom gnus-cacheable-groups nil
  54   "*Groups that match this regexp will be cached.
  55
  56 If you only want to cache your nntp groups, you could set this
  57 variable to \"^nntp\".
  58
  59 If a group matches both gnus-cacheable-groups and gnus-uncacheable-groups
  60 it's not cached."
  61   :group 'gnus-cache
  62   :type '(choice (const :tag "off" nil)
  63                 regexp))
  64
  65 (defcustom gnus-uncacheable-groups nil
  66   "*Groups that match this regexp will not be cached.
  67
  68 If you want to avoid caching your nnml groups, you could set this
  69 variable to \"^nnml\".
  70
  71 If a group matches both gnus-cacheable-groups and gnus-uncacheable-groups
  72 it's not cached."
  73   :group 'gnus-cache
  74   :type '(choice (const :tag "off" nil)
  75                  regexp))
  76
  77 (defvar gnus-cache-overview-coding-system 'raw-text
  78   "Coding system used on Gnus cache files.")
  79
  80 (defvar gnus-cache-coding-system 'raw-text
  81   "Coding system used on Gnus cache files.")
  82
  83 \f
  84
  85 ;;; Internal variables.
  86
  87 (defvar gnus-cache-removable-articles nil)
  88 (defvar gnus-cache-buffer nil)
  89 (defvar gnus-cache-active-hashtb nil)
  90 (defvar gnus-cache-active-altered nil)
  91
  92 (eval-and-compile
  93   (autoload 'nnml-generate-nov-databases-1 "nnml")
  94   (autoload 'nnvirtual-find-group-art "nnvirtual"))
  95
  96 \f
  97
  98 ;;; Functions called from Gnus.
  99
 100 (defun gnus-cache-open ()
 101   "Initialize the cache."
 102   (when (or (file-exists-p gnus-cache-directory)
 103             (and gnus-use-cache
 104                  (not (eq gnus-use-cache 'passive))))
 105     (gnus-cache-read-active)))
 106
 107 ;; Complexities of byte-compiling make this kludge necessary.  Eeek.
 108 (ignore-errors
 109   (gnus-add-shutdown 'gnus-cache-close 'gnus))
 110
 111 (defun gnus-cache-close ()
 112   "Shut down the cache."
 113   (gnus-cache-write-active)
 114   (gnus-cache-save-buffers)
 115   (setq gnus-cache-active-hashtb nil))
 116
 117 (defun gnus-cache-save-buffers ()
 118   ;; save the overview buffer if it exists and has been modified
 119   ;; delete empty cache subdirectories
 120   (when gnus-cache-buffer
 121     (let ((buffer (cdr gnus-cache-buffer))
 122           (overview-file (gnus-cache-file-name
 123                           (car gnus-cache-buffer) ".overview")))
 124       ;; write the overview only if it was modified
 125       (when (buffer-modified-p buffer)
 126         (save-excursion
 127           (set-buffer buffer)
 128           (if (> (buffer-size) 0)
 129               ;; Non-empty overview, write it to a file.
 130               (let ((coding-system-for-write
 131                      gnus-cache-overview-coding-system))
 132                 (gnus-write-buffer overview-file))
 133             ;; Empty overview file, remove it
 134             (when (file-exists-p overview-file)
 135               (delete-file overview-file))
 136             ;; If possible, remove group's cache subdirectory.
 137             (condition-case nil
 138                 ;; FIXME: we can detect the error type and warn the user
 139                 ;; of any inconsistencies (articles w/o nov entries?).
 140                 ;; for now, just be conservative...delete only if safe -- sj
 141                 (delete-directory (file-name-directory overview-file))
 142               (error nil)))))
 143       ;; Kill the buffer -- it's either unmodified or saved.
 144       (gnus-kill-buffer buffer)
 145       (setq gnus-cache-buffer nil))))
 146
 147 (defun gnus-cache-possibly-enter-article
 148   (group article ticked dormant unread &optional force)
 149   (when (and (or force (not (eq gnus-use-cache 'passive)))
 150              (numberp article)
 151              (> article 0))             ; This might be a dummy article.
 152     (let ((number article) file headers)
 153       ;; If this is a virtual group, we find the real group.
 154       (when (gnus-virtual-group-p group)
 155         (let ((result (nnvirtual-find-group-art
 156                        (gnus-group-real-name group) article)))
 157           (setq group (car result)
 158                 number (cdr result))))
 159       (when (and number
 160                  (> number 0)           ; Reffed article.
 161                  (or force
 162                      (and (or (not gnus-cacheable-groups)
 163                               (string-match gnus-cacheable-groups group))
 164                           (or (not gnus-uncacheable-groups)
 165                               (not (string-match
 166                                     gnus-uncacheable-groups group)))
 167                           (gnus-cache-member-of-class
 168                            gnus-cache-enter-articles ticked dormant unread)))
 169                  (not (file-exists-p (setq file (gnus-cache-file-name
 170                                                  group number)))))
 171         ;; Possibly create the cache directory.
 172         (gnus-make-directory (file-name-directory file))
 173         ;; Save the article in the cache.
 174         (if (file-exists-p file)
 175             t                           ; The article already is saved.
 176           (save-excursion
 177             (set-buffer nntp-server-buffer)
 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               (gnus-write-buffer file)
 183               (setq headers (nnheader-parse-head t))
 184               (mail-header-set-number headers number)
 185               (gnus-cache-change-buffer group)
 186               (set-buffer (cdr gnus-cache-buffer))
 187               (goto-char (point-max))
 188               (forward-line -1)
 189               (while (condition-case ()
 190                          (when (not (bobp))
 191                            (> (read (current-buffer)) number))
 192                        (error
 193                         ;; The line was malformed, so we just remove it!!
 194                         (gnus-delete-line)
 195                         t))
 196                 (forward-line -1))
 197               (if (bobp)
 198                   (if (not (eobp))
 199