1 ;;; gnus-async.el --- asynchronous support for Gnus
2 ;; Copyright (C) 1996,97,98 Free Software Foundation, Inc.
4 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
7 ;; This file is part of GNU Emacs.
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)
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.
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.
28 (eval-when-compile (require 'cl
))
30 (eval-when-compile (require 'cl
))
36 (defgroup gnus-asynchronous nil
37 "Support for asynchronous operations."
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
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
)
52 (integer :tag
"some" 0)
53 (other :tag
"all" t
)))
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
61 :group
'gnus-asynchronous
62 :type
'(set (const read
) (const exit
)))
64 (defcustom gnus-use-header-prefetch nil
65 "*If non-nil, prefetch the headers to the next group."
66 :group
'gnus-asynchronous
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
76 ;;; Internal variables.
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
)
82 (defvar gnus-asynch-obarray nil
)
84 (defvar gnus-async-prefetch-headers-buffer
" *Async Prefetch Headers*")
85 (defvar gnus-async-header-prefetched nil
)
87 ;;; Utility functions.
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
)))
93 ;;; Somewhat bogus semaphores.
95 (defun gnus-async-get-semaphore (semaphore)
96 "Wait until SEMAPHORE is released."
97 (while (/= (length (nconc (symbol-value semaphore
) (list nil
))) 2)
100 (defun gnus-async-release-semaphore (semaphore)
102 (setcdr (symbol-value semaphore
) nil
))
104 (defmacro gnus-async-with-semaphore
(&rest forms
)
107 (gnus-async-get-semaphore 'gnus-async-article-semaphore
)
109 (gnus-async-release-semaphore 'gnus-async-article-semaphore
)))
111 (put 'gnus-asynch-with-semaphore
'lisp-indent-function
0)
112 (put 'gnus-asynch-with-semaphore
'edebug-form-spec
'(body))
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
))
125 (defun gnus-async-set-buffer ()
126 (nnheader-set-temp-buffer gnus-async-prefetch-article-buffer t
)
127 (unless gnus-asynch-obarray
128 (set (make-local-variable 'gnus-asynch-obarray
)
129 (gnus-make-hashtable 1023))))
131 (defun gnus-async-halt-prefetch ()
133 (setq gnus-async-fetch-list nil
))
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
)
139 (gnus-group-asynchronous-p group
))
141 (set-buffer gnus-summary-buffer
)
142 (let ((next (caadr (gnus-data-find-list article
))))
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
148 (gnus-async-prefetch-article group next summary
)
150 0.1 nil
'gnus-async-prefetch-article group next summary
)))))))
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
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
)
167 gnus-async-fetch-list
))
168 (gnus-async-with-semaphore
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
))
177 (while (and (setq d
(pop data
))
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
))))
191 (setq article
(car gnus-async-fetch-list
))))
193 (when (and do-fetch article
)
194 ;; We want to fetch some more articles.
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
))
205 (get-buffer gnus-async-prefetch-article-buffer
)))
207 (gnus-message 9 "Prefetching article %d in group %s"
209 (gnus-request-article article group
))))))))))
211 (defun gnus-make-async-article-function (group article mark summary next
)
212 "Return a callback function."
216 (gnus-async-set-buffer)
217 (gnus-async-with-semaphore
219 gnus-async-article-alist
220 (cons (list ',(intern (format "%s-%d" group article
)
222 ,mark
(set-marker (make-marker) (point-max))
224 gnus-async-article-alist
))))
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
)))))
230 (defun gnus-async-unread-p (data)
231 "Return non-nil if DATA represents an unread article."
232 (gnus-data-unread-p data
))
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
)))
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
))
247 (defun gnus-async-delete-prefected-entry (entry)
248 "Delete ENTRY from buffer and alist."
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
))))
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
))
263 (gnus-async-set-buffer)
265 (when (equal group
(nth 3 (car alist
)))
266 (gnus-async-delete-prefected-entry (car alist
)))
269 (defun gnus-async-prefetched-article-entry (group article
)
270 "Return the entry for ARTICLE in GROUP iff it has been prefetched."
271 (let ((entry (save-excursion
272 (gnus-async-set-buffer)
273 (assq (intern (format "%s-%d" group article
)
275 gnus-async-article-alist
))))
276 ;; Perhaps something has emptied the buffer?
278 (= (cadr entry
) (caddr entry
)))
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
))
292 (defun gnus-async-prefetch-headers (group)
293 "Prefetch the headers for group GROUP."
296 (when (and gnus-use-header-prefetch
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
)
305 (let ((nntp-server-buffer (current-buffer))
306 (nnheader-callback-function
308 (setq gnus-async-header-prefetched
309 ,(cons group unread
)))))
310 (gnus-retrieve-headers unread group gnus-fetch-old-headers
))))))
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
)))
320 (nnheader-set-temp-buffer gnus-async-prefetch-headers-buffer t
)
322 (copy-to-buffer nntp-server-buffer
(point-min) (point-max))
324 (setq gnus-async-header-prefetched nil
)
327 (provide 'gnus-async
)
329 ;;; gnus-async.el ends here