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
))
148 (with-current-buffer gnus-summary-buffer
149 (let ((next (caadr (gnus-data-find-list article
))))
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
155 (gnus-async-prefetch-article group next summary
)
156 (when gnus-async-timer
158 (nnheader-cancel-timer 'gnus-async-timer
)))
159 (setq gnus-async-timer
161 0.1 nil
'gnus-async-prefetch-article
162 group next summary
))))))))
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
168 (setq gnus-async-fetch-list nil
))
169 (when (and gnus-asynchronous
172 (gnus-async-with-semaphore
173 (pop gnus-async-fetch-list
)))
174 (let ((do-fetch next
)
175 (do-message t
)) ;(eq major-mode 'gnus-summary-mode)))
176 (when (and (gnus-group-asynchronous-p group
)
177 (gnus-buffer-live-p summary
)
179 gnus-async-fetch-list
))
180 (gnus-async-with-semaphore
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
))
189 (while (and (setq d
(pop data
))
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
))))
203 (setq article
(car gnus-async-fetch-list
))))
205 (when (and do-fetch article
)
206 ;; We want to fetch some more articles.
207 (with-current-buffer summary
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
))
216 (get-buffer gnus-async-prefetch-article-buffer
)))
218 (gnus-message 9 "Prefetching article %d in group %s"
220 (setq gnus-async-current-prefetch-group group
)
221 (setq gnus-async-current-prefetch-article article
)
222 (gnus-request-article article group
))))))))))
224 (defun gnus-make-async-article-function (group article mark summary next
)
225 "Return a callback function."
227 (gnus-async-article-callback arg
,group
,article
,mark
,summary
,next
)))
230 (autoload 'gnus-html-prefetch-images
"gnus-html"))
232 (defun gnus-async-article-callback (arg group article mark summary next
)
233 "Function called when an async article is done being fetched."
235 (setq gnus-async-current-prefetch-article nil
)
237 (gnus-async-set-buffer)
240 (narrow-to-region mark
(point-max))
241 ;; Prefetch images for the groups that want that.
242 (when (fboundp 'gnus-html-prefetch-images
)
243 (gnus-html-prefetch-images summary
))
244 (when gnus-async-post-fetch-function
245 (funcall gnus-async-post-fetch-function summary
))))
246 (gnus-async-with-semaphore
248 gnus-async-article-alist
249 (cons (list (intern (format "%s-%d" group article
)
251 mark
(set-marker (make-marker) (point-max))
253 gnus-async-article-alist
))))
254 (if (not (gnus-buffer-live-p summary
))
255 (gnus-async-with-semaphore
256 (setq gnus-async-fetch-list nil
))
257 (gnus-async-prefetch-article group next summary t
))))
259 (defun gnus-async-unread-p (data)
260 "Return non-nil if DATA represents an unread article."
261 (gnus-data-unread-p data
))
263 (defun gnus-async-request-fetched-article (group article buffer
)
264 "See whether we have ARTICLE from GROUP and put it in BUFFER."
265 (when (numberp article
)
266 (when (and (equal group gnus-async-current-prefetch-group
)
267 (eq article gnus-async-current-prefetch-article
))
268 (gnus-async-wait-for-article article
))
269 (let ((entry (gnus-async-prefetched-article-entry group article
)))
272 (gnus-async-set-buffer)
273 (copy-to-buffer buffer
(cadr entry
) (caddr entry
))
274 ;; Remove the read article from the prefetch buffer.
275 (when (memq 'read gnus-prefetched-article-deletion-strategy
)
276 (gnus-async-delete-prefetched-entry entry
))
279 (defun gnus-async-wait-for-article (article)
280 "Wait until ARTICLE is no longer the currently-being-fetched article."
282 (gnus-async-set-buffer)
283 (let ((proc (nntp-find-connection (current-buffer)))
284 (nntp-server-buffer (current-buffer))
285 (nntp-have-messaged nil
)
289 ;; FIXME: we could stop waiting after some
290 ;; timeout, but this is the wrong place to do it.
291 ;; rather than checking time-spent-waiting, we
292 ;; should check time-since-last-output, which
293 ;; needs to be done in nntp.el.
294 (while (eq article gnus-async-current-prefetch-article
)
296 (when (nntp-accept-process-output proc
)
298 (when (and (not nntp-have-messaged
)
300 (gnus-message 5 "Waiting for async article...")
301 (setq nntp-have-messaged t
)))
303 ;; if the user interrupted on a slow/hung connection,
304 ;; do something friendly.
306 (setq gnus-async-current-prefetch-article nil
))
308 (when nntp-have-messaged
309 (gnus-message 5 ""))))))
311 (defun gnus-async-delete-prefetched-entry (entry)
312 "Delete ENTRY from buffer and alist."
314 (delete-region (cadr entry
) (caddr entry
))
315 (set-marker (cadr entry
) nil
)
316 (set-marker (caddr entry
) nil
))
317 (gnus-async-with-semaphore
318 (setq gnus-async-article-alist
319 (delq entry gnus-async-article-alist
))
320 (unintern (car entry
) gnus-async-hashtb
)))
322 (defun gnus-async-prefetch-remove-group (group)
323 "Remove all articles belonging to GROUP from the prefetch buffer."
324 (when (and (gnus-group-asynchronous-p group
)
325 (memq 'exit gnus-prefetched-article-deletion-strategy
))
327 (gnus-async-set-buffer)
328 (dolist (entry gnus-async-article-alist
)
329 (when (equal group
(nth 3 entry
))
330 (gnus-async-delete-prefetched-entry entry
))))))
332 (defun gnus-async-prefetched-article-entry (group article
)
333 "Return the entry for ARTICLE in GROUP if it has been prefetched."
334 (let ((entry (save-excursion
335 (gnus-async-set-buffer)
336 (assq (intern-soft (format "%s-%d" group article
)
338 gnus-async-article-alist
))))
339 ;; Perhaps something has emptied the buffer?
341 (= (cadr entry
) (caddr entry
)))
344 (set-marker (cadr entry
) nil
)
345 (set-marker (caddr entry
) nil
))
346 (setq gnus-async-article-alist
347 (delq entry gnus-async-article-alist
))
355 (defun gnus-async-prefetch-headers (group)
356 "Prefetch the headers for group GROUP."
359 (when (and gnus-use-header-prefetch
361 (gnus-group-asynchronous-p group
)
362 (listp gnus-async-header-prefetched
)
363 (setq unread
(gnus-list-of-unread-articles group
)))
364 ;; Mark that a fetch is in progress.
365 (setq gnus-async-header-prefetched t
)
366 (nnheader-set-temp-buffer gnus-async-prefetch-headers-buffer t
)
368 (let ((nntp-server-buffer (current-buffer))
369 (nnheader-callback-function
371 (setq gnus-async-header-prefetched
372 ,(cons group unread
)))))
373 (gnus-retrieve-headers unread group gnus-fetch-old-headers
))))))
375 (defun gnus-async-retrieve-fetched-headers (articles group
)
376 "See whether we have prefetched headers."
377 (when (and gnus-use-header-prefetch
378 (gnus-group-asynchronous-p group
)
379 (listp gnus-async-header-prefetched
)
380 (equal group
(car gnus-async-header-prefetched
))
381 (equal articles
(cdr gnus-async-header-prefetched
)))
383 (nnheader-set-temp-buffer gnus-async-prefetch-headers-buffer t
)
385 (copy-to-buffer nntp-server-buffer
(point-min) (point-max))
387 (setq gnus-async-header-prefetched nil
)
390 (provide 'gnus-async
)
392 ;;; gnus-async.el ends here