1 ;;; url-parse.el --- Uniform Resource Locator parser
3 ;; Copyright (C) 1996, 1997, 1998, 1999, 2004,
4 ;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
6 ;; Keywords: comm, data, processes
8 ;; This file is part of GNU Emacs.
10 ;; GNU Emacs is free software: you can redistribute it and/or modify
11 ;; it under the terms of the GNU General Public License as published by
12 ;; the Free Software Foundation, either version 3 of the License, or
13 ;; (at your option) any later version.
15 ;; GNU Emacs is distributed in the hope that it will be useful,
16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 ;; GNU General Public License for more details.
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
28 (require 'auth-source
)
29 (eval-when-compile (require 'cl
))
31 (autoload 'url-scheme-get-property
"url-methods")
35 (:constructor url-parse-make-urlobj
36 (&optional type user password host portspec filename
37 target attributes fullness
))
39 type user password host portspec filename target attributes fullness
)
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
183 (while (and (not bit
) (> (length methods
) 0))
185 (auth-source-user-or-password
186 ,lookfor
(funcall (pop methods
) urlobj
) (url-type urlobj
))))
189 (defun url-user-for-url (url)
190 "Attempt to use .authinfo to find a user for this URL."
191 (url-bit-for-url 'url-user
"login" url
))
193 (defun url-password-for-url (url)
194 "Attempt to use .authinfo to find a password for this URL."
195 (url-bit-for-url 'url-password
"password" url
))
199 ;; arch-tag: f338325f-71ab-4bee-93cc-78fb9a03d403
200 ;;; url-parse.el ends here