From: Lars Magne Ingebrigtsen <larsi@gnus.org>
Date: Mon, 2 May 2011 17:06:56 +0000 (+0200)
Subject: Add the new file url-queue.el, which allows controlling the
X-Git-Tag: emacs-pretest-24.0.90~104^2~275^2~148
X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=5c77c3eda3fad59d6aa5c716f49b24e911e1c222;p=emacs.git

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 528b63a6448..0bf4d09c95c 100644
--- 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
index 00000000000..2d94d8afea3
--- /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