lisp/url/url-queue.el

   1 ;;; url-queue.el --- Fetching web pages in parallel
   2
   3 ;; Copyright (C) 2011 Free Software Foundation, Inc.
   4
   5 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
   6 ;; Keywords: comm
   7
   8 ;; This file is part of GNU Emacs.
   9
  10 ;; GNU Emacs is free software: you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation, either version 3 of the License, or
  13 ;; (at your option) any later version.
  14
  15 ;; GNU Emacs is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  22
  23 ;;; Commentary:
  24
  25 ;; The point of this package is to allow fetching web pages in
  26 ;; parallel -- but control the level of parallelism to avoid DoS-ing
  27 ;; web servers and Emacs.
  28
  29 ;;; Code:
  30
  31 (eval-when-compile (require 'cl))
  32 (require 'browse-url)
  33
  34 (defcustom url-queue-parallel-processes 6
  35   "The number of concurrent processes."
  36   :version "24.1"
  37   :type 'integer
  38   :group 'url)
  39
  40 (defcustom url-queue-timeout 5
  41   "How long to let a job live once it's started (in seconds)."
  42   :version "24.1"
  43   :type 'integer
  44   :group 'url)
  45
  46 ;;; Internal variables.
  47
  48 (defvar url-queue nil)
  49
  50 (defstruct url-queue
  51   url callback cbargs silentp
  52   buffer start-time)
  53
  54 ;;;###autoload
  55 (defun url-queue-retrieve (url callback &optional cbargs silent)
  56   "Retrieve URL asynchronously and call CALLBACK with CBARGS when finished.
  57 Like `url-retrieve' (which see for details of the arguments), but
  58 controls the level of parallelism via the
  59 `url-queue-parallel-processes' variable."
  60   (setq url-queue
  61         (append url-queue
  62                 (list (make-url-queue :url url
  63                                       :callback callback
  64                                       :cbargs cbargs
  65                                       :silentp silent))))
  66   (url-queue-run-queue))
  67
  68 (defun url-queue-run-queue ()
  69   (url-queue-prune-old-entries)
  70   (let ((running 0)
  71         waiting)
  72     (dolist (entry url-queue)
  73       (cond
  74        ((url-queue-start-time entry)
  75         (incf running))
  76        ((not waiting)
  77         (setq waiting entry))))
  78     (when (and waiting
  79                (< running url-queue-parallel-processes))
  80       (setf (url-queue-start-time waiting) (float-time))
  81       (url-queue-start-retrieve waiting))))
  82
  83 (defun url-queue-callback-function (status job)
  84   (setq url-queue (delq job url-queue))
  85   (url-queue-run-queue)
  86   (apply (url-queue-callback job) (cons status (url-queue-cbargs job))))
  87
  88 (defun url-queue-start-retrieve (job)
  89   (setf (url-queue-buffer job)
  90         (ignore-errors
  91           (url-retrieve (url-queue-url job)
  92                         #'url-queue-callback-function (list job)
  93                         (url-queue-silentp job)))))
  94
  95 (defun url-queue-prune-old-entries ()
  96   (let (dead-jobs)
  97     (dolist (job url-queue)
  98       ;; Kill jobs that have lasted longer than the timeout.
  99       (when (and (url-queue-start-time job)
 100                  (> (- (float-time) (url-queue-start-time job))
 101                     url-queue-timeout))
 102         (push job dead-jobs)))
 103     (dolist (job dead-jobs)
 104       (when (bufferp (url-queue-buffer job))
 105         (while (get-buffer-process (url-queue-buffer job))
 106           (ignore-errors
 107             (delete-process (get-buffer-process (url-queue-buffer job)))))
 108         (ignore-errors
 109           (kill-buffer (url-queue-buffer job))))
 110       (setq url-queue (delq job url-queue)))))
 111
 112 (provide 'url-queue)
 113
 114 ;;; url-queue.el ends here