1;;; url-parse.el --- Uniform Resource Locator parser
2
3;; Copyright (C) 1996, 1997, 1998, 1999, 2004,
4;;   2005, 2006, 2007 Free Software Foundation, Inc.
5
6;; Keywords: comm, data, processes
7
8;; This file is part of GNU Emacs.
9;;
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 2, or (at your option)
13;; any later version.
14;;
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.
19;;
20;; You should have received a copy of the GNU General Public License
21;; along with GNU Emacs; see the file COPYING.  If not, write to the
22;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
23;; Boston, MA 02110-1301, USA.
24
25;;; Commentary:
26
27;;; Code:
28
29(require 'url-vars)
30
31(autoload 'url-scheme-get-property "url-methods")
32
33(defmacro url-type (urlobj)
34  `(aref ,urlobj 0))
35
36(defmacro url-user (urlobj)
37  `(aref ,urlobj 1))
38
39(defmacro url-password (urlobj)
40  `(aref ,urlobj 2))
41
42(defmacro url-host (urlobj)
43  `(aref ,urlobj 3))
44
45(defmacro url-port (urlobj)
46  `(or (aref ,urlobj 4)
47      (if (url-fullness ,urlobj)
48	  (url-scheme-get-property (url-type ,urlobj) 'default-port))))
49
50(defmacro url-filename (urlobj)
51  `(aref ,urlobj 5))
52
53(defmacro url-target (urlobj)
54  `(aref ,urlobj 6))
55
56(defmacro url-attributes (urlobj)
57  `(aref ,urlobj 7))
58
59(defmacro url-fullness (urlobj)
60  `(aref ,urlobj 8))
61
62(defmacro url-set-type (urlobj type)
63  `(aset ,urlobj 0 ,type))
64
65(defmacro url-set-user (urlobj user)
66  `(aset ,urlobj 1 ,user))
67
68(defmacro url-set-password (urlobj pass)
69  `(aset ,urlobj 2 ,pass))
70
71(defmacro url-set-host (urlobj host)
72  `(aset ,urlobj 3 ,host))
73
74(defmacro url-set-port (urlobj port)
75  `(aset ,urlobj 4 ,port))
76
77(defmacro url-set-filename (urlobj file)
78  `(aset ,urlobj 5 ,file))
79
80(defmacro url-set-target (urlobj targ)
81  `(aset ,urlobj 6 ,targ))
82
83(defmacro url-set-attributes (urlobj targ)
84  `(aset ,urlobj 7 ,targ))
85
86(defmacro url-set-full (urlobj val)
87  `(aset ,urlobj 8 ,val))
88
89;;;###autoload
90(defun url-recreate-url (urlobj)
91  "Recreate a URL string from the parsed URLOBJ."
92  (concat (url-type urlobj) ":" (if (url-host urlobj) "//" "")
93	  (if (url-user urlobj)
94	      (concat (url-user urlobj)
95		      (if (url-password urlobj)
96			  (concat ":" (url-password urlobj)))
97		      "@"))
98	  (url-host urlobj)
99	  (if (and (url-port urlobj)
100		   (not (equal (url-port urlobj)
101			       (url-scheme-get-property (url-type urlobj) 'default-port))))
102	      (format ":%d" (url-port urlobj)))
103	  (or (url-filename urlobj) "/")
104	  (url-recreate-url-attributes urlobj)
105	  (if (url-target urlobj)
106	      (concat "#" (url-target urlobj)))))
107
108(defun url-recreate-url-attributes (urlobj)
109  "Recreate the attributes of an URL string from the parsed URLOBJ."
110  (when (url-attributes urlobj)
111    (concat ";"
112	    (mapconcat (lambda (x)
113                         (if (cdr x)
114                             (concat (car x) "=" (cdr x))
115                           (car x)))
116                       (url-attributes urlobj) ";"))))
117
118;;;###autoload
119(defun url-generic-parse-url (url)
120  "Return a vector of the parts of URL.
121Format is:
122\[TYPE USER PASSWORD HOST PORT FILE TARGET ATTRIBUTES FULL\]"
123  ;; See RFC 3986.
124  (cond
125   ((null url)
126    (make-vector 9 nil))
127   ((or (not (string-match url-nonrelative-link url))
128	(= ?/ (string-to-char url)))
129    ;; This isn't correct, as a relative URL can be a fragment link
130    ;; (e.g. "#foo") and many other things (see section 4.2).
131    ;; However, let's not fix something that isn't broken, especially
132    ;; when close to a release.
133    (let ((retval (make-vector 9 nil)))
134      (url-set-filename retval url)
135      (url-set-full retval nil)
136      retval))
137   (t
138    (with-temp-buffer
139      (set-syntax-table url-parse-syntax-table)
140      (let ((save-pos nil)
141	    (prot nil)
142	    (user nil)
143	    (pass nil)
144	    (host nil)
145	    (port nil)
146	    (file nil)
147	    (refs nil)
148	    (attr nil)
149	    (full nil)
150	    (inhibit-read-only t))
151	(erase-buffer)
152	(insert url)
153	(goto-char (point-min))
154	(setq save-pos (point))
155
156	;; 3.1. Scheme
157	(if (not (looking-at "//"))
158	    (progn
159	      (skip-chars-forward "a-zA-Z+.\\-")
160	      (downcase-region save-pos (point))
161	      (setq prot (buffer-substring save-pos (point)))
162	      (skip-chars-forward ":")
163	      (setq save-pos (point))))
164
165	;; 3.2. Authority
166	(if (looking-at "//")
167	    (progn
168	      (setq full t)
169	      (forward-char 2)
170	      (setq save-pos (point))
171	      (skip-chars-forward "^/")
172	      (setq host (buffer-substring save-pos (point)))
173	      (if (string-match "^\\([^@]+\\)@" host)
174		  (setq user (match-string 1 host)
175			host (substring host (match-end 0) nil)))
176	      (if (and user (string-match "\\([^:]+\\):\\(.*\\)" user))
177		  (setq pass (match-string 2 user)
178			user (match-string 1 user)))
179	      ;; This gives wrong results for IPv6 literal addresses.
180	      (if (string-match ":\\([0-9+]+\\)" host)
181		  (setq port (string-to-number (match-string 1 host))
182			host (substring host 0 (match-beginning 0))))
183	      (if (string-match ":$" host)
184		  (setq host (substring host 0 (match-beginning 0))))
185	      (setq host (downcase host)
186		    save-pos (point))))
187
188	(if (not port)
189	    (setq port (url-scheme-get-property prot 'default-port)))
190
191	;; 3.3. Path
192	;; Gross hack to preserve ';' in data URLs
193	(setq save-pos (point))
194
195	;; 3.4. Query
196	(if (string= "data" prot)
197	    (goto-char (point-max))
198	  ;; Now check for references
199	  (skip-chars-forward "^#")
200	  (if (eobp)
201	      nil
202	    (delete-region
203	     (point)
204	     (progn
205	       (skip-chars-forward "#")
206	       (setq refs (buffer-substring (point) (point-max)))
207	       (point-max))))
208	  (goto-char save-pos)
209	  (skip-chars-forward "^;")
210	  (if (not (eobp))
211	      (setq attr (url-parse-args (buffer-substring (point) (point-max)) t)
212		    attr (nreverse attr))))
213
214	(setq file (buffer-substring save-pos (point)))
215	(if (and host (string-match "%[0-9][0-9]" host))
216	    (setq host (url-unhex-string host)))
217	(vector prot user pass host port file refs attr full))))))
218
219(provide 'url-parse)
220
221;; arch-tag: f338325f-71ab-4bee-93cc-78fb9a03d403
222;;; url-parse.el ends here
223