Merge 'master' into noverlay

1 files changed, 105 insertions, 125 deletions

diff --git a/lisp/url/url-util.el b/lisp/url/url-util.el
index 1d9e386bbc3..147a643c9fd 100644
--- a/lisp/url/url-util.el
+++ b/lisp/url/url-util.el
@@ -1,7 +1,6 @@
 ;;; url-util.el --- Miscellaneous helper routines for URL library -*- lexical-binding: t -*-
 
-;; Copyright (C) 1996-1999, 2001, 2004-2017 Free Software Foundation,
-;; Inc.
+;; Copyright (C) 1996-2022 Free Software Foundation, Inc.
 
 ;; Author: Bill Perry <wmperry@gnu.org>
 ;; Maintainer: emacs-devel@gnu.org
@@ -28,8 +27,6 @@
 
 (require 'url-parse)
 (require 'url-vars)
-(autoload 'timezone-parse-date "timezone")
-(autoload 'timezone-make-date-arpa-standard "timezone")
 (autoload 'mail-header-extract "mailheader")
 
 (defvar url-parse-args-syntax-table
@@ -61,8 +58,6 @@ If a list, it is a list of the types of messages to be logged."
 
 ;;;###autoload
 (defun url-debug (tag &rest args)
-  (if quit-flag
-      (error "Interrupted!"))
   (if (or (eq url-debug t)
 	  (numberp url-debug)
 	  (and (listp url-debug) (memq tag url-debug)))
@@ -74,61 +69,51 @@ If a list, it is a list of the types of messages to be logged."
 
 ;;;###autoload
 (defun url-parse-args (str &optional nodowncase)
-  ;; Return an assoc list of attribute/value pairs from an RFC822-type string
-  (let (
-	name				; From name=
+  ;; Return an assoc list of attribute/value pairs from a string
+  ;; that uses RFC 822 (or later) format.
+  (let (name				; From name=
 	value				; its value
 	results				; Assoc list of results
 	name-pos			; Start of XXXX= position
-	val-pos				; Start of value position
-	st
-	nd
-	)
-    (save-excursion
-      (save-restriction
-	(set-buffer (get-buffer-create " *urlparse-temp*"))
-	(set-syntax-table url-parse-args-syntax-table)
-	(erase-buffer)
-	(insert str)
-	(setq st (point-min)
-	      nd (point-max))
-	(set-syntax-table url-parse-args-syntax-table)
-	(narrow-to-region st nd)
-	(goto-char (point-min))
-	(while (not (eobp))
-	  (skip-chars-forward "; \n\t")
-	  (setq name-pos (point))
-	  (skip-chars-forward "^ \n\t=;")
-	  (if (not nodowncase)
-	      (downcase-region name-pos (point)))
-	  (setq name (buffer-substring name-pos (point)))
-	  (skip-chars-forward " \t\n")
-	  (if (/= (or (char-after (point)) 0)  ?=) ; There is no value
-	      (setq value nil)
-	    (skip-chars-forward " \t\n=")
-	    (setq val-pos (point)
-		  value
-		  (cond
-		   ((or (= (or (char-after val-pos) 0) ?\")
-			(= (or (char-after val-pos) 0) ?'))
-		    (buffer-substring (1+ val-pos)
-				      (condition-case ()
-					  (prog2
-					      (forward-sexp 1)
-					      (1- (point))
-					    (skip-chars-forward "\""))
-					(error
-					 (skip-chars-forward "^ \t\n")
-					 (point)))))
-		   (t
-		    (buffer-substring val-pos
-				      (progn
-					(skip-chars-forward "^;")
-					(skip-chars-backward " \t")
-					(point)))))))
-	  (setq results (cons (cons name value) results))
-	  (skip-chars-forward "; \n\t"))
-	results))))
+	val-pos)                        ; Start of value position
+    (with-temp-buffer
+      (insert str)
+      (set-syntax-table url-parse-args-syntax-table)
+      (goto-char (point-min))
+      (while (not (eobp))
+	(skip-chars-forward "; \n\t")
+	(setq name-pos (point))
+	(skip-chars-forward "^ \n\t=;")
+	(unless nodowncase
+	  (downcase-region name-pos (point)))
+	(setq name (buffer-substring name-pos (point)))
+	(skip-chars-forward " \t\n")
+	(if (/= (or (char-after (point)) 0)  ?=) ; There is no value
+	    (setq value nil)
+	  (skip-chars-forward " \t\n=")
+	  (setq val-pos (point)
+		value
+		(cond
+		 ((or (= (or (char-after val-pos) 0) ?\")
+		      (= (or (char-after val-pos) 0) ?'))
+		  (buffer-substring (1+ val-pos)
+				    (condition-case ()
+					(prog2
+					    (forward-sexp 1)
+					    (1- (point))
+					  (skip-chars-forward "\""))
+				      (error
+				       (skip-chars-forward "^ \t\n")
+				       (point)))))
+		 (t
+		  (buffer-substring val-pos
+				    (progn
+				      (skip-chars-forward "^;")
+				      (skip-chars-backward " \t")
+				      (point)))))))
+	(setq results (cons (cons name value) results))
+	(skip-chars-forward "; \n\t"))
+      results)))
 
 ;;;###autoload
 (defun url-insert-entities-in-string (string)
@@ -182,7 +167,7 @@ Will not do anything if `url-show-status' is nil."
 	  (null url-show-status)
 	  (active-minibuffer-window)
 	  (= url-lazy-message-time
-	     (setq url-lazy-message-time (nth 1 (current-time)))))
+	     (setq url-lazy-message-time (time-convert nil 'integer))))
       nil
     (apply 'message args)))
 
@@ -193,45 +178,32 @@ Will not do anything if `url-show-status' is nil."
   (format-time-string "%a, %d %b %Y %T GMT" specified-time t)))
 
 ;;;###autoload
-(defun url-eat-trailing-space (x)
-  "Remove spaces/tabs at the end of a string."
-  (let ((y (1- (length x)))
-	(skip-chars (list ?  ?\t ?\n)))
-    (while (and (>= y 0) (memq (aref x y) skip-chars))
-      (setq y (1- y)))
-    (substring x 0 (1+ y))))
+(define-obsolete-function-alias 'url-eat-trailing-space
+  #'string-trim-right "29.1")
 
 ;;;###autoload
-(defun url-strip-leading-spaces (x)
-  "Remove spaces at the front of a string."
-  (let ((y (1- (length x)))
-	(z 0)
-	(skip-chars (list ?  ?\t ?\n)))
-    (while (and (<= z y) (memq (aref x z) skip-chars))
-      (setq z (1+ z)))
-    (substring x z nil)))
-
+(define-obsolete-function-alias 'url-strip-leading-spaces
+  #'string-trim-left "29.1")
 
 (define-obsolete-function-alias 'url-pretty-length
   'file-size-human-readable "24.4")
 
 ;;;###autoload
-(defun url-display-percentage (fmt perc &rest args)
+(defun url-display-message (fmt &rest args)
+  "Like `message', but do nothing if `url-show-status' is nil."
   (when (and url-show-status
-	     (or (null url-current-object)
-		 (not (url-silent url-current-object))))
-    (if (null fmt)
-	(if (fboundp 'clear-progress-display)
-	    (clear-progress-display))
-      (if (and (fboundp 'progress-display) perc)
-	  (apply 'progress-display fmt perc args)
-	(apply 'message fmt args)))))
+             (not (and url-current-object (url-silent url-current-object)))
+             fmt)
+    (apply #'message fmt args)))
+
+;;;###autoload
+(defun url-display-percentage (fmt _perc &rest args)
+  (declare (obsolete url-display-message "29.1"))
+  (url-display-message fmt args))
 
 ;;;###autoload
 (defun url-percentage (x y)
-  (if (fboundp 'float)
-      (round (* 100 (/ x (float y))))
-    (/ (* x 100) y)))
+  (round (* 100 (/ x (float y)))))
 
 ;;;###autoload
 (defalias 'url-basepath 'url-file-directory)
@@ -264,7 +236,7 @@ Will not do anything if `url-show-status' is nil."
     (while pairs
       (setq cur (car pairs)
 	    pairs (cdr pairs))
-      (unless (string-match "=" cur)
+      (unless (string-search "=" cur)
         (setq cur (concat cur "=")))
 
       (when (string-match "=" cur)
@@ -294,7 +266,7 @@ Given a QUERY in the form:
 \(This is the same format as produced by `url-parse-query-string')
 
 This will return a string
-\"key1=val1&key2=val2&key3=val1&key3=val2&key4&key5\". Keys may
+\"key1=val1&key2=val2&key3=val1&key3=val2&key4&key5\".  Keys may
 be strings or symbols; if they are symbols, the symbol name will
 be used.
 
@@ -347,10 +319,13 @@ instead of just \"key\" as in the example above."
 
 ;;;###autoload
 (defun url-unhex-string (str &optional allow-newlines)
-  "Remove %XX embedded spaces, etc in a URL.
+  "Decode %XX sequences in a percent-encoded URL.
 If optional second argument ALLOW-NEWLINES is non-nil, then allow the
 decoding of carriage returns and line feeds in the string, which is normally
-forbidden in URL encoding."
+forbidden in URL encoding.
+
+The resulting string in general requires decoding using an
+appropriate coding-system; see `decode-coding-string'."
   (setq str (or str ""))
   (let ((tmp "")
 	(case-fold-search t))
@@ -407,9 +382,12 @@ string: \"%\" followed by two upper-case hex digits.
 
 The allowed characters are specified by ALLOWED-CHARS.  If this
 argument is nil, the list `url-unreserved-chars' determines the
-allowed characters.  Otherwise, ALLOWED-CHARS should be a vector
-whose Nth element is non-nil if character N is allowed."
-  (unless allowed-chars
+allowed characters.  Otherwise, ALLOWED-CHARS should be either a
+list of allowed chars, or a vector whose Nth element is non-nil
+if character N is allowed."
+  (if allowed-chars
+      (unless (vectorp allowed-chars)
+        (setq allowed-chars (url--allowed-chars allowed-chars)))
     (setq allowed-chars (url--allowed-chars url-unreserved-chars)))
   (mapconcat (lambda (byte)
 	       (if (aref allowed-chars byte)
@@ -502,7 +480,7 @@ WIDTH defaults to the current frame width."
 	 (urlobj nil))
     ;; The first thing that can go are the search strings
     (if (and (>= str-width fr-width)
-	     (string-match "?" url))
+	     (string-match "\\?" url))
 	(setq url (concat (substring url 0 (match-beginning 0)) "?...")
 	      str-width (length url)))
     (if (< str-width fr-width)
@@ -544,6 +522,7 @@ This uses `url-current-object', set locally to the buffer."
 (defun url-get-url-at-point (&optional pt)
   "Get the URL closest to point, but don't change position.
 Has a preference for looking backward when not directly on a symbol."
+  (declare (obsolete thing-at-point-url-at-point "27.1"))
   ;; Not at all perfect - point must be right in the name.
   (save-excursion
     (if pt (goto-char pt))
@@ -577,38 +556,13 @@ Has a preference for looking backward when not directly on a symbol."
 	  (setq url nil))
       url)))
 
-(defun url-generate-unique-filename (&optional fmt)
-  "Generate a unique filename in `url-temporary-directory'."
-  (declare (obsolete make-temp-file "23.1"))
-  ;; This variable is obsolete, but so is this function.
-  (let ((tempdir (with-no-warnings url-temporary-directory)))
-    (if (not fmt)
-	(let ((base (format "url-tmp.%d" (user-real-uid)))
-	      (fname "")
-	      (x 0))
-	  (setq fname (format "%s%d" base x))
-	  (while (file-exists-p
-		  (expand-file-name fname tempdir))
-	    (setq x (1+ x)
-		  fname (concat base (int-to-string x))))
-	  (expand-file-name fname tempdir))
-      (let ((base (concat "url" (int-to-string (user-real-uid))))
-	    (fname "")
-	    (x 0))
-	(setq fname (format fmt (concat base (int-to-string x))))
-	(while (file-exists-p
-		(expand-file-name fname tempdir))
-	  (setq x (1+ x)
-		fname (format fmt (concat base (int-to-string x)))))
-	(expand-file-name fname tempdir)))))
-
 (defun url-extract-mime-headers ()
   "Set `url-current-mime-headers' in current buffer."
   (save-excursion
     (goto-char (point-min))
     (unless url-current-mime-headers
-      (set (make-local-variable 'url-current-mime-headers)
-	   (mail-header-extract)))))
+      (setq-local url-current-mime-headers
+                  (mail-header-extract)))))
 
 (defun url-make-private-file (file)
   "Make FILE only readable and writable by the current user.
@@ -623,9 +577,35 @@ Creates FILE and its parent directories if they do not exist."
         (with-temp-buffer
           (write-region (point-min) (point-max) file nil 'silent nil 'excl)))
     (file-already-exists
-     (if (file-symlink-p file)
-         (error "Danger: `%s' is a symbolic link" file))
-     (set-file-modes file #o0600))))
+     (set-file-modes file #o0600 'nofollow))))
+
+(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)