Mercurial > emacs
annotate lisp/url/url-parse.el @ 59890:fecf0bc95c49
(Basic Window): Mention color-change in mode line.
(Change Window): Explain dragging vertical boundaries.
author | Richard M. Stallman <rms@gnu.org> |
---|---|
date | Thu, 03 Feb 2005 07:31:56 +0000 |
parents | 01934125951e |
children | e30c08177a3b 47f53c5c9620 |
rev | line source |
---|---|
54695 | 1 ;;; url-parse.el --- Uniform Resource Locator parser |
54831
ca18766bb266
Comment fixups.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
54802
diff
changeset
|
2 |
57427 | 3 ;; Copyright (c) 1996,1997,1998,1999,2004 Free Software Foundation, Inc. |
54831
ca18766bb266
Comment fixups.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
54802
diff
changeset
|
4 |
54695 | 5 ;; Keywords: comm, data, processes |
6 | |
54831
ca18766bb266
Comment fixups.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
54802
diff
changeset
|
7 ;; This file is part of GNU Emacs. |
ca18766bb266
Comment fixups.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
54802
diff
changeset
|
8 ;; |
ca18766bb266
Comment fixups.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
54802
diff
changeset
|
9 ;; GNU Emacs is free software; you can redistribute it and/or modify |
ca18766bb266
Comment fixups.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
54802
diff
changeset
|
10 ;; it under the terms of the GNU General Public License as published by |
ca18766bb266
Comment fixups.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
54802
diff
changeset
|
11 ;; the Free Software Foundation; either version 2, or (at your option) |
ca18766bb266
Comment fixups.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
54802
diff
changeset
|
12 ;; any later version. |
ca18766bb266
Comment fixups.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
54802
diff
changeset
|
13 ;; |
ca18766bb266
Comment fixups.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
54802
diff
changeset
|
14 ;; GNU Emacs is distributed in the hope that it will be useful, |
ca18766bb266
Comment fixups.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
54802
diff
changeset
|
15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
ca18766bb266
Comment fixups.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
54802
diff
changeset
|
16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
ca18766bb266
Comment fixups.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
54802
diff
changeset
|
17 ;; GNU General Public License for more details. |
ca18766bb266
Comment fixups.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
54802
diff
changeset
|
18 ;; |
ca18766bb266
Comment fixups.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
54802
diff
changeset
|
19 ;; You should have received a copy of the GNU General Public License |
ca18766bb266
Comment fixups.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
54802
diff
changeset
|
20 ;; along with GNU Emacs; see the file COPYING. If not, write to the |
ca18766bb266
Comment fixups.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
54802
diff
changeset
|
21 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, |
ca18766bb266
Comment fixups.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
54802
diff
changeset
|
22 ;; Boston, MA 02111-1307, USA. |
ca18766bb266
Comment fixups.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
54802
diff
changeset
|
23 |
ca18766bb266
Comment fixups.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
54802
diff
changeset
|
24 ;;; Commentary: |
ca18766bb266
Comment fixups.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
54802
diff
changeset
|
25 |
ca18766bb266
Comment fixups.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
54802
diff
changeset
|
26 ;;; Code: |
ca18766bb266
Comment fixups.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
54802
diff
changeset
|
27 |
54695 | 28 (require 'url-vars) |
29 | |
30 (autoload 'url-scheme-get-property "url-methods") | |
31 | |
32 (defmacro url-type (urlobj) | |
33 `(aref ,urlobj 0)) | |
34 | |
35 (defmacro url-user (urlobj) | |
36 `(aref ,urlobj 1)) | |
37 | |
38 (defmacro url-password (urlobj) | |
39 `(aref ,urlobj 2)) | |
40 | |
41 (defmacro url-host (urlobj) | |
42 `(aref ,urlobj 3)) | |
43 | |
44 (defmacro url-port (urlobj) | |
45 `(or (aref ,urlobj 4) | |
46 (if (url-fullness ,urlobj) | |
47 (url-scheme-get-property (url-type ,urlobj) 'default-port)))) | |
48 | |
49 (defmacro url-filename (urlobj) | |
50 `(aref ,urlobj 5)) | |
51 | |
52 (defmacro url-target (urlobj) | |
53 `(aref ,urlobj 6)) | |
54 | |
55 (defmacro url-attributes (urlobj) | |
56 `(aref ,urlobj 7)) | |
57 | |
58 (defmacro url-fullness (urlobj) | |
59 `(aref ,urlobj 8)) | |
60 | |
61 (defmacro url-set-type (urlobj type) | |
62 `(aset ,urlobj 0 ,type)) | |
63 | |
64 (defmacro url-set-user (urlobj user) | |
65 `(aset ,urlobj 1 ,user)) | |
66 | |
67 (defmacro url-set-password (urlobj pass) | |
68 `(aset ,urlobj 2 ,pass)) | |
69 | |
70 (defmacro url-set-host (urlobj host) | |
71 `(aset ,urlobj 3 ,host)) | |
72 | |
73 (defmacro url-set-port (urlobj port) | |
74 `(aset ,urlobj 4 ,port)) | |
75 | |
76 (defmacro url-set-filename (urlobj file) | |
77 `(aset ,urlobj 5 ,file)) | |
78 | |
79 (defmacro url-set-target (urlobj targ) | |
80 `(aset ,urlobj 6 ,targ)) | |
81 | |
82 (defmacro url-set-attributes (urlobj targ) | |
83 `(aset ,urlobj 7 ,targ)) | |
84 | |
85 (defmacro url-set-full (urlobj val) | |
86 `(aset ,urlobj 8 ,val)) | |
87 | |
88 ;;;###autoload | |
89 (defun url-recreate-url (urlobj) | |
54802 | 90 "Recreate a URL string from the parsed URLOBJ." |
54695 | 91 (concat (url-type urlobj) ":" (if (url-host urlobj) "//" "") |
92 (if (url-user urlobj) | |
93 (concat (url-user urlobj) | |
94 (if (url-password urlobj) | |
95 (concat ":" (url-password urlobj))) | |
96 "@")) | |
97 (url-host urlobj) | |
98 (if (and (url-port urlobj) | |
99 (not (equal (url-port urlobj) | |
100 (url-scheme-get-property (url-type urlobj) 'default-port)))) | |
101 (format ":%d" (url-port urlobj))) | |
102 (or (url-filename urlobj) "/") | |
103 (if (url-target urlobj) | |
104 (concat "#" (url-target urlobj))) | |
105 (if (url-attributes urlobj) | |
106 (concat ";" | |
107 (mapconcat | |
108 (function | |
109 (lambda (x) | |
110 (if (cdr x) | |
111 (concat (car x) "=" (cdr x)) | |
112 (car x)))) (url-attributes urlobj) ";"))))) | |
113 | |
114 ;;;###autoload | |
115 (defun url-generic-parse-url (url) | |
116 "Return a vector of the parts of URL. | |
117 Format is: | |
54802 | 118 \[TYPE USER PASSWORD HOST PORT FILE TARGET ATTRIBUTES FULL\]" |
54695 | 119 (cond |
120 ((null url) | |
121 (make-vector 9 nil)) | |
122 ((or (not (string-match url-nonrelative-link url)) | |
123 (= ?/ (string-to-char url))) | |
124 (let ((retval (make-vector 9 nil))) | |
125 (url-set-filename retval url) | |
126 (url-set-full retval nil) | |
127 retval)) | |
128 (t | |
129 (save-excursion | |
130 (set-buffer (get-buffer-create " *urlparse*")) | |
131 (set-syntax-table url-parse-syntax-table) | |
132 (let ((save-pos nil) | |
133 (prot nil) | |
134 (user nil) | |
135 (pass nil) | |
136 (host nil) | |
137 (port nil) | |
138 (file nil) | |
139 (refs nil) | |
140 (attr nil) | |
141 (full nil) | |
142 (inhibit-read-only t)) | |
143 (erase-buffer) | |
144 (insert url) | |
145 (goto-char (point-min)) | |
146 (setq save-pos (point)) | |
147 (if (not (looking-at "//")) | |
148 (progn | |
149 (skip-chars-forward "a-zA-Z+.\\-") | |
150 (downcase-region save-pos (point)) | |
151 (setq prot (buffer-substring save-pos (point))) | |
152 (skip-chars-forward ":") | |
153 (setq save-pos (point)))) | |
154 | |
155 ;; We are doing a fully specified URL, with hostname and all | |
156 (if (looking-at "//") | |
157 (progn | |
158 (setq full t) | |
159 (forward-char 2) | |
160 (setq save-pos (point)) | |
161 (skip-chars-forward "^/") | |
162 (setq host (buffer-substring save-pos (point))) | |
163 (if (string-match "^\\([^@]+\\)@" host) | |
164 (setq user (match-string 1 host) | |
165 host (substring host (match-end 0) nil))) | |
166 (if (and user (string-match "\\([^:]+\\):\\(.*\\)" user)) | |
167 (setq pass (match-string 2 user) | |
168 user (match-string 1 user))) | |
169 (if (string-match ":\\([0-9+]+\\)" host) | |
170 (setq port (string-to-int (match-string 1 host)) | |
171 host (substring host 0 (match-beginning 0)))) | |
172 (if (string-match ":$" host) | |
173 (setq host (substring host 0 (match-beginning 0)))) | |
174 (setq host (downcase host) | |
175 save-pos (point)))) | |
176 | |
177 (if (not port) | |
178 (setq port (url-scheme-get-property prot 'default-port))) | |
179 | |
180 ;; Gross hack to preserve ';' in data URLs | |
181 | |
182 (setq save-pos (point)) | |
183 | |
184 (if (string= "data" prot) | |
185 (goto-char (point-max)) | |
186 ;; Now check for references | |
187 (skip-chars-forward "^#") | |
188 (if (eobp) | |
189 nil | |
190 (delete-region | |
191 (point) | |
192 (progn | |
193 (skip-chars-forward "#") | |
194 (setq refs (buffer-substring (point) (point-max))) | |
195 (point-max)))) | |
196 (goto-char save-pos) | |
197 (skip-chars-forward "^;") | |
198 (if (not (eobp)) | |
199 (setq attr (url-parse-args (buffer-substring (point) (point-max)) t) | |
200 attr (nreverse attr)))) | |
201 | |
202 (setq file (buffer-substring save-pos (point))) | |
203 (if (and host (string-match "%[0-9][0-9]" host)) | |
204 (setq host (url-unhex-string host))) | |
205 (vector prot user pass host port file refs attr full)))))) | |
206 | |
207 (provide 'url-parse) | |
54699 | 208 |
54831
ca18766bb266
Comment fixups.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
54802
diff
changeset
|
209 ;; arch-tag: f338325f-71ab-4bee-93cc-78fb9a03d403 |
ca18766bb266
Comment fixups.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
54802
diff
changeset
|
210 ;;; url-parse.el ends here |