1
0
mirror of https://git.savannah.gnu.org/git/emacs.git synced 2025-01-14 16:50:58 +00:00
emacs/lisp/url/url-queue.el
Paul Eggert 476066e89d Avoid some double-rounding of Lisp timestamps
Also, simplify some time-related Lisp timestamp code
while we’re in the neighborhood.
* lisp/battery.el (battery-linux-proc-acpi)
(battery-linux-sysfs, battery-upower, battery-bsd-apm):
* lisp/calendar/timeclock.el (timeclock-seconds-to-string)
(timeclock-log, timeclock-last-period)
(timeclock-entry-length, timeclock-entry-list-span)
(timeclock-find-discrep, timeclock-generate-report):
* lisp/cedet/ede/detect.el (ede-detect-qtest):
* lisp/completion.el (cmpl-hours-since-origin):
* lisp/ecomplete.el (ecomplete-decay-1):
* lisp/emacs-lisp/ert.el (ert--results-update-stats-display)
(ert--results-update-stats-display-maybe):
* lisp/emacs-lisp/timer-list.el (list-timers):
* lisp/emacs-lisp/timer.el (timer-until)
(timer-event-handler):
* lisp/erc/erc-backend.el (erc-server-send-ping)
(erc-server-send-queue, erc-handle-parsed-server-response)
(erc-handle-unknown-server-response):
* lisp/erc/erc-track.el (erc-buffer-visible):
* lisp/erc/erc.el (erc-lurker-cleanup, erc-lurker-p)
(erc-cmd-PING, erc-send-current-line):
* lisp/eshell/em-pred.el (eshell-pred-file-time):
* lisp/eshell/em-unix.el (eshell-show-elapsed-time):
* lisp/gnus/gnus-icalendar.el (gnus-icalendar-event:org-timestamp):
* lisp/gnus/gnus-int.el (gnus-backend-trace):
* lisp/gnus/gnus-sum.el (gnus-user-date):
* lisp/gnus/mail-source.el (mail-source-delete-crash-box):
* lisp/gnus/nnmaildir.el (nnmaildir--scan):
* lisp/ibuf-ext.el (ibuffer-mark-old-buffers):
* lisp/gnus/nnmaildir.el (nnmaildir--scan):
* lisp/mouse.el (mouse--down-1-maybe-follows-link)
(mouse--click-1-maybe-follows-link):
* lisp/mpc.el (mpc--faster-toggle):
* lisp/net/rcirc.el (rcirc-handler-ctcp-KEEPALIVE)
(rcirc-sentinel):
* lisp/net/tramp-cache.el (tramp-get-file-property):
* lisp/net/tramp-sh.el (tramp-sh-handle-file-newer-than-file-p)
(tramp-maybe-open-connection):
* lisp/net/tramp-smb.el (tramp-smb-maybe-open-connection):
* lisp/org/org-clock.el (org-clock-resolve):
(org-resolve-clocks, org-clock-in, org-clock-out, org-clock-sum):
* lisp/org/org-timer.el (org-timer-start)
(org-timer-pause-or-continue, org-timer-seconds):
* lisp/org/org.el (org-evaluate-time-range):
* lisp/org/ox-publish.el (org-publish-cache-ctime-of-src):
* lisp/pixel-scroll.el (pixel-scroll-in-rush-p):
* lisp/play/hanoi.el (hanoi-move-ring):
* lisp/proced.el (proced-format-time):
* lisp/progmodes/cpp.el (cpp-progress-message):
* lisp/progmodes/flymake.el (flymake--handle-report):
* lisp/progmodes/js.el (js--wait-for-matching-output):
* lisp/subr.el (progress-reporter-do-update):
* lisp/term/xterm.el (xterm--read-event-for-query):
* lisp/time.el (display-time-update, emacs-uptime):
* lisp/tooltip.el (tooltip-delay):
* lisp/url/url-cookie.el (url-cookie-parse-file-netscape):
* lisp/url/url-queue.el (url-queue-prune-old-entries):
* lisp/url/url.el (url-retrieve-synchronously):
* lisp/xt-mouse.el (xterm-mouse-event):
Avoid double-rounding of time-related values.  Simplify.
* lisp/calendar/icalendar.el (icalendar--decode-isodatetime):
When hoping for the best (unlikely), use a better decoded time.
(icalendar--convert-sexp-to-ical): Avoid unnecessary encode-time.
* lisp/calendar/timeclock.el (timeclock-when-to-leave):
* lisp/cedet/ede/detect.el (ede-detect-qtest):
* lisp/desktop.el (desktop-create-buffer):
* lisp/emacs-lisp/benchmark.el (benchmark-elapse):
* lisp/gnus/gnus-art.el (article-lapsed-string):
* lisp/gnus/gnus-group.el (gnus-group-timestamp-delta):
* lisp/gnus/nnmail.el (nnmail-expired-article-p):
* lisp/gnus/nnmaildir.el (nnmaildir-request-expire-articles):
* lisp/nxml/rng-maint.el (rng-time-function):
* lisp/org/org-clock.el (org-clock-get-clocked-time)
(org-clock-resolve, org-resolve-clocks, org-resolve-clocks-if-idle):
* lisp/org/org-habit.el (org-habit-insert-consistency-graphs):
* lisp/progmodes/vhdl-mode.el (vhdl-update-progress-info)
(vhdl-fix-case-region-1):
Use time-since instead of open-coding most of it.
* lisp/erc/erc-dcc.el (erc-dcc-get-sentinel):
* lisp/erc/erc.el (erc-string-to-emacs-time, erc-time-gt):
Now obsolete.  All uses changed.
(erc-time-diff): Accept all Lisp time values.
All uses changed.
* lisp/gnus/gnus-demon.el (gnus-demon-idle-since):
* lisp/gnus/gnus-score.el (gnus-score-headers):
* lisp/gnus/nneething.el (nneething-make-head):
* lisp/gnus/nnheader.el (nnheader-message-maybe):
* lisp/gnus/nnimap.el (nnimap-keepalive):
* lisp/image.el (image-animate-timeout):
* lisp/mail/feedmail.el (feedmail-rfc822-date):
* lisp/net/imap.el (imap-wait-for-tag):
* lisp/net/newst-backend.el (newsticker--image-get):
* lisp/net/rcirc.el (rcirc-handler-317, rcirc-handler-333):
* lisp/obsolete/xesam.el (xesam-refresh-entry):
* lisp/org/org-agenda.el (org-agenda-show-clocking-issues)
(org-agenda-check-clock-gap, org-agenda-to-appt):
* lisp/org/org-capture.el (org-capture-set-target-location):
* lisp/org/org-clock.el (org-clock-resolve-clock)
(org-clocktable-steps):
* lisp/org/org-colview.el (org-columns-edit-value)
(org-columns, org-agenda-columns):
* lisp/org/org-duration.el (org-duration-from-minutes):
* lisp/org/org-element.el (org-element-cache-sync-duration)
(org-element-cache-sync-break)
(org-element--cache-interrupt-p, org-element--cache-sync):
* lisp/org/org-habit.el (org-habit-get-faces)
* lisp/org/org-indent.el (org-indent-add-properties):
* lisp/org/org-table.el (org-table-sum):
* lisp/org/org-timer.el (org-timer-show-remaining-time)
(org-timer-set-timer):
* lisp/org/org.el (org-babel-load-file, org-today)
(org-auto-repeat-maybe, org-2ft, org-time-stamp)
(org-read-date-analyze, org-time-stamp-to-now)
(org-small-year-to-year, org-goto-calendar):
* lisp/org/ox.el (org-export-insert-default-template):
* lisp/ses.el (ses--time-check):
* lisp/type-break.el (type-break-time-warning)
(type-break-statistics, type-break-demo-boring):
* lisp/url/url-cache.el (url-cache-expired)
(url-cache-prune-cache):
* lisp/vc/vc-git.el (vc-git-stash-snapshot):
* lisp/erc/erc-match.el (erc-log-matches-come-back):
Simplify.
2019-02-22 18:33:57 -08:00

