Commit | Line | Data |
---|---|---|
eec82323 | 1 | ;;; gnus-async.el --- asynchronous support for Gnus |
e84b4b86 | 2 | |
ba318903 | 3 | ;; Copyright (C) 1996-2014 Free Software Foundation, Inc. |
eec82323 | 4 | |
6748645f | 5 | ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> |
eec82323 LMI |
6 | ;; Keywords: news |
7 | ||
8 | ;; This file is part of GNU Emacs. | |
9 | ||
5e809f55 | 10 | ;; GNU Emacs is free software: you can redistribute it and/or modify |
eec82323 | 11 | ;; it under the terms of the GNU General Public License as published by |
5e809f55 GM |
12 | ;; the Free Software Foundation, either version 3 of the License, or |
13 | ;; (at your option) any later version. | |
eec82323 LMI |
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 | |
5e809f55 | 17 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
eec82323 LMI |
18 | ;; GNU General Public License for more details. |
19 | ||
20 | ;; You should have received a copy of the GNU General Public License | |
5e809f55 | 21 | ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. |
eec82323 LMI |
22 | |
23 | ;;; Commentary: | |
24 | ||
25 | ;;; Code: | |
26 | ||
5ab7173c RS |
27 | (eval-when-compile (require 'cl)) |
28 | ||
eec82323 LMI |
29 | (require 'gnus) |
30 | (require 'gnus-sum) | |
31 | (require 'nntp) | |
32 | ||
33 | (defgroup gnus-asynchronous nil | |
34 | "Support for asynchronous operations." | |
35 | :group 'gnus) | |
36 | ||
eec82323 LMI |
37 | (defcustom gnus-use-article-prefetch 30 |
38 | "*If non-nil, prefetch articles in groups that allow this. | |
39 | If a number, prefetch only that many articles forward; | |
40 | if t, prefetch as many articles as possible." | |
41 | :group 'gnus-asynchronous | |
42 | :type '(choice (const :tag "off" nil) | |
16409b0b GM |
43 | (const :tag "all" t) |
44 | (integer :tag "some" 0))) | |
eec82323 | 45 | |
23f87bed MB |
46 | (defcustom gnus-asynchronous nil |
47 | "*If nil, inhibit all Gnus asynchronicity. | |
48 | If non-nil, let the other asynch variables be heeded." | |
49 | :group 'gnus-asynchronous | |
50 | :type 'boolean) | |
51 | ||
eec82323 LMI |
52 | (defcustom gnus-prefetched-article-deletion-strategy '(read exit) |
53 | "List of symbols that say when to remove articles from the prefetch buffer. | |
54 | Possible values in this list are `read', which means that | |
55 | articles are removed as they are read, and `exit', which means | |
56 | that all articles belonging to a group are removed on exit | |
57 | from that group." | |
58 | :group 'gnus-asynchronous | |
59 | :type '(set (const read) (const exit))) | |
60 | ||
61 | (defcustom gnus-use-header-prefetch nil | |
62 | "*If non-nil, prefetch the headers to the next group." | |
63 | :group 'gnus-asynchronous | |
64 | :type 'boolean) | |
65 | ||
66 | (defcustom gnus-async-prefetch-article-p 'gnus-async-unread-p | |
67 | "Function called to say whether an article should be prefetched or not. | |
68 | The function is called with one parameter -- the article data. | |
69 | It should return non-nil if the article is to be prefetched." | |
70 | :group 'gnus-asynchronous | |
71 | :type 'function) | |
72 | ||
b1992461 KY |
73 | (defcustom gnus-async-post-fetch-function nil |
74 | "Function called after an article has been prefetched. | |
75 | The function will be called narrowed to the region of the article | |
76 | that was fetched." | |
2bed3f04 | 77 | :version "24.1" |
b1992461 | 78 | :group 'gnus-asynchronous |
a931698a | 79 | :type '(choice (const nil) function)) |
b1992461 | 80 | |
eec82323 LMI |
81 | ;;; Internal variables. |
82 | ||
83 | (defvar gnus-async-prefetch-article-buffer " *Async Prefetch Article*") | |
84 | (defvar gnus-async-article-alist nil) | |
85 | (defvar gnus-async-article-semaphore '(nil)) | |
86 | (defvar gnus-async-fetch-list nil) | |
16409b0b GM |
87 | (defvar gnus-async-hashtb nil) |
88 | (defvar gnus-async-current-prefetch-group nil) | |
89 | (defvar gnus-async-current-prefetch-article nil) | |
90 | (defvar gnus-async-timer nil) | |
eec82323 LMI |
91 | |
92 | (defvar gnus-async-prefetch-headers-buffer " *Async Prefetch Headers*") | |
93 | (defvar gnus-async-header-prefetched nil) | |
94 | ||
95 | ;;; Utility functions. | |
96 | ||
97 | (defun gnus-group-asynchronous-p (group) | |
98 | "Say whether GROUP is fetched from a server that supports asynchronicity." | |
99 | (gnus-asynchronous-p (gnus-find-method-for-group group))) | |
100 | ||
101 | ;;; Somewhat bogus semaphores. | |
102 | ||
103 | (defun gnus-async-get-semaphore (semaphore) | |
104 | "Wait until SEMAPHORE is released." | |
105 | (while (/= (length (nconc (symbol-value semaphore) (list nil))) 2) | |
106 | (sleep-for 1))) | |
107 | ||
108 | (defun gnus-async-release-semaphore (semaphore) | |
109 | "Release SEMAPHORE." | |
110 | (setcdr (symbol-value semaphore) nil)) | |
111 | ||
112 | (defmacro gnus-async-with-semaphore (&rest forms) | |
113 | `(unwind-protect | |
114 | (progn | |
115 | (gnus-async-get-semaphore 'gnus-async-article-semaphore) | |
116 | ,@forms) | |
117 | (gnus-async-release-semaphore 'gnus-async-article-semaphore))) | |
118 | ||
16409b0b GM |
119 | (put 'gnus-async-with-semaphore 'lisp-indent-function 0) |
120 | (put 'gnus-async-with-semaphore 'edebug-form-spec '(body)) | |
eec82323 LMI |
121 | |
122 | ;;; | |
123 | ;;; Article prefetch | |
124 | ;;; | |
125 | ||
126 | (gnus-add-shutdown 'gnus-async-close 'gnus) | |
127 | (defun gnus-async-close () | |
128 | (gnus-kill-buffer gnus-async-prefetch-article-buffer) | |
129 | (gnus-kill-buffer gnus-async-prefetch-headers-buffer) | |
16409b0b GM |
130 | (setq gnus-async-hashtb nil |
131 | gnus-async-article-alist nil | |
eec82323 LMI |
132 | gnus-async-header-prefetched nil)) |
133 | ||
134 | (defun gnus-async-set-buffer () | |
6748645f | 135 | (nnheader-set-temp-buffer gnus-async-prefetch-article-buffer t) |
16409b0b GM |
136 | (unless gnus-async-hashtb |
137 | (setq gnus-async-hashtb (gnus-make-hashtable 1023)))) | |
eec82323 LMI |
138 | |
139 | (defun gnus-async-halt-prefetch () | |
140 | "Stop prefetching." | |
141 | (setq gnus-async-fetch-list nil)) | |
142 | ||
143 | (defun gnus-async-prefetch-next (group article summary) | |
144 | "Possibly prefetch several articles starting with the article after ARTICLE." | |
145 | (when (and (gnus-buffer-live-p summary) | |
146 | gnus-asynchronous | |
147 | (gnus-group-asynchronous-p group)) | |
20a673b2 | 148 | (with-current-buffer gnus-summary-buffer |
eec82323 LMI |
149 | (let ((next (caadr (gnus-data-find-list article)))) |
150 | (when next | |
151 | (if (not (fboundp 'run-with-idle-timer)) | |
152 | ;; This is either an older Emacs or XEmacs, so we | |
153 | ;; do this, which leads to slightly slower article | |
154 | ;; buffer display. | |
155 | (gnus-async-prefetch-article group next summary) | |
16409b0b GM |
156 | (when gnus-async-timer |
157 | (ignore-errors | |
158 | (nnheader-cancel-timer 'gnus-async-timer))) | |
159 | (setq gnus-async-timer | |
160 | (run-with-idle-timer | |
161 | 0.1 nil 'gnus-async-prefetch-article | |
162 | group next summary)))))))) | |
eec82323 LMI |
163 | |
164 | (defun gnus-async-prefetch-article (group article summary &optional next) | |
165 | "Possibly prefetch several articles starting with ARTICLE." | |
166 | (if (not (gnus-buffer-live-p summary)) | |
167 | (gnus-async-with-semaphore | |
16409b0b | 168 | (setq gnus-async-fetch-list nil)) |
eec82323 LMI |
169 | (when (and gnus-asynchronous |
170 | (gnus-alive-p)) | |
171 | (when next | |
172 | (gnus-async-with-semaphore | |
16409b0b | 173 | (pop gnus-async-fetch-list))) |
eec82323 | 174 | (let ((do-fetch next) |
16409b0b | 175 | (do-message t)) ;(eq major-mode 'gnus-summary-mode))) |
eec82323 LMI |
176 | (when (and (gnus-group-asynchronous-p group) |
177 | (gnus-buffer-live-p summary) | |
178 | (or (not next) | |
179 | gnus-async-fetch-list)) | |
180 | (gnus-async-with-semaphore | |
16409b0b GM |
181 | (unless next |
182 | (setq do-fetch (not gnus-async-fetch-list)) | |
183 | ;; Nix out any outstanding requests. | |
184 | (setq gnus-async-fetch-list nil) | |
185 | ;; Fill in the new list. | |
186 | (let ((n gnus-use-article-prefetch) | |
187 | (data (gnus-data-find-list article)) | |
188 | d) | |
189 | (while (and (setq d (pop data)) | |
190 | (if (numberp n) | |
191 | (natnump (decf n)) | |
192 | n)) | |
193 | (unless (or (gnus-async-prefetched-article-entry | |
194 | group (setq article (gnus-data-number d))) | |
195 | (not (natnump article)) | |
196 | (not (funcall gnus-async-prefetch-article-p d))) | |
197 | ;; Not already fetched -- so we add it to the list. | |
198 | (push article gnus-async-fetch-list))) | |
199 | (setq gnus-async-fetch-list | |
200 | (nreverse gnus-async-fetch-list)))) | |
201 | ||
202 | (when do-fetch | |
203 | (setq article (car gnus-async-fetch-list)))) | |
eec82323 LMI |
204 | |
205 | (when (and do-fetch article) | |
206 | ;; We want to fetch some more articles. | |
20a673b2 | 207 | (with-current-buffer summary |
eec82323 LMI |
208 | (let (mark) |
209 | (gnus-async-set-buffer) | |
210 | (goto-char (point-max)) | |
211 | (setq mark (point-marker)) | |
212 | (let ((nnheader-callback-function | |
213 | (gnus-make-async-article-function | |
214 | group article mark summary next)) | |
215 | (nntp-server-buffer | |
216 | (get-buffer gnus-async-prefetch-article-buffer))) | |
217 | (when do-message | |
218 | (gnus-message 9 "Prefetching article %d in group %s" | |
219 | article group)) | |
16409b0b GM |
220 | (setq gnus-async-current-prefetch-group group) |
221 | (setq gnus-async-current-prefetch-article article) | |
eec82323 LMI |
222 | (gnus-request-article article group)))))))))) |
223 | ||
224 | (defun gnus-make-async-article-function (group article mark summary next) | |
225 | "Return a callback function." | |
226 | `(lambda (arg) | |
16409b0b GM |
227 | (gnus-async-article-callback arg ,group ,article ,mark ,summary ,next))) |
228 | ||
16ec6ca4 KY |
229 | (eval-when-compile |
230 | (autoload 'gnus-html-prefetch-images "gnus-html")) | |
231 | ||
16409b0b GM |
232 | (defun gnus-async-article-callback (arg group article mark summary next) |
233 | "Function called when an async article is done being fetched." | |
234 | (save-excursion | |
235 | (setq gnus-async-current-prefetch-article nil) | |
236 | (when arg | |
237 | (gnus-async-set-buffer) | |
724d30be KY |
238 | (save-excursion |
239 | (save-restriction | |
240 | (narrow-to-region mark (point-max)) | |
f3b146e9 LMI |
241 | ;; Put the articles into the agent, if they aren't already. |
242 | (when (and gnus-agent | |
243 | (gnus-agent-group-covered-p group)) | |
244 | (save-restriction | |
245 | (narrow-to-region mark (point-max)) | |
246 | (gnus-agent-store-article article group))) | |
724d30be KY |
247 | ;; Prefetch images for the groups that want that. |
248 | (when (fboundp 'gnus-html-prefetch-images) | |
249 | (gnus-html-prefetch-images summary)) | |
250 | (when gnus-async-post-fetch-function | |
b1992461 | 251 | (funcall gnus-async-post-fetch-function summary)))) |
16409b0b GM |
252 | (gnus-async-with-semaphore |
253 | (setq | |
254 | gnus-async-article-alist | |
255 | (cons (list (intern (format "%s-%d" group article) | |
256 | gnus-async-hashtb) | |
30818a23 | 257 | mark (point-max-marker) |
16409b0b GM |
258 | group article) |
259 | gnus-async-article-alist)))) | |
260 | (if (not (gnus-buffer-live-p summary)) | |
261 | (gnus-async-with-semaphore | |
262 | (setq gnus-async-fetch-list nil)) | |
263 | (gnus-async-prefetch-article group next summary t)))) | |
eec82323 LMI |
264 | |
265 | (defun gnus-async-unread-p (data) | |
266 | "Return non-nil if DATA represents an unread article." | |
267 | (gnus-data-unread-p data)) | |
268 | ||
269 | (defun gnus-async-request-fetched-article (group article buffer) | |
270 | "See whether we have ARTICLE from GROUP and put it in BUFFER." | |
271 | (when (numberp article) | |
16409b0b GM |
272 | (when (and (equal group gnus-async-current-prefetch-group) |
273 | (eq article gnus-async-current-prefetch-article)) | |
274 | (gnus-async-wait-for-article article)) | |
eec82323 LMI |
275 | (let ((entry (gnus-async-prefetched-article-entry group article))) |
276 | (when entry | |
277 | (save-excursion | |
278 | (gnus-async-set-buffer) | |
279 | (copy-to-buffer buffer (cadr entry) (caddr entry)) | |
280 | ;; Remove the read article from the prefetch buffer. | |
281 | (when (memq 'read gnus-prefetched-article-deletion-strategy) | |
16409b0b | 282 | (gnus-async-delete-prefetched-entry entry)) |
eec82323 LMI |
283 | t))))) |
284 | ||
16409b0b GM |
285 | (defun gnus-async-wait-for-article (article) |
286 | "Wait until ARTICLE is no longer the currently-being-fetched article." | |
287 | (save-excursion | |
288 | (gnus-async-set-buffer) | |
289 | (let ((proc (nntp-find-connection (current-buffer))) | |
290 | (nntp-server-buffer (current-buffer)) | |
291 | (nntp-have-messaged nil) | |
292 | (tries 0)) | |
01c52d31 MB |
293 | (when proc |
294 | (condition-case nil | |
295 | ;; FIXME: we could stop waiting after some | |
296 | ;; timeout, but this is the wrong place to do it. | |
297 | ;; rather than checking time-spent-waiting, we | |
298 | ;; should check time-since-last-output, which | |
299 | ;; needs to be done in nntp.el. | |
300 | (while (eq article gnus-async-current-prefetch-article) | |
301 | (incf tries) | |
302 | (when (nntp-accept-process-output proc) | |
303 | (setq tries 0)) | |
304 | (when (and (not nntp-have-messaged) | |
305 | (= tries 3)) | |
306 | (gnus-message 5 "Waiting for async article...") | |
307 | (setq nntp-have-messaged t))) | |
308 | (quit | |
309 | ;; if the user interrupted on a slow/hung connection, | |
310 | ;; do something friendly. | |
311 | (when (> tries 3) | |
312 | (setq gnus-async-current-prefetch-article nil)) | |
313 | (signal 'quit nil))) | |
314 | (when nntp-have-messaged | |
315 | (gnus-message 5 "")))))) | |
16409b0b GM |
316 | |
317 | (defun gnus-async-delete-prefetched-entry (entry) | |
eec82323 LMI |
318 | "Delete ENTRY from buffer and alist." |
319 | (ignore-errors | |
320 | (delete-region (cadr entry) (caddr entry)) | |
321 | (set-marker (cadr entry) nil) | |
322 | (set-marker (caddr entry) nil)) | |
323 | (gnus-async-with-semaphore | |
16409b0b | 324 | (setq gnus-async-article-alist |
a3f57c41 G |
325 | (delq entry gnus-async-article-alist)) |
326 | (unintern (car entry) gnus-async-hashtb))) | |
eec82323 LMI |
327 | |
328 | (defun gnus-async-prefetch-remove-group (group) | |
329 | "Remove all articles belonging to GROUP from the prefetch buffer." | |
330 | (when (and (gnus-group-asynchronous-p group) | |
331 | (memq 'exit gnus-prefetched-article-deletion-strategy)) | |
01c52d31 MB |
332 | (save-excursion |
333 | (gnus-async-set-buffer) | |
334 | (dolist (entry gnus-async-article-alist) | |
335 | (when (equal group (nth 3 entry)) | |
336 | (gnus-async-delete-prefetched-entry entry)))))) | |
eec82323 LMI |
337 | |
338 | (defun gnus-async-prefetched-article-entry (group article) | |
e7f767c2 | 339 | "Return the entry for ARTICLE in GROUP if it has been prefetched." |
6748645f LMI |
340 | (let ((entry (save-excursion |
341 | (gnus-async-set-buffer) | |
a3f57c41 G |
342 | (assq (intern-soft (format "%s-%d" group article) |
343 | gnus-async-hashtb) | |
6748645f | 344 | gnus-async-article-alist)))) |
eec82323 LMI |
345 | ;; Perhaps something has emptied the buffer? |
346 | (if (and entry | |
347 | (= (cadr entry) (caddr entry))) | |
348 | (progn | |
349 | (ignore-errors | |
350 | (set-marker (cadr entry) nil) | |
351 | (set-marker (caddr entry) nil)) | |
352 | (setq gnus-async-article-alist | |
353 | (delq entry gnus-async-article-alist)) | |
354 | nil) | |
355 | entry))) | |
356 | ||
357 | ;;; | |
358 | ;;; Header prefetch | |
359 | ;;; | |
360 | ||
361 | (defun gnus-async-prefetch-headers (group) | |
362 | "Prefetch the headers for group GROUP." | |
363 | (save-excursion | |
364 | (let (unread) | |
365 | (when (and gnus-use-header-prefetch | |
366 | gnus-asynchronous | |
367 | (gnus-group-asynchronous-p group) | |
368 | (listp gnus-async-header-prefetched) | |
369 | (setq unread (gnus-list-of-unread-articles group))) | |
370 | ;; Mark that a fetch is in progress. | |
371 | (setq gnus-async-header-prefetched t) | |
372 | (nnheader-set-temp-buffer gnus-async-prefetch-headers-buffer t) | |
373 | (erase-buffer) | |
374 | (let ((nntp-server-buffer (current-buffer)) | |
375 | (nnheader-callback-function | |
376 | `(lambda (arg) | |
377 | (setq gnus-async-header-prefetched | |
378 | ,(cons group unread))))) | |
379 | (gnus-retrieve-headers unread group gnus-fetch-old-headers)))))) | |
380 | ||
381 | (defun gnus-async-retrieve-fetched-headers (articles group) | |
382 | "See whether we have prefetched headers." | |
383 | (when (and gnus-use-header-prefetch | |
384 | (gnus-group-asynchronous-p group) | |
385 | (listp gnus-async-header-prefetched) | |
386 | (equal group (car gnus-async-header-prefetched)) | |
387 | (equal articles (cdr gnus-async-header-prefetched))) | |
388 | (save-excursion | |
389 | (nnheader-set-temp-buffer gnus-async-prefetch-headers-buffer t) | |
390 | (nntp-decode-text) | |
391 | (copy-to-buffer nntp-server-buffer (point-min) (point-max)) | |
392 | (erase-buffer) | |
393 | (setq gnus-async-header-prefetched nil) | |
394 | t))) | |
395 | ||
396 | (provide 'gnus-async) | |
397 | ||
398 | ;;; gnus-async.el ends here |