Mercurial > emacs
annotate lisp/gnus-cache.el @ 14502:37107ad125f0
Include blockinput.h.
author | Richard M. Stallman <rms@gnu.org> |
---|---|
date | Tue, 06 Feb 1996 20:09:50 +0000 |
parents | 83f275dcd93a |
children | 530d0d516a42 |
rev | line source |
---|---|
13401 | 1 ;;; gnus-cache.el --- cache interface for Gnus |
14169 | 2 |
13401 | 3 ;; Copyright (C) 1995 Free Software Foundation, Inc. |
4 | |
5 ;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no> | |
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 | |
14169 | 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. | |
13401 | 24 |
25 ;;; Commentary: | |
26 | |
27 ;;; Code: | |
28 | |
29 (require 'gnus) | |
30 | |
31 (defvar gnus-cache-directory (concat gnus-article-save-directory "cache/") | |
32 "*The directory where cached articles will be stored.") | |
33 | |
34 (defvar gnus-cache-enter-articles '(ticked dormant) | |
35 "*Classes of articles to enter into the cache.") | |
36 | |
37 (defvar gnus-cache-remove-articles '(read) | |
38 "*Classes of articles to remove from the cache.") | |
39 | |
40 | |
41 | |
42 (defvar gnus-cache-buffer nil) | |
43 | |
44 | |
45 | |
46 (defun gnus-cache-change-buffer (group) | |
47 (and gnus-cache-buffer | |
48 ;; see if the current group's overview cache has been loaded | |
49 (or (string= group (car gnus-cache-buffer)) | |
50 ;; another overview cache is current, save it | |
51 (gnus-cache-save-buffers))) | |
52 ;; if gnus-cache buffer is nil, create it | |
53 (or gnus-cache-buffer | |
54 ;; create cache buffer | |
55 (save-excursion | |
56 (setq gnus-cache-buffer | |
57 (cons group | |
58 (set-buffer (get-buffer-create " *gnus-cache-overview*")))) | |
59 (buffer-disable-undo (current-buffer)) | |
60 ;; insert the contents of this groups cache overview | |
61 (erase-buffer) | |
62 (let ((file (gnus-cache-file-name group ".overview"))) | |
63 (and (file-exists-p file) | |
64 (insert-file-contents file))) | |
65 ;; we have a fresh (empty/just loaded) buffer, | |
66 ;; mark it as unmodified to save a redundant write later. | |
67 (set-buffer-modified-p nil)))) | |
68 | |
69 | |
70 (defun gnus-cache-save-buffers () | |
71 ;; save the overview buffer if it exists and has been modified | |
72 ;; delete empty cache subdirectories | |
73 (if (null gnus-cache-buffer) | |
74 () | |
75 (let ((buffer (cdr gnus-cache-buffer)) | |
76 (overview-file (gnus-cache-file-name | |
77 (car gnus-cache-buffer) ".overview"))) | |
78 ;; write the overview only if it was modified | |
79 (if (buffer-modified-p buffer) | |
80 (save-excursion | |
81 (set-buffer buffer) | |
82 (if (> (buffer-size) 0) | |
83 ;; non-empty overview, write it out | |
84 (progn | |
85 (gnus-make-directory (file-name-directory overview-file)) | |
86 (write-region (point-min) (point-max) | |
87 overview-file nil 'quietly)) | |
88 ;; empty overview file, remove it | |
89 (and (file-exists-p overview-file) | |
90 (delete-file overview-file)) | |
91 ;; if possible, remove group's cache subdirectory | |
92 (condition-case nil | |
93 ;; FIXME: we can detect the error type and warn the user | |
94 ;; of any inconsistencies (articles w/o nov entries?). | |
95 ;; for now, just be conservative...delete only if safe -- sj | |
96 (delete-directory (file-name-directory overview-file)) | |
97 (error nil))))) | |
98 ;; kill the buffer, it's either unmodified or saved | |
99 (gnus-kill-buffer buffer) | |
100 (setq gnus-cache-buffer nil)))) | |
101 | |
102 | |
103 ;; Return whether an article is a member of a class. | |
104 (defun gnus-cache-member-of-class (class ticked dormant unread) | |
105 (or (and ticked (memq 'ticked class)) | |
106 (and dormant (memq 'dormant class)) | |
107 (and unread (memq 'unread class)) | |
108 (and (not unread) (memq 'read class)))) | |
109 | |
110 (defun gnus-cache-file-name (group article) | |
111 (concat (file-name-as-directory gnus-cache-directory) | |
112 (if (gnus-use-long-file-name 'not-cache) | |
113 group | |
114 (let ((group (concat group ""))) | |
115 (if (string-match ":" group) | |
116 (aset group (match-beginning 0) ?/)) | |
117 (gnus-replace-chars-in-string group ?. ?/))) | |
118 "/" (if (stringp article) article (int-to-string article)))) | |
119 | |
120 (defun gnus-cache-possibly-enter-article | |
121 (group article headers ticked dormant unread) | |
122 (let ((number (mail-header-number headers)) | |
123 file dir) | |
124 (if (or (not (vectorp headers)) ; This might be a dummy article. | |
125 (< number 0) ; Reffed article from other group. | |
126 (not (gnus-cache-member-of-class | |
127 gnus-cache-enter-articles ticked dormant unread)) | |
128 (file-exists-p (setq file (gnus-cache-file-name group article)))) | |
129 () ; Do nothing. | |
130 ;; Possibly create the cache directory. | |
131 (or (file-exists-p (setq dir (file-name-directory file))) | |
132 (gnus-make-directory dir)) | |
133 ;; Save the article in the cache. | |
134 (if (file-exists-p file) | |
135 t ; The article already is saved, so we end here. | |
136 (let ((gnus-use-cache nil)) | |
137 (gnus-summary-select-article)) | |
138 (save-excursion | |
139 (set-buffer gnus-article-buffer) | |
140 (save-restriction | |
141 (widen) | |
142 (write-region (point-min) (point-max) file nil 'quiet)) | |
143 (gnus-cache-change-buffer group) | |
144 (set-buffer (cdr gnus-cache-buffer)) | |
145 (goto-char (point-max)) | |
146 (forward-line -1) | |
147 (while (condition-case () | |
148 (and (not (bobp)) | |
149 (> (read (current-buffer)) number)) | |
150 (error | |
151 ;; The line was malformed, so we just remove it!! | |
152 (gnus-delete-line) | |
153 t)) | |
154 (forward-line -1)) | |
155 (if (bobp) | |
156 (if (not (eobp)) | |
157 (progn | |
158 (beginning-of-line) | |
159 (if (< (read (current-buffer)) number) | |
160 (forward-line 1))) | |
161 (beginning-of-line)) | |
162 (forward-line 1)) | |
163 (beginning-of-line) | |
164 ;; [number subject from date id references chars lines xref] | |
165 (insert (format "%s\t%s\t%s\t%s\t%s\t%s\t%s\t%s\t%s\t\n" | |
166 (mail-header-number headers) | |
167 (mail-header-subject headers) | |
168 (mail-header-from headers) | |
169 (mail-header-date headers) | |
170 (mail-header-id headers) | |
171 (or (mail-header-references headers) "") | |
172 (or (mail-header-chars headers) "") | |
173 (or (mail-header-lines headers) "") | |
174 (or (mail-header-xref headers) "")))) | |
175 t)))) | |
176 | |
177 (defun gnus-cache-enter-remove-article (article) | |
14037
f98acba8258a
(gnus-cache-enter-remove-article, gnus-cache-possibly-remove-articles):
Karl Heuer <kwzh@gnu.org>
parents:
13401
diff
changeset
|
178 (setq gnus-cache-removable-articles |
f98acba8258a
(gnus-cache-enter-remove-article, gnus-cache-possibly-remove-articles):
Karl Heuer <kwzh@gnu.org>
parents:
13401
diff
changeset
|
179 (cons article gnus-cache-removable-articles))) |
13401 | 180 |
181 (defsubst gnus-cache-possibly-remove-article | |
182 (article ticked dormant unread) | |
183 (let ((file (gnus-cache-file-name gnus-newsgroup-name article))) | |
184 (if (or (not (file-exists-p file)) | |
185 (not (gnus-cache-member-of-class | |
186 gnus-cache-remove-articles ticked dormant unread))) | |
187 nil | |
188 (save-excursion | |
189 (delete-file file) | |
190 (set-buffer (cdr gnus-cache-buffer)) | |
191 (goto-char (point-min)) | |
192 (if (or (looking-at (concat (int-to-string article) "\t")) | |
193 (search-forward (concat "\n" (int-to-string article) "\t") | |
194 (point-max) t)) | |
195 (delete-region (progn (beginning-of-line) (point)) | |
196 (progn (forward-line 1) (point)))))))) | |
197 | |
198 (defun gnus-cache-possibly-remove-articles () | |
14037
f98acba8258a
(gnus-cache-enter-remove-article, gnus-cache-possibly-remove-articles):
Karl Heuer <kwzh@gnu.org>
parents:
13401
diff
changeset
|
199 (let ((articles gnus-cache-removable-articles) |
13401 | 200 (cache-articles (gnus-cache-articles-in-group gnus-newsgroup-name)) |
201 article) | |
202 (gnus-cache-change-buffer gnus-newsgroup-name) | |
203 (while articles | |
204 (setq article (car articles) | |
205 articles (cdr articles)) | |
206 (if (memq article cache-articles) | |
207 ;; The article was in the cache, so we see whether we are | |
208 ;; supposed to remove it from the cache. | |
209 (gnus-cache-possibly-remove-article | |
210 article (memq article gnus-newsgroup-marked) | |
211 (memq article gnus-newsgroup-dormant) | |
212 (or (memq article gnus-newsgroup-unreads) | |
213 (memq article gnus-newsgroup-unselected)))))) | |
214 ;; the overview file might have been modified, save it | |
215 ;; safe because we're only called at group exit anyway | |
216 (gnus-cache-save-buffers)) | |
217 | |
218 | |
219 (defun gnus-cache-request-article (article group) | |
220 (let ((file (gnus-cache-file-name group article))) | |
221 (if (not (file-exists-p file)) | |
222 () | |
223 (erase-buffer) | |
224 ;; There may be some overlays that we have to kill... | |
225 (insert "i") | |
226 (let ((overlays (overlays-at (point-min)))) | |
227 (while overlays | |
228 (delete-overlay (car overlays)) | |
229 (setq overlays (cdr overlays)))) | |
230 (erase-buffer) | |
231 (insert-file-contents file) | |
232 t))) | |
233 | |
234 (defun gnus-cache-articles-in-group (group) | |
235 (let ((dir (file-name-directory (gnus-cache-file-name group 1))) | |
236 articles) | |
237 (if (not (file-exists-p dir)) | |
238 nil | |
239 (setq articles (directory-files dir nil "^[0-9]+$" t)) | |
240 (if (not articles) | |
241 nil | |
242 (sort (mapcar (function (lambda (name) | |
243 (string-to-int name))) | |
244 articles) | |
245 '<))))) | |
246 | |
247 (defun gnus-cache-active-articles (group) | |
248 (let ((articles (gnus-cache-articles-in-group group))) | |
249 (and articles | |
250 (cons (car articles) (gnus-last-element articles))))) | |
251 | |
252 (defun gnus-cache-possibly-alter-active (group active) | |
253 (let ((cache-active (gnus-cache-active-articles group))) | |
254 (and cache-active (< (car cache-active) (car active)) | |
255 (setcar active (car cache-active))) | |
256 (and cache-active (> (cdr cache-active) (cdr active)) | |
257 (setcdr active (cdr cache-active))))) | |
258 | |
259 (defun gnus-cache-retrieve-headers (articles group) | |
260 (let* ((cached (gnus-cache-articles-in-group group)) | |
261 (articles (gnus-sorted-complement articles cached)) | |
262 (cache-file (gnus-cache-file-name group ".overview")) | |
263 type) | |
264 (let ((gnus-use-cache nil)) | |
265 (setq type (and articles (gnus-retrieve-headers articles group)))) | |
266 (gnus-cache-save-buffers) | |
267 (save-excursion | |
268 (cond ((not (file-exists-p cache-file)) | |
269 type) | |
270 ((null type) | |
271 (set-buffer nntp-server-buffer) | |
272 (erase-buffer) | |
273 (insert-file-contents cache-file) | |
274 'nov) | |
275 ((eq type 'nov) | |
276 (gnus-cache-braid-nov group cached) | |
277 type) | |
278 (t | |
279 (gnus-cache-braid-heads group cached) | |
280 type))))) | |
281 | |
282 (defun gnus-cache-braid-nov (group cached) | |
283 (let ((cache-buf (get-buffer-create " *gnus-cache*")) | |
284 beg end) | |
285 (gnus-cache-save-buffers) | |
286 (save-excursion | |
287 (set-buffer cache-buf) | |
288 (buffer-disable-undo (current-buffer)) | |
289 (erase-buffer) | |
290 (insert-file-contents (gnus-cache-file-name group ".overview")) | |
291 (goto-char (point-min)) | |
292 (insert "\n") | |
293 (goto-char (point-min))) | |
294 (set-buffer nntp-server-buffer) | |
295 (goto-char (point-min)) | |
296 (while cached | |
297 (while (and (not (eobp)) | |
298 (< (read (current-buffer)) (car cached))) | |
299 (forward-line 1)) | |
300 (beginning-of-line) | |
301 (save-excursion | |
302 (set-buffer cache-buf) | |
303 (if (search-forward (concat "\n" (int-to-string (car cached)) "\t") | |
304 nil t) | |
305 (setq beg (progn (beginning-of-line) (point)) | |
306 end (progn (end-of-line) (point))) | |
307 (setq beg nil))) | |
308 (if beg (progn (insert-buffer-substring cache-buf beg end) | |
309 (insert "\n"))) | |
310 (setq cached (cdr cached))) | |
311 (kill-buffer cache-buf))) | |
312 | |
313 (defun gnus-cache-braid-heads (group cached) | |
314 (let ((cache-buf (get-buffer-create " *gnus-cache*"))) | |
315 (save-excursion | |
316 (set-buffer cache-buf) | |
317 (buffer-disable-undo (current-buffer)) | |
318 (erase-buffer)) | |
319 (set-buffer nntp-server-buffer) | |
320 (goto-char (point-min)) | |
321 (while cached | |
322 (while (and (not (eobp)) | |
323 (looking-at "2.. +\\([0-9]+\\) ") | |
324 (< (progn (goto-char (match-beginning 1)) | |
325 (read (current-buffer))) | |
326 (car cached))) | |
327 (search-forward "\n.\n" nil 'move)) | |
328 (beginning-of-line) | |
329 (save-excursion | |
330 (set-buffer cache-buf) | |
331 (erase-buffer) | |
332 (insert-file-contents (gnus-cache-file-name group (car cached))) | |
333 (goto-char (point-min)) | |
334 (insert "220 " (int-to-string (car cached)) " Article retrieved.\n") | |
335 (search-forward "\n\n" nil 'move) | |
336 (delete-region (point) (point-max)) | |
337 (forward-char -1) | |
338 (insert ".")) | |
339 (insert-buffer-substring cache-buf) | |
340 (setq cached (cdr cached))) | |
341 (kill-buffer cache-buf))) | |
342 | |
343 (defun gnus-jog-cache () | |
344 "Go through all groups and put the articles into the cache." | |
345 (interactive) | |
346 (let ((newsrc (cdr gnus-newsrc-alist)) | |
347 (gnus-cache-enter-articles '(unread)) | |
348 (gnus-mark-article-hook nil) | |
349 (gnus-expert-user t) | |
350 (gnus-large-newsgroup nil)) | |
351 (while newsrc | |
352 (gnus-summary-read-group (car (car newsrc))) | |
353 (if (not (eq major-mode 'gnus-summary-mode)) | |
354 () | |
355 (while gnus-newsgroup-unreads | |
356 (gnus-summary-select-article t t nil (car gnus-newsgroup-unreads)) | |
357 (setq gnus-newsgroup-unreads (cdr gnus-newsgroup-unreads))) | |
358 (kill-buffer (current-buffer))) | |
359 (setq newsrc (cdr newsrc))))) | |
360 | |
361 (provide 'gnus-cache) | |
362 | |
363 ;;; gnus-cache.el ends here |