Commit | Line | Data |
---|---|---|
eec82323 LMI |
1 | ;;; gnus-async.el --- asynchronous support for Gnus |
2 | ;; Copyright (C) 1996,97 Free Software Foundation, Inc. | |
3 | ||
4 | ;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no> | |
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 | (require 'gnus) | |
29 | (require 'gnus-sum) | |
30 | (require 'nntp) | |
31 | ||
32 | (defgroup gnus-asynchronous nil | |
33 | "Support for asynchronous operations." | |
34 | :group 'gnus) | |
35 | ||
36 | (defcustom gnus-asynchronous t | |
37 | "*If nil, inhibit all Gnus asynchronicity. | |
38 | If non-nil, let the other asynch variables be heeded." | |
39 | :group 'gnus-asynchronous | |
40 | :type 'boolean) | |
41 | ||
42 | (defcustom gnus-use-article-prefetch 30 | |
43 | "*If non-nil, prefetch articles in groups that allow this. | |
44 | If a number, prefetch only that many articles forward; | |
45 | if t, prefetch as many articles as possible." | |
46 | :group 'gnus-asynchronous | |
47 | :type '(choice (const :tag "off" nil) | |
48 | (const :tag "all" t) | |
49 | (integer :tag "some" 0))) | |
50 | ||
51 | (defcustom gnus-prefetched-article-deletion-strategy '(read exit) | |
52 | "List of symbols that say when to remove articles from the prefetch buffer. | |
53 | Possible values in this list are `read', which means that | |
54 | articles are removed as they are read, and `exit', which means | |
55 | that all articles belonging to a group are removed on exit | |
56 | from that group." | |
57 | :group 'gnus-asynchronous | |
58 | :type '(set (const read) (const exit))) | |
59 | ||
60 | (defcustom gnus-use-header-prefetch nil | |
61 | "*If non-nil, prefetch the headers to the next group." | |
62 | :group 'gnus-asynchronous | |
63 | :type 'boolean) | |
64 | ||
65 | (defcustom gnus-async-prefetch-article-p 'gnus-async-unread-p | |
66 | "Function called to say whether an article should be prefetched or not. | |
67 | The function is called with one parameter -- the article data. | |
68 | It should return non-nil if the article is to be prefetched." | |
69 | :group 'gnus-asynchronous | |
70 | :type 'function) | |
71 | ||
72 | ;;; Internal variables. | |
73 | ||
74 | (defvar gnus-async-prefetch-article-buffer " *Async Prefetch Article*") | |
75 | (defvar gnus-async-article-alist nil) | |
76 | (defvar gnus-async-article-semaphore '(nil)) | |
77 | (defvar gnus-async-fetch-list nil) | |
78 | ||
79 | (defvar gnus-async-prefetch-headers-buffer " *Async Prefetch Headers*") | |
80 | (defvar gnus-async-header-prefetched nil) | |
81 | ||
82 | ;;; Utility functions. | |
83 | ||
84 | (defun gnus-group-asynchronous-p (group) | |
85 | "Say whether GROUP is fetched from a server that supports asynchronicity." | |
86 | (gnus-asynchronous-p (gnus-find-method-for-group group))) | |
87 | ||
88 | ;;; Somewhat bogus semaphores. | |
89 | ||
90 | (defun gnus-async-get-semaphore (semaphore) | |
91 | "Wait until SEMAPHORE is released." | |
92 | (while (/= (length (nconc (symbol-value semaphore) (list nil))) 2) | |
93 | (sleep-for 1))) | |
94 | ||
95 | (defun gnus-async-release-semaphore (semaphore) | |
96 | "Release SEMAPHORE." | |
97 | (setcdr (symbol-value semaphore) nil)) | |
98 | ||
99 | (defmacro gnus-async-with-semaphore (&rest forms) | |
100 | `(unwind-protect | |
101 | (progn | |
102 | (gnus-async-get-semaphore 'gnus-async-article-semaphore) | |
103 | ,@forms) | |
104 | (gnus-async-release-semaphore 'gnus-async-article-semaphore))) | |
105 | ||
106 | (put 'gnus-asynch-with-semaphore 'lisp-indent-function 0) | |
107 | (put 'gnus-asynch-with-semaphore 'edebug-form-spec '(body)) | |
108 | ||
109 | ;;; | |
110 | ;;; Article prefetch | |
111 | ;;; | |
112 | ||
113 | (gnus-add-shutdown 'gnus-async-close 'gnus) | |
114 | (defun gnus-async-close () | |
115 | (gnus-kill-buffer gnus-async-prefetch-article-buffer) | |
116 | (gnus-kill-buffer gnus-async-prefetch-headers-buffer) | |
117 | (setq gnus-async-article-alist nil | |
118 | gnus-async-header-prefetched nil)) | |
119 | ||
120 | (defun gnus-async-set-buffer () | |
121 | (nnheader-set-temp-buffer gnus-async-prefetch-article-buffer t)) | |
122 | ||
123 | (defun gnus-async-halt-prefetch () | |
124 | "Stop prefetching." | |
125 | (setq gnus-async-fetch-list nil)) | |
126 | ||
127 | (defun gnus-async-prefetch-next (group article summary) | |
128 | "Possibly prefetch several articles starting with the article after ARTICLE." | |
129 | (when (and (gnus-buffer-live-p summary) | |
130 | gnus-asynchronous | |
131 | (gnus-group-asynchronous-p group)) | |
132 | (save-excursion | |
133 | (set-buffer gnus-summary-buffer) | |
134 | (let ((next (caadr (gnus-data-find-list article)))) | |
135 | (when next | |
136 | (if (not (fboundp 'run-with-idle-timer)) | |
137 | ;; This is either an older Emacs or XEmacs, so we | |
138 | ;; do this, which leads to slightly slower article | |
139 | ;; buffer display. | |
140 | (gnus-async-prefetch-article group next summary) | |
141 | (run-with-idle-timer | |
142 | 0.1 nil 'gnus-async-prefetch-article group next summary))))))) | |
143 | ||
144 | (defun gnus-async-prefetch-article (group article summary &optional next) | |
145 | "Possibly prefetch several articles starting with ARTICLE." | |
146 | (if (not (gnus-buffer-live-p summary)) | |
147 | (gnus-async-with-semaphore | |
148 | (setq gnus-async-fetch-list nil)) | |
149 | (when (and gnus-asynchronous | |
150 | (gnus-alive-p)) | |
151 | (when next | |
152 | (gnus-async-with-semaphore | |
153 | (pop gnus-async-fetch-list))) | |
154 | (let ((do-fetch next) | |
155 | (do-message t)) ;(eq major-mode 'gnus-summary-mode))) | |
156 | (when (and (gnus-group-asynchronous-p group) | |
157 | (gnus-buffer-live-p summary) | |
158 | (or (not next) | |
159 | gnus-async-fetch-list)) | |
160 | (gnus-async-with-semaphore | |
161 | (unless next | |
162 | (setq do-fetch (not gnus-async-fetch-list)) | |
163 | ;; Nix out any outstanding requests. | |
164 | (setq gnus-async-fetch-list nil) | |
165 | ;; Fill in the new list. | |
166 | (let ((n gnus-use-article-prefetch) | |
167 | (data (gnus-data-find-list article)) | |
168 | d) | |
169 | (while (and (setq d (pop data)) | |
170 | (if (numberp n) | |
171 | (natnump (decf n)) | |
172 | n)) | |
173 | (unless (or (gnus-async-prefetched-article-entry | |
174 | group (setq article (gnus-data-number d))) | |
175 | (not (natnump article)) | |
176 | (not (funcall gnus-async-prefetch-article-p d))) | |
177 | ;; Not already fetched -- so we add it to the list. | |
178 | (push article gnus-async-fetch-list))) | |
179 | (setq gnus-async-fetch-list | |
180 | (nreverse gnus-async-fetch-list)))) | |
181 | ||
182 | (when do-fetch | |
183 | (setq article (car gnus-async-fetch-list)))) | |
184 | ||
185 | (when (and do-fetch article) | |
186 | ;; We want to fetch some more articles. | |
187 | (save-excursion | |
188 | (set-buffer summary) | |
189 | (let (mark) | |
190 | (gnus-async-set-buffer) | |
191 | (goto-char (point-max)) | |
192 | (setq mark (point-marker)) | |
193 | (let ((nnheader-callback-function | |
194 | (gnus-make-async-article-function | |
195 | group article mark summary next)) | |
196 | (nntp-server-buffer | |
197 | (get-buffer gnus-async-prefetch-article-buffer))) | |
198 | (when do-message | |
199 | (gnus-message 9 "Prefetching article %d in group %s" | |
200 | article group)) | |
201 | (gnus-request-article article group)))))))))) | |
202 | ||
203 | (defun gnus-make-async-article-function (group article mark summary next) | |
204 | "Return a callback function." | |
205 | `(lambda (arg) | |
206 | (save-excursion | |
207 | (when arg | |
208 | (gnus-async-set-buffer) | |
209 | (gnus-async-with-semaphore | |
210 | (push (list ',(intern (format "%s-%d" group article)) | |
211 | ,mark (set-marker (make-marker) (point-max)) | |
212 | ,group ,article) | |
213 | gnus-async-article-alist))) | |
214 | (if (not (gnus-buffer-live-p ,summary)) | |
215 | (gnus-async-with-semaphore | |
216 | (setq gnus-async-fetch-list nil)) | |
217 | (gnus-async-prefetch-article ,group ,next ,summary t))))) | |
218 | ||
219 | (defun gnus-async-unread-p (data) | |
220 | "Return non-nil if DATA represents an unread article." | |
221 | (gnus-data-unread-p data)) | |
222 | ||
223 | (defun gnus-async-request-fetched-article (group article buffer) | |
224 | "See whether we have ARTICLE from GROUP and put it in BUFFER." | |
225 | (when (numberp article) | |
226 | (let ((entry (gnus-async-prefetched-article-entry group article))) | |
227 | (when entry | |
228 | (save-excursion | |
229 | (gnus-async-set-buffer) | |
230 | (copy-to-buffer buffer (cadr entry) (caddr entry)) | |
231 | ;; Remove the read article from the prefetch buffer. | |
232 | (when (memq 'read gnus-prefetched-article-deletion-strategy) | |
233 | (gnus-async-delete-prefected-entry entry)) | |
234 | t))))) | |
235 | ||
236 | (defun gnus-async-delete-prefected-entry (entry) | |
237 | "Delete ENTRY from buffer and alist." | |
238 | (ignore-errors | |
239 | (delete-region (cadr entry) (caddr entry)) | |
240 | (set-marker (cadr entry) nil) | |
241 | (set-marker (caddr entry) nil)) | |
242 | (gnus-async-with-semaphore | |
243 | (setq gnus-async-article-alist | |
244 | (delq entry gnus-async-article-alist)))) | |
245 | ||
246 | (defun gnus-async-prefetch-remove-group (group) | |
247 | "Remove all articles belonging to GROUP from the prefetch buffer." | |
248 | (when (and (gnus-group-asynchronous-p group) | |
249 | (memq 'exit gnus-prefetched-article-deletion-strategy)) | |
250 | (let ((alist gnus-async-article-alist)) | |
251 | (save-excursion | |
252 | (gnus-async-set-buffer) | |
253 | (while alist | |
254 | (when (equal group (nth 3 (car alist))) | |
255 | (gnus-async-delete-prefected-entry (car alist))) | |
256 | (pop alist)))))) | |
257 | ||
258 | (defun gnus-async-prefetched-article-entry (group article) | |
259 | "Return the entry for ARTICLE in GROUP iff it has been prefetched." | |
260 | (let ((entry (assq (intern (format "%s-%d" group article)) | |
261 | gnus-async-article-alist))) | |
262 | ;; Perhaps something has emptied the buffer? | |
263 | (if (and entry | |
264 | (= (cadr entry) (caddr entry))) | |
265 | (progn | |
266 | (ignore-errors | |
267 | (set-marker (cadr entry) nil) | |
268 | (set-marker (caddr entry) nil)) | |
269 | (setq gnus-async-article-alist | |
270 | (delq entry gnus-async-article-alist)) | |
271 | nil) | |
272 | entry))) | |
273 | ||
274 | ;;; | |
275 | ;;; Header prefetch | |
276 | ;;; | |
277 | ||
278 | (defun gnus-async-prefetch-headers (group) | |
279 | "Prefetch the headers for group GROUP." | |
280 | (save-excursion | |
281 | (let (unread) | |
282 | (when (and gnus-use-header-prefetch | |
283 | gnus-asynchronous | |
284 | (gnus-group-asynchronous-p group) | |
285 | (listp gnus-async-header-prefetched) | |
286 | (setq unread (gnus-list-of-unread-articles group))) | |
287 | ;; Mark that a fetch is in progress. | |
288 | (setq gnus-async-header-prefetched t) | |
289 | (nnheader-set-temp-buffer gnus-async-prefetch-headers-buffer t) | |
290 | (erase-buffer) | |
291 | (let ((nntp-server-buffer (current-buffer)) | |
292 | (nnheader-callback-function | |
293 | `(lambda (arg) | |
294 | (setq gnus-async-header-prefetched | |
295 | ,(cons group unread))))) | |
296 | (gnus-retrieve-headers unread group gnus-fetch-old-headers)))))) | |
297 | ||
298 | (defun gnus-async-retrieve-fetched-headers (articles group) | |
299 | "See whether we have prefetched headers." | |
300 | (when (and gnus-use-header-prefetch | |
301 | (gnus-group-asynchronous-p group) | |
302 | (listp gnus-async-header-prefetched) | |
303 | (equal group (car gnus-async-header-prefetched)) | |
304 | (equal articles (cdr gnus-async-header-prefetched))) | |
305 | (save-excursion | |
306 | (nnheader-set-temp-buffer gnus-async-prefetch-headers-buffer t) | |
307 | (nntp-decode-text) | |
308 | (copy-to-buffer nntp-server-buffer (point-min) (point-max)) | |
309 | (erase-buffer) | |
310 | (setq gnus-async-header-prefetched nil) | |
311 | t))) | |
312 | ||
313 | (provide 'gnus-async) | |
314 | ||
315 | ;;; gnus-async.el ends here |