aboutsummaryrefslogtreecommitdiffstats
path: root/lisp
diff options
context:
space:
mode:
authorStefan Monnier2004-04-04 01:21:46 +0000
committerStefan Monnier2004-04-04 01:21:46 +0000
commit8c8b8430b557f8f1503bfecce39b6f2938665e5a (patch)
tree1ed7295c23b469148f8996b6b37b11e9936fb7a1 /lisp
parent5c84686c48f49474e4b5b59ab859ff56fc7248d2 (diff)
downloademacs-8c8b8430b557f8f1503bfecce39b6f2938665e5a.tar.gz
emacs-8c8b8430b557f8f1503bfecce39b6f2938665e5a.zip
Initial revision
Diffstat (limited to 'lisp')
-rw-r--r--lisp/url/.gitignore4
-rw-r--r--lisp/url/url-about.el100
-rw-r--r--lisp/url/url-auth.el318
-rw-r--r--lisp/url/url-cache.el203
-rw-r--r--lisp/url/url-cid.el65
-rw-r--r--lisp/url/url-cookie.el468
-rw-r--r--lisp/url/url-dav.el973
-rw-r--r--lisp/url/url-dired.el102
-rw-r--r--lisp/url/url-expand.el143
-rw-r--r--lisp/url/url-file.el239
-rw-r--r--lisp/url/url-ftp.el44
-rw-r--r--lisp/url/url-gw.el264
-rw-r--r--lisp/url/url-handlers.el252
-rw-r--r--lisp/url/url-history.el199
-rw-r--r--lisp/url/url-http.el1223
-rw-r--r--lisp/url/url-https.el53
-rw-r--r--lisp/url/url-imap.el81
-rw-r--r--lisp/url/url-irc.el78
-rw-r--r--lisp/url/url-ldap.el233
-rw-r--r--lisp/url/url-mailto.el129
-rw-r--r--lisp/url/url-methods.el149
-rw-r--r--lisp/url/url-misc.el119
-rw-r--r--lisp/url/url-news.el135
-rw-r--r--lisp/url/url-nfs.el97
-rw-r--r--lisp/url/url-ns.el106
-rw-r--r--lisp/url/url-parse.el207
-rw-r--r--lisp/url/url-privacy.el83
-rw-r--r--lisp/url/url-proxy.el78
-rw-r--r--lisp/url/url-util.el487
-rw-r--r--lisp/url/url-vars.el435
-rw-r--r--lisp/url/url.el269
-rw-r--r--lisp/url/vc-dav.el177
32 files changed, 7513 insertions, 0 deletions
diff --git a/lisp/url/.gitignore b/lisp/url/.gitignore
new file mode 100644
index 00000000000..362a9c89b75
--- /dev/null
+++ b/lisp/url/.gitignore
@@ -0,0 +1,4 @@
1Makefile
2auto-autoloads.el
3custom-load.el
4url-auto.el
diff --git a/lisp/url/url-about.el b/lisp/url/url-about.el
new file mode 100644
index 00000000000..4fbf2083fae
--- /dev/null
+++ b/lisp/url/url-about.el
@@ -0,0 +1,100 @@
1;;; url-about.el --- Show internal URLs
2;; Author: $Author: wmperry $
3;; Created: $Date: 2001/11/24 22:30:21 $
4;; Version: $Revision: 1.1 $
5;; Keywords: comm, data, processes, hypermedia
6
7;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
8;;; Copyright (c) 2001 Free Software Foundation, Inc.
9;;;
10;;; This file is part of GNU Emacs.
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 the
24;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
25;;; Boston, MA 02111-1307, USA.
26;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
27(eval-when-compile
28 (require 'cl))
29(require 'url-util)
30(require 'url-parse)
31
32(defun url-probe-protocols ()
33 "Returns a list of all potential URL schemes."
34 (or (get 'url-extension-protocols 'probed)
35 (mapc (lambda (s) (url-scheme-get-property s 'name))
36 (or (get 'url-extension-protocols 'schemes)
37 (let ((schemes '("info" "man" "rlogin" "telnet"
38 "tn3270" "data" "snews")))
39 (mapc (lambda (d)
40 (mapc (lambda (f)
41 (if (string-match "url-\\(.*\\).el$" f)
42 (push (match-string 1 f) schemes)))
43 (directory-files d nil "^url-.*\\.el$")))
44 load-path)
45 (put 'url-extension-protocols 'schemes schemes)
46 schemes)))))
47
48(defun url-about-protocols (url)
49 (url-probe-protocols)
50 (insert "<html>\n"
51 " <head>\n"
52 " <title>Supported Protocols</title>\n"
53 " </head>\n"
54 " <body>\n"
55 " <h1>Supported Protocols - URL v" url-version "</h1>\n"
56 " <table width='100%' border='1'>\n"
57 " <tr>\n"
58 " <td>Protocol\n"
59 " <td>Properties\n"
60 " <td>Description\n"
61 " </tr>\n")
62 (mapc (lambda (k)
63 (if (string= k "proxy")
64 ;; Ignore the proxy setting... its magic!
65 nil
66 (insert " <tr>\n")
67 ;; The name of the protocol
68 (insert " <td valign=top>" (or (url-scheme-get-property k 'name) k) "\n")
69
70 ;; Now the properties. Currently just asynchronous
71 ;; status, default port number, and proxy status.
72 (insert " <td valign=top>"
73 (if (url-scheme-get-property k 'asynchronous-p) "As" "S")
74 "ynchronous<br>\n"
75 (if (url-scheme-get-property k 'default-port)
76 (format "Default Port: %d<br>\n"
77 (url-scheme-get-property k 'default-port)) "")
78 (if (assoc k url-proxy-services)
79 (format "Proxy: %s<br>\n" (assoc k url-proxy-services)) ""))
80 ;; Now the description...
81 (insert " <td valign=top>"
82 (or (url-scheme-get-property k 'description) "N/A"))))
83 (sort (let (x) (maphash (lambda (k v) (push k x)) url-scheme-registry) x) 'string-lessp))
84 (insert " </table>\n"
85 " </body>\n"
86 "</html>\n"))
87
88(defun url-about (url)
89 "Show internal URLs."
90 (let* ((item (downcase (url-filename url)))
91 (func (intern (format "url-about-%s" item))))
92 (if (fboundp func)
93 (progn
94 (set-buffer (generate-new-buffer " *about-data*"))
95 (insert "Content-type: text/html\n\n")
96 (funcall func url)
97 (current-buffer))
98 (error "URL does not know about `%s'" item))))
99
100(provide 'url-about)
diff --git a/lisp/url/url-auth.el b/lisp/url/url-auth.el
new file mode 100644
index 00000000000..5a88b32159c
--- /dev/null
+++ b/lisp/url/url-auth.el
@@ -0,0 +1,318 @@
1;;; url-auth.el --- Uniform Resource Locator authorization modules
2;; Author: $Author: wmperry $
3;; Created: $Date: 2001/12/05 19:05:51 $
4;; Version: $Revision: 1.4 $
5;; Keywords: comm, data, processes, hypermedia
6
7;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
8;;; Copyright (c) 1993 - 1996 by William M. Perry <wmperry@cs.indiana.edu>
9;;; Copyright (c) 1996 - 1999 Free Software Foundation, Inc.
10;;;
11;;; This file is part of GNU Emacs.
12;;;
13;;; GNU Emacs is free software; you can redistribute it and/or modify
14;;; it under the terms of the GNU General Public License as published by
15;;; the Free Software Foundation; either version 2, or (at your option)
16;;; any later version.
17;;;
18;;; GNU Emacs is distributed in the hope that it will be useful,
19;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
20;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
21;;; GNU General Public License for more details.
22;;;
23;;; You should have received a copy of the GNU General Public License
24;;; along with GNU Emacs; see the file COPYING. If not, write to the
25;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
26;;; Boston, MA 02111-1307, USA.
27;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
28
29(require 'url-vars)
30(require 'url-parse)
31(autoload 'url-warn "url")
32
33(defsubst url-auth-user-prompt (url realm)
34 "String to usefully prompt for a username."
35 (concat "Username [for "
36 (or realm (url-truncate-url-for-viewing
37 (url-recreate-url url)
38 (- (window-width) 10 20)))
39 "]: "))
40
41;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
42;;; Basic authorization code
43;;; ------------------------
44;;; This implements the BASIC authorization type. See the online
45;;; documentation at
46;;; http://www.w3.org/hypertext/WWW/AccessAuthorization/Basic.html
47;;; for the complete documentation on this type.
48;;;
49;;; This is very insecure, but it works as a proof-of-concept
50;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
51(defvar url-basic-auth-storage 'url-http-real-basic-auth-storage
52 "Where usernames and passwords are stored.
53
54Must be a symbol pointing to another variable that will actually store
55the information. The value of this variable is an assoc list of assoc
56lists. The first assoc list is keyed by the server name. The cdr of
57this is an assoc list based on the 'directory' specified by the url we
58are looking up.")
59
60(defun url-basic-auth (url &optional prompt overwrite realm args)
61 "Get the username/password for the specified URL.
62If optional argument PROMPT is non-nil, ask for the username/password
63to use for the url and its descendants. If optional third argument
64OVERWRITE is non-nil, overwrite the old username/password pair if it
65is found in the assoc list. If REALM is specified, use that as the realm
66instead of the pathname inheritance method."
67 (let* ((href (if (stringp url)
68 (url-generic-parse-url url)
69 url))
70 (server (url-host href))
71 (port (url-port href))
72 (path (url-filename href))
73 user pass byserv retval data)
74 (setq server (format "%s:%d" server port)
75 path (cond
76 (realm realm)
77 ((string-match "/$" path) path)
78 (t (url-basepath path)))
79 byserv (cdr-safe (assoc server
80 (symbol-value url-basic-auth-storage))))
81 (cond
82 ((and prompt (not byserv))
83 (setq user (read-string (url-auth-user-prompt url realm)
84 (user-real-login-name))
85 pass (funcall url-passwd-entry-func "Password: "))
86 (set url-basic-auth-storage
87 (cons (list server
88 (cons path
89 (setq retval
90 (base64-encode-string
91 (format "%s:%s" user pass)))))
92 (symbol-value url-basic-auth-storage))))
93 (byserv
94 (setq retval (cdr-safe (assoc path byserv)))
95 (if (and (not retval)
96 (string-match "/" path))
97 (while (and byserv (not retval))
98 (setq data (car (car byserv)))
99 (if (or (not (string-match "/" data)) ; Its a realm - take it!
100 (and
101 (>= (length path) (length data))
102 (string= data (substring path 0 (length data)))))
103 (setq retval (cdr (car byserv))))
104 (setq byserv (cdr byserv))))
105 (if (or (and (not retval) prompt) overwrite)
106 (progn
107 (setq user (read-string (url-auth-user-prompt url realm)
108 (user-real-login-name))
109 pass (funcall url-passwd-entry-func "Password: ")
110 retval (base64-encode-string (format "%s:%s" user pass))
111 byserv (assoc server (symbol-value url-basic-auth-storage)))
112 (setcdr byserv
113 (cons (cons path retval) (cdr byserv))))))
114 (t (setq retval nil)))
115 (if retval (setq retval (concat "Basic " retval)))
116 retval))
117
118;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
119;;; Digest authorization code
120;;; ------------------------
121;;; This implements the DIGEST authorization type. See the internet draft
122;;; ftp://ds.internic.net/internet-drafts/draft-ietf-http-digest-aa-01.txt
123;;; for the complete documentation on this type.
124;;;
125;;; This is very secure
126;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
127(defvar url-digest-auth-storage nil
128 "Where usernames and passwords are stored. Its value is an assoc list of
129assoc lists. The first assoc list is keyed by the server name. The cdr of
130this is an assoc list based on the 'directory' specified by the url we are
131looking up.")
132
133(defun url-digest-auth-create-key (username password realm method uri)
134 "Create a key for digest authentication method"
135 (let* ((info (if (stringp uri)
136 (url-generic-parse-url uri)
137 uri))
138 (a1 (md5 (concat username ":" realm ":" password)))
139 (a2 (md5 (concat method ":" (url-filename info)))))
140 (list a1 a2)))
141
142(defun url-digest-auth (url &optional prompt overwrite realm args)
143 "Get the username/password for the specified URL.
144If optional argument PROMPT is non-nil, ask for the username/password
145to use for the url and its descendants. If optional third argument
146OVERWRITE is non-nil, overwrite the old username/password pair if it
147is found in the assoc list. If REALM is specified, use that as the realm
148instead of hostname:portnum."
149 (if args
150 (let* ((href (if (stringp url)
151 (url-generic-parse-url url)
152 url))
153 (server (url-host href))
154 (port (url-port href))
155 (path (url-filename href))
156 user pass byserv retval data)
157 (setq path (cond
158 (realm realm)
159 ((string-match "/$" path) path)
160 (t (url-basepath path)))
161 server (format "%s:%d" server port)
162 byserv (cdr-safe (assoc server url-digest-auth-storage)))
163 (cond
164 ((and prompt (not byserv))
165 (setq user (read-string (url-auth-user-prompt url realm)
166 (user-real-login-name))
167 pass (funcall url-passwd-entry-func "Password: ")
168 url-digest-auth-storage
169 (cons (list server
170 (cons path
171 (setq retval
172 (cons user
173 (url-digest-auth-create-key
174 user pass realm
175 (or url-request-method "GET")
176 url)))))
177 url-digest-auth-storage)))
178 (byserv
179 (setq retval (cdr-safe (assoc path byserv)))
180 (if (and (not retval) ; no exact match, check directories
181 (string-match "/" path)) ; not looking for a realm
182 (while (and byserv (not retval))
183 (setq data (car (car byserv)))
184 (if (or (not (string-match "/" data))
185 (and
186 (>= (length path) (length data))
187 (string= data (substring path 0 (length data)))))
188 (setq retval (cdr (car byserv))))
189 (setq byserv (cdr byserv))))
190 (if (or (and (not retval) prompt) overwrite)
191 (progn
192 (setq user (read-string (url-auth-user-prompt url realm)
193 (user-real-login-name))
194 pass (funcall url-passwd-entry-func "Password: ")
195 retval (setq retval
196 (cons user
197 (url-digest-auth-create-key
198 user pass realm
199 (or url-request-method "GET")
200 url)))
201 byserv (assoc server url-digest-auth-storage))
202 (setcdr byserv
203 (cons (cons path retval) (cdr byserv))))))
204 (t (setq retval nil)))
205 (if retval
206 (let ((nonce (or (cdr-safe (assoc "nonce" args)) "nonegiven"))
207 (opaque (or (cdr-safe (assoc "opaque" args)) "nonegiven")))
208 (format
209 (concat "Digest username=\"%s\", realm=\"%s\","
210 "nonce=\"%s\", uri=\"%s\","
211 "response=\"%s\", opaque=\"%s\"")
212 (nth 0 retval) realm nonce (url-filename href)
213 (md5 (concat (nth 1 retval) ":" nonce ":"
214 (nth 2 retval))) opaque))))))
215
216(defvar url-registered-auth-schemes nil
217 "A list of the registered authorization schemes and various and sundry
218information associated with them.")
219
220;;;###autoload
221(defun url-get-authentication (url realm type prompt &optional args)
222 "Return an authorization string suitable for use in the WWW-Authenticate
223header in an HTTP/1.0 request.
224
225URL is the url you are requesting authorization to. This can be either a
226 string representing the URL, or the parsed representation returned by
227 `url-generic-parse-url'
228REALM is the realm at a specific site we are looking for. This should be a
229 string specifying the exact realm, or nil or the symbol 'any' to
230 specify that the filename portion of the URL should be used as the
231 realm
232TYPE is the type of authentication to be returned. This is either a string
233 representing the type (basic, digest, etc), or nil or the symbol 'any'
234 to specify that any authentication is acceptable. If requesting 'any'
235 the strongest matching authentication will be returned. If this is
236 wrong, its no big deal, the error from the server will specify exactly
237 what type of auth to use
238PROMPT is boolean - specifies whether to ask the user for a username/password
239 if one cannot be found in the cache"
240 (if (not realm)
241 (setq realm (cdr-safe (assoc "realm" args))))
242 (if (stringp url)
243 (setq url (url-generic-parse-url url)))
244 (if (or (null type) (eq type 'any))
245 ;; Whooo doogies!
246 ;; Go through and get _all_ the authorization strings that could apply
247 ;; to this URL, store them along with the 'rating' we have in the list
248 ;; of schemes, then sort them so that the 'best' is at the front of the
249 ;; list, then get the car, then get the cdr.
250 ;; Zooom zooom zoooooom
251 (cdr-safe
252 (car-safe
253 (sort
254 (mapcar
255 (function
256 (lambda (scheme)
257 (if (fboundp (car (cdr scheme)))
258 (cons (cdr (cdr scheme))
259 (funcall (car (cdr scheme)) url nil nil realm))
260 (cons 0 nil))))
261 url-registered-auth-schemes)
262 (function
263 (lambda (x y)
264 (cond
265 ((null (cdr x)) nil)
266 ((and (cdr x) (null (cdr y))) t)
267 ((and (cdr x) (cdr y))
268 (>= (car x) (car y)))
269 (t nil)))))))
270 (if (symbolp type) (setq type (symbol-name type)))
271 (let* ((scheme (car-safe
272 (cdr-safe (assoc (downcase type)
273 url-registered-auth-schemes)))))
274 (if (and scheme (fboundp scheme))
275 (funcall scheme url prompt
276 (and prompt
277 (funcall scheme url nil nil realm args))
278 realm args)))))
279
280;;;###autoload
281(defun url-register-auth-scheme (type &optional function rating)
282 "Register an HTTP authentication method.
283
284TYPE is a string or symbol specifying the name of the method. This
285 should be the same thing you expect to get returned in an Authenticate
286 header in HTTP/1.0 - it will be downcased.
287FUNCTION is the function to call to get the authorization information. This
288 defaults to `url-?-auth', where ? is TYPE
289RATING a rating between 1 and 10 of the strength of the authentication.
290 This is used when asking for the best authentication for a specific
291 URL. The item with the highest rating is returned."
292 (let* ((type (cond
293 ((stringp type) (downcase type))
294 ((symbolp type) (downcase (symbol-name type)))
295 (t (error "Bad call to `url-register-auth-scheme'"))))
296 (function (or function (intern (concat "url-" type "-auth"))))
297 (rating (cond
298 ((null rating) 2)
299 ((stringp rating) (string-to-int rating))
300 (t rating)))
301 (node (assoc type url-registered-auth-schemes)))
302 (if (not (fboundp function))
303 (url-warn 'security
304 (format (eval-when-compile
305 "Tried to register `%s' as an auth scheme"
306 ", but it is not a function!") function)))
307
308 (if node
309 (setcdr node (cons function rating))
310 (setq url-registered-auth-schemes
311 (cons (cons type (cons function rating))
312 url-registered-auth-schemes)))))
313
314(defun url-auth-registered (scheme)
315 ;; Return non-nil iff SCHEME is registered as an auth type
316 (assoc scheme url-registered-auth-schemes))
317
318(provide 'url-auth)
diff --git a/lisp/url/url-cache.el b/lisp/url/url-cache.el
new file mode 100644
index 00000000000..a6bf2847dd6
--- /dev/null
+++ b/lisp/url/url-cache.el
@@ -0,0 +1,203 @@
1;;; url-cache.el --- Uniform Resource Locator retrieval tool
2;; Author: $Author: fx $
3;; Created: $Date: 2002/01/22 17:53:45 $
4;; Version: $Revision: 1.4 $
5;; Keywords: comm, data, processes, hypermedia
6
7;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
8;;; Copyright (c) 1993 - 1996 by William M. Perry <wmperry@cs.indiana.edu>
9;;; Copyright (c) 1996 - 1999 Free Software Foundation, Inc.
10;;;
11;;; This file is part of GNU Emacs.
12;;;
13;;; GNU Emacs is free software; you can redistribute it and/or modify
14;;; it under the terms of the GNU General Public License as published by
15;;; the Free Software Foundation; either version 2, or (at your option)
16;;; any later version.
17;;;
18;;; GNU Emacs is distributed in the hope that it will be useful,
19;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
20;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
21;;; GNU General Public License for more details.
22;;;
23;;; You should have received a copy of the GNU General Public License
24;;; along with GNU Emacs; see the file COPYING. If not, write to the
25;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
26;;; Boston, MA 02111-1307, USA.
27;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
28(require 'url-parse)
29
30(defcustom url-cache-directory
31 (expand-file-name "cache" url-configuration-directory)
32 "*The directory where cache files should be stored."
33 :type 'directory
34 :group 'url-file)
35
36;; Cache manager
37(defun url-cache-file-writable-p (file)
38 "Follows the documentation of `file-writable-p', unlike `file-writable-p'."
39 (and (file-writable-p file)
40 (if (file-exists-p file)
41 (not (file-directory-p file))
42 (file-directory-p (file-name-directory file)))))
43
44(defun url-cache-prepare (file)
45 "Makes it possible to cache data in FILE.
46Creates any necessary parent directories, deleting any non-directory files
47that would stop this. Returns nil if parent directories can not be
48created. If FILE already exists as a non-directory, it changes
49permissions of FILE or deletes FILE to make it possible to write a new
50version of FILE. Returns nil if this can not be done. Returns nil if
51FILE already exists as a directory. Otherwise, returns t, indicating that
52FILE can be created or overwritten."
53 (cond
54 ((url-cache-file-writable-p file)
55 t)
56 ((file-directory-p file)
57 nil)
58 (t
59 (condition-case ()
60 (or (make-directory (file-name-directory file) t) t)
61 (error nil)))))
62
63;;;###autoload
64(defun url-store-in-cache (&optional buff)
65 "Store buffer BUFF in the cache."
66 (if (not (and buff (get-buffer buff)))
67 nil
68 (save-excursion
69 (and buff (set-buffer buff))
70 (let* ((fname (url-cache-create-filename (url-view-url t))))
71 (if (url-cache-prepare fname)
72 (let ((coding-system-for-write 'binary))
73 (write-region (point-min) (point-max) fname nil 5)))))))
74
75;;;###autoload
76(defun url-is-cached (url)
77 "Return non-nil if the URL is cached."
78 (let* ((fname (url-cache-create-filename url))
79 (attribs (file-attributes fname)))
80 (and fname ; got a filename
81 (file-exists-p fname) ; file exists
82 (not (eq (nth 0 attribs) t)) ; Its not a directory
83 (nth 5 attribs)))) ; Can get last mod-time
84
85(defun url-cache-create-filename-human-readable (url)
86 "Return a filename in the local cache for URL"
87 (if url
88 (let* ((url (if (vectorp url) (url-recreate-url url) url))
89 (urlobj (url-generic-parse-url url))
90 (protocol (url-type urlobj))
91 (hostname (url-host urlobj))
92 (host-components
93 (cons
94 (user-real-login-name)
95 (cons (or protocol "file")
96 (reverse (split-string (or hostname "localhost")
97 (eval-when-compile
98 (regexp-quote ".")))))))
99 (fname (url-filename urlobj)))
100 (if (and fname (/= (length fname) 0) (= (aref fname 0) ?/))
101 (setq fname (substring fname 1 nil)))
102 (if fname
103 (let ((slash nil))
104 (setq fname
105 (mapconcat
106 (function
107 (lambda (x)
108 (cond
109 ((and (= ?/ x) slash)
110 (setq slash nil)
111 "%2F")
112 ((= ?/ x)
113 (setq slash t)
114 "/")
115 (t
116 (setq slash nil)
117 (char-to-string x))))) fname ""))))
118
119 (setq fname (and fname
120 (mapconcat
121 (function (lambda (x)
122 (if (= x ?~) "" (char-to-string x))))
123 fname ""))
124 fname (cond
125 ((null fname) nil)
126 ((or (string= "" fname) (string= "/" fname))
127 url-directory-index-file)
128 ((= (string-to-char fname) ?/)
129 (if (string= (substring fname -1 nil) "/")
130 (concat fname url-directory-index-file)
131 (substring fname 1 nil)))
132 (t
133 (if (string= (substring fname -1 nil) "/")
134 (concat fname url-directory-index-file)
135 fname))))
136 (and fname
137 (expand-file-name fname
138 (expand-file-name
139 (mapconcat 'identity host-components "/")
140 url-cache-directory))))))
141
142(defun url-cache-create-filename-using-md5 (url)
143 "Create a cached filename using MD5.
144 Very fast if you are in XEmacs, suitably fast otherwise."
145 (require 'md5)
146 (if url
147 (let* ((url (if (vectorp url) (url-recreate-url url) url))
148 (checksum (md5 url))
149 (urlobj (url-generic-parse-url url))
150 (protocol (url-type urlobj))
151 (hostname (url-host urlobj))
152 (host-components
153 (cons
154 (user-real-login-name)
155 (cons (or protocol "file")
156 (nreverse
157 (delq nil
158 (split-string (or hostname "localhost")
159 (eval-when-compile
160 (regexp-quote "."))))))))
161 (fname (url-filename urlobj)))
162 (and fname
163 (expand-file-name checksum
164 (expand-file-name
165 (mapconcat 'identity host-components "/")
166 url-cache-directory))))))
167
168(defcustom url-cache-creation-function 'url-cache-create-filename-using-md5
169 "*What function to use to create a cached filename."
170 :type '(choice (const :tag "MD5 of filename (low collision rate)"
171 :value url-cache-create-filename-using-md5)
172 (const :tag "Human readable filenames (higher collision rate)"
173 :value url-cache-create-filename-human-readable)
174 (function :tag "Other"))
175 :group 'url-cache)
176
177(defun url-cache-create-filename (url)
178 (funcall url-cache-creation-function url))
179
180;;;###autoload
181(defun url-cache-extract (fnam)
182 "Extract FNAM from the local disk cache"
183 (erase-buffer)
184 (insert-file-contents-literally fnam))
185
186;;;###autoload
187(defun url-cache-expired (url mod)
188 "Return t iff a cached file has expired."
189 (let* ((urlobj (if (vectorp url) url (url-generic-parse-url url)))
190 (type (url-type urlobj)))
191 (cond
192 (url-standalone-mode
193 (not (file-exists-p (url-cache-create-filename url))))
194 ((string= type "http")
195 t)
196 ((member type '("file" "ftp"))
197 (if (or (equal mod '(0 0)) (not mod))
198 t
199 (or (> (nth 0 mod) (nth 0 (current-time)))
200 (> (nth 1 mod) (nth 1 (current-time))))))
201 (t nil))))
202
203(provide 'url-cache)
diff --git a/lisp/url/url-cid.el b/lisp/url/url-cid.el
new file mode 100644
index 00000000000..be380387acf
--- /dev/null
+++ b/lisp/url/url-cid.el
@@ -0,0 +1,65 @@
1;;; url-cid.el --- Content-ID URL loader
2;; Author: $Author: fx $
3;; Created: $Date: 2001/05/05 16:35:58 $
4;; Version: $Revision: 1.3 $
5;; Keywords: comm, data, processes
6
7;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
8;;; Copyright (c) 1998 - 1999 Free Software Foundation, Inc.
9;;;
10;;; This file is part of GNU Emacs.
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 the
24;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
25;;; Boston, MA 02111-1307, USA.
26;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
27
28(require 'url-vars)
29(require 'url-parse)
30
31(require 'mm-decode)
32
33(defun url-cid-gnus (cid)
34 (let ((content-type nil)
35 (encoding nil)
36 (part nil)
37 (data nil))
38 (setq part (mm-get-content-id cid))
39 (if (not part)
40 (message "Unknown CID encountered: %s" cid)
41 (setq data (save-excursion
42 (set-buffer (mm-handle-buffer part))
43 (buffer-string))
44 content-type (mm-handle-type part)
45 encoding (symbol-name (mm-handle-encoding part)))
46 (if (= 0 (length content-type)) (setq content-type "text/plain"))
47 (if (= 0 (length encoding)) (setq encoding "8bit"))
48 (if (listp content-type)
49 (setq content-type (car content-type)))
50 (insert (format "Content-type: %d\r\n" (length data))
51 "Content-type: " content-type "\r\n"
52 "Content-transfer-encoding: " encoding "\r\n"
53 "\r\n"
54 (or data "")))))
55
56;;;###autoload
57(defun url-cid (url)
58 (cond
59 ((fboundp 'mm-get-content-id)
60 ;; Using Pterodactyl Gnus or later
61 (save-excursion
62 (set-buffer (generate-new-buffer " *url-cid*"))
63 (url-cid-gnus (url-filename url))))
64 (t
65 (message "Unable to handle CID URL: %s" url))))
diff --git a/lisp/url/url-cookie.el b/lisp/url/url-cookie.el
new file mode 100644
index 00000000000..eca89cb0f5a
--- /dev/null
+++ b/lisp/url/url-cookie.el
@@ -0,0 +1,468 @@
1;;; url-cookie.el --- Netscape Cookie support
2;; Author: $Author: wmperry $
3;; Created: $Date: 2002/10/29 14:44:59 $
4;; Version: $Revision: 1.7 $
5;; Keywords: comm, data, processes, hypermedia
6
7;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
8;;; Copyright (c) 1996 by William M. Perry <wmperry@cs.indiana.edu>
9;;; Copyright (c) 1996 - 1999 Free Software Foundation, Inc.
10;;;
11;;; This file is part of GNU Emacs.
12;;;
13;;; GNU Emacs is free software; you can redistribute it and/or modify
14;;; it under the terms of the GNU General Public License as published by
15;;; the Free Software Foundation; either version 2, or (at your option)
16;;; any later version.
17;;;
18;;; GNU Emacs is distributed in the hope that it will be useful,
19;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
20;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
21;;; GNU General Public License for more details.
22;;;
23;;; You should have received a copy of the GNU General Public License
24;;; along with GNU Emacs; see the file COPYING. If not, write to the
25;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
26;;; Boston, MA 02111-1307, USA.
27;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
28
29(require 'timezone)
30(require 'url-util)
31(require 'url-parse)
32(eval-when-compile (require 'cl))
33
34;; See http://home.netscape.com/newsref/std/cookie_spec.html for the
35;; 'open standard' defining this crap.
36;;
37;; A cookie is stored internally as a vector of 7 slots
38;; [ 'cookie name value expires path domain secure ]
39
40(defsubst url-cookie-name (cookie) (aref cookie 1))
41(defsubst url-cookie-value (cookie) (aref cookie 2))
42(defsubst url-cookie-expires (cookie) (aref cookie 3))
43(defsubst url-cookie-path (cookie) (aref cookie 4))
44(defsubst url-cookie-domain (cookie) (aref cookie 5))
45(defsubst url-cookie-secure (cookie) (aref cookie 6))
46
47(defsubst url-cookie-set-name (cookie val) (aset cookie 1 val))
48(defsubst url-cookie-set-value (cookie val) (aset cookie 2 val))
49(defsubst url-cookie-set-expires (cookie val) (aset cookie 3 val))
50(defsubst url-cookie-set-path (cookie val) (aset cookie 4 val))
51(defsubst url-cookie-set-domain (cookie val) (aset cookie 5 val))
52(defsubst url-cookie-set-secure (cookie val) (aset cookie 6 val))
53(defsubst url-cookie-retrieve-arg (key args) (nth 1 (memq key args)))
54
55(defsubst url-cookie-create (&rest args)
56 (let ((retval (make-vector 7 nil)))
57 (aset retval 0 'cookie)
58 (url-cookie-set-name retval (url-cookie-retrieve-arg :name args))
59 (url-cookie-set-value retval (url-cookie-retrieve-arg :value args))
60 (url-cookie-set-expires retval (url-cookie-retrieve-arg :expires args))
61 (url-cookie-set-path retval (url-cookie-retrieve-arg :path args))
62 (url-cookie-set-domain retval (url-cookie-retrieve-arg :domain args))
63 (url-cookie-set-secure retval (url-cookie-retrieve-arg :secure args))
64 retval))
65
66(defun url-cookie-p (obj)
67 (and (vectorp obj) (= (length obj) 7) (eq (aref obj 0) 'cookie)))
68
69(defgroup url-cookie nil
70 "URL cookies"
71 :prefix "url-"
72 :prefix "url-cookie-"
73 :group 'url)
74
75(defvar url-cookie-storage nil "Where cookies are stored.")
76(defvar url-cookie-secure-storage nil "Where secure cookies are stored.")
77(defcustom url-cookie-file nil "*Where cookies are stored on disk."
78 :type '(choice (const :tag "Default" :value nil) file)
79 :group 'url-file
80 :group 'url-cookie)
81
82(defcustom url-cookie-confirmation nil
83 "*If non-nil, confirmation by the user is required to accept HTTP cookies."
84 :type 'boolean
85 :group 'url-cookie)
86
87(defcustom url-cookie-multiple-line nil
88 "*If nil, HTTP requests put all cookies for the server on one line.
89Some web servers, such as http://www.hotmail.com/, only accept cookies
90when they are on one line. This is broken behaviour, but just try
91telling Microsoft that.")
92
93(defvar url-cookies-changed-since-last-save nil
94 "Whether the cookies list has changed since the last save operation.")
95
96;;;###autoload
97(defun url-cookie-parse-file (&optional fname)
98 (setq fname (or fname url-cookie-file))
99 (condition-case ()
100 (load fname nil t)
101 (error (message "Could not load cookie file %s" fname))))
102
103(defun url-cookie-clean-up (&optional secure)
104 (let* (
105 (var (if secure 'url-cookie-secure-storage 'url-cookie-storage))
106 (val (symbol-value var))
107 (cur nil)
108 (new nil)
109 (cookies nil)
110 (cur-cookie nil)
111 (new-cookies nil)
112 )
113 (while val
114 (setq cur (car val)
115 val (cdr val)
116 new-cookies nil
117 cookies (cdr cur))
118 (while cookies
119 (setq cur-cookie (car cookies)
120 cookies (cdr cookies))
121 (if (or (not (url-cookie-p cur-cookie))
122 (url-cookie-expired-p cur-cookie)
123 (null (url-cookie-expires cur-cookie)))
124 nil
125 (setq new-cookies (cons cur-cookie new-cookies))))
126 (if (not new-cookies)
127 nil
128 (setcdr cur new-cookies)
129 (setq new (cons cur new))))
130 (set var new)))
131
132;;;###autoload
133(defun url-cookie-write-file (&optional fname)
134 (setq fname (or fname url-cookie-file))
135 (cond
136 ((not url-cookies-changed-since-last-save) nil)
137 ((not (file-writable-p fname))
138 (message "Cookies file %s (see variable `url-cookie-file') is unwritable." fname))
139 (t
140 (url-cookie-clean-up)
141 (url-cookie-clean-up t)
142 (save-excursion
143 (set-buffer (get-buffer-create " *cookies*"))
144 (erase-buffer)
145 (fundamental-mode)
146 (insert ";; Emacs-W3 HTTP cookies file\n"
147 ";; Automatically generated file!!! DO NOT EDIT!!!\n\n"
148 "(setq url-cookie-storage\n '")
149 (pp url-cookie-storage (current-buffer))
150 (insert ")\n(setq url-cookie-secure-storage\n '")
151 (pp url-cookie-secure-storage (current-buffer))
152 (insert ")\n")
153 (write-file fname)
154 (kill-buffer (current-buffer))))))
155
156(defun url-cookie-store (name value &optional expires domain path secure)
157 "Stores a netscape-style cookie"
158 (let* ((storage (if secure url-cookie-secure-storage url-cookie-storage))
159 (tmp storage)
160 (cur nil)
161 (found-domain nil))
162
163 ;; First, look for a matching domain
164 (setq found-domain (assoc domain storage))
165
166 (if found-domain
167 ;; Need to either stick the new cookie in existing domain storage
168 ;; or possibly replace an existing cookie if the names match.
169 (progn
170 (setq storage (cdr found-domain)
171 tmp nil)
172 (while storage
173 (setq cur (car storage)
174 storage (cdr storage))
175 (if (and (equal path (url-cookie-path cur))
176 (equal name (url-cookie-name cur)))
177 (progn
178 (url-cookie-set-expires cur expires)
179 (url-cookie-set-value cur value)
180 (setq tmp t))))
181 (if (not tmp)
182 ;; New cookie
183 (setcdr found-domain (cons
184 (url-cookie-create :name name
185 :value value
186 :expires expires
187 :domain domain
188 :path path
189 :secure secure)
190 (cdr found-domain)))))
191 ;; Need to add a new top-level domain
192 (setq tmp (url-cookie-create :name name
193 :value value
194 :expires expires
195 :domain domain
196 :path path
197 :secure secure))
198 (cond
199 (storage
200 (setcdr storage (cons (list domain tmp) (cdr storage))))
201 (secure
202 (setq url-cookie-secure-storage (list (list domain tmp))))
203 (t
204 (setq url-cookie-storage (list (list domain tmp))))))))
205
206(defun url-cookie-expired-p (cookie)
207 (let* (
208 (exp (url-cookie-expires cookie))
209 (cur-date (and exp (timezone-parse-date (current-time-string))))
210 (exp-date (and exp (timezone-parse-date exp)))
211 (cur-greg (and cur-date (timezone-absolute-from-gregorian
212 (string-to-int (aref cur-date 1))
213 (string-to-int (aref cur-date 2))
214 (string-to-int (aref cur-date 0)))))
215 (exp-greg (and exp (timezone-absolute-from-gregorian
216 (string-to-int (aref exp-date 1))
217 (string-to-int (aref exp-date 2))
218 (string-to-int (aref exp-date 0)))))
219 (diff-in-days (and exp (- cur-greg exp-greg)))
220 )
221 (cond
222 ((not exp) nil) ; No expiry == expires at browser quit
223 ((< diff-in-days 0) nil) ; Expires sometime after today
224 ((> diff-in-days 0) t) ; Expired before today
225 (t ; Expires sometime today, check times
226 (let* ((cur-time (timezone-parse-time (aref cur-date 3)))
227 (exp-time (timezone-parse-time (aref exp-date 3)))
228 (cur-norm (+ (* 360 (string-to-int (aref cur-time 2)))
229 (* 60 (string-to-int (aref cur-time 1)))
230 (* 1 (string-to-int (aref cur-time 0)))))
231 (exp-norm (+ (* 360 (string-to-int (aref exp-time 2)))
232 (* 60 (string-to-int (aref exp-time 1)))
233 (* 1 (string-to-int (aref exp-time 0))))))
234 (> (- cur-norm exp-norm) 1))))))
235
236;;;###autoload
237(defun url-cookie-retrieve (host path &optional secure)
238 "Retrieves all the netscape-style cookies for a specified HOST and PATH"
239 (let ((storage (if secure
240 (append url-cookie-secure-storage url-cookie-storage)
241 url-cookie-storage))
242 (case-fold-search t)
243 (cookies nil)
244 (cur nil)
245 (retval nil)
246 (path-regexp nil))
247 (while storage
248 (setq cur (car storage)
249 storage (cdr storage)
250 cookies (cdr cur))
251 (if (and (car cur)
252 (string-match (concat "^.*" (regexp-quote (car cur)) "$") host))
253 ;; The domains match - a possible hit!
254 (while cookies
255 (setq cur (car cookies)
256 cookies (cdr cookies)
257 path-regexp (concat "^" (regexp-quote
258 (url-cookie-path cur))))
259 (if (and (string-match path-regexp path)
260 (not (url-cookie-expired-p cur)))
261 (setq retval (cons cur retval))))))
262 retval))
263
264;;;###autolaod
265(defun url-cookie-generate-header-lines (host path secure)
266 (let* ((cookies (url-cookie-retrieve host path secure))
267 (retval nil)
268 (cur nil)
269 (chunk nil))
270 ;; Have to sort this for sending most specific cookies first
271 (setq cookies (and cookies
272 (sort cookies
273 (function
274 (lambda (x y)
275 (> (length (url-cookie-path x))
276 (length (url-cookie-path y))))))))
277 (while cookies
278 (setq cur (car cookies)
279 cookies (cdr cookies)
280 chunk (format "%s=%s" (url-cookie-name cur) (url-cookie-value cur))
281 retval (if (and url-cookie-multiple-line
282 (< 80 (+ (length retval) (length chunk) 4)))
283 (concat retval "\r\nCookie: " chunk)
284 (if retval
285 (concat retval "; " chunk)
286 (concat "Cookie: " chunk)))))
287 (if retval
288 (concat retval "\r\n")
289 "")))
290
291(defvar url-cookie-two-dot-domains
292 (concat "\\.\\("
293 (mapconcat 'identity (list "com" "edu" "net" "org" "gov" "mil" "int")
294 "\\|")
295 "\\)$")
296 "A regular expression of top-level domains that only require two matching
297'.'s in the domain name in order to set a cookie.")
298
299(defcustom url-cookie-trusted-urls nil
300 "*A list of regular expressions matching URLs to always accept cookies from."
301 :type '(repeat regexp)
302 :group 'url-cookie)
303
304(defcustom url-cookie-untrusted-urls nil
305 "*A list of regular expressions matching URLs to never accept cookies from."
306 :type '(repeat regexp)
307 :group 'url-cookie)
308
309(defun url-cookie-host-can-set-p (host domain)
310 (let ((numdots 0)
311 (tmp domain)
312 (last nil)
313 (case-fold-search t)
314 (mindots 3))
315 (while (setq last (string-match "\\." domain last))
316 (setq numdots (1+ numdots)
317 last (1+ last)))
318 (if (string-match url-cookie-two-dot-domains domain)
319 (setq mindots 2))
320 (cond
321 ((string= host domain) ; Apparently netscape lets you do this
322 t)
323 ((>= numdots mindots) ; We have enough dots in domain name
324 ;; Need to check and make sure the host is actually _in_ the
325 ;; domain it wants to set a cookie for though.
326 (string-match (concat (regexp-quote domain) "$") host))
327 (t
328 nil))))
329
330;;;###autoload
331(defun url-cookie-handle-set-cookie (str)
332 (setq url-cookies-changed-since-last-save t)
333 (let* ((args (url-parse-args str t))
334 (case-fold-search t)
335 (secure (and (assoc-ignore-case "secure" args) t))
336 (domain (or (cdr-safe (assoc-ignore-case "domain" args))
337 (url-host url-current-object)))
338 (current-url (url-view-url t))
339 (trusted url-cookie-trusted-urls)
340 (untrusted url-cookie-untrusted-urls)
341 (expires (cdr-safe (assoc-ignore-case "expires" args)))
342 (path (or (cdr-safe (assoc-ignore-case "path" args))
343 (file-name-directory
344 (url-filename url-current-object))))
345 (rest nil))
346 (while args
347 (if (not (member (downcase (car (car args)))
348 '("secure" "domain" "expires" "path")))
349 (setq rest (cons (car args) rest)))
350 (setq args (cdr args)))
351
352 ;; Sometimes we get dates that the timezone package cannot handle very
353 ;; gracefully - take care of this here, instead of in url-cookie-expired-p
354 ;; to speed things up.
355 (if (and expires
356 (string-match
357 (concat "^[^,]+, +\\(..\\)-\\(...\\)-\\(..\\) +"
358 "\\(..:..:..\\) +\\[*\\([^\]]+\\)\\]*$")
359 expires))
360 (setq expires (concat (match-string 1 expires) " "
361 (match-string 2 expires) " "
362 (match-string 3 expires) " "
363 (match-string 4 expires) " ["
364 (match-string 5 expires) "]")))
365
366 ;; This one is for older Emacs/XEmacs variants that don't
367 ;; understand this format without tenths of a second in it.
368 ;; Wednesday, 30-Dec-2037 16:00:00 GMT
369 ;; - vs -
370 ;; Wednesday, 30-Dec-2037 16:00:00.00 GMT
371 (if (and expires
372 (string-match
373 "\\([0-9]+\\)-\\([A-Za-z]+\\)-\\([0-9]+\\)[ \t]+\\([0-9]+:[0-9]+:[0-9]+\\)\\(\\.[0-9]+\\)*[ \t]+\\([-+a-zA-Z0-9]+\\)"
374 expires))
375 (setq expires (concat (match-string 1 expires) "-" ; day
376 (match-string 2 expires) "-" ; month
377 (match-string 3 expires) " " ; year
378 (match-string 4 expires) ".00 " ; hour:minutes:seconds
379 (match-string 6 expires)))) ":" ; timezone
380
381 (while (consp trusted)
382 (if (string-match (car trusted) current-url)
383 (setq trusted (- (match-end 0) (match-beginning 0)))
384 (pop trusted)))
385 (while (consp untrusted)
386 (if (string-match (car untrusted) current-url)
387 (setq untrusted (- (match-end 0) (match-beginning 0)))
388 (pop untrusted)))
389 (if (and trusted untrusted)
390 ;; Choose the more specific match
391 (if (> trusted untrusted)
392 (setq untrusted nil)
393 (setq trusted nil)))
394 (cond
395 (untrusted
396 ;; The site was explicity marked as untrusted by the user
397 nil)
398 ((or (eq url-privacy-level 'paranoid)
399 (and (listp url-privacy-level) (memq 'cookies url-privacy-level)))
400 ;; user never wants cookies
401 nil)
402 ((and url-cookie-confirmation
403 (not trusted)
404 (save-window-excursion
405 (with-output-to-temp-buffer "*Cookie Warning*"
406 (mapcar
407 (function
408 (lambda (x)
409 (princ (format "%s - %s" (car x) (cdr x))))) rest))
410 (prog1
411 (not (funcall url-confirmation-func
412 (format "Allow %s to set these cookies? "
413 (url-host url-current-object))))
414 (if (get-buffer "*Cookie Warning*")
415 (kill-buffer "*Cookie Warning*")))))
416 ;; user wants to be asked, and declined.
417 nil)
418 ((url-cookie-host-can-set-p (url-host url-current-object) domain)
419 ;; Cookie is accepted by the user, and passes our security checks
420 (let ((cur nil))
421 (while rest
422 (setq cur (pop rest))
423 (url-cookie-store (car cur) (cdr cur)
424 expires domain path secure))))
425 (t
426 (message "%s tried to set a cookie for domain %s - rejected."
427 (url-host url-current-object) domain)))))
428
429(defvar url-cookie-timer nil)
430
431(defcustom url-cookie-save-interval 3600
432 "*The number of seconds between automatic saves of cookies.
433Default is 1 hour. Note that if you change this variable outside of
434the `customize' interface after `url-do-setup' has been run, you need
435to run the `url-cookie-setup-save-timer' function manually."
436 :set (function (lambda (var val)
437 (set-default var val)
438 (and (featurep 'url)
439 (fboundp 'url-cookie-setup-save-timer)
440 (url-cookie-setup-save-timer))))
441 :type 'integer
442 :group 'url)
443
444;;;###autoload
445(defun url-cookie-setup-save-timer ()
446 "Reset the cookie saver timer."
447 (interactive)
448 (cond
449 ((featurep 'itimer)
450 (ignore-errors (delete-itimer url-cookie-timer))
451 (setq url-cookie-timer nil)
452 (if url-cookie-save-interval
453 (setq url-cookie-timer
454 (start-itimer "url-cookie-saver" 'url-cookie-write-file
455 url-cookie-save-interval
456 url-cookie-save-interval))))
457 ((fboundp 'run-at-time)
458 (ignore-errors (cancel-timer url-cookie-timer))
459 (setq url-cookie-timer nil)
460 (if url-cookie-save-interval
461 (setq url-cookie-timer
462 (run-at-time url-cookie-save-interval
463 url-cookie-save-interval
464 'url-cookie-write-file))))
465 (t nil)))
466
467(provide 'url-cookie)
468
diff --git a/lisp/url/url-dav.el b/lisp/url/url-dav.el
new file mode 100644
index 00000000000..ed5f04375ee
--- /dev/null
+++ b/lisp/url/url-dav.el
@@ -0,0 +1,973 @@
1;;; url-dav.el --- WebDAV support
2
3;; Copyright (C) 2001 Free Software Foundation, Inc.
4
5;; Author: Bill Perry <wmperry@gnu.org>
6;; Maintainer: Bill Perry <wmperry@gnu.org>
7;; Version: $Revision: 1.6 $
8;; Keywords: url, vc
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., 59 Temple Place - Suite 330,
23;; Boston, MA 02111-1307, USA.
24
25(eval-when-compile
26 (require 'cl))
27
28(require 'xml)
29(require 'url-util)
30(require 'url-handlers)
31
32(defvar url-dav-supported-protocols '(1 2)
33 "List of supported DAV versions.")
34
35;;;###autoload
36(defun url-dav-supported-p (url)
37 (and (featurep 'xml)
38 (fboundp 'xml-expand-namespace)
39 (intersection url-dav-supported-protocols
40 (plist-get (url-http-options url) 'dav))))
41
42(defun url-dav-node-text (node)
43 "Return the text data from the XML node NODE."
44 (mapconcat (lambda (txt)
45 (if (stringp txt)
46 txt
47 "")) (xml-node-children node) " "))
48
49
50;;; Parsing routines for the actual node contents.
51;;;
52;;; I am not incredibly happy with how this code looks/works right
53;;; now, but it DOES work, and if we get the API right, our callers
54;;; won't have to worry about the internal representation.
55
56(defconst url-dav-datatype-attribute
57 'urn:uuid:c2f41010-65b3-11d1-a29f-00aa00c14882/dt)
58
59(defun url-dav-process-integer-property (node)
60 (truncate (string-to-number (url-dav-node-text node))))
61
62(defun url-dav-process-number-property (node)
63 (string-to-number (url-dav-node-text node)))
64
65(defconst url-dav-iso8601-regexp
66 (let* ((dash "-?")
67 (colon ":?")
68 (4digit "\\([0-9][0-9][0-9][0-9]\\)")
69 (2digit "\\([0-9][0-9]\\)")
70 (date-fullyear 4digit)
71 (date-month 2digit)
72 (date-mday 2digit)
73 (time-hour 2digit)
74 (time-minute 2digit)
75 (time-second 2digit)
76 (time-secfrac "\\(\\.[0-9]+\\)?")
77 (time-numoffset (concat "[-+]\\(" time-hour "\\):" time-minute))
78 (time-offset (concat "Z" time-numoffset))
79 (partial-time (concat time-hour colon time-minute colon time-second
80 time-secfrac))
81 (full-date (concat date-fullyear dash date-month dash date-mday))
82 (full-time (concat partial-time time-offset))
83 (date-time (concat full-date "T" full-time)))
84 (list (concat "^" full-date)
85 (concat "T" partial-time)
86 (concat "Z" time-numoffset)))
87 "List of regular expressions matching iso8601 dates.
881st regular expression matches the date.
892nd regular expression matches the time.
903rd regular expression matches the (optional) timezone specification.
91")
92
93(defun url-dav-process-date-property (node)
94 (require 'parse-time)
95 (let* ((date-re (nth 0 url-dav-iso8601-regexp))
96 (time-re (nth 1 url-dav-iso8601-regexp))
97 (tz-re (nth 2 url-dav-iso8601-regexp))
98 (date-string (url-dav-node-text node))
99 re-start
100 time seconds minute hour fractional-seconds
101 day month year day-of-week dst tz)
102 ;; We need to populate 'time' with
103 ;; (SEC MIN HOUR DAY MON YEAR DOW DST TZ)
104
105 ;; Nobody else handles iso8601 correctly, lets do it ourselves.
106 (when (string-match date-re date-string re-start)
107 (setq year (string-to-int (match-string 1 date-string))
108 month (string-to-int (match-string 2 date-string))
109 day (string-to-int (match-string 3 date-string))
110 re-start (match-end 0))
111 (when (string-match time-re date-string re-start)
112 (setq hour (string-to-int (match-string 1 date-string))
113 minute (string-to-int (match-string 2 date-string))
114 seconds (string-to-int (match-string 3 date-string))
115 fractional-seconds (string-to-int (or
116 (match-string 4 date-string)
117 "0"))
118 re-start (match-end 0))
119 (when (string-match tz-re date-string re-start)
120 (setq tz (match-string 1 date-string)))
121 (url-debug 'dav "Parsed iso8601%s date" (if tz "tz" ""))
122 (setq time (list seconds minute hour day month year day-of-week dst tz))))
123
124 ;; Fall back to having Gnus do fancy things for us.
125 (when (not time)
126 (setq time (parse-time-string date-string)))
127
128 (if time
129 (setq time (apply 'encode-time time))
130 (url-debug 'dav "Unable to decode date (%S) (%s)"
131 (xml-node-name node) date-string))
132 time))
133
134(defun url-dav-process-boolean-property (node)
135 (/= 0 (string-to-int (url-dav-node-text node))))
136
137(defun url-dav-process-uri-property (node)
138 ;; Returns a parsed representation of the URL...
139 (url-generic-parse-url (url-dav-node-text node)))
140
141(defun url-dav-find-parser (node)
142 "Find a function to parse the XML node NODE."
143 (or (get (xml-node-name node) 'dav-parser)
144 (let ((fn (intern (format "url-dav-process-%s" (xml-node-name node)))))
145 (if (not (fboundp fn))
146 (setq fn 'url-dav-node-text)
147 (put (xml-node-name node) 'dav-parser fn))
148 fn)))
149
150(defmacro url-dav-dispatch-node (node)
151 `(funcall (url-dav-find-parser ,node) ,node))
152
153(defun url-dav-process-DAV:prop (node)
154 ;; A prop node has content model of ANY
155 ;;
156 ;; Some predefined nodes have special meanings though.
157 ;;
158 ;; DAV:supportedlock - list of DAV:lockentry
159 ;; DAV:source
160 ;; DAV:iscollection - boolean
161 ;; DAV:getcontentlength - integer
162 ;; DAV:ishidden - boolean
163 ;; DAV:getcontenttype - string
164 ;; DAV:resourcetype - node who's name is the resource type
165 ;; DAV:getlastmodified - date
166 ;; DAV:creationdate - date
167 ;; DAV:displayname - string
168 ;; DAV:getetag - unknown
169 (let ((children (xml-node-children node))
170 (node-type nil)
171 (props nil)
172 (value nil)
173 (handler-func nil))
174 (when (not children)
175 (error "No child nodes in DAV:prop"))
176
177 (while children
178 (setq node (car children)
179 node-type (intern
180 (or
181 (cdr-safe (assq url-dav-datatype-attribute
182 (xml-node-attributes node)))
183 "unknown"))
184 value nil)
185
186 (case node-type
187 ((dateTime.iso8601tz
188 dateTime.iso8601
189 dateTime.tz
190 dateTime.rfc1123
191 dateTime
192 date) ; date is our 'special' one...
193 ;; Some type of date/time string.
194 (setq value (url-dav-process-date-property node)))
195 (int
196 ;; Integer type...
197 (setq value (url-dav-process-integer-property node)))
198 ((number float)
199 (setq value (url-dav-process-number-property node)))
200 (boolean
201 (setq value (url-dav-process-boolean-property node)))
202 (uri
203 (setq value (url-dav-process-uri-property node)))
204 (otherwise
205 (if (not (eq node-type 'unknown))
206 (url-debug 'dav "Unknown data type in url-dav-process-prop: %s"
207 node-type))
208 (setq value (url-dav-dispatch-node node))))
209
210 (setq props (plist-put props (xml-node-name node) value)
211 children (cdr children)))
212 props))
213
214(defun url-dav-process-DAV:supportedlock (node)
215 ;; DAV:supportedlock is a list of DAV:lockentry items.
216 ;; DAV:lockentry in turn contains a DAV:lockscope and DAV:locktype.
217 ;; The DAV:lockscope must have a single node beneath it, ditto for
218 ;; DAV:locktype.
219 (let ((children (xml-node-children node))
220 (results nil)
221 scope type)
222 (while children
223 (when (and (not (stringp (car children)))
224 (eq (xml-node-name (car children)) 'DAV:lockentry))
225 (setq scope (assq 'DAV:lockscope (xml-node-children (car children)))
226 type (assq 'DAV:locktype (xml-node-children (car children))))
227 (when (and scope type)
228 (setq scope (xml-node-name (car (xml-node-children scope)))
229 type (xml-node-name (car (xml-node-children type))))
230 (push (cons type scope) results)))
231 (setq children (cdr children)))
232 results))
233
234(defun url-dav-process-subnode-property (node)
235 ;; Returns a list of child node names.
236 (delq nil (mapcar 'car-safe (xml-node-children node))))
237
238(defalias 'url-dav-process-DAV:depth 'url-dav-process-integer-property)
239(defalias 'url-dav-process-DAV:resourcetype 'url-dav-process-subnode-property)
240(defalias 'url-dav-process-DAV:locktype 'url-dav-process-subnode-property)
241(defalias 'url-dav-process-DAV:lockscope 'url-dav-process-subnode-property)
242(defalias 'url-dav-process-DAV:getcontentlength 'url-dav-process-integer-property)
243(defalias 'url-dav-process-DAV:getlastmodified 'url-dav-process-date-property)
244(defalias 'url-dav-process-DAV:creationdate 'url-dav-process-date-property)
245(defalias 'url-dav-process-DAV:iscollection 'url-dav-process-boolean-property)
246(defalias 'url-dav-process-DAV:ishidden 'url-dav-process-boolean-property)
247
248(defun url-dav-process-DAV:locktoken (node)
249 ;; DAV:locktoken can have one or more DAV:href children.
250 (delq nil (mapcar (lambda (n)
251 (if (stringp n)
252 n
253 (url-dav-dispatch-node n)))
254 (xml-node-children node))))
255
256(defun url-dav-process-DAV:owner (node)
257 ;; DAV:owner can contain anything.
258 (delq nil (mapcar (lambda (n)
259 (if (stringp n)
260 n
261 (url-dav-dispatch-node n)))
262 (xml-node-children node))))
263
264(defun url-dav-process-DAV:activelock (node)
265 ;; DAV:activelock can contain:
266 ;; DAV:lockscope
267 ;; DAV:locktype
268 ;; DAV:depth
269 ;; DAV:owner (optional)
270 ;; DAV:timeout (optional)
271 ;; DAV:locktoken (optional)
272 (let ((children (xml-node-children node))
273 (results nil))
274 (while children
275 (if (listp (car children))
276 (push (cons (xml-node-name (car children))
277 (url-dav-dispatch-node (car children)))
278 results))
279 (setq children (cdr children)))
280 results))
281
282(defun url-dav-process-DAV:lockdiscovery (node)
283 ;; Can only contain a list of DAV:activelock objects.
284 (let ((children (xml-node-children node))
285 (results nil))
286 (while children
287 (cond
288 ((stringp (car children))
289 ;; text node? why?
290 nil)
291 ((eq (xml-node-name (car children)) 'DAV:activelock)
292 (push (url-dav-dispatch-node (car children)) results))
293 (t
294 ;; Ignore unknown nodes...
295 nil))
296 (setq children (cdr children)))
297 results))
298
299(defun url-dav-process-DAV:status (node)
300 ;; The node contains a standard HTTP/1.1 response line... we really
301 ;; only care about the numeric status code.
302 (let ((status (url-dav-node-text node)))
303 (if (string-match "\\`[ \r\t\n]*HTTP/[0-9.]+ \\([0-9]+\\)" status)
304 (string-to-int (match-string 1 status))
305 500)))
306
307(defun url-dav-process-DAV:propstat (node)
308 ;; A propstate node can have the following children...
309 ;;
310 ;; DAV:prop - a list of properties and values
311 ;; DAV:status - An HTTP/1.1 status line
312 (let ((children (xml-node-children node))
313 (props nil)
314 (status nil))
315 (when (not children)
316 (error "No child nodes in DAV:propstat"))
317
318 (setq props (url-dav-dispatch-node (assq 'DAV:prop children))
319 status (url-dav-dispatch-node (assq 'DAV:status children)))
320
321 ;; Need to parse out the HTTP status
322 (setq props (plist-put props 'DAV:status status))
323 props))
324
325(defun url-dav-process-DAV:response (node)
326 (let ((children (xml-node-children node))
327 (propstat nil)
328 (href))
329 (when (not children)
330 (error "No child nodes in DAV:response"))
331
332 ;; A response node can have the following children...
333 ;;
334 ;; DAV:href - URL the response is for.
335 ;; DAV:propstat - see url-dav-process-propstat
336 ;; DAV:responsedescription - text description of the response
337 (setq propstat (assq 'DAV:propstat children)
338 href (assq 'DAV:href children))
339
340 (when (not href)
341 (error "No href in DAV:response"))
342
343 (when (not propstat)
344 (error "No propstat in DAV:response"))
345
346 (setq propstat (url-dav-dispatch-node propstat)
347 href (url-dav-dispatch-node href))
348 (cons href propstat)))
349
350(defun url-dav-process-DAV:multistatus (node)
351 (let ((children (xml-node-children node))
352 (results nil))
353 (while children
354 (push (url-dav-dispatch-node (car children)) results)
355 (setq children (cdr children)))
356 results))
357
358
359;;; DAV request/response generation/processing
360(defun url-dav-process-response (buffer url)
361 "Parses a WebDAV response from BUFFER, interpreting it relative to URL.
362
363The buffer must have been retrieved by HTTP or HTTPS and contain an
364XML document.
365"
366 (declare (special url-http-content-type
367 url-http-response-status
368 url-http-end-of-headers))
369 (let ((tree nil)
370 (overall-status nil))
371 (when buffer
372 (unwind-protect
373 (save-excursion
374 (set-buffer buffer)
375 (goto-char url-http-end-of-headers)
376 (setq overall-status url-http-response-status)
377
378 ;; XML documents can be transferred as either text/xml or
379 ;; application/xml, and we are required to accept both of
380 ;; them.
381 (if (and
382 url-http-content-type
383 (or (string-match "^text/xml" url-http-content-type)
384 (string-match "^application/xml" url-http-content-type)))
385 (setq tree (xml-parse-region (point) (point-max)))))
386 ;; Clean up after ourselves.
387 '(kill-buffer buffer)))
388
389 ;; We should now be
390 (if (eq (xml-node-name (car tree)) 'DAV:multistatus)
391 (url-dav-dispatch-node (car tree))
392 (url-debug 'dav "Got back singleton response for URL(%S)" url)
393 (let ((properties (url-dav-dispatch-node (car tree))))
394 ;; We need to make sure we have a DAV:status node in there for
395 ;; higher-level code;
396 (setq properties (plist-put properties 'DAV:status overall-status))
397 ;; Make this look like a DAV:multistatus parse tree so that
398 ;; nobody but us needs to know the difference.
399 (list (cons url properties))))))
400
401(defun url-dav-request (url method tag body
402 &optional depth headers namespaces)
403 "Performs WebDAV operation METHOD on URL. Returns the parsed responses.
404Automatically creates an XML request body if TAG is non-nil.
405BODY is the XML document fragment to be enclosed by <TAG></TAG>.
406
407DEPTH is how deep the request should propogate. Default is 0, meaning
408it should apply only to URL. A negative number means to use
409`Infinity' for the depth. Not all WebDAV servers support this depth
410though.
411
412HEADERS is an assoc list of extra headers to send in the request.
413
414NAMESPACES is an assoc list of (NAMESPACE . EXPANSION), and these are
415added to the <TAG> element. The DAV=DAV: namespace is automatically
416added to this list, so most requests can just pass in nil.
417"
418 ;; Take care of the default value for depth...
419 (setq depth (or depth 0))
420
421 ;; Now lets translate it into something webdav can understand.
422 (if (< depth 0)
423 (setq depth "Infinity")
424 (setq depth (int-to-string depth)))
425 (if (not (assoc "DAV" namespaces))
426 (setq namespaces (cons '("DAV" . "DAV:") namespaces)))
427
428 (let* ((url-request-extra-headers `(("Depth" . ,depth)
429 ("Content-type" . "text/xml")
430 ,@headers))
431 (url-request-method method)
432 (url-request-data
433 (if tag
434 (concat
435 "<?xml version=\"1.0\" encoding=\"utf-8\" ?>\n"
436 "<" (symbol-name tag) " "
437 ;; add in the appropriate namespaces...
438 (mapconcat (lambda (ns)
439 (concat "xmlns:" (car ns) "='" (cdr ns) "'"))
440 namespaces "\n ")
441 ">\n"
442 body
443 "</" (symbol-name tag) ">\n"))))
444 (url-dav-process-response (url-retrieve-synchronously url) url)))
445
446;;;###autoload
447(defun url-dav-get-properties (url &optional attributes depth namespaces)
448 "Return properties for URL, up to DEPTH levels deep.
449
450Returns an assoc list, where the key is the filename (possibly a full
451URI), and the value is a standard property list of DAV property
452names (ie: DAV:resourcetype).
453"
454 (url-dav-request url "PROPFIND" 'DAV:propfind
455 (if attributes
456 (mapconcat (lambda (attr)
457 (concat "<DAV:prop><"
458 (symbol-name attr)
459 "/></DAV:prop>"))
460 attributes "\n ")
461 " <DAV:allprop/>")
462 depth nil namespaces))
463
464(defmacro url-dav-http-success-p (status)
465 "Return whether PROPERTIES was the result of a successful DAV request."
466 `(= (/ (or ,status 500) 100) 2))
467
468
469;;; Locking support
470(defvar url-dav-lock-identifier (concat "mailto:" user-mail-address)
471 "*URL used as contact information when creating locks in DAV.
472This will be used as the contents of the DAV:owner/DAV:href tag to
473identify the owner of a LOCK when requesting it. This will be shown
474to other users when the DAV:lockdiscovery property is requested, so
475make sure you are comfortable with it leaking to the outside world.
476")
477
478;;;###autoload
479(defun url-dav-lock-resource (url exclusive &optional depth)
480 "Request a lock on URL. If EXCLUSIVE is non-nil, get an exclusive lock.
481Optional 3rd argument DEPTH says how deep the lock should go, default is 0
482\(lock only the resource and none of its children\).
483
484Returns a cons-cell of (SUCCESSFUL-RESULTS . FAILURE-RESULTS).
485SUCCESSFUL-RESULTS is a list of (URL STATUS locktoken).
486FAILURE-RESULTS is a list of (URL STATUS).
487"
488 (setq exclusive (if exclusive "<DAV:exclusive/>" "<DAV:shared/>"))
489 (let* ((body
490 (concat
491 " <DAV:lockscope>" exclusive "</DAV:lockscope>\n"
492 " <DAV:locktype> <DAV:write/> </DAV:locktype>\n"
493 " <DAV:owner>\n"
494 " <DAV:href>" url-dav-lock-identifier "</DAV:href>\n"
495 " </DAV:owner>\n"))
496 (response nil) ; Responses to the LOCK request
497 (result nil) ; For walking thru the response list
498 (child-url nil)
499 (child-status nil)
500 (failures nil) ; List of failure cases (URL . STATUS)
501 (successes nil)) ; List of success cases (URL . STATUS)
502 (setq response (url-dav-request url "LOCK" 'DAV:lockinfo body
503 depth '(("Timeout" . "Infinite"))))
504
505 ;; Get the parent URL ready for expand-file-name
506 (if (not (vectorp url))
507 (setq url (url-generic-parse-url url)))
508
509 ;; Walk thru the response list, fully expand the URL, and grab the
510 ;; status code.
511 (while response
512 (setq result (pop response)
513 child-url (url-expand-file-name (pop result) url)
514 child-status (or (plist-get result 'DAV:status) 500))
515 (if (url-dav-http-success-p child-status)
516 (push (list url child-status "huh") successes)
517 (push (list url child-status) failures)))
518 (cons successes failures)))
519
520;;;###autoload
521(defun url-dav-active-locks (url &optional depth)
522 "Return an assoc list of all active locks on URL."
523 (let ((response (url-dav-get-properties url '(DAV:lockdiscovery) depth))
524 (properties nil)
525 (child nil)
526 (child-url nil)
527 (child-results nil)
528 (results nil))
529 (if (not (vectorp url))
530 (setq url (url-generic-parse-url url)))
531
532 (while response
533 (setq child (pop response)
534 child-url (pop child)
535 child-results nil)
536 (when (and (url-dav-http-success-p (plist-get child 'DAV:status))
537 (setq child (plist-get child 'DAV:lockdiscovery)))
538 ;; After our parser has had its way with it, The
539 ;; DAV:lockdiscovery property is a list of DAV:activelock
540 ;; objects, which are comprised of DAV:activelocks, which
541 ;; assoc lists of properties and values.
542 (while child
543 (if (assq 'DAV:locktoken (car child))
544 (let ((tokens (cdr (assq 'DAV:locktoken (car child))))
545 (owners (cdr (assq 'DAV:owner (car child)))))
546 (dolist (token tokens)
547 (dolist (owner owners)
548 (push (cons token owner) child-results)))))
549 (pop child)))
550 (if child-results
551 (push (cons (url-expand-file-name child-url url) child-results)
552 results)))
553 results))
554
555;;;###autoload
556(defun url-dav-unlock-resource (url lock-token)
557 "Release the lock on URL represented by LOCK-TOKEN.
558Returns `t' iff the lock was successfully released.
559"
560 (declare (special url-http-response-status))
561 (let* ((url-request-extra-headers (list (cons "Lock-Token"
562 (concat "<" lock-token ">"))))
563 (url-request-method "UNLOCK")
564 (url-request-data nil)
565 (buffer (url-retrieve-synchronously url))
566 (result nil))
567 (when buffer
568 (unwind-protect
569 (save-excursion
570 (set-buffer buffer)
571 (setq result (url-dav-http-success-p url-http-response-status)))
572 (kill-buffer buffer)))
573 result))
574
575
576;;; file-name-handler stuff
577(defun url-dav-file-attributes-mode-string (properties)
578 (let ((modes (make-string 10 ?-))
579 (supported-locks (plist-get properties 'DAV:supportedlock))
580 (executable-p (equal (plist-get properties 'http://apache.org/dav/props/executable)
581 "T"))
582 (directory-p (memq 'DAV:collection (plist-get properties 'DAV:resourcetype)))
583 (readable t)
584 (lock nil))
585 ;; Assume we can read this, otherwise the PROPFIND would have
586 ;; failed.
587 (when readable
588 (aset modes 1 ?r)
589 (aset modes 4 ?r)
590 (aset modes 7 ?r))
591
592 (when directory-p
593 (aset modes 0 ?d))
594
595 (when executable-p
596 (aset modes 3 ?x)
597 (aset modes 6 ?x)
598 (aset modes 9 ?x))
599
600 (while supported-locks
601 (setq lock (car supported-locks)
602 supported-locks (cdr supported-locks))
603 (case (car lock)
604 (DAV:write
605 (case (cdr lock)
606 (DAV:shared ; group permissions (possibly world)
607 (aset modes 5 ?w))
608 (DAV:exclusive
609 (aset modes 2 ?w)) ; owner permissions?
610 (otherwise
611 (url-debug 'dav "Unrecognized DAV:lockscope (%S)" (cdr lock)))))
612 (otherwise
613 (url-debug 'dav "Unrecognized DAV:locktype (%S)" (car lock)))))
614 modes))
615
616;;;###autoload
617(defun url-dav-file-attributes (url)
618 (let ((properties (cdar (url-dav-get-properties url)))
619 (attributes nil))
620 (if (and properties
621 (url-dav-http-success-p (plist-get properties 'DAV:status)))
622 ;; We got a good DAV response back..
623 (setq attributes
624 (list
625 ;; t for directory, string for symbolic link, or nil
626 ;; Need to support DAV Bindings to figure out the
627 ;; symbolic link issues.
628 (if (memq 'DAV:collection (plist-get properties 'DAV:resourcetype)) t nil)
629
630 ;; Number of links to file... Needs DAV Bindings.
631 1
632
633 ;; File uid - no way to figure out?
634 0
635
636 ;; File gid - no way to figure out?
637 0
638
639 ;; Last access time - ???
640 nil
641
642 ;; Last modification time
643 (plist-get properties 'DAV:getlastmodified)
644
645 ;; Last status change time... just reuse last-modified
646 ;; for now.
647 (plist-get properties 'DAV:getlastmodified)
648
649 ;; size in bytes
650 (or (plist-get properties 'DAV:getcontentlength) 0)
651
652 ;; file modes as a string like `ls -l'
653 ;;
654 ;; Should be able to build this up from the
655 ;; DAV:supportedlock attribute pretty easily. Getting
656 ;; the group info could be impossible though.
657 (url-dav-file-attributes-mode-string properties)
658
659 ;; t iff file's gid would change if it were deleted &
660 ;; recreated. No way for us to know that thru DAV.
661 nil
662
663 ;; inode number - meaningless
664 nil
665
666 ;; device number - meaningless
667 nil))
668 ;; Fall back to just the normal http way of doing things.
669 (setq attributes (url-http-head-file-attributes url)))
670 attributes))
671
672;;;###autoload
673(defun url-dav-save-resource (url obj &optional content-type lock-token)
674 "Save OBJ as URL using WebDAV.
675URL must be a fully qualified URL.
676OBJ may be a buffer or a string."
677 (let ((buffer nil)
678 (result nil)
679 (url-request-extra-headers nil)
680 (url-request-method "PUT")
681 (url-request-data
682 (cond
683 ((bufferp obj)
684 (save-excursion
685 (set-buffer obj)
686 (buffer-string)))
687 ((stringp obj)
688 obj)
689 (t
690 (error "Invalid object to url-dav-save-resource")))))
691
692 (if lock-token
693 (push
694 (cons "If" (concat "(<" lock-token ">)"))
695 url-request-extra-headers))
696
697 ;; Everything must always have a content-type when we submit it.
698 (push
699 (cons "Content-type" (or content-type "application/octet-stream"))
700 url-request-extra-headers)
701
702 ;; Do the save...
703 (setq buffer (url-retrieve-synchronously url))
704
705 ;; Sanity checking
706 (when buffer
707 (unwind-protect
708 (save-excursion
709 (set-buffer buffer)
710 (setq result (url-dav-http-success-p url-http-response-status)))
711 (kill-buffer buffer)))
712 result))
713
714(eval-when-compile
715 (defmacro url-dav-delete-something (url lock-token &rest error-checking)
716 "Delete URL completely, with no sanity checking whatsoever. DO NOT USE.
717This is defined as a macro that will not be visible from compiled files.
718Use with care, and even then think three times.
719"
720 `(progn
721 ,@error-checking
722 (url-dav-request ,url "DELETE" nil nil -1
723 (if ,lock-token
724 (list
725 (cons "If"
726 (concat "(<" ,lock-token ">)"))))))))
727
728
729;;;###autoload
730(defun url-dav-delete-directory (url &optional recursive lock-token)
731 "Delete the WebDAV collection URL.
732If optional second argument RECURSIVE is non-nil, then delete all
733files in the collection as well.
734"
735 (let ((status nil)
736 (props nil)
737 (props nil))
738 (setq props (url-dav-delete-something
739 url lock-token
740 (setq props (url-dav-get-properties url '(DAV:getcontenttype) 1))
741 (if (and (not recursive)
742 (/= (length props) 1))
743 (signal 'file-error (list "Removing directory"
744 "directory not empty" url)))))
745
746 (mapc (lambda (result)
747 (setq status (plist-get (cdr result) 'DAV:status))
748 (if (not (url-dav-http-success-p status))
749 (signal 'file-error (list "Removing directory"
750 "Errror removing"
751 (car result) status))))
752 props))
753 nil)
754
755;;;###autoload
756(defun url-dav-delete-file (url &optional lock-token)
757 "Delete file named URL."
758 (let ((props nil)
759 (status nil))
760 (setq props (url-dav-delete-something
761 url lock-token
762 (setq props (url-dav-get-properties url))
763 (if (eq (plist-get (cdar props) 'DAV:resourcetype) 'DAV:collection)
764 (signal 'file-error (list "Removing old name" "is a collection" url)))))
765
766 (mapc (lambda (result)
767 (setq status (plist-get (cdr result) 'DAV:status))
768 (if (not (url-dav-http-success-p status))
769 (signal 'file-error (list "Removing old name"
770 "Errror removing"
771 (car result) status))))
772 props))
773 nil)
774
775;;;###autoload
776(defun url-dav-directory-files (url &optional full match nosort files-only)
777 "Return a list of names of files in DIRECTORY.
778There are three optional arguments:
779If FULL is non-nil, return absolute file names. Otherwise return names
780 that are relative to the specified directory.
781If MATCH is non-nil, mention only file names that match the regexp MATCH.
782If NOSORT is non-nil, the list is not sorted--its order is unpredictable.
783 NOSORT is useful if you plan to sort the result yourself.
784"
785 (let ((properties (url-dav-get-properties url '(DAV:resourcetype) 1))
786 (child-url nil)
787 (child-props nil)
788 (files nil)
789 (parsed-url (url-generic-parse-url url)))
790
791 (if (= (length properties) 1)
792 (signal 'file-error (list "Opening directory" "not a directory" url)))
793
794 (while properties
795 (setq child-props (pop properties)
796 child-url (pop child-props))
797 (if (and (eq (plist-get child-props 'DAV:resourcetype) 'DAV:collection)
798 files-only)
799 ;; It is a directory, and we were told to return just files.
800 nil
801
802 ;; Fully expand the URL and then rip off the beginning if we
803 ;; are not supposed to return fully-qualified names.
804 (setq child-url (url-expand-file-name child-url parsed-url))
805 (if (not full)
806 (setq child-url (substring child-url (length url))))
807
808 ;; We don't want '/' as the last character in filenames...
809 (if (string-match "/$" child-url)
810 (setq child-url (substring child-url 0 -1)))
811
812 ;; If we have a match criteria, then apply it.
813 (if (or (and match (not (string-match match child-url)))
814 (string= child-url "")
815 (string= child-url url))
816 nil
817 (push child-url files))))
818
819 (if nosort
820 files
821 (sort files 'string-lessp))))
822
823;;;###autoload
824(defun url-dav-file-directory-p (url)
825 "Return t if URL names an existing DAV collection."
826 (let ((properties (cdar (url-dav-get-properties url '(DAV:resourcetype)))))
827 (eq (plist-get properties 'DAV:resourcetype) 'DAV:collection)))
828
829;;;###autoload
830(defun url-dav-make-directory (url &optional parents)
831 "Create the directory DIR and any nonexistent parent dirs."
832 (declare (special url-http-response-status))
833 (let* ((url-request-extra-headers nil)
834 (url-request-method "MKCOL")
835 (url-request-data nil)
836 (buffer (url-retrieve-synchronously url))
837 (result nil))
838 (when buffer
839 (unwind-protect
840 (save-excursion
841 (set-buffer buffer)
842 (case url-http-response-status
843 (201 ; Collection created in its entirety
844 (setq result t))
845 (403 ; Forbidden
846 nil)
847 (405 ; Method not allowed
848 nil)
849 (409 ; Conflict
850 nil)
851 (415 ; Unsupported media type (WTF?)
852 nil)
853 (507 ; Insufficient storage
854 nil)
855 (otherwise
856 nil)))
857 (kill-buffer buffer)))
858 result))
859
860;;;###autoload
861(defun url-dav-rename-file (oldname newname &optional overwrite)
862 (if (not (and (string-match url-handler-regexp oldname)
863 (string-match url-handler-regexp newname)))
864 (signal 'file-error "Cannot rename between different URL backends" oldname newname))
865
866 (let* ((headers nil)
867 (props nil)
868 (status nil)
869 (directory-p (url-dav-file-directory-p oldname))
870 (exists-p (url-http-file-exists-p newname)))
871
872 (if (and exists-p
873 (or
874 (null overwrite)
875 (and (numberp overwrite)
876 (not (yes-or-no-p
877 (format "File %s already exists; rename to it anyway? "
878 newname))))))
879 (signal 'file-already-exists (list "File already exists" newname)))
880
881 ;; Honor the overwrite flag...
882 (if overwrite (push '("Overwrite" . "T") headers))
883
884 ;; Have to tell them where to copy it to!
885 (push (cons "Destination" newname) headers)
886
887 ;; Always send a depth of -1 in case we are moving a collection.
888 (setq props (url-dav-request oldname "MOVE" nil nil (if directory-p -1 0)
889 headers))
890
891 (mapc (lambda (result)
892 (setq status (plist-get (cdr result) 'DAV:status))
893
894 (if (not (url-dav-http-success-p status))
895 (signal 'file-error (list "Renaming" oldname newname status))))
896 props)
897 t))
898
899;;;###autoload
900(defun url-dav-file-name-all-completions (file url)
901 "Return a list of all completions of file name FILE in directory DIRECTORY.
902These are all file names in directory DIRECTORY which begin with FILE.
903"
904 (url-dav-directory-files url nil (concat "^" file ".*")))
905
906;;;###autoload
907(defun url-dav-file-name-completion (file url)
908 "Complete file name FILE in directory DIRECTORY.
909Returns the longest string
910common to all file names in DIRECTORY that start with FILE.
911If there is only one and FILE matches it exactly, returns t.
912Returns nil if DIR contains no name starting with FILE.
913"
914 (let ((matches (url-dav-file-name-all-completions file url))
915 (result nil))
916 (cond
917 ((null matches)
918 ;; No matches
919 nil)
920 ((and (= (length matches) 1)
921 (string= file (car matches)))
922 ;; Only one file and FILE matches it exactly...
923 t)
924 (t
925 ;; Need to figure out the longest string that they have in commmon
926 (setq matches (sort matches (lambda (a b) (> (length a) (length b)))))
927 (let ((n (length file))
928 (searching t)
929 (regexp nil)
930 (failed nil))
931 (while (and searching
932 (< n (length (car matches))))
933 (setq regexp (concat "^" (substring (car matches) 0 (1+ n)))
934 failed nil)
935 (dolist (potential matches)
936 (if (not (string-match regexp potential))
937 (setq failed t)))
938 (if failed
939 (setq searching nil)
940 (incf n)))
941 (substring (car matches) 0 n))))))
942
943(defun url-dav-register-handler (op)
944 (put op 'url-file-handlers (intern-soft (format "url-dav-%s" op))))
945
946(mapcar 'url-dav-register-handler
947 '(file-name-all-completions
948 file-name-completion
949 rename-file
950 make-directory
951 file-directory-p
952 directory-files
953 delete-file
954 delete-directory
955 file-attributes))
956
957
958;;; Version Control backend cruft
959
960;(put 'vc-registered 'url-file-handlers 'url-dav-vc-registered)
961
962;;;###autoload
963(defun url-dav-vc-registered (url)
964 (if (and (string-match "\\`https?" url)
965 (plist-get (url-http-options url) 'dav))
966 (progn
967 (vc-file-setprop url 'vc-backend 'dav)
968 t)))
969
970
971;;; Miscellaneous stuff.
972
973(provide 'url-dav)
diff --git a/lisp/url/url-dired.el b/lisp/url/url-dired.el
new file mode 100644
index 00000000000..9a9e45fa15d
--- /dev/null
+++ b/lisp/url/url-dired.el
@@ -0,0 +1,102 @@
1;;; url-dired.el --- URL Dired minor mode
2;; Author: $Author: fx $
3;; Created: $Date: 2001/05/05 16:44:20 $
4;; Version: $Revision: 1.3 $
5;; Keywords: comm, files
6
7;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
8;;; Copyright (c) 1993 - 1996 by William M. Perry <wmperry@cs.indiana.edu>
9;;; Copyright (c) 1996 - 1999 Free Software Foundation, Inc.
10;;;
11;;; This file is part of GNU Emacs.
12;;;
13;;; GNU Emacs is free software; you can redistribute it and/or modify
14;;; it under the terms of the GNU General Public License as published by
15;;; the Free Software Foundation; either version 2, or (at your option)
16;;; any later version.
17;;;
18;;; GNU Emacs is distributed in the hope that it will be useful,
19;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
20;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
21;;; GNU General Public License for more details.
22;;;
23;;; You should have received a copy of the GNU General Public License
24;;; along with GNU Emacs; see the file COPYING. If not, write to the
25;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
26;;; Boston, MA 02111-1307, USA.
27;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
28
29(autoload 'w3-fetch "w3")
30(autoload 'w3-open-local "w3")
31(autoload 'dired-get-filename "dired")
32
33(defvar url-dired-minor-mode-map
34 (let ((map (make-sparse-keymap)))
35 (define-key map "\C-m" 'url-dired-find-file)
36 (if (featurep 'xemacs)
37 (define-key map [button2] 'url-dired-find-file-mouse)
38 (define-key map [mouse-2] 'url-dired-find-file-mouse))
39 map)
40 "Keymap used when browsing directories.")
41
42(defvar url-dired-minor-mode nil
43 "Whether we are in url-dired-minor-mode")
44
45(make-variable-buffer-local 'url-dired-minor-mode)
46
47(defun url-dired-find-file ()
48 "In dired, visit the file or directory named on this line, using Emacs-W3."
49 (interactive)
50 (let ((filename (dired-get-filename)))
51 (cond ((string-match "/\\(.*@.*\\):\\(/.*\\)" filename)
52 (w3-fetch (concat "file://" (match-string 1 filename) (match-string 2 filename))))
53 (t
54 (w3-open-local filename)))))
55
56(defun url-dired-find-file-mouse (event)
57 "In dired, visit the file or directory name you click on, using Emacs-W3."
58 (interactive "@e")
59 (mouse-set-point event)
60 (url-dired-find-file))
61
62(defun url-dired-minor-mode (&optional arg)
63 "Minor mode for directory browsing with Emacs-W3."
64 (interactive "P")
65 (cond
66 ((null arg)
67 (setq url-dired-minor-mode (not url-dired-minor-mode)))
68 ((equal 0 arg)
69 (setq url-dired-minor-mode nil))
70 (t
71 (setq url-dired-minor-mode t))))
72
73(if (not (fboundp 'add-minor-mode))
74 (defun add-minor-mode (toggle name &optional keymap after toggle-fun)
75 "Add a minor mode to `minor-mode-alist' and `minor-mode-map-alist'.
76TOGGLE is a symbol which is used as the variable which toggle the minor mode,
77NAME is the name that should appear in the modeline (it should be a string
78beginning with a space), KEYMAP is a keymap to make active when the minor
79mode is active, and AFTER is the toggling symbol used for another minor
80mode. If AFTER is non-nil, then it is used to position the new mode in the
81minor-mode alists. TOGGLE-FUN specifies an interactive function that
82is called to toggle the mode on and off; this affects what appens when
83button2 is pressed on the mode, and when button3 is pressed somewhere
84in the list of modes. If TOGGLE-FUN is nil and TOGGLE names an
85interactive function, TOGGLE is used as the toggle function.
86
87Example: (add-minor-mode 'view-minor-mode \" View\" view-mode-map)"
88 (if (not (assq toggle minor-mode-alist))
89 (setq minor-mode-alist (cons (list toggle name) minor-mode-alist)))
90 (if (and keymap (not (assq toggle minor-mode-map-alist)))
91 (setq minor-mode-map-alist (cons (cons toggle keymap)
92 minor-mode-map-alist)))))
93
94(add-minor-mode 'url-dired-minor-mode " URL" url-dired-minor-mode-map)
95
96(defun url-find-file-dired (dir)
97 "\"Edit\" directory DIR, but with additional URL-friendly bindings."
98 (interactive "DURL Dired (directory): ")
99 (find-file dir)
100 (url-dired-minor-mode t))
101
102(provide 'url-dired)
diff --git a/lisp/url/url-expand.el b/lisp/url/url-expand.el
new file mode 100644
index 00000000000..49048dd323e
--- /dev/null
+++ b/lisp/url/url-expand.el
@@ -0,0 +1,143 @@
1;;; url-expand.el --- expand-file-name for URLs
2;; Author: $Author: wmperry $
3;; Created: $Date: 1999/12/05 08:09:15 $
4;; Version: $Revision: 1.3 $
5;; Keywords: comm, data, processes
6
7;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
8;;; Copyright (c) 1999 Free Software Foundation, Inc.
9;;;
10;;; This file is part of GNU Emacs.
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 the
24;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
25;;; Boston, MA 02111-1307, USA.
26;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
27
28(require 'url-methods)
29(require 'url-util)
30(require 'url-parse)
31
32(defun url-expander-remove-relative-links (name)
33 ;; Strip . and .. from pathnames
34 (let ((new (if (not (string-match "^/" name))
35 (concat "/" name)
36 name)))
37
38 ;; If it ends with a '/.' or '/..', tack on a trailing '/' sot hat
39 ;; the tests that follow are not too complicated in terms of
40 ;; looking for '..' or '../', etc.
41 (if (string-match "/\\.+$" new)
42 (setq new (concat new "/")))
43
44 ;; Remove '/./' first
45 (while (string-match "/\\(\\./\\)" new)
46 (setq new (concat (substring new 0 (match-beginning 1))
47 (substring new (match-end 1)))))
48
49 ;; Then remove '/../'
50 (while (string-match "/\\([^/]*/\\.\\./\\)" new)
51 (setq new (concat (substring new 0 (match-beginning 1))
52 (substring new (match-end 1)))))
53
54 ;; Remove cruft at the beginning of the string, so people that put
55 ;; in extraneous '..' because they are morons won't lose.
56 (while (string-match "^/\\.\\.\\(/\\)" new)
57 (setq new (substring new (match-beginning 1) nil)))
58 new))
59
60(defun url-expand-file-name (url &optional default)
61 "Convert URL to a fully specified URL, and canonicalize it.
62Second arg DEFAULT is a URL to start with if URL is relative.
63If DEFAULT is nil or missing, the current buffer's URL is used.
64Path components that are `.' are removed, and
65path components followed by `..' are removed, along with the `..' itself."
66 (if (and url (not (string-match "^#" url)))
67 ;; Need to nuke newlines and spaces in the URL, or we open
68 ;; ourselves up to potential security holes.
69 (setq url (mapconcat (function (lambda (x)
70 (if (memq x '(? ?\n ?\r))
71 ""
72 (char-to-string x))))
73 url "")))
74
75 ;; Need to figure out how/where to expand the fragment relative to
76 (setq default (cond
77 ((vectorp default)
78 ;; Default URL has already been parsed
79 default)
80 (default
81 ;; They gave us a default URL in non-parsed format
82 (url-generic-parse-url default))
83 (url-current-object
84 ;; We are in a URL-based buffer, use the pre-parsed object
85 url-current-object)
86 ((string-match url-nonrelative-link url)
87 ;; The URL they gave us is absolute, go for it.
88 nil)
89 (t
90 ;; Hmmm - this shouldn't ever happen.
91 (error "url-expand-file-name confused - no default?"))))
92
93 (cond
94 ((= (length url) 0) ; nil or empty string
95 (url-recreate-url default))
96 ((string-match "^#" url) ; Offset link, use it raw
97 url)
98 ((string-match url-nonrelative-link url) ; Fully-qualified URL, return it immediately
99 url)
100 (t
101 (let* ((urlobj (url-generic-parse-url url))
102 (inhibit-file-name-handlers t)
103 (expander (url-scheme-get-property (url-type default) 'expand-file-name)))
104 (if (string-match "^//" url)
105 (setq urlobj (url-generic-parse-url (concat (url-type default) ":"
106 url))))
107 (funcall expander urlobj default)
108 (url-recreate-url urlobj)))))
109
110(defun url-identity-expander (urlobj defobj)
111 (url-set-type urlobj (or (url-type urlobj) (url-type defobj))))
112
113(defun url-default-expander (urlobj defobj)
114 ;; The default expansion routine - urlobj is modified by side effect!
115 (if (url-type urlobj)
116 ;; Well, they told us the scheme, let's just go with it.
117 nil
118 (url-set-type urlobj (or (url-type urlobj) (url-type defobj)))
119 (url-set-port urlobj (or (url-port urlobj)
120 (and (string= (url-type urlobj)
121 (url-type defobj))
122 (url-port defobj))))
123 (if (not (string= "file" (url-type urlobj)))
124 (url-set-host urlobj (or (url-host urlobj) (url-host defobj))))
125 (if (string= "ftp" (url-type urlobj))
126 (url-set-user urlobj (or (url-user urlobj) (url-user defobj))))
127 (if (string= (url-filename urlobj) "")
128 (url-set-filename urlobj "/"))
129 (if (string-match "^/" (url-filename urlobj))
130 nil
131 (let ((query nil)
132 (file nil)
133 (sepchar nil))
134 (if (string-match "[?#]" (url-filename urlobj))
135 (setq query (substring (url-filename urlobj) (match-end 0))
136 file (substring (url-filename urlobj) 0 (match-beginning 0))
137 sepchar (substring (url-filename urlobj) (match-beginning 0) (match-end 0)))
138 (setq file (url-filename urlobj)))
139 (setq file (url-expander-remove-relative-links
140 (concat (url-basepath (url-filename defobj)) file)))
141 (url-set-filename urlobj (if query (concat file sepchar query) file))))))
142
143(provide 'url-expand)
diff --git a/lisp/url/url-file.el b/lisp/url/url-file.el
new file mode 100644
index 00000000000..fad9995f9ba
--- /dev/null
+++ b/lisp/url/url-file.el
@@ -0,0 +1,239 @@
1;;; url-file.el --- File retrieval code
2;; Author: $Author: fx $
3;; Created: $Date: 2002/04/22 09:14:24 $
4;; Version: $Revision: 1.11 $
5;; Keywords: comm, data, processes
6
7;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
8;;; Copyright (c) 1993 - 1996 by William M. Perry <wmperry@cs.indiana.edu>
9;;; Copyright (c) 1996 - 1999 Free Software Foundation, Inc.
10;;;
11;;; This file is part of GNU Emacs.
12;;;
13;;; GNU Emacs is free software; you can redistribute it and/or modify
14;;; it under the terms of the GNU General Public License as published by
15;;; the Free Software Foundation; either version 2, or (at your option)
16;;; any later version.
17;;;
18;;; GNU Emacs is distributed in the hope that it will be useful,
19;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
20;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
21;;; GNU General Public License for more details.
22;;;
23;;; You should have received a copy of the GNU General Public License
24;;; along with GNU Emacs; see the file COPYING. If not, write to the
25;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
26;;; Boston, MA 02111-1307, USA.
27;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
28
29(eval-when-compile (require 'cl))
30(require 'mailcap)
31(require 'url-vars)
32(require 'url-parse)
33(require 'url-dired)
34
35(defconst url-file-default-port 21 "Default FTP port.")
36(defconst url-file-asynchronous-p t "FTP transfers are asynchronous.")
37(defalias 'url-file-expand-file-name 'url-default-expander)
38
39(defun url-file-find-possibly-compressed-file (fname &rest args)
40 "Find the exact file referenced by `fname'.
41This tries the common compression extensions, because things like
42ange-ftp and efs are not quite smart enough to realize when a server
43can do automatic decompression for them, and won't find 'foo' if
44'foo.gz' exists, even though the ftp server would happily serve it up
45to them."
46 (let ((scratch nil)
47 (compressed-extensions '("" ".gz" ".z" ".Z" ".bz2"))
48 (found nil))
49 (while (and compressed-extensions (not found))
50 (if (file-exists-p (setq scratch (concat fname (pop compressed-extensions))))
51 (setq found scratch)))
52 found))
53
54(defun url-file-host-is-local-p (host)
55 "Return t iff HOST references our local machine."
56 (let ((case-fold-search t))
57 (or
58 (null host)
59 (string= "" host)
60 (equal (downcase host) (downcase (system-name)))
61 (and (string-match "^localhost$" host) t)
62 (and (not (string-match (regexp-quote ".") host))
63 (equal (downcase host) (if (string-match (regexp-quote ".")
64 (system-name))
65 (substring (system-name) 0
66 (match-beginning 0))
67 (system-name)))))))
68
69(defun url-file-asynch-callback (x y name buff func args &optional efs)
70 (if (not (featurep 'ange-ftp))
71 ;; EFS passes us an extra argument
72 (setq name buff
73 buff func
74 func args
75 args efs))
76 (let ((size (nth 7 (file-attributes name))))
77 (save-excursion
78 (set-buffer buff)
79 (goto-char (point-max))
80 (if (/= -1 size)
81 (insert (format "Content-length: %d\n" size)))
82 (insert "\n")
83 (insert-file-contents-literally name)
84 (if (not (url-file-host-is-local-p (url-host url-current-object)))
85 (condition-case ()
86 (delete-file name)
87 (error nil)))
88 (apply func args))))
89
90(defun url-file-build-filename (url)
91 (if (not (vectorp url))
92 (setq url (url-generic-parse-url url)))
93 (let* ((user (url-user url))
94 (pass (url-password url))
95 (port (url-port url))
96 (host (url-host url))
97 (site (if (and port (/= port 21))
98 (if (featurep 'ange-ftp)
99 (format "%s %d" host port)
100 ;; This works in Emacs 21's ange-ftp too.
101 (format "%s#%d" host port))
102 host))
103 (file (url-unhex-string (url-filename url)))
104 (filename (if (or user (not (url-file-host-is-local-p host)))
105 (concat "/" (or user "anonymous") "@" site ":" file)
106 (if (and (memq system-type
107 '(emx ms-dos windows-nt ms-windows))
108 (string-match "^/[a-zA-Z]:/" file))
109 (substring file 1)
110 file)))
111 pos-index)
112
113 (and user pass
114 (cond
115 ((featurep 'ange-ftp)
116 (ange-ftp-set-passwd host user pass))
117 ((or (featurep 'efs) (featurep 'efs-auto))
118 (efs-set-passwd host user pass))
119 (t
120 nil)))
121
122 ;; This makes sure that directories have a trailing directory
123 ;; separator on them so URL expansion works right.
124 ;;
125 ;; FIXME? What happens if the remote system doesn't use our local
126 ;; directory-sep-char as its separator? Would it be safer to just
127 ;; use '/' unconditionally and rely on the FTP server to
128 ;; straighten it out for us?
129 (if (and (file-directory-p filename)
130 (not (string-match (format "%c$" directory-sep-char) filename)))
131 (url-set-filename url
132 (format "%s%c" filename directory-sep-char)))
133
134 ;; If it is a directory, look for an index file first.
135 (if (and (file-directory-p filename)
136 url-directory-index-file
137 (setq pos-index (expand-file-name url-directory-index-file filename))
138 (file-exists-p pos-index)
139 (file-readable-p pos-index))
140 (setq filename pos-index))
141
142 ;; Find the (possibly compressed) file
143 (setq filename (url-file-find-possibly-compressed-file filename))
144 filename))
145
146;;;###autoload
147(defun url-file (url callback cbargs)
148 "Handle file: and ftp: URLs."
149 (let* ((buffer nil)
150 (uncompressed-filename nil)
151 (content-type nil)
152 (content-encoding nil)
153 (coding-system-for-read 'binary))
154
155 (setq filename (url-file-build-filename url))
156
157 (if (not filename)
158 (error "File does not exist: %s" (url-recreate-url url)))
159
160 ;; Need to figure out the content-type from the real extension,
161 ;; not the compressed one.
162 (setq uncompressed-filename (if (string-match "\\.\\(gz\\|Z\\|z\\)$" filename)
163 (substring filename 0 (match-beginning 0))
164 filename))
165 (setq content-type (mailcap-extension-to-mime
166 (url-file-extension uncompressed-filename))
167 content-encoding (case (intern (url-file-extension filename))
168 ((\.z \.gz) "gzip")
169 (\.Z "compress")
170 (\.uue "x-uuencoded")
171 (\.hqx "x-hqx")
172 (\.bz2 "x-bzip2")
173 (otherwise nil)))
174
175 (if (file-directory-p filename)
176 ;; A directory is done the same whether we are local or remote
177 (url-find-file-dired filename)
178 (save-excursion
179 (setq buffer (generate-new-buffer " *url-file*"))
180 (set-buffer buffer)
181 (mm-disable-multibyte)
182 (setq url-current-object url)
183 (insert "Content-type: " (or content-type "application/octet-stream") "\n")
184 (if content-encoding
185 (insert "Content-transfer-encoding: " content-encoding "\n"))
186 (if (url-file-host-is-local-p (url-host url))
187 ;; Local files are handled slightly oddly
188 (if (featurep 'ange-ftp)
189 (url-file-asynch-callback nil nil
190 filename
191 (current-buffer)
192 callback cbargs)
193 (url-file-asynch-callback nil nil nil
194 filename
195 (current-buffer)
196 callback cbargs))
197 ;; FTP handling
198 (let* ((extension (url-file-extension filename))
199 (new (url-generate-unique-filename
200 (and (> (length extension) 0)
201 (concat "%s." extension)))))
202 (if (featurep 'ange-ftp)
203 (ange-ftp-copy-file-internal filename (expand-file-name new) t
204 nil t
205 (list 'url-file-asynch-callback
206 new (current-buffer)
207 callback cbargs)
208 t)
209 (autoload 'efs-copy-file-internal "efs")
210 (efs-copy-file-internal filename (efs-ftp-path filename)
211 new (efs-ftp-path new)
212 t nil 0
213 (list 'url-file-asynch-callback
214 new (current-buffer)
215 callback cbargs)
216 0 nil))))))
217 buffer))
218
219(defmacro url-file-create-wrapper (method args)
220 (` (defalias (quote (, (intern (format "url-ftp-%s" method))))
221 (defun (, (intern (format "url-file-%s" method))) (, args)
222 (, (format "FTP/FILE URL wrapper around `%s' call." method))
223 (setq url (url-file-build-filename url))
224 (and url ((, method) (,@ (remove '&rest (remove '&optional args)))))))))
225
226(url-file-create-wrapper file-exists-p (url))
227(url-file-create-wrapper file-attributes (url))
228(url-file-create-wrapper file-symlink-p (url))
229(url-file-create-wrapper file-readable-p (url))
230(url-file-create-wrapper file-writable-p (url))
231(url-file-create-wrapper file-executable-p (url))
232(if (featurep 'xemacs)
233 (progn
234 (url-file-create-wrapper directory-files (url &optional full match nosort files-only))
235 (url-file-create-wrapper file-truename (url &optional default)))
236 (url-file-create-wrapper directory-files (url &optional full match nosort))
237 (url-file-create-wrapper file-truename (url &optional counter prev-dirs)))
238
239(provide 'url-file)
diff --git a/lisp/url/url-ftp.el b/lisp/url/url-ftp.el
new file mode 100644
index 00000000000..19b55c199e3
--- /dev/null
+++ b/lisp/url/url-ftp.el
@@ -0,0 +1,44 @@
1;;; url-ftp.el --- FTP wrapper
2;; Author: $Author: wmperry $
3;; Created: $Date: 1999/11/30 12:47:21 $
4;; Version: $Revision: 1.1 $
5;; Keywords: comm, data, processes
6
7;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
8;;; Copyright (c) 1993 - 1996 by William M. Perry <wmperry@cs.indiana.edu>
9;;; Copyright (c) 1996 - 1999 Free Software Foundation, Inc.
10;;;
11;;; This file is part of GNU Emacs.
12;;;
13;;; GNU Emacs is free software; you can redistribute it and/or modify
14;;; it under the terms of the GNU General Public License as published by
15;;; the Free Software Foundation; either version 2, or (at your option)
16;;; any later version.
17;;;
18;;; GNU Emacs is distributed in the hope that it will be useful,
19;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
20;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
21;;; GNU General Public License for more details.
22;;;
23;;; You should have received a copy of the GNU General Public License
24;;; along with GNU Emacs; see the file COPYING. If not, write to the
25;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
26;;; Boston, MA 02111-1307, USA.
27;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
28
29;; We knew not what we did when we overloaded 'file' to mean 'file'
30;; and 'ftp' back in the dark ages of the web.
31;;
32;; This stub file is just here to please the auto-scheme-loading code
33;; in url-methods.el and just maps everything onto the code in
34;; url-file.
35
36(require 'url-parse)
37(require 'url-file)
38
39(defconst url-ftp-default-port 21 "Default FTP port.")
40(defconst url-ftp-asynchronous-p t "FTP transfers are asynchronous.")
41(defalias 'url-ftp-expand-file-name 'url-default-expander)
42(defalias 'url-ftp 'url-file)
43
44(provide 'url-ftp)
diff --git a/lisp/url/url-gw.el b/lisp/url/url-gw.el
new file mode 100644
index 00000000000..d66a4468065
--- /dev/null
+++ b/lisp/url/url-gw.el
@@ -0,0 +1,264 @@
1;;; url-gw.el --- Gateway munging for URL loading
2;; Author: Bill Perry <wmperry@gnu.org>
3;; Created: $Date: 2002/04/22 09:26:46 $
4;; $Revision: 1.8 $
5;; Keywords: comm, data, processes
6
7;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
8;;; Copyright (c) 1997, 1998 Free Software Foundation, Inc.
9;;;
10;;; This file is part of GNU Emacs.
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 the
24;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
25;;; Boston, MA 02111-1307, USA.
26;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
27(eval-when-compile (require 'cl))
28(require 'url-vars)
29
30;; Fixme: support SSH explicitly or via a url-gateway-rlogin-program?
31
32(autoload 'socks-open-network-stream "socks")
33(autoload 'open-ssl-stream "ssl")
34
35(defgroup url-gateway nil
36 "URL gateway variables"
37 :group 'url)
38
39(defcustom url-gateway-local-host-regexp nil
40 "*A regular expression specifying local hostnames/machines."
41 :type '(choice (const nil) regexp)
42 :group 'url-gateway)
43
44(defcustom url-gateway-prompt-pattern
45 "^[^#$%>;]*[#$%>;] *" ;; "bash\\|\$ *\r?$\\|> *\r?"
46 "*A regular expression matching a shell prompt."
47 :type 'regexp
48 :group 'url-gateway)
49
50(defcustom url-gateway-rlogin-host nil
51 "*What hostname to actually rlog into before doing a telnet."
52 :type '(choice (const nil) string)
53 :group 'url-gateway)
54
55(defcustom url-gateway-rlogin-user-name nil
56 "*Username to log into the remote machine with when using rlogin."
57 :type '(choice (const nil) string)
58 :group 'url-gateway)
59
60(defcustom url-gateway-rlogin-parameters '("telnet" "-8")
61 "*Parameters to `url-open-rlogin'.
62This list will be used as the parameter list given to rsh."
63 :type '(repeat string)
64 :group 'url-gateway)
65
66(defcustom url-gateway-telnet-host nil
67 "*What hostname to actually login to before doing a telnet."
68 :type '(choice (const nil) string)
69 :group 'url-gateway)
70
71(defcustom url-gateway-telnet-parameters '("exec" "telnet" "-8")
72 "*Parameters to `url-open-telnet'.
73This list will be executed as a command after logging in via telnet."
74 :type '(repeat string)
75 :group 'url-gateway)
76
77(defcustom url-gateway-telnet-login-prompt "^\r*.?login:"
78 "*Prompt that tells us we should send our username when loggin in w/telnet."
79 :type 'regexp
80 :group 'url-gateway)
81
82(defcustom url-gateway-telnet-password-prompt "^\r*.?password:"
83 "*Prompt that tells us we should send our password when loggin in w/telnet."
84 :type 'regexp
85 :group 'url-gateway)
86
87(defcustom url-gateway-telnet-user-name nil
88 "User name to log in via telnet with."
89 :type '(choice (const nil) string)
90 :group 'url-gateway)
91
92(defcustom url-gateway-telnet-password nil
93 "Password to use to log in via telnet with."
94 :type '(choice (const nil) string)
95 :group 'url-gateway)
96
97(defcustom url-gateway-broken-resolution nil
98 "*Whether to use nslookup to resolve hostnames.
99This should be used when your version of Emacs cannot correctly use DNS,
100but your machine can. This usually happens if you are running a statically
101linked Emacs under SunOS 4.x"
102 :type 'boolean
103 :group 'url-gateway)
104
105(defcustom url-gateway-nslookup-program "nslookup"
106 "*If non-NIL then a string naming nslookup program."
107 :type '(choice (const :tag "None" :value nil) string)
108 :group 'url-gateway)
109
110;; Stolen from ange-ftp
111;;;###autoload
112(defun url-gateway-nslookup-host (host)
113 "Attempt to resolve the given HOST using nslookup if possible."
114 (interactive "sHost: ")
115 (if url-gateway-nslookup-program
116 (let ((proc (start-process " *nslookup*" " *nslookup*"
117 url-gateway-nslookup-program host))
118 (res host))
119 (process-kill-without-query proc)
120 (save-excursion
121 (set-buffer (process-buffer proc))
122 (while (memq (process-status proc) '(run open))
123 (accept-process-output proc))
124 (goto-char (point-min))
125 (if (re-search-forward "Name:.*\nAddress: *\\(.*\\)$" nil t)
126 (setq res (buffer-substring (match-beginning 1)
127 (match-end 1))))
128 (kill-buffer (current-buffer)))
129 res)
130 host))
131
132;; Stolen from red gnus nntp.el
133(defun url-wait-for-string (regexp proc)
134 "Wait until string matching REGEXP arrives in process PROC's buffer."
135 (let ((buf (current-buffer)))
136 (goto-char (point-min))
137 (while (not (re-search-forward regexp nil t))
138 (accept-process-output proc)
139 (set-buffer buf)
140 (goto-char (point-min)))))
141
142;; Stolen from red gnus nntp.el
143(defun url-open-rlogin (name buffer host service)
144 "Open a connection using rsh."
145 (if (not (stringp service))
146 (setq service (int-to-string service)))
147 (let ((proc (if url-gateway-rlogin-user-name
148 (start-process
149 name buffer "rsh"
150 url-gateway-rlogin-host "-l" url-gateway-rlogin-user-name
151 (mapconcat 'identity
152 (append url-gateway-rlogin-parameters
153 (list host service)) " "))
154 (start-process
155 name buffer "rsh" url-gateway-rlogin-host
156 (mapconcat 'identity
157 (append url-gateway-rlogin-parameters
158 (list host service))
159 " ")))))
160 (set-buffer buffer)
161 (url-wait-for-string "^\r*200" proc)
162 (beginning-of-line)
163 (delete-region (point-min) (point))
164 proc))
165
166;; Stolen from red gnus nntp.el
167(defun url-open-telnet (name buffer host service)
168 (if (not (stringp service))
169 (setq service (int-to-string service)))
170 (save-excursion
171 (set-buffer (get-buffer-create buffer))
172 (erase-buffer)
173 (let ((proc (start-process name buffer "telnet" "-8"))
174 (case-fold-search t))
175 (when (memq (process-status proc) '(open run))
176 (process-send-string proc "set escape \^X\n")
177 (process-send-string proc (concat
178 "open " url-gateway-telnet-host "\n"))
179 (url-wait-for-string url-gateway-telnet-login-prompt proc)
180 (process-send-string
181 proc (concat
182 (or url-gateway-telnet-user-name
183 (setq url-gateway-telnet-user-name (read-string "login: ")))
184 "\n"))
185 (url-wait-for-string url-gateway-telnet-password-prompt proc)
186 (process-send-string
187 proc (concat
188 (or url-gateway-telnet-password
189 (setq url-gateway-telnet-password
190 (funcall url-passwd-entry-func "Password: ")))
191 "\n"))
192 (erase-buffer)
193 (url-wait-for-string url-gateway-prompt-pattern proc)
194 (process-send-string
195 proc (concat (mapconcat 'identity
196 (append url-gateway-telnet-parameters
197 (list host service)) " ") "\n"))
198 (url-wait-for-string "^\r*Escape character.*\r*\n+" proc)
199 (delete-region (point-min) (match-end 0))
200 (process-send-string proc "\^]\n")
201 (url-wait-for-string "^telnet" proc)
202 (process-send-string proc "mode character\n")
203 (accept-process-output proc 1)
204 (sit-for 1)
205 (goto-char (point-min))
206 (forward-line 1)
207 (delete-region (point) (point-max)))
208 proc)))
209
210;;;###autoload
211(defun url-open-stream (name buffer host service)
212 "Open a stream to HOST, possibly via a gateway.
213Args per `open-network-stream'.
214Will not make a connexion if `url-gateway-unplugged' is non-nil."
215 (unless url-gateway-unplugged
216 (let ((gw-method (if (and url-gateway-local-host-regexp
217 (not (eq 'ssl url-gateway-method))
218 (string-match
219 url-gateway-local-host-regexp
220 host))
221 'native
222 url-gateway-method))
223;;; ;; This hack is for OS/2 Emacs so that it will not do bogus CRLF
224;;; ;; conversions while trying to be 'helpful'
225;;; (tcp-binary-process-output-services (if (stringp service)
226;;; (list service)
227;;; (list service
228;;; (int-to-string service))))
229
230 ;; An attempt to deal with denied connections, and attempt
231 ;; to reconnect
232 (cur-retries 0)
233 (retry t)
234 (errobj nil)
235 (conn nil))
236
237 ;; If the user told us to do DNS for them, do it.
238 (if url-gateway-broken-resolution
239 (setq host (url-gateway-nslookup-host host)))
240
241 (condition-case errobj
242 ;; This is a clean way to ensure the new process inherits the
243 ;; right coding systems in both Emacs and XEmacs.
244 (let ((coding-system-for-read 'binary)
245 (coding-system-for-write 'binary))
246 (setq conn (case gw-method
247 (ssl
248 (open-ssl-stream name buffer host service))
249 ((native)
250 (open-network-stream name buffer host service))
251 (socks
252 (socks-open-network-stream name buffer host service))
253 (telnet
254 (url-open-telnet name buffer host service))
255 (rlogin
256 (url-open-rlogin name buffer host service))
257 (otherwise
258 (error "Bad setting of url-gateway-method: %s"
259 url-gateway-method)))))
260 (error
261 (setq conn nil)))
262 conn)))
263
264(provide 'url-gw)
diff --git a/lisp/url/url-handlers.el b/lisp/url/url-handlers.el
new file mode 100644
index 00000000000..8b6ebdf0518
--- /dev/null
+++ b/lisp/url/url-handlers.el
@@ -0,0 +1,252 @@
1;;; url-handlers.el --- file-name-handler stuff for URL loading
2;; Author: $Author: sds $
3;; Created: $Date: 2003/06/26 18:45:45 $
4;; Version: $Revision: 1.10 $
5;; Keywords: comm, data, processes, hypermedia
6
7;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
8;;; Copyright (c) 1993 - 1996 by William M. Perry <wmperry@cs.indiana.edu>
9;;; Copyright (c) 1996 - 1999 Free Software Foundation, Inc.
10;;;
11;;; This file is part of GNU Emacs.
12;;;
13;;; GNU Emacs is free software; you can redistribute it and/or modify
14;;; it under the terms of the GNU General Public License as published by
15;;; the Free Software Foundation; either version 2, or (at your option)
16;;; any later version.
17;;;
18;;; GNU Emacs is distributed in the hope that it will be useful,
19;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
20;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
21;;; GNU General Public License for more details.
22;;;
23;;; You should have received a copy of the GNU General Public License
24;;; along with GNU Emacs; see the file COPYING. If not, write to the
25;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
26;;; Boston, MA 02111-1307, USA.
27;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
28
29(require 'url)
30(require 'url-parse)
31(require 'url-util)
32(require 'mm-decode)
33(require 'mailcap)
34
35(eval-when-compile
36 (require 'cl))
37
38;; Implementation status
39;; ---------------------
40;; Function Status
41;; ------------------------------------------------------------
42;; add-name-to-file Needs DAV Bindings
43;; copy-file Broken (assumes 1st item is URL)
44;; delete-directory Finished (DAV)
45;; delete-file Finished (DAV)
46;; diff-latest-backup-file
47;; directory-file-name unnecessary (what about VMS)?
48;; directory-files Finished (DAV)
49;; dired-call-process
50;; dired-compress-file
51;; dired-uncache
52;; expand-file-name Finished
53;; file-accessible-directory-p
54;; file-attributes Finished, better with DAV
55;; file-directory-p Needs DAV, finished
56;; file-executable-p Finished
57;; file-exists-p Finished
58;; file-local-copy
59;; file-modes
60;; file-name-all-completions Finished (DAV)
61;; file-name-as-directory
62;; file-name-completion Finished (DAV)
63;; file-name-directory
64;; file-name-nondirectory
65;; file-name-sans-versions why?
66;; file-newer-than-file-p
67;; file-ownership-preserved-p No way to know
68;; file-readable-p Finished
69;; file-regular-p !directory_p
70;; file-symlink-p Needs DAV bindings
71;; file-truename Needs DAV bindings
72;; file-writable-p Check for LOCK?
73;; find-backup-file-name why?
74;; get-file-buffer why?
75;; insert-directory Use DAV
76;; insert-file-contents Finished
77;; load
78;; make-directory Finished (DAV)
79;; make-symbolic-link Needs DAV bindings
80;; rename-file Finished (DAV)
81;; set-file-modes Use mod_dav specific executable flag?
82;; set-visited-file-modtime Impossible?
83;; shell-command Impossible?
84;; unhandled-file-name-directory
85;; vc-registered Finished (DAV)
86;; verify-visited-file-modtime
87;; write-region
88
89(defvar url-handler-regexp
90 "\\`\\(https?\\|ftp\\|file\\|nfs\\)://"
91 "*A regular expression for matching URLs handled by file-name-handler-alist.
92Some valid URL protocols just do not make sense to visit interactively
93\(about, data, info, irc, mailto, etc\). This regular expression
94avoids conflicts with local files that look like URLs \(Gnus is
95particularly bad at this\).")
96
97;;;###autoload
98(defun url-setup-file-name-handlers ()
99 "Setup file-name handlers."
100 (cond
101 ((not (boundp 'file-name-handler-alist))
102 nil) ; Don't load if no alist
103 ((rassq 'url-file-handler file-name-handler-alist)
104 nil) ; Don't load twice
105 (t
106 (push (cons url-handler-regexp 'url-file-handler)
107 file-name-handler-alist))))
108
109(defun url-run-real-handler (operation args)
110 (let ((inhibit-file-name-handlers (cons 'url-file-handler
111 (if (eq operation inhibit-file-name-operation)
112 inhibit-file-name-handlers)))
113 (inhibit-file-name-operation operation))
114 (apply operation args)))
115
116(defun url-file-handler (operation &rest args)
117 "Function called from the `file-name-handler-alist' routines.
118OPERATION is what needs to be done (`file-exists-p', etc). ARGS are
119the arguments that would have been passed to OPERATION."
120 (let ((fn (or (get operation 'url-file-handlers)
121 (intern-soft (format "url-%s" operation))))
122 (val nil)
123 (hooked nil))
124 (if (and fn (fboundp fn))
125 (setq hooked t
126 val (apply fn args))
127 (setq hooked nil
128 val (url-run-real-handler operation args)))
129 (url-debug 'handlers "%s %S%S => %S" (if hooked "Hooked" "Real")
130 operation args val)
131 val))
132
133(defun url-file-handler-identity (&rest args)
134 ;; Identity function
135 (car args))
136
137;; These are operations that we can fully support
138(put 'file-readable-p 'url-file-handlers 'url-file-exists-p)
139(put 'substitute-in-file-name 'url-file-handlers 'url-file-handler-identity)
140(put 'file-name-absolute-p 'url-file-handlers (lambda (&rest ignored) t))
141(put 'expand-file-name 'url-file-handlers 'url-handler-expand-file-name)
142
143;; These are operations that we do not support yet (DAV!!!)
144(put 'file-writable-p 'url-file-handlers 'ignore)
145(put 'file-symlink-p 'url-file-handlers 'ignore)
146
147(defun url-handler-expand-file-name (file &optional base)
148 (if (file-name-absolute-p file)
149 (expand-file-name file "/")
150 (url-expand-file-name file base)))
151
152;; The actual implementation
153;;;###autoload
154(defun url-copy-file (url newname &optional ok-if-already-exists keep-time)
155 "Copy URL to NEWNAME. Both args must be strings.
156Signals a `file-already-exists' error if file NEWNAME already exists,
157unless a third argument OK-IF-ALREADY-EXISTS is supplied and non-nil.
158A number as third arg means request confirmation if NEWNAME already exists.
159This is what happens in interactive use with M-x.
160Fourth arg KEEP-TIME non-nil means give the new file the same
161last-modified time as the old one. (This works on only some systems.)
162A prefix arg makes KEEP-TIME non-nil."
163 (if (and (file-exists-p newname)
164 (not ok-if-already-exists))
165 (error "Opening output file: File already exists, %s" newname))
166 (let ((buffer (url-retrieve-synchronously url))
167 (handle nil))
168 (if (not buffer)
169 (error "Opening input file: No such file or directory, %s" url))
170 (save-excursion
171 (set-buffer buffer)
172 (setq handle (mm-dissect-buffer t)))
173 (mm-save-part-to-file handle newname)
174 (kill-buffer buffer)
175 (mm-destroy-parts handle)))
176
177;;;###autoload
178(defun url-file-local-copy (url &rest ignored)
179 "Copy URL into a temporary file on this machine.
180Returns the name of the local copy, or nil, if FILE is directly
181accessible."
182 (let ((filename (make-temp-name "url")))
183 (url-copy-file url filename)
184 filename))
185
186;;;###autoload
187(defun url-insert-file-contents (url &optional visit beg end replace)
188 (let ((buffer (url-retrieve-synchronously url))
189 (handle nil)
190 (data nil))
191 (if (not buffer)
192 (error "Opening input file: No such file or directory, %s" url))
193 (if visit (setq buffer-file-name url))
194 (save-excursion
195 (set-buffer buffer)
196 (setq handle (mm-dissect-buffer t))
197 (set-buffer (mm-handle-buffer handle))
198 (if beg
199 (setq data (buffer-substring beg end))
200 (setq data (buffer-string))))
201 (kill-buffer buffer)
202 (mm-destroy-parts handle)
203 (if replace (delete-region (point-min) (point-max)))
204 (save-excursion
205 (insert data))
206 (list url (length data))))
207
208(defun url-file-name-completion (url directory)
209 (error "Unimplemented"))
210
211(defun url-file-name-all-completions (file directory)
212 (error "Unimplemented"))
213
214;; All other handlers map onto their respective backends.
215(defmacro url-handlers-create-wrapper (method args)
216 `(defun ,(intern (format "url-%s" method)) ,args
217 ,(format "URL file-name-handler wrapper for `%s' call.\n---\n%s" method
218 (or (documentation method t) "No original documentation."))
219 (setq url (url-generic-parse-url url))
220 (when (url-type url)
221 (funcall (url-scheme-get-property (url-type url) (quote ,method))
222 ,@(remove '&rest (remove '&optional args))))))
223
224(url-handlers-create-wrapper file-exists-p (url))
225(url-handlers-create-wrapper file-attributes (url))
226(url-handlers-create-wrapper file-symlink-p (url))
227(url-handlers-create-wrapper file-writable-p (url))
228(url-handlers-create-wrapper file-directory-p (url))
229(url-handlers-create-wrapper file-executable-p (url))
230
231(if (featurep 'xemacs)
232 (progn
233 ;; XEmacs specific prototypes
234 (url-handlers-create-wrapper
235 directory-files (url &optional full match nosort files-only))
236 (url-handlers-create-wrapper
237 file-truename (url &optional default)))
238 ;; Emacs specific prototypes
239 (url-handlers-create-wrapper
240 directory-files (url &optional full match nosort))
241 (url-handlers-create-wrapper
242 file-truename (url &optional counter prev-dirs)))
243
244(add-hook 'find-file-hooks 'url-handlers-set-buffer-mode)
245
246(defun url-handlers-set-buffer-mode ()
247 "Set correct modes for the current buffer if visiting a remote file."
248 (and (stringp buffer-file-name)
249 (string-match url-handler-regexp buffer-file-name)
250 (auto-save-mode 0)))
251
252(provide 'url-handlers)
diff --git a/lisp/url/url-history.el b/lisp/url/url-history.el
new file mode 100644
index 00000000000..77b58b6f660
--- /dev/null
+++ b/lisp/url/url-history.el
@@ -0,0 +1,199 @@
1;;; url-history.el --- Global history tracking for URL package
2;; Author: $Author: fx $
3;; Created: $Date: 2001/05/05 16:49:52 $
4;; Version: $Revision: 1.6 $
5;; Keywords: comm, data, processes, hypermedia
6
7;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
8;;; Copyright (c) 1993 - 1996 by William M. Perry <wmperry@cs.indiana.edu>
9;;; Copyright (c) 1996 - 1999 Free Software Foundation, Inc.
10;;;
11;;; This file is part of GNU Emacs.
12;;;
13;;; GNU Emacs is free software; you can redistribute it and/or modify
14;;; it under the terms of the GNU General Public License as published by
15;;; the Free Software Foundation; either version 2, or (at your option)
16;;; any later version.
17;;;
18;;; GNU Emacs is distributed in the hope that it will be useful,
19;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
20;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
21;;; GNU General Public License for more details.
22;;;
23;;; You should have received a copy of the GNU General Public License
24;;; along with GNU Emacs; see the file COPYING. If not, write to the
25;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
26;;; Boston, MA 02111-1307, USA.
27;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
28
29;; This can get a recursive require.
30;;(require 'url)
31(eval-when-compile (require 'cl))
32(require 'url-parse)
33(autoload 'url-do-setup "url")
34
35(defgroup url-history nil
36 "History variables in the URL package"
37 :prefix "url-history"
38 :group 'url)
39
40(defcustom url-history-track nil
41 "*Controls whether to keep a list of all the URLS being visited.
42If non-nil, url will keep track of all the URLS visited.
43If eq to `t', then the list is saved to disk at the end of each emacs
44session."
45 :type 'boolean
46 :group 'url-history)
47
48(defcustom url-history-file nil
49 "*The global history file for the URL package.
50This file contains a list of all the URLs you have visited. This file
51is parsed at startup and used to provide URL completion."
52 :type '(choice (const :tag "Default" :value nil) file)
53 :group 'url-history)
54
55(defcustom url-history-save-interval 3600
56 "*The number of seconds between automatic saves of the history list.
57Default is 1 hour. Note that if you change this variable outside of
58the `customize' interface after `url-do-setup' has been run, you need
59to run the `url-history-setup-save-timer' function manually."
60 :set (function (lambda (var val)
61 (set-default var val)
62 (and (featurep 'url)
63 (fboundp 'url-history-setup-save-timer)
64 (let ((def (symbol-function
65 'url-history-setup-save-timer)))
66 (not (and (listp def) (eq 'autoload (car def)))))
67 (url-history-setup-save-timer))))
68 :type 'integer
69 :group 'url-history)
70
71(defvar url-history-timer nil)
72
73(defvar url-history-list nil
74 "List of urls visited this session.")
75
76(defvar url-history-changed-since-last-save nil
77 "Whether the history list has changed since the last save operation.")
78
79(defvar url-history-hash-table nil
80 "Hash table for global history completion.")
81
82;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
83;;;###autoload
84(defun url-history-setup-save-timer ()
85 "Reset the history list timer."
86 (interactive)
87 (cond
88 ((featurep 'itimer)
89 (ignore-errors (delete-itimer url-history-timer))
90 (setq url-history-timer nil)
91 (if url-history-save-interval
92 (setq url-history-timer
93 (start-itimer "url-history-saver" 'url-history-save-history
94 url-history-save-interval
95 url-history-save-interval))))
96 ((fboundp 'run-at-time)
97 (ignore-errors (cancel-timer url-history-timer))
98 (setq url-history-timer nil)
99 (if url-history-save-interval
100 (setq url-history-timer
101 (run-at-time url-history-save-interval
102 url-history-save-interval
103 'url-history-save-history))))
104 (t nil)))
105
106;;;###autoload
107(defun url-history-parse-history (&optional fname)
108 "Parse a history file stored in FNAME."
109 ;; Parse out the mosaic global history file for completions, etc.
110 (or fname (setq fname (expand-file-name url-history-file)))
111 (cond
112 ((not (file-exists-p fname))
113 (message "%s does not exist." fname))
114 ((not (file-readable-p fname))
115 (message "%s is unreadable." fname))
116 (t
117 (condition-case nil
118 (load fname nil t)
119 (error (message "Could not load %s" fname)))))
120 (if (not url-history-hash-table)
121 (setq url-history-hash-table (make-hash-table :size 31 :test 'equal))))
122
123(defun url-history-update-url (url time)
124 (setq url-history-changed-since-last-save t)
125 (puthash (if (vectorp url) (url-recreate-url url) url) time url-history-hash-table))
126
127;;;###autoload
128(defun url-history-save-history (&optional fname)
129 "Write the global history file into `url-history-file'.
130The type of data written is determined by what is in the file to begin
131with. If the type of storage cannot be determined, then prompt the
132user for what type to save as."
133 (interactive)
134 (or fname (setq fname (expand-file-name url-history-file)))
135 (cond
136 ((not url-history-changed-since-last-save) nil)
137 ((not (file-writable-p fname))
138 (message "%s is unwritable." fname))
139 (t
140 (let ((make-backup-files nil)
141 (version-control nil)
142 (require-final-newline t))
143 (save-excursion
144 (set-buffer (get-buffer-create " *url-tmp*"))
145 (erase-buffer)
146 (let ((count 0))
147 (maphash (function
148 (lambda (key value)
149 (while (string-match "[\r\n]+" key)
150 (setq key (concat (substring key 0 (match-beginning 0))
151 (substring key (match-end 0) nil))))
152 (setq count (1+ count))
153 (insert "(puthash \"" key "\""
154 (if (not (stringp value)) " '" "")
155 (prin1-to-string value)
156 " url-history-hash-table)\n")))
157 url-history-hash-table)
158 (goto-char (point-min))
159 (insert (format
160 "(setq url-history-hash-table (make-hash-table :size %d :test 'equal))\n"
161 (/ count 4)))
162 (goto-char (point-max))
163 (insert "\n")
164 (write-file fname))
165 (kill-buffer (current-buffer))))))
166 (setq url-history-changed-since-last-save nil))
167
168(defun url-have-visited-url (url)
169 (url-do-setup)
170 (gethash url url-history-hash-table nil))
171
172(defun url-completion-function (string predicate function)
173 (url-do-setup)
174 (cond
175 ((eq function nil)
176 (let ((list nil))
177 (maphash (function (lambda (key val)
178 (setq list (cons (cons key val)
179 list))))
180 url-history-hash-table)
181 (try-completion string (nreverse list) predicate)))
182 ((eq function t)
183 (let ((stub (concat "^" (regexp-quote string)))
184 (retval nil))
185 (maphash
186 (function
187 (lambda (url time)
188 (if (string-match stub url)
189 (setq retval (cons url retval)))))
190 url-history-hash-table)
191 retval))
192 ((eq function 'lambda)
193 (and url-history-hash-table
194 (gethash string url-history-hash-table)
195 t))
196 (t
197 (error "url-completion-function very confused."))))
198
199(provide 'url-history)
diff --git a/lisp/url/url-http.el b/lisp/url/url-http.el
new file mode 100644
index 00000000000..bdb6b38cf65
--- /dev/null
+++ b/lisp/url/url-http.el
@@ -0,0 +1,1223 @@
1;;; url-http.el --- HTTP retrieval routines
2;; Author: Bill Perry <wmperry@gnu.org>
3;; Version: $Revision: 1.39 $
4;; Keywords: comm, data, processes
5
6;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
7;;; Copyright (c) 1999, 2001 Free Software Foundation, Inc.
8;;;
9;;; This file is part of GNU Emacs.
10;;;
11;;; GNU Emacs is free software; you can redistribute it and/or modify
12;;; it under the terms of the GNU General Public License as published by
13;;; the Free Software Foundation; either version 2, or (at your option)
14;;; any later version.
15;;;
16;;; GNU Emacs is distributed in the hope that it will be useful,
17;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19;;; GNU General Public License for more details.
20;;;
21;;; You should have received a copy of the GNU General Public License
22;;; along with GNU Emacs; see the file COPYING. If not, write to the
23;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
24;;; Boston, MA 02111-1307, USA.
25;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
26
27(eval-when-compile
28 (require 'cl)
29 (defvar url-http-extra-headers))
30(require 'url-gw)
31(require 'url-util)
32(require 'url-parse)
33(require 'url-cookie)
34(require 'mail-parse)
35(require 'url-auth)
36(autoload 'url-retrieve-synchronously "url")
37(autoload 'url-retrieve "url")
38(autoload 'url-cache-create-filename "url-cache")
39(autoload 'url-mark-buffer-as-dead "url")
40
41(defconst url-http-default-port 80 "Default HTTP port.")
42(defconst url-http-asynchronous-p t "HTTP retrievals are asynchronous.")
43(defalias 'url-http-expand-file-name 'url-default-expander)
44
45(defvar url-http-real-basic-auth-storage nil)
46(defvar url-http-proxy-basic-auth-storage nil)
47
48(defvar url-http-open-connections (make-hash-table :test 'equal
49 :size 17)
50 "A hash table of all open network connections.")
51
52(defvar url-http-version "1.1"
53 "What version of HTTP we advertise, as a string.
54Valid values are 1.1 and 1.0.
55This is only useful when debugging the HTTP subsystem.
56
57Setting this to 1.0 will tell servers not to send chunked encoding,
58and other HTTP/1.1 specific features.
59")
60
61(defvar url-http-attempt-keepalives t
62 "Whether to use a single TCP connection multiple times in HTTP.
63This is only useful when debugging the HTTP subsystem. Setting to
64`nil' will explicitly close the connection to the server after every
65request.
66")
67
68;(eval-when-compile
69;; These are all macros so that they are hidden from external sight
70;; when the file is byte-compiled.
71;;
72;; This allows us to expose just the entry points we want.
73
74;; These routines will allow us to implement persistent HTTP
75;; connections.
76(defsubst url-http-debug (&rest args)
77 (if quit-flag
78 (let ((proc (get-buffer-process (current-buffer))))
79 ;; The user hit C-g, honor it! Some things can get in an
80 ;; incredibly tight loop (chunked encoding)
81 (if proc
82 (progn
83 (set-process-sentinel proc nil)
84 (set-process-filter proc nil)))
85 (error "Transfer interrupted!")))
86 (apply 'url-debug 'http args))
87
88(defun url-http-mark-connection-as-busy (host port proc)
89 (url-http-debug "Marking connection as busy: %s:%d %S" host port proc)
90 (puthash (cons host port)
91 (delq proc (gethash (cons host port) url-http-open-connections))
92 url-http-open-connections)
93 proc)
94
95(defun url-http-mark-connection-as-free (host port proc)
96 (url-http-debug "Marking connection as free: %s:%d %S" host port proc)
97 (set-process-buffer proc nil)
98 (set-process-sentinel proc 'url-http-idle-sentinel)
99 (puthash (cons host port)
100 (cons proc (gethash (cons host port) url-http-open-connections))
101 url-http-open-connections)
102 nil)
103
104(defun url-http-find-free-connection (host port)
105 (let ((conns (gethash (cons host port) url-http-open-connections))
106 (found nil))
107 (while (and conns (not found))
108 (if (not (memq (process-status (car conns)) '(run open)))
109 (progn
110 (url-http-debug "Cleaning up dead process: %s:%d %S"
111 host port (car conns))
112 (url-http-idle-sentinel (car conns) nil))
113 (setq found (car conns))
114 (url-http-debug "Found existing connection: %s:%d %S" host port found))
115 (pop conns))
116 (if found
117 (url-http-debug "Reusing existing connection: %s:%d" host port)
118 (url-http-debug "Contacting host: %s:%d" host port))
119 (url-lazy-message "Contacting host: %s:%d" host port)
120 (url-http-mark-connection-as-busy host port
121 (or found
122 (url-open-stream host nil host
123 port)))))
124
125;; Building an HTTP request
126(defun url-http-user-agent-string ()
127 (if (or (eq url-privacy-level 'paranoid)
128 (and (listp url-privacy-level)
129 (memq 'agent url-privacy-level)))
130 ""
131 (format "User-Agent: %sURL/%s%s\r\n"
132 (if url-package-name
133 (concat url-package-name "/" url-package-version " ")
134 "")
135 url-version
136 (cond
137 ((and url-os-type url-system-type)
138 (concat " (" url-os-type "; " url-system-type ")"))
139 ((or url-os-type url-system-type)
140 (concat " (" (or url-system-type url-os-type) ")"))
141 (t "")))))
142
143(defun url-http-create-request (url &optional ref-url)
144 "Create an HTTP request for URL, referred to by REF-URL."
145 (declare (special proxy-object proxy-info))
146 (let* ((extra-headers)
147 (request nil)
148 (no-cache (cdr-safe (assoc "Pragma" url-request-extra-headers)))
149 (proxy-obj (and (boundp 'proxy-object) proxy-object))
150 (proxy-auth (if (or (cdr-safe (assoc "Proxy-Authorization"
151 url-request-extra-headers))
152 (not proxy-obj))
153 nil
154 (let ((url-basic-auth-storage
155 'url-http-proxy-basic-auth-storage))
156 (url-get-authentication url nil 'any nil))))
157 (real-fname (if proxy-obj (url-recreate-url proxy-obj)
158 (url-filename url)))
159 (host (url-host (or proxy-obj url)))
160 (auth (if (cdr-safe (assoc "Authorization" url-request-extra-headers))
161 nil
162 (url-get-authentication (or
163 (and (boundp 'proxy-info)
164 proxy-info)
165 url) nil 'any nil))))
166 (if (equal "" real-fname)
167 (setq real-fname "/"))
168 (setq no-cache (and no-cache (string-match "no-cache" no-cache)))
169 (if auth
170 (setq auth (concat "Authorization: " auth "\r\n")))
171 (if proxy-auth
172 (setq proxy-auth (concat "Proxy-Authorization: " proxy-auth "\r\n")))
173
174 ;; Protection against stupid values in the referer
175 (if (and ref-url (stringp ref-url) (or (string= ref-url "file:nil")
176 (string= ref-url "")))
177 (setq ref-url nil))
178
179 ;; We do not want to expose the referer if the user is paranoid.
180 (if (or (memq url-privacy-level '(low high paranoid))
181 (and (listp url-privacy-level)
182 (memq 'lastloc url-privacy-level)))
183 (setq ref-url nil))
184
185 ;; url-request-extra-headers contains an assoc-list of
186 ;; header/value pairs that we need to put into the request.
187 (setq extra-headers (mapconcat
188 (lambda (x)
189 (concat (car x) ": " (cdr x)))
190 url-request-extra-headers "\r\n"))
191 (if (not (equal extra-headers ""))
192 (setq extra-headers (concat extra-headers "\r\n")))
193
194 ;; This was done with a call to `format'. Concatting parts has
195 ;; the advantage of keeping the parts of each header togther and
196 ;; allows us to elide null lines directly, at the cost of making
197 ;; the layout less clear.
198 (setq request
199 (concat
200 ;; The request
201 (or url-request-method "GET") " " real-fname " HTTP/" url-http-version "\r\n"
202 ;; Version of MIME we speak
203 "MIME-Version: 1.0\r\n"
204 ;; (maybe) Try to keep the connection open
205 "Connection: " (if (or proxy-obj
206 (not url-http-attempt-keepalives))
207 "close" "keep-alive") "\r\n"
208 ;; HTTP extensions we support
209 (if url-extensions-header
210 (format
211 "Extension: %s\r\n" url-extensions-header))
212 ;; Who we want to talk to
213 (if (/= (url-port (or proxy-obj url))
214 (url-scheme-get-property
215 (url-type (or proxy-obj url)) 'default-port))
216 (format
217 "Host: %s:%d\r\n" host (url-port (or proxy-obj url)))
218 (format "Host: %s\r\n" host))
219 ;; Who its from
220 (if url-personal-mail-address
221 (concat
222 "From: " url-personal-mail-address "\r\n"))
223 ;; Encodings we understand
224 (if url-mime-encoding-string
225 (concat
226 "Accept-encoding: " url-mime-encoding-string "\r\n"))
227 (if url-mime-charset-string
228 (concat
229 "Accept-charset: " url-mime-charset-string "\r\n"))
230 ;; Languages we understand
231 (if url-mime-language-string
232 (concat
233 "Accept-language: " url-mime-language-string "\r\n"))
234 ;; Types we understand
235 "Accept: " (or url-mime-accept-string "*/*") "\r\n"
236 ;; User agent
237 (url-http-user-agent-string)
238 ;; Proxy Authorization
239 proxy-auth
240 ;; Authorization
241 auth
242 ;; Cookies
243 (url-cookie-generate-header-lines host real-fname
244 (equal "https" (url-type url)))
245 ;; If-modified-since
246 (if (and (not no-cache)
247 (member url-request-method '("GET" nil)))
248 (let ((tm (url-is-cached (or proxy-obj url))))
249 (if tm
250 (concat "If-modified-since: "
251 (url-get-normalized-date tm) "\r\n"))))
252 ;; Whence we came
253 (if ref-url (concat
254 "Referer: " ref-url "\r\n"))
255 extra-headers
256 ;; Any data
257 (if url-request-data
258 (concat
259 "Content-length: " (number-to-string
260 (length url-request-data))
261 "\r\n\r\n"
262 url-request-data))
263 ;; End request
264 "\r\n"))
265 (url-http-debug "Request is: \n%s" request)
266 request))
267
268;; Parsing routines
269(defun url-http-clean-headers ()
270 "Remove trailing \r from header lines.
271This allows us to use `mail-fetch-field', etc."
272 (declare (special url-http-end-of-headers))
273 (goto-char (point-min))
274 (while (re-search-forward "\r$" url-http-end-of-headers t)
275 (replace-match "")))
276
277(defun url-http-handle-authentication (proxy)
278 (declare (special status success url-http-method url-http-data
279 url-callback-function url-callback-arguments))
280 (url-http-debug "Handling %s authentication" (if proxy "proxy" "normal"))
281 (let ((auth (or (mail-fetch-field (if proxy "proxy-authenticate" "www-authenticate"))
282 "basic"))
283 (type nil)
284 (url (url-recreate-url url-current-object))
285 (url-basic-auth-storage 'url-http-real-basic-auth-storage)
286 )
287
288 ;; Cheating, but who cares? :)
289 (if proxy
290 (setq url-basic-auth-storage 'url-http-proxy-basic-auth-storage))
291
292 (setq auth (url-eat-trailing-space (url-strip-leading-spaces auth)))
293 (if (string-match "[ \t]" auth)
294 (setq type (downcase (substring auth 0 (match-beginning 0))))
295 (setq type (downcase auth)))
296
297 (if (not (url-auth-registered type))
298 (progn
299 (widen)
300 (goto-char (point-max))
301 (insert "<hr>Sorry, but I do not know how to handle " type
302 " authentication. If you'd like to write it,"
303 " send it to " url-bug-address ".<hr>")
304 (setq status t))
305 (let* ((args auth)
306 (ctr (1- (length args)))
307 auth)
308 (while (/= 0 ctr)
309 (if (char-equal ?, (aref args ctr))
310 (aset args ctr ?\;))
311 (setq ctr (1- ctr)))
312 (setq args (url-parse-args args)
313 auth (url-get-authentication url (cdr-safe (assoc "realm" args))
314 type t args))
315 (if (not auth)
316 (setq success t)
317 (push (cons (if proxy "Proxy-Authorization" "Authorization") auth)
318 url-http-extra-headers)
319 (let ((url-request-method url-http-method)
320 (url-request-data url-http-data)
321 (url-request-extra-headers url-http-extra-headers))
322 (url-retrieve url url-callback-function url-callback-arguments))))
323 (kill-buffer (current-buffer)))))
324
325(defun url-http-parse-response ()
326 "Parse just the response code."
327 (declare (special url-http-end-of-headers url-http-response-status))
328 (if (not url-http-end-of-headers)
329 (error "Trying to parse HTTP response code in odd buffer: %s" (buffer-name)))
330 (url-http-debug "url-http-parse-response called in (%s)" (buffer-name))
331 (goto-char (point-min))
332 (skip-chars-forward " \t\n") ; Skip any blank crap
333 (skip-chars-forward "HTTP/") ; Skip HTTP Version
334 (read (current-buffer))
335 (setq url-http-response-status (read (current-buffer))))
336
337(defun url-http-handle-cookies ()
338 "Handle all set-cookie / set-cookie2 headers in an HTTP response.
339The buffer must already be narrowed to the headers, so mail-fetch-field will
340work correctly."
341 (let ((cookies (mail-fetch-field "Set-Cookie" nil nil t))
342 (cookies2 (mail-fetch-field "Set-Cookie2" nil nil t)))
343 (and cookies (url-http-debug "Found %d Set-Cookie headers" (length cookies)))
344 (and cookies2 (url-http-debug "Found %d Set-Cookie2 headers" (length cookies2)))
345 (while cookies
346 (url-cookie-handle-set-cookie (pop cookies)))
347;;; (while cookies2
348;;; (url-cookie-handle-set-cookie2 (pop cookies)))
349 )
350 )
351
352(defun url-http-parse-headers ()
353 "Parse and handle HTTP specific headers.
354Return t if and only if the current buffer is still active and
355should be shown to the user."
356 ;; The comments after each status code handled are taken from RFC
357 ;; 2616 (HTTP/1.1)
358 (declare (special url-http-end-of-headers url-http-response-status
359 url-http-method url-http-data url-http-process
360 url-callback-function url-callback-arguments))
361
362 (url-http-mark-connection-as-free (url-host url-current-object)
363 (url-port url-current-object)
364 url-http-process)
365
366 (if (or (not (boundp 'url-http-end-of-headers))
367 (not url-http-end-of-headers))
368 (error "Trying to parse headers in odd buffer: %s" (buffer-name)))
369 (goto-char (point-min))
370 (url-http-debug "url-http-parse-headers called in (%s)" (buffer-name))
371 (url-http-parse-response)
372 (mail-narrow-to-head)
373 ;;(narrow-to-region (point-min) url-http-end-of-headers)
374 (let ((version nil)
375 (class nil)
376 (success nil))
377 (setq class (/ url-http-response-status 100))
378 (url-http-debug "Parsed HTTP headers: class=%d status=%d" class url-http-response-status)
379 (url-http-handle-cookies)
380
381 (case class
382 ;; Classes of response codes
383 ;;
384 ;; 5xx = Server Error
385 ;; 4xx = Client Error
386 ;; 3xx = Redirection
387 ;; 2xx = Successful
388 ;; 1xx = Informational
389 (1 ; Information messages
390 ;; 100 = Continue with request
391 ;; 101 = Switching protocols
392 ;; 102 = Processing (Added by DAV)
393 (url-mark-buffer-as-dead (current-buffer))
394 (error "HTTP responses in class 1xx not supported (%d)" url-http-response-status))
395 (2 ; Success
396 ;; 200 Ok
397 ;; 201 Created
398 ;; 202 Accepted
399 ;; 203 Non-authoritative information
400 ;; 204 No content
401 ;; 205 Reset content
402 ;; 206 Partial content
403 ;; 207 Multi-status (Added by DAV)
404 (case url-http-response-status
405 ((204 205)
406 ;; No new data, just stay at the same document
407 (url-mark-buffer-as-dead (current-buffer))
408 (setq success t))
409 (otherwise
410 ;; Generic success for all others. Store in the cache, and
411 ;; mark it as successful.
412 (widen)
413 (if (equal url-http-method "GET")
414 (url-store-in-cache (current-buffer)))
415 (setq success t))))
416 (3 ; Redirection
417 ;; 300 Multiple choices
418 ;; 301 Moved permanently
419 ;; 302 Found
420 ;; 303 See other
421 ;; 304 Not modified
422 ;; 305 Use proxy
423 ;; 307 Temporary redirect
424 (let ((redirect-uri (or (mail-fetch-field "Location")
425 (mail-fetch-field "URI"))))
426 (case url-http-response-status
427 (300
428 ;; Quoth the spec (section 10.3.1)
429 ;; -------------------------------
430 ;; The requested resource corresponds to any one of a set of
431 ;; representations, each with its own specific location and
432 ;; agent-driven negotiation information is being provided so
433 ;; that the user can select a preferred representation and
434 ;; redirect its request to that location.
435 ;; [...]
436 ;; If the server has a preferred choice of representation, it
437 ;; SHOULD include the specific URI for that representation in
438 ;; the Location field; user agents MAY use the Location field
439 ;; value for automatic redirection.
440 ;; -------------------------------
441 ;; We do not support agent-driven negotiation, so we just
442 ;; redirect to the preferred URI if one is provided.
443 nil)
444 ((301 302 307)
445 ;; If the 301|302 status code is received in response to a
446 ;; request other than GET or HEAD, the user agent MUST NOT
447 ;; automatically redirect the request unless it can be
448 ;; confirmed by the user, since this might change the
449 ;; conditions under which the request was issued.
450 (if (member url-http-method '("HEAD" "GET"))
451 ;; Automatic redirection is ok
452 nil
453 ;; It is just too big of a pain in the ass to get this
454 ;; prompt all the time. We will just silently lose our
455 ;; data and convert to a GET method.
456 (url-http-debug "Converting `%s' request to `GET' because of REDIRECT(%d)"
457 url-http-method url-http-response-status)
458 (setq url-http-method "GET"
459 url-request-data nil)))
460 (303
461 ;; The response to the request can be found under a different
462 ;; URI and SHOULD be retrieved using a GET method on that
463 ;; resource.
464 (setq url-http-method "GET"
465 url-http-data nil))
466 (304
467 ;; The 304 response MUST NOT contain a message-body.
468 (url-http-debug "Extracting document from cache... (%s)"
469 (url-cache-create-filename (url-view-url t)))
470 (url-cache-extract (url-cache-create-filename (url-view-url t)))
471 (setq redirect-uri nil
472 success t))
473 (305
474 ;; The requested resource MUST be accessed through the
475 ;; proxy given by the Location field. The Location field
476 ;; gives the URI of the proxy. The recipient is expected
477 ;; to repeat this single request via the proxy. 305
478 ;; responses MUST only be generated by origin servers.
479 (error "Redirection thru a proxy server not supported: %s"
480 redirect-uri))
481 (otherwise
482 ;; Treat everything like '300'
483 nil))
484 (when redirect-uri
485 ;; Clean off any whitespace and/or <...> cruft.
486 (if (string-match "\\([^ \t]+\\)[ \t]" redirect-uri)
487 (setq redirect-uri (match-string 1 redirect-uri)))
488 (if (string-match "^<\\(.*\\)>$" redirect-uri)
489 (setq redirect-uri (match-string 1 redirect-uri)))
490
491 ;; Some stupid sites (like sourceforge) send a
492 ;; non-fully-qualified URL (ie: /), which royally confuses
493 ;; the URL library.
494 (if (not (string-match url-nonrelative-link redirect-uri))
495 (setq redirect-uri (url-expand-file-name redirect-uri)))
496 (let ((url-request-method url-http-method)
497 (url-request-data url-http-data)
498 (url-request-extra-headers url-http-extra-headers))
499 (url-retrieve redirect-uri url-callback-function
500 url-callback-arguments)
501 (url-mark-buffer-as-dead (current-buffer))))))
502 (4 ; Client error
503 ;; 400 Bad Request
504 ;; 401 Unauthorized
505 ;; 402 Payment required
506 ;; 403 Forbidden
507 ;; 404 Not found
508 ;; 405 Method not allowed
509 ;; 406 Not acceptable
510 ;; 407 Proxy authentication required
511 ;; 408 Request time-out
512 ;; 409 Conflict
513 ;; 410 Gone
514 ;; 411 Length required
515 ;; 412 Precondition failed
516 ;; 413 Request entity too large
517 ;; 414 Request-URI too large
518 ;; 415 Unsupported media type
519 ;; 416 Requested range not satisfiable
520 ;; 417 Expectation failed
521 ;; 422 Unprocessable Entity (Added by DAV)
522 ;; 423 Locked
523 ;; 424 Failed Dependency
524 (case url-http-response-status
525 (401
526 ;; The request requires user authentication. The response
527 ;; MUST include a WWW-Authenticate header field containing a
528 ;; challenge applicable to the requested resource. The
529 ;; client MAY repeat the request with a suitable
530 ;; Authorization header field.
531 (url-http-handle-authentication nil))
532 (402
533 ;; This code is reserved for future use
534 (url-mark-buffer-as-dead (current-buffer))
535 (error "Somebody wants you to give them money"))
536 (403
537 ;; The server understood the request, but is refusing to
538 ;; fulfill it. Authorization will not help and the request
539 ;; SHOULD NOT be repeated.
540 (setq success t))
541 (404
542 ;; Not found
543 (setq success t))
544 (405
545 ;; The method specified in the Request-Line is not allowed
546 ;; for the resource identified by the Request-URI. The
547 ;; response MUST include an Allow header containing a list of
548 ;; valid methods for the requested resource.
549 (setq success t))
550 (406
551 ;; The resource identified by the request is only capable of
552 ;; generating response entities which have content
553 ;; characteristics nota cceptable according to the accept
554 ;; headers sent in the request.
555 (setq success t))
556 (407
557 ;; This code is similar to 401 (Unauthorized), but indicates
558 ;; that the client must first authenticate itself with the
559 ;; proxy. The proxy MUST return a Proxy-Authenticate header
560 ;; field containing a challenge applicable to the proxy for
561 ;; the requested resource.
562 (url-http-handle-authentication t))
563 (408
564 ;; The client did not produce a request within the time that
565 ;; the server was prepared to wait. The client MAY repeat
566 ;; the request without modifications at any later time.
567 (setq success t))
568 (409
569 ;; The request could not be completed due to a conflict with
570 ;; the current state of the resource. This code is only
571 ;; allowed in situations where it is expected that the user
572 ;; mioght be able to resolve the conflict and resubmit the
573 ;; request. The response body SHOULD include enough
574 ;; information for the user to recognize the source of the
575 ;; conflict.
576 (setq success t))
577 (410
578 ;; The requested resource is no longer available at the
579 ;; server and no forwarding address is known.
580 (setq success t))
581 (411
582 ;; The server refuses to accept the request without a defined
583 ;; Content-Length. The client MAY repeat the request if it
584 ;; adds a valid Content-Length header field containing the
585 ;; length of the message-body in the request message.
586 ;;
587 ;; NOTE - this will never happen because
588 ;; `url-http-create-request' automatically calculates the
589 ;; content-length.
590 (setq success t))
591 (412
592 ;; The precondition given in one or more of the
593 ;; request-header fields evaluated to false when it was
594 ;; tested on the server.
595 (setq success t))
596 ((413 414)
597 ;; The server is refusing to process a request because the
598 ;; request entity|URI is larger than the server is willing or
599 ;; able to process.
600 (setq success t))
601 (415
602 ;; The server is refusing to service the request because the
603 ;; entity of the request is in a format not supported by the
604 ;; requested resource for the requested method.
605 (setq success t))
606 (416
607 ;; A server SHOULD return a response with this status code if
608 ;; a request included a Range request-header field, and none
609 ;; of the range-specifier values in this field overlap the
610 ;; current extent of the selected resource, and the request
611 ;; did not include an If-Range request-header field.
612 (setq success t))
613 (417
614 ;; The expectation given in an Expect request-header field
615 ;; could not be met by this server, or, if the server is a
616 ;; proxy, the server has unambiguous evidence that the
617 ;; request could not be met by the next-hop server.
618 (setq success t))
619 (otherwise
620 ;; The request could not be understood by the server due to
621 ;; malformed syntax. The client SHOULD NOT repeat the
622 ;; request without modifications.
623 (setq success t))))
624 (5
625 ;; 500 Internal server error
626 ;; 501 Not implemented
627 ;; 502 Bad gateway
628 ;; 503 Service unavailable
629 ;; 504 Gateway time-out
630 ;; 505 HTTP version not supported
631 ;; 507 Insufficient storage
632 (setq success t)
633 (case url-http-response-status
634 (501
635 ;; The server does not support the functionality required to
636 ;; fulfill the request.
637 nil)
638 (502
639 ;; The server, while acting as a gateway or proxy, received
640 ;; an invalid response from the upstream server it accessed
641 ;; in attempting to fulfill the request.
642 nil)
643 (503
644 ;; The server is currently unable to handle the request due
645 ;; to a temporary overloading or maintenance of the server.
646 ;; The implication is that this is a temporary condition
647 ;; which will be alleviated after some delay. If known, the
648 ;; length of the delay MAY be indicated in a Retry-After
649 ;; header. If no Retry-After is given, the client SHOULD
650 ;; handle the response as it would for a 500 response.
651 nil)
652 (504
653 ;; The server, while acting as a gateway or proxy, did not
654 ;; receive a timely response from the upstream server
655 ;; specified by the URI (e.g. HTTP, FTP, LDAP) or some other
656 ;; auxiliary server (e.g. DNS) it needed to access in
657 ;; attempting to complete the request.
658 nil)
659 (505
660 ;; The server does not support, or refuses to support, the
661 ;; HTTP protocol version that was used in the request
662 ;; message.
663 nil)
664 (507 ; DAV
665 ;; The method could not be performed on the resource
666 ;; because the server is unable to store the representation
667 ;; needed to successfully complete the request. This
668 ;; condition is considered to be temporary. If the request
669 ;; which received this status code was the result of a user
670 ;; action, the request MUST NOT be repeated until it is
671 ;; requested by a separate user action.
672 nil)))
673 (otherwise
674 (error "Unknown class of HTTP response code: %d (%d)"
675 class url-http-response-status)))
676 (if (not success)
677 (url-mark-buffer-as-dead (current-buffer)))
678 (url-http-debug "Finished parsing HTTP headers: %S" success)
679 (widen)
680 success))
681
682;; Miscellaneous
683(defun url-http-activate-callback ()
684 "Activate callback specified when this buffer was created."
685 (declare (special url-http-process
686 url-callback-function
687 url-callback-arguments))
688 (url-http-mark-connection-as-free (url-host url-current-object)
689 (url-port url-current-object)
690 url-http-process)
691 (url-http-debug "Activating callback in buffer (%s)" (buffer-name))
692 (apply url-callback-function url-callback-arguments))
693
694;; )
695
696;; These unfortunately cannot be macros... please ignore them!
697(defun url-http-idle-sentinel (proc why)
698 "Remove this (now defunct) process PROC from the list of open connections."
699 (maphash (lambda (key val)
700 (if (memq proc val)
701 (puthash key (delq proc val) url-http-open-connections)))
702 url-http-open-connections))
703
704(defun url-http-end-of-document-sentinel (proc why)
705 ;; Sentinel used for old HTTP/0.9 or connections we know are going
706 ;; to die as the 'end of document' notifier.
707 (url-http-debug "url-http-end-of-document-sentinel in buffer (%s)"
708 (process-buffer proc))
709 (url-http-idle-sentinel proc why)
710 (save-excursion
711 (set-buffer (process-buffer proc))
712 (goto-char (point-min))
713 (if (not (looking-at "HTTP/"))
714 ;; HTTP/0.9 just gets passed back no matter what
715 (url-http-activate-callback)
716 (if (url-http-parse-headers)
717 (url-http-activate-callback)))))
718
719(defun url-http-simple-after-change-function (st nd length)
720 ;; Function used when we do NOT know how long the document is going to be
721 ;; Just _very_ simple 'downloaded %d' type of info.
722 (declare (special url-http-end-of-headers))
723 (url-lazy-message "Reading %s..." (url-pretty-length nd)))
724
725(defun url-http-content-length-after-change-function (st nd length)
726 "Function used when we DO know how long the document is going to be.
727More sophisticated percentage downloaded, etc.
728Also does minimal parsing of HTTP headers and will actually cause
729the callback to be triggered."
730 (declare (special url-current-object
731 url-http-end-of-headers
732 url-http-content-length
733 url-http-content-type
734 url-http-process))
735 (if url-http-content-type
736 (url-display-percentage
737 "Reading [%s]... %s of %s (%d%%)"
738 (url-percentage (- nd url-http-end-of-headers)
739 url-http-content-length)
740 url-http-content-type
741 (url-pretty-length (- nd url-http-end-of-headers))
742 (url-pretty-length url-http-content-length)
743 (url-percentage (- nd url-http-end-of-headers)
744 url-http-content-length))
745 (url-display-percentage
746 "Reading... %s of %s (%d%%)"
747 (url-percentage (- nd url-http-end-of-headers)
748 url-http-content-length)
749 (url-pretty-length (- nd url-http-end-of-headers))
750 (url-pretty-length url-http-content-length)
751 (url-percentage (- nd url-http-end-of-headers)
752 url-http-content-length)))
753
754 (if (> (- nd url-http-end-of-headers) url-http-content-length)
755 (progn
756 ;; Found the end of the document! Wheee!
757 (url-display-percentage nil nil)
758 (message "Reading... done.")
759 (if (url-http-parse-headers)
760 (url-http-activate-callback)))))
761
762(defun url-http-chunked-encoding-after-change-function (st nd length)
763 "Function used when dealing with 'chunked' encoding.
764Cannot give a sophisticated percentage, but we need a different
765function to look for the special 0-length chunk that signifies
766the end of the document."
767 (declare (special url-current-object
768 url-http-end-of-headers
769 url-http-content-type
770 url-http-chunked-length
771 url-http-chunked-counter
772 url-http-process url-http-chunked-start))
773 (save-excursion
774 (goto-char st)
775 (let ((read-next-chunk t)
776 (case-fold-search t)
777 (regexp nil)
778 (no-initial-crlf nil))
779 ;; We need to loop thru looking for more chunks even within
780 ;; one after-change-function call.
781 (while read-next-chunk
782 (setq no-initial-crlf (= 0 url-http-chunked-counter))
783 (if url-http-content-type
784 (url-display-percentage nil
785 "Reading [%s]... chunk #%d"
786 url-http-content-type url-http-chunked-counter)
787 (url-display-percentage nil
788 "Reading... chunk #%d"
789 url-http-chunked-counter))
790 (url-http-debug "Reading chunk %d (%d %d %d)"
791 url-http-chunked-counter st nd length)
792 (setq regexp (if no-initial-crlf
793 "\\([0-9a-z]+\\).*\r?\n"
794 "\r?\n\\([0-9a-z]+\\).*\r?\n"))
795
796 (if url-http-chunked-start
797 ;; We know how long the chunk is supposed to be, skip over
798 ;; leading crap if possible.
799 (if (> nd (+ url-http-chunked-start url-http-chunked-length))
800 (progn
801 (url-http-debug "Got to the end of chunk #%d!"
802 url-http-chunked-counter)
803 (goto-char (+ url-http-chunked-start
804 url-http-chunked-length)))
805 (url-http-debug "Still need %d bytes to hit end of chunk"
806 (- (+ url-http-chunked-start
807 url-http-chunked-length)
808 nd))
809 (setq read-next-chunk nil)))
810 (if (not read-next-chunk)
811 (url-http-debug "Still spinning for next chunk...")
812 (if no-initial-crlf (skip-chars-forward "\r\n"))
813 (if (not (looking-at regexp))
814 (progn
815 ;; Must not have received the entirety of the chunk header,
816 ;; need to spin some more.
817 (url-http-debug "Did not see start of chunk @ %d!" (point))
818 (setq read-next-chunk nil))
819 (add-text-properties (match-beginning 0) (match-end 0)
820 (list 'start-open t
821 'end-open t
822 'chunked-encoding t
823 'face (if (featurep 'xemacs)
824 'text-cursor
825 'cursor)
826 'invisible t))
827 (setq url-http-chunked-length (string-to-int (buffer-substring
828 (match-beginning 1)
829 (match-end 1))
830 16)
831 url-http-chunked-counter (1+ url-http-chunked-counter)
832 url-http-chunked-start (set-marker
833 (or url-http-chunked-start
834 (make-marker))
835 (match-end 0)))
836; (if (not url-http-debug)
837 (delete-region (match-beginning 0) (match-end 0));)
838 (url-http-debug "Saw start of chunk %d (length=%d, start=%d"
839 url-http-chunked-counter url-http-chunked-length
840 (marker-position url-http-chunked-start))
841 (if (= 0 url-http-chunked-length)
842 (progn
843 ;; Found the end of the document! Wheee!
844 (url-http-debug "Saw end of stream chunk!")
845 (setq read-next-chunk nil)
846 (url-display-percentage nil nil)
847 (goto-char (match-end 1))
848 (if (re-search-forward "^\r*$" nil t)
849 (message "Saw end of trailers..."))
850 (if (url-http-parse-headers)
851 (url-http-activate-callback))))))))))
852
853(defun url-http-wait-for-headers-change-function (st nd length)
854 ;; This will wait for the headers to arrive and then splice in the
855 ;; next appropriate after-change-function, etc.
856 (declare (special url-current-object
857 url-http-end-of-headers
858 url-http-content-type
859 url-http-content-length
860 url-http-transfer-encoding
861 url-callback-function
862 url-callback-arguments
863 url-http-process
864 url-http-method
865 url-http-after-change-function
866 url-http-response-status))
867 (url-http-debug "url-http-wait-for-headers-change-function (%s)"
868 (buffer-name))
869 (if (not (bobp))
870 (let ((end-of-headers nil)
871 (old-http nil)
872 (content-length nil))
873 (goto-char (point-min))
874 (if (not (looking-at "^HTTP/[1-9]\\.[0-9]"))
875 ;; Not HTTP/x.y data, must be 0.9
876 ;; God, I wish this could die.
877 (setq end-of-headers t
878 url-http-end-of-headers 0
879 old-http t)
880 (if (re-search-forward "^\r*$" nil t)
881 ;; Saw the end of the headers
882 (progn
883 (url-http-debug "Saw end of headers... (%s)" (buffer-name))
884 (setq url-http-end-of-headers (set-marker (make-marker)
885 (point))
886 end-of-headers t)
887 (url-http-clean-headers))))
888
889 (if (not end-of-headers)
890 ;; Haven't seen the end of the headers yet, need to wait
891 ;; for more data to arrive.
892 nil
893 (if old-http
894 (message "HTTP/0.9 How I hate thee!")
895 (progn
896 (url-http-parse-response)
897 (mail-narrow-to-head)
898 ;;(narrow-to-region (point-min) url-http-end-of-headers)
899 (setq url-http-transfer-encoding (mail-fetch-field
900 "transfer-encoding")
901 url-http-content-type (mail-fetch-field "content-type"))
902 (if (mail-fetch-field "content-length")
903 (setq url-http-content-length
904 (string-to-int (mail-fetch-field "content-length"))))
905 (widen)))
906 (if url-http-transfer-encoding
907 (setq url-http-transfer-encoding
908 (downcase url-http-transfer-encoding)))
909
910 (cond
911 ((or (= url-http-response-status 204)
912 (= url-http-response-status 205))
913 (url-http-debug "%d response must have headers only (%s)."
914 url-http-response-status (buffer-name))
915 (if (url-http-parse-headers)
916 (url-http-activate-callback)))
917 ((string= "HEAD" url-http-method)
918 ;; A HEAD request is _ALWAYS_ terminated by the header
919 ;; information, regardless of any entity headers,
920 ;; according to section 4.4 of the HTTP/1.1 draft.
921 (url-http-debug "HEAD request must have headers only (%s)."
922 (buffer-name))
923 (if (url-http-parse-headers)
924 (url-http-activate-callback)))
925 ((string= "CONNECT" url-http-method)
926 ;; A CONNECT request is finished, but we cannot stick this
927 ;; back on the free connectin list
928 (url-http-debug "CONNECT request must have headers only.")
929 (if (url-http-parse-headers)
930 (url-http-activate-callback)))
931 ((equal url-http-response-status 304)
932 ;; Only allowed to have a header section. We have to handle
933 ;; this here instead of in url-http-parse-headers because if
934 ;; you have a cached copy of something without a known
935 ;; content-length, and try to retrieve it from the cache, we'd
936 ;; fall into the 'being dumb' section and wait for the
937 ;; connection to terminate, which means we'd wait for 10
938 ;; seconds for the keep-alives to time out on some servers.
939 (if (url-http-parse-headers)
940 (url-http-activate-callback)))
941 (old-http
942 ;; HTTP/0.9 always signaled end-of-connection by closing the
943 ;; connection.
944 (url-http-debug
945 "Saw HTTP/0.9 response, connection closed means end of document.")
946 (setq url-http-after-change-function
947 'url-http-simple-after-change-function))
948 ((equal url-http-transfer-encoding "chunked")
949 (url-http-debug "Saw chunked encoding.")
950 (setq url-http-after-change-function
951 'url-http-chunked-encoding-after-change-function)
952 (if (> nd url-http-end-of-headers)
953 (progn
954 (url-http-debug
955 "Calling initial chunked-encoding for extra data at end of headers")
956 (url-http-chunked-encoding-after-change-function
957 (marker-position url-http-end-of-headers) nd
958 (- nd url-http-end-of-headers)))))
959 ((integerp url-http-content-length)
960 (url-http-debug
961 "Got a content-length, being smart about document end.")
962 (setq url-http-after-change-function
963 'url-http-content-length-after-change-function)
964 (cond
965 ((= 0 url-http-content-length)
966 ;; We got a NULL body! Activate the callback
967 ;; immediately!
968 (url-http-debug
969 "Got 0-length content-length, activating callback immediately.")
970 (if (url-http-parse-headers)
971 (url-http-activate-callback)))
972 ((> nd url-http-end-of-headers)
973 ;; Have some leftover data
974 (url-http-debug "Calling initial content-length for extra data at end of headers")
975 (url-http-content-length-after-change-function
976 (marker-position url-http-end-of-headers)
977 nd
978 (- nd url-http-end-of-headers)))
979 (t
980 nil)))
981 (t
982 (url-http-debug "No content-length, being dumb.")
983 (setq url-http-after-change-function
984 'url-http-simple-after-change-function)))))
985 ;; We are still at the beginning of the buffer... must just be
986 ;; waiting for a response.
987 (url-http-debug "Spinning waiting for headers..."))
988 (goto-char (point-max)))
989
990;;;###autoload
991(defun url-http (url callback cbargs)
992 "Retrieve URL via HTTP asynchronously.
993URL must be a parsed URL. See `url-generic-parse-url' for details.
994When retrieval is completed, the function CALLBACK is executed with
995CBARGS as the arguments."
996 (check-type url vector "Need a pre-parsed URL.")
997 (declare (special url-current-object
998 url-http-end-of-headers
999 url-http-content-type
1000 url-http-content-length
1001 url-http-transfer-encoding
1002 url-http-after-change-function
1003 url-callback-function
1004 url-callback-arguments
1005 url-http-method
1006 url-http-extra-headers
1007 url-http-data
1008 url-http-chunked-length
1009 url-http-chunked-start
1010 url-http-chunked-counter
1011 url-http-process))
1012 (let ((connection (url-http-find-free-connection (url-host url)
1013 (url-port url)))
1014 (buffer (generate-new-buffer (format " *http %s:%d*"
1015 (url-host url)
1016 (url-port url)))))
1017 (if (not connection)
1018 ;; Failed to open the connection for some reason
1019 (progn
1020 (kill-buffer buffer)
1021 (setq buffer nil)
1022 (error "Could not create connection to %s:%d" (url-host url)
1023 (url-port url)))
1024 (save-excursion
1025 (set-buffer buffer)
1026 (mm-disable-multibyte)
1027 (setq url-current-object url
1028 mode-line-format "%b [%s]")
1029
1030 (dolist (var '(url-http-end-of-headers
1031 url-http-content-type
1032 url-http-content-length
1033 url-http-transfer-encoding
1034 url-http-after-change-function
1035 url-http-response-status
1036 url-http-chunked-length
1037 url-http-chunked-counter
1038 url-http-chunked-start
1039 url-callback-function
1040 url-callback-arguments
1041 url-http-process
1042 url-http-method
1043 url-http-extra-headers
1044 url-http-data))
1045 (set (make-local-variable var) nil))
1046
1047 (setq url-http-method (or url-request-method "GET")
1048 url-http-extra-headers url-request-extra-headers
1049 url-http-data url-request-data
1050 url-http-process connection
1051 url-http-chunked-length nil
1052 url-http-chunked-start nil
1053 url-http-chunked-counter 0
1054 url-callback-function callback
1055 url-callback-arguments cbargs
1056 url-http-after-change-function 'url-http-wait-for-headers-change-function)
1057
1058 (set-process-buffer connection buffer)
1059 (set-process-sentinel connection 'url-http-end-of-document-sentinel)
1060 (set-process-filter connection 'url-http-generic-filter)
1061 (process-send-string connection (url-http-create-request url))))
1062 buffer))
1063
1064;; Since Emacs 19/20 does not allow you to change the
1065;; `after-change-functions' hook in the midst of running them, we fake
1066;; an after change by hooking into the process filter and inserting
1067;; the data ourselves. This is slightly less efficient, but there
1068;; were tons of weird ways the after-change code was biting us in the
1069;; shorts.
1070(defun url-http-generic-filter (proc data)
1071 ;; Sometimes we get a zero-length data chunk after the process has
1072 ;; been changed to 'free', which means it has no buffer associated
1073 ;; with it. Do nothing if there is no buffer, or 0 length data.
1074 (declare (special url-http-after-change-function))
1075 (and (process-buffer proc)
1076 (/= (length data) 0)
1077 (save-excursion
1078 (set-buffer (process-buffer proc))
1079 (url-http-debug "Calling after change function `%s' for `%S'" url-http-after-change-function proc)
1080 (funcall url-http-after-change-function
1081 (point-max)
1082 (progn
1083 (goto-char (point-max))
1084 (insert data)
1085 (point-max))
1086 (length data)))))
1087
1088;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1089;;; file-name-handler stuff from here on out
1090;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1091(if (not (fboundp 'symbol-value-in-buffer))
1092 (defun url-http-symbol-value-in-buffer (symbol buffer
1093 &optional unbound-value)
1094 "Return the value of SYMBOL in BUFFER, or UNBOUND-VALUE if it is unbound."
1095 (save-excursion
1096 (set-buffer buffer)
1097 (if (not (boundp symbol))
1098 unbound-value
1099 (symbol-value symbol))))
1100 (defalias 'url-http-symbol-value-in-buffer 'symbol-value-in-buffer))
1101
1102(defun url-http-head (url)
1103 (let ((url-request-method "HEAD")
1104 (url-request-data nil))
1105 (url-retrieve-synchronously url)))
1106
1107;;;###autoload
1108(defun url-http-file-exists-p (url)
1109 (let ((version nil)
1110 (status nil)
1111 (exists nil)
1112 (buffer (url-http-head url)))
1113 (if (not buffer)
1114 (setq exists nil)
1115 (setq status (url-http-symbol-value-in-buffer 'url-http-response-status
1116 buffer 500)
1117 exists (and (>= status 200) (< status 300)))
1118 (kill-buffer buffer))
1119 exists))
1120
1121;;;###autoload
1122(defalias 'url-http-file-readable-p 'url-http-file-exists-p)
1123
1124(defun url-http-head-file-attributes (url)
1125 (let ((buffer (url-http-head url))
1126 (attributes nil))
1127 (when buffer
1128 (setq attributes (make-list 11 nil))
1129 (setf (nth 1 attributes) 1) ; Number of links to file
1130 (setf (nth 2 attributes) 0) ; file uid
1131 (setf (nth 3 attributes) 0) ; file gid
1132 (setf (nth 7 attributes) ; file size
1133 (url-http-symbol-value-in-buffer 'url-http-content-length
1134 buffer -1))
1135 (setf (nth 8 attributes) (eval-when-compile (make-string 10 ?-)))
1136 (kill-buffer buffer))
1137 attributes))
1138
1139;;;###autoload
1140(defun url-http-file-attributes (url)
1141 (if (url-dav-supported-p url)
1142 (url-dav-file-attributes url)
1143 (url-http-head-file-attributes url)))
1144
1145;;;###autoload
1146(defun url-http-options (url)
1147 "Returns a property list describing options available for URL.
1148This list is retrieved using the `OPTIONS' HTTP method.
1149
1150Property list members:
1151
1152methods
1153 A list of symbols specifying what HTTP methods the resource
1154 supports.
1155
1156dav
1157 A list of numbers specifying what DAV protocol/schema versions are
1158 supported.
1159
1160dasl
1161 A list of supported DASL search types supported (string form)
1162
1163ranges
1164 A list of the units available for use in partial document fetches.
1165
1166p3p
1167 The `Platform For Privacy Protection' description for the resource.
1168 Currently this is just the raw header contents. This is likely to
1169 change once P3P is formally supported by the URL package or
1170 Emacs/W3.
1171"
1172 (let* ((url-request-method "OPTIONS")
1173 (url-request-data nil)
1174 (buffer (url-retrieve-synchronously url))
1175 (header nil)
1176 (options nil))
1177 (when (and buffer (= 2 (/ (url-http-symbol-value-in-buffer
1178 'url-http-response-status buffer 0) 100)))
1179 ;; Only parse the options if we got a 2xx response code!
1180 (save-excursion
1181 (save-restriction
1182 (save-match-data
1183 (set-buffer buffer)
1184 (mail-narrow-to-head)
1185
1186 ;; Figure out what methods are supported.
1187 (when (setq header (mail-fetch-field "allow"))
1188 (setq options (plist-put
1189 options 'methods
1190 (mapcar 'intern (split-string header "[ ,]+")))))
1191
1192 ;; Check for DAV
1193 (when (setq header (mail-fetch-field "dav"))
1194 (setq options (plist-put
1195 options 'dav
1196 (delq 0
1197 (mapcar 'string-to-number
1198 (split-string header "[, ]+"))))))
1199
1200 ;; Now for DASL
1201 (when (setq header (mail-fetch-field "dasl"))
1202 (setq options (plist-put
1203 options 'dasl
1204 (split-string header "[, ]+"))))
1205
1206 ;; P3P - should get more detailed here. FIXME
1207 (when (setq header (mail-fetch-field "p3p"))
1208 (setq options (plist-put options 'p3p header)))
1209
1210 ;; Check for whether they accept byte-range requests.
1211 (when (setq header (mail-fetch-field "accept-ranges"))
1212 (setq options (plist-put
1213 options 'ranges
1214 (delq 'none
1215 (mapcar 'intern
1216 (split-string header "[, ]+"))))))
1217 ))))
1218 (if buffer (kill-buffer buffer))
1219 options))
1220
1221(provide 'url-http)
1222
1223;;; url-http.el ends here
diff --git a/lisp/url/url-https.el b/lisp/url/url-https.el
new file mode 100644
index 00000000000..27652792d49
--- /dev/null
+++ b/lisp/url/url-https.el
@@ -0,0 +1,53 @@
1;;; url-https.el --- HTTP over SSL routines
2;; Author: $Author: wmperry $
3;; Created: $Date: 2001/11/22 14:32:13 $
4;; Version: $Revision: 1.3 $
5;; Keywords: comm, data, processes
6
7;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
8;;; Copyright (c) 1999 Free Software Foundation, Inc.
9;;;
10;;; This file is part of GNU Emacs.
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 the
24;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
25;;; Boston, MA 02111-1307, USA.
26;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
27
28(require 'url-gw)
29(require 'url-util)
30(require 'url-parse)
31(require 'url-cookie)
32(require 'url-http)
33
34(defconst url-https-default-port 443 "Default HTTPS port.")
35(defconst url-https-asynchronous-p t "HTTPS retrievals are asynchronous.")
36(defalias 'url-https-expand-file-name 'url-http-expand-file-name)
37
38(defmacro url-https-create-secure-wrapper (method args)
39 (` (defun (, (intern (format (if method "url-https-%s" "url-https") method))) (, args)
40 (, (format "HTTPS wrapper around `%s' call." (or method "url-http")))
41 (condition-case ()
42 (require 'ssl)
43 (error
44 (error "HTTPS support could not find `ssl' library.")))
45 (let ((url-gateway-method 'ssl))
46 ((, (intern (format (if method "url-http-%s" "url-http") method))) (,@ (remove '&rest (remove '&optional args))))))))
47
48(url-https-create-secure-wrapper nil (url callback cbargs))
49(url-https-create-secure-wrapper file-exists-p (url))
50(url-https-create-secure-wrapper file-readable-p (url))
51(url-https-create-secure-wrapper file-attributes (url))
52
53(provide 'url-https)
diff --git a/lisp/url/url-imap.el b/lisp/url/url-imap.el
new file mode 100644
index 00000000000..3d143759cfb
--- /dev/null
+++ b/lisp/url/url-imap.el
@@ -0,0 +1,81 @@
1;;; url-imap.el --- IMAP retrieval routines
2;; Author: Simon Josefsson <jas@pdc.kth.se>
3;; Created: $Date: 2002/01/22 17:52:16 $
4;; Version: $Revision: 1.4 $
5;; Keywords: comm, data, processes
6
7;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
8;;; Copyright (c) 1999 Free Software Foundation, Inc.
9;;;
10;;; This file is part of GNU Emacs.
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 the
24;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
25;;; Boston, MA 02111-1307, USA.
26;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
27
28; Anyway, here's a teaser. It's quite broken in lots of regards, but at
29; least it seem to work. At least a little. At least when called
30; manually like this (I've no idea how it's supposed to be called):
31
32; (url-imap (url-generic-parse-url "imap://cyrus.andrew.cmu.edu/archive.c-client;UID=1021"))
33
34(eval-when-compile (require 'cl))
35(require 'url-util)
36(require 'url-parse)
37(require 'nnimap)
38(require 'mm-util)
39
40(defconst url-imap-default-port 143 "Default IMAP port")
41
42(defun url-imap-open-host (host port user pass)
43 ;; xxx use user and password
44 (if (fboundp 'nnheader-init-server-buffer)
45 (nnheader-init-server-buffer))
46 (let ((imap-username user)
47 (imap-password pass)
48 (authenticator (if user 'login 'anonymous)))
49 (if (stringp port)
50 (setq port (string-to-int port)))
51 (nnimap-open-server host
52 `((nnimap-server-port ,port)
53 (nnimap-stream 'network)
54 (nnimap-authenticator ,authenticator)))))
55
56(defun url-imap (url)
57 (check-type url vector "Need a pre-parsed URL.")
58 (save-excursion
59 (set-buffer (generate-new-buffer " *url-imap*"))
60 (mm-disable-multibyte)
61 (let* ((host (url-host url))
62 (port (url-port url))
63 ;; xxx decode mailbox (see rfc2192)
64 (mailbox (url-filename url))
65 (coding-system-for-read 'binary))
66 (and (eq (string-to-char mailbox) ?/)
67 (setq mailbox (substring mailbox 1)))
68 (url-imap-open-host host port (url-user url) (url-password url))
69 (cond ((assoc "TYPE" (url-attributes url))
70 ;; xxx list mailboxes (start gnus?)
71 )
72 ((assoc "UID" (url-attributes url))
73 ;; fetch message part
74 ;; xxx handle partial fetches
75 (insert "Content-type: message/rfc822\n\n")
76 (nnimap-request-article (cdr (assoc "UID" (url-attributes url)))
77 mailbox host (current-buffer)))
78 (t
79 ;; xxx list messages in mailbox (start gnus?)
80 )))
81 (current-buffer)))
diff --git a/lisp/url/url-irc.el b/lisp/url/url-irc.el
new file mode 100644
index 00000000000..c4005d19ec7
--- /dev/null
+++ b/lisp/url/url-irc.el
@@ -0,0 +1,78 @@
1;;; url-irc.el --- IRC URL interface
2;; Author: $Author: wmperry $
3;; Created: $Date: 1999/12/24 12:13:33 $
4;; Version: $Revision: 1.2 $
5;; Keywords: comm, data, processes
6
7;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
8;;; Copyright (c) 1996 by William M. Perry <wmperry@cs.indiana.edu>
9;;; Copyright (c) 1996 - 1999 Free Software Foundation, Inc.
10;;;
11;;; This file is part of GNU Emacs.
12;;;
13;;; GNU Emacs is free software; you can redistribute it and/or modify
14;;; it under the terms of the GNU General Public License as published by
15;;; the Free Software Foundation; either version 2, or (at your option)
16;;; any later version.
17;;;
18;;; GNU Emacs is distributed in the hope that it will be useful,
19;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
20;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
21;;; GNU General Public License for more details.
22;;;
23;;; You should have received a copy of the GNU General Public License
24;;; along with GNU Emacs; see the file COPYING. If not, write to the
25;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
26;;; Boston, MA 02111-1307, USA.
27;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
28
29;;; IRC URLs are defined in http://www.w3.org/Addressing/draft-mirashi-url-irc-01.txt
30
31(require 'url-vars)
32(require 'url-parse)
33
34(defconst url-irc-default-port 6667 "Default port for IRC connections")
35
36(defcustom url-irc-function 'url-irc-zenirc
37 "*Function to actually open an IRC connection.
38Should be a function that takes several argument:
39 HOST - the hostname of the IRC server to contact
40 PORT - the port number of the IRC server to contact
41 CHANNEL - What channel on the server to visit right away (can be nil)
42 USER - What username to use
43PASSWORD - What password to use"
44 :type '(choice (const :tag "ZEN IRC" :value 'url-irc-zenirc)
45 (function :tag "Other"))
46 :group 'url)
47
48(defun url-irc-zenirc (host port channel user password)
49 (let ((zenirc-buffer-name (if (and user host port)
50 (format "%s@%s:%d" user host port)
51 (format "%s:%d" host port)))
52 (zenirc-server-alist
53 (list
54 (list host port password nil user))))
55 (zenirc)
56 (goto-char (point-max))
57 (if (not channel)
58 nil
59 (insert "/join " channel)
60 (zenirc-send-line))))
61
62;;;###autoload
63(defun url-irc (url)
64 (let* ((host (url-host url))
65 (port (string-to-int (url-port url)))
66 (pass (url-password url))
67 (user (url-user url))
68 (chan (url-filename url)))
69 (if (url-target url)
70 (setq chan (concat chan "#" (url-target url))))
71 (if (string-match "^/" chan)
72 (setq chan (substring chan 1 nil)))
73 (if (= (length chan) 0)
74 (setq chan nil))
75 (funcall url-irc-function host port chan user pass)
76 nil))
77
78(provide 'url-irc)
diff --git a/lisp/url/url-ldap.el b/lisp/url/url-ldap.el
new file mode 100644
index 00000000000..67409e39a1d
--- /dev/null
+++ b/lisp/url/url-ldap.el
@@ -0,0 +1,233 @@
1;;; url-ldap.el --- LDAP Uniform Resource Locator retrieval code
2;; Author: $Author: wmperry $
3;; Created: $Date: 1999/11/26 12:11:50 $
4;; Version: $Revision: 1.1.1.1 $
5;; Keywords: comm, data, processes
6
7;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
8;;; Copyright (c) 1998 - 1999 Free Software Foundation, Inc.
9;;;
10;;; This file is part of GNU Emacs.
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 the
24;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
25;;; Boston, MA 02111-1307, USA.
26;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
27
28(require 'url-vars)
29(require 'url-parse)
30(require 'url-util)
31
32;; This has been implemented from RFC2255 'The LDAP URL Format' (Dec 1997)
33;;
34;; basic format is: ldap://host:port/dn?attributes?scope?filter?extensions
35;;
36;; Test URLs:
37;; ldap://ldap.itd.umich.edu/cn%3Dumbflabmanager%2C%20ou%3DUser%20Groups%2C%20ou%3DGroups%2C%20o%3DUniversity%20of%20Michigan%2C%20c%3DUS
38;; ldap://ldap.itd.umich.edu/o=University%20of%20Michigan,c=US
39;;
40;; For simple queries, I have verified compatibility with Netscape
41;; Communicator v4.5 under linux.
42;;
43;; For anything _useful_ though, like specifying the attributes,
44;; scope, filter, or extensions, netscape claims the URL format is
45;; unrecognized. So I don't think it supports anything other than the
46;; defaults (scope=base,attributes=*,filter=(objectClass=*)
47
48(defconst url-ldap-default-port 389 "Default LDAP port.")
49(defalias 'url-ldap-expand-file-name 'url-default-expander)
50
51(defvar url-ldap-pretty-names
52 '(("l" . "City")
53 ("objectclass" . "Object Class")
54 ("o" . "Organization")
55 ("ou" . "Organizational Unit")
56 ("cn" . "Name")
57 ("sn" . "Last Name")
58 ("givenname" . "First Name")
59 ("mail" . "Email")
60 ("title" . "Title")
61 ("c" . "Country")
62 ("postalcode" . "ZIP Code")
63 ("telephonenumber" . "Phone Number")
64 ("facsimiletelephonenumber" . "Fax")
65 ("postaladdress" . "Mailing Address")
66 ("description" . "Notes"))
67 "*An assoc list mapping LDAP attribute names to pretty descriptions of them.")
68
69(defvar url-ldap-attribute-formatters
70 '(("mail" . (lambda (x) (format "<a href='mailto:%s'>%s</a>" x x)))
71 ("owner" . url-ldap-dn-formatter)
72 ("creatorsname" . url-ldap-dn-formatter)
73 ("jpegphoto" . url-ldap-image-formatter)
74 ("usercertificate" . url-ldap-certificate-formatter)
75 ("modifiersname" . url-ldap-dn-formatter)
76 ("namingcontexts" . url-ldap-dn-formatter)
77 ("defaultnamingcontext" . url-ldap-dn-formatter)
78 ("member" . url-ldap-dn-formatter))
79 "*An assoc list mapping LDAP attribute names to pretty formatters for them.")
80
81(defsubst url-ldap-attribute-pretty-name (n)
82 (or (cdr-safe (assoc (downcase n) url-ldap-pretty-names)) n))
83
84(defsubst url-ldap-attribute-pretty-desc (n v)
85 (if (string-match "^\\([^;]+\\);" n)
86 (setq n (match-string 1 n)))
87 (funcall (or (cdr-safe (assoc (downcase n) url-ldap-attribute-formatters)) 'identity) v))
88
89(defun url-ldap-dn-formatter (dn)
90 (concat "<a href='/"
91 (url-hexify-string dn)
92 "'>" dn "</a>"))
93
94(defun url-ldap-certificate-formatter (data)
95 (condition-case ()
96 (require 'ssl)
97 (error nil))
98 (let ((vals (and (fboundp 'ssl-certificate-information)
99 (ssl-certificate-information data))))
100 (if (not vals)
101 "<b>Unable to parse certificate</b>"
102 (concat "<table border=0>\n"
103 (mapconcat
104 (lambda (ava)
105 (format "<tr><td>%s</td><td>%s</td></tr>\n" (car ava) (cdr ava)))
106 vals "\n")
107 "</table>\n"))))
108
109(defun url-ldap-image-formatter (data)
110 (format "<img alt='JPEG Photo' src='data:image/jpeg;base64,%s'>"
111 (url-hexify-string (base64-encode-string data))))
112
113;;;###autoload
114(defun url-ldap (url)
115 (save-excursion
116 (set-buffer (generate-new-buffer " *url-ldap*"))
117 (setq url-current-object url)
118 (insert "Content-type: text/html\r\n\r\n")
119 (if (not (fboundp 'ldap-search-internal))
120 (insert "<html>\n"
121 " <head>\n"
122 " <title>LDAP Not Supported</title>\n"
123 " <base href='" (url-recreate-url url) "'>\n"
124 " </head>\n"
125 " <body>\n"
126 " <h1>LDAP Not Supported</h1>\n"
127 " <p>\n"
128 " This version of Emacs does not support LDAP.\n"
129 " </p>\n"
130 " </body>\n"
131 "</html>\n")
132 (let* ((binddn nil)
133 (data (url-filename url))
134 (host (url-host url))
135 (port (url-port url))
136 (base-object nil)
137 (attributes nil)
138 (scope nil)
139 (filter nil)
140 (extensions nil)
141 (connection nil)
142 (results nil)
143 (extract-dn (and (fboundp 'function-max-args)
144 (= (function-max-args 'ldap-search-internal) 7))))
145
146 ;; Get rid of leading /
147 (if (string-match "^/" data)
148 (setq data (substring data 1)))
149
150 (setq data (mapcar (lambda (x) (if (/= (length x) 0) x nil)) (split-string data "\\?"))
151 base-object (nth 0 data)
152 attributes (nth 1 data)
153 scope (nth 2 data)
154 filter (nth 3 data)
155 extensions (nth 4 data))
156
157 ;; fill in the defaults
158 (setq base-object (url-unhex-string (or base-object ""))
159 scope (intern (url-unhex-string (or scope "base")))
160 filter (url-unhex-string (or filter "(objectClass=*)")))
161
162 (if (not (memq scope '(base one tree)))
163 (error "Malformed LDAP URL: Unknown scope: %S" scope))
164
165 ;; Convert to the internal LDAP support scoping names.
166 (setq scope (cdr (assq scope '((base . base) (one . onelevel) (sub . subtree)))))
167
168 (if attributes
169 (setq attributes (mapcar 'url-unhex-string (split-string attributes ","))))
170
171 ;; Parse out the exentions
172 (if extensions
173 (setq extensions (mapcar (lambda (ext)
174 (if (string-match "\\([^=]*\\)=\\(.*\\)" ext)
175 (cons (match-string 1 ext) (match-string 2 ext))
176 (cons ext ext)))
177 (split-string extensions ","))
178 extensions (mapcar (lambda (ext)
179 (cons (url-unhex-string (car ext))
180 (url-unhex-string (cdr ext))))
181 extensions)))
182
183 (setq binddn (cdr-safe (or (assoc "bindname" extensions)
184 (assoc "!bindname" extensions))))
185
186 ;; Now, let's actually do something with it.
187 (setq connection (ldap-open host (if binddn (list 'binddn binddn)))
188 results (if extract-dn
189 (ldap-search-internal connection filter base-object scope attributes nil t)
190 (ldap-search-internal connection filter base-object scope attributes nil)))
191
192 (ldap-close connection)
193 (insert "<html>\n"
194 " <head>\n"
195 " <title>LDAP Search Results</title>\n"
196 " <base href='" (url-recreate-url url) "'>\n"
197 " </head>\n"
198 " <body>\n"
199 " <h1>" (int-to-string (length results)) " matches</h1>\n")
200
201 (mapc (lambda (obj)
202 (insert " <hr>\n"
203 " <table border=1>\n")
204 (if extract-dn
205 (insert " <tr><th colspan=2>" (car obj) "</th></tr>\n"))
206 (mapc (lambda (attr)
207 (if (= (length (cdr attr)) 1)
208 ;; single match, easy
209 (insert " <tr><td>"
210 (url-ldap-attribute-pretty-name (car attr))
211 "</td><td>"
212 (url-ldap-attribute-pretty-desc (car attr) (car (cdr attr)))
213 "</td></tr>\n")
214 ;; Multiple matches, slightly uglier
215 (insert " <tr>\n"
216 (format " <td valign=top>" (length (cdr attr)))
217 (url-ldap-attribute-pretty-name (car attr)) "</td><td>"
218 (mapconcat (lambda (x)
219 (url-ldap-attribute-pretty-desc (car attr) x))
220 (cdr attr)
221 "<br>\n")
222 "</td>"
223 " </tr>\n")))
224 (if extract-dn (cdr obj) obj))
225 (insert " </table>\n"))
226 results)
227
228 (insert " <hr>\n"
229 " </body>\n"
230 "</html>\n")))
231 (current-buffer)))
232
233(provide 'url-ldap)
diff --git a/lisp/url/url-mailto.el b/lisp/url/url-mailto.el
new file mode 100644
index 00000000000..02e410411f5
--- /dev/null
+++ b/lisp/url/url-mailto.el
@@ -0,0 +1,129 @@
1;;; url-mail.el --- Mail Uniform Resource Locator retrieval code
2;; Author: $Author: fx $
3;; Created: $Date: 2001/10/05 17:04:06 $
4;; Version: $Revision: 1.4 $
5;; Keywords: comm, data, processes
6
7;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
8;;; Copyright (c) 1993 - 1996 by William M. Perry <wmperry@cs.indiana.edu>
9;;; Copyright (c) 1996 - 1999 Free Software Foundation, Inc.
10;;;
11;;; This file is part of GNU Emacs.
12;;;
13;;; GNU Emacs is free software; you can redistribute it and/or modify
14;;; it under the terms of the GNU General Public License as published by
15;;; the Free Software Foundation; either version 2, or (at your option)
16;;; any later version.
17;;;
18;;; GNU Emacs is distributed in the hope that it will be useful,
19;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
20;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
21;;; GNU General Public License for more details.
22;;;
23;;; You should have received a copy of the GNU General Public License
24;;; along with GNU Emacs; see the file COPYING. If not, write to the
25;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
26;;; Boston, MA 02111-1307, USA.
27;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
28
29(eval-when-compile (require 'cl))
30(require 'url-vars)
31(require 'url-parse)
32(require 'url-util)
33
34;;;###autoload
35(defun url-mail (&rest args)
36 (interactive "P")
37 (if (fboundp 'message-mail)
38 (apply 'message-mail args)
39 (or (apply 'mail args)
40 (error "Mail aborted"))))
41
42(defun url-mail-goto-field (field)
43 (if (not field)
44 (goto-char (point-max))
45 (let ((dest nil)
46 (lim nil)
47 (case-fold-search t))
48 (save-excursion
49 (goto-char (point-min))
50 (if (re-search-forward (regexp-quote mail-header-separator) nil t)
51 (setq lim (match-beginning 0)))
52 (goto-char (point-min))
53 (if (re-search-forward (concat "^" (regexp-quote field) ":") lim t)
54 (setq dest (match-beginning 0))))
55 (if dest
56 (progn
57 (goto-char dest)
58 (end-of-line))
59 (goto-char lim)
60 (insert (capitalize field) ": ")
61 (save-excursion
62 (insert "\n"))))))
63
64;;;###autoload
65(defun url-mailto (url)
66 "Handle the mailto: URL syntax."
67 (if (url-user url)
68 ;; malformed mailto URL (mailto://wmperry@gnu.org instead of
69 ;; mailto:wmperry@gnu.org
70 (url-set-filename url (concat (url-user url) "@" (url-filename url))))
71 (setq url (url-filename url))
72 (let (to args source-url subject func headers-start)
73 (if (string-match (regexp-quote "?") url)
74 (setq headers-start (match-end 0)
75 to (url-unhex-string (substring url 0 (match-beginning 0)))
76 args (url-parse-query-string
77 (substring url headers-start nil) t))
78 (setq to (url-unhex-string url)))
79 (setq source-url (url-view-url t))
80 (if (and url-request-data (not (assoc "subject" args)))
81 (setq args (cons (list "subject"
82 (concat "Automatic submission from "
83 url-package-name "/"
84 url-package-version)) args)))
85 (if (and source-url (not (assoc "x-url-from" args)))
86 (setq args (cons (list "x-url-from" source-url) args)))
87
88 (if (assoc "to" args)
89 (push to (cdr (assoc "to" args)))
90 (setq args (cons (list "to" to) args)))
91 (setq subject (cdr-safe (assoc "subject" args)))
92 (if (fboundp url-mail-command) (funcall url-mail-command) (mail))
93 (while args
94 (if (string= (caar args) "body")
95 (progn
96 (goto-char (point-max))
97 (insert (mapconcat 'identity (cdar args) "\n")))
98 (url-mail-goto-field (caar args))
99 (setq func (intern-soft (concat "mail-" (caar args))))
100 (insert (mapconcat 'identity (cdar args) ", ")))
101 (setq args (cdr args)))
102 ;; (url-mail-goto-field "User-Agent")
103;; (insert url-package-name "/" url-package-version " URL/" url-version)
104 (if (not url-request-data)
105 (progn
106 (set-buffer-modified-p nil)
107 (if subject
108 (url-mail-goto-field nil)
109 (url-mail-goto-field "subject")))
110 (if url-request-extra-headers
111 (mapconcat
112 (lambda (x)
113 (url-mail-goto-field (car x))
114 (insert (cdr x)))
115 url-request-extra-headers ""))
116 (goto-char (point-max))
117 (insert url-request-data)
118 ;; It seems Microsoft-ish to send without warning.
119 ;; Fixme: presumably this should depend on a privacy setting.
120 (if (y-or-n-p "Send this auto-generated mail? ")
121 (cond ((eq url-mail-command 'compose-mail)
122 (funcall (get mail-user-agent 'sendfunc) nil))
123 ;; otherwise, we can't be sure
124 ((fboundp 'message-mail)
125 (message-send-and-exit))
126 (t (mail-send-and-exit nil)))))
127 nil))
128
129(provide 'url-mailto)
diff --git a/lisp/url/url-methods.el b/lisp/url/url-methods.el
new file mode 100644
index 00000000000..505fa083c89
--- /dev/null
+++ b/lisp/url/url-methods.el
@@ -0,0 +1,149 @@
1;;; url-methods.el --- Load URL schemes as needed
2;; Author: $Author: wmperry $
3;; Created: $Date: 2002/11/04 14:40:32 $
4;; Version: $Revision: 1.14 $
5;; Keywords: comm, data, processes, hypermedia
6
7;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
8;;; Copyright (c) 1993 - 1996 by William M. Perry <wmperry@cs.indiana.edu>
9;;; Copyright (c) 1996 - 1999 Free Software Foundation, Inc.
10;;;
11;;; This file is part of GNU Emacs.
12;;;
13;;; GNU Emacs is free software; you can redistribute it and/or modify
14;;; it under the terms of the GNU General Public License as published by
15;;; the Free Software Foundation; either version 2, or (at your option)
16;;; any later version.
17;;;
18;;; GNU Emacs is distributed in the hope that it will be useful,
19;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
20;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
21;;; GNU General Public License for more details.
22;;;
23;;; You should have received a copy of the GNU General Public License
24;;; along with GNU Emacs; see the file COPYING. If not, write to the
25;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
26;;; Boston, MA 02111-1307, USA.
27;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
28
29(eval-when-compile
30 (require 'cl))
31
32;; This loads up some of the small, silly URLs that I really don't
33;; want to bother putting in their own separate files.
34(require 'url-auto)
35(require 'url-parse)
36
37(defvar url-scheme-registry (make-hash-table :size 7 :test 'equal))
38
39(defconst url-scheme-methods
40 '((default-port . variable)
41 (asynchronous-p . variable)
42 (expand-file-name . function)
43 (file-exists-p . function)
44 (file-attributes . function)
45 (parse-url . function)
46 (file-symlink-p . function)
47 (file-writable-p . function)
48 (file-directory-p . function)
49 (file-executable-p . function)
50 (directory-files . function)
51 (file-truename . function))
52 "Assoc-list of methods that each URL loader can provide.")
53
54(defconst url-scheme-default-properties
55 (list 'name "unknown"
56 'loader 'url-scheme-default-loader
57 'default-port 0
58 'expand-file-name 'url-identity-expander
59 'parse-url 'url-generic-parse-url
60 'asynchronous-p nil
61 'file-directory-p 'ignore
62 'file-truename (lambda (&rest args)
63 (url-recreate-url (car args)))
64 'file-exists-p 'ignore
65 'file-attributes 'ignore))
66
67(defun url-scheme-default-loader (url &optional callback cbargs)
68 "Signal an error for an unknown URL scheme."
69 (error "Unkown URL scheme: %s" (url-type url)))
70
71(defun url-scheme-register-proxy (scheme)
72 "Automatically find a proxy for SCHEME and put it in `url-proxy-services'."
73 (let* ((env-var (concat scheme "_proxy"))
74 (env-proxy (or (getenv (upcase env-var))
75 (getenv (downcase env-var))))
76 (cur-proxy (assoc scheme url-proxy-services))
77 (urlobj nil))
78
79 ;; Store any proxying information - this will not overwrite an old
80 ;; entry, so that people can still set this information in their
81 ;; .emacs file
82 (cond
83 (cur-proxy nil) ; Keep their old settings
84 ((null env-proxy) nil) ; No proxy setup
85 ;; First check if its something like hostname:port
86 ((string-match "^\\([^:]+\\):\\([0-9]+\\)$" env-proxy)
87 (setq urlobj (url-generic-parse-url nil)) ; Get a blank object
88 (url-set-type urlobj "http")
89 (url-set-host urlobj (match-string 1 env-proxy))
90 (url-set-port urlobj (string-to-number (match-string 2 env-proxy))))
91 ;; Then check if its a fully specified URL
92 ((string-match url-nonrelative-link env-proxy)
93 (setq urlobj (url-generic-parse-url env-proxy))
94 (url-set-type urlobj "http")
95 (url-set-target urlobj nil))
96 ;; Finally, fall back on the assumption that its just a hostname
97 (t
98 (setq urlobj (url-generic-parse-url nil)) ; Get a blank object
99 (url-set-type urlobj "http")
100 (url-set-host urlobj env-proxy)))
101
102 (if (and (not cur-proxy) urlobj)
103 (progn
104 (setq url-proxy-services
105 (cons (cons scheme (format "%s:%d" (url-host urlobj)
106 (url-port urlobj)))
107 url-proxy-services))
108 (message "Using a proxy for %s..." scheme)))))
109
110(defun url-scheme-get-property (scheme property)
111 "Get property of a URL SCHEME.
112Will automatically try to load a backend from url-SCHEME.el if
113it has not already been loaded."
114 (setq scheme (downcase scheme))
115 (let ((desc (gethash scheme url-scheme-registry)))
116 (if (not desc)
117 (let* ((stub (concat "url-" scheme))
118 (loader (intern stub)))
119 (condition-case ()
120 (require loader)
121 (error nil))
122 (if (fboundp loader)
123 (progn
124 ;; Found the module to handle <scheme> URLs
125 (url-scheme-register-proxy scheme)
126 (setq desc (list 'name scheme
127 'loader loader))
128 (dolist (cell url-scheme-methods)
129 (let ((symbol (intern-soft (format "%s-%s" stub (car cell))))
130 (type (cdr cell)))
131 (if symbol
132 (case type
133 (function
134 ;; Store the symbol name of a function
135 (if (fboundp symbol)
136 (setq desc (plist-put desc (car cell) symbol))))
137 (variable
138 ;; Store the VALUE of a variable
139 (if (boundp symbol)
140 (setq desc (plist-put desc (car cell)
141 (symbol-value symbol)))))
142 (otherwise
143 (error "Malformed url-scheme-methods entry: %S"
144 cell))))))
145 (puthash scheme desc url-scheme-registry)))))
146 (or (plist-get desc property)
147 (plist-get url-scheme-default-properties property))))
148
149(provide 'url-methods)
diff --git a/lisp/url/url-misc.el b/lisp/url/url-misc.el
new file mode 100644
index 00000000000..9a9e58b263a
--- /dev/null
+++ b/lisp/url/url-misc.el
@@ -0,0 +1,119 @@
1;;; url-misc.el --- Misc Uniform Resource Locator retrieval code
2;; Author: $Author: fx $
3;; Created: $Date: 2002/04/22 22:23:59 $
4;; Version: $Revision: 1.5 $
5;; Keywords: comm, data, processes
6
7;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
8;;; Copyright (c) 1993 - 1996 by William M. Perry <wmperry@cs.indiana.edu>
9;;; Copyright (c) 1996, 97, 98, 99, 2002 Free Software Foundation, Inc.
10;;;
11;;; This file is part of GNU Emacs.
12;;;
13;;; GNU Emacs is free software; you can redistribute it and/or modify
14;;; it under the terms of the GNU General Public License as published by
15;;; the Free Software Foundation; either version 2, or (at your option)
16;;; any later version.
17;;;
18;;; GNU Emacs is distributed in the hope that it will be useful,
19;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
20;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
21;;; GNU General Public License for more details.
22;;;
23;;; You should have received a copy of the GNU General Public License
24;;; along with GNU Emacs; see the file COPYING. If not, write to the
25;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
26;;; Boston, MA 02111-1307, USA.
27;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
28
29(require 'url-vars)
30(require 'url-parse)
31(autoload 'Info-goto-node "info" "" t)
32(autoload 'man "man" nil t)
33
34;;;###autoload
35(defun url-man (url)
36 "Fetch a Unix manual page URL."
37 (man (url-filename url))
38 nil)
39
40;;;###autoload
41(defun url-info (url)
42 "Fetch a GNU Info URL."
43 ;; Fetch an info node
44 (let* ((fname (url-filename url))
45 (node (url-unhex-string (or (url-target url) "Top"))))
46 (if (and fname node)
47 (Info-goto-node (concat "(" fname ")" node))
48 (error "Malformed url: %s" (url-recreate-url url)))
49 nil))
50
51(defun url-do-terminal-emulator (type server port user)
52 (terminal-emulator
53 (generate-new-buffer (format "%s%s" (if user (concat user "@") "") server))
54 (case type
55 (rlogin "rlogin")
56 (telnet "telnet")
57 (tn3270 "tn3270")
58 (otherwise
59 (error "Unknown terminal emulator required: %s" type)))
60 (case type
61 (rlogin
62 (if user
63 (list server "-l" user)
64 (list server)))
65 (telnet
66 (if user (message "Please log in as user: %s" user))
67 (if port
68 (list server port)
69 (list server)))
70 (tn3270
71 (if user (message "Please log in as user: %s" user))
72 (list server)))))
73
74;;;###autoload
75(defun url-generic-emulator-loader (url)
76 (let* ((type (intern (downcase (url-type url))))
77 (server (url-host url))
78 (name (url-user url))
79 (port (url-port url)))
80 (url-do-terminal-emulator type server port name))
81 nil)
82
83;;;###autoload
84(defalias 'url-rlogin 'url-generic-emulator-loader)
85;;;###autoload
86(defalias 'url-telnet 'url-generic-emulator-loader)
87;;;###autoload
88(defalias 'url-tn3270 'url-generic-emulator-loader)
89
90;; RFC 2397
91;;;###autoload
92(defun url-data (url)
93 "Fetch a data URL (RFC 2397)."
94 (let ((mediatype nil)
95 ;; The mediatype may need to be hex-encoded too -- see the RFC.
96 (desc (url-unhex-string (url-filename url)))
97 (encoding "8bit")
98 (data nil))
99 (save-excursion
100 (if (not (string-match "\\([^,]*\\)?," desc))
101 (error "Malformed data URL: %s" desc)
102 (setq mediatype (match-string 1 desc))
103 (if (and mediatype (string-match ";base64\\'" mediatype))
104 (setq mediatype (substring mediatype 0 (match-beginning 0))
105 encoding "base64"))
106 (if (or (null mediatype)
107 (eq ?\; (aref mediatype 0)))
108 (setq mediatype (concat "text/plain" mediatype)))
109 (setq data (url-unhex-string (substring desc (match-end 0)))))
110 (set-buffer (generate-new-buffer " *url-data*"))
111 (mm-disable-multibyte)
112 (insert (format "Content-Length: %d\n" (length data))
113 "Content-Type: " mediatype "\n"
114 "Content-Encoding: " encoding "\n"
115 "\n")
116 (if data (insert data))
117 (current-buffer))))
118
119(provide 'url-misc)
diff --git a/lisp/url/url-news.el b/lisp/url/url-news.el
new file mode 100644
index 00000000000..f758b12f689
--- /dev/null
+++ b/lisp/url/url-news.el
@@ -0,0 +1,135 @@
1;;; url-news.el --- News Uniform Resource Locator retrieval code
2;; Author: $Author: fx $
3;; Created: $Date: 2001/05/22 16:13:00 $
4;; Version: $Revision: 1.3 $
5;; Keywords: comm, data, processes
6
7;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
8;;; Copyright (c) 1993 - 1996 by William M. Perry <wmperry@cs.indiana.edu>
9;;; Copyright (c) 1996 - 1999 Free Software Foundation, Inc.
10;;;
11;;; This file is part of GNU Emacs.
12;;;
13;;; GNU Emacs is free software; you can redistribute it and/or modify
14;;; it under the terms of the GNU General Public License as published by
15;;; the Free Software Foundation; either version 2, or (at your option)
16;;; any later version.
17;;;
18;;; GNU Emacs is distributed in the hope that it will be useful,
19;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
20;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
21;;; GNU General Public License for more details.
22;;;
23;;; You should have received a copy of the GNU General Public License
24;;; along with GNU Emacs; see the file COPYING. If not, write to the
25;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
26;;; Boston, MA 02111-1307, USA.
27;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
28(require 'url-vars)
29(require 'url-util)
30(require 'url-parse)
31(require 'nntp)
32(autoload 'url-warn "url")
33(autoload 'gnus-group-read-ephemeral-group "gnus-group")
34(eval-when-compile (require 'cl))
35
36(defgroup url-news nil
37 "News related options"
38 :group 'url)
39
40(defun url-news-open-host (host port user pass)
41 (if (fboundp 'nnheader-init-server-buffer)
42 (nnheader-init-server-buffer))
43 (nntp-open-server host (list (string-to-int port)))
44 (if (and user pass)
45 (progn
46 (nntp-send-command "^.*\r?\n" "AUTHINFO USER" user)
47 (nntp-send-command "^.*\r?\n" "AUTHINFO PASS" pass)
48 (if (not (nntp-server-opened host))
49 (url-warn 'url (format "NNTP authentication to `%s' as `%s' failed"
50 host user))))))
51
52(defun url-news-fetch-message-id (host message-id)
53 (let ((buf (generate-new-buffer " *url-news*")))
54 (if (eq ?> (aref message-id (1- (length message-id))))
55 nil
56 (setq message-id (concat "<" message-id ">")))
57 (if (cdr-safe (nntp-request-article message-id nil host buf))
58 ;; Successfully retrieved the article
59 nil
60 (save-excursion
61 (set-buffer buf)
62 (insert "Content-type: text/html\n\n"
63 "<html>\n"
64 " <head>\n"
65 " <title>Error</title>\n"
66 " </head>\n"
67 " <body>\n"
68 " <div>\n"
69 " <h1>Error requesting article...</h1>\n"
70 " <p>\n"
71 " The status message returned by the NNTP server was:"
72 "<br><hr>\n"
73 " <xmp>\n"
74 (nntp-status-message)
75 " </xmp>\n"
76 " </p>\n"
77 " <p>\n"
78 " If you If you feel this is an error, <a href=\""
79 "mailto:" url-bug-address "\">send me mail</a>\n"
80 " </p>\n"
81 " </div>\n"
82 " </body>\n"
83 "</html>\n"
84 "<!-- Automatically generated by URL v" url-version " -->\n"
85 )))
86 buf))
87
88(defun url-news-fetch-newsgroup (newsgroup host)
89 (declare (special gnus-group-buffer))
90 (if (string-match "^/+" newsgroup)
91 (setq newsgroup (substring newsgroup (match-end 0))))
92 (if (string-match "/+$" newsgroup)
93 (setq newsgroup (substring newsgroup 0 (match-beginning 0))))
94
95 ;; This saves us from checking new news if GNUS is already running
96 ;; FIXME - is it relatively safe to use gnus-alive-p here? FIXME
97 (if (or (not (get-buffer gnus-group-buffer))
98 (save-excursion
99 (set-buffer gnus-group-buffer)
100 (not (eq major-mode 'gnus-group-mode))))
101 (gnus))
102 (set-buffer gnus-group-buffer)
103 (goto-char (point-min))
104 (gnus-group-read-ephemeral-group newsgroup
105 (list 'nntp host
106 'nntp-open-connection-function
107 nntp-open-connection-function)
108 nil
109 (cons (current-buffer) 'browse)))
110
111;;;###autoload
112(defun url-news (url)
113 ;; Find a news reference
114 (let* ((host (or (url-host url) url-news-server))
115 (port (url-port url))
116 (article-brackets nil)
117 (buf nil)
118 (article (url-filename url)))
119 (url-news-open-host host port (url-user url) (url-password url))
120 (setq article (url-unhex-string article))
121 (cond
122 ((string-match "@" article) ; Its a specific article
123 (setq buf (url-news-fetch-message-id host article)))
124 ((string= article "") ; List all newsgroups
125 (gnus))
126 (t ; Whole newsgroup
127 (url-news-fetch-newsgroup article host)))
128 buf))
129
130;;;###autoload
131(defun url-snews (url)
132 (let ((nntp-open-connection-function 'nntp-open-ssl-stream))
133 (url-news url)))
134
135(provide 'url-news)
diff --git a/lisp/url/url-nfs.el b/lisp/url/url-nfs.el
new file mode 100644
index 00000000000..d3e5b4d4128
--- /dev/null
+++ b/lisp/url/url-nfs.el
@@ -0,0 +1,97 @@
1;;; url-nfs.el --- NFS URL interface
2;; Author: $Author: fx $
3;; Created: $Date: 2001/05/22 16:10:50 $
4;; Version: $Revision: 1.3 $
5;; Keywords: comm, data, processes
6
7;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
8;;; Copyright (c) 1996 by William M. Perry <wmperry@cs.indiana.edu>
9;;; Copyright (c) 1996 - 1999 Free Software Foundation, Inc.
10;;;
11;;; This file is part of GNU Emacs.
12;;;
13;;; GNU Emacs is free software; you can redistribute it and/or modify
14;;; it under the terms of the GNU General Public License as published by
15;;; the Free Software Foundation; either version 2, or (at your option)
16;;; any later version.
17;;;
18;;; GNU Emacs is distributed in the hope that it will be useful,
19;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
20;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
21;;; GNU General Public License for more details.
22;;;
23;;; You should have received a copy of the GNU General Public License
24;;; along with GNU Emacs; see the file COPYING. If not, write to the
25;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
26;;; Boston, MA 02111-1307, USA.
27;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
28
29(eval-when-compile (require 'cl))
30(require 'url-parse)
31(require 'url-file)
32
33(defvar url-nfs-automounter-directory-spec
34 "file:/net/%h%f"
35 "*How to invoke the NFS automounter. Certain % sequences are recognized.
36
37%h -- the hostname of the NFS server
38%n -- the port # of the NFS server
39%u -- the username to use to authenticate
40%p -- the password to use to authenticate
41%f -- the filename on the remote server
42%% -- a literal %
43
44Each can be used any number of times.")
45
46(defun url-nfs-unescape (format host port user pass file)
47 (save-excursion
48 (set-buffer (get-buffer-create " *nfs-parse*"))
49 (erase-buffer)
50 (insert format)
51 (goto-char (point-min))
52 (while (re-search-forward "%\\(.\\)" nil t)
53 (let ((escape (aref (match-string 1) 0)))
54 (replace-match "" t t)
55 (case escape
56 (?% (insert "%"))
57 (?h (insert host))
58 (?n (insert (or port "")))
59 (?u (insert (or user "")))
60 (?p (insert (or pass "")))
61 (?f (insert (or file "/"))))))
62 (buffer-string)))
63
64(defun url-nfs-build-filename (url)
65 (let* ((host (url-host url))
66 (port (string-to-int (url-port url)))
67 (pass (url-password url))
68 (user (url-user url))
69 (file (url-filename url)))
70 (url-generic-parse-url
71 (url-nfs-unescape url-nfs-automounter-directory-spec
72 host port user pass file))))
73
74(defun url-nfs (url callback cbargs)
75 (url-file (url-nfs-build-filename url) callback cbargs))
76
77(defmacro url-nfs-create-wrapper (method args)
78 (` (defun (, (intern (format "url-nfs-%s" method))) (, args)
79 (, (format "NFS URL wrapper around `%s' call." method))
80 (setq url (url-nfs-build-filename url))
81 (and url ((, (intern (format "url-file-%s" method)))
82 (,@ (remove '&rest (remove '&optional args))))))))
83
84(url-nfs-create-wrapper file-exists-p (url))
85(url-nfs-create-wrapper file-attributes (url))
86(url-nfs-create-wrapper file-symlink-p (url))
87(url-nfs-create-wrapper file-readable-p (url))
88(url-nfs-create-wrapper file-writable-p (url))
89(url-nfs-create-wrapper file-executable-p (url))
90(if (featurep 'xemacs)
91 (progn
92 (url-nfs-create-wrapper directory-files (url &optional full match nosort files-only))
93 (url-nfs-create-wrapper file-truename (url &optional default)))
94 (url-nfs-create-wrapper directory-files (url &optional full match nosort))
95 (url-nfs-create-wrapper file-truename (url &optional counter prev-dirs)))
96
97(provide 'url-nfs)
diff --git a/lisp/url/url-ns.el b/lisp/url/url-ns.el
new file mode 100644
index 00000000000..0800f70700a
--- /dev/null
+++ b/lisp/url/url-ns.el
@@ -0,0 +1,106 @@
1;;; url-ns.el --- Various netscape-ish functions for proxy definitions
2;; Author: $Author: fx $
3;; Created: $Date: 2000/12/20 21:08:02 $
4;; Version: $Revision: 1.2 $
5;; Keywords: comm, data, processes, hypermedia
6
7;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
8;;; Copyright (c) 1997 - 1999 Free Software Foundation, Inc.
9;;;
10;;; This file is part of GNU Emacs.
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 the
24;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
25;;; Boston, MA 02111-1307, USA.
26;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
27
28(require 'url-gw)
29
30;;;###autoload
31(defun isPlainHostName (host)
32 (not (string-match "\\." host)))
33
34;;;###autoload
35(defun dnsDomainIs (host dom)
36 (string-match (concat (regexp-quote dom) "$") host))
37
38;;;###autoload
39(defun dnsResolve (host)
40 (url-gateway-nslookup-host host))
41
42;;;###autoload
43(defun isResolvable (host)
44 (if (string-match "^[0-9.]+$" host)
45 t
46 (not (string= host (url-gateway-nslookup-host host)))))
47
48;;;###autoload
49(defun isInNet (ip net mask)
50 (let ((netc (split-string ip "\\."))
51 (ipc (split-string net "\\."))
52 (maskc (split-string mask "\\.")))
53 (if (or (/= (length netc) (length ipc))
54 (/= (length ipc) (length maskc)))
55 nil
56 (setq netc (mapcar 'string-to-int netc)
57 ipc (mapcar 'string-to-int ipc)
58 maskc (mapcar 'string-to-int maskc))
59 (and
60 (= (logand (nth 0 netc) (nth 0 maskc))
61 (logand (nth 0 ipc) (nth 0 maskc)))
62 (= (logand (nth 1 netc) (nth 1 maskc))
63 (logand (nth 1 ipc) (nth 1 maskc)))
64 (= (logand (nth 2 netc) (nth 2 maskc))
65 (logand (nth 2 ipc) (nth 2 maskc)))
66 (= (logand (nth 3 netc) (nth 3 maskc))
67 (logand (nth 3 ipc) (nth 3 maskc)))))))
68
69;; Netscape configuration file parsing
70(defvar url-ns-user-prefs nil
71 "Internal, do not use.")
72
73;;;###autoload
74(defun url-ns-prefs (&optional file)
75 (if (not file)
76 (setq file (expand-file-name "~/.netscape/preferences.js")))
77 (if (not (and (file-exists-p file)
78 (file-readable-p file)))
79 (message "Could not open %s for reading" file)
80 (save-excursion
81 (let ((false nil)
82 (true t))
83 (setq url-ns-user-prefs (make-hash-table :size 13 :test 'equal))
84 (set-buffer (get-buffer-create " *ns-parse*"))
85 (erase-buffer)
86 (insert-file-contents file)
87 (goto-char (point-min))
88 (while (re-search-forward "^//" nil t)
89 (replace-match ";;"))
90 (goto-char (point-min))
91 (while (re-search-forward "^user_pref(" nil t)
92 (replace-match "(url-ns-set-user-pref "))
93 (goto-char (point-min))
94 (while (re-search-forward "\"," nil t)
95 (replace-match "\""))
96 (goto-char (point-min))
97 (eval-buffer)))))
98
99(defun url-ns-set-user-pref (key val)
100 (puthash key val url-ns-user-prefs))
101
102;;;###autoload
103(defun url-ns-user-pref (key &optional default)
104 (gethash key url-ns-user-prefs default))
105
106(provide 'url-ns)
diff --git a/lisp/url/url-parse.el b/lisp/url/url-parse.el
new file mode 100644
index 00000000000..4cbc4d6b150
--- /dev/null
+++ b/lisp/url/url-parse.el
@@ -0,0 +1,207 @@
1;;; url-parse.el --- Uniform Resource Locator parser
2;; Author: $Author: fx $
3;; Created: $Date: 2001/10/01 11:52:06 $
4;; Version: $Revision: 1.4 $
5;; Keywords: comm, data, processes
6
7;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
8;;; Copyright (c) 1993 - 1996 by William M. Perry <wmperry@cs.indiana.edu>
9;;; Copyright (c) 1996 - 1999 Free Software Foundation, Inc.
10;;;
11;;; This file is part of GNU Emacs.
12;;;
13;;; GNU Emacs is free software; you can redistribute it and/or modify
14;;; it under the terms of the GNU General Public License as published by
15;;; the Free Software Foundation; either version 2, or (at your option)
16;;; any later version.
17;;;
18;;; GNU Emacs is distributed in the hope that it will be useful,
19;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
20;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
21;;; GNU General Public License for more details.
22;;;
23;;; You should have received a copy of the GNU General Public License
24;;; along with GNU Emacs; see the file COPYING. If not, write to the
25;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
26;;; Boston, MA 02111-1307, USA.
27;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
28(require 'url-auto)
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 (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.
117Format is:
118\[proto username password hostname portnumber file reference attributes fullp\]"
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)
diff --git a/lisp/url/url-privacy.el b/lisp/url/url-privacy.el
new file mode 100644
index 00000000000..dcb244e5a21
--- /dev/null
+++ b/lisp/url/url-privacy.el
@@ -0,0 +1,83 @@
1;;; url-privacy.el --- Global history tracking for URL package
2;; Author: $Author: fx $
3;; Created: $Date: 2001/10/05 17:10:26 $
4;; Version: $Revision: 1.4 $
5;; Keywords: comm, data, processes, hypermedia
6
7;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
8;;; Copyright (c) 1993 - 1996 by William M. Perry <wmperry@cs.indiana.edu>
9;;; Copyright (c) 1996 - 1999 Free Software Foundation, Inc.
10;;;
11;;; This file is part of GNU Emacs.
12;;;
13;;; GNU Emacs is free software; you can redistribute it and/or modify
14;;; it under the terms of the GNU General Public License as published by
15;;; the Free Software Foundation; either version 2, or (at your option)
16;;; any later version.
17;;;
18;;; GNU Emacs is distributed in the hope that it will be useful,
19;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
20;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
21;;; GNU General Public License for more details.
22;;;
23;;; You should have received a copy of the GNU General Public License
24;;; along with GNU Emacs; see the file COPYING. If not, write to the
25;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
26;;; Boston, MA 02111-1307, USA.
27;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
28
29(eval-when-compile (require 'cl))
30(require 'url-vars)
31
32(if (fboundp 'device-type)
33 (defalias 'url-device-type 'device-type)
34 (defun url-device-type (&optional device) (or window-system 'tty)))
35
36;;;###autoload
37(defun url-setup-privacy-info ()
38 (interactive)
39 (setq url-system-type
40 (cond
41 ((or (eq url-privacy-level 'paranoid)
42 (and (listp url-privacy-level)
43 (memq 'os url-privacy-level)))
44 nil)
45 ;; First, we handle the inseparable OS/Windowing system
46 ;; combinations
47 ((eq system-type 'Apple-Macintosh) "Macintosh")
48 ((eq system-type 'next-mach) "NeXT")
49 ((eq system-type 'windows-nt) "Windows-NT; 32bit")
50 ((eq system-type 'ms-windows) "Windows; 16bit")
51 ((eq system-type 'ms-dos) "MS-DOS; 32bit")
52 ((memq (url-device-type) '(win32 w32)) "Windows; 32bit")
53 ((eq (url-device-type) 'pm) "OS/2; 32bit")
54 (t
55 (case (url-device-type)
56 (x "X11")
57 (ns "OpenStep")
58 (tty "TTY")
59 (otherwise nil)))))
60
61 (setq url-personal-mail-address (or url-personal-mail-address
62 user-mail-address
63 (format "%s@%s" (user-real-login-name)
64 (system-name))))
65
66 (if (or (memq url-privacy-level '(paranoid high))
67 (and (listp url-privacy-level)
68 (memq 'email url-privacy-level)))
69 (setq url-personal-mail-address nil))
70
71 (setq url-os-type
72 (cond
73 ((or (eq url-privacy-level 'paranoid)
74 (and (listp url-privacy-level)
75 (memq 'os url-privacy-level)))
76 nil)
77 ((boundp 'system-configuration)
78 system-configuration)
79 ((boundp 'system-type)
80 (symbol-name system-type))
81 (t nil))))
82
83(provide 'url-privacy)
diff --git a/lisp/url/url-proxy.el b/lisp/url/url-proxy.el
new file mode 100644
index 00000000000..b13a0545528
--- /dev/null
+++ b/lisp/url/url-proxy.el
@@ -0,0 +1,78 @@
1;;; url-proxy.el --- Proxy server support
2;; Author: $Author: fx $
3;; Created: $Date: 2001/10/11 21:09:35 $
4;; Version: $Revision: 1.5 $
5;; Keywords: comm, data, processes, hypermedia
6
7;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
8;;; Copyright (c) 1999 Free Software Foundation, Inc.
9;;;
10;;; This file is part of GNU Emacs.
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 the
24;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
25;;; Boston, MA 02111-1307, USA.
26;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
27
28(require 'url-parse)
29(autoload 'url-warn "url")
30
31(defun url-default-find-proxy-for-url (urlobj host)
32 (cond
33 ((or (and (assoc "no_proxy" url-proxy-services)
34 (string-match
35 (cdr
36 (assoc "no_proxy" url-proxy-services))
37 host))
38 (equal "www" (url-type urlobj)))
39 "DIRECT")
40 ((cdr (assoc (url-type urlobj) url-proxy-services))
41 (concat "PROXY " (cdr (assoc (url-type urlobj) url-proxy-services))))
42 ;;
43 ;; Should check for socks
44 ;;
45 (t
46 "DIRECT")))
47
48(defvar url-proxy-locator 'url-default-find-proxy-for-url)
49
50(defun url-find-proxy-for-url (url host)
51 (let ((proxies (split-string (funcall url-proxy-locator url host) " *; *"))
52 (proxy nil)
53 (case-fold-search t))
54 ;; Not sure how I should handle gracefully degrading from one proxy to
55 ;; another, so for now just deal with the first one
56 ;; (while proxies
57 (if (listp proxies)
58 (setq proxy (car proxies))
59 (setq proxy proxies))
60 (cond
61 ((string-match "^direct" proxy) nil)
62 ((string-match "^proxy +" proxy)
63 (concat "http://" (substring proxy (match-end 0)) "/"))
64 ((string-match "^socks +" proxy)
65 (concat "socks://" (substring proxy (match-end 0))))
66 (t
67 (url-warn 'url (format "Unknown proxy directive: %s" proxy) 'critical)
68 nil))))
69
70(defun url-proxy (url callback &optional cbargs)
71 ;; Retrieve URL from a proxy.
72 ;; Expects `url-using-proxy' to be bound to the specific proxy to use."
73 (setq url-using-proxy (url-generic-parse-url url-using-proxy))
74 (let ((proxy-object (copy-sequence url)))
75 (url-set-target proxy-object nil)
76 (url-http url-using-proxy callback cbargs)))
77
78(provide 'url-proxy)
diff --git a/lisp/url/url-util.el b/lisp/url/url-util.el
new file mode 100644
index 00000000000..d81a059ee02
--- /dev/null
+++ b/lisp/url/url-util.el
@@ -0,0 +1,487 @@
1;;; url-util.el --- Miscellaneous helper routines for URL library
2;; Author: Bill Perry <wmperry@gnu.org>
3;; Created: $Date: 2002/04/22 09:16:11 $
4;; Version: $Revision: 1.14 $
5;; Keywords: comm, data, processes
6
7;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
8;;; Copyright (c) 1993 - 1996 by William M. Perry <wmperry@cs.indiana.edu>
9;;; Copyright (c) 1996, 97, 98, 99, 2001 Free Software Foundation, Inc.
10;;;
11;;; This file is part of GNU Emacs.
12;;;
13;;; GNU Emacs is free software; you can redistribute it and/or modify
14;;; it under the terms of the GNU General Public License as published by
15;;; the Free Software Foundation; either version 2, or (at your option)
16;;; any later version.
17;;;
18;;; GNU Emacs is distributed in the hope that it will be useful,
19;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
20;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
21;;; GNU General Public License for more details.
22;;;
23;;; You should have received a copy of the GNU General Public License
24;;; along with GNU Emacs; see the file COPYING. If not, write to the
25;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
26;;; Boston, MA 02111-1307, USA.
27;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
28
29(require 'url-parse)
30(autoload 'timezone-parse-date "timezone")
31(autoload 'timezone-make-date-arpa-standard "timezone")
32
33(defvar url-parse-args-syntax-table
34 (copy-syntax-table emacs-lisp-mode-syntax-table)
35 "A syntax table for parsing sgml attributes.")
36
37(modify-syntax-entry ?' "\"" url-parse-args-syntax-table)
38(modify-syntax-entry ?` "\"" url-parse-args-syntax-table)
39(modify-syntax-entry ?{ "(" url-parse-args-syntax-table)
40(modify-syntax-entry ?} ")" url-parse-args-syntax-table)
41
42;;;###autoload
43(defcustom url-debug nil
44 "*What types of debug messages from the URL library to show.
45Debug messages are logged to the *URL-DEBUG* buffer.
46
47If t, all messages will be logged.
48If a number, all messages will be logged, as well shown via `message'.
49If a list, it is a list of the types of messages to be logged."
50 :type '(choice (const :tag "none" nil)
51 (const :tag "all" t)
52 (checklist :tag "custom"
53 (const :tag "HTTP" :value http)
54 (const :tag "DAV" :value dav)
55 (const :tag "General" :value retrieval)
56 (const :tag "Filename handlers" :value handlers)
57 (symbol :tag "Other")))
58 :group 'url-hairy)
59
60;;;###autoload
61(defun url-debug (tag &rest args)
62 (if quit-flag
63 (error "Interrupted!"))
64 (if (or (eq url-debug t)
65 (numberp url-debug)
66 (and (listp url-debug) (memq tag url-debug)))
67 (save-excursion
68 (set-buffer (get-buffer-create "*URL-DEBUG*"))
69 (goto-char (point-max))
70 (insert (symbol-name tag) " -> " (apply 'format args) "\n")
71 (if (numberp url-debug)
72 (apply 'message args)))))
73
74;;;###autoload
75(defun url-parse-args (str &optional nodowncase)
76 ;; Return an assoc list of attribute/value pairs from an RFC822-type string
77 (let (
78 name ; From name=
79 value ; its value
80 results ; Assoc list of results
81 name-pos ; Start of XXXX= position
82 val-pos ; Start of value position
83 st
84 nd
85 )
86 (save-excursion
87 (save-restriction
88 (set-buffer (get-buffer-create " *urlparse-temp*"))
89 (set-syntax-table url-parse-args-syntax-table)
90 (erase-buffer)
91 (insert str)
92 (setq st (point-min)
93 nd (point-max))
94 (set-syntax-table url-parse-args-syntax-table)
95 (narrow-to-region st nd)
96 (goto-char (point-min))
97 (while (not (eobp))
98 (skip-chars-forward "; \n\t")
99 (setq name-pos (point))
100 (skip-chars-forward "^ \n\t=;")
101 (if (not nodowncase)
102 (downcase-region name-pos (point)))
103 (setq name (buffer-substring name-pos (point)))
104 (skip-chars-forward " \t\n")
105 (if (/= (or (char-after (point)) 0) ?=) ; There is no value
106 (setq value nil)
107 (skip-chars-forward " \t\n=")
108 (setq val-pos (point)
109 value
110 (cond
111 ((or (= (or (char-after val-pos) 0) ?\")
112 (= (or (char-after val-pos) 0) ?'))
113 (buffer-substring (1+ val-pos)
114 (condition-case ()
115 (prog2
116 (forward-sexp 1)
117 (1- (point))
118 (skip-chars-forward "\""))
119 (error
120 (skip-chars-forward "^ \t\n")
121 (point)))))
122 (t
123 (buffer-substring val-pos
124 (progn
125 (skip-chars-forward "^;")
126 (skip-chars-backward " \t")
127 (point)))))))
128 (setq results (cons (cons name value) results))
129 (skip-chars-forward "; \n\t"))
130 results))))
131
132;;;###autoload
133(defun url-insert-entities-in-string (string)
134 "Convert HTML markup-start characters to entity references in STRING.
135Also replaces the \" character, so that the result may be safely used as
136 an attribute value in a tag. Returns a new string with the result of the
137 conversion. Replaces these characters as follows:
138 & ==> &amp;
139 < ==> &lt;
140 > ==> &gt;
141 \" ==> &quot;"
142 (if (string-match "[&<>\"]" string)
143 (save-excursion
144 (set-buffer (get-buffer-create " *entity*"))
145 (erase-buffer)
146 (buffer-disable-undo (current-buffer))
147 (insert string)
148 (goto-char (point-min))
149 (while (progn
150 (skip-chars-forward "^&<>\"")
151 (not (eobp)))
152 (insert (cdr (assq (char-after (point))
153 '((?\" . "&quot;")
154 (?& . "&amp;")
155 (?< . "&lt;")
156 (?> . "&gt;")))))
157 (delete-char 1))
158 (buffer-string))
159 string))
160
161;;;###autoload
162(defun url-normalize-url (url)
163 "Return a 'normalized' version of URL.
164Strips out default port numbers, etc."
165 (let (type data grok retval)
166 (setq data (url-generic-parse-url url)
167 type (url-type data))
168 (if (member type '("www" "about" "mailto" "info"))
169 (setq retval url)
170 (url-set-target data nil)
171 (setq retval (url-recreate-url data)))
172 retval))
173
174;;;###autoload
175(defun url-lazy-message (&rest args)
176 "Just like `message', but is a no-op if called more than once a second.
177Will not do anything if url-show-status is nil."
178 (if (or (null url-show-status)
179 (active-minibuffer-window)
180 (= url-lazy-message-time
181 (setq url-lazy-message-time (nth 1 (current-time)))))
182 nil
183 (apply 'message args)))
184
185;;;###autoload
186(defun url-get-normalized-date (&optional specified-time)
187 "Return a 'real' date string that most HTTP servers can understand."
188 (require 'timezone)
189 (let* ((raw (if specified-time (current-time-string specified-time)
190 (current-time-string)))
191 (gmt (timezone-make-date-arpa-standard raw
192 (nth 1 (current-time-zone))
193 "GMT"))
194 (parsed (timezone-parse-date gmt))
195 (day (cdr-safe (assoc (substring raw 0 3) weekday-alist)))
196 (year nil)
197 (month (car
198 (rassoc
199 (string-to-int (aref parsed 1)) monthabbrev-alist)))
200 )
201 (setq day (or (car-safe (rassoc day weekday-alist))
202 (substring raw 0 3))
203 year (aref parsed 0))
204 ;; This is needed for plexus servers, or the server will hang trying to
205 ;; parse the if-modified-since header. Hopefully, I can take this out
206 ;; soon.
207 (if (and year (> (length year) 2))
208 (setq year (substring year -2 nil)))
209
210 (concat day ", " (aref parsed 2) "-" month "-" year " "
211 (aref parsed 3) " " (or (aref parsed 4)
212 (concat "[" (nth 1 (current-time-zone))
213 "]")))))
214
215;;;###autoload
216(defun url-eat-trailing-space (x)
217 "Remove spaces/tabs at the end of a string."
218 (let ((y (1- (length x)))
219 (skip-chars (list ? ?\t ?\n)))
220 (while (and (>= y 0) (memq (aref x y) skip-chars))
221 (setq y (1- y)))
222 (substring x 0 (1+ y))))
223
224;;;###autoload
225(defun url-strip-leading-spaces (x)
226 "Remove spaces at the front of a string."
227 (let ((y (1- (length x)))
228 (z 0)
229 (skip-chars (list ? ?\t ?\n)))
230 (while (and (<= z y) (memq (aref x z) skip-chars))
231 (setq z (1+ z)))
232 (substring x z nil)))
233
234;;;###autoload
235(defun url-pretty-length (n)
236 (cond
237 ((< n 1024)
238 (format "%d bytes" n))
239 ((< n (* 1024 1024))
240 (format "%dk" (/ n 1024.0)))
241 (t
242 (format "%2.2fM" (/ n (* 1024 1024.0))))))
243
244;;;###autoload
245(defun url-display-percentage (fmt perc &rest args)
246 (if (null fmt)
247 (if (fboundp 'clear-progress-display)
248 (clear-progress-display))
249 (if (and (fboundp 'progress-display) perc)
250 (apply 'progress-display fmt perc args)
251 (apply 'message fmt args))))
252
253;;;###autoload
254(defun url-percentage (x y)
255 (if (fboundp 'float)
256 (round (* 100 (/ x (float y))))
257 (/ (* x 100) y)))
258
259;;;###autoload
260(defun url-basepath (file &optional x)
261 "Return the base pathname of FILE, or the actual filename if X is true."
262 (cond
263 ((null file) "")
264 ((string-match (eval-when-compile (regexp-quote "?")) file)
265 (if x
266 (file-name-nondirectory (substring file 0 (match-beginning 0)))
267 (file-name-directory (substring file 0 (match-beginning 0)))))
268 (x (file-name-nondirectory file))
269 (t (file-name-directory file))))
270
271;;;###autoload
272(defun url-parse-query-string (query &optional downcase)
273 (let (retval pairs cur key val)
274 (setq pairs (split-string query "&"))
275 (while pairs
276 (setq cur (car pairs)
277 pairs (cdr pairs))
278 (if (not (string-match "=" cur))
279 nil ; Grace
280 (setq key (url-unhex-string (substring cur 0 (match-beginning 0)))
281 val (url-unhex-string (substring cur (match-end 0) nil)))
282 (if downcase
283 (setq key (downcase key)))
284 (setq cur (assoc key retval))
285 (if cur
286 (setcdr cur (cons val (cdr cur)))
287 (setq retval (cons (list key val) retval)))))
288 retval))
289
290(defun url-unhex (x)
291 (if (> x ?9)
292 (if (>= x ?a)
293 (+ 10 (- x ?a))
294 (+ 10 (- x ?A)))
295 (- x ?0)))
296
297;;;###autoload
298(defun url-unhex-string (str &optional allow-newlines)
299 "Remove %XXX embedded spaces, etc in a url.
300If optional second argument ALLOW-NEWLINES is non-nil, then allow the
301decoding of carriage returns and line feeds in the string, which is normally
302forbidden in URL encoding."
303 (setq str (or str ""))
304 (let ((tmp "")
305 (case-fold-search t))
306 (while (string-match "%[0-9a-f][0-9a-f]" str)
307 (let* ((start (match-beginning 0))
308 (ch1 (url-unhex (elt str (+ start 1))))
309 (code (+ (* 16 ch1)
310 (url-unhex (elt str (+ start 2))))))
311 (setq tmp (concat
312 tmp (substring str 0 start)
313 (cond
314 (allow-newlines
315 (char-to-string code))
316 ((or (= code ?\n) (= code ?\r))
317 " ")
318 (t (char-to-string code))))
319 str (substring str (match-end 0)))))
320 (setq tmp (concat tmp str))
321 tmp))
322
323(defconst url-unreserved-chars
324 '(
325 ?a ?b ?c ?d ?e ?f ?g ?h ?i ?j ?k ?l ?m ?n ?o ?p ?q ?r ?s ?t ?u ?v ?w ?x ?y ?z
326 ?A ?B ?C ?D ?E ?F ?G ?H ?I ?J ?K ?L ?M ?N ?O ?P ?Q ?R ?S ?T ?U ?V ?W ?X ?Y ?Z
327 ?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9
328 ?- ?_ ?. ?! ?~ ?* ?' ?\( ?\))
329 "A list of characters that are _NOT_ reserved in the URL spec.
330This is taken from RFC 2396.")
331
332;;;###autoload
333(defun url-hexify-string (str)
334 "Escape characters in a string."
335 (mapconcat
336 (lambda (char)
337 ;; Fixme: use a char table instead.
338 (if (not (memq char url-unreserved-chars))
339 (if (< char 16)
340 (format "%%0%X" char)
341 (if (> char 255)
342 (error "Hexifying multibyte character %s" str))
343 (format "%%%X" char))
344 (char-to-string char)))
345 str ""))
346
347;;;###autoload
348(defun url-file-extension (fname &optional x)
349 "Return the filename extension of FNAME.
350If optional variable X is t,
351then return the basename of the file with the extension stripped off."
352 (if (and fname
353 (setq fname (url-basepath fname t))
354 (string-match "\\.[^./]+$" fname))
355 (if x (substring fname 0 (match-beginning 0))
356 (substring fname (match-beginning 0) nil))
357 ;;
358 ;; If fname has no extension, and x then return fname itself instead of
359 ;; nothing. When caching it allows the correct .hdr file to be produced
360 ;; for filenames without extension.
361 ;;
362 (if x
363 fname
364 "")))
365
366;;;###autoload
367(defun url-truncate-url-for-viewing (url &optional width)
368 "Return a shortened version of URL that is WIDTH characters or less wide.
369WIDTH defaults to the current frame width."
370 (let* ((fr-width (or width (frame-width)))
371 (str-width (length url))
372 (tail (file-name-nondirectory url))
373 (fname nil)
374 (modified 0)
375 (urlobj nil))
376 ;; The first thing that can go are the search strings
377 (if (and (>= str-width fr-width)
378 (string-match "?" url))
379 (setq url (concat (substring url 0 (match-beginning 0)) "?...")
380 str-width (length url)
381 tail (file-name-nondirectory url)))
382 (if (< str-width fr-width)
383 nil ; Hey, we are done!
384 (setq urlobj (url-generic-parse-url url)
385 fname (url-filename urlobj)
386 fr-width (- fr-width 4))
387 (while (and (>= str-width fr-width)
388 (string-match "/" fname))
389 (setq fname (substring fname (match-end 0) nil)
390 modified (1+ modified))
391 (url-set-filename urlobj fname)
392 (setq url (url-recreate-url urlobj)
393 str-width (length url)))
394 (if (> modified 1)
395 (setq fname (concat "/.../" fname))
396 (setq fname (concat "/" fname)))
397 (url-set-filename urlobj fname)
398 (setq url (url-recreate-url urlobj)))
399 url))
400
401;;;###autoload
402(defun url-view-url (&optional no-show)
403 "View the current document's URL.
404Optional argument NO-SHOW means just return the URL, don't show it in
405the minibuffer.
406
407This uses `url-current-object', set locally to the buffer."
408 (interactive)
409 (if (not url-current-object)
410 nil
411 (if no-show
412 (url-recreate-url url-current-object)
413 (message "%s" (url-recreate-url url-current-object)))))
414
415(eval-and-compile
416 (defvar url-get-url-filename-chars "-%.?@a-zA-Z0-9()_/:~=&"
417 "Valid characters in a URL")
418 )
419
420(defun url-get-url-at-point (&optional pt)
421 "Get the URL closest to point, but don't change position.
422Has a preference for looking backward when not directly on a symbol."
423 ;; Not at all perfect - point must be right in the name.
424 (save-excursion
425 (if pt (goto-char pt))
426 (let (start url)
427 (save-excursion
428 ;; first see if you're just past a filename
429 (if (not (eobp))
430 (if (looking-at "[] \t\n[{}()]") ; whitespace or some parens
431 (progn
432 (skip-chars-backward " \n\t\r({[]})")
433 (if (not (bobp))
434 (backward-char 1)))))
435 (if (and (char-after (point))
436 (string-match (eval-when-compile
437 (concat "[" url-get-url-filename-chars "]"))
438 (char-to-string (char-after (point)))))
439 (progn
440 (skip-chars-backward url-get-url-filename-chars)
441 (setq start (point))
442 (skip-chars-forward url-get-url-filename-chars))
443 (setq start (point)))
444 (setq url (buffer-substring-no-properties start (point))))
445 (if (and url (string-match "^(.*)\\.?$" url))
446 (setq url (match-string 1 url)))
447 (if (and url (string-match "^URL:" url))
448 (setq url (substring url 4 nil)))
449 (if (and url (string-match "\\.$" url))
450 (setq url (substring url 0 -1)))
451 (if (and url (string-match "^www\\." url))
452 (setq url (concat "http://" url)))
453 (if (and url (not (string-match url-nonrelative-link url)))
454 (setq url nil))
455 url)))
456
457(defun url-generate-unique-filename (&optional fmt)
458 "Generate a unique filename in `url-temporary-directory'."
459 (if (not fmt)
460 (let ((base (format "url-tmp.%d" (user-real-uid)))
461 (fname "")
462 (x 0))
463 (setq fname (format "%s%d" base x))
464 (while (file-exists-p
465 (expand-file-name fname url-temporary-directory))
466 (setq x (1+ x)
467 fname (concat base (int-to-string x))))
468 (expand-file-name fname url-temporary-directory))
469 (let ((base (concat "url" (int-to-string (user-real-uid))))
470 (fname "")
471 (x 0))
472 (setq fname (format fmt (concat base (int-to-string x))))
473 (while (file-exists-p
474 (expand-file-name fname url-temporary-directory))
475 (setq x (1+ x)
476 fname (format fmt (concat base (int-to-string x)))))
477 (expand-file-name fname url-temporary-directory))))
478
479(defun url-extract-mime-headers ()
480 "Set `url-current-mime-headers' in current buffer."
481 (save-excursion
482 (goto-char (point-min))
483 (unless url-current-mime-headers
484 (set (make-local-variable 'url-current-mime-headers)
485 (mail-header-extract)))))
486
487(provide 'url-util)
diff --git a/lisp/url/url-vars.el b/lisp/url/url-vars.el
new file mode 100644
index 00000000000..4e09c441a45
--- /dev/null
+++ b/lisp/url/url-vars.el
@@ -0,0 +1,435 @@
1;;; url-vars.el --- Variables for Uniform Resource Locator tool
2;; Author: $Author: fx $
3;; Created: $Date: 2002/04/22 09:25:02 $
4;; Version: $Revision: 1.14 $
5;; Keywords: comm, data, processes, hypermedia
6
7;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
8;;; Copyright (c) 1993 - 1996 by William M. Perry <wmperry@cs.indiana.edu>
9;;; Copyright (c) 1996, 97, 98, 99, 2001 Free Software Foundation, Inc.
10;;;
11;;; This file is part of GNU Emacs.
12;;;
13;;; GNU Emacs is free software; you can redistribute it and/or modify
14;;; it under the terms of the GNU General Public License as published by
15;;; the Free Software Foundation; either version 2, or (at your option)
16;;; any later version.
17;;;
18;;; GNU Emacs is distributed in the hope that it will be useful,
19;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
20;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
21;;; GNU General Public License for more details.
22;;;
23;;; You should have received a copy of the GNU General Public License
24;;; along with GNU Emacs; see the file COPYING. If not, write to the
25;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
26;;; Boston, MA 02111-1307, USA.
27;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
28
29(require 'mm-util)
30(eval-when-compile (require 'cl))
31
32(defconst url-version (let ((x "$State: Exp $"))
33 (if (string-match "State: \\([^ \t\n]+\\)" x)
34 (substring x (match-beginning 1) (match-end 1))
35 x))
36 "Version number of URL package.")
37
38(defgroup url nil
39 "Uniform Resource Locator tool"
40 :group 'hypermedia)
41
42(defgroup url-file nil
43 "URL storage"
44 :prefix "url-"
45 :group 'url)
46
47(defgroup url-cache nil
48 "URL cache"
49 :prefix "url-"
50 :prefix "url-cache-"
51 :group 'url)
52
53(defgroup url-mime nil
54 "MIME options of URL"
55 :prefix "url-"
56 :group 'url)
57
58(defgroup url-hairy nil
59 "Hairy options of URL"
60 :prefix "url-"
61 :group 'url)
62
63
64(defvar url-current-object nil
65 "A parsed representation of the current url.")
66
67(defvar url-current-mime-headers nil
68 "A parsed representation of the MIME headers for the current url.")
69
70(mapcar 'make-variable-buffer-local
71 '(
72 url-current-object
73 url-current-referer
74 url-current-mime-headers
75 ))
76
77(defcustom url-honor-refresh-requests t
78 "*Whether to do automatic page reloads.
79These are done at the request of the document author or the server via
80the `Refresh' header in an HTTP response. If nil, no refresh
81requests will be honored. If t, all refresh requests will be honored.
82If non-nil and not t, the user will be asked for each refresh
83request."
84 :type '(choice (const :tag "off" nil)
85 (const :tag "on" t)
86 (const :tag "ask" 'ask))
87 :group 'url-hairy)
88
89(defcustom url-automatic-caching nil
90 "*If non-nil, all documents will be automatically cached to the local disk."
91 :type 'boolean
92 :group 'url-cache)
93
94;; Fixme: sanitize this.
95(defcustom url-cache-expired
96 (lambda (t1 t2) (>= (- (car t2) (car t1)) 5))
97 "*A function determining if a cached item has expired.
98It takes two times (numbers) as its arguments, and returns non-nil if
99the second time is 'too old' when compared to the first time."
100 :type 'function
101 :group 'url-cache)
102
103(defvar url-bug-address "w3-bugs@xemacs.org"
104 "Where to send bug reports.")
105
106(defcustom url-personal-mail-address nil
107 "*Your full email address.
108This is what is sent to HTTP servers as the FROM field in an HTTP
109request."
110 :type '(choice (const :tag "Unspecified" nil) string)
111 :group 'url)
112
113(defcustom url-directory-index-file "index.html"
114 "*The filename to look for when indexing a directory.
115If this file exists, and is readable, then it will be viewed instead of
116using `dired' to view the directory."
117 :type 'string
118 :group 'url-file)
119
120;; Fixme: this should have a setter which calls url-setup-privacy-info.
121(defcustom url-privacy-level '(email)
122 "*How private you want your requests to be.
123HTTP has header fields for various information about the user, including
124operating system information, email addresses, the last page you visited, etc.
125This variable controls how much of this information is sent.
126
127This should a symbol or a list.
128Valid values if a symbol are:
129none -- Send all information
130low -- Don't send the last location
131high -- Don't send the email address or last location
132paranoid -- Don't send anything
133
134If a list, this should be a list of symbols of what NOT to send.
135Valid symbols are:
136email -- the email address
137os -- the operating system info
138lastloc -- the last location
139agent -- Do not send the User-Agent string
140cookie -- never accept HTTP cookies
141
142Samples:
143
144 (setq url-privacy-level 'high)
145 (setq url-privacy-level '(email lastloc)) ;; equivalent to 'high
146 (setq url-privacy-level '(os))
147
148::NOTE::
149This variable controls several other variables and is _NOT_ automatically
150updated. Call the function `url-setup-privacy-info' after modifying this
151variable."
152 :type '(radio (const :tag "None (you believe in the basic goodness of humanity)"
153 :value none)
154 (const :tag "Low (do not reveal last location)"
155 :value low)
156 (const :tag "High (no email address or last location)"
157 :value high)
158 (const :tag "Paranoid (reveal nothing!)"
159 :value paranoid)
160 (checklist :tag "Custom"
161 (const :tag "Email address" :value email)
162 (const :tag "Operating system" :value os)
163 (const :tag "Last location" :value lastloc)
164 (const :tag "Browser identification" :value agent)
165 (const :tag "No cookies" :value cookie)))
166 :group 'url)
167
168(defvar url-inhibit-uncompression nil "Do not do decompression if non-nil.")
169
170(defcustom url-uncompressor-alist '((".z" . "x-gzip")
171 (".gz" . "x-gzip")
172 (".uue" . "x-uuencoded")
173 (".hqx" . "x-hqx")
174 (".Z" . "x-compress")
175 (".bz2" . "x-bzip2"))
176 "*An alist of file extensions and appropriate content-transfer-encodings."
177 :type '(repeat (cons :format "%v"
178 (string :tag "Extension")
179 (string :tag "Encoding")))
180 :group 'url-mime)
181
182(defcustom url-mail-command (if (fboundp 'compose-mail)
183 'compose-mail
184 'url-mail)
185 "*This function will be called whenever url needs to send mail.
186It should enter a mail-mode-like buffer in the current window.
187The commands `mail-to' and `mail-subject' should still work in this
188buffer, and it should use `mail-header-separator' if possible."
189 :type 'function
190 :group 'url)
191
192(defcustom url-proxy-services nil
193 "*An alist of schemes and proxy servers that gateway them.
194Looks like ((\"http\" . \"hostname:portnumber\") ...). This is set up
195from the ACCESS_proxy environment variables."
196 :type '(repeat (cons :format "%v"
197 (string :tag "Protocol")
198 (string :tag "Proxy")))
199 :group 'url)
200
201(defcustom url-passwd-entry-func nil
202 "*Symbol indicating which function to call to read in a password.
203It will be set up depending on whether you are running EFS or ange-ftp
204at startup if it is nil. This function should accept the prompt
205string as its first argument, and the default value as its second
206argument."
207 :type '(choice (const :tag "Guess" :value nil)
208 (const :tag "Use Ange-FTP" :value ange-ftp-read-passwd)
209 (const :tag "Use EFS" :value efs-read-passwd)
210 (const :tag "Use Password Package" :value read-passwd)
211 (function :tag "Other"))
212 :group 'url-hairy)
213
214(defcustom url-standalone-mode nil
215 "*Rely solely on the cache?"
216 :type 'boolean
217 :group 'url-cache)
218
219(defvar url-mime-separator-chars (mapcar 'identity
220 (concat "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
221 "abcdefghijklmnopqrstuvwxyz"
222 "0123456789'()+_,-./=?"))
223 "Characters allowable in a MIME multipart separator.")
224
225(defcustom url-bad-port-list
226 '("25" "119" "19")
227 "*List of ports to warn the user about connecting to.
228Defaults to just the mail, chargen, and NNTP ports so you cannot be
229tricked into sending fake mail or forging messages by a malicious HTML
230document."
231 :type '(repeat (string :tag "Port"))
232 :group 'url-hairy)
233
234(defvar url-mime-content-type-charset-regexp
235 ";[ \t]*charset=\"?\\([^\"]+\\)\"?"
236 "Regexp used in parsing `Content-Type' for a charset indication.")
237
238(defvar url-request-data nil "Any data to send with the next request.")
239
240(defvar url-request-extra-headers nil
241 "A list of extra headers to send with the next request.
242Should be an assoc list of headers/contents.")
243
244(defvar url-request-method nil "The method to use for the next request.")
245
246;; FIXME!! (RFC 2616 gives examples like `compress, gzip'.)
247(defvar url-mime-encoding-string nil
248 "*String to send in the Accept-encoding: field in HTTP requests.")
249
250;; `mm-mime-mule-charset-alist' in Gnus 5.8/9 contains elements whose
251;; cars aren't valid MIME charsets/coding systems, at least in Emacs.
252;; This gets it correct by construction in Emacs. Fixme: DTRT for
253;; XEmacs -- its `coding-system-list' doesn't have the BASE-ONLY arg.
254(when (and (not (featurep 'xemacs))
255 (fboundp 'coding-system-list))
256 (setq mm-mime-mule-charset-alist
257 (apply
258 'nconc
259 (mapcar
260 (lambda (cs)
261 (when (and (coding-system-get cs 'mime-charset)
262 (not (eq t (coding-system-get cs 'safe-charsets))))
263 (list (cons (coding-system-get cs 'mime-charset)
264 (delq 'ascii
265 (coding-system-get cs 'safe-charsets))))))
266 (coding-system-list 'base-only)))))
267
268;; Perhaps the first few should actually be given decreasing `q's and
269;; the list should be trimmed significantly.
270;; Fixme: do something sane if we don't have `sort-coding-systems'
271;; (Emacs 20, XEmacs).
272(defun url-mime-charset-string ()
273 "Generate a list of preferred MIME charsets for HTTP requests.
274Generated according to current coding system priorities."
275 (if (fboundp 'sort-coding-systems)
276 (let ((ordered (sort-coding-systems
277 (let (accum)
278 (dolist (elt mm-mime-mule-charset-alist)
279 (if (mm-coding-system-p (car elt))
280 (push (car elt) accum)))
281 (nreverse accum)))))
282 (concat (format "%s;q=1, " (pop ordered))
283 (mapconcat 'symbol-name ordered ";q=0.5, ")
284 ";q=0.5"))))
285
286(defvar url-mime-charset-string (url-mime-charset-string)
287 "*String to send in the Accept-charset: field in HTTP requests.
288The MIME charset corresponding to the most preferred coding system is
289given priority 1 and the rest are given priority 0.5.")
290
291(defun url-set-mime-charset-string ()
292 (setq url-mime-charset-string (url-mime-charset-string)))
293;; Regenerate if the language environment changes.
294(add-hook 'set-language-environment-hook 'url-set-mime-charset-string)
295
296;; Fixme: set from the locale.
297(defcustom url-mime-language-string nil
298 "*String to send in the Accept-language: field in HTTP requests.
299
300Specifies the preferred language when servers can serve documents in
301several languages. Use RFC 1766 abbreviations, e.g.@: `en' for
302English, `de' for German. A comma-separated specifies descending
303order of preference. The ordering can be made explicit using `q'
304factors defined by HTTP, e.g. `de,en-gb;q=0.8,en;q=0.7'. `*' means
305get the first available language (as opposed to the default)."
306 :type '(radio
307 (const :tag "None (get default language version)" :value nil)
308 (const :tag "Any (get first available language version)" :value "*")
309 (string :tag "Other"))
310 :group 'url-mime
311 :group 'i18n)
312
313(defvar url-mime-accept-string nil
314 "String to send to the server in the Accept: field in HTTP requests.")
315
316(defvar url-package-version nil
317 "Version number of package using URL.")
318
319(defvar url-package-name nil "Version number of package using URL.")
320
321(defvar url-system-type nil
322 "What type of system we are on.")
323(defvar url-os-type nil
324 "What OS we are on.")
325
326(defcustom url-max-password-attempts 5
327 "*Maximum number of times a password will be prompted for.
328Applies when a protected document is denied by the server."
329 :type 'integer
330 :group 'url)
331
332(defcustom url-temporary-directory (or (getenv "TMPDIR") "/tmp")
333 "*Where temporary files go."
334 :type 'directory
335 :group 'url-file)
336
337(defcustom url-show-status t
338 "*Whether to show a running total of bytes transferred.
339Can cause a large hit if using a remote X display over a slow link, or
340a terminal with a slow modem."
341 :type 'boolean
342 :group 'url)
343
344(defvar url-using-proxy nil
345 "Either nil or the fully qualified proxy URL in use, e.g.
346http://www.domain.com/")
347
348(defcustom url-news-server nil
349 "*The default news server from which to get newsgroups/articles.
350Applies if no server is specified in the URL. Defaults to the
351environment variable NNTPSERVER or \"news\" if NNTPSERVER is
352undefined."
353 :type '(choice (const :tag "None" :value nil) string)
354 :group 'url)
355
356(defvar url-nonrelative-link
357 "\\`\\([-a-zA-Z0-9+.]+:\\)"
358 "A regular expression that will match an absolute URL.")
359
360(defcustom url-confirmation-func 'y-or-n-p
361 "*What function to use for asking yes or no functions.
362Possible values are `yes-or-no-p' or `y-or-n-p', or any function that
363takes a single argument (the prompt), and returns t only if a positive
364answer is given."
365 :type '(choice (const :tag "Short (y or n)" :value y-or-n-p)
366 (const :tag "Long (yes or no)" :value yes-or-no-p)
367 (function :tag "Other"))
368 :group 'url-hairy)
369
370(defcustom url-gateway-method 'native
371 "*The type of gateway support to use.
372Should be a symbol specifying how to get a connection from the local machine.
373
374Currently supported methods:
375`telnet': Run telnet in a subprocess to connect;
376`rlogin': Rlogin to another machine to connect;
377`socks': Connect through a socks server;
378`ssl': Connect with SSL;
379`native': Connect directy."
380 :type '(radio (const :tag "Telnet to gateway host" :value telnet)
381 (const :tag "Rlogin to gateway host" :value rlogin)
382 (const :tag "Use SOCKS proxy" :value socks)
383 (const :tag "Use SSL for all connections" :value ssl)
384 (const :tag "Direct connection" :value native))
385 :group 'url-hairy)
386
387(defvar url-setup-done nil "Has setup configuration been done?")
388
389(defconst weekday-alist
390 '(("Sunday" . 0) ("Monday" . 1) ("Tuesday" . 2) ("Wednesday" . 3)
391 ("Thursday" . 4) ("Friday" . 5) ("Saturday" . 6)
392 ("Tues" . 2) ("Thurs" . 4)
393 ("Sun" . 0) ("Mon" . 1) ("Tue" . 2) ("Wed" . 3)
394 ("Thu" . 4) ("Fri" . 5) ("Sat" . 6)))
395
396(defconst monthabbrev-alist
397 '(("Jan" . 1) ("Feb" . 2) ("Mar" . 3) ("Apr" . 4) ("May" . 5) ("Jun" . 6)
398 ("Jul" . 7) ("Aug" . 8) ("Sep" . 9) ("Oct" . 10) ("Nov" . 11)
399 ("Dec" . 12)))
400
401(defvar url-lazy-message-time 0)
402
403;; Fixme: We may not be able to run SSL.
404(defvar url-extensions-header "Security/Digest Security/SSL")
405
406(defvar url-parse-syntax-table
407 (copy-syntax-table emacs-lisp-mode-syntax-table)
408 "*A syntax table for parsing URLs.")
409
410(modify-syntax-entry ?' "\"" url-parse-syntax-table)
411(modify-syntax-entry ?` "\"" url-parse-syntax-table)
412(modify-syntax-entry ?< "(>" url-parse-syntax-table)
413(modify-syntax-entry ?> ")<" url-parse-syntax-table)
414(modify-syntax-entry ?/ " " url-parse-syntax-table)
415
416(defvar url-load-hook nil
417 "*Hooks to be run after initalizing the URL library.")
418
419;;; Make OS/2 happy - yeeks
420;; (defvar tcp-binary-process-input-services nil
421;; "*Make OS/2 happy with our CRLF pairs...")
422
423(defconst url-working-buffer " *url-work")
424
425(defvar url-gateway-unplugged nil
426 "Non-nil means don't open new network connexions.
427This should be set, e.g. by mail user agents rendering HTML to avoid
428`bugs' which call home.")
429
430(defun url-vars-unload-hook ()
431 (remove-hook 'set-language-environment-hook 'url-set-mime-charset-string))
432
433(provide 'url-vars)
434
435;;; url-vars.el ends here
diff --git a/lisp/url/url.el b/lisp/url/url.el
new file mode 100644
index 00000000000..22d5aa59997
--- /dev/null
+++ b/lisp/url/url.el
@@ -0,0 +1,269 @@
1;;; url.el --- Uniform Resource Locator retrieval tool
2;; Author: Bill Perry <wmperry@gnu.org>
3;; Version: $Revision: 1.15 $
4;; Keywords: comm, data, processes, hypermedia
5
6;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
7;;; Copyright (c) 1993 - 1996 by William M. Perry <wmperry@cs.indiana.edu>
8;;; Copyright (c) 1996, 97, 98, 99, 2001 Free Software Foundation, Inc.
9;;;
10;;; This file is part of GNU Emacs.
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 the
24;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
25;;; Boston, MA 02111-1307, USA.
26;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
27
28;; Registered URI schemes: http://www.iana.org/assignments/uri-schemes
29
30(eval-when-compile (require 'cl))
31;; Don't require CL at runtime if we can avoid it (Emacs 21).
32;; Otherwise we need it for hashing functions. `puthash' was never
33;; defined in the Emacs 20 cl.el for some reason.
34(if (fboundp 'puthash)
35 nil ; internal or CL is loaded
36 (defalias 'puthash 'cl-puthash)
37 (autoload 'cl-puthash "cl")
38 (autoload 'gethash "cl")
39 (autoload 'maphash "cl")
40 (autoload 'make-hash-table "cl"))
41
42(eval-when-compile
43 (require 'mm-decode)
44 (require 'mm-view))
45
46(require 'mailcap)
47(require 'url-vars)
48(require 'url-cookie)
49(require 'url-history)
50(require 'url-expand)
51(require 'url-privacy)
52(require 'url-methods)
53(require 'url-proxy)
54(require 'url-parse)
55(require 'url-util)
56
57;; Fixme: customize? convert-standard-filename?
58;;;###autoload
59(defvar url-configuration-directory "~/.url")
60
61(defun url-do-setup ()
62 "Setup the url package.
63This is to avoid conflict with user settings if URL is dumped with
64Emacs."
65 (unless url-setup-done
66
67 ;; Make OS/2 happy
68 ;;(push '("http" "80") tcp-binary-process-input-services)
69
70 (mailcap-parse-mailcaps)
71 (mailcap-parse-mimetypes)
72
73 ;; Register all the authentication schemes we can handle
74 (url-register-auth-scheme "basic" nil 4)
75 (url-register-auth-scheme "digest" nil 7)
76
77 (setq url-cookie-file
78 (or url-cookie-file
79 (expand-file-name "cookies" url-configuration-directory)))
80
81 (setq url-history-file
82 (or url-history-file
83 (expand-file-name "history" url-configuration-directory)))
84
85 ;; Parse the global history file if it exists, so that it can be used
86 ;; for URL completion, etc.
87 (url-history-parse-history)
88 (url-history-setup-save-timer)
89
90 ;; Ditto for cookies
91 (url-cookie-setup-save-timer)
92 (url-cookie-parse-file url-cookie-file)
93
94 ;; Read in proxy gateways
95 (let ((noproxy (and (not (assoc "no_proxy" url-proxy-services))
96 (or (getenv "NO_PROXY")
97 (getenv "no_PROXY")
98 (getenv "no_proxy")))))
99 (if noproxy
100 (setq url-proxy-services
101 (cons (cons "no_proxy"
102 (concat "\\("
103 (mapconcat
104 (lambda (x)
105 (cond
106 ((= x ?,) "\\|")
107 ((= x ? ) "")
108 ((= x ?.) (regexp-quote "."))
109 ((= x ?*) ".*")
110 ((= x ??) ".")
111 (t (char-to-string x))))
112 noproxy "") "\\)"))
113 url-proxy-services))))
114
115 ;; Set the password entry funtion based on user defaults or guess
116 ;; based on which remote-file-access package they are using.
117 (cond
118 (url-passwd-entry-func nil) ; Already been set
119 ((fboundp 'read-passwd) ; Use secure password if available
120 (setq url-passwd-entry-func 'read-passwd))
121 ((or (featurep 'efs) ; Using EFS
122 (featurep 'efs-auto)) ; or autoloading efs
123 (if (not (fboundp 'read-passwd))
124 (autoload 'read-passwd "passwd" "Read in a password" nil))
125 (setq url-passwd-entry-func 'read-passwd))
126 ((or (featurep 'ange-ftp) ; Using ange-ftp
127 (and (boundp 'file-name-handler-alist)
128 (not (featurep 'xemacs)))) ; ??
129 (setq url-passwd-entry-func 'ange-ftp-read-passwd))
130 (t
131 (url-warn
132 'security
133 "(url-setup): Can't determine how to read passwords, winging it.")))
134
135 (url-setup-privacy-info)
136 (run-hooks 'url-load-hook)
137 (setq url-setup-done t)))
138
139;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
140;;; Retrieval functions
141;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
142(defun url-retrieve (url callback &optional cbargs)
143 "Retrieve URL asynchronously and call CALLBACK with CBARGS when finished.
144The callback is called when the object has been completely retrieved, with
145the current buffer containing the object, and any MIME headers associated
146with it. URL is either a string or a parsed URL.
147
148Return the buffer URL will load into, or nil if the process has
149already completed."
150 (url-do-setup)
151 (url-gc-dead-buffers)
152 (if (stringp url)
153 (set-text-properties 0 (length url) nil url))
154 (if (not (vectorp url))
155 (setq url (url-generic-parse-url url)))
156 (if (not (functionp callback))
157 (error "Must provide a callback function to url-retrieve"))
158 (unless (url-type url)
159 (error "Bad url: %s" (url-recreate-url url)))
160 (let ((loader (url-scheme-get-property (url-type url) 'loader))
161 (url-using-proxy (if (url-host url)
162 (url-find-proxy-for-url url (url-host url))))
163 (buffer nil)
164 (asynch (url-scheme-get-property (url-type url) 'asynchronous-p)))
165 (if url-using-proxy
166 (setq asynch t
167 loader 'url-proxy))
168 (if asynch
169 (setq buffer (funcall loader url callback cbargs))
170 (setq buffer (funcall loader url))
171 (if buffer
172 (save-excursion
173 (set-buffer buffer)
174 (apply callback cbargs))))
175 (url-history-update-url url (current-time))
176 buffer))
177
178(defun url-retrieve-synchronously (url)
179 "Retrieve URL synchronously.
180Return the buffer containing the data, or nil if there are no data
181associated with it (the case for dired, info, or mailto URLs that need
182no further processing). URL is either a string or a parsed URL."
183 (url-do-setup)
184
185 (lexical-let ((retrieval-done nil)
186 (asynch-buffer nil))
187 (setq asynch-buffer
188 (url-retrieve url (lambda (&rest ignored)
189 (url-debug 'retrieval "Synchronous fetching done (%S)" (current-buffer))
190 (setq retrieval-done t
191 asynch-buffer (current-buffer)))))
192 (if (not asynch-buffer)
193 ;; We do not need to do anything, it was a mailto or something
194 ;; similar that takes processing completely outside of the URL
195 ;; package.
196 nil
197 (while (not retrieval-done)
198 (url-debug 'retrieval "Spinning in url-retrieve-synchronously: %S (%S)"
199 retrieval-done asynch-buffer)
200 ;; Quoth monnier:
201 ;; It turns out that the problem seems to be that the (sit-for
202 ;; 0.1) below doesn't actually process the data: instead it
203 ;; returns immediately because there is keyboard input
204 ;; waiting, so we end up spinning endlessly waiting for the
205 ;; process to finish while not letting it finish.
206
207 ;; However, raman claims that it blocks Emacs with Emacspeak
208 ;; for unexplained reasons. Put back for his benefit until
209 ;; someone can understand it.
210 ;; (sleep-for 0.1)
211 (sit-for 0.1))
212 asynch-buffer)))
213
214(defun url-mm-callback (&rest ignored)
215 (let ((handle (mm-dissect-buffer t)))
216 (save-excursion
217 (url-mark-buffer-as-dead (current-buffer))
218 (set-buffer (generate-new-buffer (url-recreate-url url-current-object)))
219 (if (eq (mm-display-part handle) 'external)
220 (progn
221 (set-process-sentinel
222 ;; Fixme: this shouldn't have to know the form of the
223 ;; undisplayer produced by `mm-display-part'.
224 (get-buffer-process (cdr (mm-handle-undisplayer handle)))
225 `(lambda (proc event)
226 (mm-destroy-parts (quote ,handle))))
227 (message "Viewing externally")
228 (kill-buffer (current-buffer)))
229 (display-buffer (current-buffer))
230 (mm-destroy-parts handle)))))
231
232(defun url-mm-url (url)
233 "Retrieve URL and pass to the appropriate viewing application."
234 (require 'mm-decode)
235 (require 'mm-view)
236 (url-retrieve url 'url-mm-callback nil))
237
238;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
239;;; Miscellaneous
240;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
241(defvar url-dead-buffer-list nil)
242
243(defun url-mark-buffer-as-dead (buff)
244 (push buff url-dead-buffer-list))
245
246(defun url-gc-dead-buffers ()
247 (let ((buff))
248 (while (setq buff (pop url-dead-buffer-list))
249 (if (buffer-live-p buff)
250 (kill-buffer buff)))))
251
252(cond
253 ((fboundp 'display-warning)
254 (defalias 'url-warn 'display-warning))
255 ((fboundp 'warn)
256 (defun url-warn (class message &optional level)
257 (warn "(%s/%s) %s" class (or level 'warning) message)))
258 (t
259 (defun url-warn (class message &optional level)
260 (save-excursion
261 (set-buffer (get-buffer-create "*URL-WARNINGS*"))
262 (goto-char (point-max))
263 (save-excursion
264 (insert (format "(%s/%s) %s\n" class (or level 'warning) message)))
265 (display-buffer (current-buffer))))))
266
267(provide 'url)
268
269;;; url.el ends here
diff --git a/lisp/url/vc-dav.el b/lisp/url/vc-dav.el
new file mode 100644
index 00000000000..dc03361dcc8
--- /dev/null
+++ b/lisp/url/vc-dav.el
@@ -0,0 +1,177 @@
1;;; vc-dav.el --- vc.el support for WebDAV
2
3;; Copyright (C) 2001 Free Software Foundation, Inc.
4
5;; Author: Bill Perry <wmperry@gnu.org>
6;; Maintainer: Bill Perry <wmperry@gnu.org>
7;; Version: $Revision: 1.3 $
8;; Keywords: url, vc
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., 59 Temple Place - Suite 330,
23;; Boston, MA 02111-1307, USA.
24
25(require 'url)
26(require 'url-dav)
27
28;;; Required functions for a vc backend
29(defun vc-dav-registered (url)
30 "Return t iff URL is registered with a DAV aware server."
31 (url-dav-vc-registered url))
32
33(defun vc-dav-state (url)
34 "Return the current version control state of URL.
35For a list of possible values, see `vc-state'."
36 ;; Things we can support for WebDAV
37 ;;
38 ;; up-to-date - use lockdiscovery
39 ;; edited - check for an active lock by us
40 ;; USER - use lockdiscovery + owner
41 ;;
42 ;; These don't make sense for WebDAV
43 ;; needs-patch
44 ;; needs-merge
45 ;; unlocked-changes
46 (let ((locks (url-dav-active-locks url)))
47 (cond
48 ((null locks) 'up-to-date)
49 ((assoc url locks)
50 ;; SOMEBODY has a lock... let's find out who.
51 (setq locks (cdr (assoc url locks)))
52 (if (rassoc url-dav-lock-identifier locks)
53 ;; _WE_ have a lock
54 'edited
55 (cdr (car locks)))))))
56
57(defun vc-dav-checkout-model (url)
58 "Indicate whether URL needs to be \"checked out\" before it can be edited.
59See `vc-checkout-model' for a list of possible values."
60 ;; The only thing we can support with webdav is 'locking
61 'locking)
62
63;; This should figure out the version # of the file somehow. What is
64;; the most appropriate property in WebDAV to look at for this?
65(defun vc-dav-workfile-version (url)
66 "Return the current workfile version of URL."
67 "Unknown")
68
69(defun vc-dav-register (url &optional rev comment)
70 "Register URL in the DAV backend."
71 ;; Do we need to do anything here? FIXME?
72 )
73
74(defun vc-dav-checkin (url rev comment)
75 "Commit changes in URL to WebDAV.
76If REV is non-nil, that should become the new revision number.
77COMMENT is used as a check-in comment."
78 ;; This should PUT the resource and release any locks that we hold.
79 )
80
81(defun vc-dav-checkout (url &optional editable rev destfile)
82 "Check out revision REV of URL into the working area.
83
84If EDITABLE is non-nil URL should be writable by the user and if
85locking is used for URL, a lock should also be set.
86
87If REV is non-nil, that is the revision to check out. If REV is the
88empty string, that means to check ou tht ehead of the trunk.
89
90If optional arg DESTFILE is given, it is an alternate filename to
91write the contents to.
92"
93 ;; This should LOCK the resource.
94 )
95
96(defun vc-dav-revert (url &optional contents-done)
97 "Revert URL back to the current workfile version.
98
99If optional arg CONTENTS-DONE is non-nil, then the contents of FILE
100have already been reverted from a version backup, and this function
101only needs to update the status of URL within the backend.
102"
103 ;; Should do a GET if !contents_done
104 ;; Should UNLOCK the file.
105 )
106
107(defun vc-dav-print-log (url)
108 "Insert the revision log of URL into the *vc* buffer."
109 )
110
111(defun vc-dav-diff (url &optional rev1 rev2)
112 "Insert the diff for URL into the *vc-diff* buffer.
113If REV1 and REV2 are non-nil report differences from REV1 to REV2.
114If REV1 is nil, use the current workfile version as the older version.
115If REV2 is nil, use the current workfile contents as the nwer version.
116
117It should return a status of either 0 (no differences found), or
1181 (either non-empty diff or the diff is run asynchronously).
119"
120 ;; We should do this asynchronously...
121 ;; How would we do it at all, that is the question!
122 )
123
124
125
126;;; Optional functions
127;; Should be faster than vc-dav-state - but how?
128(defun vc-dav-state-heuristic (url)
129 "Estimate the version control state of URL at visiting time."
130 (vc-dav-state url))
131
132;; This should use url-dav-get-properties with a depth of `1' to get
133;; all the properties.
134(defun vc-dav-dir-state (url)
135 "find the version control state of all files in DIR in a fast way."
136 )
137
138(defun vc-dav-workfile-unchanged-p (url)
139 "Return non-nil if URL is unchanged from its current workfile version."
140 ;; Probably impossible with webdav
141 )
142
143(defun vc-dav-responsible-p (url)
144 "Return non-nil if DAV considers itself `responsible' for URL."
145 ;; Check for DAV support on the web server.
146 t)
147
148(defun vc-dav-could-register (url)
149 "Return non-nil if URL could be registered under this backend."
150 ;; Check for DAV support on the web server.
151 t)
152
153;;; Unimplemented functions
154;;
155;; vc-dav-latest-on-branch-p(URL)
156;; Return non-nil if the current workfile version of FILE is the
157;; latest on its branch. There are no branches in webdav yet.
158;;
159;; vc-dav-mode-line-string(url)
160;; Return a dav-specific mode line string for URL. Are there any
161;; specific states that we want exposed?
162;;
163;; vc-dav-dired-state-info(url)
164;; Translate the `vc-state' property of URL into a string that can
165;; be used in a vc-dired buffer. Are there any extra states that
166;; we want exposed?
167;;
168;; vc-dav-receive-file(url rev)
169;; Let this backend `receive' a file that is already registered
170;; under another backend. The default just calls `register', which
171;; should be sufficient for WebDAV.
172;;
173;; vc-dav-unregister(url)
174;; Unregister URL. Not possible with WebDAV, other than by
175;; deleting the resource.
176
177(provide 'vc-dav)
generated by cgit v1.2.1 (git 2.18.0) at 2026-01-30 16:49:16 +0000