Add the new file url-queue.el, which allows controlling the

parallelism when fetching web pages asynchronously.

diff --git a/lisp/url/ChangeLog b/lisp/url/ChangeLog
index 528b63a6448e5adaed073ba0bd51d095ec54eb03..0bf4d09c95c161bcf4eb0f098ef16b7cd1ab89b6 100644 (file)
--- a/lisp/url/ChangeLog
+++ b/lisp/url/ChangeLog
@@ -1,3 +1,7 @@
+2011-05-02  Lars Magne Ingebrigtsen  <larsi@gnus.org>
+
+       * url-queue.el: New file.
+
 2011-04-16  Lars Magne Ingebrigtsen  <larsi@gnus.org>
 
        * url-http.el (url-http-wait-for-headers-change-function): Protect

diff --git a/lisp/url/url-queue.el b/lisp/url/url-queue.el
new file mode 100644 (file)
index 0000000..2d94d8a
--- /dev/null
+++ b/lisp/url/url-queue.el
@@ -0,0 +1,108 @@
+;;; url-queue.el --- Fetching web pages in parallel
+
+;; Copyright (C) 2011 Free Software Foundation, Inc.
+
+;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
+;; Keywords: comm
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; The point of this package is to allow fetching web pages in
+;; parallel -- but control the level of parallelism to avoid DoS-ing
+;; web servers and Emacs.
+
+;;; Code:
+
+(eval-when-compile (require 'cl))
+(require 'browse-url)
+
+(defcustom url-queue-parallel-processes 4
+  "The number of concurrent processes."
+  :type 'integer
+  :group 'url)
+
+(defcustom url-queue-timeout 5
+  "How long to let a job live once it's started (in seconds)."
+  :type 'integer
+  :group 'url)
+
+;;; Internal variables.
+
+(defvar url-queue nil)
+
+(defstruct url-queue
+  url callback cbargs silentp
+  process start-time)
+
+(defun url-queue-retrieve (url callback &optional cbargs silent)
+  "Retrieve URL asynchronously and call CALLBACK with CBARGS when finished.
+Like `url-retrieve' (which see for details of the arguments), but
+controls the level of parallelism via the
+`url-queue-parallel-processes' variable."
+  (setq url-queue
+       (append url-queue
+               (list (make-url-queue :url url
+                                     :callback callback
+                                     :cbargs cbargs
+                                     :silentp silent))))
+  (url-queue-run-queue))
+
+(defun url-queue-run-queue ()
+  (url-queue-prune-old-entries)
+  (let ((running 0)
+       waiting)
+    (dolist (entry url-queue)
+      (if (url-queue-start-time entry)
+         (incf running)
+       (setq waiting entry)))
+    (when (and waiting
+              (< running url-queue-parallel-processes))
+      (setf (url-queue-start-time waiting) (float-time))
+      (url-queue-start-retrieve waiting))))
+
+(defun url-queue-callback-function (status job)
+  (setq url-queue (delq job url-queue))
+  (url-queue-run-queue)
+  (apply (url-queue-callback job) (cons status (url-queue-cbargs job))))
+
+(defun url-queue-start-retrieve (job)
+  (setf (url-queue-process job)
+       (ignore-errors
+         (url-retrieve (url-queue-url job)
+                       #'url-queue-callback-function (list job)
+                       (url-queue-silentp job)))))
+
+(defun url-queue-prune-old-entries ()
+  (let (dead-jobs)
+    (dolist (job url-queue)
+      ;; Kill jobs that have lasted longer than five seconds.
+      (when (and (url-queue-start-time job)
+                (> (- (float-time) (url-queue-start-time job))
+                   url-queue-timeout))
+       (push job dead-jobs)))
+    (dolist (job dead-jobs)
+      (when (processp (url-queue-process job))
+       (ignore-errors
+         (delete-process (url-queue-process job)))
+       (ignore-errors
+         (kill-buffer (process-buffer (url-queue-process job))))
+       (setq url-queue (delq job url-queue))))))
+
+(provide 'url-queue)
+
+;;; url-queue.el ends here