Mercurial > hg > xemacs-beta

comparison lisp/url/url-parse.el @ 0:376386a54a3c r19-14

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-14
author cvs
date Mon, 13 Aug 2007 08:45:50 +0200
parents
children
comparison
equal deleted inserted replaced
-1:000000000000 0:376386a54a3c
1 ;;; url-parse.el,v --- Uniform Resource Locator parser
2 ;; Author: wmperry
3 ;; Created: 1996/01/05 17:45:31
4 ;; Version: 1.8
5 ;; Keywords: comm, data, processes
6
7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
8 ;;; Copyright (c) 1993, 1994, 1995 by William M. Perry (wmperry@spry.com)
9 ;;;
10 ;;; This file is not part of GNU Emacs, but the same permissions apply.
11 ;;;
12 ;;; GNU Emacs is free software; you can redistribute it and/or modify
13 ;;; it under the terms of the GNU General Public License as published by
14 ;;; the Free Software Foundation; either version 2, or (at your option)
15 ;;; any later version.
16 ;;;
17 ;;; GNU Emacs is distributed in the hope that it will be useful,
18 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
19 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
20 ;;; GNU General Public License for more details.
21 ;;;
22 ;;; You should have received a copy of the GNU General Public License
23 ;;; along with GNU Emacs; see the file COPYING. If not, write to
24 ;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
25 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
26 (defmacro url-type (urlobj)
27 (` (aref (, urlobj) 0)))
28
29 (defmacro url-user (urlobj)
30 (` (aref (, urlobj) 1)))
31
32 (defmacro url-password (urlobj)
33 (` (aref (, urlobj) 2)))
34
35 (defmacro url-host (urlobj)
36 (` (aref (, urlobj) 3)))
37
38 (defmacro url-port (urlobj)
39 (` (or (aref (, urlobj) 4)
40 (if (url-fullness (, urlobj))
41 (cdr-safe (assoc (url-type (, urlobj)) url-default-ports))))))
42
43 (defmacro url-filename (urlobj)
44 (` (aref (, urlobj) 5)))
45
46 (defmacro url-target (urlobj)
47 (` (aref (, urlobj) 6)))
48
49 (defmacro url-attributes (urlobj)
50 (` (aref (, urlobj) 7)))
51
52 (defmacro url-fullness (urlobj)
53 (` (aref (, urlobj) 8)))
54
55 (defmacro url-set-type (urlobj type)
56 (` (aset (, urlobj) 0 (, type))))
57
58 (defmacro url-set-user (urlobj user)
59 (` (aset (, urlobj) 1 (, user))))
60
61 (defmacro url-set-password (urlobj pass)
62 (` (aset (, urlobj) 2 (, pass))))
63
64 (defmacro url-set-host (urlobj host)
65 (` (aset (, urlobj) 3 (, host))))
66
67 (defmacro url-set-port (urlobj port)
68 (` (aset (, urlobj) 4 (, port))))
69
70 (defmacro url-set-filename (urlobj file)
71 (` (aset (, urlobj) 5 (, file))))
72
73 (defmacro url-set-target (urlobj targ)
74 (` (aset (, urlobj) 6 (, targ))))
75
76 (defmacro url-set-attributes (urlobj targ)
77 (` (aset (, urlobj) 7 (, targ))))
78
79 (defmacro url-set-full (urlobj val)
80 (` (aset (, urlobj) 8 (, val))))
81
82 (defun url-recreate-url (urlobj)
83 (concat (url-type urlobj) ":" (if (url-host urlobj) "//" "")
84 (if (url-user urlobj)
85 (concat (url-user urlobj)
86 (if (url-password urlobj)
87 (concat ":" (url-password urlobj)))
88 "@"))
89 (url-host urlobj)
90 (if (and (url-port urlobj)
91 (not (equal (url-port urlobj)
92 (cdr-safe (assoc (url-type urlobj)
93 url-default-ports)))))
94 (concat ":" (url-port urlobj)))
95 (or (url-filename urlobj) "/")
96 (if (url-target urlobj)
97 (concat "#" (url-target urlobj)))
98 (if (url-attributes urlobj)
99 (concat ";"
100 (mapconcat
101 (function
102 (lambda (x)
103 (if (cdr x)
104 (concat (car x) "=" (cdr x))
105 (car x)))) (url-attributes urlobj) ";")))))
106
107 (defun url-generic-parse-url (url)
108 "Return a vector of the parts of URL.
109 Format is [protocol username password hostname portnumber file reference]"
110 (cond
111 ((null url)
112 (make-vector 9 nil))
113 ((or (not (string-match url-nonrelative-link url))
114 (= ?/ (string-to-char url)))
115 (let ((retval (make-vector 9 nil)))
116 (url-set-filename retval url)
117 (url-set-full retval nil)
118 retval))
119 (t
120 (save-excursion
121 (set-buffer (get-buffer-create " *urlparse*"))
122 (erase-buffer)
123 (insert url)
124 (goto-char (point-min))
125 (set-syntax-table url-mailserver-syntax-table)
126 (let ((save-pos (point))
127 (prot nil)
128 (user nil)
129 (pass nil)
130 (host nil)
131 (port nil)
132 (file nil)
133 (refs nil)
134 (attr nil)
135 (full nil))
136 (if (not (looking-at "//"))
137 (progn
138 (skip-chars-forward "a-zA-Z+.\\-")
139 (downcase-region save-pos (point))
140 (setq prot (buffer-substring save-pos (point)))
141 (skip-chars-forward ":")
142 (setq save-pos (point))))
143
144 ;; We are doing a fully specified URL, with hostname and all
145 (if (looking-at "//")
146 (progn
147 (setq full t)
148 (forward-char 2)
149 (setq save-pos (point))
150 (skip-chars-forward "^/")
151 (downcase-region save-pos (point))
152 (setq host (buffer-substring save-pos (point)))
153 (if (string-match "^\\([^@]+\\)@" host)
154 (setq user (url-match host 1)
155 host (substring host (match-end 0) nil)))
156 (if (and user (string-match "\\([^:]+\\):\\(.*\\)" user))
157 (setq pass (url-match user 2)
158 user (url-match user 1)))
159 (if (string-match ":\\([0-9+]+\\)" host)
160 (setq port (url-match host 1)
161 host (substring host 0 (match-beginning 0))))
162 (if (string-match ":$" host)
163 (setq host (substring host 0 (match-beginning 0))))
164 (setq save-pos (point))))
165 ;; Now check for references
166 (setq save-pos (point))
167 (skip-chars-forward "^#")
168 (if (eobp)
169 nil
170 (delete-region
171 (point)
172 (progn
173 (skip-chars-forward "#")
174 (setq refs (buffer-substring (point) (point-max)))
175 (point-max))))
176 (goto-char save-pos)
177 (skip-chars-forward "^;")
178 (if (not (eobp))
179 (setq attr (mm-parse-args (point) (point-max))
180 attr (nreverse attr)))
181 (setq file (buffer-substring save-pos (point)))
182 (and port (string= port (or (cdr-safe (assoc prot url-default-ports))
183 ""))
184 (setq port nil))
185 (if (and host (string-match "%[0-9][0-9]" host))
186 (setq host (url-unhex-string host)))
187 (vector prot user pass host port file refs attr full))))))
188
189 (provide 'url-parse)