;;; gnus-cache.el --- cache interface for Gnus
-;; Copyright (C) 1995 Free Software Foundation, Inc.
-;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
+;; Copyright (C) 1995-2013 Free Software Foundation, Inc.
+
+;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: news
;; This file is part of GNU Emacs.
-;; GNU Emacs is free software; you can redistribute it and/or modify
+;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version.
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs; see the file COPYING. If not, write to
-;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;; Code:
+;; For Emacs <22.2 and XEmacs.
+(eval-and-compile
+ (unless (fboundp 'declare-function) (defmacro declare-function (&rest r))))
+
+(eval-when-compile (require 'cl))
+
(require 'gnus)
+(require 'gnus-sum)
+
+(eval-when-compile
+ (unless (fboundp 'gnus-agent-load-alist)
+ (defun gnus-agent-load-alist (group))))
+
+(defcustom gnus-cache-active-file
+ (expand-file-name "active" gnus-cache-directory)
+ "*The cache active file."
+ :group 'gnus-cache
+ :type 'file)
+
+(defcustom gnus-cache-enter-articles '(ticked dormant)
+ "Classes of articles to enter into the cache."
+ :group 'gnus-cache
+ :type '(set (const ticked) (const dormant) (const unread) (const read)))
+
+(defcustom gnus-cache-remove-articles '(read)
+ "Classes of articles to remove from the cache."
+ :group 'gnus-cache
+ :type '(set (const ticked) (const dormant) (const unread) (const read)))
+
+(defcustom gnus-cacheable-groups nil
+ "*Groups that match this regexp will be cached.
+
+If you only want to cache your nntp groups, you could set this
+variable to \"^nntp\".
+
+If a group matches both gnus-cacheable-groups and gnus-uncacheable-groups
+it's not cached."
+ :group 'gnus-cache
+ :type '(choice (const :tag "off" nil)
+ regexp))
+
+(defcustom gnus-uncacheable-groups nil
+ "*Groups that match this regexp will not be cached.
+
+If you want to avoid caching your nnml groups, you could set this
+variable to \"^nnml\".
-(defvar gnus-cache-directory (concat gnus-article-save-directory "cache/")
- "*The directory where cached articles will be stored.")
+If a group matches both gnus-cacheable-groups and gnus-uncacheable-groups
+it's not cached."
+ :group 'gnus-cache
+ :type '(choice (const :tag "off" nil)
+ regexp))
-(defvar gnus-cache-enter-articles '(ticked dormant)
- "*Classes of articles to enter into the cache.")
+(defvar gnus-cache-overview-coding-system 'raw-text
+ "Coding system used on Gnus cache files.")
-(defvar gnus-cache-remove-articles '(read)
- "*Classes of articles to remove from the cache.")
+(defvar gnus-cache-coding-system 'raw-text
+ "Coding system used on Gnus cache files.")
\f
+;;; Internal variables.
+
+(defvar gnus-cache-removable-articles nil)
(defvar gnus-cache-buffer nil)
+(defvar gnus-cache-active-hashtb nil)
+(defvar gnus-cache-active-altered nil)
+(defvar gnus-cache-total-fetched-hashtb nil)
+
+(declare-function nnvirtual-find-group-art "nnvirtual" (group article))
+
+(autoload 'nnml-generate-nov-databases-directory "nnml")
+(autoload 'nnvirtual-find-group-art "nnvirtual")
\f
-(defun gnus-cache-change-buffer (group)
- (and gnus-cache-buffer
- ;; see if the current group's overview cache has been loaded
- (or (string= group (car gnus-cache-buffer))
- ;; another overview cache is current, save it
- (gnus-cache-save-buffers)))
- ;; if gnus-cache buffer is nil, create it
- (or gnus-cache-buffer
- ;; create cache buffer
- (save-excursion
- (setq gnus-cache-buffer
- (cons group
- (set-buffer (get-buffer-create " *gnus-cache-overview*"))))
- (buffer-disable-undo (current-buffer))
- ;; insert the contents of this groups cache overview
- (erase-buffer)
- (let ((file (gnus-cache-file-name group ".overview")))
- (and (file-exists-p file)
- (insert-file-contents file)))
- ;; we have a fresh (empty/just loaded) buffer,
- ;; mark it as unmodified to save a redundant write later.
- (set-buffer-modified-p nil))))
+;;; Functions called from Gnus.
+
+(defun gnus-cache-open ()
+ "Initialize the cache."
+ (when (or (file-exists-p gnus-cache-directory)
+ (and gnus-use-cache
+ (not (eq gnus-use-cache 'passive))))
+ (gnus-cache-read-active)))
+
+;; Complexities of byte-compiling make this kludge necessary. Eeek.
+(ignore-errors
+ (gnus-add-shutdown 'gnus-cache-close 'gnus))
+(defun gnus-cache-close ()
+ "Shut down the cache."
+ (gnus-cache-write-active)
+ (gnus-cache-save-buffers)
+ (setq gnus-cache-active-hashtb nil))
(defun gnus-cache-save-buffers ()
;; save the overview buffer if it exists and has been modified
;; delete empty cache subdirectories
- (if (null gnus-cache-buffer)
- ()
+ (when gnus-cache-buffer
(let ((buffer (cdr gnus-cache-buffer))
(overview-file (gnus-cache-file-name
(car gnus-cache-buffer) ".overview")))
;; write the overview only if it was modified
- (if (buffer-modified-p buffer)
- (save-excursion
- (set-buffer buffer)
- (if (> (buffer-size) 0)
- ;; non-empty overview, write it out
- (progn
- (gnus-make-directory (file-name-directory overview-file))
- (write-region (point-min) (point-max)
- overview-file nil 'quietly))
- ;; empty overview file, remove it
- (and (file-exists-p overview-file)
- (delete-file overview-file))
- ;; if possible, remove group's cache subdirectory
+ (when (and (buffer-live-p buffer) (buffer-modified-p buffer))
+ (with-current-buffer buffer
+ (if (> (buffer-size) 0)
+ ;; Non-empty overview, write it to a file.
+ (let ((coding-system-for-write
+ gnus-cache-overview-coding-system))
+ (gnus-write-buffer overview-file))
+ (let ((file-name-coding-system nnmail-pathname-coding-system))
+ ;; Empty overview file, remove it
+ (when (file-exists-p overview-file)
+ (delete-file overview-file))
+ ;; If possible, remove group's cache subdirectory.
(condition-case nil
;; FIXME: we can detect the error type and warn the user
;; of any inconsistencies (articles w/o nov entries?).
;; for now, just be conservative...delete only if safe -- sj
(delete-directory (file-name-directory overview-file))
- (error nil)))))
- ;; kill the buffer, it's either unmodified or saved
+ (error))))
+
+ (gnus-cache-update-overview-total-fetched-for
+ (car gnus-cache-buffer) overview-file)))
+ ;; Kill the buffer -- it's either unmodified or saved.
(gnus-kill-buffer buffer)
(setq gnus-cache-buffer nil))))
-
-;; Return whether an article is a member of a class.
-(defun gnus-cache-member-of-class (class ticked dormant unread)
- (or (and ticked (memq 'ticked class))
- (and dormant (memq 'dormant class))
- (and unread (memq 'unread class))
- (and (not unread) (memq 'read class))))
-
-(defun gnus-cache-file-name (group article)
- (concat (file-name-as-directory gnus-cache-directory)
- (if (gnus-use-long-file-name 'not-cache)
- group
- (let ((group (concat group "")))
- (if (string-match ":" group)
- (aset group (match-beginning 0) ?/))
- (gnus-replace-chars-in-string group ?. ?/)))
- "/" (if (stringp article) article (int-to-string article))))
-
-(defun gnus-cache-possibly-enter-article
- (group article headers ticked dormant unread)
- (let ((number (mail-header-number headers))
- file dir)
- (if (or (not (vectorp headers)) ; This might be a dummy article.
- (not (gnus-cache-member-of-class
- gnus-cache-enter-articles ticked dormant unread))
- (file-exists-p (setq file (gnus-cache-file-name group article))))
- () ; Do nothing.
- ;; Possibly create the cache directory.
- (or (file-exists-p (setq dir (file-name-directory file)))
- (gnus-make-directory dir))
- ;; Save the article in the cache.
- (if (file-exists-p file)
- t ; The article already is saved, so we end here.
- (let ((gnus-use-cache nil))
- (gnus-summary-select-article))
- (save-excursion
- (set-buffer gnus-article-buffer)
- (save-restriction
- (widen)
- (write-region (point-min) (point-max) file nil 'quiet))
- (gnus-cache-change-buffer group)
- (set-buffer (cdr gnus-cache-buffer))
- (goto-char (point-max))
- (forward-line -1)
- (while (condition-case ()
- (and (not (bobp))
- (> (read (current-buffer)) number))
- (error
- ;; The line was malformed, so we just remove it!!
- (gnus-delete-line)
- t))
- (forward-line -1))
- (if (bobp)
- (if (not (eobp))
- (progn
- (beginning-of-line)
- (if (< (read (current-buffer)) number)
- (forward-line 1)))
- (beginning-of-line))
- (forward-line 1))
- (beginning-of-line)
- ;; [number subject from date id references chars lines xref]
- (insert (format "%s\t%s\t%s\t%s\t%s\t%s\t%s\t%s\t%s\t\n"
- (mail-header-number headers)
- (mail-header-subject headers)
- (mail-header-from headers)
- (mail-header-date headers)
- (mail-header-id headers)
- (or (mail-header-references headers) "")
- (or (mail-header-chars headers) "")
- (or (mail-header-lines headers) "")
- (or (mail-header-xref headers) ""))))
- t))))
+(defun gnus-cache-possibly-enter-article
+ (group article ticked dormant unread &optional force)
+ (when (and (or force (not (eq gnus-use-cache 'passive)))
+ (numberp article)
+ (> article 0)) ; This might be a dummy article.
+ (let ((number article)
+ file headers lines-chars
+ (file-name-coding-system nnmail-pathname-coding-system))
+ ;; If this is a virtual group, we find the real group.
+ (when (gnus-virtual-group-p group)
+ (let ((result (nnvirtual-find-group-art
+ (gnus-group-real-name group) article)))
+ (setq group (car result)
+ number (cdr result))))
+ (when (and number
+ (> number 0) ; Reffed article.
+ (or force
+ (and (gnus-cache-fully-p group)
+ (gnus-cache-member-of-class
+ gnus-cache-enter-articles ticked dormant unread)))
+ (not (file-exists-p (setq file (gnus-cache-file-name
+ group number)))))
+ ;; Possibly create the cache directory.
+ (gnus-make-directory (file-name-directory file))
+ ;; Save the article in the cache.
+ (if (file-exists-p file)
+ t ; The article already is saved.
+ (with-current-buffer nntp-server-buffer
+ (require 'gnus-art)
+ (let ((gnus-use-cache nil)
+ (gnus-article-decode-hook nil))
+ (gnus-request-article-this-buffer number group))
+ (when (> (buffer-size) 0)
+ (let ((coding-system-for-write gnus-cache-coding-system))
+ (gnus-write-buffer file)
+ (gnus-cache-update-file-total-fetched-for group file))
+ (setq lines-chars (nnheader-get-lines-and-char))
+ (nnheader-remove-body)
+ (setq headers (nnheader-parse-naked-head))
+ (mail-header-set-number headers number)
+ (mail-header-set-lines headers (car lines-chars))
+ (mail-header-set-chars headers (cadr lines-chars))
+ (gnus-cache-change-buffer group)
+ (set-buffer (cdr gnus-cache-buffer))
+ (goto-char (point-max))
+ (forward-line -1)
+ (while (condition-case ()
+ (when (not (bobp))
+ (> (read (current-buffer)) number))
+ (error
+ ;; The line was malformed, so we just remove it!!
+ (gnus-delete-line)
+ t))
+ (forward-line -1))
+ (if (bobp)
+ (if (not (eobp))
+ (progn
+ (beginning-of-line)
+ (when (< (read (current-buffer)) number)
+ (forward-line 1)))
+ (beginning-of-line))
+ (forward-line 1))
+ (beginning-of-line)
+ (nnheader-insert-nov headers)
+ ;; Update the active info.
+ (set-buffer gnus-summary-buffer)
+ (gnus-cache-possibly-update-active group (cons number number))
+ (setq gnus-newsgroup-cached
+ (gnus-add-to-sorted-list gnus-newsgroup-cached article))
+ (gnus-summary-update-secondary-mark article))
+ t))))))
(defun gnus-cache-enter-remove-article (article)
- (setq gnus-cache-removeable-articles
- (cons article gnus-cache-removeable-articles)))
-
-(defsubst gnus-cache-possibly-remove-article
- (article ticked dormant unread)
- (let ((file (gnus-cache-file-name gnus-newsgroup-name article)))
- (if (or (not (file-exists-p file))
- (not (gnus-cache-member-of-class
- gn
projects / gnus / blobdiff