| 1 | ;;; gnus-async.el --- asynchronous support for Gnus |
| 2 | |
| 3 | ;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, |
| 4 | ;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. |
| 5 | |
| 6 | ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> |
| 7 | ;; Keywords: news |
| 8 | |
| 9 | ;; This file is part of GNU Emacs. |
| 10 | |
| 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. |
| 15 | |
| 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. |
| 20 | |
| 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/>. |
| 23 | |
| 24 | ;;; Commentary: |
| 25 | |
| 26 | ;;; Code: |
| 27 | |
| 28 | (eval-when-compile (require 'cl)) |
| 29 | |
| 30 | (require 'gnus) |
| 31 | (require 'gnus-sum) |
| 32 | (require 'nntp) |
| 33 | |
| 34 | (defgroup gnus-asynchronous nil |
| 35 | "Support for asynchronous operations." |
| 36 | :group 'gnus) |
| 37 | |
| 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) |
| 44 | (const :tag "all" t) |
| 45 | (integer :tag "some" 0))) |
| 46 | |
| 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 |
| 51 | :type 'boolean) |
| 52 | |
| 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 |
| 58 | from that group." |
| 59 | :group 'gnus-asynchronous |
| 60 | :type '(set (const read) (const exit))) |
| 61 | |
| 62 | (defcustom gnus-use-header-prefetch nil |
| 63 | "*If non-nil, prefetch the headers to the next group." |
| 64 | :group 'gnus-asynchronous |
| 65 | :type 'boolean) |
| 66 | |
| 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 |
| 72 | :type 'function) |
| 73 | |
| 74 | ;;; Internal variables. |
| 75 | |
| 76 | (defvar gnus-async-prefetch-article-buffer " *Async Prefetch Article*") |
| 77 | (defvar gnus-async-article-alist nil) |
| 78 | (defvar gnus-async-article-semaphore '(nil)) |
| 79 | (defvar gnus-async-fetch-list nil) |
| 80 | (defvar gnus-async-hashtb nil) |
| 81 | (defvar gnus-async-current-prefetch-group nil) |
| 82 | (defvar gnus-async-current-prefetch-article nil) |
| 83 | (defvar gnus-async-timer nil) |
| 84 | |
| 85 | (defvar gnus-async-prefetch-headers-buffer " *Async Prefetch Headers*") |
| 86 | (defvar gnus-async-header-prefetched nil) |
| 87 | |
| 88 | ;;; Utility functions. |
| 89 | |
| 90 | (defun gnus-group-asynchronous-p (group) |
| 91 | "Say whether GROUP is fetched from a server that supports asynchronicity." |
| 92 | (gnus-asynchronous-p (gnus-find-method-for-group group))) |
| 93 | |
| 94 | ;;; Somewhat bogus semaphores. |
| 95 | |
| 96 | (defun gnus-async-get-semaphore (semaphore) |
| 97 | "Wait until SEMAPHORE is released." |
| 98 | (while (/= (length (nconc (symbol-value semaphore) (list nil))) 2) |
| 99 | (sleep-for 1))) |
| 100 | |
| 101 | (defun gnus-async-release-semaphore (semaphore) |
| 102 | "Release SEMAPHORE." |
| 103 | (setcdr (symbol-value semaphore) nil)) |
| 104 | |
| 105 | (defmacro gnus-async-with-semaphore (&rest forms) |
| 106 | `(unwind-protect |
| 107 | (progn |
| 108 | (gnus-async-get-semaphore 'gnus-async-article-semaphore) |
| 109 | ,@forms) |
| 110 | (gnus-async-release-semaphore 'gnus-async-article-semaphore))) |
| 111 | |
| 112 | (put 'gnus-async-with-semaphore 'lisp-indent-function 0) |
| 113 | (put 'gnus-async-with-semaphore 'edebug-form-spec '(body)) |
| 114 | |
| 115 | ;;; |
| 116 | ;;; Article prefetch |
| 117 | ;;; |
| 118 | |
| 119 | (gnus-add-shutdown 'gnus-async-close 'gnus) |
| 120 | (defun gnus-async-close () |
| 121 | (gnus-kill-buffer gnus-async-prefetch-article-buffer) |
| 122 | (gnus-kill-buffer gnus-async-prefetch-headers-buffer) |
| 123 | (setq gnus-async-hashtb nil |
| 124 | gnus-async-article-alist nil |
| 125 | gnus-async-header-prefetched nil)) |
| 126 | |
| 127 | (defun gnus-async-set-buffer () |
| 128 | (nnheader-set-temp-buffer gnus-async-prefetch-article-buffer t) |
| 129 | (unless gnus-async-hashtb |
| 130 | (setq gnus-async-hashtb (gnus-make-hashtable 1023)))) |
| 131 | |
| 132 | (defun gnus-async-halt-prefetch () |
| 133 | "Stop prefetching." |
| 134 | (setq gnus-async-fetch-list nil)) |
| 135 | |
| 136 | (defun gnus-async-prefetch-next (group article summary) |
| 137 | "Possibly prefetch several articles starting with the article after ARTICLE." |
| 138 | (when (and (gnus-buffer-live-p summary) |
| 139 | gnus-asynchronous |
| 140 | (gnus-group-asynchronous-p group)) |
| 141 | (save-excursion |
| 142 | (set-buffer gnus-summary-buffer) |
| 143 | (let ((next (caadr (gnus-data-find-list article)))) |
| 144 | (when next |
| 145 | (if (not (fboundp 'run-with-idle-timer)) |
| 146 | ;; This is either an older Emacs or XEmacs, so we |
| 147 | ;; do this, which leads to slightly slower article |
| 148 | ;; buffer display. |
| 149 | (gnus-async-prefetch-article group next summary) |
| 150 | (when gnus-async-timer |
| 151 | (ignore-errors |
| 152 | (nnheader-cancel-timer 'gnus-async-timer))) |
| 153 | (setq gnus-async-timer |
| 154 | (run-with-idle-timer |
| 155 | 0.1 nil 'gnus-async-prefetch-article |
| 156 | group next summary)))))))) |
| 157 | |
| 158 | (defun gnus-async-prefetch-article (group article summary &optional next) |
| 159 | "Possibly prefetch several articles starting with ARTICLE." |
| 160 | (if (not (gnus-buffer-live-p summary)) |
| 161 | (gnus-async-with-semaphore |
| 162 | (setq gnus-async-fetch-list nil)) |
| 163 | (when (and gnus-asynchronous |
| 164 | (gnus-alive-p)) |
| 165 | (when next |
| 166 | (gnus-async-with-semaphore |
| 167 | (pop gnus-async-fetch-list))) |
| 168 | (let ((do-fetch next) |
| 169 | (do-message t)) ;(eq major-mode 'gnus-summary-mode))) |
| 170 | (when (and (gnus-group-asynchronous-p group) |
| 171 | (gnus-buffer-live-p summary) |
| 172 | (or (not next) |
| 173 | gnus-async-fetch-list)) |
| 174 | (gnus-async-with-semaphore |
| 175 | (unless next |
| 176 | (setq do-fetch (not gnus-async-fetch-list)) |
| 177 | ;; Nix out any outstanding requests. |
| 178 | (setq gnus-async-fetch-list nil) |
| 179 | ;; Fill in the new list. |
| 180 | (let ((n gnus-use-article-prefetch) |
| 181 | (data (gnus-data-find-list article)) |
| 182 | d) |
| 183 | (while (and (setq d (pop data)) |
| 184 | (if (numberp n) |
| 185 | (natnump (decf n)) |
| 186 | n)) |
| 187 | (unless (or (gnus-async-prefetched-article-entry |
| 188 | group (setq article (gnus-data-number d))) |
| 189 | (not (natnump article)) |
| 190 | (not (funcall gnus-async-prefetch-article-p d))) |
| 191 | ;; Not already fetched -- so we add it to the list. |
| 192 | (push article gnus-async-fetch-list))) |
| 193 | (setq gnus-async-fetch-list |
| 194 | (nreverse gnus-async-fetch-list)))) |
| 195 | |
| 196 | (when do-fetch |
| 197 | (setq article (car gnus-async-fetch-list)))) |
| 198 | |
| 199 | (when (and do-fetch article) |
| 200 | ;; We want to fetch some more articles. |
| 201 | (save-excursion |
| 202 | (set-buffer summary) |
| 203 | (let (mark) |
| 204 | (gnus-async-set-buffer) |
| 205 | (goto-char (point-max)) |
| 206 | (setq mark (point-marker)) |
| 207 | (let ((nnheader-callback-function |
| 208 | (gnus-make-async-article-function |
| 209 | group article mark summary next)) |
| 210 | (nntp-server-buffer |
| 211 | (get-buffer gnus-async-prefetch-article-buffer))) |
| 212 | (when do-message |
| 213 | (gnus-message 9 "Prefetching article %d in group %s" |
| 214 | article group)) |
| 215 | (setq gnus-async-current-prefetch-group group) |
| 216 | (setq gnus-async-current-prefetch-article article) |
| 217 | (gnus-request-article article group)))))))))) |
| 218 | |
| 219 | (defun gnus-make-async-article-function (group article mark summary next) |
| 220 | "Return a callback function." |
| 221 | `(lambda (arg) |
| 222 | (gnus-async-article-callback arg ,group ,article ,mark ,summary ,next))) |
| 223 | |
| 224 | (defun gnus-async-article-callback (arg group article mark summary next) |
| 225 | "Function called when an async article is done being fetched." |
| 226 | (save-excursion |
| 227 | (setq gnus-async-current-prefetch-article nil) |
| 228 | (when arg |
| 229 | (gnus-async-set-buffer) |
| 230 | (gnus-async-with-semaphore |
| 231 | (setq |
| 232 | gnus-async-article-alist |
| 233 | (cons (list (intern (format "%s-%d" group article) |
| 234 | gnus-async-hashtb) |
| 235 | mark (set-marker (make-marker) (point-max)) |
| 236 | group article) |
| 237 | gnus-async-article-alist)))) |
| 238 | (if (not (gnus-buffer-live-p summary)) |
| 239 | (gnus-async-with-semaphore |
| 240 | (setq gnus-async-fetch-list nil)) |
| 241 | (gnus-async-prefetch-article group next summary t)))) |
| 242 | |
| 243 | (defun gnus-async-unread-p (data) |
| 244 | "Return non-nil if DATA represents an unread article." |
| 245 | (gnus-data-unread-p data)) |
| 246 | |
| 247 | (defun gnus-async-request-fetched-article (group article buffer) |
| 248 | "See whether we have ARTICLE from GROUP and put it in BUFFER." |
| 249 | (when (numberp article) |
| 250 | (when (and (equal group gnus-async-current-prefetch-group) |
| 251 | (eq article gnus-async-current-prefetch-article)) |
| 252 | (gnus-async-wait-for-article article)) |
| 253 | (let ((entry (gnus-async-prefetched-article-entry group article))) |
| 254 | (when entry |
| 255 | (save-excursion |
| 256 | (gnus-async-set-buffer) |
| 257 | (copy-to-buffer buffer (cadr entry) (caddr entry)) |
| 258 | ;; Remove the read article from the prefetch buffer. |
| 259 | (when (memq 'read gnus-prefetched-article-deletion-strategy) |
| 260 | (gnus-async-delete-prefetched-entry entry)) |
| 261 | t))))) |
| 262 | |
| 263 | (defun gnus-async-wait-for-article (article) |
| 264 | "Wait until ARTICLE is no longer the currently-being-fetched article." |
| 265 | (save-excursion |
| 266 | (gnus-async-set-buffer) |
| 267 | (let ((proc (nntp-find-connection (current-buffer))) |
| 268 | (nntp-server-buffer (current-buffer)) |
| 269 | (nntp-have-messaged nil) |
| 270 | (tries 0)) |
| 271 | (when proc |
| 272 | (condition-case nil |
| 273 | ;; FIXME: we could stop waiting after some |
| 274 | ;; timeout, but this is the wrong place to do it. |
| 275 | ;; rather than checking time-spent-waiting, we |
| 276 | ;; should check time-since-last-output, which |
| 277 | ;; needs to be done in nntp.el. |
| 278 | (while (eq article gnus-async-current-prefetch-article) |
| 279 | (incf tries) |
| 280 | (when (nntp-accept-process-output proc) |
| 281 | (setq tries 0)) |
| 282 | (when (and (not nntp-have-messaged) |
| 283 | (= tries 3)) |
| 284 | (gnus-message 5 "Waiting for async article...") |
| 285 | (setq nntp-have-messaged t))) |
| 286 | (quit |
| 287 | ;; if the user interrupted on a slow/hung connection, |
| 288 | ;; do something friendly. |
| 289 | (when (> tries 3) |
| 290 | (setq gnus-async-current-prefetch-article nil)) |
| 291 | (signal 'quit nil))) |
| 292 | (when nntp-have-messaged |
| 293 | (gnus-message 5 "")))))) |
| 294 | |
| 295 | (defun gnus-async-delete-prefetched-entry (entry) |
| 296 | "Delete ENTRY from buffer and alist." |
| 297 | (ignore-errors |
| 298 | (delete-region (cadr entry) (caddr entry)) |
| 299 | (set-marker (cadr entry) nil) |
| 300 | (set-marker (caddr entry) nil)) |
| 301 | (gnus-async-with-semaphore |
| 302 | (setq gnus-async-article-alist |
| 303 | (delq entry gnus-async-article-alist)))) |
| 304 | |
| 305 | (defun gnus-async-prefetch-remove-group (group) |
| 306 | "Remove all articles belonging to GROUP from the prefetch buffer." |
| 307 | (when (and (gnus-group-asynchronous-p group) |
| 308 | (memq 'exit gnus-prefetched-article-deletion-strategy)) |
| 309 | (save-excursion |
| 310 | (gnus-async-set-buffer) |
| 311 | (dolist (entry gnus-async-article-alist) |
| 312 | (when (equal group (nth 3 entry)) |
| 313 | (gnus-async-delete-prefetched-entry entry)))))) |
| 314 | |
| 315 | (defun gnus-async-prefetched-article-entry (group article) |
| 316 | "Return the entry for ARTICLE in GROUP if it has been prefetched." |
| 317 | (let ((entry (save-excursion |
| 318 | (gnus-async-set-buffer) |
| 319 | (assq (intern (format "%s-%d" group article) |
| 320 | gnus-async-hashtb) |
| 321 | gnus-async-article-alist)))) |
| 322 | ;; Perhaps something has emptied the buffer? |
| 323 | (if (and entry |
| 324 | (= (cadr entry) (caddr entry))) |
| 325 | (progn |
| 326 | (ignore-errors |
| 327 | (set-marker (cadr entry) nil) |
| 328 | (set-marker (caddr entry) nil)) |
| 329 | (setq gnus-async-article-alist |
| 330 | (delq entry gnus-async-article-alist)) |
| 331 | nil) |
| 332 | entry))) |
| 333 | |
| 334 | ;;; |
| 335 | ;;; Header prefetch |
| 336 | ;;; |
| 337 | |
| 338 | (defun gnus-async-prefetch-headers (group) |
| 339 | "Prefetch the headers for group GROUP." |
| 340 | (save-excursion |
| 341 | (let (unread) |
| 342 | (when (and gnus-use-header-prefetch |
| 343 | gnus-asynchronous |
| 344 | (gnus-group-asynchronous-p group) |
| 345 | (listp gnus-async-header-prefetched) |
| 346 | (setq unread (gnus-list-of-unread-articles group))) |
| 347 | ;; Mark that a fetch is in progress. |
| 348 | (setq gnus-async-header-prefetched t) |
| 349 | (nnheader-set-temp-buffer gnus-async-prefetch-headers-buffer t) |
| 350 | (erase-buffer) |
| 351 | (let ((nntp-server-buffer (current-buffer)) |
| 352 | (nnheader-callback-function |
| 353 | `(lambda (arg) |
| 354 | (setq gnus-async-header-prefetched |
| 355 | ,(cons group unread))))) |
| 356 | (gnus-retrieve-headers unread group gnus-fetch-old-headers)))))) |
| 357 | |
| 358 | (defun gnus-async-retrieve-fetched-headers (articles group) |
| 359 | "See whether we have prefetched headers." |
| 360 | (when (and gnus-use-header-prefetch |
| 361 | (gnus-group-asynchronous-p group) |
| 362 | (listp gnus-async-header-prefetched) |
| 363 | (equal group (car gnus-async-header-prefetched)) |
| 364 | (equal articles (cdr gnus-async-header-prefetched))) |
| 365 | (save-excursion |
| 366 | (nnheader-set-temp-buffer gnus-async-prefetch-headers-buffer t) |
| 367 | (nntp-decode-text) |
| 368 | (copy-to-buffer nntp-server-buffer (point-min) (point-max)) |
| 369 | (erase-buffer) |
| 370 | (setq gnus-async-header-prefetched nil) |
| 371 | t))) |
| 372 | |
| 373 | (provide 'gnus-async) |
| 374 | |
| 375 | ;; arch-tag: fee61de5-3ea2-4de6-8578-2f90ce89391d |
| 376 | ;;; gnus-async.el ends here |