1 ;;; gnus-cache.el --- cache interface for Gnus
2 ;; Copyright (C) 1995 Free Software Foundation, Inc.
4 ;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
7 ;; This file is part of GNU Emacs.
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)
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.
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
21 ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
29 (defvar gnus-cache-directory
(concat gnus-article-save-directory
"cache/")
30 "*The directory where cached articles will be stored.")
32 (defvar gnus-cache-enter-articles
'(ticked dormant
)
33 "*Classes of articles to enter into the cache.")
35 (defvar gnus-cache-remove-articles
'(read)
36 "*Classes of articles to remove from the cache.")
40 (defvar gnus-cache-buffer nil
)
44 (defun gnus-cache-change-buffer (group)
45 (and gnus-cache-buffer
46 ;; see if the current group's overview cache has been loaded
47 (or (string= group
(car gnus-cache-buffer
))
48 ;; another overview cache is current, save it
49 (gnus-cache-save-buffers)))
50 ;; if gnus-cache buffer is nil, create it
52 ;; create cache buffer
54 (setq gnus-cache-buffer
56 (set-buffer (get-buffer-create " *gnus-cache-overview*"))))
57 (buffer-disable-undo (current-buffer))
58 ;; insert the contents of this groups cache overview
60 (let ((file (gnus-cache-file-name group
".overview")))
61 (and (file-exists-p file
)
62 (insert-file-contents file
)))
63 ;; we have a fresh (empty/just loaded) buffer,
64 ;; mark it as unmodified to save a redundant write later.
65 (set-buffer-modified-p nil
))))
68 (defun gnus-cache-save-buffers ()
69 ;; save the overview buffer if it exists and has been modified
70 ;; delete empty cache subdirectories
71 (if (null gnus-cache-buffer
)
73 (let ((buffer (cdr gnus-cache-buffer
))
74 (overview-file (gnus-cache-file-name
75 (car gnus-cache-buffer
) ".overview")))
76 ;; write the overview only if it was modified
77 (if (buffer-modified-p buffer
)
80 (if (> (buffer-size) 0)
81 ;; non-empty overview, write it out
83 (gnus-make-directory (file-name-directory overview-file
))
84 (write-region (point-min) (point-max)
85 overview-file nil
'quietly
))
86 ;; empty overview file, remove it
87 (and (file-exists-p overview-file
)
88 (delete-file overview-file
))
89 ;; if possible, remove group's cache subdirectory
91 ;; FIXME: we can detect the error type and warn the user
92 ;; of any inconsistencies (articles w/o nov entries?).
93 ;; for now, just be conservative...delete only if safe -- sj
94 (delete-directory (file-name-directory overview-file
))
96 ;; kill the buffer, it's either unmodified or saved
97 (gnus-kill-buffer buffer
)
98 (setq gnus-cache-buffer nil
))))
101 ;; Return whether an article is a member of a class.
102 (defun gnus-cache-member-of-class (class ticked dormant unread
)
103 (or (and ticked
(memq 'ticked class
))
104 (and dormant
(memq 'dormant class
))
105 (and unread
(memq 'unread class
))
106 (and (not unread
) (memq 'read class
))))
108 (defun gnus-cache-file-name (group article
)
109 (concat (file-name-as-directory gnus-cache-directory
)
110 (if (gnus-use-long-file-name 'not-cache
)
112 (let ((group (concat group
"")))
113 (if (string-match ":" group
)
114 (aset group
(match-beginning 0) ?
/))
115 (gnus-replace-chars-in-string group ?. ?
/)))
116 "/" (if (stringp article
) article
(int-to-string article
))))
118 (defun gnus-cache-possibly-enter-article
119 (group article headers ticked dormant unread
)
120 (let ((number (mail-header-number headers
))
122 (if (or (not (vectorp headers
)) ; This might be a dummy article.
123 (< number
0) ; Reffed article from other group.
124 (not (gnus-cache-member-of-class
125 gnus-cache-enter-articles ticked dormant unread
))
126 (file-exists-p (setq file
(gnus-cache-file-name group article
))))
128 ;; Possibly create the cache directory.
129 (or (file-exists-p (setq dir
(file-name-directory file
)))
130 (gnus-make-directory dir
))
131 ;; Save the article in the cache.
132 (if (file-exists-p file
)
133 t
; The article already is saved, so we end here.
134 (let ((gnus-use-cache nil
))
135 (gnus-summary-select-article))
137 (set-buffer gnus-article-buffer
)
140 (write-region (point-min) (point-max) file nil
'quiet
))
141 (gnus-cache-change-buffer group
)
142 (set-buffer (cdr gnus-cache-buffer
))
143 (goto-char (point-max))
145 (while (condition-case ()
147 (> (read (current-buffer)) number
))
149 ;; The line was malformed, so we just remove it!!
157 (if (< (read (current-buffer)) number
)
162 ;; [number subject from date id references chars lines xref]
163 (insert (format "%s\t%s\t%s\t%s\t%s\t%s\t%s\t%s\t%s\t\n"
164 (mail-header-number headers
)
165 (mail-header-subject headers
)
166 (mail-header-from headers
)
167 (mail-header-date headers
)
168 (mail-header-id headers
)
169 (or (mail-header-references headers
) "")
170 (or (mail-header-chars headers
) "")
171 (or (mail-header-lines headers
) "")
172 (or (mail-header-xref headers
) ""))))
175 (defun gnus-cache-enter-remove-article (article)
176 (setq gnus-cache-removeable-articles
177 (cons article gnus-cache-removeable-articles
)))
179 (defsubst gnus-cache-possibly-remove-article
180 (article ticked dormant unread
)
181 (let ((file (gnus-cache-file-name gnus-newsgroup-name article
)))
182 (if (or (not (file-exists-p file
))
183 (not (gnus-cache-member-of-class
184 gnus-cache-remove-articles ticked dormant unread
)))
188 (set-buffer (cdr gnus-cache-buffer
))
189 (goto-char (point-min))
190 (if (or (looking-at (concat (int-to-string article
) "\t"))
191 (search-forward (concat "\n" (int-to-string article
) "\t")
193 (delete-region (progn (beginning-of-line) (point))
194 (progn (forward-line 1) (point))))))))
196 (defun gnus-cache-possibly-remove-articles ()
197 (let ((articles gnus-cache-removeable-articles
)
198 (cache-articles (gnus-cache-articles-in-group gnus-newsgroup-name
))
200 (gnus-cache-change-buffer gnus-newsgroup-name
)
202 (setq article
(car articles
)
203 articles
(cdr articles
))
204 (if (memq article cache-articles
)
205 ;; The article was in the cache, so we see whether we are
206 ;; supposed to remove it from the cache.
207 (gnus-cache-possibly-remove-article
208 article
(memq article gnus-newsgroup-marked
)
209 (memq article gnus-newsgroup-dormant
)
210 (or (memq article gnus-newsgroup-unreads
)
211 (memq article gnus-newsgroup-unselected
))))))
212 ;; the overview file might have been modified, save it
213 ;; safe because we're only called at group exit anyway
214 (gnus-cache-save-buffers))
217 (defun gnus-cache-request-article (article group
)
218 (let ((file (gnus-cache-file-name group article
)))
219 (if (not (file-exists-p file
))
222 ;; There may be some overlays that we have to kill...
224 (let ((overlays (overlays-at (point-min))))
226 (delete-overlay (car overlays
))
227 (setq overlays
(cdr overlays
))))
229 (insert-file-contents file
)
232 (defun gnus-cache-articles-in-group (group)
233 (let ((dir (file-name-directory (gnus-cache-file-name group
1)))
235 (if (not (file-exists-p dir
))
237 (setq articles
(directory-files dir nil
"^[0-9]+$" t
))
240 (sort (mapcar (function (lambda (name)
241 (string-to-int name
)))
245 (defun gnus-cache-active-articles (group)
246 (let ((articles (gnus-cache-articles-in-group group
)))
248 (cons (car articles
) (gnus-last-element articles
)))))
250 (defun gnus-cache-possibly-alter-active (group active
)
251 (let ((cache-active (gnus-cache-active-articles group
)))
252 (and cache-active
(< (car cache-active
) (car active
))
253 (setcar active
(car cache-active
)))
254 (and cache-active
(> (cdr cache-active
) (cdr active
))
255 (setcdr active
(cdr cache-active
)))))
257 (defun gnus-cache-retrieve-headers (articles group
)
258 (let* ((cached (gnus-cache-articles-in-group group
))
259 (articles (gnus-sorted-complement articles cached
))
260 (cache-file (gnus-cache-file-name group
".overview"))
262 (let ((gnus-use-cache nil
))
263 (setq type
(and articles
(gnus-retrieve-headers articles group
))))
264 (gnus-cache-save-buffers)
266 (cond ((not (file-exists-p cache-file
))
269 (set-buffer nntp-server-buffer
)
271 (insert-file-contents cache-file
)
274 (gnus-cache-braid-nov group cached
)
277 (gnus-cache-braid-heads group cached
)
280 (defun gnus-cache-braid-nov (group cached
)
281 (let ((cache-buf (get-buffer-create " *gnus-cache*"))
283 (gnus-cache-save-buffers)
285 (set-buffer cache-buf
)
286 (buffer-disable-undo (current-buffer))
288 (insert-file-contents (gnus-cache-file-name group
".overview"))
289 (goto-char (point-min))
291 (goto-char (point-min)))
292 (set-buffer nntp-server-buffer
)
293 (goto-char (point-min))
295 (while (and (not (eobp))
296 (< (read (current-buffer)) (car cached
)))
300 (set-buffer cache-buf
)
301 (if (search-forward (concat "\n" (int-to-string (car cached
)) "\t")
303 (setq beg
(progn (beginning-of-line) (point))
304 end
(progn (end-of-line) (point)))
306 (if beg
(progn (insert-buffer-substring cache-buf beg end
)
308 (setq cached
(cdr cached
)))
309 (kill-buffer cache-buf
)))
311 (defun gnus-cache-braid-heads (group cached
)
312 (let ((cache-buf (get-buffer-create " *gnus-cache*")))
314 (set-buffer cache-buf
)
315 (buffer-disable-undo (current-buffer))
317 (set-buffer nntp-server-buffer
)
318 (goto-char (point-min))
320 (while (and (not (eobp))
321 (looking-at "2.. +\\([0-9]+\\) ")
322 (< (progn (goto-char (match-beginning 1))
323 (read (current-buffer)))
325 (search-forward "\n.\n" nil
'move
))
328 (set-buffer cache-buf
)
330 (insert-file-contents (gnus-cache-file-name group
(car cached
)))
331 (goto-char (point-min))
332 (insert "220 " (int-to-string (car cached
)) " Article retrieved.\n")
333 (search-forward "\n\n" nil
'move
)
334 (delete-region (point) (point-max))
337 (insert-buffer-substring cache-buf
)
338 (setq cached
(cdr cached
)))
339 (kill-buffer cache-buf
)))
341 (defun gnus-jog-cache ()
342 "Go through all groups and put the articles into the cache."
344 (let ((newsrc (cdr gnus-newsrc-alist
))
345 (gnus-cache-enter-articles '(unread))
346 (gnus-mark-article-hook nil
)
348 (gnus-large-newsgroup nil
))
350 (gnus-summary-read-group (car (car newsrc
)))
351 (if (not (eq major-mode
'gnus-summary-mode
))
353 (while gnus-newsgroup-unreads
354 (gnus-summary-select-article t t nil
(car gnus-newsgroup-unreads
))
355 (setq gnus-newsgroup-unreads
(cdr gnus-newsgroup-unreads
)))
356 (kill-buffer (current-buffer)))
357 (setq newsrc
(cdr newsrc
)))))
359 (provide 'gnus-cache
)
361 ;;; gnus-cache.el ends here