[bpt/emacs.git] / lisp / url / url-parse.el

;;; url-parse.el --- Uniform Resource Locator parser

;; Copyright (C) 1996-1999, 2004-2014 Free Software Foundation, Inc.

;; Keywords: comm, data, processes

;; 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 <http://www.gnu.org/licenses/>.

;;; Commentary:

;;; Code:

(require 'url-vars)
(require 'auth-source)
(eval-when-compile (require 'cl-lib))

(autoload 'url-scheme-get-property "url-methods")

(cl-defstruct (url
            (:constructor nil)
            (:constructor url-parse-make-urlobj
                          (&optional type user password host portspec filename
                                     target attributes fullness))
            (:copier nil))
  type user password host portspec filename target attributes fullness
  silent (use-cookies t))

(defsubst url-port (urlobj)
  "Return the port number for the URL specified by URLOBJ.
If the port spec is nil (i.e. URLOBJ specifies no port number),
return the default port number for URLOBJ's scheme."
  (declare (gv-setter (lambda (port) `(setf (url-portspec ,urlobj) ,port))))
  (or (url-portspec urlobj)
      (if (url-type urlobj)
          (url-scheme-get-property (url-type urlobj) 'default-port))))

(defun url-path-and-query (urlobj)
  "Return the path and query components of URLOBJ.
These two components are stored together in the FILENAME slot of
the object.  The return value of this function is (PATH . QUERY),
where each of PATH and QUERY are strings or nil."
  (let ((name (url-filename urlobj))
	path query)
    (when name
      (if (string-match "\\?" name)
	  (setq path  (substring name 0 (match-beginning 0))
		query (substring name (match-end 0)))
	(setq path name)))
    (if (equal path "") (setq path nil))
    (if (equal query "") (setq query nil))
    (cons path query)))

(defun url-port-if-non-default (urlobj)
  "Return the port number specified by URLOBJ, if it is not the default.
If the specified port number is the default, return nil."
  (let ((port (url-portspec urlobj))
	type)
    (and port
	 (or (null (setq type (url-type urlobj)))
	     (not (equal port (url-scheme-get-property type 'default-port))))
	 port)))

;;;###autoload
(defun url-recreate-url (urlobj)
  "Recreate a URL string from the parsed URLOBJ."
  (let* ((type (url-type urlobj))
	 (user (url-user urlobj))
	 (pass (url-password urlobj))
	 (host (url-host urlobj))
	 ;; RFC 3986: "omit the port component and its : delimiter if
	 ;; port is empty or if its value would be the same as that of
	 ;; the scheme's default."
	 (port (url-port-if-non-default urlobj))
	 (file (url-filename urlobj))
	 (frag (url-target urlobj)))
    (concat (if type (concat type ":"))
	    (if (url-fullness urlobj) "//")
	    (if (or user pass)
		(concat user
			(if pass (concat ":" pass))
			"@"))
	    host
	    (if port (format ":%d" (url-port urlobj)))
	    (or file "/")
	    (if frag (concat "#" frag)))))

(defun url-recreate-url-attributes (urlobj)
  "Recreate the attributes of an URL string from the parsed URLOBJ."
  (declare (obsolete nil "24.3"))
  (when (url-attributes urlobj)
    (concat ";"
	    (mapconcat (lambda (x)
                         (if (cdr x)
                             (concat (car x) "=" (cdr x))
                           (car x)))
                       (url-attributes urlobj) ";"))))

;;;###autoload
(defun url-generic-parse-url (url)
  "Return an URL-struct of the parts of URL.
The CL-style struct contains the following fields:

TYPE     is the URI scheme (string or nil).
USER     is the user name (string or nil).
PASSWORD is the password (string [deprecated] or nil).
HOST     is the host (a registered name, IP literal in square
         brackets, or IPv4 address in dotted-decimal form).
PORTSPEC is the specified port (a number), or nil.
FILENAME is the path AND the query component of the URI.
TARGET   is the fragment identifier component (used to refer to a
         subordinate resource, e.g. a part of a webpage).
ATTRIBUTES is nil; this slot originally stored the attribute and
         value alists for IMAP URIs, but this feature was removed
         since it conflicts with RFC 3986.
FULLNESS is non-nil if the hierarchical sequence component of
         the URL starts with two slashes, \"//\".

The parser follows RFC 3986, except that it also tries to handle
URIs that are not fully specified (e.g. lacking TYPE), and it
does not check for or perform %-encoding.

Here is an example.  The URL

  foo://bob:pass@example.com:42/a/b/c.dtb?type=animal&name=narwhal#nose

parses to

  TYPE     = \"foo\"
  USER     = \"bob\"
  PASSWORD = \"pass\"
  HOST     = \"example.com\"
  PORTSPEC = 42
  FILENAME = \"/a/b/c.dtb?type=animal&name=narwhal\"
  TARGET   = \"nose\"
  ATTRIBUTES = nil
  FULLNESS = t"
  (if (null url)
      (url-parse-make-urlobj)
    (with-temp-buffer
      ;; Don't let those temp-buffer modifications accidentally
      ;; deactivate the mark of the current-buffer.
      (let ((deactivate-mark nil))
        (set-syntax-table url-parse-syntax-table)
	(erase-buffer)
	(insert url)
	(goto-char (point-min))
        (let ((save-pos (point))
              scheme user pass host port file fragment full
              (inhibit-read-only t))

          ;; 3.1. Scheme
	  ;; This is nil for a URI that is not fully specified.
          (when (looking-at "\\([a-zA-Z][-a-zA-Z0-9+.]*\\):")
	    (goto-char (match-end 0))
            (setq save-pos (point))
	    (setq scheme (downcase (match-string 1))))

          ;; 3.2. Authority
          (when (looking-at "//")
            (setq full t)
            (forward-char 2)
            (setq save-pos (point))
            (skip-chars-forward "^/?#")
            (setq host (buffer-substring save-pos (point)))
	    ;; 3.2.1 User Information
            (if (string-match "^\\([^@]+\\)@" host)
                (setq user (match-string 1 host)
                      host (substring host (match-end 0))))
            (if (and user (string-match "\\`\\([^:]*\\):\\(.*\\)" user))
                (setq pass (match-string 2 user)
                      user (match-string 1 user)))
            (cond
	     ;; IPv6 literal address.
	     ((string-match "^\\(\\[[^]]+\\]\\)\\(?::\\([0-9]*\\)\\)?$" host)
	      (setq port (match-string 2 host)
		    host (match-string 1 host)))
	     ;; Registered name or IPv4 address.
	     ((string-match ":\\([0-9]*\\)$" host)
	      (setq port (match-string 1 host)
		    host (substring host 0 (match-beginning 0)))))
	    (cond ((equal port "")
		   (setq port nil))
		  (port
		   (setq port (string-to-number port))))
            (setq host (downcase host)))

	  ;; Now point is on the / ? or # which terminates the
	  ;; authority, or at the end of the URI, or (if there is no
	  ;; authority) at the beginning of the absolute path.

          (setq save-pos (point))
          (if (string= "data" scheme)
	      ;; For the "data" URI scheme, all the rest is the FILE.
	      (setq file (buffer-substring save-pos (point-max)))
	    ;; For hysterical raisins, our data structure returns the
	    ;; path and query components together in one slot.
	    ;; 3.3. Path
	    (skip-chars-forward "^?#")
	    ;; 3.4. Query
	    (when (looking-at "?")
	      (skip-chars-forward "^#"))
	    (setq file (buffer-substring save-pos (point)))
	    ;; 3.5 Fragment
	    (when (looking-at "#")
	      (let ((opoint (point)))
		(forward-char 1)
		(unless (eobp)
		  (setq fragment (buffer-substring (point) (point-max))))
		(delete-region opoint (point-max)))))

          (if (and host (string-match "%[0-9][0-9]" host))
              (setq host (url-unhex-string host)))
          (url-parse-make-urlobj scheme user pass host port file
				 fragment nil full))))))

(defmacro url-bit-for-url (method lookfor url)
  `(let* ((urlobj (url-generic-parse-url url))
          (bit (funcall ,method urlobj))
          (methods (list 'url-recreate-url
                         'url-host))
          auth-info)
     (while (and (not bit) (> (length methods) 0))
       (setq auth-info (auth-source-search
                        :max 1
                        :host (funcall (pop methods) urlobj)
                        :port (url-type urlobj)))
       (setq bit (plist-get (nth 0 auth-info) ,lookfor))
       (when (functionp bit)
         (setq bit (funcall bit))))
     bit))

(defun url-user-for-url (url)
  "Attempt to use .authinfo to find a user for this URL."
  (url-bit-for-url 'url-user :user url))

(defun url-password-for-url (url)
  "Attempt to use .authinfo to find a password for this URL."
  (url-bit-for-url 'url-password :secret url))

(provide 'url-parse)

;;; url-parse.el ends here
Commit	Line	Data
8c8b8430	1	;;; url-parse.el --- Uniform Resource Locator parser
ffc00a35	2
ba318903	3	;; Copyright (C) 1996-1999, 2004-2014 Free Software Foundation, Inc.
ffc00a35	4
8c8b8430 SM	5	;; Keywords: comm, data, processes
8c8b8430 SM	6
ffc00a35 SM	7	;; This file is part of GNU Emacs.
ffc00a35 SM	8	;;
4936186e	9	;; GNU Emacs is free software: you can redistribute it and/or modify
ffc00a35	10	;; it under the terms of the GNU General Public License as published by
4936186e GM	11	;; the Free Software Foundation, either version 3 of the License, or
	12	;; (at your option) any later version.
	13
ffc00a35 SM	14	;; GNU Emacs is distributed in the hope that it will be useful,
	15	;; but WITHOUT ANY WARRANTY; without even the implied warranty of
	16	;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	17	;; GNU General Public License for more details.
4936186e	18
ffc00a35	19	;; You should have received a copy of the GNU General Public License
4936186e	20	;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
ffc00a35 SM	21
	22	;;; Commentary:
	23
	24	;;; Code:
	25
8c8b8430	26	(require 'url-vars)
04c23739	27	(require 'auth-source)
a464a6c7	28	(eval-when-compile (require 'cl-lib))
8c8b8430 SM	29
	30	(autoload 'url-scheme-get-property "url-methods")
	31
a464a6c7	32	(cl-defstruct (url
d18ec89f SM	33	(:constructor nil)
	34	(:constructor url-parse-make-urlobj
	35	(&optional type user password host portspec filename
	36	target attributes fullness))
	37	(:copier nil))
aacaa419 LI	38	type user password host portspec filename target attributes fullness
aacaa419 LI	39	silent (use-cookies t))
8c8b8430	40
d18ec89f	41	(defsubst url-port (urlobj)
33d35987 TA	42	"Return the port number for the URL specified by URLOBJ.
	43	If the port spec is nil (i.e. URLOBJ specifies no port number),
	44	return the default port number for URLOBJ's scheme."
a464a6c7	45	(declare (gv-setter (lambda (port) `(setf (url-portspec ,urlobj) ,port))))
d18ec89f	46	(or (url-portspec urlobj)
9f9aa044	47	(if (url-type urlobj)
d18ec89f	48	(url-scheme-get-property (url-type urlobj) 'default-port))))
8c8b8430	49
9f9aa044 CY	50	(defun url-path-and-query (urlobj)
9f9aa044 CY	51	"Return the path and query components of URLOBJ.
eaf5afb7	52	These two components are stored together in the FILENAME slot of
9f9aa044 CY	53	the object. The return value of this function is (PATH . QUERY),
	54	where each of PATH and QUERY are strings or nil."
	55	(let ((name (url-filename urlobj))
	56	path query)
	57	(when name
	58	(if (string-match "\\?" name)
	59	(setq path (substring name 0 (match-beginning 0))
	60	query (substring name (match-end 0)))
	61	(setq path name)))
	62	(if (equal path "") (setq path nil))
	63	(if (equal query "") (setq query nil))
	64	(cons path query)))
	65
	66	(defun url-port-if-non-default (urlobj)
	67	"Return the port number specified by URLOBJ, if it is not the default.
	68	If the specified port number is the default, return nil."
	69	(let ((port (url-portspec urlobj))
	70	type)
	71	(and port
	72	(or (null (setq type (url-type urlobj)))
	73	(not (equal port (url-scheme-get-property type 'default-port))))
	74	port)))
	75
8c8b8430 SM	76	;;;###autoload
8c8b8430 SM	77	(defun url-recreate-url (urlobj)
61bbdf64	78	"Recreate a URL string from the parsed URLOBJ."
9f9aa044 CY	79	(let* ((type (url-type urlobj))
	80	(user (url-user urlobj))
	81	(pass (url-password urlobj))
	82	(host (url-host urlobj))
	83	;; RFC 3986: "omit the port component and its : delimiter if
	84	;; port is empty or if its value would be the same as that of
	85	;; the scheme's default."
	86	(port (url-port-if-non-default urlobj))
	87	(file (url-filename urlobj))
	88	(frag (url-target urlobj)))
ce7b18ec CY	89	(concat (if type (concat type ":"))
	90	(if (url-fullness urlobj) "//")
	91	(if (or user pass)
	92	(concat user
	93	(if pass (concat ":" pass))
	94	"@"))
	95	host
9f9aa044	96	(if port (format ":%d" (url-port urlobj)))
ce7b18ec CY	97	(or file "/")
ce7b18ec CY	98	(if frag (concat "#" frag)))))
fb7dc310 SM	99
	100	(defun url-recreate-url-attributes (urlobj)
	101	"Recreate the attributes of an URL string from the parsed URLOBJ."
59f7af81	102	(declare (obsolete nil "24.3"))
fb7dc310	103	(when (url-attributes urlobj)
0539db75	104	(concat ";"
fb7dc310 SM	105	(mapconcat (lambda (x)
	106	(if (cdr x)
	107	(concat (car x) "=" (cdr x))
	108	(car x)))
	109	(url-attributes urlobj) ";"))))
8c8b8430 SM	110
	111	;;;###autoload
	112	(defun url-generic-parse-url (url)
66991ff0 SM	113	"Return an URL-struct of the parts of URL.
66991ff0 SM	114	The CL-style struct contains the following fields:
ce7b18ec CY	115
	116	TYPE is the URI scheme (string or nil).
	117	USER is the user name (string or nil).
	118	PASSWORD is the password (string [deprecated] or nil).
	119	HOST is the host (a registered name, IP literal in square
	120	brackets, or IPv4 address in dotted-decimal form).
	121	PORTSPEC is the specified port (a number), or nil.
	122	FILENAME is the path AND the query component of the URI.
	123	TARGET is the fragment identifier component (used to refer to a
	124	subordinate resource, e.g. a part of a webpage).
	125	ATTRIBUTES is nil; this slot originally stored the attribute and
	126	value alists for IMAP URIs, but this feature was removed
	127	since it conflicts with RFC 3986.
d136f184	128	FULLNESS is non-nil if the hierarchical sequence component of
9f9aa044	129	the URL starts with two slashes, \"//\".
ce7b18ec CY	130
	131	The parser follows RFC 3986, except that it also tries to handle
	132	URIs that are not fully specified (e.g. lacking TYPE), and it
	133	does not check for or perform %-encoding.
	134
	135	Here is an example. The URL
	136
	137	foo://bob:pass@example.com:42/a/b/c.dtb?type=animal&name=narwhal#nose
	138
	139	parses to
	140
	141	TYPE = \"foo\"
	142	USER = \"bob\"
	143	PASSWORD = \"pass\"
	144	HOST = \"example.com\"
	145	PORTSPEC = 42
	146	FILENAME = \"/a/b/c.dtb?type=animal&name=narwhal\"
	147	TARGET = \"nose\"
	148	ATTRIBUTES = nil
	149	FULLNESS = t"
	150	(if (null url)
	151	(url-parse-make-urlobj)
d58fae84	152	(with-temp-buffer
c074ba4a SM	153	;; Don't let those temp-buffer modifications accidentally
	154	;; deactivate the mark of the current-buffer.
	155	(let ((deactivate-mark nil))
	156	(set-syntax-table url-parse-syntax-table)
ce7b18ec CY	157	(erase-buffer)
	158	(insert url)
	159	(goto-char (point-min))
	160	(let ((save-pos (point))
	161	scheme user pass host port file fragment full
c074ba4a	162	(inhibit-read-only t))
c074ba4a SM	163
c074ba4a SM	164	;; 3.1. Scheme
ce7b18ec CY	165	;; This is nil for a URI that is not fully specified.
	166	(when (looking-at "\\([a-zA-Z][-a-zA-Z0-9+.]*\\):")
	167	(goto-char (match-end 0))
	168	(setq save-pos (point))
	169	(setq scheme (downcase (match-string 1))))
c074ba4a SM	170
	171	;; 3.2. Authority
	172	(when (looking-at "//")
	173	(setq full t)
	174	(forward-char 2)
	175	(setq save-pos (point))
ce7b18ec	176	(skip-chars-forward "^/?#")
c074ba4a	177	(setq host (buffer-substring save-pos (point)))
ce7b18ec	178	;; 3.2.1 User Information
c074ba4a SM	179	(if (string-match "^\\([^@]+\\)@" host)
c074ba4a SM	180	(setq user (match-string 1 host)
ce7b18ec CY	181	host (substring host (match-end 0))))
ce7b18ec CY	182	(if (and user (string-match "\\`\\([^:]\\):\\(.\\)" user))
c074ba4a SM	183	(setq pass (match-string 2 user)
c074ba4a SM	184	user (match-string 1 user)))
ce7b18ec CY	185	(cond
	186	;; IPv6 literal address.
	187	((string-match "^\\(\\[[^]]+\\]\\)\\(?::\\([0-9]*\\)\\)?$" host)
	188	(setq port (match-string 2 host)
	189	host (match-string 1 host)))
	190	;; Registered name or IPv4 address.
	191	((string-match ":\\([0-9]*\\)$" host)
	192	(setq port (match-string 1 host)
	193	host (substring host 0 (match-beginning 0)))))
	194	(cond ((equal port "")
	195	(setq port nil))
	196	(port
	197	(setq port (string-to-number port))))
	198	(setq host (downcase host)))
	199
ce7b18ec CY	200	;; Now point is on the / ? or # which terminates the
	201	;; authority, or at the end of the URI, or (if there is no
	202	;; authority) at the beginning of the absolute path.
	203
c074ba4a	204	(setq save-pos (point))
ce7b18ec CY	205	(if (string= "data" scheme)
	206	;; For the "data" URI scheme, all the rest is the FILE.
	207	(setq file (buffer-substring save-pos (point-max)))
	208	;; For hysterical raisins, our data structure returns the
	209	;; path and query components together in one slot.
	210	;; 3.3. Path
	211	(skip-chars-forward "^?#")
	212	;; 3.4. Query
	213	(when (looking-at "?")
	214	(skip-chars-forward "^#"))
	215	(setq file (buffer-substring save-pos (point)))
	216	;; 3.5 Fragment
	217	(when (looking-at "#")
	218	(let ((opoint (point)))
	219	(forward-char 1)
	220	(unless (eobp)
	221	(setq fragment (buffer-substring (point) (point-max))))
	222	(delete-region opoint (point-max)))))
c074ba4a	223
c074ba4a SM	224	(if (and host (string-match "%[0-9][0-9]" host))
c074ba4a SM	225	(setq host (url-unhex-string host)))
ce7b18ec CY	226	(url-parse-make-urlobj scheme user pass host port file
ce7b18ec CY	227	fragment nil full))))))
8c8b8430	228
04c23739 MH	229	(defmacro url-bit-for-url (method lookfor url)
	230	`(let* ((urlobj (url-generic-parse-url url))
	231	(bit (funcall ,method urlobj))
	232	(methods (list 'url-recreate-url
563790b6 TZ	233	'url-host))
563790b6 TZ	234	auth-info)
04c23739	235	(while (and (not bit) (> (length methods) 0))
563790b6 TZ	236	(setq auth-info (auth-source-search
	237	:max 1
	238	:host (funcall (pop methods) urlobj)
	239	:port (url-type urlobj)))
	240	(setq bit (plist-get (nth 0 auth-info) ,lookfor))
	241	(when (functionp bit)
	242	(setq bit (funcall bit))))
04c23739 MH	243	bit))
	244
	245	(defun url-user-for-url (url)
	246	"Attempt to use .authinfo to find a user for this URL."
563790b6	247	(url-bit-for-url 'url-user :user url))
04c23739 MH	248
	249	(defun url-password-for-url (url)
	250	"Attempt to use .authinfo to find a password for this URL."
563790b6	251	(url-bit-for-url 'url-password :secret url))
04c23739	252
8c8b8430	253	(provide 'url-parse)
e5566bd5	254
ffc00a35	255	;;; url-parse.el ends here