1 ;;; gnus-async.el --- asynchronous support for Gnus
3 ;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
4 ;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
6 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
9 ;; This file is part of GNU Emacs.
11 ;; GNU Emacs is free software: you can redistribute it and/or modify
12 ;; it under the terms of the GNU General Public License as published by
13 ;; the Free Software Foundation, either version 3 of the License, or
14 ;; (at your option) any later version.
16 ;; GNU Emacs is distributed in the hope that it will be useful,
17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19 ;; GNU General Public License for more details.
21 ;; You should have received a copy of the GNU General Public License
22 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
28 (eval-when-compile (require 'cl
))
34 (defgroup gnus-asynchronous nil
35 "Support for asynchronous operations."
38 (defcustom gnus-use-article-prefetch
30
39 "*If non-nil, prefetch articles in groups that allow this.
40 If a number, prefetch only that many articles forward;
41 if t, prefetch as many articles as possible."
42 :group
'gnus-asynchronous
43 :type
'(choice (const :tag
"off" nil
)
45 (integer :tag
"some" 0)))
47 (defcustom gnus-asynchronous nil
48 "*If nil, inhibit all Gnus asynchronicity.
49 If non-nil, let the other asynch variables be heeded."
50 :group
'gnus-asynchronous
53 (defcustom gnus-prefetched-article-deletion-strategy
'(read exit
)
54 "List of symbols that say when to remove articles from the prefetch buffer.
55 Possible values in this list are `read', which means that
56 articles are removed as they are read, and `exit', which means
57 that all articles belonging to a group are removed on exit
59 :group
'gnus-asynchronous
60 :type
'(set (const read
) (const exit
)))
62 (defcustom gnus-use-header-prefetch nil
63 "*If non-nil, prefetch the headers to the next group."
64 :group
'gnus-asynchronous
67 (defcustom gnus-async-prefetch-article-p
'gnus-async-unread-p
68 "Function called to say whether an article should be prefetched or not.
69 The function is called with one parameter -- the article data.
70 It should return non-nil if the article is to be prefetched."
71 :group
'gnus-asynchronous
74 (defcustom gnus-async-post-fetch-function nil
75 "Function called after an article has been prefetched.
76 The function will be called narrowed to the region of the article
78 :group
'gnus-asynchronous
81 ;;; Internal variables.
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
)
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
)
92 (defvar gnus-async-prefetch-headers-buffer
" *Async Prefetch Headers*")
93 (defvar gnus-async-header-prefetched nil
)
95 ;;; Utility functions.
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
)))
101 ;;; Somewhat bogus semaphores.
103 (defun gnus-async-get-semaphore (semaphore)
104 "Wait until SEMAPHORE is released."
105 (while (/= (length (nconc (symbol-value semaphore
) (list nil
))) 2)
108 (defun gnus-async-release-semaphore (semaphore)
110 (setcdr (symbol-value semaphore
) nil
))
112 (defmacro gnus-async-with-semaphore
(&rest forms
)
115 (gnus-async-get-semaphore 'gnus-async-article-semaphore
)
117 (gnus-async-release-semaphore 'gnus-async-article-semaphore
)))
119 (put 'gnus-async-with-semaphore
'lisp-indent-function
0)
120 (put 'gnus-async-with-semaphore
'edebug-form-spec
'(body))
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
)
130 (setq gnus-async-hashtb nil
131 gnus-async-article-alist nil
132 gnus-async-header-prefetched nil
))
134 (defun gnus-async-set-buffer ()
135 (nnheader-set-temp-buffer gnus-async-prefetch-article-buffer t
)
136 (unless gnus-async-hashtb
137 (setq gnus-async-hashtb
(gnus-make-hashtable 1023))))
139 (defun gnus-async-halt-prefetch ()
141 (setq gnus-async-fetch-list nil
))
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
)
147 (gnus-group-asynchronous-p group
))
149 (set-buffer gnus-summary-buffer
)
150 (let ((next (caadr (gnus-data-find-list article
))))
152 (if (not (fboundp 'run-with-idle-timer
))
153 ;; This is either an older Emacs or XEmacs, so we
154 ;; do this, which leads to slightly slower article
156 (gnus-async-prefetch-article group next summary
)
157 (when gnus-async-timer
159 (nnheader-cancel-timer 'gnus-async-timer
)))
160 (setq gnus-async-timer
162 0.1 nil
'gnus-async-prefetch-article
163 group next summary
))))))))
165 (defun gnus-async-prefetch-article (group article summary
&optional next
)
166 "Possibly prefetch several articles starting with ARTICLE."
167 (if (not (gnus-buffer-live-p summary
))
168 (gnus-async-with-semaphore
169 (setq gnus-async-fetch-list nil
))
170 (when (and gnus-asynchronous
173 (gnus-async-with-semaphore
174 (pop gnus-async-fetch-list
)))
175 (let ((do-fetch next
)
176 (do-message t
)) ;(eq major-mode 'gnus-summary-mode)))
177 (when (and (gnus-group-asynchronous-p group
)
178 (gnus-buffer-live-p summary
)
180 gnus-async-fetch-list
))
181 (gnus-async-with-semaphore
183 (setq do-fetch
(not gnus-async-fetch-list
))
184 ;; Nix out any outstanding requests.
185 (setq gnus-async-fetch-list nil
)
186 ;; Fill in the new list.
187 (let ((n gnus-use-article-prefetch
)
188 (data (gnus-data-find-list article
))
190 (while (and (setq d
(pop data
))
194 (unless (or (gnus-async-prefetched-article-entry
195 group
(setq article
(gnus-data-number d
)))
196 (not (natnump article
))
197 (not (funcall gnus-async-prefetch-article-p d
)))
198 ;; Not already fetched -- so we add it to the list.
199 (push article gnus-async-fetch-list
)))
200 (setq gnus-async-fetch-list
201 (nreverse gnus-async-fetch-list
))))
204 (setq article
(car gnus-async-fetch-list
))))
206 (when (and do-fetch article
)
207 ;; We want to fetch some more articles.
211 (gnus-async-set-buffer)
212 (goto-char (point-max))
213 (setq mark
(point-marker))
214 (let ((nnheader-callback-function
215 (gnus-make-async-article-function
216 group article mark summary next
))
218 (get-buffer gnus-async-prefetch-article-buffer
)))
220 (gnus-message 9 "Prefetching article %d in group %s"
222 (setq gnus-async-current-prefetch-group group
)
223 (setq gnus-async-current-prefetch-article article
)
224 (gnus-request-article article group
))))))))))
226 (defun gnus-make-async-article-function (group article mark summary next
)
227 "Return a callback function."
229 (gnus-async-article-callback arg
,group
,article
,mark
,summary
,next
)))
231 (defun gnus-async-article-callback (arg group article mark summary next
)
232 "Function called when an async article is done being fetched."
234 (setq gnus-async-current-prefetch-article nil
)
236 (gnus-async-set-buffer)
237 (when gnus-async-post-fetch-function
240 (narrow-to-region mark
(point-max))
241 (funcall gnus-async-post-fetch-function summary
))))
242 (gnus-async-with-semaphore
244 gnus-async-article-alist
245 (cons (list (intern (format "%s-%d" group article
)
247 mark
(set-marker (make-marker) (point-max))
249 gnus-async-article-alist
))))
250 (if (not (gnus-buffer-live-p summary
))
251 (gnus-async-with-semaphore
252 (setq gnus-async-fetch-list nil
))
253 (gnus-async-prefetch-article group next summary t
))))
255 (defun gnus-async-unread-p (data)
256 "Return non-nil if DATA represents an unread article."
257 (gnus-data-unread-p data
))
259 (defun gnus-async-request-fetched-article (group article buffer
)
260 "See whether we have ARTICLE from GROUP and put it in BUFFER."
261 (when (numberp article
)
262 (when (and (equal group gnus-async-current-prefetch-group
)
263 (eq article gnus-async-current-prefetch-article
))
264 (gnus-async-wait-for-article article
))
265 (let ((entry (gnus-async-prefetched-article-entry group article
)))
268 (gnus-async-set-buffer)
269 (copy-to-buffer buffer
(cadr entry
) (caddr entry
))
270 ;; Remove the read article from the prefetch buffer.
271 (when (memq 'read gnus-prefetched-article-deletion-strategy
)
272 (gnus-async-delete-prefetched-entry entry
))
275 (defun gnus-async-wait-for-article (article)
276 "Wait until ARTICLE is no longer the currently-being-fetched article."
278 (gnus-async-set-buffer)
279 (let ((proc (nntp-find-connection (current-buffer)))
280 (nntp-server-buffer (current-buffer))
281 (nntp-have-messaged nil
)
285 ;; FIXME: we could stop waiting after some
286 ;; timeout, but this is the wrong place to do it.
287 ;; rather than checking time-spent-waiting, we
288 ;; should check time-since-last-output, which
289 ;; needs to be done in nntp.el.
290 (while (eq article gnus-async-current-prefetch-article
)
292 (when (nntp-accept-process-output proc
)
294 (when (and (not nntp-have-messaged
)
296 (gnus-message 5 "Waiting for async article...")
297 (setq nntp-have-messaged t
)))
299 ;; if the user interrupted on a slow/hung connection,
300 ;; do something friendly.
302 (setq gnus-async-current-prefetch-article nil
))
304 (when nntp-have-messaged
305 (gnus-message 5 ""))))))
307 (defun gnus-async-delete-prefetched-entry (entry)
308 "Delete ENTRY from buffer and alist."
310 (delete-region (cadr entry
) (caddr entry
))
311 (set-marker (cadr entry
) nil
)
312 (set-marker (caddr entry
) nil
))
313 (gnus-async-with-semaphore
314 (setq gnus-async-article-alist
315 (delq entry gnus-async-article-alist
))))
317 (defun gnus-async-prefetch-remove-group (group)
318 "Remove all articles belonging to GROUP from the prefetch buffer."
319 (when (and (gnus-group-asynchronous-p group
)
320 (memq 'exit gnus-prefetched-article-deletion-strategy
))
322 (gnus-async-set-buffer)
323 (dolist (entry gnus-async-article-alist
)
324 (when (equal group
(nth 3 entry
))
325 (gnus-async-delete-prefetched-entry entry
))))))
327 (defun gnus-async-prefetched-article-entry (group article
)
328 "Return the entry for ARTICLE in GROUP if it has been prefetched."
329 (let ((entry (save-excursion
330 (gnus-async-set-buffer)
331 (assq (intern (format "%s-%d" group article
)
333 gnus-async-article-alist
))))
334 ;; Perhaps something has emptied the buffer?
336 (= (cadr entry
) (caddr entry
)))
339 (set-marker (cadr entry
) nil
)
340 (set-marker (caddr entry
) nil
))
341 (setq gnus-async-article-alist
342 (delq entry gnus-async-article-alist
))
350 (defun gnus-async-prefetch-headers (group)
351 "Prefetch the headers for group GROUP."
354 (when (and gnus-use-header-prefetch
356 (gnus-group-asynchronous-p group
)
357 (listp gnus-async-header-prefetched
)
358 (setq unread
(gnus-list-of-unread-articles group
)))
359 ;; Mark that a fetch is in progress.
360 (setq gnus-async-header-prefetched t
)
361 (nnheader-set-temp-buffer gnus-async-prefetch-headers-buffer t
)
363 (let ((nntp-server-buffer (current-buffer))
364 (nnheader-callback-function
366 (setq gnus-async-header-prefetched
367 ,(cons group unread
)))))
368 (gnus-retrieve-headers unread group gnus-fetch-old-headers
))))))
370 (defun gnus-async-retrieve-fetched-headers (articles group
)
371 "See whether we have prefetched headers."
372 (when (and gnus-use-header-prefetch
373 (gnus-group-asynchronous-p group
)
374 (listp gnus-async-header-prefetched
)
375 (equal group
(car gnus-async-header-prefetched
))
376 (equal articles
(cdr gnus-async-header-prefetched
)))
378 (nnheader-set-temp-buffer gnus-async-prefetch-headers-buffer t
)
380 (copy-to-buffer nntp-server-buffer
(point-min) (point-max))
382 (setq gnus-async-header-prefetched nil
)
385 (provide 'gnus-async
)
387 ;; arch-tag: fee61de5-3ea2-4de6-8578-2f90ce89391d
388 ;;; gnus-async.el ends here