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 silent)
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))))
45 (defsetf url-port (urlobj) (port) `(setf (url-portspec ,urlobj) ,port))
48 (defun url-recreate-url (urlobj)
49 "Recreate a URL string from the parsed URLOBJ."
50 (concat (url-type urlobj) ":" (if (url-host urlobj) "//" "")
52 (concat (url-user urlobj)
53 (if (url-password urlobj)
54 (concat ":" (url-password 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)))
61 (or (url-filename urlobj) "/")
62 (url-recreate-url-attributes urlobj)
63 (if (url-target urlobj)
64 (concat "#" (url-target urlobj)))))
66 (defun url-recreate-url-attributes (urlobj)
67 "Recreate the attributes of an URL string from the parsed URLOBJ."
68 (when (url-attributes urlobj)
70 (mapconcat (lambda (x)
72 (concat (car x) "=" (cdr x))
74 (url-attributes urlobj) ";"))))
77 (defun url-generic-parse-url (url)
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."
84 (url-parse-make-urlobj))
85 ((or (not (string-match url-nonrelative-link url))
86 (= ?/ (string-to-char url)))
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.
91 (url-parse-make-urlobj nil nil nil nil nil url))
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)
108 (inhibit-read-only t))
111 (goto-char (point-min))
112 (setq save-pos (point))
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)))
123 (when (looking-at "//")
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)
145 (setq port (url-scheme-get-property prot 'default-port)))
148 ;; Gross hack to preserve ';' in data URLs
149 (setq save-pos (point))
152 (if (string= "data" prot)
153 (goto-char (point-max))
154 ;; Now check for references
155 (skip-chars-forward "^#")
161 (skip-chars-forward "#")
162 (setq refs (buffer-substring (point) (point-max)))
165 (skip-chars-forward "^;")
167 (setq attr (url-parse-args (buffer-substring (point) (point-max))
169 attr (nreverse attr))))
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)))))))
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
183 (while (and (not bit) (> (length methods) 0))
184 (setq auth-info (auth-source-search
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))))
193 (defun url-user-for-url (url)
194 "Attempt to use .authinfo to find a user for this URL."
195 (url-bit-for-url 'url-user :user url))
197 (defun url-password-for-url (url)
198 "Attempt to use .authinfo to find a password for this URL."
199 (url-bit-for-url 'url-password :secret url))
203 ;;; url-parse.el ends here