197 lines
6.8 KiB
EmacsLisp

;;; url-queue.el --- Fetching web pages in parallel -*- lexical-binding: t -*-
;; Copyright (C) 2011-2019 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 <https://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-lib))
(require 'browse-url)
(require 'url-parse)
(defcustom url-queue-parallel-processes 6
"The number of concurrent processes."
:version "24.1"
:type 'integer
:group 'url)
(defcustom url-queue-timeout 5
"How long to let a job live once it's started (in seconds)."
:version "24.1"
:type 'integer
:group 'url)
;;; Internal variables.
(defvar url-queue nil)
(defvar url-queue-progress-timer nil)
(cl-defstruct url-queue
url callback cbargs silentp
buffer start-time pre-triggered
inhibit-cookiesp context-buffer)
;;;###autoload
(defun url-queue-retrieve (url callback &optional cbargs silent inhibit-cookies)
"Retrieve URL asynchronously and call CALLBACK with CBARGS when finished.
This is like `url-retrieve' (which see for details of the arguments),
but with limits on the degree of parallelism. The variable
`url-queue-parallel-processes' sets the number of concurrent processes.
The variable `url-queue-timeout' sets a timeout."
(setq url-queue
(append url-queue
(list (make-url-queue :url url
:callback callback
:cbargs cbargs
:silentp silent
:inhibit-cookiesp inhibit-cookies
:context-buffer (current-buffer)))))
(url-queue-setup-runners))
;; To ensure asynch behavior, we start the required number of queue
;; runners from `run-with-idle-timer'. So we're basically going
;; through the queue in two ways: 1) synchronously when a program
;; calls `url-queue-retrieve' (which will then start the required
;; number of queue runners), and 2) at the exit of each job, which
;; will then not start any further threads, but just reuse the
;; previous "slot".
(defun url-queue-setup-runners ()
(let ((running 0)
waiting)
(dolist (entry url-queue)
(cond
((or (url-queue-start-time entry)
(url-queue-pre-triggered entry))
(cl-incf running))
((not waiting)
(setq waiting entry))))
(when (and waiting
(< running url-queue-parallel-processes))
(setf (url-queue-pre-triggered waiting) t)
;; We start fetching from this idle timer...
(run-with-idle-timer 0.01 nil #'url-queue-run-queue)
;; And then we set up a separate timer to ensure progress when a
;; web server is unresponsive.
(unless url-queue-progress-timer
(setq url-queue-progress-timer
(run-with-idle-timer 1 1 #'url-queue-check-progress))))))
(defun url-queue-run-queue ()
(url-queue-prune-old-entries)
(let ((running 0)
waiting)
(dolist (entry url-queue)
(cond
((url-queue-start-time entry)
(cl-incf running))
((not waiting)
(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-check-progress ()
(when url-queue-progress-timer
(if url-queue
(url-queue-run-queue)
(cancel-timer url-queue-progress-timer)
(setq url-queue-progress-timer nil))))
(defun url-queue-callback-function (status job)
(setq url-queue (delq job url-queue))
(when (and (eq (car status) :error)
(eq (cadr (cadr status)) 'connection-failed))
;; If we get a connection error, then flush all other jobs from
;; the host from the queue. This particularly makes sense if the
;; error really is a DNS resolver issue, which happens
;; synchronously and totally halts Emacs.
(url-queue-remove-jobs-from-host
(plist-get (nthcdr 3 (cadr status)) :host)))
(url-queue-run-queue)
(apply (url-queue-callback job) (cons status (url-queue-cbargs job))))
(defun url-queue-remove-jobs-from-host (host)
(let ((jobs nil))
(dolist (job url-queue)
(when (equal (url-host (url-generic-parse-url (url-queue-url job)))
host)
(push job jobs)))
(dolist (job jobs)
(url-queue-kill-job job)
(setq url-queue (delq job url-queue)))))
(defun url-queue-start-retrieve (job)
(setf (url-queue-buffer job)
(ignore-errors
(with-current-buffer (if (buffer-live-p (url-queue-context-buffer job))
(url-queue-context-buffer job)
(current-buffer))
(let ((url-request-noninteractive t))
(url-retrieve (url-queue-url job)
#'url-queue-callback-function (list job)
(url-queue-silentp job)
(url-queue-inhibit-cookiesp job)))))))
(defun url-queue-prune-old-entries ()
(let (dead-jobs)
(dolist (job url-queue)
;; Kill jobs that have lasted longer than the timeout.
(when (and (url-queue-start-time job)
(time-less-p url-queue-timeout
(time-since (url-queue-start-time job))))
(push job dead-jobs)))
(dolist (job dead-jobs)
(url-queue-kill-job job)
(setq url-queue (delq job url-queue)))))
(defun url-queue-kill-job (job)
(when (bufferp (url-queue-buffer job))
(let (process)
(while (setq process (get-buffer-process (url-queue-buffer job)))
(set-process-sentinel process 'ignore)
(ignore-errors
(delete-process process)))))
;; Call the callback with an error message to ensure that the caller
;; is notified that the job has failed.
(with-current-buffer
(if (and (bufferp (url-queue-buffer job))
(buffer-live-p (url-queue-buffer job)))
;; Use the (partially filled) process buffer if it exists.
(url-queue-buffer job)
;; If not, just create a new buffer, which will probably be
;; killed again by the caller.
(generate-new-buffer " *temp*"))
(apply (url-queue-callback job)
(cons (list :error (list 'error 'url-queue-timeout
"Queue timeout exceeded"))
(url-queue-cbargs job)))))
(provide 'url-queue)
;;; url-queue.el ends here