code.delx.au - gnu-emacs/blob - 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 2
  35   "The number of concurrent processes."
  36   :type 'integer
  37   :group 'url)
  38
  39 (defcustom url-queue-timeout 5
  40   "How long to let a job live once it's started (in seconds)."
  41   :type 'integer
  42   :group 'url)
  43
  44 ;;; Internal variables.
  45
  46 (defvar url-queue nil)
  47
  48 (defstruct url-queue
  49   url callback cbargs silentp
  50   buffer start-time)
  51
  52 ;;;###autoload
  53 (defun url-queue-retrieve (url callback &optional cbargs silent)
  54   "Retrieve URL asynchronously and call CALLBACK with CBARGS when finished.
  55 Like `url-retrieve' (which see for details of the arguments), but
  56 controls the level of parallelism via the
  57 `url-queue-parallel-processes' variable."
  58   (setq url-queue
  59         (append url-queue
  60                 (list (make-url-queue :url url
  61                                       :callback callback
  62                                       :cbargs cbargs
  63                                       :silentp silent))))
  64   (url-queue-run-queue))
  65
  66 (defun url-queue-run-queue ()
  67   (url-queue-prune-old-entries)
  68   (let ((running 0)
  69         waiting)
  70     (dolist (entry url-queue)
  71       (cond
  72        ((url-queue-start-time entry)
  73         (incf running))
  74        ((not waiting)
  75         (setq waiting entry))))
  76     (when (and waiting
  77                (< running url-queue-parallel-processes))
  78       (setf (url-queue-start-time waiting) (float-time))
  79       (url-queue-start-retrieve waiting))))
  80
  81 (defun url-queue-callback-function (status job)
  82   (setq url-queue (delq job url-queue))
  83   (url-queue-run-queue)
  84   (apply (url-queue-callback job) (cons status (url-queue-cbargs job))))
  85
  86 (defun url-queue-start-retrieve (job)
  87   (setf (url-queue-buffer job)
  88         (ignore-errors
  89           (url-retrieve (url-queue-url job)
  90                         #'url-queue-callback-function (list job)
  91                         (url-queue-silentp job)))))
  92
  93 (defun url-queue-prune-old-entries ()
  94   (let (dead-jobs)
  95     (dolist (job url-queue)
  96       ;; Kill jobs that have lasted longer than the timeout.
  97       (when (and (url-queue-start-time job)
  98                  (> (- (float-time) (url-queue-start-time job))
  99                     url-queue-timeout))
 100         (push job dead-jobs)))
 101     (dolist (job dead-jobs)
 102       (when (bufferp (url-queue-buffer job))
 103         (while (get-buffer-process (url-queue-buffer job))
 104           (ignore-errors
 105             (delete-process (get-buffer-process (url-queue-buffer job)))))
 106         (ignore-errors
 107           (kill-buffer (url-queue-buffer job))))
 108       (setq url-queue (delq job url-queue)))))
 109
 110 (provide 'url-queue)
 111
 112 ;;; url-queue.el ends here