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