aboutsummaryrefslogtreecommitdiffstats
path: root/lisp/url
diff options
context:
space:
mode:
authorMiles Bader2004-06-28 07:56:49 +0000
committerMiles Bader2004-06-28 07:56:49 +0000
commit327719ee8a3fcdb36ed6acaf6d8cb5fbdf0bd801 (patch)
tree21de188e13b5e41a79bb50040933072ae0235217 /lisp/url
parent852f73b7fa7b71910282eacb6263b3ecfd4ee783 (diff)
parent376de73927383d6062483db10b8a82448505f52b (diff)
downloademacs-327719ee8a3fcdb36ed6acaf6d8cb5fbdf0bd801.tar.gz
emacs-327719ee8a3fcdb36ed6acaf6d8cb5fbdf0bd801.zip
Revision: miles@gnu.org--gnu-2004/emacs--unicode--0--patch-15
Merge from emacs--cvs-trunk--0 Patches applied: * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-218 - miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-220 Update from CVS * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-221 Restore deleted tagline in etc/TUTORIAL.ru * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-222 - miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-228 Update from CVS * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-229 Remove TeX output files from the archive * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-230 - miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-247 Update from CVS * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-248 src/lisp.h (CYCLE_CHECK): Macro moved from xfaces.c * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-249 - miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-256 Update from CVS * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-258 - miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-263 Update from CVS * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-264 Update from CVS: lispref/display.texi: emacs -> Emacs. * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-265 - miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-274 Update from CVS * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-275 Update from CVS: man/makefile.w32-in: Revert last change * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-276 - miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-295 Update from CVS * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-296 Allow restarting an existing debugger session that's exited * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-297 - miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-299 Update from CVS * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-300 - miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-327 Update from CVS * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-328 Update from CVS: src/.gdbinit (xsymbol): Fix last change. * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-329 - miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-344 Update from CVS * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-345 Tweak source regexps so that building in place won't cause problems * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-346 - miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-351 Update from CVS * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-352 Update from CVS: lisp/flymake.el: New file. * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-353 - miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-361 Update from CVS * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-362 Support " [...]" style defaults in minibuffer-electric-default-mode * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-363 (read-number): Use canonical format for default in prompt. * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-364 - miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-367 Update from CVS * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-368 Improve display-supports-face-attributes-p on non-ttys * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-369 Rewrite face-differs-from-default-p * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-370 Move `display-supports-face-attributes-p' entirely into C code * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-371 Update from CVS * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-372 Simplify face-differs-from-default-p; don't consider :stipple. * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-373 Update from CVS * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-374 (tty_supports_face_attributes_p): Ensure attributes differ from default * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-375 - miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-376 Update from CVS * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-377 (Fdisplay_supports_face_attributes_p): Work around bootstrapping problem * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-378 - miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-380 Update from CVS * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-381 Face merging cleanups * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-382 - miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-384 Update from CVS * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-385 src/xfaces.c (push_named_merge_point): Return 0 if a cycle is detected * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-386 - miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-395 Update from CVS * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-396 Tweak arch tagging to make build/install-in-place less annoying * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-397 Work around vc-arch problems when building eshell * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-398 Tweak permissions * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-399 Tweak directory permissions * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-400 Update from CVS * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-401 More build-in-place tweaking of arch tagging * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-402 Update from CVS * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-403 Yet more build-in-place tweaking of arch tagging * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-404 - miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-409 Update from CVS * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-410 Make sure image types are initialized for lookup too * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-411 - miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-416 Update from CVS
Diffstat (limited to 'lisp/url')
-rw-r--r--lisp/url/url-dav.el983
-rw-r--r--lisp/url/url-file.el245
-rw-r--r--lisp/url/url-handlers.el258
-rw-r--r--lisp/url/url-http.el1224
-rw-r--r--lisp/url/url-https.el56
-rw-r--r--lisp/url/url-nfs.el100
-rw-r--r--lisp/url/url-util.el508
7 files changed, 3374 insertions, 0 deletions
diff --git a/lisp/url/url-dav.el b/lisp/url/url-dav.el
new file mode 100644
index 00000000000..d6c5ffffa43
--- /dev/null
+++ b/lisp/url/url-dav.el
@@ -0,0 +1,983 @@
1;;; url-dav.el --- WebDAV support
2
3;; Copyright (C) 2001, 2004 Free Software Foundation, Inc.
4
5;; Author: Bill Perry <wmperry@gnu.org>
6;; Maintainer: Bill Perry <wmperry@gnu.org>
7;; Keywords: url, vc
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;; DAV is in RFC 2518.
27
28;;; Commentary:
29
30;;; Code:
31
32(eval-when-compile
33 (require 'cl))
34
35(require 'xml)
36(require 'url-util)
37(require 'url-handlers)
38
39(defvar url-dav-supported-protocols '(1 2)
40 "List of supported DAV versions.")
41
42(defun url-intersection (l1 l2)
43 "Return a list of the elements occuring in both of the lists L1 and L2."
44 (if (null l2)
45 l2
46 (let (result)
47 (while l1
48 (if (member (car l1) l2)
49 (setq result (cons (pop l1) result))
50 (pop l1)))
51 (nreverse result))))
52
53;;;###autoload
54(defun url-dav-supported-p (url)
55 (and (featurep 'xml)
56 (fboundp 'xml-expand-namespace)
57 (url-intersection url-dav-supported-protocols
58 (plist-get (url-http-options url) 'dav))))
59
60(defun url-dav-node-text (node)
61 "Return the text data from the XML node NODE."
62 (mapconcat (lambda (txt)
63 (if (stringp txt)
64 txt
65 "")) (xml-node-children node) " "))
66
67
68;;; Parsing routines for the actual node contents.
69;;
70;; I am not incredibly happy with how this code looks/works right
71;; now, but it DOES work, and if we get the API right, our callers
72;; won't have to worry about the internal representation.
73
74(defconst url-dav-datatype-attribute
75 'urn:uuid:c2f41010-65b3-11d1-a29f-00aa00c14882/dt)
76
77(defun url-dav-process-integer-property (node)
78 (truncate (string-to-number (url-dav-node-text node))))
79
80(defun url-dav-process-number-property (node)
81 (string-to-number (url-dav-node-text node)))
82
83(defconst url-dav-iso8601-regexp
84 (let* ((dash "-?")
85 (colon ":?")
86 (4digit "\\([0-9][0-9][0-9][0-9]\\)")
87 (2digit "\\([0-9][0-9]\\)")
88 (date-fullyear 4digit)
89 (date-month 2digit)
90 (date-mday 2digit)
91 (time-hour 2digit)
92 (time-minute 2digit)
93 (time-second 2digit)
94 (time-secfrac "\\(\\.[0-9]+\\)?")
95 (time-numoffset (concat "[-+]\\(" time-hour "\\):" time-minute))
96 (time-offset (concat "Z" time-numoffset))
97 (partial-time (concat time-hour colon time-minute colon time-second
98 time-secfrac))
99 (full-date (concat date-fullyear dash date-month dash date-mday))
100 (full-time (concat partial-time time-offset))
101 (date-time (concat full-date "T" full-time)))
102 (list (concat "^" full-date)
103 (concat "T" partial-time)
104 (concat "Z" time-numoffset)))
105 "List of regular expressions matching iso8601 dates.
1061st regular expression matches the date.
1072nd regular expression matches the time.
1083rd regular expression matches the (optional) timezone specification.")
109
110(defun url-dav-process-date-property (node)
111 (require 'parse-time)
112 (let* ((date-re (nth 0 url-dav-iso8601-regexp))
113 (time-re (nth 1 url-dav-iso8601-regexp))
114 (tz-re (nth 2 url-dav-iso8601-regexp))
115 (date-string (url-dav-node-text node))
116 re-start
117 time seconds minute hour fractional-seconds
118 day month year day-of-week dst tz)
119 ;; We need to populate 'time' with
120 ;; (SEC MIN HOUR DAY MON YEAR DOW DST TZ)
121
122 ;; Nobody else handles iso8601 correctly, lets do it ourselves.
123 (when (string-match date-re date-string re-start)
124 (setq year (string-to-int (match-string 1 date-string))
125 month (string-to-int (match-string 2 date-string))
126 day (string-to-int (match-string 3 date-string))
127 re-start (match-end 0))
128 (when (string-match time-re date-string re-start)
129 (setq hour (string-to-int (match-string 1 date-string))
130 minute (string-to-int (match-string 2 date-string))
131 seconds (string-to-int (match-string 3 date-string))
132 fractional-seconds (string-to-int (or
133 (match-string 4 date-string)
134 "0"))
135 re-start (match-end 0))
136 (when (string-match tz-re date-string re-start)
137 (setq tz (match-string 1 date-string)))
138 (url-debug 'dav "Parsed iso8601%s date" (if tz "tz" ""))
139 (setq time (list seconds minute hour day month year day-of-week dst tz))))
140
141 ;; Fall back to having Gnus do fancy things for us.
142 (when (not time)
143 (setq time (parse-time-string date-string)))
144
145 (if time
146 (setq time (apply 'encode-time time))
147 (url-debug 'dav "Unable to decode date (%S) (%s)"
148 (xml-node-name node) date-string))
149 time))
150
151(defun url-dav-process-boolean-property (node)
152 (/= 0 (string-to-int (url-dav-node-text node))))
153
154(defun url-dav-process-uri-property (node)
155 ;; Returns a parsed representation of the URL...
156 (url-generic-parse-url (url-dav-node-text node)))
157
158(defun url-dav-find-parser (node)
159 "Find a function to parse the XML node NODE."
160 (or (get (xml-node-name node) 'dav-parser)
161 (let ((fn (intern (format "url-dav-process-%s" (xml-node-name node)))))
162 (if (not (fboundp fn))
163 (setq fn 'url-dav-node-text)
164 (put (xml-node-name node) 'dav-parser fn))
165 fn)))
166
167(defmacro url-dav-dispatch-node (node)
168 `(funcall (url-dav-find-parser ,node) ,node))
169
170(defun url-dav-process-DAV:prop (node)
171 ;; A prop node has content model of ANY
172 ;;
173 ;; Some predefined nodes have special meanings though.
174 ;;
175 ;; DAV:supportedlock - list of DAV:lockentry
176 ;; DAV:source
177 ;; DAV:iscollection - boolean
178 ;; DAV:getcontentlength - integer
179 ;; DAV:ishidden - boolean
180 ;; DAV:getcontenttype - string
181 ;; DAV:resourcetype - node who's name is the resource type
182 ;; DAV:getlastmodified - date
183 ;; DAV:creationdate - date
184 ;; DAV:displayname - string
185 ;; DAV:getetag - unknown
186 (let ((children (xml-node-children node))
187 (node-type nil)
188 (props nil)
189 (value nil)
190 (handler-func nil))
191 (when (not children)
192 (error "No child nodes in DAV:prop"))
193
194 (while children
195 (setq node (car children)
196 node-type (intern
197 (or
198 (cdr-safe (assq url-dav-datatype-attribute
199 (xml-node-attributes node)))
200 "unknown"))
201 value nil)
202
203 (case node-type
204 ((dateTime.iso8601tz
205 dateTime.iso8601
206 dateTime.tz
207 dateTime.rfc1123
208 dateTime
209 date) ; date is our 'special' one...
210 ;; Some type of date/time string.
211 (setq value (url-dav-process-date-property node)))
212 (int
213 ;; Integer type...
214 (setq value (url-dav-process-integer-property node)))
215 ((number float)
216 (setq value (url-dav-process-number-property node)))
217 (boolean
218 (setq value (url-dav-process-boolean-property node)))
219 (uri
220 (setq value (url-dav-process-uri-property node)))
221 (otherwise
222 (if (not (eq node-type 'unknown))
223 (url-debug 'dav "Unknown data type in url-dav-process-prop: %s"
224 node-type))
225 (setq value (url-dav-dispatch-node node))))
226
227 (setq props (plist-put props (xml-node-name node) value)
228 children (cdr children)))
229 props))
230
231(defun url-dav-process-DAV:supportedlock (node)
232 ;; DAV:supportedlock is a list of DAV:lockentry items.
233 ;; DAV:lockentry in turn contains a DAV:lockscope and DAV:locktype.
234 ;; The DAV:lockscope must have a single node beneath it, ditto for
235 ;; DAV:locktype.
236 (let ((children (xml-node-children node))
237 (results nil)
238 scope type)
239 (while children
240 (when (and (not (stringp (car children)))
241 (eq (xml-node-name (car children)) 'DAV:lockentry))
242 (setq scope (assq 'DAV:lockscope (xml-node-children (car children)))
243 type (assq 'DAV:locktype (xml-node-children (car children))))
244 (when (and scope type)
245 (setq scope (xml-node-name (car (xml-node-children scope)))
246 type (xml-node-name (car (xml-node-children type))))
247 (push (cons type scope) results)))
248 (setq children (cdr children)))
249 results))
250
251(defun url-dav-process-subnode-property (node)
252 ;; Returns a list of child node names.
253 (delq nil (mapcar 'car-safe (xml-node-children node))))
254
255(defalias 'url-dav-process-DAV:depth 'url-dav-process-integer-property)
256(defalias 'url-dav-process-DAV:resourcetype 'url-dav-process-subnode-property)
257(defalias 'url-dav-process-DAV:locktype 'url-dav-process-subnode-property)
258(defalias 'url-dav-process-DAV:lockscope 'url-dav-process-subnode-property)
259(defalias 'url-dav-process-DAV:getcontentlength 'url-dav-process-integer-property)
260(defalias 'url-dav-process-DAV:getlastmodified 'url-dav-process-date-property)
261(defalias 'url-dav-process-DAV:creationdate 'url-dav-process-date-property)
262(defalias 'url-dav-process-DAV:iscollection 'url-dav-process-boolean-property)
263(defalias 'url-dav-process-DAV:ishidden 'url-dav-process-boolean-property)
264
265(defun url-dav-process-DAV:locktoken (node)
266 ;; DAV:locktoken can have one or more DAV:href children.
267 (delq nil (mapcar (lambda (n)
268 (if (stringp n)
269 n
270 (url-dav-dispatch-node n)))
271 (xml-node-children node))))
272
273(defun url-dav-process-DAV:owner (node)
274 ;; DAV:owner can contain anything.
275 (delq nil (mapcar (lambda (n)
276 (if (stringp n)
277 n
278 (url-dav-dispatch-node n)))
279 (xml-node-children node))))
280
281(defun url-dav-process-DAV:activelock (node)
282 ;; DAV:activelock can contain:
283 ;; DAV:lockscope
284 ;; DAV:locktype
285 ;; DAV:depth
286 ;; DAV:owner (optional)
287 ;; DAV:timeout (optional)
288 ;; DAV:locktoken (optional)
289 (let ((children (xml-node-children node))
290 (results nil))
291 (while children
292 (if (listp (car children))
293 (push (cons (xml-node-name (car children))
294 (url-dav-dispatch-node (car children)))
295 results))
296 (setq children (cdr children)))
297 results))
298
299(defun url-dav-process-DAV:lockdiscovery (node)
300 ;; Can only contain a list of DAV:activelock objects.
301 (let ((children (xml-node-children node))
302 (results nil))
303 (while children
304 (cond
305 ((stringp (car children))
306 ;; text node? why?
307 nil)
308 ((eq (xml-node-name (car children)) 'DAV:activelock)
309 (push (url-dav-dispatch-node (car children)) results))
310 (t
311 ;; Ignore unknown nodes...
312 nil))
313 (setq children (cdr children)))
314 results))
315
316(defun url-dav-process-DAV:status (node)
317 ;; The node contains a standard HTTP/1.1 response line... we really
318 ;; only care about the numeric status code.
319 (let ((status (url-dav-node-text node)))
320 (if (string-match "\\`[ \r\t\n]*HTTP/[0-9.]+ \\([0-9]+\\)" status)
321 (string-to-int (match-string 1 status))
322 500)))
323
324(defun url-dav-process-DAV:propstat (node)
325 ;; A propstate node can have the following children...
326 ;;
327 ;; DAV:prop - a list of properties and values
328 ;; DAV:status - An HTTP/1.1 status line
329 (let ((children (xml-node-children node))
330 (props nil)
331 (status nil))
332 (when (not children)
333 (error "No child nodes in DAV:propstat"))
334
335 (setq props (url-dav-dispatch-node (assq 'DAV:prop children))
336 status (url-dav-dispatch-node (assq 'DAV:status children)))
337
338 ;; Need to parse out the HTTP status
339 (setq props (plist-put props 'DAV:status status))
340 props))
341
342(defun url-dav-process-DAV:response (node)
343 (let ((children (xml-node-children node))
344 (propstat nil)
345 (href))
346 (when (not children)
347 (error "No child nodes in DAV:response"))
348
349 ;; A response node can have the following children...
350 ;;
351 ;; DAV:href - URL the response is for.
352 ;; DAV:propstat - see url-dav-process-propstat
353 ;; DAV:responsedescription - text description of the response
354 (setq propstat (assq 'DAV:propstat children)
355 href (assq 'DAV:href children))
356
357 (when (not href)
358 (error "No href in DAV:response"))
359
360 (when (not propstat)
361 (error "No propstat in DAV:response"))
362
363 (setq propstat (url-dav-dispatch-node propstat)
364 href (url-dav-dispatch-node href))
365 (cons href propstat)))
366
367(defun url-dav-process-DAV:multistatus (node)
368 (let ((children (xml-node-children node))
369 (results nil))
370 (while children
371 (push (url-dav-dispatch-node (car children)) results)
372 (setq children (cdr children)))
373 results))
374
375
376;;; DAV request/response generation/processing
377(defun url-dav-process-response (buffer url)
378 "Parse a WebDAV response from BUFFER, interpreting it relative to URL.
379
380The buffer must have been retrieved by HTTP or HTTPS and contain an
381XML document."
382 (declare (special url-http-content-type
383 url-http-response-status
384 url-http-end-of-headers))
385 (let ((tree nil)
386 (overall-status nil))
387 (when buffer
388 (unwind-protect
389 (with-current-buffer buffer
390 (goto-char url-http-end-of-headers)
391 (setq overall-status url-http-response-status)
392
393 ;; XML documents can be transferred as either text/xml or
394 ;; application/xml, and we are required to accept both of
395 ;; them.
396 (if (and
397 url-http-content-type
398 (string-match "\\`\\(text\\|application\\)/xml"
399 url-http-content-type))
400 (setq tree (xml-parse-region (point) (point-max)))))
401 ;; Clean up after ourselves.
402 (kill-buffer buffer)))
403
404 ;; We should now be
405 (if (eq (xml-node-name (car tree)) 'DAV:multistatus)
406 (url-dav-dispatch-node (car tree))
407 (url-debug 'dav "Got back singleton response for URL(%S)" url)
408 (let ((properties (url-dav-dispatch-node (car tree))))
409 ;; We need to make sure we have a DAV:status node in there for
410 ;; higher-level code;
411 (setq properties (plist-put properties 'DAV:status overall-status))
412 ;; Make this look like a DAV:multistatus parse tree so that
413 ;; nobody but us needs to know the difference.
414 (list (cons url properties))))))
415
416(defun url-dav-request (url method tag body
417 &optional depth headers namespaces)
418 "Perform WebDAV operation METHOD on URL. Return the parsed responses.
419Automatically creates an XML request body if TAG is non-nil.
420BODY is the XML document fragment to be enclosed by <TAG></TAG>.
421
422DEPTH is how deep the request should propogate. Default is 0, meaning
423it should apply only to URL. A negative number means to use
424`Infinity' for the depth. Not all WebDAV servers support this depth
425though.
426
427HEADERS is an assoc list of extra headers to send in the request.
428
429NAMESPACES is an assoc list of (NAMESPACE . EXPANSION), and these are
430added to the <TAG> element. The DAV=DAV: namespace is automatically
431added to this list, so most requests can just pass in nil."
432 ;; Take care of the default value for depth...
433 (setq depth (or depth 0))
434
435 ;; Now lets translate it into something webdav can understand.
436 (if (< depth 0)
437 (setq depth "Infinity")
438 (setq depth (int-to-string depth)))
439 (if (not (assoc "DAV" namespaces))
440 (setq namespaces (cons '("DAV" . "DAV:") namespaces)))
441
442 (let* ((url-request-extra-headers `(("Depth" . ,depth)
443 ("Content-type" . "text/xml")
444 ,@headers))
445 (url-request-method method)
446 (url-request-data
447 (if tag
448 (concat
449 "<?xml version=\"1.0\" encoding=\"utf-8\" ?>\n"
450 "<" (symbol-name tag) " "
451 ;; add in the appropriate namespaces...
452 (mapconcat (lambda (ns)
453 (concat "xmlns:" (car ns) "='" (cdr ns) "'"))
454 namespaces "\n ")
455 ">\n"
456 body
457 "</" (symbol-name tag) ">\n"))))
458 (url-dav-process-response (url-retrieve-synchronously url) url)))
459
460;;;###autoload
461(defun url-dav-get-properties (url &optional attributes depth namespaces)
462 "Return properties for URL, up to DEPTH levels deep.
463
464Returns an assoc list, where the key is the filename (possibly a full
465URI), and the value is a standard property list of DAV property
466names (ie: DAV:resourcetype)."
467 (url-dav-request url "PROPFIND" 'DAV:propfind
468 (if attributes
469 (mapconcat (lambda (attr)
470 (concat "<DAV:prop><"
471 (symbol-name attr)
472 "/></DAV:prop>"))
473 attributes "\n ")
474 " <DAV:allprop/>")
475 depth nil namespaces))
476
477(defmacro url-dav-http-success-p (status)
478 "Return whether PROPERTIES was the result of a successful DAV request."
479 `(= (/ (or ,status 500) 100) 2))
480
481
482;;; Locking support
483(defvar url-dav-lock-identifier (concat "mailto:" user-mail-address)
484 "*URL used as contact information when creating locks in DAV.
485This will be used as the contents of the DAV:owner/DAV:href tag to
486identify the owner of a LOCK when requesting it. This will be shown
487to other users when the DAV:lockdiscovery property is requested, so
488make sure you are comfortable with it leaking to the outside world.")
489
490;;;###autoload
491(defun url-dav-lock-resource (url exclusive &optional depth)
492 "Request a lock on URL. If EXCLUSIVE is non-nil, get an exclusive lock.
493Optional 3rd argument DEPTH says how deep the lock should go, default is 0
494\(lock only the resource and none of its children\).
495
496Returns a cons-cell of (SUCCESSFUL-RESULTS . FAILURE-RESULTS).
497SUCCESSFUL-RESULTS is a list of (URL STATUS locktoken).
498FAILURE-RESULTS is a list of (URL STATUS)."
499 (setq exclusive (if exclusive "<DAV:exclusive/>" "<DAV:shared/>"))
500 (let* ((body
501 (concat
502 " <DAV:lockscope>" exclusive "</DAV:lockscope>\n"
503 " <DAV:locktype> <DAV:write/> </DAV:locktype>\n"
504 " <DAV:owner>\n"
505 " <DAV:href>" url-dav-lock-identifier "</DAV:href>\n"
506 " </DAV:owner>\n"))
507 (response nil) ; Responses to the LOCK request
508 (result nil) ; For walking thru the response list
509 (child-url nil)
510 (child-status nil)
511 (failures nil) ; List of failure cases (URL . STATUS)
512 (successes nil)) ; List of success cases (URL . STATUS)
513 (setq response (url-dav-request url "LOCK" 'DAV:lockinfo body
514 depth '(("Timeout" . "Infinite"))))
515
516 ;; Get the parent URL ready for expand-file-name
517 (if (not (vectorp url))
518 (setq url (url-generic-parse-url url)))
519
520 ;; Walk thru the response list, fully expand the URL, and grab the
521 ;; status code.
522 (while response
523 (setq result (pop response)
524 child-url (url-expand-file-name (pop result) url)
525 child-status (or (plist-get result 'DAV:status) 500))
526 (if (url-dav-http-success-p child-status)
527 (push (list url child-status "huh") successes)
528 (push (list url child-status) failures)))
529 (cons successes failures)))
530
531;;;###autoload
532(defun url-dav-active-locks (url &optional depth)
533 "Return an assoc list of all active locks on URL."
534 (let ((response (url-dav-get-properties url '(DAV:lockdiscovery) depth))
535 (properties nil)
536 (child nil)
537 (child-url nil)
538 (child-results nil)
539 (results nil))
540 (if (not (vectorp url))
541 (setq url (url-generic-parse-url url)))
542
543 (while response
544 (setq child (pop response)
545 child-url (pop child)
546 child-results nil)
547 (when (and (url-dav-http-success-p (plist-get child 'DAV:status))
548 (setq child (plist-get child 'DAV:lockdiscovery)))
549 ;; After our parser has had its way with it, The
550 ;; DAV:lockdiscovery property is a list of DAV:activelock
551 ;; objects, which are comprised of DAV:activelocks, which
552 ;; assoc lists of properties and values.
553 (while child
554 (if (assq 'DAV:locktoken (car child))
555 (let ((tokens (cdr (assq 'DAV:locktoken (car child))))
556 (owners (cdr (assq 'DAV:owner (car child)))))
557 (dolist (token tokens)
558 (dolist (owner owners)
559 (push (cons token owner) child-results)))))
560 (pop child)))
561 (if child-results
562 (push (cons (url-expand-file-name child-url url) child-results)
563 results)))
564 results))
565
566;;;###autoload
567(defun url-dav-unlock-resource (url lock-token)
568 "Release the lock on URL represented by LOCK-TOKEN.
569Returns t iff the lock was successfully released."
570 (declare (special url-http-response-status))
571 (let* ((url-request-extra-headers (list (cons "Lock-Token"
572 (concat "<" lock-token ">"))))
573 (url-request-method "UNLOCK")
574 (url-request-data nil)
575 (buffer (url-retrieve-synchronously url))
576 (result nil))
577 (when buffer
578 (unwind-protect
579 (with-current-buffer buffer
580 (setq result (url-dav-http-success-p url-http-response-status)))
581 (kill-buffer buffer)))
582 result))
583
584
585;;; file-name-handler stuff
586(defun url-dav-file-attributes-mode-string (properties)
587 (let ((modes (make-string 10 ?-))
588 (supported-locks (plist-get properties 'DAV:supportedlock))
589 (executable-p (equal (plist-get properties 'http://apache.org/dav/props/executable)
590 "T"))
591 (directory-p (memq 'DAV:collection (plist-get properties 'DAV:resourcetype)))
592 (readable t)
593 (lock nil))
594 ;; Assume we can read this, otherwise the PROPFIND would have
595 ;; failed.
596 (when readable
597 (aset modes 1 ?r)
598 (aset modes 4 ?r)
599 (aset modes 7 ?r))
600
601 (when directory-p
602 (aset modes 0 ?d))
603
604 (when executable-p
605 (aset modes 3 ?x)
606 (aset modes 6 ?x)
607 (aset modes 9 ?x))
608
609 (while supported-locks
610 (setq lock (car supported-locks)
611 supported-locks (cdr supported-locks))
612 (case (car lock)
613 (DAV:write
614 (case (cdr lock)
615 (DAV:shared ; group permissions (possibly world)
616 (aset modes 5 ?w))
617 (DAV:exclusive
618 (aset modes 2 ?w)) ; owner permissions?
619 (otherwise
620 (url-debug 'dav "Unrecognized DAV:lockscope (%S)" (cdr lock)))))
621 (otherwise
622 (url-debug 'dav "Unrecognized DAV:locktype (%S)" (car lock)))))
623 modes))
624
625(autoload 'url-http-head-file-attributes "url-http")
626
627;;;###autoload
628(defun url-dav-file-attributes (url &optional id-format)
629 (let ((properties (cdar (url-dav-get-properties url)))
630 (attributes nil))
631 (if (and properties
632 (url-dav-http-success-p (plist-get properties 'DAV:status)))
633 ;; We got a good DAV response back..
634 (setq attributes
635 (list
636 ;; t for directory, string for symbolic link, or nil
637 ;; Need to support DAV Bindings to figure out the
638 ;; symbolic link issues.
639 (if (memq 'DAV:collection (plist-get properties 'DAV:resourcetype)) t nil)
640
641 ;; Number of links to file... Needs DAV Bindings.
642 1
643
644 ;; File uid - no way to figure out?
645 0
646
647 ;; File gid - no way to figure out?
648 0
649
650 ;; Last access time - ???
651 nil
652
653 ;; Last modification time
654 (plist-get properties 'DAV:getlastmodified)
655
656 ;; Last status change time... just reuse last-modified
657 ;; for now.
658 (plist-get properties 'DAV:getlastmodified)
659
660 ;; size in bytes
661 (or (plist-get properties 'DAV:getcontentlength) 0)
662
663 ;; file modes as a string like `ls -l'
664 ;;
665 ;; Should be able to build this up from the
666 ;; DAV:supportedlock attribute pretty easily. Getting
667 ;; the group info could be impossible though.
668 (url-dav-file-attributes-mode-string properties)
669
670 ;; t iff file's gid would change if it were deleted &
671 ;; recreated. No way for us to know that thru DAV.
672 nil
673
674 ;; inode number - meaningless
675 nil
676
677 ;; device number - meaningless
678 nil))
679 ;; Fall back to just the normal http way of doing things.
680 (setq attributes (url-http-head-file-attributes url id-format)))
681 attributes))
682
683;;;###autoload
684(defun url-dav-save-resource (url obj &optional content-type lock-token)
685 "Save OBJ as URL using WebDAV.
686URL must be a fully qualified URL.
687OBJ may be a buffer or a string."
688 (declare (special url-http-response-status))
689 (let ((buffer nil)
690 (result nil)
691 (url-request-extra-headers nil)
692 (url-request-method "PUT")
693 (url-request-data
694 (cond
695 ((bufferp obj)
696 (with-current-buffer obj
697 (buffer-string)))
698 ((stringp obj)
699 obj)
700 (t
701 (error "Invalid object to url-dav-save-resource")))))
702
703 (if lock-token
704 (push
705 (cons "If" (concat "(<" lock-token ">)"))
706 url-request-extra-headers))
707
708 ;; Everything must always have a content-type when we submit it.
709 (push
710 (cons "Content-type" (or content-type "application/octet-stream"))
711 url-request-extra-headers)
712
713 ;; Do the save...
714 (setq buffer (url-retrieve-synchronously url))
715
716 ;; Sanity checking
717 (when buffer
718 (unwind-protect
719 (with-current-buffer buffer
720 (setq result (url-dav-http-success-p url-http-response-status)))
721 (kill-buffer buffer)))
722 result))
723
724(eval-when-compile
725 (defmacro url-dav-delete-something (url lock-token &rest error-checking)
726 "Delete URL completely, with no sanity checking whatsoever. DO NOT USE.
727This is defined as a macro that will not be visible from compiled files.
728Use with care, and even then think three times.
729"
730 `(progn
731 ,@error-checking
732 (url-dav-request ,url "DELETE" nil nil -1
733 (if ,lock-token
734 (list
735 (cons "If"
736 (concat "(<" ,lock-token ">)"))))))))
737
738
739;;;###autoload
740(defun url-dav-delete-directory (url &optional recursive lock-token)
741 "Delete the WebDAV collection URL.
742If optional second argument RECURSIVE is non-nil, then delete all
743files in the collection as well."
744 (let ((status nil)
745 (props nil)
746 (props nil))
747 (setq props (url-dav-delete-something
748 url lock-token
749 (setq props (url-dav-get-properties url '(DAV:getcontenttype) 1))
750 (if (and (not recursive)
751 (/= (length props) 1))
752 (signal 'file-error (list "Removing directory"
753 "directory not empty" url)))))
754
755 (mapc (lambda (result)
756 (setq status (plist-get (cdr result) 'DAV:status))
757 (if (not (url-dav-http-success-p status))
758 (signal 'file-error (list "Removing directory"
759 "Errror removing"
760 (car result) status))))
761 props))
762 nil)
763
764;;;###autoload
765(defun url-dav-delete-file (url &optional lock-token)
766 "Delete file named URL."
767 (let ((props nil)
768 (status nil))
769 (setq props (url-dav-delete-something
770 url lock-token
771 (setq props (url-dav-get-properties url))
772 (if (eq (plist-get (cdar props) 'DAV:resourcetype) 'DAV:collection)
773 (signal 'file-error (list "Removing old name" "is a collection" url)))))
774
775 (mapc (lambda (result)
776 (setq status (plist-get (cdr result) 'DAV:status))
777 (if (not (url-dav-http-success-p status))
778 (signal 'file-error (list "Removing old name"
779 "Errror removing"
780 (car result) status))))
781 props))
782 nil)
783
784;;;###autoload
785(defun url-dav-directory-files (url &optional full match nosort files-only)
786 "Return a list of names of files in DIRECTORY.
787There are three optional arguments:
788If FULL is non-nil, return absolute file names. Otherwise return names
789 that are relative to the specified directory.
790If MATCH is non-nil, mention only file names that match the regexp MATCH.
791If NOSORT is non-nil, the list is not sorted--its order is unpredictable.
792 NOSORT is useful if you plan to sort the result yourself."
793 (let ((properties (url-dav-get-properties url '(DAV:resourcetype) 1))
794 (child-url nil)
795 (child-props nil)
796 (files nil)
797 (parsed-url (url-generic-parse-url url)))
798
799 (if (= (length properties) 1)
800 (signal 'file-error (list "Opening directory" "not a directory" url)))
801
802 (while properties
803 (setq child-props (pop properties)
804 child-url (pop child-props))
805 (if (and (eq (plist-get child-props 'DAV:resourcetype) 'DAV:collection)
806 files-only)
807 ;; It is a directory, and we were told to return just files.
808 nil
809
810 ;; Fully expand the URL and then rip off the beginning if we
811 ;; are not supposed to return fully-qualified names.
812 (setq child-url (url-expand-file-name child-url parsed-url))
813 (if (not full)
814 (setq child-url (substring child-url (length url))))
815
816 ;; We don't want '/' as the last character in filenames...
817 (if (string-match "/$" child-url)
818 (setq child-url (substring child-url 0 -1)))
819
820 ;; If we have a match criteria, then apply it.
821 (if (or (and match (not (string-match match child-url)))
822 (string= child-url "")
823 (string= child-url url))
824 nil
825 (push child-url files))))
826
827 (if nosort
828 files
829 (sort files 'string-lessp))))
830
831;;;###autoload
832(defun url-dav-file-directory-p (url)
833 "Return t if URL names an existing DAV collection."
834 (let ((properties (cdar (url-dav-get-properties url '(DAV:resourcetype)))))
835 (eq (plist-get properties 'DAV:resourcetype) 'DAV:collection)))
836
837;;;###autoload
838(defun url-dav-make-directory (url &optional parents)
839 "Create the directory DIR and any nonexistent parent dirs."
840 (declare (special url-http-response-status))
841 (let* ((url-request-extra-headers nil)
842 (url-request-method "MKCOL")
843 (url-request-data nil)
844 (buffer (url-retrieve-synchronously url))
845 (result nil))
846 (when buffer
847 (unwind-protect
848 (with-current-buffer buffer
849 (case url-http-response-status
850 (201 ; Collection created in its entirety
851 (setq result t))
852 (403 ; Forbidden
853 nil)
854 (405 ; Method not allowed
855 nil)
856 (409 ; Conflict
857 nil)
858 (415 ; Unsupported media type (WTF?)
859 nil)
860 (507 ; Insufficient storage
861 nil)
862 (otherwise
863 nil)))
864 (kill-buffer buffer)))
865 result))
866
867;;;###autoload
868(defun url-dav-rename-file (oldname newname &optional overwrite)
869 (if (not (and (string-match url-handler-regexp oldname)
870 (string-match url-handler-regexp newname)))
871 (signal 'file-error
872 (list "Cannot rename between different URL backends"
873 oldname newname)))
874
875 (let* ((headers nil)
876 (props nil)
877 (status nil)
878 (directory-p (url-dav-file-directory-p oldname))
879 (exists-p (url-http-file-exists-p newname)))
880
881 (if (and exists-p
882 (or
883 (null overwrite)
884 (and (numberp overwrite)
885 (not (yes-or-no-p
886 (format "File %s already exists; rename to it anyway? "
887 newname))))))
888 (signal 'file-already-exists (list "File already exists" newname)))
889
890 ;; Honor the overwrite flag...
891 (if overwrite (push '("Overwrite" . "T") headers))
892
893 ;; Have to tell them where to copy it to!
894 (push (cons "Destination" newname) headers)
895
896 ;; Always send a depth of -1 in case we are moving a collection.
897 (setq props (url-dav-request oldname "MOVE" nil nil (if directory-p -1 0)
898 headers))
899
900 (mapc (lambda (result)
901 (setq status (plist-get (cdr result) 'DAV:status))
902
903 (if (not (url-dav-http-success-p status))
904 (signal 'file-error (list "Renaming" oldname newname status))))
905 props)
906 t))
907
908;;;###autoload
909(defun url-dav-file-name-all-completions (file url)
910 "Return a list of all completions of file name FILE in directory DIRECTORY.
911These are all file names in directory DIRECTORY which begin with FILE."
912 (url-dav-directory-files url nil (concat "^" file ".*")))
913
914;;;###autoload
915(defun url-dav-file-name-completion (file url)
916 "Complete file name FILE in directory DIRECTORY.
917Returns the longest string
918common to all file names in DIRECTORY that start with FILE.
919If there is only one and FILE matches it exactly, returns t.
920Returns nil if DIR contains no name starting with FILE."
921 (let ((matches (url-dav-file-name-all-completions file url))
922 (result nil))
923 (cond
924 ((null matches)
925 ;; No matches
926 nil)
927 ((and (= (length matches) 1)
928 (string= file (car matches)))
929 ;; Only one file and FILE matches it exactly...
930 t)
931 (t
932 ;; Need to figure out the longest string that they have in commmon
933 (setq matches (sort matches (lambda (a b) (> (length a) (length b)))))
934 (let ((n (length file))
935 (searching t)
936 (regexp nil)
937 (failed nil))
938 (while (and searching
939 (< n (length (car matches))))
940 (setq regexp (concat "^" (substring (car matches) 0 (1+ n)))
941 failed nil)
942 (dolist (potential matches)
943 (if (not (string-match regexp potential))
944 (setq failed t)))
945 (if failed
946 (setq searching nil)
947 (incf n)))
948 (substring (car matches) 0 n))))))
949
950(defun url-dav-register-handler (op)
951 (put op 'url-file-handlers (intern-soft (format "url-dav-%s" op))))
952
953(mapcar 'url-dav-register-handler
954 '(file-name-all-completions
955 file-name-completion
956 rename-file
957 make-directory
958 file-directory-p
959 directory-files
960 delete-file
961 delete-directory
962 file-attributes))
963
964
965;;; Version Control backend cruft
966
967;(put 'vc-registered 'url-file-handlers 'url-dav-vc-registered)
968
969;;;###autoload
970(defun url-dav-vc-registered (url)
971 (if (and (string-match "\\`https?" url)
972 (plist-get (url-http-options url) 'dav))
973 (progn
974 (vc-file-setprop url 'vc-backend 'dav)
975 t)))
976
977
978;;; Miscellaneous stuff.
979
980(provide 'url-dav)
981
982;; arch-tag: 2b14b7b3-888a-49b8-a490-17276a40e78e
983;;; url-dav.el ends here
diff --git a/lisp/url/url-file.el b/lisp/url/url-file.el
new file mode 100644
index 00000000000..77c2e74555f
--- /dev/null
+++ b/lisp/url/url-file.el
@@ -0,0 +1,245 @@
1;;; url-file.el --- File retrieval code
2
3;; Copyright (c) 1996 - 1999,2004 Free Software Foundation, Inc.
4;; Copyright (c) 1993 - 1996 by William M. Perry <wmperry@cs.indiana.edu>
5
6;; Keywords: comm, data, processes
7
8;; This file is part of GNU Emacs.
9;;
10;; GNU Emacs is free software; you can redistribute it and/or modify
11;; it under the terms of the GNU General Public License as published by
12;; the Free Software Foundation; either version 2, or (at your option)
13;; any later version.
14;;
15;; GNU Emacs is distributed in the hope that it will be useful,
16;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18;; GNU General Public License for more details.
19;;
20;; You should have received a copy of the GNU General Public License
21;; along with GNU Emacs; see the file COPYING. If not, write to the
22;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
23;; Boston, MA 02111-1307, USA.
24
25;;; Commentary:
26
27;;; Code:
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 (format "%s%c" filename directory-sep-char)))
132 (if (and (file-directory-p filename)
133 (not (string-match "/\\'" filename)))
134 (url-set-filename url (format "%s/" filename)))
135
136
137 ;; If it is a directory, look for an index file first.
138 (if (and (file-directory-p filename)
139 url-directory-index-file
140 (setq pos-index (expand-file-name url-directory-index-file filename))
141 (file-exists-p pos-index)
142 (file-readable-p pos-index))
143 (setq filename pos-index))
144
145 ;; Find the (possibly compressed) file
146 (setq filename (url-file-find-possibly-compressed-file filename))
147 filename))
148
149;;;###autoload
150(defun url-file (url callback cbargs)
151 "Handle file: and ftp: URLs."
152 (let* ((buffer nil)
153 (uncompressed-filename nil)
154 (content-type nil)
155 (content-encoding nil)
156 (coding-system-for-read 'binary))
157
158 (setq filename (url-file-build-filename url))
159
160 (if (not filename)
161 (error "File does not exist: %s" (url-recreate-url url)))
162
163 ;; Need to figure out the content-type from the real extension,
164 ;; not the compressed one.
165 (setq uncompressed-filename (if (string-match "\\.\\(gz\\|Z\\|z\\)$" filename)
166 (substring filename 0 (match-beginning 0))
167 filename))
168 (setq content-type (mailcap-extension-to-mime
169 (url-file-extension uncompressed-filename))
170 content-encoding (case (intern (url-file-extension filename))
171 ((\.z \.gz) "gzip")
172 (\.Z "compress")
173 (\.uue "x-uuencoded")
174 (\.hqx "x-hqx")
175 (\.bz2 "x-bzip2")
176 (otherwise nil)))
177
178 (if (file-directory-p filename)
179 ;; A directory is done the same whether we are local or remote
180 (url-find-file-dired filename)
181 (save-excursion
182 (setq buffer (generate-new-buffer " *url-file*"))
183 (set-buffer buffer)
184 (mm-disable-multibyte)
185 (setq url-current-object url)
186 (insert "Content-type: " (or content-type "application/octet-stream") "\n")
187 (if content-encoding
188 (insert "Content-transfer-encoding: " content-encoding "\n"))
189 (if (url-file-host-is-local-p (url-host url))
190 ;; Local files are handled slightly oddly
191 (if (featurep 'ange-ftp)
192 (url-file-asynch-callback nil nil
193 filename
194 (current-buffer)
195 callback cbargs)
196 (url-file-asynch-callback nil nil nil
197 filename
198 (current-buffer)
199 callback cbargs))
200 ;; FTP handling
201 (let* ((extension (url-file-extension filename))
202 (new (url-generate-unique-filename
203 (and (> (length extension) 0)
204 (concat "%s." extension)))))
205 (if (featurep 'ange-ftp)
206 (ange-ftp-copy-file-internal filename (expand-file-name new) t
207 nil t
208 (list 'url-file-asynch-callback
209 new (current-buffer)
210 callback cbargs)
211 t)
212 (autoload 'efs-copy-file-internal "efs")
213 (efs-copy-file-internal filename (efs-ftp-path filename)
214 new (efs-ftp-path new)
215 t nil 0
216 (list 'url-file-asynch-callback
217 new (current-buffer)
218 callback cbargs)
219 0 nil))))))
220 buffer))
221
222(defmacro url-file-create-wrapper (method args)
223 `(defalias ',(intern (format "url-ftp-%s" method))
224 (defun ,(intern (format "url-file-%s" method)) ,args
225 ,(format "FTP/FILE URL wrapper around `%s' call." method)
226 (setq url (url-file-build-filename url))
227 (and url (,method ,@(remove '&rest (remove '&optional args)))))))
228
229(url-file-create-wrapper file-exists-p (url))
230(url-file-create-wrapper file-attributes (url &optional id-format))
231(url-file-create-wrapper file-symlink-p (url))
232(url-file-create-wrapper file-readable-p (url))
233(url-file-create-wrapper file-writable-p (url))
234(url-file-create-wrapper file-executable-p (url))
235(if (featurep 'xemacs)
236 (progn
237 (url-file-create-wrapper directory-files (url &optional full match nosort files-only))
238 (url-file-create-wrapper file-truename (url &optional default)))
239 (url-file-create-wrapper directory-files (url &optional full match nosort))
240 (url-file-create-wrapper file-truename (url &optional counter prev-dirs)))
241
242(provide 'url-file)
243
244;; arch-tag: 010e914a-7313-494b-8a8c-6495a862157d
245;;; url-file.el ends here
diff --git a/lisp/url/url-handlers.el b/lisp/url/url-handlers.el
new file mode 100644
index 00000000000..6c540e8d61b
--- /dev/null
+++ b/lisp/url/url-handlers.el
@@ -0,0 +1,258 @@
1;;; url-handlers.el --- file-name-handler stuff for URL loading
2
3;; Copyright (c) 1996,97,98,1999,2004 Free Software Foundation, Inc.
4;; Copyright (c) 1993 - 1996 by William M. Perry <wmperry@cs.indiana.edu>
5
6;; Keywords: comm, data, processes, hypermedia
7
8;; This file is part of GNU Emacs.
9;;
10;; GNU Emacs is free software; you can redistribute it and/or modify
11;; it under the terms of the GNU General Public License as published by
12;; the Free Software Foundation; either version 2, or (at your option)
13;; any later version.
14;;
15;; GNU Emacs is distributed in the hope that it will be useful,
16;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18;; GNU General Public License for more details.
19;;
20;; You should have received a copy of the GNU General Public License
21;; along with GNU Emacs; see the file COPYING. If not, write to the
22;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
23;; Boston, MA 02111-1307, USA.
24
25;;; Commentary:
26
27;;; Code:
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(define-minor-mode url-handler-mode
99 "Use URL to handle URL-like file names."
100 :global t
101 (if (not (boundp 'file-name-handler-alist))
102 ;; Can't be turned ON anyway.
103 (setq url-handler-mode nil)
104 ;; Remove old entry, if any.
105 (setq file-name-handler-alist
106 (delq (rassq 'url-file-handler file-name-handler-alist)
107 file-name-handler-alist))
108 (if url-handler-mode
109 (push (cons url-handler-regexp 'url-file-handler)
110 file-name-handler-alist))))
111
112(defun url-run-real-handler (operation args)
113 (let ((inhibit-file-name-handlers (cons 'url-file-handler
114 (if (eq operation inhibit-file-name-operation)
115 inhibit-file-name-handlers)))
116 (inhibit-file-name-operation operation))
117 (apply operation args)))
118
119(defun url-file-handler (operation &rest args)
120 "Function called from the `file-name-handler-alist' routines.
121OPERATION is what needs to be done (`file-exists-p', etc). ARGS are
122the arguments that would have been passed to OPERATION."
123 (let ((fn (or (get operation 'url-file-handlers)
124 (intern-soft (format "url-%s" operation))))
125 (val nil)
126 (hooked nil))
127 (if (and fn (fboundp fn))
128 (setq hooked t
129 val (apply fn args))
130 (setq hooked nil
131 val (url-run-real-handler operation args)))
132 (url-debug 'handlers "%s %S%S => %S" (if hooked "Hooked" "Real")
133 operation args val)
134 val))
135
136(defun url-file-handler-identity (&rest args)
137 ;; Identity function
138 (car args))
139
140;; These are operations that we can fully support
141(put 'file-readable-p 'url-file-handlers 'url-file-exists-p)
142(put 'substitute-in-file-name 'url-file-handlers 'url-file-handler-identity)
143(put 'file-name-absolute-p 'url-file-handlers (lambda (&rest ignored) t))
144(put 'expand-file-name 'url-file-handlers 'url-handler-expand-file-name)
145
146;; These are operations that we do not support yet (DAV!!!)
147(put 'file-writable-p 'url-file-handlers 'ignore)
148(put 'file-symlink-p 'url-file-handlers 'ignore)
149
150(defun url-handler-expand-file-name (file &optional base)
151 (if (file-name-absolute-p file)
152 (expand-file-name file "/")
153 (url-expand-file-name file base)))
154
155;; The actual implementation
156;;;###autoload
157(defun url-copy-file (url newname &optional ok-if-already-exists keep-time)
158 "Copy URL to NEWNAME. Both args must be strings.
159Signals a `file-already-exists' error if file NEWNAME already exists,
160unless a third argument OK-IF-ALREADY-EXISTS is supplied and non-nil.
161A number as third arg means request confirmation if NEWNAME already exists.
162This is what happens in interactive use with M-x.
163Fourth arg KEEP-TIME non-nil means give the new file the same
164last-modified time as the old one. (This works on only some systems.)
165A prefix arg makes KEEP-TIME non-nil."
166 (if (and (file-exists-p newname)
167 (not ok-if-already-exists))
168 (error "Opening output file: File already exists, %s" newname))
169 (let ((buffer (url-retrieve-synchronously url))
170 (handle nil))
171 (if (not buffer)
172 (error "Opening input file: No such file or directory, %s" url))
173 (save-excursion
174 (set-buffer buffer)
175 (setq handle (mm-dissect-buffer t)))
176 (mm-save-part-to-file handle newname)
177 (kill-buffer buffer)
178 (mm-destroy-parts handle)))
179
180;;;###autoload
181(defun url-file-local-copy (url &rest ignored)
182 "Copy URL into a temporary file on this machine.
183Returns the name of the local copy, or nil, if FILE is directly
184accessible."
185 (let ((filename (make-temp-name "url")))
186 (url-copy-file url filename)
187 filename))
188
189;;;###autoload
190(defun url-insert-file-contents (url &optional visit beg end replace)
191 (let ((buffer (url-retrieve-synchronously url))
192 (handle nil)
193 (data nil))
194 (if (not buffer)
195 (error "Opening input file: No such file or directory, %s" url))
196 (if visit (setq buffer-file-name url))
197 (save-excursion
198 (set-buffer buffer)
199 (setq handle (mm-dissect-buffer t))
200 (set-buffer (mm-handle-buffer handle))
201 (if beg
202 (setq data (buffer-substring beg end))
203 (setq data (buffer-string))))
204 (kill-buffer buffer)
205 (mm-destroy-parts handle)
206 (if replace (delete-region (point-min) (point-max)))
207 (save-excursion
208 (insert data))
209 (list url (length data))))
210
211(defun url-file-name-completion (url directory)
212 (error "Unimplemented"))
213
214(defun url-file-name-all-completions (file directory)
215 (error "Unimplemented"))
216
217;; All other handlers map onto their respective backends.
218(defmacro url-handlers-create-wrapper (method args)
219 `(defun ,(intern (format "url-%s" method)) ,args
220 ,(format "URL file-name-handler wrapper for `%s' call.\n---\n%s" method
221 (or (documentation method t) "No original documentation."))
222 (setq url (url-generic-parse-url url))
223 (when (url-type url)
224 (funcall (url-scheme-get-property (url-type url) (quote ,method))
225 ,@(remove '&rest (remove '&optional args))))))
226
227(url-handlers-create-wrapper file-exists-p (url))
228(url-handlers-create-wrapper file-attributes (url &optional id-format))
229(url-handlers-create-wrapper file-symlink-p (url))
230(url-handlers-create-wrapper file-writable-p (url))
231(url-handlers-create-wrapper file-directory-p (url))
232(url-handlers-create-wrapper file-executable-p (url))
233
234(if (featurep 'xemacs)
235 (progn
236 ;; XEmacs specific prototypes
237 (url-handlers-create-wrapper
238 directory-files (url &optional full match nosort files-only))
239 (url-handlers-create-wrapper
240 file-truename (url &optional default)))
241 ;; Emacs specific prototypes
242 (url-handlers-create-wrapper
243 directory-files (url &optional full match nosort))
244 (url-handlers-create-wrapper
245 file-truename (url &optional counter prev-dirs)))
246
247(add-hook 'find-file-hook 'url-handlers-set-buffer-mode)
248
249(defun url-handlers-set-buffer-mode ()
250 "Set correct modes for the current buffer if visiting a remote file."
251 (and (stringp buffer-file-name)
252 (string-match url-handler-regexp buffer-file-name)
253 (auto-save-mode 0)))
254
255(provide 'url-handlers)
256
257;; arch-tag: 7300b99c-cc83-42ff-9147-79b2723c62ac
258;;; url-handlers.el ends here
diff --git a/lisp/url/url-http.el b/lisp/url/url-http.el
new file mode 100644
index 00000000000..200025c3804
--- /dev/null
+++ b/lisp/url/url-http.el
@@ -0,0 +1,1224 @@
1;;; url-http.el --- HTTP retrieval routines
2
3;; Copyright (c) 1999, 2001, 2004 Free Software Foundation, Inc.
4
5;; Author: Bill Perry <wmperry@gnu.org>
6;; Keywords: comm, data, processes
7
8;; This file is part of GNU Emacs.
9;;
10;; GNU Emacs is free software; you can redistribute it and/or modify
11;; it under the terms of the GNU General Public License as published by
12;; the Free Software Foundation; either version 2, or (at your option)
13;; any later version.
14;;
15;; GNU Emacs is distributed in the hope that it will be useful,
16;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18;; GNU General Public License for more details.
19;;
20;; You should have received a copy of the GNU General Public License
21;; along with GNU Emacs; see the file COPYING. If not, write to the
22;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
23;; Boston, MA 02111-1307, USA.
24
25;;; Commentary:
26
27;;; Code:
28
29(eval-when-compile
30 (require 'cl)
31 (defvar url-http-extra-headers))
32(require 'url-gw)
33(require 'url-util)
34(require 'url-parse)
35(require 'url-cookie)
36(require 'mail-parse)
37(require 'url-auth)
38(autoload 'url-retrieve-synchronously "url")
39(autoload 'url-retrieve "url")
40(autoload 'url-cache-create-filename "url-cache")
41(autoload 'url-mark-buffer-as-dead "url")
42
43(defconst url-http-default-port 80 "Default HTTP port.")
44(defconst url-http-asynchronous-p t "HTTP retrievals are asynchronous.")
45(defalias 'url-http-expand-file-name 'url-default-expander)
46
47(defvar url-http-real-basic-auth-storage nil)
48(defvar url-http-proxy-basic-auth-storage nil)
49
50(defvar url-http-open-connections (make-hash-table :test 'equal
51 :size 17)
52 "A hash table of all open network connections.")
53
54(defvar url-http-version "1.1"
55 "What version of HTTP we advertise, as a string.
56Valid values are 1.1 and 1.0.
57This is only useful when debugging the HTTP subsystem.
58
59Setting this to 1.0 will tell servers not to send chunked encoding,
60and other HTTP/1.1 specific features.
61")
62
63(defvar url-http-attempt-keepalives t
64 "Whether to use a single TCP connection multiple times in HTTP.
65This is only useful when debugging the HTTP subsystem. Setting to
66`nil' will explicitly close the connection to the server after every
67request.
68")
69
70;(eval-when-compile
71;; These are all macros so that they are hidden from external sight
72;; when the file is byte-compiled.
73;;
74;; This allows us to expose just the entry points we want.
75
76;; These routines will allow us to implement persistent HTTP
77;; connections.
78(defsubst url-http-debug (&rest args)
79 (if quit-flag
80 (let ((proc (get-buffer-process (current-buffer))))
81 ;; The user hit C-g, honor it! Some things can get in an
82 ;; incredibly tight loop (chunked encoding)
83 (if proc
84 (progn
85 (set-process-sentinel proc nil)
86 (set-process-filter proc nil)))
87 (error "Transfer interrupted!")))
88 (apply 'url-debug 'http args))
89
90(defun url-http-mark-connection-as-busy (host port proc)
91 (url-http-debug "Marking connection as busy: %s:%d %S" host port proc)
92 (puthash (cons host port)
93 (delq proc (gethash (cons host port) url-http-open-connections))
94 url-http-open-connections)
95 proc)
96
97(defun url-http-mark-connection-as-free (host port proc)
98 (url-http-debug "Marking connection as free: %s:%d %S" host port proc)
99 (set-process-buffer proc nil)
100 (set-process-sentinel proc 'url-http-idle-sentinel)
101 (puthash (cons host port)
102 (cons proc (gethash (cons host port) url-http-open-connections))
103 url-http-open-connections)
104 nil)
105
106(defun url-http-find-free-connection (host port)
107 (let ((conns (gethash (cons host port) url-http-open-connections))
108 (found nil))
109 (while (and conns (not found))
110 (if (not (memq (process-status (car conns)) '(run open)))
111 (progn
112 (url-http-debug "Cleaning up dead process: %s:%d %S"
113 host port (car conns))
114 (url-http-idle-sentinel (car conns) nil))
115 (setq found (car conns))
116 (url-http-debug "Found existing connection: %s:%d %S" host port found))
117 (pop conns))
118 (if found
119 (url-http-debug "Reusing existing connection: %s:%d" host port)
120 (url-http-debug "Contacting host: %s:%d" host port))
121 (url-lazy-message "Contacting host: %s:%d" host port)
122 (url-http-mark-connection-as-busy host port
123 (or found
124 (url-open-stream host nil host
125 port)))))
126
127;; Building an HTTP request
128(defun url-http-user-agent-string ()
129 (if (or (eq url-privacy-level 'paranoid)
130 (and (listp url-privacy-level)
131 (memq 'agent url-privacy-level)))
132 ""
133 (format "User-Agent: %sURL/%s%s\r\n"
134 (if url-package-name
135 (concat url-package-name "/" url-package-version " ")
136 "")
137 url-version
138 (cond
139 ((and url-os-type url-system-type)
140 (concat " (" url-os-type "; " url-system-type ")"))
141 ((or url-os-type url-system-type)
142 (concat " (" (or url-system-type url-os-type) ")"))
143 (t "")))))
144
145(defun url-http-create-request (url &optional ref-url)
146 "Create an HTTP request for URL, referred to by REF-URL."
147 (declare (special proxy-object proxy-info))
148 (let* ((extra-headers)
149 (request nil)
150 (no-cache (cdr-safe (assoc "Pragma" url-request-extra-headers)))
151 (proxy-obj (and (boundp 'proxy-object) proxy-object))
152 (proxy-auth (if (or (cdr-safe (assoc "Proxy-Authorization"
153 url-request-extra-headers))
154 (not proxy-obj))
155 nil
156 (let ((url-basic-auth-storage
157 'url-http-proxy-basic-auth-storage))
158 (url-get-authentication url nil 'any nil))))
159 (real-fname (if proxy-obj (url-recreate-url proxy-obj)
160 (url-filename url)))
161 (host (url-host (or proxy-obj url)))
162 (auth (if (cdr-safe (assoc "Authorization" url-request-extra-headers))
163 nil
164 (url-get-authentication (or
165 (and (boundp 'proxy-info)
166 proxy-info)
167 url) nil 'any nil))))
168 (if (equal "" real-fname)
169 (setq real-fname "/"))
170 (setq no-cache (and no-cache (string-match "no-cache" no-cache)))
171 (if auth
172 (setq auth (concat "Authorization: " auth "\r\n")))
173 (if proxy-auth
174 (setq proxy-auth (concat "Proxy-Authorization: " proxy-auth "\r\n")))
175
176 ;; Protection against stupid values in the referer
177 (if (and ref-url (stringp ref-url) (or (string= ref-url "file:nil")
178 (string= ref-url "")))
179 (setq ref-url nil))
180
181 ;; We do not want to expose the referer if the user is paranoid.
182 (if (or (memq url-privacy-level '(low high paranoid))
183 (and (listp url-privacy-level)
184 (memq 'lastloc url-privacy-level)))
185 (setq ref-url nil))
186
187 ;; url-request-extra-headers contains an assoc-list of
188 ;; header/value pairs that we need to put into the request.
189 (setq extra-headers (mapconcat
190 (lambda (x)
191 (concat (car x) ": " (cdr x)))
192 url-request-extra-headers "\r\n"))
193 (if (not (equal extra-headers ""))
194 (setq extra-headers (concat extra-headers "\r\n")))
195
196 ;; This was done with a call to `format'. Concatting parts has
197 ;; the advantage of keeping the parts of each header togther and
198 ;; allows us to elide null lines directly, at the cost of making
199 ;; the layout less clear.
200 (setq request
201 (concat
202 ;; The request
203 (or url-request-method "GET") " " real-fname " HTTP/" url-http-version "\r\n"
204 ;; Version of MIME we speak
205 "MIME-Version: 1.0\r\n"
206 ;; (maybe) Try to keep the connection open
207 "Connection: " (if (or proxy-obj
208 (not url-http-attempt-keepalives))
209 "close" "keep-alive") "\r\n"
210 ;; HTTP extensions we support
211 (if url-extensions-header
212 (format
213 "Extension: %s\r\n" url-extensions-header))
214 ;; Who we want to talk to
215 (if (/= (url-port (or proxy-obj url))
216 (url-scheme-get-property
217 (url-type (or proxy-obj url)) 'default-port))
218 (format
219 "Host: %s:%d\r\n" host (url-port (or proxy-obj url)))
220 (format "Host: %s\r\n" host))
221 ;; Who its from
222 (if url-personal-mail-address
223 (concat
224 "From: " url-personal-mail-address "\r\n"))
225 ;; Encodings we understand
226 (if url-mime-encoding-string
227 (concat
228 "Accept-encoding: " url-mime-encoding-string "\r\n"))
229 (if url-mime-charset-string
230 (concat
231 "Accept-charset: " url-mime-charset-string "\r\n"))
232 ;; Languages we understand
233 (if url-mime-language-string
234 (concat
235 "Accept-language: " url-mime-language-string "\r\n"))
236 ;; Types we understand
237 "Accept: " (or url-mime-accept-string "*/*") "\r\n"
238 ;; User agent
239 (url-http-user-agent-string)
240 ;; Proxy Authorization
241 proxy-auth
242 ;; Authorization
243 auth
244 ;; Cookies
245 (url-cookie-generate-header-lines host real-fname
246 (equal "https" (url-type url)))
247 ;; If-modified-since
248 (if (and (not no-cache)
249 (member url-request-method '("GET" nil)))
250 (let ((tm (url-is-cached (or proxy-obj url))))
251 (if tm
252 (concat "If-modified-since: "
253 (url-get-normalized-date tm) "\r\n"))))
254 ;; Whence we came
255 (if ref-url (concat
256 "Referer: " ref-url "\r\n"))
257 extra-headers
258 ;; Any data
259 (if url-request-data
260 (concat
261 "Content-length: " (number-to-string
262 (length url-request-data))
263 "\r\n\r\n"
264 url-request-data))
265 ;; End request
266 "\r\n"))
267 (url-http-debug "Request is: \n%s" request)
268 request))
269
270;; Parsing routines
271(defun url-http-clean-headers ()
272 "Remove trailing \r from header lines.
273This allows us to use `mail-fetch-field', etc."
274 (declare (special url-http-end-of-headers))
275 (goto-char (point-min))
276 (while (re-search-forward "\r$" url-http-end-of-headers t)
277 (replace-match "")))
278
279(defun url-http-handle-authentication (proxy)
280 (declare (special status success url-http-method url-http-data
281 url-callback-function url-callback-arguments))
282 (url-http-debug "Handling %s authentication" (if proxy "proxy" "normal"))
283 (let ((auth (or (mail-fetch-field (if proxy "proxy-authenticate" "www-authenticate"))
284 "basic"))
285 (type nil)
286 (url (url-recreate-url url-current-object))
287 (url-basic-auth-storage 'url-http-real-basic-auth-storage)
288 )
289
290 ;; Cheating, but who cares? :)
291 (if proxy
292 (setq url-basic-auth-storage 'url-http-proxy-basic-auth-storage))
293
294 (setq auth (url-eat-trailing-space (url-strip-leading-spaces auth)))
295 (if (string-match "[ \t]" auth)
296 (setq type (downcase (substring auth 0 (match-beginning 0))))
297 (setq type (downcase auth)))
298
299 (if (not (url-auth-registered type))
300 (progn
301 (widen)
302 (goto-char (point-max))
303 (insert "<hr>Sorry, but I do not know how to handle " type
304 " authentication. If you'd like to write it,"
305 " send it to " url-bug-address ".<hr>")
306 (setq status t))
307 (let* ((args auth)
308 (ctr (1- (length args)))
309 auth)
310 (while (/= 0 ctr)
311 (if (char-equal ?, (aref args ctr))
312 (aset args ctr ?\;))
313 (setq ctr (1- ctr)))
314 (setq args (url-parse-args args)
315 auth (url-get-authentication url (cdr-safe (assoc "realm" args))
316 type t args))
317 (if (not auth)
318 (setq success t)
319 (push (cons (if proxy "Proxy-Authorization" "Authorization") auth)
320 url-http-extra-headers)
321 (let ((url-request-method url-http-method)
322 (url-request-data url-http-data)
323 (url-request-extra-headers url-http-extra-headers))
324 (url-retrieve url url-callback-function url-callback-arguments))))
325 (kill-buffer (current-buffer)))))
326
327(defun url-http-parse-response ()
328 "Parse just the response code."
329 (declare (special url-http-end-of-headers url-http-response-status))
330 (if (not url-http-end-of-headers)
331 (error "Trying to parse HTTP response code in odd buffer: %s" (buffer-name)))
332 (url-http-debug "url-http-parse-response called in (%s)" (buffer-name))
333 (goto-char (point-min))
334 (skip-chars-forward " \t\n") ; Skip any blank crap
335 (skip-chars-forward "HTTP/") ; Skip HTTP Version
336 (read (current-buffer))
337 (setq url-http-response-status (read (current-buffer))))
338
339(defun url-http-handle-cookies ()
340 "Handle all set-cookie / set-cookie2 headers in an HTTP response.
341The buffer must already be narrowed to the headers, so mail-fetch-field will
342work correctly."
343 (let ((cookies (mail-fetch-field "Set-Cookie" nil nil t))
344 (cookies2 (mail-fetch-field "Set-Cookie2" nil nil t)))
345 (and cookies (url-http-debug "Found %d Set-Cookie headers" (length cookies)))
346 (and cookies2 (url-http-debug "Found %d Set-Cookie2 headers" (length cookies2)))
347 (while cookies
348 (url-cookie-handle-set-cookie (pop cookies)))
349;;; (while cookies2
350;;; (url-cookie-handle-set-cookie2 (pop cookies)))
351 )
352 )
353
354(defun url-http-parse-headers ()
355 "Parse and handle HTTP specific headers.
356Return t if and only if the current buffer is still active and
357should be shown to the user."
358 ;; The comments after each status code handled are taken from RFC
359 ;; 2616 (HTTP/1.1)
360 (declare (special url-http-end-of-headers url-http-response-status
361 url-http-method url-http-data url-http-process
362 url-callback-function url-callback-arguments))
363
364 (url-http-mark-connection-as-free (url-host url-current-object)
365 (url-port url-current-object)
366 url-http-process)
367
368 (if (or (not (boundp 'url-http-end-of-headers))
369 (not url-http-end-of-headers))
370 (error "Trying to parse headers in odd buffer: %s" (buffer-name)))
371 (goto-char (point-min))
372 (url-http-debug "url-http-parse-headers called in (%s)" (buffer-name))
373 (url-http-parse-response)
374 (mail-narrow-to-head)
375 ;;(narrow-to-region (point-min) url-http-end-of-headers)
376 (let ((class nil)
377 (success nil))
378 (setq class (/ url-http-response-status 100))
379 (url-http-debug "Parsed HTTP headers: class=%d status=%d" class url-http-response-status)
380 (url-http-handle-cookies)
381
382 (case class
383 ;; Classes of response codes
384 ;;
385 ;; 5xx = Server Error
386 ;; 4xx = Client Error
387 ;; 3xx = Redirection
388 ;; 2xx = Successful
389 ;; 1xx = Informational
390 (1 ; Information messages
391 ;; 100 = Continue with request
392 ;; 101 = Switching protocols
393 ;; 102 = Processing (Added by DAV)
394 (url-mark-buffer-as-dead (current-buffer))
395 (error "HTTP responses in class 1xx not supported (%d)" url-http-response-status))
396 (2 ; Success
397 ;; 200 Ok
398 ;; 201 Created
399 ;; 202 Accepted
400 ;; 203 Non-authoritative information
401 ;; 204 No content
402 ;; 205 Reset content
403 ;; 206 Partial content
404 ;; 207 Multi-status (Added by DAV)
405 (case url-http-response-status
406 ((204 205)
407 ;; No new data, just stay at the same document
408 (url-mark-buffer-as-dead (current-buffer))
409 (setq success t))
410 (otherwise
411 ;; Generic success for all others. Store in the cache, and
412 ;; mark it as successful.
413 (widen)
414 (if (equal url-http-method "GET")
415 (url-store-in-cache (current-buffer)))
416 (setq success t))))
417 (3 ; Redirection
418 ;; 300 Multiple choices
419 ;; 301 Moved permanently
420 ;; 302 Found
421 ;; 303 See other
422 ;; 304 Not modified
423 ;; 305 Use proxy
424 ;; 307 Temporary redirect
425 (let ((redirect-uri (or (mail-fetch-field "Location")
426 (mail-fetch-field "URI"))))
427 (case url-http-response-status
428 (300
429 ;; Quoth the spec (section 10.3.1)
430 ;; -------------------------------
431 ;; The requested resource corresponds to any one of a set of
432 ;; representations, each with its own specific location and
433 ;; agent-driven negotiation information is being provided so
434 ;; that the user can select a preferred representation and
435 ;; redirect its request to that location.
436 ;; [...]
437 ;; If the server has a preferred choice of representation, it
438 ;; SHOULD include the specific URI for that representation in
439 ;; the Location field; user agents MAY use the Location field
440 ;; value for automatic redirection.
441 ;; -------------------------------
442 ;; We do not support agent-driven negotiation, so we just
443 ;; redirect to the preferred URI if one is provided.
444 nil)
445 ((301 302 307)
446 ;; If the 301|302 status code is received in response to a
447 ;; request other than GET or HEAD, the user agent MUST NOT
448 ;; automatically redirect the request unless it can be
449 ;; confirmed by the user, since this might change the
450 ;; conditions under which the request was issued.
451 (if (member url-http-method '("HEAD" "GET"))
452 ;; Automatic redirection is ok
453 nil
454 ;; It is just too big of a pain in the ass to get this
455 ;; prompt all the time. We will just silently lose our
456 ;; data and convert to a GET method.
457 (url-http-debug "Converting `%s' request to `GET' because of REDIRECT(%d)"
458 url-http-method url-http-response-status)
459 (setq url-http-method "GET"
460 url-request-data nil)))
461 (303
462 ;; The response to the request can be found under a different
463 ;; URI and SHOULD be retrieved using a GET method on that
464 ;; resource.
465 (setq url-http-method "GET"
466 url-http-data nil))
467 (304
468 ;; The 304 response MUST NOT contain a message-body.
469 (url-http-debug "Extracting document from cache... (%s)"
470 (url-cache-create-filename (url-view-url t)))
471 (url-cache-extract (url-cache-create-filename (url-view-url t)))
472 (setq redirect-uri nil
473 success t))
474 (305
475 ;; The requested resource MUST be accessed through the
476 ;; proxy given by the Location field. The Location field
477 ;; gives the URI of the proxy. The recipient is expected
478 ;; to repeat this single request via the proxy. 305
479 ;; responses MUST only be generated by origin servers.
480 (error "Redirection thru a proxy server not supported: %s"
481 redirect-uri))
482 (otherwise
483 ;; Treat everything like '300'
484 nil))
485 (when redirect-uri
486 ;; Clean off any whitespace and/or <...> cruft.
487 (if (string-match "\\([^ \t]+\\)[ \t]" redirect-uri)
488 (setq redirect-uri (match-string 1 redirect-uri)))
489 (if (string-match "^<\\(.*\\)>$" redirect-uri)
490 (setq redirect-uri (match-string 1 redirect-uri)))
491
492 ;; Some stupid sites (like sourceforge) send a
493 ;; non-fully-qualified URL (ie: /), which royally confuses
494 ;; the URL library.
495 (if (not (string-match url-nonrelative-link redirect-uri))
496 (setq redirect-uri (url-expand-file-name redirect-uri)))
497 (let ((url-request-method url-http-method)
498 (url-request-data url-http-data)
499 (url-request-extra-headers url-http-extra-headers))
500 (url-retrieve redirect-uri url-callback-function
501 url-callback-arguments)
502 (url-mark-buffer-as-dead (current-buffer))))))
503 (4 ; Client error
504 ;; 400 Bad Request
505 ;; 401 Unauthorized
506 ;; 402 Payment required
507 ;; 403 Forbidden
508 ;; 404 Not found
509 ;; 405 Method not allowed
510 ;; 406 Not acceptable
511 ;; 407 Proxy authentication required
512 ;; 408 Request time-out
513 ;; 409 Conflict
514 ;; 410 Gone
515 ;; 411 Length required
516 ;; 412 Precondition failed
517 ;; 413 Request entity too large
518 ;; 414 Request-URI too large
519 ;; 415 Unsupported media type
520 ;; 416 Requested range not satisfiable
521 ;; 417 Expectation failed
522 ;; 422 Unprocessable Entity (Added by DAV)
523 ;; 423 Locked
524 ;; 424 Failed Dependency
525 (case url-http-response-status
526 (401
527 ;; The request requires user authentication. The response
528 ;; MUST include a WWW-Authenticate header field containing a
529 ;; challenge applicable to the requested resource. The
530 ;; client MAY repeat the request with a suitable
531 ;; Authorization header field.
532 (url-http-handle-authentication nil))
533 (402
534 ;; This code is reserved for future use
535 (url-mark-buffer-as-dead (current-buffer))
536 (error "Somebody wants you to give them money"))
537 (403
538 ;; The server understood the request, but is refusing to
539 ;; fulfill it. Authorization will not help and the request
540 ;; SHOULD NOT be repeated.
541 (setq success t))
542 (404
543 ;; Not found
544 (setq success t))
545 (405
546 ;; The method specified in the Request-Line is not allowed
547 ;; for the resource identified by the Request-URI. The
548 ;; response MUST include an Allow header containing a list of
549 ;; valid methods for the requested resource.
550 (setq success t))
551 (406
552 ;; The resource identified by the request is only capable of
553 ;; generating response entities which have content
554 ;; characteristics nota cceptable according to the accept
555 ;; headers sent in the request.
556 (setq success t))
557 (407
558 ;; This code is similar to 401 (Unauthorized), but indicates
559 ;; that the client must first authenticate itself with the
560 ;; proxy. The proxy MUST return a Proxy-Authenticate header
561 ;; field containing a challenge applicable to the proxy for
562 ;; the requested resource.
563 (url-http-handle-authentication t))
564 (408
565 ;; The client did not produce a request within the time that
566 ;; the server was prepared to wait. The client MAY repeat
567 ;; the request without modifications at any later time.
568 (setq success t))
569 (409
570 ;; The request could not be completed due to a conflict with
571 ;; the current state of the resource. This code is only
572 ;; allowed in situations where it is expected that the user
573 ;; mioght be able to resolve the conflict and resubmit the
574 ;; request. The response body SHOULD include enough
575 ;; information for the user to recognize the source of the
576 ;; conflict.
577 (setq success t))
578 (410
579 ;; The requested resource is no longer available at the
580 ;; server and no forwarding address is known.
581 (setq success t))
582 (411
583 ;; The server refuses to accept the request without a defined
584 ;; Content-Length. The client MAY repeat the request if it
585 ;; adds a valid Content-Length header field containing the
586 ;; length of the message-body in the request message.
587 ;;
588 ;; NOTE - this will never happen because
589 ;; `url-http-create-request' automatically calculates the
590 ;; content-length.
591 (setq success t))
592 (412
593 ;; The precondition given in one or more of the
594 ;; request-header fields evaluated to false when it was
595 ;; tested on the server.
596 (setq success t))
597 ((413 414)
598 ;; The server is refusing to process a request because the
599 ;; request entity|URI is larger than the server is willing or
600 ;; able to process.
601 (setq success t))
602 (415
603 ;; The server is refusing to service the request because the
604 ;; entity of the request is in a format not supported by the
605 ;; requested resource for the requested method.
606 (setq success t))
607 (416
608 ;; A server SHOULD return a response with this status code if
609 ;; a request included a Range request-header field, and none
610 ;; of the range-specifier values in this field overlap the
611 ;; current extent of the selected resource, and the request
612 ;; did not include an If-Range request-header field.
613 (setq success t))
614 (417
615 ;; The expectation given in an Expect request-header field
616 ;; could not be met by this server, or, if the server is a
617 ;; proxy, the server has unambiguous evidence that the
618 ;; request could not be met by the next-hop server.
619 (setq success t))
620 (otherwise
621 ;; The request could not be understood by the server due to
622 ;; malformed syntax. The client SHOULD NOT repeat the
623 ;; request without modifications.
624 (setq success t))))
625 (5
626 ;; 500 Internal server error
627 ;; 501 Not implemented
628 ;; 502 Bad gateway
629 ;; 503 Service unavailable
630 ;; 504 Gateway time-out
631 ;; 505 HTTP version not supported
632 ;; 507 Insufficient storage
633 (setq success t)
634 (case url-http-response-status
635 (501
636 ;; The server does not support the functionality required to
637 ;; fulfill the request.
638 nil)
639 (502
640 ;; The server, while acting as a gateway or proxy, received
641 ;; an invalid response from the upstream server it accessed
642 ;; in attempting to fulfill the request.
643 nil)
644 (503
645 ;; The server is currently unable to handle the request due
646 ;; to a temporary overloading or maintenance of the server.
647 ;; The implication is that this is a temporary condition
648 ;; which will be alleviated after some delay. If known, the
649 ;; length of the delay MAY be indicated in a Retry-After
650 ;; header. If no Retry-After is given, the client SHOULD
651 ;; handle the response as it would for a 500 response.
652 nil)
653 (504
654 ;; The server, while acting as a gateway or proxy, did not
655 ;; receive a timely response from the upstream server
656 ;; specified by the URI (e.g. HTTP, FTP, LDAP) or some other
657 ;; auxiliary server (e.g. DNS) it needed to access in
658 ;; attempting to complete the request.
659 nil)
660 (505
661 ;; The server does not support, or refuses to support, the
662 ;; HTTP protocol version that was used in the request
663 ;; message.
664 nil)
665 (507 ; DAV
666 ;; The method could not be performed on the resource
667 ;; because the server is unable to store the representation
668 ;; needed to successfully complete the request. This
669 ;; condition is considered to be temporary. If the request
670 ;; which received this status code was the result of a user
671 ;; action, the request MUST NOT be repeated until it is
672 ;; requested by a separate user action.
673 nil)))
674 (otherwise
675 (error "Unknown class of HTTP response code: %d (%d)"
676 class url-http-response-status)))
677 (if (not success)
678 (url-mark-buffer-as-dead (current-buffer)))
679 (url-http-debug "Finished parsing HTTP headers: %S" success)
680 (widen)
681 success))
682
683;; Miscellaneous
684(defun url-http-activate-callback ()
685 "Activate callback specified when this buffer was created."
686 (declare (special url-http-process
687 url-callback-function
688 url-callback-arguments))
689 (url-http-mark-connection-as-free (url-host url-current-object)
690 (url-port url-current-object)
691 url-http-process)
692 (url-http-debug "Activating callback in buffer (%s)" (buffer-name))
693 (apply url-callback-function url-callback-arguments))
694
695;; )
696
697;; These unfortunately cannot be macros... please ignore them!
698(defun url-http-idle-sentinel (proc why)
699 "Remove this (now defunct) process PROC from the list of open connections."
700 (maphash (lambda (key val)
701 (if (memq proc val)
702 (puthash key (delq proc val) url-http-open-connections)))
703 url-http-open-connections))
704
705(defun url-http-end-of-document-sentinel (proc why)
706 ;; Sentinel used for old HTTP/0.9 or connections we know are going
707 ;; to die as the 'end of document' notifier.
708 (url-http-debug "url-http-end-of-document-sentinel in buffer (%s)"
709 (process-buffer proc))
710 (url-http-idle-sentinel proc why)
711 (save-excursion
712 (set-buffer (process-buffer proc))
713 (goto-char (point-min))
714 (if (not (looking-at "HTTP/"))
715 ;; HTTP/0.9 just gets passed back no matter what
716 (url-http-activate-callback)
717 (if (url-http-parse-headers)
718 (url-http-activate-callback)))))
719
720(defun url-http-simple-after-change-function (st nd length)
721 ;; Function used when we do NOT know how long the document is going to be
722 ;; Just _very_ simple 'downloaded %d' type of info.
723 (declare (special url-http-end-of-headers))
724 (url-lazy-message "Reading %s..." (url-pretty-length nd)))
725
726(defun url-http-content-length-after-change-function (st nd length)
727 "Function used when we DO know how long the document is going to be.
728More sophisticated percentage downloaded, etc.
729Also does minimal parsing of HTTP headers and will actually cause
730the callback to be triggered."
731 (declare (special url-current-object
732 url-http-end-of-headers
733 url-http-content-length
734 url-http-content-type
735 url-http-process))
736 (if url-http-content-type
737 (url-display-percentage
738 "Reading [%s]... %s of %s (%d%%)"
739 (url-percentage (- nd url-http-end-of-headers)
740 url-http-content-length)
741 url-http-content-type
742 (url-pretty-length (- nd url-http-end-of-headers))
743 (url-pretty-length url-http-content-length)
744 (url-percentage (- nd url-http-end-of-headers)
745 url-http-content-length))
746 (url-display-percentage
747 "Reading... %s of %s (%d%%)"
748 (url-percentage (- nd url-http-end-of-headers)
749 url-http-content-length)
750 (url-pretty-length (- nd url-http-end-of-headers))
751 (url-pretty-length url-http-content-length)
752 (url-percentage (- nd url-http-end-of-headers)
753 url-http-content-length)))
754
755 (if (> (- nd url-http-end-of-headers) url-http-content-length)
756 (progn
757 ;; Found the end of the document! Wheee!
758 (url-display-percentage nil nil)
759 (message "Reading... done.")
760 (if (url-http-parse-headers)
761 (url-http-activate-callback)))))
762
763(defun url-http-chunked-encoding-after-change-function (st nd length)
764 "Function used when dealing with 'chunked' encoding.
765Cannot give a sophisticated percentage, but we need a different
766function to look for the special 0-length chunk that signifies
767the end of the document."
768 (declare (special url-current-object
769 url-http-end-of-headers
770 url-http-content-type
771 url-http-chunked-length
772 url-http-chunked-counter
773 url-http-process url-http-chunked-start))
774 (save-excursion
775 (goto-char st)
776 (let ((read-next-chunk t)
777 (case-fold-search t)
778 (regexp nil)
779 (no-initial-crlf nil))
780 ;; We need to loop thru looking for more chunks even within
781 ;; one after-change-function call.
782 (while read-next-chunk
783 (setq no-initial-crlf (= 0 url-http-chunked-counter))
784 (if url-http-content-type
785 (url-display-percentage nil
786 "Reading [%s]... chunk #%d"
787 url-http-content-type url-http-chunked-counter)
788 (url-display-percentage nil
789 "Reading... chunk #%d"
790 url-http-chunked-counter))
791 (url-http-debug "Reading chunk %d (%d %d %d)"
792 url-http-chunked-counter st nd length)
793 (setq regexp (if no-initial-crlf
794 "\\([0-9a-z]+\\).*\r?\n"
795 "\r?\n\\([0-9a-z]+\\).*\r?\n"))
796
797 (if url-http-chunked-start
798 ;; We know how long the chunk is supposed to be, skip over
799 ;; leading crap if possible.
800 (if (> nd (+ url-http-chunked-start url-http-chunked-length))
801 (progn
802 (url-http-debug "Got to the end of chunk #%d!"
803 url-http-chunked-counter)
804 (goto-char (+ url-http-chunked-start
805 url-http-chunked-length)))
806 (url-http-debug "Still need %d bytes to hit end of chunk"
807 (- (+ url-http-chunked-start
808 url-http-chunked-length)
809 nd))
810 (setq read-next-chunk nil)))
811 (if (not read-next-chunk)
812 (url-http-debug "Still spinning for next chunk...")
813 (if no-initial-crlf (skip-chars-forward "\r\n"))
814 (if (not (looking-at regexp))
815 (progn
816 ;; Must not have received the entirety of the chunk header,
817 ;; need to spin some more.
818 (url-http-debug "Did not see start of chunk @ %d!" (point))
819 (setq read-next-chunk nil))
820 (add-text-properties (match-beginning 0) (match-end 0)
821 (list 'start-open t
822 'end-open t
823 'chunked-encoding t
824 'face (if (featurep 'xemacs)
825 'text-cursor
826 'cursor)
827 'invisible t))
828 (setq url-http-chunked-length (string-to-int (buffer-substring
829 (match-beginning 1)
830 (match-end 1))
831 16)
832 url-http-chunked-counter (1+ url-http-chunked-counter)
833 url-http-chunked-start (set-marker
834 (or url-http-chunked-start
835 (make-marker))
836 (match-end 0)))
837; (if (not url-http-debug)
838 (delete-region (match-beginning 0) (match-end 0));)
839 (url-http-debug "Saw start of chunk %d (length=%d, start=%d"
840 url-http-chunked-counter url-http-chunked-length
841 (marker-position url-http-chunked-start))
842 (if (= 0 url-http-chunked-length)
843 (progn
844 ;; Found the end of the document! Wheee!
845 (url-http-debug "Saw end of stream chunk!")
846 (setq read-next-chunk nil)
847 (url-display-percentage nil nil)
848 (goto-char (match-end 1))
849 (if (re-search-forward "^\r*$" nil t)
850 (message "Saw end of trailers..."))
851 (if (url-http-parse-headers)
852 (url-http-activate-callback))))))))))
853
854(defun url-http-wait-for-headers-change-function (st nd length)
855 ;; This will wait for the headers to arrive and then splice in the
856 ;; next appropriate after-change-function, etc.
857 (declare (special url-current-object
858 url-http-end-of-headers
859 url-http-content-type
860 url-http-content-length
861 url-http-transfer-encoding
862 url-callback-function
863 url-callback-arguments
864 url-http-process
865 url-http-method
866 url-http-after-change-function
867 url-http-response-status))
868 (url-http-debug "url-http-wait-for-headers-change-function (%s)"
869 (buffer-name))
870 (if (not (bobp))
871 (let ((end-of-headers nil)
872 (old-http nil)
873 (content-length nil))
874 (goto-char (point-min))
875 (if (not (looking-at "^HTTP/[1-9]\\.[0-9]"))
876 ;; Not HTTP/x.y data, must be 0.9
877 ;; God, I wish this could die.
878 (setq end-of-headers t
879 url-http-end-of-headers 0
880 old-http t)
881 (if (re-search-forward "^\r*$" nil t)
882 ;; Saw the end of the headers
883 (progn
884 (url-http-debug "Saw end of headers... (%s)" (buffer-name))
885 (setq url-http-end-of-headers (set-marker (make-marker)
886 (point))
887 end-of-headers t)
888 (url-http-clean-headers))))
889
890 (if (not end-of-headers)
891 ;; Haven't seen the end of the headers yet, need to wait
892 ;; for more data to arrive.
893 nil
894 (if old-http
895 (message "HTTP/0.9 How I hate thee!")
896 (progn
897 (url-http-parse-response)
898 (mail-narrow-to-head)
899 ;;(narrow-to-region (point-min) url-http-end-of-headers)
900 (setq url-http-transfer-encoding (mail-fetch-field
901 "transfer-encoding")
902 url-http-content-type (mail-fetch-field "content-type"))
903 (if (mail-fetch-field "content-length")
904 (setq url-http-content-length
905 (string-to-int (mail-fetch-field "content-length"))))
906 (widen)))
907 (if url-http-transfer-encoding
908 (setq url-http-transfer-encoding
909 (downcase url-http-transfer-encoding)))
910
911 (cond
912 ((or (= url-http-response-status 204)
913 (= url-http-response-status 205))
914 (url-http-debug "%d response must have headers only (%s)."
915 url-http-response-status (buffer-name))
916 (if (url-http-parse-headers)
917 (url-http-activate-callback)))
918 ((string= "HEAD" url-http-method)
919 ;; A HEAD request is _ALWAYS_ terminated by the header
920 ;; information, regardless of any entity headers,
921 ;; according to section 4.4 of the HTTP/1.1 draft.
922 (url-http-debug "HEAD request must have headers only (%s)."
923 (buffer-name))
924 (if (url-http-parse-headers)
925 (url-http-activate-callback)))
926 ((string= "CONNECT" url-http-method)
927 ;; A CONNECT request is finished, but we cannot stick this
928 ;; back on the free connectin list
929 (url-http-debug "CONNECT request must have headers only.")
930 (if (url-http-parse-headers)
931 (url-http-activate-callback)))
932 ((equal url-http-response-status 304)
933 ;; Only allowed to have a header section. We have to handle
934 ;; this here instead of in url-http-parse-headers because if
935 ;; you have a cached copy of something without a known
936 ;; content-length, and try to retrieve it from the cache, we'd
937 ;; fall into the 'being dumb' section and wait for the
938 ;; connection to terminate, which means we'd wait for 10
939 ;; seconds for the keep-alives to time out on some servers.
940 (if (url-http-parse-headers)
941 (url-http-activate-callback)))
942 (old-http
943 ;; HTTP/0.9 always signaled end-of-connection by closing the
944 ;; connection.
945 (url-http-debug
946 "Saw HTTP/0.9 response, connection closed means end of document.")
947 (setq url-http-after-change-function
948 'url-http-simple-after-change-function))
949 ((equal url-http-transfer-encoding "chunked")
950 (url-http-debug "Saw chunked encoding.")
951 (setq url-http-after-change-function
952 'url-http-chunked-encoding-after-change-function)
953 (if (> nd url-http-end-of-headers)
954 (progn
955 (url-http-debug
956 "Calling initial chunked-encoding for extra data at end of headers")
957 (url-http-chunked-encoding-after-change-function
958 (marker-position url-http-end-of-headers) nd
959 (- nd url-http-end-of-headers)))))
960 ((integerp url-http-content-length)
961 (url-http-debug
962 "Got a content-length, being smart about document end.")
963 (setq url-http-after-change-function
964 'url-http-content-length-after-change-function)
965 (cond
966 ((= 0 url-http-content-length)
967 ;; We got a NULL body! Activate the callback
968 ;; immediately!
969 (url-http-debug
970 "Got 0-length content-length, activating callback immediately.")
971 (if (url-http-parse-headers)
972 (url-http-activate-callback)))
973 ((> nd url-http-end-of-headers)
974 ;; Have some leftover data
975 (url-http-debug "Calling initial content-length for extra data at end of headers")
976 (url-http-content-length-after-change-function
977 (marker-position url-http-end-of-headers)
978 nd
979 (- nd url-http-end-of-headers)))
980 (t
981 nil)))
982 (t
983 (url-http-debug "No content-length, being dumb.")
984 (setq url-http-after-change-function
985 'url-http-simple-after-change-function)))))
986 ;; We are still at the beginning of the buffer... must just be
987 ;; waiting for a response.
988 (url-http-debug "Spinning waiting for headers..."))
989 (goto-char (point-max)))
990
991;;;###autoload
992(defun url-http (url callback cbargs)
993 "Retrieve URL via HTTP asynchronously.
994URL must be a parsed URL. See `url-generic-parse-url' for details.
995When retrieval is completed, the function CALLBACK is executed with
996CBARGS as the arguments."
997 (check-type url vector "Need a pre-parsed URL.")
998 (declare (special url-current-object
999 url-http-end-of-headers
1000 url-http-content-type
1001 url-http-content-length
1002 url-http-transfer-encoding
1003 url-http-after-change-function
1004 url-callback-function
1005 url-callback-arguments
1006 url-http-method
1007 url-http-extra-headers
1008 url-http-data
1009 url-http-chunked-length
1010 url-http-chunked-start
1011 url-http-chunked-counter
1012 url-http-process))
1013 (let ((connection (url-http-find-free-connection (url-host url)
1014 (url-port url)))
1015 (buffer (generate-new-buffer (format " *http %s:%d*"
1016 (url-host url)
1017 (url-port url)))))
1018 (if (not connection)
1019 ;; Failed to open the connection for some reason
1020 (progn
1021 (kill-buffer buffer)
1022 (setq buffer nil)
1023 (error "Could not create connection to %s:%d" (url-host url)
1024 (url-port url)))
1025 (save-excursion
1026 (set-buffer buffer)
1027 (mm-disable-multibyte)
1028 (setq url-current-object url
1029 mode-line-format "%b [%s]")
1030
1031 (dolist (var '(url-http-end-of-headers
1032 url-http-content-type
1033 url-http-content-length
1034 url-http-transfer-encoding
1035 url-http-after-change-function
1036 url-http-response-status
1037 url-http-chunked-length
1038 url-http-chunked-counter
1039 url-http-chunked-start
1040 url-callback-function
1041 url-callback-arguments
1042 url-http-process
1043 url-http-method
1044 url-http-extra-headers
1045 url-http-data))
1046 (set (make-local-variable var) nil))
1047
1048 (setq url-http-method (or url-request-method "GET")
1049 url-http-extra-headers url-request-extra-headers
1050 url-http-data url-request-data
1051 url-http-process connection
1052 url-http-chunked-length nil
1053 url-http-chunked-start nil
1054 url-http-chunked-counter 0
1055 url-callback-function callback
1056 url-callback-arguments cbargs
1057 url-http-after-change-function 'url-http-wait-for-headers-change-function)
1058
1059 (set-process-buffer connection buffer)
1060 (set-process-sentinel connection 'url-http-end-of-document-sentinel)
1061 (set-process-filter connection 'url-http-generic-filter)
1062 (process-send-string connection (url-http-create-request url))))
1063 buffer))
1064
1065;; Since Emacs 19/20 does not allow you to change the
1066;; `after-change-functions' hook in the midst of running them, we fake
1067;; an after change by hooking into the process filter and inserting
1068;; the data ourselves. This is slightly less efficient, but there
1069;; were tons of weird ways the after-change code was biting us in the
1070;; shorts.
1071(defun url-http-generic-filter (proc data)
1072 ;; Sometimes we get a zero-length data chunk after the process has
1073 ;; been changed to 'free', which means it has no buffer associated
1074 ;; with it. Do nothing if there is no buffer, or 0 length data.
1075 (declare (special url-http-after-change-function))
1076 (and (process-buffer proc)
1077 (/= (length data) 0)
1078 (save-excursion
1079 (set-buffer (process-buffer proc))
1080 (url-http-debug "Calling after change function `%s' for `%S'" url-http-after-change-function proc)
1081 (funcall url-http-after-change-function
1082 (point-max)
1083 (progn
1084 (goto-char (point-max))
1085 (insert data)
1086 (point-max))
1087 (length data)))))
1088
1089;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1090;;; file-name-handler stuff from here on out
1091;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1092(if (not (fboundp 'symbol-value-in-buffer))
1093 (defun url-http-symbol-value-in-buffer (symbol buffer
1094 &optional unbound-value)
1095 "Return the value of SYMBOL in BUFFER, or UNBOUND-VALUE if it is unbound."
1096 (save-excursion
1097 (set-buffer buffer)
1098 (if (not (boundp symbol))
1099 unbound-value
1100 (symbol-value symbol))))
1101 (defalias 'url-http-symbol-value-in-buffer 'symbol-value-in-buffer))
1102
1103(defun url-http-head (url)
1104 (let ((url-request-method "HEAD")
1105 (url-request-data nil))
1106 (url-retrieve-synchronously url)))
1107
1108;;;###autoload
1109(defun url-http-file-exists-p (url)
1110 (let ((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 &optional id-format)
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 &optional id-format)
1141 (if (url-dav-supported-p url)
1142 (url-dav-file-attributes url id-format)
1143 (url-http-head-file-attributes url id-format)))
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;; arch-tag: ba7c59ae-c0f4-4a31-9617-d85f221732ee
1224;;; 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..11b2593ea80
--- /dev/null
+++ b/lisp/url/url-https.el
@@ -0,0 +1,56 @@
1;;; url-https.el --- HTTP over SSL routines
2
3;; Copyright (c) 1999, 2004 Free Software Foundation, Inc.
4
5;; Keywords: comm, data, processes
6
7;; This file is part of GNU Emacs.
8;;
9;; GNU Emacs is free software; you can redistribute it and/or modify
10;; it under the terms of the GNU General Public License as published by
11;; the Free Software Foundation; either version 2, or (at your option)
12;; any later version.
13;;
14;; GNU Emacs is distributed in the hope that it will be useful,
15;; but WITHOUT ANY WARRANTY; without even the implied warranty of
16;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17;; GNU General Public License for more details.
18;;
19;; You should have received a copy of the GNU General Public License
20;; along with GNU Emacs; see the file COPYING. If not, write to the
21;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
22;; Boston, MA 02111-1307, USA.
23
24;;; Commentary:
25
26;;; Code:
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 &optional id-format))
52
53(provide 'url-https)
54
55;; arch-tag: c3645ac5-c248-4d12-ad41-7c4b6f7b6d19
56;;; url-https.el ends here
diff --git a/lisp/url/url-nfs.el b/lisp/url/url-nfs.el
new file mode 100644
index 00000000000..d068341b1c2
--- /dev/null
+++ b/lisp/url/url-nfs.el
@@ -0,0 +1,100 @@
1;;; url-nfs.el --- NFS URL interface
2
3;; Copyright (c) 1996,97,98,1999,2004 Free Software Foundation, Inc.
4;; Copyright (c) 1996 by William M. Perry <wmperry@cs.indiana.edu>
5
6;; Keywords: comm, data, processes
7
8;; This file is part of GNU Emacs.
9;;
10;; GNU Emacs is free software; you can redistribute it and/or modify
11;; it under the terms of the GNU General Public License as published by
12;; the Free Software Foundation; either version 2, or (at your option)
13;; any later version.
14;;
15;; GNU Emacs is distributed in the hope that it will be useful,
16;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18;; GNU General Public License for more details.
19;;
20;; You should have received a copy of the GNU General Public License
21;; along with GNU Emacs; see the file COPYING. If not, write to the
22;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
23;; Boston, MA 02111-1307, USA.
24
25;;; Commentary:
26
27;;; Code:
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 &optional id-format))
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)
98
99;; arch-tag: cdf9c9ba-b7d2-4c29-8b48-7ae9bbc0d437
100;;; url-nfs.el ends here
diff --git a/lisp/url/url-util.el b/lisp/url/url-util.el
new file mode 100644
index 00000000000..d4a3733eab5
--- /dev/null
+++ b/lisp/url/url-util.el
@@ -0,0 +1,508 @@
1;;; url-util.el --- Miscellaneous helper routines for URL library
2
3;; Copyright (c) 1996,97,98,99,2001,2004 Free Software Foundation, Inc.
4;; Copyright (c) 1993 - 1996 by William M. Perry <wmperry@cs.indiana.edu>
5
6;; Author: Bill Perry <wmperry@gnu.org>
7;; Keywords: comm, data, processes
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;;; Commentary:
27
28;;; Code:
29
30(require 'url-parse)
31(autoload 'timezone-parse-date "timezone")
32(autoload 'timezone-make-date-arpa-standard "timezone")
33(autoload 'mail-header-extract "mailheader")
34
35(defvar url-parse-args-syntax-table
36 (copy-syntax-table emacs-lisp-mode-syntax-table)
37 "A syntax table for parsing sgml attributes.")
38
39(modify-syntax-entry ?' "\"" url-parse-args-syntax-table)
40(modify-syntax-entry ?` "\"" url-parse-args-syntax-table)
41(modify-syntax-entry ?{ "(" url-parse-args-syntax-table)
42(modify-syntax-entry ?} ")" url-parse-args-syntax-table)
43
44;;;###autoload
45(defcustom url-debug nil
46 "*What types of debug messages from the URL library to show.
47Debug messages are logged to the *URL-DEBUG* buffer.
48
49If t, all messages will be logged.
50If a number, all messages will be logged, as well shown via `message'.
51If a list, it is a list of the types of messages to be logged."
52 :type '(choice (const :tag "none" nil)
53 (const :tag "all" t)
54 (checklist :tag "custom"
55 (const :tag "HTTP" :value http)
56 (const :tag "DAV" :value dav)
57 (const :tag "General" :value retrieval)
58 (const :tag "Filename handlers" :value handlers)
59 (symbol :tag "Other")))
60 :group 'url-hairy)
61
62;;;###autoload
63(defun url-debug (tag &rest args)
64 (if quit-flag
65 (error "Interrupted!"))
66 (if (or (eq url-debug t)
67 (numberp url-debug)
68 (and (listp url-debug) (memq tag url-debug)))
69 (with-current-buffer (get-buffer-create "*URL-DEBUG*")
70 (goto-char (point-max))
71 (insert (symbol-name tag) " -> " (apply 'format args) "\n")
72 (if (numberp url-debug)
73 (apply 'message args)))))
74
75;;;###autoload
76(defun url-parse-args (str &optional nodowncase)
77 ;; Return an assoc list of attribute/value pairs from an RFC822-type string
78 (let (
79 name ; From name=
80 value ; its value
81 results ; Assoc list of results
82 name-pos ; Start of XXXX= position
83 val-pos ; Start of value position
84 st
85 nd
86 )
87 (save-excursion
88 (save-restriction
89 (set-buffer (get-buffer-create " *urlparse-temp*"))
90 (set-syntax-table url-parse-args-syntax-table)
91 (erase-buffer)
92 (insert str)
93 (setq st (point-min)
94 nd (point-max))
95 (set-syntax-table url-parse-args-syntax-table)
96 (narrow-to-region st nd)
97 (goto-char (point-min))
98 (while (not (eobp))
99 (skip-chars-forward "; \n\t")
100 (setq name-pos (point))
101 (skip-chars-forward "^ \n\t=;")
102 (if (not nodowncase)
103 (downcase-region name-pos (point)))
104 (setq name (buffer-substring name-pos (point)))
105 (skip-chars-forward " \t\n")
106 (if (/= (or (char-after (point)) 0) ?=) ; There is no value
107 (setq value nil)
108 (skip-chars-forward " \t\n=")
109 (setq val-pos (point)
110 value
111 (cond
112 ((or (= (or (char-after val-pos) 0) ?\")
113 (= (or (char-after val-pos) 0) ?'))
114 (buffer-substring (1+ val-pos)
115 (condition-case ()
116 (prog2
117 (forward-sexp 1)
118 (1- (point))
119 (skip-chars-forward "\""))
120 (error
121 (skip-chars-forward "^ \t\n")
122 (point)))))
123 (t
124 (buffer-substring val-pos
125 (progn
126 (skip-chars-forward "^;")
127 (skip-chars-backward " \t")
128 (point)))))))
129 (setq results (cons (cons name value) results))
130 (skip-chars-forward "; \n\t"))
131 results))))
132
133;;;###autoload
134(defun url-insert-entities-in-string (string)
135 "Convert HTML markup-start characters to entity references in STRING.
136Also replaces the \" character, so that the result may be safely used as
137 an attribute value in a tag. Returns a new string with the result of the
138 conversion. Replaces these characters as follows:
139 & ==> &amp;
140 < ==> &lt;
141 > ==> &gt;
142 \" ==> &quot;"
143 (if (string-match "[&<>\"]" string)
144 (save-excursion
145 (set-buffer (get-buffer-create " *entity*"))
146 (erase-buffer)
147 (buffer-disable-undo (current-buffer))
148 (insert string)
149 (goto-char (point-min))
150 (while (progn
151 (skip-chars-forward "^&<>\"")
152 (not (eobp)))
153 (insert (cdr (assq (char-after (point))
154 '((?\" . "&quot;")
155 (?& . "&amp;")
156 (?< . "&lt;")
157 (?> . "&gt;")))))
158 (delete-char 1))
159 (buffer-string))
160 string))
161
162;;;###autoload
163(defun url-normalize-url (url)
164 "Return a 'normalized' version of URL.
165Strips out default port numbers, etc."
166 (let (type data grok retval)
167 (setq data (url-generic-parse-url url)
168 type (url-type data))
169 (if (member type '("www" "about" "mailto" "info"))
170 (setq retval url)
171 (url-set-target data nil)
172 (setq retval (url-recreate-url data)))
173 retval))
174
175;;;###autoload
176(defun url-lazy-message (&rest args)
177 "Just like `message', but is a no-op if called more than once a second.
178Will not do anything if `url-show-status' is nil."
179 (if (or (null url-show-status)
180 (active-minibuffer-window)
181 (= url-lazy-message-time
182 (setq url-lazy-message-time (nth 1 (current-time)))))
183 nil
184 (apply 'message args)))
185
186;;;###autoload
187(defun url-get-normalized-date (&optional specified-time)
188 "Return a 'real' date string that most HTTP servers can understand."
189 (require 'timezone)
190 (let* ((raw (if specified-time (current-time-string specified-time)
191 (current-time-string)))
192 (gmt (timezone-make-date-arpa-standard raw
193 (nth 1 (current-time-zone))
194 "GMT"))
195 (parsed (timezone-parse-date gmt))
196 (day (cdr-safe (assoc (substring raw 0 3) weekday-alist)))
197 (year nil)
198 (month (car
199 (rassoc
200 (string-to-int (aref parsed 1)) monthabbrev-alist)))
201 )
202 (setq day (or (car-safe (rassoc day weekday-alist))
203 (substring raw 0 3))
204 year (aref parsed 0))
205 ;; This is needed for plexus servers, or the server will hang trying to
206 ;; parse the if-modified-since header. Hopefully, I can take this out
207 ;; soon.
208 (if (and year (> (length year) 2))
209 (setq year (substring year -2 nil)))
210
211 (concat day ", " (aref parsed 2) "-" month "-" year " "
212 (aref parsed 3) " " (or (aref parsed 4)
213 (concat "[" (nth 1 (current-time-zone))
214 "]")))))
215
216;;;###autoload
217(defun url-eat-trailing-space (x)
218 "Remove spaces/tabs at the end of a string."
219 (let ((y (1- (length x)))
220 (skip-chars (list ? ?\t ?\n)))
221 (while (and (>= y 0) (memq (aref x y) skip-chars))
222 (setq y (1- y)))
223 (substring x 0 (1+ y))))
224
225;;;###autoload
226(defun url-strip-leading-spaces (x)
227 "Remove spaces at the front of a string."
228 (let ((y (1- (length x)))
229 (z 0)
230 (skip-chars (list ? ?\t ?\n)))
231 (while (and (<= z y) (memq (aref x z) skip-chars))
232 (setq z (1+ z)))
233 (substring x z nil)))
234
235;;;###autoload
236(defun url-pretty-length (n)
237 (cond
238 ((< n 1024)
239 (format "%d bytes" n))
240 ((< n (* 1024 1024))
241 (format "%dk" (/ n 1024.0)))
242 (t
243 (format "%2.2fM" (/ n (* 1024 1024.0))))))
244
245;;;###autoload
246(defun url-display-percentage (fmt perc &rest args)
247 (if (null fmt)
248 (if (fboundp 'clear-progress-display)
249 (clear-progress-display))
250 (if (and (fboundp 'progress-display) perc)
251 (apply 'progress-display fmt perc args)
252 (apply 'message fmt args))))
253
254;;;###autoload
255(defun url-percentage (x y)
256 (if (fboundp 'float)
257 (round (* 100 (/ x (float y))))
258 (/ (* x 100) y)))
259
260;;;###autoload
261(defun url-basepath (file &optional x)
262 "Return the base pathname of FILE, or the actual filename if X is true."
263 (cond
264 ((null file) "")
265 ((string-match (eval-when-compile (regexp-quote "?")) file)
266 (if x
267 (file-name-nondirectory (substring file 0 (match-beginning 0)))
268 (file-name-directory (substring file 0 (match-beginning 0)))))
269 (x (file-name-nondirectory file))
270 (t (file-name-directory file))))
271
272;;;###autoload
273(defun url-parse-query-string (query &optional downcase)
274 (let (retval pairs cur key val)
275 (setq pairs (split-string query "&"))
276 (while pairs
277 (setq cur (car pairs)
278 pairs (cdr pairs))
279 (if (not (string-match "=" cur))
280 nil ; Grace
281 (setq key (url-unhex-string (substring cur 0 (match-beginning 0)))
282 val (url-unhex-string (substring cur (match-end 0) nil)))
283 (if downcase
284 (setq key (downcase key)))
285 (setq cur (assoc key retval))
286 (if cur
287 (setcdr cur (cons val (cdr cur)))
288 (setq retval (cons (list key val) retval)))))
289 retval))
290
291(defun url-unhex (x)
292 (if (> x ?9)
293 (if (>= x ?a)
294 (+ 10 (- x ?a))
295 (+ 10 (- x ?A)))
296 (- x ?0)))
297
298;; Fixme: Is this definition better, and does it ever matter?
299
300;; (defun url-unhex-string (str &optional allow-newlines)
301;; "Remove %XX, embedded spaces, etc in a url.
302;; If optional second argument ALLOW-NEWLINES is non-nil, then allow the
303;; decoding of carriage returns and line feeds in the string, which is normally
304;; forbidden in URL encoding."
305;; (setq str (or str ""))
306;; (setq str (replace-regexp-in-string "%[[:xdigit:]]\\{2\\}"
307;; (lambda (match)
308;; (string (string-to-number
309;; (substring match 1) 16)))
310;; str t t))
311;; (if allow-newlines
312;; (replace-regexp-in-string "[\n\r]" (lambda (match)
313;; (format "%%%.2X" (aref match 0)))
314;; str t t)
315;; str))
316
317;;;###autoload
318(defun url-unhex-string (str &optional allow-newlines)
319 "Remove %XX embedded spaces, etc in a url.
320If optional second argument ALLOW-NEWLINES is non-nil, then allow the
321decoding of carriage returns and line feeds in the string, which is normally
322forbidden in URL encoding."
323 (setq str (or str ""))
324 (let ((tmp "")
325 (case-fold-search t))
326 (while (string-match "%[0-9a-f][0-9a-f]" str)
327 (let* ((start (match-beginning 0))
328 (ch1 (url-unhex (elt str (+ start 1))))
329 (code (+ (* 16 ch1)
330 (url-unhex (elt str (+ start 2))))))
331 (setq tmp (concat
332 tmp (substring str 0 start)
333 (cond
334 (allow-newlines
335 (char-to-string code))
336 ((or (= code ?\n) (= code ?\r))
337 " ")
338 (t (char-to-string code))))
339 str (substring str (match-end 0)))))
340 (setq tmp (concat tmp str))
341 tmp))
342
343(defconst url-unreserved-chars
344 '(
345 ?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
346 ?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
347 ?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9
348 ?- ?_ ?. ?! ?~ ?* ?' ?\( ?\))
349 "A list of characters that are _NOT_ reserved in the URL spec.
350This is taken from RFC 2396.")
351
352;;;###autoload
353(defun url-hexify-string (str)
354 "Escape characters in a string."
355 (mapconcat
356 (lambda (char)
357 ;; Fixme: use a char table instead.
358 (if (not (memq char url-unreserved-chars))
359 (if (> char 255)
360 (error "Hexifying multibyte character %s" str)
361 (format "%%%02X" char))
362 (char-to-string char)))
363 str ""))
364
365;;;###autoload
366(defun url-file-extension (fname &optional x)
367 "Return the filename extension of FNAME.
368If optional variable X is t,
369then return the basename of the file with the extension stripped off."
370 (if (and fname
371 (setq fname (url-basepath fname t))
372 (string-match "\\.[^./]+$" fname))
373 (if x (substring fname 0 (match-beginning 0))
374 (substring fname (match-beginning 0) nil))
375 ;;
376 ;; If fname has no extension, and x then return fname itself instead of
377 ;; nothing. When caching it allows the correct .hdr file to be produced
378 ;; for filenames without extension.
379 ;;
380 (if x
381 fname
382 "")))
383
384;;;###autoload
385(defun url-truncate-url-for-viewing (url &optional width)
386 "Return a shortened version of URL that is WIDTH characters or less wide.
387WIDTH defaults to the current frame width."
388 (let* ((fr-width (or width (frame-width)))
389 (str-width (length url))
390 (tail (file-name-nondirectory url))
391 (fname nil)
392 (modified 0)
393 (urlobj nil))
394 ;; The first thing that can go are the search strings
395 (if (and (>= str-width fr-width)
396 (string-match "?" url))
397 (setq url (concat (substring url 0 (match-beginning 0)) "?...")
398 str-width (length url)
399 tail (file-name-nondirectory url)))
400 (if (< str-width fr-width)
401 nil ; Hey, we are done!
402 (setq urlobj (url-generic-parse-url url)
403 fname (url-filename urlobj)
404 fr-width (- fr-width 4))
405 (while (and (>= str-width fr-width)
406 (string-match "/" fname))
407 (setq fname (substring fname (match-end 0) nil)
408 modified (1+ modified))
409 (url-set-filename urlobj fname)
410 (setq url (url-recreate-url urlobj)
411 str-width (length url)))
412 (if (> modified 1)
413 (setq fname (concat "/.../" fname))
414 (setq fname (concat "/" fname)))
415 (url-set-filename urlobj fname)
416 (setq url (url-recreate-url urlobj)))
417 url))
418
419;;;###autoload
420(defun url-view-url (&optional no-show)
421 "View the current document's URL.
422Optional argument NO-SHOW means just return the URL, don't show it in
423the minibuffer.
424
425This uses `url-current-object', set locally to the buffer."
426 (interactive)
427 (if (not url-current-object)
428 nil
429 (if no-show
430 (url-recreate-url url-current-object)
431 (message "%s" (url-recreate-url url-current-object)))))
432
433(eval-and-compile
434 (defvar url-get-url-filename-chars "-%.?@a-zA-Z0-9()_/:~=&"
435 "Valid characters in a URL")
436 )
437
438(defun url-get-url-at-point (&optional pt)
439 "Get the URL closest to point, but don't change position.
440Has a preference for looking backward when not directly on a symbol."
441 ;; Not at all perfect - point must be right in the name.
442 (save-excursion
443 (if pt (goto-char pt))
444 (let (start url)
445 (save-excursion
446 ;; first see if you're just past a filename
447 (if (not (eobp))
448 (if (looking-at "[] \t\n[{}()]") ; whitespace or some parens
449 (progn
450 (skip-chars-backward " \n\t\r({[]})")
451 (if (not (bobp))
452 (backward-char 1)))))
453 (if (and (char-after (point))
454 (string-match (eval-when-compile
455 (concat "[" url-get-url-filename-chars "]"))
456 (char-to-string (char-after (point)))))
457 (progn
458 (skip-chars-backward url-get-url-filename-chars)
459 (setq start (point))
460 (skip-chars-forward url-get-url-filename-chars))
461 (setq start (point)))
462 (setq url (buffer-substring-no-properties start (point))))
463 (if (and url (string-match "^(.*)\\.?$" url))
464 (setq url (match-string 1 url)))
465 (if (and url (string-match "^URL:" url))
466 (setq url (substring url 4 nil)))
467 (if (and url (string-match "\\.$" url))
468 (setq url (substring url 0 -1)))
469 (if (and url (string-match "^www\\." url))
470 (setq url (concat "http://" url)))
471 (if (and url (not (string-match url-nonrelative-link url)))
472 (setq url nil))
473 url)))
474
475(defun url-generate-unique-filename (&optional fmt)
476 "Generate a unique filename in `url-temporary-directory'."
477 (if (not fmt)
478 (let ((base (format "url-tmp.%d" (user-real-uid)))
479 (fname "")
480 (x 0))
481 (setq fname (format "%s%d" base x))
482 (while (file-exists-p
483 (expand-file-name fname url-temporary-directory))
484 (setq x (1+ x)
485 fname (concat base (int-to-string x))))
486 (expand-file-name fname url-temporary-directory))
487 (let ((base (concat "url" (int-to-string (user-real-uid))))
488 (fname "")
489 (x 0))
490 (setq fname (format fmt (concat base (int-to-string x))))
491 (while (file-exists-p
492 (expand-file-name fname url-temporary-directory))
493 (setq x (1+ x)
494 fname (format fmt (concat base (int-to-string x)))))
495 (expand-file-name fname url-temporary-directory))))
496
497(defun url-extract-mime-headers ()
498 "Set `url-current-mime-headers' in current buffer."
499 (save-excursion
500 (goto-char (point-min))
501 (unless url-current-mime-headers
502 (set (make-local-variable 'url-current-mime-headers)
503 (mail-header-extract)))))
504
505(provide 'url-util)
506
507;; arch-tag: 24352abc-5a5a-412e-90cd-313b26bed5c9
508;;; url-util.el ends here
generated by cgit v1.2.1 (git 2.18.0) at 2026-04-08 03:48:17 +0000