summaryrefslogtreecommitdiff
path: root/lisp/url
diff options
context:
space:
mode:
Diffstat (limited to 'lisp/url')
-rw-r--r--lisp/url/url-auth.el6
-rw-r--r--lisp/url/url-cache.el12
-rw-r--r--lisp/url/url-cookie.el106
-rw-r--r--lisp/url/url-dav.el26
-rw-r--r--lisp/url/url-dired.el5
-rw-r--r--lisp/url/url-file.el26
-rw-r--r--lisp/url/url-gw.el8
-rw-r--r--lisp/url/url-handlers.el18
-rw-r--r--lisp/url/url-http.el130
-rw-r--r--lisp/url/url-methods.el4
-rw-r--r--lisp/url/url-privacy.el6
-rw-r--r--lisp/url/url-queue.el18
-rw-r--r--lisp/url/url-util.el28
-rw-r--r--lisp/url/url-vars.el28
-rw-r--r--lisp/url/url.el3
15 files changed, 300 insertions, 124 deletions
diff --git a/lisp/url/url-auth.el b/lisp/url/url-auth.el
index c3714f26562..1ef73a62c02 100644
--- a/lisp/url/url-auth.el
+++ b/lisp/url/url-auth.el
@@ -192,9 +192,11 @@ key cache `url-digest-auth-storage'."
(defun url-digest-auth-make-cnonce ()
"Compute a new unique client nonce value."
(base64-encode-string
- (apply 'format "%016x%04x%04x%05x%05x" (random) (current-time)) t))
+ (apply #'format "%016x%08x%08x" (random)
+ (read (format-time-string "(%s %N)")))
+ t))
-(defun url-digest-auth-nonce-count (nonce)
+(defun url-digest-auth-nonce-count (_nonce)
"The number requests sent to server with the given NONCE.
This count includes the request we're preparing here.
diff --git a/lisp/url/url-cache.el b/lisp/url/url-cache.el
index 01e57799cc6..66a7223bc89 100644
--- a/lisp/url/url-cache.el
+++ b/lisp/url/url-cache.el
@@ -86,10 +86,10 @@ FILE can be created or overwritten."
The actual return value is the last modification time of the cache file."
(let* ((fname (url-cache-create-filename url))
(attribs (file-attributes fname)))
- (and fname ; got a filename
- (file-exists-p fname) ; file exists
- (not (eq (nth 0 attribs) t)) ; Its not a directory
- (nth 5 attribs)))) ; Can get last mod-time
+ (and fname
+ (file-exists-p fname)
+ (not (eq (file-attribute-type attribs) t))
+ (file-attribute-modification-time attribs))))
(defun url-cache-create-filename-human-readable (url)
"Return a filename in the local cache for URL."
@@ -206,7 +206,7 @@ If `url-standalone-mode' is non-nil, cached items never expire."
(time-add
cache-time
(seconds-to-time (or expire-time url-cache-expire-time)))
- (current-time))))))
+ nil)))))
(defun url-cache-prune-cache (&optional directory)
"Remove all expired files from the cache.
@@ -226,7 +226,7 @@ considered \"expired\"."
(setq deleted-files (1+ deleted-files))))
((time-less-p
(time-add
- (nth 5 (file-attributes file))
+ (file-attribute-modification-time (file-attributes file))
(seconds-to-time url-cache-expire-time))
now)
(delete-file file)
diff --git a/lisp/url/url-cookie.el b/lisp/url/url-cookie.el
index 61fd85bbf1e..0c276388185 100644
--- a/lisp/url/url-cookie.el
+++ b/lisp/url/url-cookie.el
@@ -74,6 +74,55 @@ telling Microsoft that."
;; It's completely normal for the cookies file not to exist yet.
(load (or fname url-cookie-file) t t))
+(defun url-cookie-parse-file-netscape (filename &optional long-session)
+ "Load cookies from FILENAME in Netscape/Mozilla format.
+When LONG-SESSION is non-nil, session cookies (expiring at t=0
+i.e. 1970-1-1) are loaded as expiring one year from now instead."
+ (interactive "fLoad Netscape/Mozilla cookie file: ")
+ (let ((n 0))
+ (with-temp-buffer
+ (insert-file-contents-literally filename)
+ (goto-char (point-min))
+ (when (not (looking-at-p "# Netscape HTTP Cookie File\n"))
+ (error (format "File %s doesn't look like a netscape cookie file" filename)))
+ (while (not (eobp))
+ (when (not (looking-at-p (rx bol (* space) "#")))
+ (let* ((line (buffer-substring (point) (save-excursion (end-of-line) (point))))
+ (fields (split-string line "\t")))
+ (cond
+ ;;((>= 1 (length line) 0)
+ ;; (message "skipping empty line"))
+ ((= (length fields) 7)
+ (let ((dom (nth 0 fields))
+ ;; (match (nth 1 fields))
+ (path (nth 2 fields))
+ (secure (string= (nth 3 fields) "TRUE"))
+ ;; session cookies (expire time = 0) are supposed
+ ;; to be removed when the browser is closed, but
+ ;; the main point of loading external cookie is to
+ ;; reuse a browser session, so to prevent the
+ ;; cookie from being detected as expired straight
+ ;; away, make it expire a year from now
+ (expires (format-time-string
+ "%d %b %Y %T [GMT]"
+ (seconds-to-time
+ (let ((s (string-to-number (nth 4 fields))))
+ (if (and (= s 0) long-session)
+ (seconds-to-time (+ (* 365 24 60 60) (float-time)))
+ s)))))
+ (key (nth 5 fields))
+ (val (nth 6 fields)))
+ (cl-incf n)
+ ;;(message "adding <%s>=<%s> exp=<%s> dom=<%s> path=<%s> sec=%S" key val expires dom path secure)
+ (url-cookie-store key val expires dom path secure)
+ ))
+ (t
+ (message "ignoring malformed cookie line <%s>" line)))))
+ (forward-line))
+ (when (< 0 n)
+ (setq url-cookies-changed-since-last-save t))
+ (message "added %d cookies from file %s" n filename))))
+
(defun url-cookie-clean-up (&optional secure)
(let ((var (if secure 'url-cookie-secure-storage 'url-cookie-storage))
new new-cookies)
@@ -90,7 +139,8 @@ telling Microsoft that."
(set var new)))
(defun url-cookie-write-file (&optional fname)
- (when url-cookies-changed-since-last-save
+ (when (and url-cookies-changed-since-last-save
+ url-cookie-file)
(or fname (setq fname (expand-file-name url-cookie-file)))
(if (condition-case nil
(progn
@@ -345,6 +395,8 @@ instead delete all cookies that do not match REGEXP."
;;; Mode for listing and editing cookies.
+(defvar url-cookie--deleted-cookies nil)
+
(defun url-cookie-list ()
"Display a buffer listing the current URL cookies, if there are any.
Use \\<url-cookie-mode-map>\\[url-cookie-delete] to remove cookies."
@@ -354,6 +406,11 @@ Use \\<url-cookie-mode-map>\\[url-cookie-delete] to remove cookies."
(error "No cookies are defined"))
(pop-to-buffer "*url cookies*")
+ (url-cookie-mode)
+ (url-cookie--generate-buffer)
+ (goto-char (point-min)))
+
+(defun url-cookie--generate-buffer ()
(let ((inhibit-read-only t)
(domains (sort
(copy-sequence
@@ -364,7 +421,6 @@ Use \\<url-cookie-mode-map>\\[url-cookie-delete] to remove cookies."
(domain-length 0)
start name format domain)
(erase-buffer)
- (url-cookie-mode)
(dolist (elem domains)
(setq domain-length (max domain-length (length (car elem)))))
(setq format (format "%%-%ds %%-20s %%s" domain-length)
@@ -376,16 +432,15 @@ Use \\<url-cookie-mode-map>\\[url-cookie-delete] to remove cookies."
(lambda (c1 c2)
(string< (url-cookie-name c1)
(url-cookie-name c2)))))
- (setq start (point)
+ (setq start (point)
name (url-cookie-name cookie))
- (when (> (length name) 20)
+ (when (> (length name) 20)
(setq name (substring name 0 20)))
- (insert (format format domain name
- (url-cookie-value cookie))
- "\n")
- (setq domain "")
- (put-text-property start (1+ start) 'url-cookie cookie)))
- (goto-char (point-min))))
+ (insert (format format domain name
+ (url-cookie-value cookie))
+ "\n")
+ (setq domain "")
+ (put-text-property start (1+ start) 'url-cookie cookie)))))
(defun url-cookie-delete ()
"Delete the cookie on the current line."
@@ -409,12 +464,41 @@ Use \\<url-cookie-mode-map>\\[url-cookie-delete] to remove cookies."
(delete-region (line-beginning-position)
(progn
(forward-line 1)
- (point)))))
+ (point)))
+ (let ((point (point)))
+ (erase-buffer)
+ (url-cookie--generate-buffer)
+ (goto-char point))
+ (push cookie url-cookie--deleted-cookies)))
+
+(defun url-cookie-undo ()
+ "Undo deletion of a cookie."
+ (interactive)
+ (unless url-cookie--deleted-cookies
+ (error "No cookie deletions to undo"))
+ (let* ((cookie (pop url-cookie--deleted-cookies))
+ (variable (if (url-cookie-secure cookie)
+ 'url-cookie-secure-storage
+ 'url-cookie-storage))
+ (list (symbol-value variable))
+ (elem (assoc (url-cookie-domain cookie) list)))
+ (if elem
+ (nconc elem (list cookie))
+ (setq elem (list (url-cookie-domain cookie) cookie))
+ (set variable (cons elem list)))
+ (setq url-cookies-changed-since-last-save t)
+ (url-cookie-write-file)
+ (let ((point (point))
+ (inhibit-read-only t))
+ (erase-buffer)
+ (url-cookie--generate-buffer)
+ (goto-char point))))
(defvar url-cookie-mode-map
(let ((map (make-sparse-keymap)))
(define-key map [delete] 'url-cookie-delete)
(define-key map [(control k)] 'url-cookie-delete)
+ (define-key map [(control _)] 'url-cookie-undo)
map))
(define-derived-mode url-cookie-mode special-mode "URL Cookie"
diff --git a/lisp/url/url-dav.el b/lisp/url/url-dav.el
index f2182e39e65..2cc2b189a1d 100644
--- a/lisp/url/url-dav.el
+++ b/lisp/url/url-dav.el
@@ -204,22 +204,22 @@ Returns nil if WebDAV is not supported."
value nil)
(pcase node-type
- ((or `dateTime.iso8601tz
- `dateTime.iso8601
- `dateTime.tz
- `dateTime.rfc1123
- `dateTime
- `date) ; date is our 'special' one...
+ ((or 'dateTime.iso8601tz
+ 'dateTime.iso8601
+ 'dateTime.tz
+ 'dateTime.rfc1123
+ 'dateTime
+ 'date) ; date is our 'special' one...
;; Some type of date/time string.
(setq value (url-dav-process-date-property node)))
- (`int
+ ('int
;; Integer type...
(setq value (url-dav-process-integer-property node)))
- ((or `number `float)
+ ((or 'number 'float)
(setq value (url-dav-process-number-property node)))
- (`boolean
+ ('boolean
(setq value (url-dav-process-boolean-property node)))
- (`uri
+ ('uri
(setq value (url-dav-process-uri-property node)))
(_
(if (not (eq node-type 'unknown))
@@ -611,11 +611,11 @@ Returns t if the lock was successfully released."
(setq lock (car supported-locks)
supported-locks (cdr supported-locks))
(pcase (car lock)
- (`DAV:write
+ ('DAV:write
(pcase (cdr lock)
- (`DAV:shared ; group permissions (possibly world)
+ ('DAV:shared ; group permissions (possibly world)
(aset modes 5 ?w))
- (`DAV:exclusive
+ ('DAV:exclusive
(aset modes 2 ?w)) ; owner permissions?
(_
(url-debug 'dav "Unrecognized DAV:lockscope (%S)" (cdr lock)))))
diff --git a/lisp/url/url-dired.el b/lisp/url/url-dired.el
index 0d7f22b61c5..a665db86fef 100644
--- a/lisp/url/url-dired.el
+++ b/lisp/url/url-dired.el
@@ -43,10 +43,7 @@
(url-dired-find-file))
(define-minor-mode url-dired-minor-mode
- "Minor mode for directory browsing.
-With a prefix argument ARG, enable the mode if ARG is positive,
-and disable it otherwise. If called from Lisp, enable the mode
-if ARG is omitted or nil."
+ "Minor mode for directory browsing."
:lighter " URL" :keymap url-dired-minor-mode-map)
(defun url-find-file-dired (dir)
diff --git a/lisp/url/url-file.el b/lisp/url/url-file.el
index 23fc97828ff..b953ce76940 100644
--- a/lisp/url/url-file.el
+++ b/lisp/url/url-file.el
@@ -1,4 +1,4 @@
-;;; url-file.el --- File retrieval code
+;;; url-file.el --- File retrieval code -*- lexical-binding:t -*-
;; Copyright (C) 1996-1999, 2004-2019 Free Software Foundation, Inc.
@@ -33,7 +33,7 @@
(defconst url-file-asynchronous-p t "FTP transfers are asynchronous.")
(defalias 'url-file-expand-file-name 'url-default-expander)
-(defun url-file-find-possibly-compressed-file (fname &rest args)
+(defun url-file-find-possibly-compressed-file (fname &rest _)
"Find the exact file referenced by `fname'.
This tries the common compression extensions, because things like
ange-ftp and efs are not quite smart enough to realize when a server
@@ -63,14 +63,14 @@ to them."
(match-beginning 0))
(system-name)))))))
-(defun url-file-asynch-callback (x y name buff func args &optional efs)
+(defun url-file-asynch-callback (_x _y name buff func args &optional efs)
(if (not (featurep 'ange-ftp))
;; EFS passes us an extra argument
(setq name buff
buff func
func args
args efs))
- (let ((size (nth 7 (file-attributes name))))
+ (let ((size (file-attribute-size (file-attributes name))))
(with-current-buffer buff
(goto-char (point-max))
(if (/= -1 size)
@@ -114,8 +114,7 @@ to them."
((string-match "\\`/[^/]+:/" file)
(concat "/:" file))
(t
- file)))
- pos-index)
+ file))))
(and user pass
(cond
@@ -142,17 +141,6 @@ to them."
(not (string-match "/\\'" filename)))
(setf (url-filename url) (format "%s/" filename)))
-
- ;; If it is a directory, look for an index file first.
- (if (and (file-directory-p filename)
- url-directory-index-file
- (setq pos-index (expand-file-name url-directory-index-file filename))
- (file-exists-p pos-index)
- (file-readable-p pos-index))
- (setq filename pos-index))
-
- ;; Find the (possibly compressed) file
- (setq filename (url-file-find-possibly-compressed-file filename))
filename))
;;;###autoload
@@ -211,7 +199,7 @@ to them."
(if (featurep 'ange-ftp)
(ange-ftp-copy-file-internal filename (expand-file-name new) t
nil t
- (list 'url-file-asynch-callback
+ (list #'url-file-asynch-callback
new (current-buffer)
callback cbargs)
t)
@@ -220,7 +208,7 @@ to them."
(efs-copy-file-internal filename (efs-ftp-path filename)
new (efs-ftp-path new)
t nil 0
- (list 'url-file-asynch-callback
+ (list #'url-file-asynch-callback
new (current-buffer)
callback cbargs)
0 nil)))))))
diff --git a/lisp/url/url-gw.el b/lisp/url/url-gw.el
index c62e813b663..54360840784 100644
--- a/lisp/url/url-gw.el
+++ b/lisp/url/url-gw.el
@@ -239,7 +239,7 @@ overriding the value of `url-gateway-method'."
(let ((coding-system-for-read 'binary)
(coding-system-for-write 'binary))
(setq conn (pcase gw-method
- ((or `tls `ssl `native)
+ ((or 'tls 'ssl 'native)
(if (eq gw-method 'native)
(setq gw-method 'plain))
(open-network-stream
@@ -249,11 +249,11 @@ overriding the value of `url-gateway-method'."
:nowait (and (featurep 'make-network-process)
(url-asynchronous url-current-object)
'(:nowait t))))
- (`socks
+ ('socks
(socks-open-network-stream name buffer host service))
- (`telnet
+ ('telnet
(url-open-telnet name buffer host service))
- (`rlogin
+ ('rlogin
(url-open-rlogin name buffer host service))
(_
(error "Bad setting of url-gateway-method: %s"
diff --git a/lisp/url/url-handlers.el b/lisp/url/url-handlers.el
index 3af4e9e7b19..2d0a4a21c44 100644
--- a/lisp/url/url-handlers.el
+++ b/lisp/url/url-handlers.el
@@ -28,6 +28,7 @@
;; (require 'url-util)
(eval-when-compile (require 'mm-decode))
;; (require 'mailcap)
+(eval-when-compile (require 'subr-x))
;; The following are autoloaded instead of `require'd to avoid eagerly
;; loading all of URL when turning on url-handler-mode in the .emacs.
(autoload 'url-expand-file-name "url-expand" "Convert url to a fully specified url, and canonicalize it.")
@@ -41,6 +42,9 @@
(declare-function mm-decode-string "mm-bodies" (string charset))
;; mm-decode loads mail-parse.
(declare-function mail-content-type-get "mail-parse" (ct attribute))
+;; mm-decode loads mm-bodies, which loads mm-util.
+(declare-function mm-charset-to-coding-system "mm-util"
+ (charset &optional lbt allow-override silent))
;; Implementation status
;; ---------------------
@@ -98,10 +102,7 @@
;;;###autoload
(define-minor-mode url-handler-mode
- "Toggle using `url' library for URL filenames (URL Handler mode).
-With a prefix argument ARG, enable URL Handler mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-the mode if ARG is omitted or nil."
+ "Toggle using `url' library for URL filenames (URL Handler mode)."
:global t :group 'url
;; Remove old entry, if any.
(setq file-name-handler-alist
@@ -183,6 +184,7 @@ the arguments that would have been passed to OPERATION."
(put 'file-name-absolute-p 'url-file-handlers (lambda (&rest ignored) t))
(put 'expand-file-name 'url-file-handlers 'url-handler-expand-file-name)
(put 'directory-file-name 'url-file-handlers 'url-handler-directory-file-name)
+(put 'file-name-directory 'url-file-handlers 'url-handler-file-name-directory)
(put 'unhandled-file-name-directory 'url-file-handlers 'url-handler-unhandled-file-name-directory)
(put 'file-remote-p 'url-file-handlers 'url-handler-file-remote-p)
;; (put 'file-name-as-directory 'url-file-handlers 'url-handler-file-name-as-directory)
@@ -228,6 +230,14 @@ the arguments that would have been passed to OPERATION."
;; a local process.
nil)))
+(defun url-handler-file-name-directory (dir)
+ (let ((url (url-generic-parse-url dir)))
+ ;; Do not attempt to handle `file' URLs which are local.
+ (if (and (not (equal (url-type url) "file"))
+ (string-empty-p (url-filename url)))
+ (url-handler-file-name-directory (concat dir "/"))
+ (url-run-real-handler 'file-name-directory (list dir)))))
+
(defun url-handler-file-remote-p (filename &optional identification _connected)
(let ((url (url-generic-parse-url filename)))
(if (and (url-type url) (not (equal (url-type url) "file")))
diff --git a/lisp/url/url-http.el b/lisp/url/url-http.el
index 1bcfc10645d..76faac13808 100644
--- a/lisp/url/url-http.el
+++ b/lisp/url/url-http.el
@@ -54,6 +54,7 @@
(defvar url-http-target-url)
(defvar url-http-transfer-encoding)
(defvar url-show-status)
+(defvar url-http-referer)
(require 'url-gw)
(require 'url-parse)
@@ -238,6 +239,35 @@ request.")
emacs-info os-info))
" ")))
+(defun url-http--get-referer (url)
+ (url-http-debug "getting referer from buffer: buffer:%S target-url:%S lastloc:%S" (current-buffer) url url-current-lastloc)
+ (when url-current-lastloc
+ (if (not (url-p url-current-lastloc))
+ (setq url-current-lastloc (url-generic-parse-url url-current-lastloc)))
+ (let ((referer (copy-sequence url-current-lastloc)))
+ (setf (url-host referer) (puny-encode-domain (url-host referer)))
+ (let ((referer-string (url-recreate-url referer)))
+ (when (and (not (memq url-privacy-level '(low high paranoid)))
+ (not (and (listp url-privacy-level)
+ (memq 'lastloc url-privacy-level))))
+ ;; url-privacy-level allows referer. But url-lastloc-privacy-level
+ ;; may restrict who we send it to.
+ (cl-case url-lastloc-privacy-level
+ (host-match
+ (let ((referer-host (url-host referer))
+ (url-host (url-host url)))
+ (when (string= referer-host url-host)
+ referer-string)))
+ (domain-match
+ (let ((referer-domain (url-domain referer))
+ (url-domain (url-domain url)))
+ (when (and referer-domain
+ url-domain
+ (string= referer-domain url-domain))
+ referer-string)))
+ (otherwise
+ referer-string)))))))
+
;; Building an HTTP request
(defun url-http-user-agent-string ()
"Compute a User-Agent string.
@@ -254,8 +284,9 @@ The string is based on `url-privacy-level' and `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."
+(defun url-http-create-request ()
+ "Create an HTTP request for `url-http-target-url'.
+Use `url-http-referer' as the Referer-header (subject to `url-privacy-level')."
(let* ((extra-headers)
(request nil)
(no-cache (cdr-safe (assoc "Pragma" url-http-extra-headers)))
@@ -268,13 +299,14 @@ The string is based on `url-privacy-level' and `url-user-agent'."
'url-http-proxy-basic-auth-storage))
(url-get-authentication url-http-proxy nil 'any nil))))
(real-fname (url-filename url-http-target-url))
- (host (url-http--encode-string (url-host url-http-target-url)))
+ (host (url-host url-http-target-url))
(auth (if (cdr-safe (assoc "Authorization" url-http-extra-headers))
nil
(url-get-authentication (or
(and (boundp 'proxy-info)
proxy-info)
- url-http-target-url) nil 'any nil))))
+ url-http-target-url) nil 'any nil)))
+ (ref-url (url-http--encode-string url-http-referer)))
(if (equal "" real-fname)
(setq real-fname "/"))
(setq no-cache (and no-cache (string-match "no-cache" no-cache)))
@@ -288,12 +320,6 @@ The string is based on `url-privacy-level' and `url-user-agent'."
(string= ref-url "")))
(setq ref-url nil))
- ;; We do not want to expose the referrer if the user is paranoid.
- (if (or (memq url-privacy-level '(low high paranoid))
- (and (listp url-privacy-level)
- (memq 'lastloc url-privacy-level)))
- (setq ref-url nil))
-
;; url-http-extra-headers contains an assoc-list of
;; header/value pairs that we need to put into the request.
(setq extra-headers (mapconcat
@@ -329,9 +355,11 @@ The string is based on `url-privacy-level' and `url-user-agent'."
(url-scheme-get-property
(url-type url-http-target-url) 'default-port))
(format
- "Host: %s:%d\r\n" (puny-encode-domain host)
+ "Host: %s:%d\r\n" (url-http--encode-string
+ (puny-encode-domain host))
(url-port url-http-target-url))
- (format "Host: %s\r\n" (puny-encode-domain host)))
+ (format "Host: %s\r\n"
+ (url-http--encode-string (puny-encode-domain host))))
;; Who its from
(if url-personal-mail-address
(concat
@@ -585,7 +613,7 @@ should be shown to the user."
;; 206 Partial content
;; 207 Multi-status (Added by DAV)
(pcase status-symbol
- ((or `no-content `reset-content)
+ ((or 'no-content 'reset-content)
;; No new data, just stay at the same document
(url-mark-buffer-as-dead buffer))
(_
@@ -606,7 +634,7 @@ should be shown to the user."
(let ((redirect-uri (or (mail-fetch-field "Location")
(mail-fetch-field "URI"))))
(pcase status-symbol
- (`multiple-choices ; 300
+ ('multiple-choices ; 300
;; Quoth the spec (section 10.3.1)
;; -------------------------------
;; The requested resource corresponds to any one of a set of
@@ -623,20 +651,26 @@ 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)
- (`see-other ; 303
+ ('found ; 302
+ ;; 302 Found was ambiguously defined in the standards, but
+ ;; it's now recommended that it's treated like 303 instead
+ ;; of 307, since that's what most servers expect.
+ (setq url-http-method "GET"
+ url-http-data nil))
+ ('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.
(setq url-http-method "GET"
url-http-data nil))
- (`not-modified ; 304
+ ('not-modified ; 304
;; The 304 response MUST NOT contain a message-body.
(url-http-debug "Extracting document from cache... (%s)"
(url-cache-create-filename (url-view-url t)))
(url-cache-extract (url-cache-create-filename (url-view-url t)))
(setq redirect-uri nil
success t))
- (`use-proxy ; 305
+ ('use-proxy ; 305
;; The requested resource MUST be accessed through the
;; proxy given by the Location field. The Location field
;; gives the URI of the proxy. The recipient is expected
@@ -734,50 +768,50 @@ should be shown to the user."
;; 424 Failed Dependency
(setq success
(pcase status-symbol
- (`unauthorized ; 401
+ ('unauthorized ; 401
;; The request requires user authentication. The response
;; MUST include a WWW-Authenticate header field containing a
;; challenge applicable to the requested resource. The
;; client MAY repeat the request with a suitable
;; Authorization header field.
(url-http-handle-authentication nil))
- (`payment-required ; 402
+ ('payment-required ; 402
;; This code is reserved for future use
(url-mark-buffer-as-dead buffer)
(error "Somebody wants you to give them money"))
- (`forbidden ; 403
+ ('forbidden ; 403
;; The server understood the request, but is refusing to
;; fulfill it. Authorization will not help and the request
;; SHOULD NOT be repeated.
t)
- (`not-found ; 404
+ ('not-found ; 404
;; Not found
t)
- (`method-not-allowed ; 405
+ ('method-not-allowed ; 405
;; The method specified in the Request-Line is not allowed
;; for the resource identified by the Request-URI. The
;; response MUST include an Allow header containing a list of
;; valid methods for the requested resource.
t)
- (`not-acceptable ; 406
+ ('not-acceptable ; 406
;; The resource identified by the request is only capable of
;; generating response entities which have content
;; characteristics not acceptable according to the accept
;; headers sent in the request.
t)
- (`proxy-authentication-required ; 407
+ ('proxy-authentication-required ; 407
;; This code is similar to 401 (Unauthorized), but indicates
;; that the client must first authenticate itself with the
;; proxy. The proxy MUST return a Proxy-Authenticate header
;; field containing a challenge applicable to the proxy for
;; the requested resource.
(url-http-handle-authentication t))
- (`request-timeout ; 408
+ ('request-timeout ; 408
;; The client did not produce a request within the time that
;; the server was prepared to wait. The client MAY repeat
;; the request without modifications at any later time.
t)
- (`conflict ; 409
+ ('conflict ; 409
;; The request could not be completed due to a conflict with
;; the current state of the resource. This code is only
;; allowed in situations where it is expected that the user
@@ -786,11 +820,11 @@ should be shown to the user."
;; information for the user to recognize the source of the
;; conflict.
t)
- (`gone ; 410
+ ('gone ; 410
;; The requested resource is no longer available at the
;; server and no forwarding address is known.
t)
- (`length-required ; 411
+ ('length-required ; 411
;; The server refuses to accept the request without a defined
;; Content-Length. The client MAY repeat the request if it
;; adds a valid Content-Length header field containing the
@@ -800,29 +834,29 @@ should be shown to the user."
;; `url-http-create-request' automatically calculates the
;; content-length.
t)
- (`precondition-failed ; 412
+ ('precondition-failed ; 412
;; The precondition given in one or more of the
;; request-header fields evaluated to false when it was
;; tested on the server.
t)
- ((or `request-entity-too-large `request-uri-too-large) ; 413 414
+ ((or 'request-entity-too-large 'request-uri-too-large) ; 413 414
;; The server is refusing to process a request because the
;; request entity|URI is larger than the server is willing or
;; able to process.
t)
- (`unsupported-media-type ; 415
+ ('unsupported-media-type ; 415
;; The server is refusing to service the request because the
;; entity of the request is in a format not supported by the
;; requested resource for the requested method.
t)
- (`requested-range-not-satisfiable ; 416
+ ('requested-range-not-satisfiable ; 416
;; A server SHOULD return a response with this status code if
;; a request included a Range request-header field, and none
;; of the range-specifier values in this field overlap the
;; current extent of the selected resource, and the request
;; did not include an If-Range request-header field.
t)
- (`expectation-failed ; 417
+ ('expectation-failed ; 417
;; The expectation given in an Expect request-header field
;; could not be met by this server, or, if the server is a
;; proxy, the server has unambiguous evidence that the
@@ -849,16 +883,16 @@ should be shown to the user."
;; 507 Insufficient storage
(setq success t)
(pcase url-http-response-status
- (`not-implemented ; 501
+ ('not-implemented ; 501
;; The server does not support the functionality required to
;; fulfill the request.
nil)
- (`bad-gateway ; 502
+ ('bad-gateway ; 502
;; The server, while acting as a gateway or proxy, received
;; an invalid response from the upstream server it accessed
;; in attempting to fulfill the request.
nil)
- (`service-unavailable ; 503
+ ('service-unavailable ; 503
;; The server is currently unable to handle the request due
;; to a temporary overloading or maintenance of the server.
;; The implication is that this is a temporary condition
@@ -867,19 +901,19 @@ should be shown to the user."
;; header. If no Retry-After is given, the client SHOULD
;; handle the response as it would for a 500 response.
nil)
- (`gateway-timeout ; 504
+ ('gateway-timeout ; 504
;; The server, while acting as a gateway or proxy, did not
;; receive a timely response from the upstream server
;; specified by the URI (e.g. HTTP, FTP, LDAP) or some other
;; auxiliary server (e.g. DNS) it needed to access in
;; attempting to complete the request.
nil)
- (`http-version-not-supported ; 505
+ ('http-version-not-supported ; 505
;; The server does not support, or refuses to support, the
;; HTTP protocol version that was used in the request
;; message.
nil)
- (`insufficient-storage ; 507 (DAV)
+ ('insufficient-storage ; 507 (DAV)
;; The method could not be performed on the resource
;; because the server is unable to store the representation
;; needed to successfully complete the request. This
@@ -1258,7 +1292,8 @@ The return value of this function is the retrieval buffer."
(mime-accept-string url-mime-accept-string)
(buffer (or retry-buffer
(generate-new-buffer
- (format " *http %s:%d*" (url-host url) (url-port url))))))
+ (format " *http %s:%d*" (url-host url) (url-port url)))))
+ (referer (url-http--encode-string (url-http--get-referer url))))
(if (not connection)
;; Failed to open the connection for some reason
(progn
@@ -1293,7 +1328,8 @@ The return value of this function is the retrieval buffer."
url-http-no-retry
url-http-connection-opened
url-mime-accept-string
- url-http-proxy))
+ url-http-proxy
+ url-http-referer))
(set (make-local-variable var) nil))
(setq url-http-method (or url-request-method "GET")
@@ -1311,15 +1347,16 @@ The return value of this function is the retrieval buffer."
url-http-no-retry retry-buffer
url-http-connection-opened nil
url-mime-accept-string mime-accept-string
- url-http-proxy url-using-proxy)
+ url-http-proxy url-using-proxy
+ url-http-referer referer)
(set-process-buffer connection buffer)
(set-process-filter connection 'url-http-generic-filter)
(pcase (process-status connection)
- (`connect
+ ('connect
;; Asynchronous connection
(set-process-sentinel connection 'url-http-async-sentinel))
- (`failed
+ ('failed
;; Asynchronous connection failed
(error "Could not create connection to %s:%d" (url-host url)
(url-port url)))
@@ -1375,7 +1412,9 @@ The return value of this function is the retrieval buffer."
'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)))
+ ;; Use the non-proxy form of the request
+ (let (url-http-proxy)
+ (url-http-create-request))))
(gnutls-error
(url-http-activate-callback)
(error "gnutls-error: %s" e))
@@ -1563,7 +1602,6 @@ p3p
;; HTTPS. This used to be in url-https.el, but that file collides
;; with url-http.el on systems with 8-character file names.
-(require 'tls)
(defconst url-https-asynchronous-p t "HTTPS retrievals are asynchronous.")
diff --git a/lisp/url/url-methods.el b/lisp/url/url-methods.el
index 456be7ed4f7..1c0c5af86ac 100644
--- a/lisp/url/url-methods.el
+++ b/lisp/url/url-methods.el
@@ -134,11 +134,11 @@ it has not already been loaded."
(type (cdr cell)))
(if symbol
(pcase type
- (`function
+ ('function
;; Store the symbol name of a function
(if (fboundp symbol)
(setq desc (plist-put desc (car cell) symbol))))
- (`variable
+ ('variable
;; Store the VALUE of a variable
(if (boundp symbol)
(setq desc (plist-put desc (car cell)
diff --git a/lisp/url/url-privacy.el b/lisp/url/url-privacy.el
index 994ae6ac5da..ef9ff84d56e 100644
--- a/lisp/url/url-privacy.el
+++ b/lisp/url/url-privacy.el
@@ -45,9 +45,9 @@
((memq (url-device-type) '(win32 w32)) "Windows; 32bit")
(t
(pcase (url-device-type)
- (`x "X11")
- (`ns "OpenStep")
- (`tty "TTY")
+ ('x "X11")
+ ('ns "OpenStep")
+ ('tty "TTY")
(_ nil)))))
(setq url-personal-mail-address (or url-personal-mail-address
diff --git a/lisp/url/url-queue.el b/lisp/url/url-queue.el
index 38137b85e40..6350081b1a3 100644
--- a/lisp/url/url-queue.el
+++ b/lisp/url/url-queue.el
@@ -52,7 +52,7 @@
(cl-defstruct url-queue
url callback cbargs silentp
buffer start-time pre-triggered
- inhibit-cookiesp)
+ inhibit-cookiesp context-buffer)
;;;###autoload
(defun url-queue-retrieve (url callback &optional cbargs silent inhibit-cookies)
@@ -67,7 +67,8 @@ The variable `url-queue-timeout' sets a timeout."
:callback callback
:cbargs cbargs
:silentp silent
- :inhibit-cookiesp inhibit-cookies))))
+ :inhibit-cookiesp inhibit-cookies
+ :context-buffer (current-buffer)))))
(url-queue-setup-runners))
;; To ensure asynch behavior, we start the required number of queue
@@ -147,11 +148,14 @@ The variable `url-queue-timeout' sets a timeout."
(defun url-queue-start-retrieve (job)
(setf (url-queue-buffer job)
(ignore-errors
- (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))))))
+ (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)
diff --git a/lisp/url/url-util.el b/lisp/url/url-util.el
index 11ee15fdd4e..1ca257210aa 100644
--- a/lisp/url/url-util.el
+++ b/lisp/url/url-util.el
@@ -627,6 +627,34 @@ Creates FILE and its parent directories if they do not exist."
(error "Danger: `%s' is a symbolic link" file))
(set-file-modes file #o0600))))
+(autoload 'puny-encode-domain "puny")
+(autoload 'url-domsuf-cookie-allowed-p "url-domsuf")
+
+;;;###autoload
+(defun url-domain (url)
+ "Return the domain of the host of the URL.
+Return nil if this can't be determined.
+
+For instance, this function will return \"fsf.co.uk\" if the host in URL
+is \"www.fsf.co.uk\"."
+ (let* ((host (puny-encode-domain (url-host url)))
+ (parts (nreverse (split-string host "\\.")))
+ (candidate (pop parts))
+ found)
+ ;; IP addresses aren't domains.
+ (when (string-match "\\`[0-9.]+\\'" host)
+ (setq parts nil))
+ ;; We assume that the top-level domain is never an appropriate
+ ;; thing as "the domain", so we start at the next one (eg.
+ ;; "fsf.org").
+ (while (and parts
+ (not (setq found
+ (url-domsuf-cookie-allowed-p
+ (setq candidate (concat (pop parts) "."
+ candidate))))))
+ )
+ (and found candidate)))
+
(provide 'url-util)
;;; url-util.el ends here
diff --git a/lisp/url/url-vars.el b/lisp/url/url-vars.el
index a5d80ff1518..ae1d6e54391 100644
--- a/lisp/url/url-vars.el
+++ b/lisp/url/url-vars.el
@@ -60,10 +60,18 @@
(defvar url-current-mime-headers nil
"A parsed representation of the MIME headers for the current URL.")
+(defvar url-current-lastloc nil
+ "A parsed representation of the URL to be considered as the last location.
+Use of this value on outbound connections is subject to
+`url-privacy-level' and `url-lastloc-privacy-level'. This is never set
+by the url library, applications are expected to set this
+variable in buffers representing a displayed location.")
+
(mapc 'make-variable-buffer-local
'(
url-current-object
url-current-mime-headers
+ url-current-lastloc
))
(defcustom url-honor-refresh-requests t
@@ -117,7 +125,7 @@ Valid symbols are:
email -- the email address
os -- the operating system info
emacs -- the version of Emacs
-lastloc -- the last location
+lastloc -- the last location (see also `url-lastloc-privacy-level')
agent -- do not send the User-Agent string
cookies -- never accept HTTP cookies
@@ -150,6 +158,24 @@ variable."
(const :tag "No cookies" :value cookie)))
:group 'url)
+(defcustom url-lastloc-privacy-level 'domain-match
+ "Further restrictions on sending the last location.
+This value is only consulted if `url-privacy-level' permits
+sending last location in the first place.
+
+Valid values are:
+none -- Always send last location.
+domain-match -- Send last location if the new location is within the
+ same domain
+host-match -- Send last location if the new location is on the
+ same host
+"
+ :version "27.1"
+ :type '(radio (const :tag "Always send" none)
+ (const :tag "Domains match" domain-match)
+ (const :tag "Hosts match" host-match))
+ :group 'url)
+
(defvar url-inhibit-uncompression nil "Do not do decompression if non-nil.")
(defcustom url-uncompressor-alist '((".z" . "x-gzip")
diff --git a/lisp/url/url.el b/lisp/url/url.el
index fbf31d420cb..101c2b2c541 100644
--- a/lisp/url/url.el
+++ b/lisp/url/url.el
@@ -259,8 +259,7 @@ how long to wait for a response before giving up."
;; process output.
(while (and (not retrieval-done)
(or (not timeout)
- (< (float-time (time-subtract
- (current-time) start-time))
+ (< (float-time (time-subtract nil start-time))
timeout)))
(url-debug 'retrieval
"Spinning in url-retrieve-synchronously: %S (%S)"
generated by cgit v1.2.3 (git 2.39.1) at 2025-04-08 08:46:22 +0000