1 ;;; url-parse.el --- Uniform Resource Locator parser
3 ;; Copyright (C) 1996-1999, 2004-2012 Free Software Foundation, Inc.
5 ;; Keywords: comm, data, processes
7 ;; This file is part of GNU Emacs.
9 ;; GNU Emacs is free software: you can redistribute it and/or modify
10 ;; it under the terms of the GNU General Public License as published by
11 ;; the Free Software Foundation, either version 3 of the License, or
12 ;; (at your option) any later version.
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.
19 ;; You should have received a copy of the GNU General Public License
20 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
27 (require 'auth-source
)
28 (eval-when-compile (require 'cl
))
30 (autoload 'url-scheme-get-property
"url-methods")
34 (:constructor url-parse-make-urlobj
35 (&optional type user password host portspec filename
36 target attributes fullness
))
38 type user password host portspec filename target attributes fullness
39 silent
(use-cookies t
))
41 (defsubst url-port
(urlobj)
42 (or (url-portspec urlobj
)
43 (if (url-fullness urlobj
)
44 (url-scheme-get-property (url-type urlobj
) 'default-port
))))
46 (defsetf url-port
(urlobj) (port) `(setf (url-portspec ,urlobj
) ,port
))
49 (defun url-recreate-url (urlobj)
50 "Recreate a URL string from the parsed URLOBJ."
51 (concat (url-type urlobj
) ":" (if (url-host urlobj
) "//" "")
53 (concat (url-user urlobj
)
54 (if (url-password urlobj
)
55 (concat ":" (url-password urlobj
)))
58 (if (and (url-port urlobj
)
59 (not (equal (url-port urlobj
)
60 (url-scheme-get-property (url-type urlobj
) 'default-port
))))
61 (format ":%d" (url-port urlobj
)))
62 (or (url-filename urlobj
) "/")
63 (url-recreate-url-attributes urlobj
)
64 (if (url-target urlobj
)
65 (concat "#" (url-target urlobj
)))))
67 (defun url-recreate-url-attributes (urlobj)
68 "Recreate the attributes of an URL string from the parsed URLOBJ."
69 (when (url-attributes urlobj
)
71 (mapconcat (lambda (x)
73 (concat (car x
) "=" (cdr x
))
75 (url-attributes urlobj
) ";"))))
78 (defun url-generic-parse-url (url)
79 "Return an URL-struct of the parts of URL.
80 The CL-style struct contains the following fields:
81 TYPE USER PASSWORD HOST PORTSPEC FILENAME TARGET ATTRIBUTES FULLNESS."
85 (url-parse-make-urlobj))
86 ((or (not (string-match url-nonrelative-link url
))
87 (= ?
/ (string-to-char url
)))
88 ;; This isn't correct, as a relative URL can be a fragment link
89 ;; (e.g. "#foo") and many other things (see section 4.2).
90 ;; However, let's not fix something that isn't broken, especially
91 ;; when close to a release.
92 (url-parse-make-urlobj nil nil nil nil nil url
))
95 ;; Don't let those temp-buffer modifications accidentally
96 ;; deactivate the mark of the current-buffer.
97 (let ((deactivate-mark nil
))
98 (set-syntax-table url-parse-syntax-table
)
109 (inhibit-read-only t
))
112 (goto-char (point-min))
113 (setq save-pos
(point))
116 (unless (looking-at "//")
117 (skip-chars-forward "a-zA-Z+.\\-")
118 (downcase-region save-pos
(point))
119 (setq prot
(buffer-substring save-pos
(point)))
120 (skip-chars-forward ":")
121 (setq save-pos
(point)))
124 (when (looking-at "//")
127 (setq save-pos
(point))
128 (skip-chars-forward "^/")
129 (setq host
(buffer-substring save-pos
(point)))
130 (if (string-match "^\\([^@]+\\)@" host
)
131 (setq user
(match-string 1 host
)
132 host
(substring host
(match-end 0) nil
)))
133 (if (and user
(string-match "\\([^:]+\\):\\(.*\\)" user
))
134 (setq pass
(match-string 2 user
)
135 user
(match-string 1 user
)))
136 ;; This gives wrong results for IPv6 literal addresses.
137 (if (string-match ":\\([0-9+]+\\)" host
)
138 (setq port
(string-to-number (match-string 1 host
))
139 host
(substring host
0 (match-beginning 0))))
140 (if (string-match ":$" host
)
141 (setq host
(substring host
0 (match-beginning 0))))
142 (setq host
(downcase host
)
146 (setq port
(url-scheme-get-property prot
'default-port
)))
149 ;; Gross hack to preserve ';' in data URLs
150 (setq save-pos
(point))
153 (if (string= "data" prot
)
154 (goto-char (point-max))
155 ;; Now check for references
156 (skip-chars-forward "^#")
162 (skip-chars-forward "#")
163 (setq refs
(buffer-substring (point) (point-max)))
166 (skip-chars-forward "^;")
168 (setq attr
(url-parse-args (buffer-substring (point) (point-max))
170 attr
(nreverse attr
))))
172 (setq file
(buffer-substring save-pos
(point)))
173 (if (and host
(string-match "%[0-9][0-9]" host
))
174 (setq host
(url-unhex-string host
)))
175 (url-parse-make-urlobj
176 prot user pass host port file refs attr full
)))))))
178 (defmacro url-bit-for-url
(method lookfor url
)
179 `(let* ((urlobj (url-generic-parse-url url
))
180 (bit (funcall ,method urlobj
))
181 (methods (list 'url-recreate-url
184 (while (and (not bit
) (> (length methods
) 0))
185 (setq auth-info
(auth-source-search
187 :host
(funcall (pop methods
) urlobj
)
188 :port
(url-type urlobj
)))
189 (setq bit
(plist-get (nth 0 auth-info
) ,lookfor
))
190 (when (functionp bit
)
191 (setq bit
(funcall bit
))))
194 (defun url-user-for-url (url)
195 "Attempt to use .authinfo to find a user for this URL."
196 (url-bit-for-url 'url-user
:user url
))
198 (defun url-password-for-url (url)
199 "Attempt to use .authinfo to find a password for this URL."
200 (url-bit-for-url 'url-password
:secret url
))
204 ;;; url-parse.el ends here