diff options
Diffstat (limited to 'lisp/url/url-util.el')
| -rw-r--r-- | lisp/url/url-util.el | 230 |
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) |