summaryrefslogtreecommitdiff
path: root/lisp/url
diff options
context:
space:
mode:
Diffstat (limited to 'lisp/url')
-rw-r--r--lisp/url/url-auth.el4
-rw-r--r--lisp/url/url-cookie.el18
-rw-r--r--lisp/url/url-expand.el2
-rw-r--r--lisp/url/url-file.el1
-rw-r--r--lisp/url/url-future.el2
-rw-r--r--lisp/url/url-gw.el4
-rw-r--r--lisp/url/url-handlers.el8
-rw-r--r--lisp/url/url-http.el185
-rw-r--r--lisp/url/url-misc.el1
-rw-r--r--lisp/url/url-parse.el4
-rw-r--r--lisp/url/url-queue.el18
-rw-r--r--lisp/url/url-util.el4
-rw-r--r--lisp/url/url-vars.el27
-rw-r--r--lisp/url/url.el19
14 files changed, 222 insertions, 75 deletions
diff --git a/lisp/url/url-auth.el b/lisp/url/url-auth.el
index b2eceb0da10..a2aa97c2799 100644
--- a/lisp/url/url-auth.el
+++ b/lisp/url/url-auth.el
@@ -1,4 +1,4 @@
-;;; url-auth.el --- Uniform Resource Locator authorization modules
+;;; url-auth.el --- Uniform Resource Locator authorization modules -*- lexical-binding: t -*-
;; Copyright (C) 1996-1999, 2004-2016 Free Software Foundation, Inc.
@@ -53,7 +53,7 @@ lists. The first assoc list is keyed by the server name. The cdr of
this is an assoc list based on the \"directory\" specified by the URL we
are looking up.")
-(defun url-basic-auth (url &optional prompt overwrite realm args)
+(defun url-basic-auth (url &optional prompt overwrite realm _args)
"Get the username/password for the specified URL.
If optional argument PROMPT is non-nil, ask for the username/password
to use for the url and its descendants. If optional third argument
diff --git a/lisp/url/url-cookie.el b/lisp/url/url-cookie.el
index 4c7366adc8e..6848230c28f 100644
--- a/lisp/url/url-cookie.el
+++ b/lisp/url/url-cookie.el
@@ -353,6 +353,24 @@ to run the `url-cookie-setup-save-timer' function manually."
url-cookie-save-interval
#'url-cookie-write-file))))
+(defun url-cookie-delete-cookies (&optional regexp keep)
+ "Delete all cookies from the cookie store where the domain matches REGEXP.
+If REGEXP is nil, all cookies are deleted. If KEEP is non-nil,
+instead delete all cookies that do not match REGEXP."
+ (dolist (variable '(url-cookie-secure-storage url-cookie-storage))
+ (let ((cookies (symbol-value variable)))
+ (dolist (elem cookies)
+ (when (or (and (null keep)
+ (or (null regexp)
+ (string-match regexp (car elem))))
+ (and keep
+ regexp
+ (not (string-match regexp (car elem)))))
+ (setq cookies (delq elem cookies))))
+ (set variable cookies)))
+ (setq url-cookies-changed-since-last-save t)
+ (url-cookie-write-file))
+
;;; Mode for listing and editing cookies.
(defun url-cookie-list ()
diff --git a/lisp/url/url-expand.el b/lisp/url/url-expand.el
index 434b77550d7..48d3ce40f74 100644
--- a/lisp/url/url-expand.el
+++ b/lisp/url/url-expand.el
@@ -1,4 +1,4 @@
-;;; url-expand.el --- expand-file-name for URLs
+;;; url-expand.el --- expand-file-name for URLs -*- lexical-binding: t -*-
;; Copyright (C) 1999, 2004-2016 Free Software Foundation, Inc.
diff --git a/lisp/url/url-file.el b/lisp/url/url-file.el
index 9eb9377583d..61e83c09974 100644
--- a/lisp/url/url-file.el
+++ b/lisp/url/url-file.el
@@ -27,6 +27,7 @@
(require 'url-vars)
(require 'url-parse)
(require 'url-dired)
+(declare-function mm-disable-multibyte "mm-util" ())
(defconst url-file-default-port 21 "Default FTP port.")
(defconst url-file-asynchronous-p t "FTP transfers are asynchronous.")
diff --git a/lisp/url/url-future.el b/lisp/url/url-future.el
index c4005a634cb..12c971c87d6 100644
--- a/lisp/url/url-future.el
+++ b/lisp/url/url-future.el
@@ -1,4 +1,4 @@
-;;; url-future.el --- general futures facility for url.el
+;;; url-future.el --- general futures facility for url.el -*- lexical-binding: t -*-
;; Copyright (C) 2011-2016 Free Software Foundation, Inc.
diff --git a/lisp/url/url-gw.el b/lisp/url/url-gw.el
index 460ee0dd426..d898368cf9e 100644
--- a/lisp/url/url-gw.el
+++ b/lisp/url/url-gw.el
@@ -246,8 +246,8 @@ overriding the value of `url-gateway-method'."
:type gw-method
;; Use non-blocking socket if we can.
:nowait (featurep 'make-network-process
- '(:nowait t))))
- (`socks
+ '(:nowait t))))
+ (`socks
(socks-open-network-stream name buffer host service))
(`telnet
(url-open-telnet name buffer host service))
diff --git a/lisp/url/url-handlers.el b/lisp/url/url-handlers.el
index 717651df544..0fada8d49d7 100644
--- a/lisp/url/url-handlers.el
+++ b/lisp/url/url-handlers.el
@@ -262,14 +262,16 @@ Fifth arg PRESERVE-UID-GID is ignored.
A prefix arg makes KEEP-TIME non-nil."
(if (and (file-exists-p newname)
(not ok-if-already-exists))
- (error "Opening output file: File already exists, %s" newname))
+ (signal 'file-already-exists (list "File exists" newname)))
(let ((buffer (url-retrieve-synchronously url))
(handle nil))
(if (not buffer)
- (error "Opening input file: No such file or directory, %s" url))
+ (signal 'file-missing (list "Opening URL" "No such file or directory"
+ url)))
(with-current-buffer buffer
(setq handle (mm-dissect-buffer t)))
- (mm-save-part-to-file handle newname)
+ (let ((mm-attachment-file-modes (default-file-modes)))
+ (mm-save-part-to-file handle newname))
(kill-buffer buffer)
(mm-destroy-parts handle)))
(put 'copy-file 'url-file-handlers 'url-copy-file)
diff --git a/lisp/url/url-http.el b/lisp/url/url-http.el
index e0e080e76af..81bb9b4721e 100644
--- a/lisp/url/url-http.el
+++ b/lisp/url/url-http.el
@@ -1,4 +1,4 @@
-;;; url-http.el --- HTTP retrieval routines
+;;; url-http.el --- HTTP retrieval routines -*- lexical-binding:t -*-
;; Copyright (C) 1999, 2001, 2004-2016 Free Software Foundation, Inc.
@@ -26,6 +26,8 @@
;;; Code:
(require 'cl-lib)
+(require 'puny)
+(require 'nsm)
(eval-when-compile
(require 'subr-x))
@@ -126,6 +128,7 @@ request.")
(422 unprocessable-entity "Unprocessable Entity (Added by DAV)")
(423 locked "Locked")
(424 failed-Dependency "Failed Dependency")
+ (451 unavailable-for-legal-reasons "Unavailable for legal reasons") ;RFC 7725
(500 internal-server-error "Internal server error")
(501 not-implemented "Not implemented")
(502 bad-gateway "Bad gateway")
@@ -135,6 +138,8 @@ request.")
(507 insufficient-storage "Insufficient storage"))
"The HTTP return codes and their text.")
+(defconst url-https-default-port 443 "Default HTTPS port.")
+
;(eval-when-compile
;; These are all macros so that they are hidden from external sight
;; when the file is byte-compiled.
@@ -196,7 +201,14 @@ request.")
;; `url-open-stream' needs a buffer in which to do things
;; like authentication. But we use another buffer afterwards.
(unwind-protect
- (let ((proc (url-open-stream host buf host port gateway-method)))
+ (let ((proc (url-open-stream host buf
+ (if url-using-proxy
+ (url-host url-using-proxy)
+ host)
+ (if url-using-proxy
+ (url-port url-using-proxy)
+ port)
+ gateway-method)))
;; url-open-stream might return nil.
(when (processp proc)
;; Drop the temp buffer link before killing the buffer.
@@ -211,15 +223,36 @@ request.")
(if connection
(url-http-mark-connection-as-busy host port connection))))
+(defun url-http--user-agent-default-string ()
+ "Compute a default User-Agent string based on `url-privacy-level'."
+ (let ((package-info (when url-package-name
+ (format "%s/%s" url-package-name url-package-version)))
+ (emacs-info (unless (and (listp url-privacy-level)
+ (memq 'emacs url-privacy-level))
+ (format "Emacs/%s" emacs-version)))
+ (os-info (unless (and (listp url-privacy-level)
+ (memq 'os url-privacy-level))
+ (format "(%s; %s)" url-system-type url-os-type)))
+ (url-info (format "URL/%s" url-version)))
+ (string-join (delq nil (list package-info url-info
+ emacs-info os-info))
+ " ")))
+
;; Building an HTTP request
(defun url-http-user-agent-string ()
- (if (or (eq url-privacy-level 'paranoid)
- (and (listp url-privacy-level)
- (memq 'agent url-privacy-level)))
- ""
- (if (functionp url-user-agent)
- (funcall url-user-agent)
- url-user-agent)))
+ "Compute a User-Agent string.
+The string is based on `url-privacy-level' and `url-user-agent'."
+ (let* ((hide-ua
+ (or (eq url-privacy-level 'paranoid)
+ (and (listp url-privacy-level)
+ (memq 'agent url-privacy-level))))
+ (ua-string
+ (and (not hide-ua)
+ (cond
+ ((functionp url-user-agent) (funcall url-user-agent))
+ ((stringp url-user-agent) url-user-agent)
+ ((eq url-user-agent 'default) (url-http--user-agent-default-string))))))
+ (if ua-string (format "User-Agent: %s\r\n" (string-trim ua-string)) "")))
(defun url-http-create-request (&optional ref-url)
"Create an HTTP request for `url-http-target-url', referred to by REF-URL."
@@ -296,8 +329,9 @@ request.")
(url-scheme-get-property
(url-type url-http-target-url) 'default-port))
(format
- "Host: %s:%d\r\n" host (url-port url-http-target-url))
- (format "Host: %s\r\n" host))
+ "Host: %s:%d\r\n" (puny-encode-domain host)
+ (url-port url-http-target-url))
+ (format "Host: %s\r\n" (puny-encode-domain host)))
;; Who its from
(if url-personal-mail-address
(concat
@@ -475,6 +509,7 @@ work correctly."
)
(declare-function gnutls-peer-status "gnutls.c" (proc))
+(declare-function gnutls-negotiate "gnutls.el" t t)
(defun url-http-parse-headers ()
"Parse and handle HTTP specific headers.
@@ -588,15 +623,7 @@ should be shown to the user."
;; We do not support agent-driven negotiation, so we just
;; redirect to the preferred URI if one is provided.
nil)
- ((or `moved-permanently `found `temporary-redirect) ; 301 302 307
- ;; If the 301|302 status code is received in response to a
- ;; request other than GET or HEAD, the user agent MUST NOT
- ;; automatically redirect the request unless it can be
- ;; confirmed by the user, since this might change the
- ;; conditions under which the request was issued.
- (unless (member url-http-method '("HEAD" "GET"))
- (setq redirect-uri nil)))
- (`see-other ; 303
+ (`see-other ; 303
;; The response to the request can be found under a different
;; URI and SHOULD be retrieved using a GET method on that
;; resource.
@@ -905,7 +932,7 @@ should be shown to the user."
;; )
;; These unfortunately cannot be macros... please ignore them!
-(defun url-http-idle-sentinel (proc why)
+(defun url-http-idle-sentinel (proc _why)
"Remove (now defunct) process PROC from the list of open connections."
(maphash (lambda (key val)
(if (memq proc val)
@@ -931,18 +958,24 @@ should be shown to the user."
(erase-buffer)
(let ((url-request-method url-http-method)
(url-request-extra-headers url-http-extra-headers)
- (url-request-data url-http-data))
+ (url-request-data url-http-data)
+ (url-using-proxy (url-find-proxy-for-url
+ url-current-object
+ (url-host url-current-object))))
+ (when url-using-proxy
+ (setq url-using-proxy
+ (url-generic-parse-url url-using-proxy)))
(url-http url-current-object url-callback-function
url-callback-arguments (current-buffer)))))
((url-http-parse-headers)
(url-http-activate-callback))))))
-(defun url-http-simple-after-change-function (st nd length)
+(defun url-http-simple-after-change-function (_st _nd _length)
;; Function used when we do NOT know how long the document is going to be
;; Just _very_ simple 'downloaded %d' type of info.
- (url-lazy-message "Reading %s..." (file-size-human-readable nd)))
+ (url-lazy-message "Reading %s..." (file-size-human-readable (buffer-size))))
-(defun url-http-content-length-after-change-function (st nd length)
+(defun url-http-content-length-after-change-function (_st nd _length)
"Function used when we DO know how long the document is going to be.
More sophisticated percentage downloaded, etc.
Also does minimal parsing of HTTP headers and will actually cause
@@ -1061,7 +1094,7 @@ the end of the document."
(if (url-http-parse-headers)
(url-http-activate-callback))))))))))
-(defun url-http-wait-for-headers-change-function (st nd length)
+(defun url-http-wait-for-headers-change-function (_st nd _length)
;; This will wait for the headers to arrive and then splice in the
;; next appropriate after-change-function, etc.
(url-http-debug "url-http-wait-for-headers-change-function (%s)"
@@ -1069,7 +1102,8 @@ the end of the document."
(let ((end-of-headers nil)
(old-http nil)
(process-buffer (current-buffer))
- (content-length nil))
+ ;; (content-length nil)
+ )
(when (not (bobp))
(goto-char (point-min))
(if (and (looking-at ".*\n") ; have one line at least
@@ -1210,22 +1244,25 @@ overriding the value of `url-gateway-method'.
The return value of this function is the retrieval buffer."
(cl-check-type url vector "Need a pre-parsed URL.")
- (let* ((host (url-host (or url-using-proxy url)))
- (port (url-port (or url-using-proxy url)))
+ (let* (;; (host (url-host (or url-using-proxy url)))
+ ;; (port (url-port (or url-using-proxy url)))
(nsm-noninteractive (or url-request-noninteractive
(and (boundp 'url-http-noninteractive)
url-http-noninteractive)))
- (connection (url-http-find-free-connection host port gateway-method))
+ (connection (url-http-find-free-connection (url-host url)
+ (url-port url)
+ gateway-method))
(mime-accept-string url-mime-accept-string)
(buffer (or retry-buffer
(generate-new-buffer
- (format " *http %s:%d*" host port)))))
+ (format " *http %s:%d*" (url-host url) (url-port url))))))
(if (not connection)
;; Failed to open the connection for some reason
(progn
(kill-buffer buffer)
(setq buffer nil)
- (error "Could not create connection to %s:%d" host port))
+ (error "Could not create connection to %s:%d" (url-host url)
+ (url-port url)))
(with-current-buffer buffer
(mm-disable-multibyte)
(setq url-current-object url
@@ -1281,13 +1318,72 @@ The return value of this function is the retrieval buffer."
(set-process-sentinel connection 'url-http-async-sentinel))
(`failed
;; Asynchronous connection failed
- (error "Could not create connection to %s:%d" host port))
+ (error "Could not create connection to %s:%d" (url-host url)
+ (url-port url)))
(_
- (set-process-sentinel connection
- 'url-http-end-of-document-sentinel)
- (process-send-string connection (url-http-create-request))))))
+ (if (and url-http-proxy (string= "https"
+ (url-type url-current-object)))
+ (url-https-proxy-connect connection)
+ (set-process-sentinel connection
+ 'url-http-end-of-document-sentinel)
+ (process-send-string connection (url-http-create-request)))))))
buffer))
+(defun url-https-proxy-connect (connection)
+ (setq url-http-after-change-function 'url-https-proxy-after-change-function)
+ (process-send-string connection (format (concat "CONNECT %s:%d HTTP/1.1\r\n"
+ "Host: %s\r\n"
+ "\r\n")
+ (url-host url-current-object)
+ (or (url-port url-current-object)
+ url-https-default-port)
+ (url-host url-current-object))))
+
+(defun url-https-proxy-after-change-function (_st _nd _length)
+ (let* ((process-buffer (current-buffer))
+ (proc (get-buffer-process process-buffer)))
+ (goto-char (point-min))
+ (when (re-search-forward "^\r?\n" nil t)
+ (backward-char 1)
+ ;; Saw the end of the headers
+ (setq url-http-end-of-headers (set-marker (make-marker) (point)))
+ (url-http-parse-response)
+ (cond
+ ((null url-http-response-status)
+ ;; We got back a headerless malformed response from the
+ ;; server.
+ (url-http-activate-callback)
+ (error "Malformed response from proxy, fail!"))
+ ((= url-http-response-status 200)
+ (if (gnutls-available-p)
+ (condition-case e
+ (let ((tls-connection (gnutls-negotiate
+ :process proc
+ :hostname (url-host url-current-object)
+ :verify-error nil)))
+ ;; check certificate validity
+ (setq tls-connection
+ (nsm-verify-connection tls-connection
+ (url-host url-current-object)
+ (url-port url-current-object)))
+ (with-current-buffer process-buffer (erase-buffer))
+ (set-process-buffer tls-connection process-buffer)
+ (setq url-http-after-change-function
+ 'url-http-wait-for-headers-change-function)
+ (set-process-filter tls-connection 'url-http-generic-filter)
+ (process-send-string tls-connection
+ (url-http-create-request)))
+ (gnutls-error
+ (url-http-activate-callback)
+ (error "gnutls-error: %s" e))
+ (error
+ (url-http-activate-callback)
+ (error "error: %s" e)))
+ (error "error: gnutls support needed!")))
+ (t
+ (message "error response: %d" url-http-response-status)
+ (url-http-activate-callback))))))
+
(defun url-http-async-sentinel (proc why)
;; We are performing an asynchronous connection, and a status change
;; has occurred.
@@ -1299,11 +1395,13 @@ The return value of this function is the retrieval buffer."
(url-http-end-of-document-sentinel proc why))
((string= (substring why 0 4) "open")
(setq url-http-connection-opened t)
- (condition-case error
- (process-send-string proc (url-http-create-request))
- (file-error
- (setq url-http-connection-opened nil)
- (message "HTTP error: %s" error))))
+ (if (and url-http-proxy (string= "https" (url-type url-current-object)))
+ (url-https-proxy-connect proc)
+ (condition-case error
+ (process-send-string proc (url-http-create-request))
+ (file-error
+ (setq url-http-connection-opened nil)
+ (message "HTTP error: %s" error)))))
(t
(setf (car url-callback-arguments)
(nconc (list :error (list 'error 'connection-failed why
@@ -1365,7 +1463,7 @@ The return value of this function is the retrieval buffer."
(defalias 'url-http-file-readable-p 'url-http-file-exists-p)
-(defun url-http-head-file-attributes (url &optional id-format)
+(defun url-http-head-file-attributes (url &optional _id-format)
(let ((buffer (url-http-head url)))
(when buffer
(prog1
@@ -1380,7 +1478,7 @@ The return value of this function is the retrieval buffer."
nil nil nil) ;whether gid would change ; inode ; device.
(kill-buffer buffer)))))
-(declare-function url-dav-file-attributes "url-dav" (url &optional id-format))
+(declare-function url-dav-file-attributes "url-dav" (url &optional _id-format))
(defun url-http-file-attributes (url &optional id-format)
(if (url-dav-supported-p url)
@@ -1464,7 +1562,6 @@ p3p
;; with url-http.el on systems with 8-character file names.
(require 'tls)
-(defconst url-https-default-port 443 "Default HTTPS port.")
(defconst url-https-asynchronous-p t "HTTPS retrievals are asynchronous.")
;; FIXME what is the point of this alias being an autoload?
diff --git a/lisp/url/url-misc.el b/lisp/url/url-misc.el
index 2c277fb69c2..14b9f7eab44 100644
--- a/lisp/url/url-misc.el
+++ b/lisp/url/url-misc.el
@@ -24,6 +24,7 @@
(require 'url-vars)
(require 'url-parse)
+(declare-function mm-disable-multibyte "mm-util" ())
(autoload 'Info-goto-node "info" "" t)
(autoload 'man "man" nil t)
diff --git a/lisp/url/url-parse.el b/lisp/url/url-parse.el
index 6e51b35f5a1..c0e386d0385 100644
--- a/lisp/url/url-parse.el
+++ b/lisp/url/url-parse.el
@@ -1,4 +1,4 @@
-;;; url-parse.el --- Uniform Resource Locator parser
+;;; url-parse.el --- Uniform Resource Locator parser -*- lexical-binding: t -*-
;; Copyright (C) 1996-1999, 2004-2016 Free Software Foundation, Inc.
@@ -224,7 +224,7 @@ parses to
fragment nil full))))))
(defmacro url-bit-for-url (method lookfor url)
- `(let* ((urlobj (url-generic-parse-url url))
+ `(let* ((urlobj (url-generic-parse-url ,url))
(bit (funcall ,method urlobj))
(methods (list 'url-recreate-url
'url-host))
diff --git a/lisp/url/url-queue.el b/lisp/url/url-queue.el
index 0ff4ad1556c..8972d0b056c 100644
--- a/lisp/url/url-queue.el
+++ b/lisp/url/url-queue.el
@@ -1,4 +1,4 @@
-;;; url-queue.el --- Fetching web pages in parallel
+;;; url-queue.el --- Fetching web pages in parallel -*- lexical-binding: t -*-
;; Copyright (C) 2011-2016 Free Software Foundation, Inc.
@@ -47,6 +47,7 @@
;;; Internal variables.
(defvar url-queue nil)
+(defvar url-queue-progress-timer nil)
(cl-defstruct url-queue
url callback cbargs silentp
@@ -90,7 +91,13 @@ The variable `url-queue-timeout' sets a timeout."
(when (and waiting
(< running url-queue-parallel-processes))
(setf (url-queue-pre-triggered waiting) t)
- (run-with-idle-timer 0.01 nil 'url-queue-run-queue))))
+ ;; 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)
@@ -107,6 +114,13 @@ The variable `url-queue-timeout' sets a timeout."
(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)
diff --git a/lisp/url/url-util.el b/lisp/url/url-util.el
index 1ae2213eee6..a3844f9e32e 100644
--- a/lisp/url/url-util.el
+++ b/lisp/url/url-util.el
@@ -1,4 +1,4 @@
-;;; url-util.el --- Miscellaneous helper routines for URL library
+;;; url-util.el --- Miscellaneous helper routines for URL library -*- lexical-binding: t -*-
;; Copyright (C) 1996-1999, 2001, 2004-2016 Free Software Foundation,
;; Inc.
@@ -468,7 +468,7 @@ should return it unchanged."
(and host
(not (string-match "\\`\\[.*\\]\\'" host))
(setf (url-host obj)
- (url-hexify-string host url-host-allowed-chars)))
+ (decode-coding-string (url-host obj) 'utf-8)))
(if path
(setq path (url-hexify-string path url-path-allowed-chars)))
diff --git a/lisp/url/url-vars.el b/lisp/url/url-vars.el
index 960a04ad30f..1286d6cda98 100644
--- a/lisp/url/url-vars.el
+++ b/lisp/url/url-vars.el
@@ -116,6 +116,7 @@ If a list, this should be a list of symbols of what NOT to send.
Valid symbols are:
email -- the email address
os -- the operating system info
+emacs -- the version of Emacs
lastloc -- the last location
agent -- do not send the User-Agent string
cookies -- never accept HTTP cookies
@@ -143,6 +144,7 @@ variable."
(checklist :tag "Custom"
(const :tag "Email address" :value email)
(const :tag "Operating system" :value os)
+ (const :tag "Emacs version" :value emacs)
(const :tag "Last location" :value lastloc)
(const :tag "Browser identification" :value agent)
(const :tag "No cookies" :value cookie)))
@@ -357,16 +359,21 @@ Currently supported methods:
(const :tag "Direct connection" :value native))
:group 'url-hairy)
-(defcustom url-user-agent (format "User-Agent: %sURL/%s\r\n"
- (if url-package-name
- (concat url-package-name "/"
- url-package-version " ")
- "") url-version)
- "User Agent used by the URL package for HTTP/HTTPS requests
-Should be a string or a function of no arguments returning a string."
- :type '(choice (string :tag "A static User-Agent string")
- (function :tag "Call a function to get the User-Agent string"))
- :version "25.1"
+(defcustom url-user-agent 'default
+ "User Agent used by the URL package for HTTP/HTTPS requests.
+Should be one of:
+* A string (not including the \"User-Agent:\" prefix)
+* A function of no arguments, returning a string
+* `default' (to compute a value according to `url-privacy-level')
+* nil (to omit the User-Agent header entirely)"
+ :type
+ '(choice
+ (string :tag "A static User-Agent string")
+ (function :tag "Call a function to get the User-Agent string")
+ (const :tag "No User-Agent at all" :value nil)
+ (const :tag "An string auto-generated according to `url-privacy-level'"
+ :value default))
+ :version "26.1"
:group 'url)
(defvar url-setup-done nil "Has setup configuration been done?")
diff --git a/lisp/url/url.el b/lisp/url/url.el
index 91adada5e85..6d710e02d63 100644
--- a/lisp/url/url.el
+++ b/lisp/url/url.el
@@ -221,17 +221,20 @@ URL-encoded before it's used."
buffer))
;;;###autoload
-(defun url-retrieve-synchronously (url &optional silent inhibit-cookies)
+(defun url-retrieve-synchronously (url &optional silent inhibit-cookies timeout)
"Retrieve URL synchronously.
Return the buffer containing the data, or nil if there are no data
associated with it (the case for dired, info, or mailto URLs that need
no further processing). URL is either a string or a parsed URL.
-If SILENT is non-nil, don't display progress reports and similar messages.
-If INHIBIT-COOKIES is non-nil, cookies will neither be stored nor sent
-to the server."
+
+If SILENT is non-nil, don't do any messaging while retrieving.
+If INHIBIT-COOKIES is non-nil, refuse to store cookies. If
+TIMEOUT is passed, it should be a number that says (in seconds)
+how long to wait for a response before giving up."
(url-do-setup)
(let ((retrieval-done nil)
+ (start-time (current-time))
(asynch-buffer nil))
(setq asynch-buffer
(url-retrieve url (lambda (&rest ignored)
@@ -253,7 +256,11 @@ to the server."
;; buffer-local variable so we can find the exact process that we
;; should be waiting for. In the mean time, we'll just wait for any
;; process output.
- (while (not retrieval-done)
+ (while (and (not retrieval-done)
+ (or (not timeout)
+ (< (float-time (time-subtract
+ (current-time) start-time))
+ timeout)))
(url-debug 'retrieval
"Spinning in url-retrieve-synchronously: %S (%S)"
retrieval-done asynch-buffer)
@@ -284,7 +291,7 @@ to the server."
;; `sleep-for' was tried but it lead to other forms of
;; hanging. --Stef
(unless (or (with-local-quit
- (accept-process-output proc))
+ (accept-process-output proc 1))
(null proc))
;; accept-process-output returned nil, maybe because the process
;; exited (and may have been replaced with another). If we got
generated by cgit v1.2.3 (git 2.39.1) at 2025-04-08 04:42:29 +0000