Commit | Line | Data |
---|---|---|
8c8b8430 | 1 | ;;; url-parse.el --- Uniform Resource Locator parser |
ffc00a35 | 2 | |
73b0cd50 | 3 | ;; Copyright (C) 1996-1999, 2004-2011 Free Software Foundation, Inc. |
ffc00a35 | 4 | |
8c8b8430 SM |
5 | ;; Keywords: comm, data, processes |
6 | ||
ffc00a35 SM |
7 | ;; This file is part of GNU Emacs. |
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) |
d18ec89f | 28 | (eval-when-compile (require 'cl)) |
8c8b8430 SM |
29 | |
30 | (autoload 'url-scheme-get-property "url-methods") | |
31 | ||
d18ec89f SM |
32 | (defstruct (url |
33 | (:constructor nil) | |
34 | (:constructor url-parse-make-urlobj | |
35 | (&optional type user password host portspec filename | |
36 | target attributes fullness)) | |
37 | (:copier nil)) | |
08b8ba9f | 38 | type user password host portspec filename target attributes fullness silent) |
8c8b8430 | 39 | |
d18ec89f SM |
40 | (defsubst url-port (urlobj) |
41 | (or (url-portspec urlobj) | |
42 | (if (url-fullness urlobj) | |
43 | (url-scheme-get-property (url-type urlobj) 'default-port)))) | |
8c8b8430 | 44 | |
d18ec89f | 45 | (defsetf url-port (urlobj) (port) `(setf (url-portspec ,urlobj) ,port)) |
71ddfde5 | 46 | |
8c8b8430 SM |
47 | ;;;###autoload |
48 | (defun url-recreate-url (urlobj) | |
61bbdf64 | 49 | "Recreate a URL string from the parsed URLOBJ." |
8c8b8430 SM |
50 | (concat (url-type urlobj) ":" (if (url-host urlobj) "//" "") |
51 | (if (url-user urlobj) | |
52 | (concat (url-user urlobj) | |
53 | (if (url-password urlobj) | |
54 | (concat ":" (url-password urlobj))) | |
55 | "@")) | |
56 | (url-host urlobj) | |
57 | (if (and (url-port urlobj) | |
58 | (not (equal (url-port urlobj) | |
59 | (url-scheme-get-property (url-type urlobj) 'default-port)))) | |
60 | (format ":%d" (url-port urlobj))) | |
fb7dc310 SM |
61 | (or (url-filename urlobj) "/") |
62 | (url-recreate-url-attributes urlobj) | |
8c8b8430 | 63 | (if (url-target urlobj) |
fb7dc310 SM |
64 | (concat "#" (url-target urlobj))))) |
65 | ||
66 | (defun url-recreate-url-attributes (urlobj) | |
67 | "Recreate the attributes of an URL string from the parsed URLOBJ." | |
68 | (when (url-attributes urlobj) | |
0539db75 | 69 | (concat ";" |
fb7dc310 SM |
70 | (mapconcat (lambda (x) |
71 | (if (cdr x) | |
72 | (concat (car x) "=" (cdr x)) | |
73 | (car x))) | |
74 | (url-attributes urlobj) ";")))) | |
8c8b8430 SM |
75 | |
76 | ;;;###autoload | |
77 | (defun url-generic-parse-url (url) | |
66991ff0 SM |
78 | "Return an URL-struct of the parts of URL. |
79 | The CL-style struct contains the following fields: | |
80 | TYPE USER PASSWORD HOST PORTSPEC FILENAME TARGET ATTRIBUTES FULLNESS." | |
f6fb70fc | 81 | ;; See RFC 3986. |
8c8b8430 SM |
82 | (cond |
83 | ((null url) | |
d18ec89f | 84 | (url-parse-make-urlobj)) |
8c8b8430 SM |
85 | ((or (not (string-match url-nonrelative-link url)) |
86 | (= ?/ (string-to-char url))) | |
f6fb70fc MH |
87 | ;; This isn't correct, as a relative URL can be a fragment link |
88 | ;; (e.g. "#foo") and many other things (see section 4.2). | |
89 | ;; However, let's not fix something that isn't broken, especially | |
90 | ;; when close to a release. | |
d18ec89f | 91 | (url-parse-make-urlobj nil nil nil nil nil url)) |
8c8b8430 | 92 | (t |
d58fae84 | 93 | (with-temp-buffer |
c074ba4a SM |
94 | ;; Don't let those temp-buffer modifications accidentally |
95 | ;; deactivate the mark of the current-buffer. | |
96 | (let ((deactivate-mark nil)) | |
97 | (set-syntax-table url-parse-syntax-table) | |
98 | (let ((save-pos nil) | |
99 | (prot nil) | |
100 | (user nil) | |
101 | (pass nil) | |
102 | (host nil) | |
103 | (port nil) | |
104 | (file nil) | |
105 | (refs nil) | |
106 | (attr nil) | |
107 | (full nil) | |
108 | (inhibit-read-only t)) | |
109 | (erase-buffer) | |
110 | (insert url) | |
111 | (goto-char (point-min)) | |
112 | (setq save-pos (point)) | |
113 | ||
114 | ;; 3.1. Scheme | |
115 | (unless (looking-at "//") | |
116 | (skip-chars-forward "a-zA-Z+.\\-") | |
117 | (downcase-region save-pos (point)) | |
118 | (setq prot (buffer-substring save-pos (point))) | |
119 | (skip-chars-forward ":") | |
120 | (setq save-pos (point))) | |
121 | ||
122 | ;; 3.2. Authority | |
123 | (when (looking-at "//") | |
124 | (setq full t) | |
125 | (forward-char 2) | |
126 | (setq save-pos (point)) | |
127 | (skip-chars-forward "^/") | |
128 | (setq host (buffer-substring save-pos (point))) | |
129 | (if (string-match "^\\([^@]+\\)@" host) | |
130 | (setq user (match-string 1 host) | |
131 | host (substring host (match-end 0) nil))) | |
132 | (if (and user (string-match "\\([^:]+\\):\\(.*\\)" user)) | |
133 | (setq pass (match-string 2 user) | |
134 | user (match-string 1 user))) | |
135 | ;; This gives wrong results for IPv6 literal addresses. | |
136 | (if (string-match ":\\([0-9+]+\\)" host) | |
137 | (setq port (string-to-number (match-string 1 host)) | |
138 | host (substring host 0 (match-beginning 0)))) | |
139 | (if (string-match ":$" host) | |
140 | (setq host (substring host 0 (match-beginning 0)))) | |
141 | (setq host (downcase host) | |
142 | save-pos (point))) | |
143 | ||
144 | (if (not port) | |
145 | (setq port (url-scheme-get-property prot 'default-port))) | |
146 | ||
147 | ;; 3.3. Path | |
148 | ;; Gross hack to preserve ';' in data URLs | |
149 | (setq save-pos (point)) | |
150 | ||
151 | ;; 3.4. Query | |
152 | (if (string= "data" prot) | |
153 | (goto-char (point-max)) | |
154 | ;; Now check for references | |
155 | (skip-chars-forward "^#") | |
156 | (if (eobp) | |
157 | nil | |
158 | (delete-region | |
159 | (point) | |
160 | (progn | |
161 | (skip-chars-forward "#") | |
162 | (setq refs (buffer-substring (point) (point-max))) | |
163 | (point-max)))) | |
164 | (goto-char save-pos) | |
165 | (skip-chars-forward "^;") | |
166 | (unless (eobp) | |
167 | (setq attr (url-parse-args (buffer-substring (point) (point-max)) | |
168 | t) | |
0539db75 | 169 | attr (nreverse attr)))) |
8c8b8430 | 170 | |
c074ba4a SM |
171 | (setq file (buffer-substring save-pos (point))) |
172 | (if (and host (string-match "%[0-9][0-9]" host)) | |
173 | (setq host (url-unhex-string host))) | |
174 | (url-parse-make-urlobj | |
175 | prot user pass host port file refs attr full))))))) | |
8c8b8430 | 176 | |
04c23739 MH |
177 | (defmacro url-bit-for-url (method lookfor url) |
178 | `(let* ((urlobj (url-generic-parse-url url)) | |
179 | (bit (funcall ,method urlobj)) | |
180 | (methods (list 'url-recreate-url | |
563790b6 TZ |
181 | 'url-host)) |
182 | auth-info) | |
04c23739 | 183 | (while (and (not bit) (> (length methods) 0)) |
563790b6 TZ |
184 | (setq auth-info (auth-source-search |
185 | :max 1 | |
186 | :host (funcall (pop methods) urlobj) | |
187 | :port (url-type urlobj))) | |
188 | (setq bit (plist-get (nth 0 auth-info) ,lookfor)) | |
189 | (when (functionp bit) | |
190 | (setq bit (funcall bit)))) | |
04c23739 MH |
191 | bit)) |
192 | ||
193 | (defun url-user-for-url (url) | |
194 | "Attempt to use .authinfo to find a user for this URL." | |
563790b6 | 195 | (url-bit-for-url 'url-user :user url)) |
04c23739 MH |
196 | |
197 | (defun url-password-for-url (url) | |
198 | "Attempt to use .authinfo to find a password for this URL." | |
563790b6 | 199 | (url-bit-for-url 'url-password :secret url)) |
04c23739 | 200 | |
8c8b8430 | 201 | (provide 'url-parse) |
e5566bd5 | 202 | |
ffc00a35 | 203 | ;;; url-parse.el ends here |