; Do not overwrite preexisting contents of unread-command-events
[emacs.git] / lisp / url / url-dav.el
Commit [+]AuthorDateLineData
8c8b8430
SM
Stefan Monnier2004-04-04 01:21:46 +00001;;; url-dav.el --- WebDAV support
2
7e09ef09 Paul Eggert2015-01-01 14:26:41 -08003;; Copyright (C) 2001, 2004-2015 Free Software Foundation, Inc.
8c8b8430
SM
Stefan Monnier2004-04-04 01:21:46 +00004
5;; Author: Bill Perry <wmperry@gnu.org>
93a583ee Glenn Morris2014-03-28 20:55:44 -04006;; Maintainer: emacs-devel@gnu.org
8c8b8430
SM
Stefan Monnier2004-04-04 01:21:46 +00007;; Keywords: url, vc
8
76827ca4
SM
Stefan Monnier2004-04-12 20:42:44 +00009;; This file is part of GNU Emacs.
10
4936186e Glenn Morris2008-05-06 04:29:13 +000011;; GNU Emacs is free software: you can redistribute it and/or modify
8c8b8430 Stefan Monnier2004-04-04 01:21:46 +000012;; it under the terms of the GNU General Public License as published by
4936186e
GM
Glenn Morris2008-05-06 04:29:13 +000013;; the Free Software Foundation, either version 3 of the License, or
14;; (at your option) any later version.
8c8b8430
SM
Stefan Monnier2004-04-04 01:21:46 +000015
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
4936186e Glenn Morris2008-05-06 04:29:13 +000022;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
8c8b8430 Stefan Monnier2004-04-04 01:21:46 +000023
0aa70d32
SM
Stefan Monnier2004-04-12 04:03:16 +000024;; DAV is in RFC 2518.
25
76827ca4
SM
Stefan Monnier2004-04-12 20:42:44 +000026;;; Commentary:
27
28;;; Code:
29
a464a6c7 Stefan Monnier2012-07-11 19:13:41 -040030(eval-when-compile (require 'cl-lib))
8c8b8430
SM
Stefan Monnier2004-04-04 01:21:46 +000031
32(require 'xml)
33(require 'url-util)
34(require 'url-handlers)
f440830d Glenn Morris2013-05-21 00:25:14 -070035(require 'url-http)
8c8b8430
SM
Stefan Monnier2004-04-04 01:21:46 +000036
37(defvar url-dav-supported-protocols '(1 2)
38 "List of supported DAV versions.")
39
f440830d Glenn Morris2013-05-21 00:25:14 -070040;; Dynamically bound.
a464a6c7
SM
Stefan Monnier2012-07-11 19:13:41 -040041(defvar url-http-content-type)
42(defvar url-http-response-status)
43(defvar url-http-end-of-headers)
44
0aa70d32 Stefan Monnier2004-04-12 04:03:16 +000045(defun url-intersection (l1 l2)
d1ce47b0 Juanma Barranquero2008-07-02 11:14:38 +000046 "Return a list of the elements occurring in both of the lists L1 and L2."
0aa70d32
SM
Stefan Monnier2004-04-12 04:03:16 +000047 (if (null l2)
48 l2
49 (let (result)
50 (while l1
51 (if (member (car l1) l2)
52 (setq result (cons (pop l1) result))
53 (pop l1)))
54 (nreverse result))))
55
8c8b8430
SM
Stefan Monnier2004-04-04 01:21:46 +000056;;;###autoload
57(defun url-dav-supported-p (url)
7fa20d96
DE
David Engster2012-07-28 13:07:17 +020058 "Return WebDAV protocol version supported by URL.
59Returns nil if WebDAV is not supported."
60 (url-intersection url-dav-supported-protocols
61 (plist-get (url-http-options url) 'dav)))
8c8b8430
SM
Stefan Monnier2004-04-04 01:21:46 +000062
63(defun url-dav-node-text (node)
64 "Return the text data from the XML node NODE."
65 (mapconcat (lambda (txt)
66 (if (stringp txt)
67 txt
68 "")) (xml-node-children node) " "))
69
70\f
71;;; Parsing routines for the actual node contents.
76827ca4
SM
Stefan Monnier2004-04-12 20:42:44 +000072;;
73;; I am not incredibly happy with how this code looks/works right
74;; now, but it DOES work, and if we get the API right, our callers
75;; won't have to worry about the internal representation.
8c8b8430
SM
Stefan Monnier2004-04-04 01:21:46 +000076
77(defconst url-dav-datatype-attribute
78 'urn:uuid:c2f41010-65b3-11d1-a29f-00aa00c14882/dt)
79
80(defun url-dav-process-integer-property (node)
81 (truncate (string-to-number (url-dav-node-text node))))
82
83(defun url-dav-process-number-property (node)
84 (string-to-number (url-dav-node-text node)))
85
86(defconst url-dav-iso8601-regexp
87 (let* ((dash "-?")
88 (colon ":?")
89 (4digit "\\([0-9][0-9][0-9][0-9]\\)")
90 (2digit "\\([0-9][0-9]\\)")
91 (date-fullyear 4digit)
92 (date-month 2digit)
93 (date-mday 2digit)
94 (time-hour 2digit)
95 (time-minute 2digit)
96 (time-second 2digit)
97 (time-secfrac "\\(\\.[0-9]+\\)?")
98 (time-numoffset (concat "[-+]\\(" time-hour "\\):" time-minute))
99 (time-offset (concat "Z" time-numoffset))
100 (partial-time (concat time-hour colon time-minute colon time-second
101 time-secfrac))
102 (full-date (concat date-fullyear dash date-month dash date-mday))
103 (full-time (concat partial-time time-offset))
104 (date-time (concat full-date "T" full-time)))
105 (list (concat "^" full-date)
106 (concat "T" partial-time)
107 (concat "Z" time-numoffset)))
d1ce47b0 Juanma Barranquero2008-07-02 11:14:38 +0000108 "List of regular expressions matching ISO 8601 dates.
8c8b8430
SM
Stefan Monnier2004-04-04 01:21:46 +00001091st regular expression matches the date.
1102nd regular expression matches the time.
76827ca4 Stefan Monnier2004-04-12 20:42:44 +00001113rd regular expression matches the (optional) timezone specification.")
8c8b8430
SM
Stefan Monnier2004-04-04 01:21:46 +0000112
113(defun url-dav-process-date-property (node)
114 (require 'parse-time)
115 (let* ((date-re (nth 0 url-dav-iso8601-regexp))
116 (time-re (nth 1 url-dav-iso8601-regexp))
117 (tz-re (nth 2 url-dav-iso8601-regexp))
118 (date-string (url-dav-node-text node))
119 re-start
120 time seconds minute hour fractional-seconds
121 day month year day-of-week dst tz)
122 ;; We need to populate 'time' with
123 ;; (SEC MIN HOUR DAY MON YEAR DOW DST TZ)
124
c7015153 Juanma Barranquero2011-11-15 18:37:37 +0100125 ;; Nobody else handles iso8601 correctly, let's do it ourselves.
8c8b8430 Stefan Monnier2004-04-04 01:21:46 +0000126 (when (string-match date-re date-string re-start)
216d3806
JB
Juanma Barranquero2005-05-16 10:07:59 +0000127 (setq year (string-to-number (match-string 1 date-string))
128 month (string-to-number (match-string 2 date-string))
129 day (string-to-number (match-string 3 date-string))
8c8b8430
SM
Stefan Monnier2004-04-04 01:21:46 +0000130 re-start (match-end 0))
131 (when (string-match time-re date-string re-start)
216d3806
JB
Juanma Barranquero2005-05-16 10:07:59 +0000132 (setq hour (string-to-number (match-string 1 date-string))
133 minute (string-to-number (match-string 2 date-string))
134 seconds (string-to-number (match-string 3 date-string))
135 fractional-seconds (string-to-number (or
136 (match-string 4 date-string)
137 "0"))
8c8b8430
SM
Stefan Monnier2004-04-04 01:21:46 +0000138 re-start (match-end 0))
139 (when (string-match tz-re date-string re-start)
140 (setq tz (match-string 1 date-string)))
141 (url-debug 'dav "Parsed iso8601%s date" (if tz "tz" ""))
142 (setq time (list seconds minute hour day month year day-of-week dst tz))))
143
144 ;; Fall back to having Gnus do fancy things for us.
145 (when (not time)
146 (setq time (parse-time-string date-string)))
147
148 (if time
149 (setq time (apply 'encode-time time))
150 (url-debug 'dav "Unable to decode date (%S) (%s)"
151 (xml-node-name node) date-string))
152 time))
153
154(defun url-dav-process-boolean-property (node)
216d3806 Juanma Barranquero2005-05-16 10:07:59 +0000155 (/= 0 (string-to-number (url-dav-node-text node))))
8c8b8430
SM
Stefan Monnier2004-04-04 01:21:46 +0000156
157(defun url-dav-process-uri-property (node)
158 ;; Returns a parsed representation of the URL...
159 (url-generic-parse-url (url-dav-node-text node)))
160
161(defun url-dav-find-parser (node)
162 "Find a function to parse the XML node NODE."
163 (or (get (xml-node-name node) 'dav-parser)
164 (let ((fn (intern (format "url-dav-process-%s" (xml-node-name node)))))
165 (if (not (fboundp fn))
166 (setq fn 'url-dav-node-text)
167 (put (xml-node-name node) 'dav-parser fn))
168 fn)))
169
170(defmacro url-dav-dispatch-node (node)
171 `(funcall (url-dav-find-parser ,node) ,node))
172
173(defun url-dav-process-DAV:prop (node)
174 ;; A prop node has content model of ANY
175 ;;
176 ;; Some predefined nodes have special meanings though.
177 ;;
178 ;; DAV:supportedlock - list of DAV:lockentry
179 ;; DAV:source
180 ;; DAV:iscollection - boolean
181 ;; DAV:getcontentlength - integer
182 ;; DAV:ishidden - boolean
183 ;; DAV:getcontenttype - string
184 ;; DAV:resourcetype - node who's name is the resource type
185 ;; DAV:getlastmodified - date
186 ;; DAV:creationdate - date
187 ;; DAV:displayname - string
188 ;; DAV:getetag - unknown
189 (let ((children (xml-node-children node))
190 (node-type nil)
191 (props nil)
192 (value nil)
193 (handler-func nil))
194 (when (not children)
195 (error "No child nodes in DAV:prop"))
196
197 (while children
198 (setq node (car children)
199 node-type (intern
259b63b4 Juanma Barranquero2007-09-26 00:39:23 +0000200 (or
8c8b8430
SM
Stefan Monnier2004-04-04 01:21:46 +0000201 (cdr-safe (assq url-dav-datatype-attribute
202 (xml-node-attributes node)))
203 "unknown"))
204 value nil)
205
a464a6c7
SM
Stefan Monnier2012-07-11 19:13:41 -0400206 (pcase node-type
207 ((or `dateTime.iso8601tz
208 `dateTime.iso8601
209 `dateTime.tz
210 `dateTime.rfc1123
211 `dateTime
212 `date) ; date is our 'special' one...
8c8b8430
SM
Stefan Monnier2004-04-04 01:21:46 +0000213 ;; Some type of date/time string.
214 (setq value (url-dav-process-date-property node)))
a464a6c7 Stefan Monnier2012-07-11 19:13:41 -0400215 (`int
8c8b8430
SM
Stefan Monnier2004-04-04 01:21:46 +0000216 ;; Integer type...
217 (setq value (url-dav-process-integer-property node)))
a464a6c7 Stefan Monnier2012-07-11 19:13:41 -0400218 ((or `number `float)
8c8b8430 Stefan Monnier2004-04-04 01:21:46 +0000219 (setq value (url-dav-process-number-property node)))
a464a6c7 Stefan Monnier2012-07-11 19:13:41 -0400220 (`boolean
8c8b8430 Stefan Monnier2004-04-04 01:21:46 +0000221 (setq value (url-dav-process-boolean-property node)))
a464a6c7 Stefan Monnier2012-07-11 19:13:41 -0400222 (`uri
8c8b8430 Stefan Monnier2004-04-04 01:21:46 +0000223 (setq value (url-dav-process-uri-property node)))
a464a6c7 Stefan Monnier2012-07-11 19:13:41 -0400224 (_
8c8b8430
SM
Stefan Monnier2004-04-04 01:21:46 +0000225 (if (not (eq node-type 'unknown))
226 (url-debug 'dav "Unknown data type in url-dav-process-prop: %s"
227 node-type))
228 (setq value (url-dav-dispatch-node node))))
229
230 (setq props (plist-put props (xml-node-name node) value)
231 children (cdr children)))
232 props))
233
234(defun url-dav-process-DAV:supportedlock (node)
235 ;; DAV:supportedlock is a list of DAV:lockentry items.
236 ;; DAV:lockentry in turn contains a DAV:lockscope and DAV:locktype.
237 ;; The DAV:lockscope must have a single node beneath it, ditto for
238 ;; DAV:locktype.
239 (let ((children (xml-node-children node))
240 (results nil)
241 scope type)
242 (while children
243 (when (and (not (stringp (car children)))
244 (eq (xml-node-name (car children)) 'DAV:lockentry))
245 (setq scope (assq 'DAV:lockscope (xml-node-children (car children)))
246 type (assq 'DAV:locktype (xml-node-children (car children))))
247 (when (and scope type)
248 (setq scope (xml-node-name (car (xml-node-children scope)))
249 type (xml-node-name (car (xml-node-children type))))
250 (push (cons type scope) results)))
251 (setq children (cdr children)))
252 results))
253
254(defun url-dav-process-subnode-property (node)
255 ;; Returns a list of child node names.
256 (delq nil (mapcar 'car-safe (xml-node-children node))))
257
258(defalias 'url-dav-process-DAV:depth 'url-dav-process-integer-property)
259(defalias 'url-dav-process-DAV:resourcetype 'url-dav-process-subnode-property)
260(defalias 'url-dav-process-DAV:locktype 'url-dav-process-subnode-property)
261(defalias 'url-dav-process-DAV:lockscope 'url-dav-process-subnode-property)
262(defalias 'url-dav-process-DAV:getcontentlength 'url-dav-process-integer-property)
263(defalias 'url-dav-process-DAV:getlastmodified 'url-dav-process-date-property)
264(defalias 'url-dav-process-DAV:creationdate 'url-dav-process-date-property)
265(defalias 'url-dav-process-DAV:iscollection 'url-dav-process-boolean-property)
266(defalias 'url-dav-process-DAV:ishidden 'url-dav-process-boolean-property)
267
268(defun url-dav-process-DAV:locktoken (node)
269 ;; DAV:locktoken can have one or more DAV:href children.
270 (delq nil (mapcar (lambda (n)
271 (if (stringp n)
272 n
273 (url-dav-dispatch-node n)))
274 (xml-node-children node))))
275
276(defun url-dav-process-DAV:owner (node)
277 ;; DAV:owner can contain anything.
278 (delq nil (mapcar (lambda (n)
279 (if (stringp n)
280 n
281 (url-dav-dispatch-node n)))
282 (xml-node-children node))))
283
284(defun url-dav-process-DAV:activelock (node)
285 ;; DAV:activelock can contain:
286 ;; DAV:lockscope
287 ;; DAV:locktype
288 ;; DAV:depth
289 ;; DAV:owner (optional)
290 ;; DAV:timeout (optional)
291 ;; DAV:locktoken (optional)
292 (let ((children (xml-node-children node))
293 (results nil))
294 (while children
295 (if (listp (car children))
296 (push (cons (xml-node-name (car children))
297 (url-dav-dispatch-node (car children)))
298 results))
299 (setq children (cdr children)))
300 results))
301
302(defun url-dav-process-DAV:lockdiscovery (node)
303 ;; Can only contain a list of DAV:activelock objects.
304 (let ((children (xml-node-children node))
305 (results nil))
306 (while children
307 (cond
308 ((stringp (car children))
309 ;; text node? why?
310 nil)
311 ((eq (xml-node-name (car children)) 'DAV:activelock)
312 (push (url-dav-dispatch-node (car children)) results))
313 (t
314 ;; Ignore unknown nodes...
315 nil))
316 (setq children (cdr children)))
317 results))
318
319(defun url-dav-process-DAV:status (node)
320 ;; The node contains a standard HTTP/1.1 response line... we really
321 ;; only care about the numeric status code.
322 (let ((status (url-dav-node-text node)))
323 (if (string-match "\\`[ \r\t\n]*HTTP/[0-9.]+ \\([0-9]+\\)" status)
216d3806 Juanma Barranquero2005-05-16 10:07:59 +0000324 (string-to-number (match-string 1 status))
8c8b8430
SM
Stefan Monnier2004-04-04 01:21:46 +0000325 500)))
326
327(defun url-dav-process-DAV:propstat (node)
328 ;; A propstate node can have the following children...
329 ;;
330 ;; DAV:prop - a list of properties and values
331 ;; DAV:status - An HTTP/1.1 status line
332 (let ((children (xml-node-children node))
333 (props nil)
334 (status nil))
335 (when (not children)
336 (error "No child nodes in DAV:propstat"))
337
338 (setq props (url-dav-dispatch-node (assq 'DAV:prop children))
339 status (url-dav-dispatch-node (assq 'DAV:status children)))
340
341 ;; Need to parse out the HTTP status
342 (setq props (plist-put props 'DAV:status status))
343 props))
344
345(defun url-dav-process-DAV:response (node)
346 (let ((children (xml-node-children node))
347 (propstat nil)
348 (href))
349 (when (not children)
350 (error "No child nodes in DAV:response"))
351
352 ;; A response node can have the following children...
353 ;;
354 ;; DAV:href - URL the response is for.
355 ;; DAV:propstat - see url-dav-process-propstat
356 ;; DAV:responsedescription - text description of the response
357 (setq propstat (assq 'DAV:propstat children)
358 href (assq 'DAV:href children))
359
360 (when (not href)
361 (error "No href in DAV:response"))
362
363 (when (not propstat)
364 (error "No propstat in DAV:response"))
365
366 (setq propstat (url-dav-dispatch-node propstat)
367 href (url-dav-dispatch-node href))
368 (cons href propstat)))
369
370(defun url-dav-process-DAV:multistatus (node)
371 (let ((children (xml-node-children node))
372 (results nil))
373 (while children
374 (push (url-dav-dispatch-node (car children)) results)
375 (setq children (cdr children)))
376 results))
377
378\f
379;;; DAV request/response generation/processing
380(defun url-dav-process-response (buffer url)
76827ca4 Stefan Monnier2004-04-12 20:42:44 +0000381 "Parse a WebDAV response from BUFFER, interpreting it relative to URL.
8c8b8430
SM
Stefan Monnier2004-04-04 01:21:46 +0000382
383The buffer must have been retrieved by HTTP or HTTPS and contain an
76827ca4 Stefan Monnier2004-04-12 20:42:44 +0000384XML document."
8c8b8430
SM
Stefan Monnier2004-04-04 01:21:46 +0000385 (let ((tree nil)
386 (overall-status nil))
387 (when buffer
388 (unwind-protect
f1bfaf65 Stefan Monnier2004-04-16 21:58:11 +0000389 (with-current-buffer buffer
7fa20d96 David Engster2012-07-28 13:07:17 +0200390 ;; First remove all indentation and line endings
8c8b8430 Stefan Monnier2004-04-04 01:21:46 +0000391 (goto-char url-http-end-of-headers)
7fa20d96
DE
David Engster2012-07-28 13:07:17 +0200392 (indent-rigidly (point) (point-max) -1000)
393 (save-excursion
394 (while (re-search-forward "\r?\n" nil t)
395 (replace-match "")))
8c8b8430
SM
Stefan Monnier2004-04-04 01:21:46 +0000396 (setq overall-status url-http-response-status)
397
398 ;; XML documents can be transferred as either text/xml or
399 ;; application/xml, and we are required to accept both of
400 ;; them.
401 (if (and
402 url-http-content-type
f1bfaf65
SM
Stefan Monnier2004-04-16 21:58:11 +0000403 (string-match "\\`\\(text\\|application\\)/xml"
404 url-http-content-type))
7fa20d96 David Engster2012-07-28 13:07:17 +0200405 (setq tree (xml-parse-region (point) (point-max) nil nil 'symbol-qnames))))
8c8b8430 Stefan Monnier2004-04-04 01:21:46 +0000406 ;; Clean up after ourselves.
f1bfaf65 Stefan Monnier2004-04-16 21:58:11 +0000407 (kill-buffer buffer)))
8c8b8430 Stefan Monnier2004-04-04 01:21:46 +0000408
f1bfaf65 Stefan Monnier2004-04-16 21:58:11 +0000409 ;; We should now be
8c8b8430
SM
Stefan Monnier2004-04-04 01:21:46 +0000410 (if (eq (xml-node-name (car tree)) 'DAV:multistatus)
411 (url-dav-dispatch-node (car tree))
412 (url-debug 'dav "Got back singleton response for URL(%S)" url)
413 (let ((properties (url-dav-dispatch-node (car tree))))
414 ;; We need to make sure we have a DAV:status node in there for
415 ;; higher-level code;
416 (setq properties (plist-put properties 'DAV:status overall-status))
417 ;; Make this look like a DAV:multistatus parse tree so that
418 ;; nobody but us needs to know the difference.
419 (list (cons url properties))))))
420
7fa20d96 David Engster2012-07-28 13:07:17 +0200421;;;###autoload
8c8b8430
SM
Stefan Monnier2004-04-04 01:21:46 +0000422(defun url-dav-request (url method tag body
423 &optional depth headers namespaces)
76827ca4 Stefan Monnier2004-04-12 20:42:44 +0000424 "Perform WebDAV operation METHOD on URL. Return the parsed responses.
8c8b8430
SM
Stefan Monnier2004-04-04 01:21:46 +0000425Automatically creates an XML request body if TAG is non-nil.
426BODY is the XML document fragment to be enclosed by <TAG></TAG>.
427
e1dbe924 Paul Eggert2011-11-19 18:29:42 -0800428DEPTH is how deep the request should propagate. Default is 0, meaning
8c8b8430
SM
Stefan Monnier2004-04-04 01:21:46 +0000429it should apply only to URL. A negative number means to use
430`Infinity' for the depth. Not all WebDAV servers support this depth
431though.
432
433HEADERS is an assoc list of extra headers to send in the request.
434
435NAMESPACES is an assoc list of (NAMESPACE . EXPANSION), and these are
436added to the <TAG> element. The DAV=DAV: namespace is automatically
76827ca4 Stefan Monnier2004-04-12 20:42:44 +0000437added to this list, so most requests can just pass in nil."
8c8b8430
SM
Stefan Monnier2004-04-04 01:21:46 +0000438 ;; Take care of the default value for depth...
439 (setq depth (or depth 0))
440
c7015153 Juanma Barranquero2011-11-15 18:37:37 +0100441 ;; Now let's translate it into something webdav can understand.
8c8b8430
SM
Stefan Monnier2004-04-04 01:21:46 +0000442 (if (< depth 0)
443 (setq depth "Infinity")
444 (setq depth (int-to-string depth)))
445 (if (not (assoc "DAV" namespaces))
446 (setq namespaces (cons '("DAV" . "DAV:") namespaces)))
447
448 (let* ((url-request-extra-headers `(("Depth" . ,depth)
449 ("Content-type" . "text/xml")
450 ,@headers))
451 (url-request-method method)
452 (url-request-data
453 (if tag
454 (concat
455 "<?xml version=\"1.0\" encoding=\"utf-8\" ?>\n"
456 "<" (symbol-name tag) " "
457 ;; add in the appropriate namespaces...
458 (mapconcat (lambda (ns)
459 (concat "xmlns:" (car ns) "='" (cdr ns) "'"))
460 namespaces "\n ")
461 ">\n"
462 body
463 "</" (symbol-name tag) ">\n"))))
464 (url-dav-process-response (url-retrieve-synchronously url) url)))
465
8c8b8430
SM
Stefan Monnier2004-04-04 01:21:46 +0000466(defun url-dav-get-properties (url &optional attributes depth namespaces)
467 "Return properties for URL, up to DEPTH levels deep.
468
469Returns an assoc list, where the key is the filename (possibly a full
470URI), and the value is a standard property list of DAV property
76827ca4 Stefan Monnier2004-04-12 20:42:44 +0000471names (ie: DAV:resourcetype)."
8c8b8430
SM
Stefan Monnier2004-04-04 01:21:46 +0000472 (url-dav-request url "PROPFIND" 'DAV:propfind
473 (if attributes
474 (mapconcat (lambda (attr)
475 (concat "<DAV:prop><"
476 (symbol-name attr)
477 "/></DAV:prop>"))
478 attributes "\n ")
479 " <DAV:allprop/>")
480 depth nil namespaces))
481
be307485 Stefan Monnier2014-12-05 12:49:53 -0500482(define-inline url-dav-http-success-p (status)
d1ce47b0 Juanma Barranquero2008-07-02 11:14:38 +0000483 "Return whether STATUS was the result of a successful DAV request."
be307485 Stefan Monnier2014-12-05 12:49:53 -0500484 (inline-quote (= (/ (or ,status 500) 100) 2)))
8c8b8430
SM
Stefan Monnier2004-04-04 01:21:46 +0000485
486\f
487;;; Locking support
488(defvar url-dav-lock-identifier (concat "mailto:" user-mail-address)
fb7ada5f Chong Yidong2012-04-09 21:05:48 +0800489 "URL used as contact information when creating locks in DAV.
8c8b8430
SM
Stefan Monnier2004-04-04 01:21:46 +0000490This will be used as the contents of the DAV:owner/DAV:href tag to
491identify the owner of a LOCK when requesting it. This will be shown
492to other users when the DAV:lockdiscovery property is requested, so
76827ca4 Stefan Monnier2004-04-12 20:42:44 +0000493make sure you are comfortable with it leaking to the outside world.")
8c8b8430 Stefan Monnier2004-04-04 01:21:46 +0000494
8c8b8430
SM
Stefan Monnier2004-04-04 01:21:46 +0000495(defun url-dav-lock-resource (url exclusive &optional depth)
496 "Request a lock on URL. If EXCLUSIVE is non-nil, get an exclusive lock.
497Optional 3rd argument DEPTH says how deep the lock should go, default is 0
498\(lock only the resource and none of its children\).
499
500Returns a cons-cell of (SUCCESSFUL-RESULTS . FAILURE-RESULTS).
501SUCCESSFUL-RESULTS is a list of (URL STATUS locktoken).
76827ca4 Stefan Monnier2004-04-12 20:42:44 +0000502FAILURE-RESULTS is a list of (URL STATUS)."
8c8b8430
SM
Stefan Monnier2004-04-04 01:21:46 +0000503 (setq exclusive (if exclusive "<DAV:exclusive/>" "<DAV:shared/>"))
504 (let* ((body
505 (concat
506 " <DAV:lockscope>" exclusive "</DAV:lockscope>\n"
507 " <DAV:locktype> <DAV:write/> </DAV:locktype>\n"
508 " <DAV:owner>\n"
509 " <DAV:href>" url-dav-lock-identifier "</DAV:href>\n"
510 " </DAV:owner>\n"))
511 (response nil) ; Responses to the LOCK request
512 (result nil) ; For walking thru the response list
513 (child-url nil)
514 (child-status nil)
515 (failures nil) ; List of failure cases (URL . STATUS)
516 (successes nil)) ; List of success cases (URL . STATUS)
517 (setq response (url-dav-request url "LOCK" 'DAV:lockinfo body
518 depth '(("Timeout" . "Infinite"))))
519
520 ;; Get the parent URL ready for expand-file-name
521 (if (not (vectorp url))
522 (setq url (url-generic-parse-url url)))
523
524 ;; Walk thru the response list, fully expand the URL, and grab the
525 ;; status code.
526 (while response
527 (setq result (pop response)
528 child-url (url-expand-file-name (pop result) url)
529 child-status (or (plist-get result 'DAV:status) 500))
530 (if (url-dav-http-success-p child-status)
531 (push (list url child-status "huh") successes)
532 (push (list url child-status) failures)))
533 (cons successes failures)))
534
8c8b8430
SM
Stefan Monnier2004-04-04 01:21:46 +0000535(defun url-dav-active-locks (url &optional depth)
536 "Return an assoc list of all active locks on URL."
537 (let ((response (url-dav-get-properties url '(DAV:lockdiscovery) depth))
538 (properties nil)
539 (child nil)
540 (child-url nil)
541 (child-results nil)
542 (results nil))
543 (if (not (vectorp url))
544 (setq url (url-generic-parse-url url)))
545
546 (while response
547 (setq child (pop response)
548 child-url (pop child)
549 child-results nil)
550 (when (and (url-dav-http-success-p (plist-get child 'DAV:status))
551 (setq child (plist-get child 'DAV:lockdiscovery)))
552 ;; After our parser has had its way with it, The
553 ;; DAV:lockdiscovery property is a list of DAV:activelock
554 ;; objects, which are comprised of DAV:activelocks, which
555 ;; assoc lists of properties and values.
556 (while child
557 (if (assq 'DAV:locktoken (car child))
558 (let ((tokens (cdr (assq 'DAV:locktoken (car child))))
559 (owners (cdr (assq 'DAV:owner (car child)))))
560 (dolist (token tokens)
561 (dolist (owner owners)
562 (push (cons token owner) child-results)))))
563 (pop child)))
564 (if child-results
565 (push (cons (url-expand-file-name child-url url) child-results)
566 results)))
567 results))
568
8c8b8430
SM
Stefan Monnier2004-04-04 01:21:46 +0000569(defun url-dav-unlock-resource (url lock-token)
570 "Release the lock on URL represented by LOCK-TOKEN.
3ecd3a56 Glenn Morris2007-08-08 07:27:21 +0000571Returns t if the lock was successfully released."
8c8b8430
SM
Stefan Monnier2004-04-04 01:21:46 +0000572 (let* ((url-request-extra-headers (list (cons "Lock-Token"
573 (concat "<" lock-token ">"))))
574 (url-request-method "UNLOCK")
575 (url-request-data nil)
576 (buffer (url-retrieve-synchronously url))
577 (result nil))
578 (when buffer
579 (unwind-protect
f1bfaf65 Stefan Monnier2004-04-16 21:58:11 +0000580 (with-current-buffer buffer
8c8b8430
SM
Stefan Monnier2004-04-04 01:21:46 +0000581 (setq result (url-dav-http-success-p url-http-response-status)))
582 (kill-buffer buffer)))
583 result))
584
585\f
586;;; file-name-handler stuff
587(defun url-dav-file-attributes-mode-string (properties)
588 (let ((modes (make-string 10 ?-))
589 (supported-locks (plist-get properties 'DAV:supportedlock))
590 (executable-p (equal (plist-get properties 'http://apache.org/dav/props/executable)
591 "T"))
592 (directory-p (memq 'DAV:collection (plist-get properties 'DAV:resourcetype)))
593 (readable t)
594 (lock nil))
595 ;; Assume we can read this, otherwise the PROPFIND would have
596 ;; failed.
597 (when readable
598 (aset modes 1 ?r)
599 (aset modes 4 ?r)
600 (aset modes 7 ?r))
601
602 (when directory-p
603 (aset modes 0 ?d))
604
605 (when executable-p
606 (aset modes 3 ?x)
607 (aset modes 6 ?x)
608 (aset modes 9 ?x))
609
610 (while supported-locks
611 (setq lock (car supported-locks)
612 supported-locks (cdr supported-locks))
a464a6c7
SM
Stefan Monnier2012-07-11 19:13:41 -0400613 (pcase (car lock)
614 (`DAV:write
615 (pcase (cdr lock)
616 (`DAV:shared ; group permissions (possibly world)
8c8b8430 Stefan Monnier2004-04-04 01:21:46 +0000617 (aset modes 5 ?w))
a464a6c7 Stefan Monnier2012-07-11 19:13:41 -0400618 (`DAV:exclusive
8c8b8430 Stefan Monnier2004-04-04 01:21:46 +0000619 (aset modes 2 ?w)) ; owner permissions?
a464a6c7 Stefan Monnier2012-07-11 19:13:41 -0400620 (_
8c8b8430 Stefan Monnier2004-04-04 01:21:46 +0000621 (url-debug 'dav "Unrecognized DAV:lockscope (%S)" (cdr lock)))))
a464a6c7 Stefan Monnier2012-07-11 19:13:41 -0400622 (_
8c8b8430
SM
Stefan Monnier2004-04-04 01:21:46 +0000623 (url-debug 'dav "Unrecognized DAV:locktype (%S)" (car lock)))))
624 modes))
625
f1bfaf65 Stefan Monnier2004-04-16 21:58:11 +0000626(defun url-dav-file-attributes (url &optional id-format)
5e047764 Stefan Monnier2006-09-20 17:35:21 +0000627 (let ((properties (cdar (url-dav-get-properties url))))
8c8b8430
SM
Stefan Monnier2004-04-04 01:21:46 +0000628 (if (and properties
629 (url-dav-http-success-p (plist-get properties 'DAV:status)))
630 ;; We got a good DAV response back..
5e047764
SM
Stefan Monnier2006-09-20 17:35:21 +0000631 (list
632 ;; t for directory, string for symbolic link, or nil
633 ;; Need to support DAV Bindings to figure out the
634 ;; symbolic link issues.
635 (if (memq 'DAV:collection (plist-get properties 'DAV:resourcetype)) t nil)
8c8b8430 Stefan Monnier2004-04-04 01:21:46 +0000636
5e047764
SM
Stefan Monnier2006-09-20 17:35:21 +0000637 ;; Number of links to file... Needs DAV Bindings.
638 1
8c8b8430 Stefan Monnier2004-04-04 01:21:46 +0000639
5e047764
SM
Stefan Monnier2006-09-20 17:35:21 +0000640 ;; File uid - no way to figure out?
641 0
8c8b8430 Stefan Monnier2004-04-04 01:21:46 +0000642
5e047764
SM
Stefan Monnier2006-09-20 17:35:21 +0000643 ;; File gid - no way to figure out?
644 0
8c8b8430 Stefan Monnier2004-04-04 01:21:46 +0000645
5e047764
SM
Stefan Monnier2006-09-20 17:35:21 +0000646 ;; Last access time - ???
647 nil
8c8b8430 Stefan Monnier2004-04-04 01:21:46 +0000648
5e047764
SM
Stefan Monnier2006-09-20 17:35:21 +0000649 ;; Last modification time
650 (plist-get properties 'DAV:getlastmodified)
8c8b8430 Stefan Monnier2004-04-04 01:21:46 +0000651
5e047764
SM
Stefan Monnier2006-09-20 17:35:21 +0000652 ;; Last status change time... just reuse last-modified
653 ;; for now.
654 (plist-get properties 'DAV:getlastmodified)
8c8b8430 Stefan Monnier2004-04-04 01:21:46 +0000655
5e047764
SM
Stefan Monnier2006-09-20 17:35:21 +0000656 ;; size in bytes
657 (or (plist-get properties 'DAV:getcontentlength) 0)
8c8b8430 Stefan Monnier2004-04-04 01:21:46 +0000658
5e047764 Stefan Monnier2006-09-20 17:35:21 +0000659 ;; file modes as a string like `ls -l'
3ecd3a56 Glenn Morris2007-08-08 07:27:21 +0000660 ;;
5e047764
SM
Stefan Monnier2006-09-20 17:35:21 +0000661 ;; Should be able to build this up from the
662 ;; DAV:supportedlock attribute pretty easily. Getting
663 ;; the group info could be impossible though.
664 (url-dav-file-attributes-mode-string properties)
8c8b8430 Stefan Monnier2004-04-04 01:21:46 +0000665
3ecd3a56 Glenn Morris2007-08-08 07:27:21 +0000666 ;; t if file's gid would change if it were deleted &
5e047764
SM
Stefan Monnier2006-09-20 17:35:21 +0000667 ;; recreated. No way for us to know that thru DAV.
668 nil
8c8b8430 Stefan Monnier2004-04-04 01:21:46 +0000669
5e047764
SM
Stefan Monnier2006-09-20 17:35:21 +0000670 ;; inode number - meaningless
671 nil
8c8b8430 Stefan Monnier2004-04-04 01:21:46 +0000672
5e047764
SM
Stefan Monnier2006-09-20 17:35:21 +0000673 ;; device number - meaningless
674 nil)
8c8b8430 Stefan Monnier2004-04-04 01:21:46 +0000675 ;; Fall back to just the normal http way of doing things.
5e047764 Stefan Monnier2006-09-20 17:35:21 +0000676 (url-http-head-file-attributes url id-format))))
8c8b8430 Stefan Monnier2004-04-04 01:21:46 +0000677
8c8b8430
SM
Stefan Monnier2004-04-04 01:21:46 +0000678(defun url-dav-save-resource (url obj &optional content-type lock-token)
679 "Save OBJ as URL using WebDAV.
680URL must be a fully qualified URL.
681OBJ may be a buffer or a string."
682 (let ((buffer nil)
683 (result nil)
684 (url-request-extra-headers nil)
685 (url-request-method "PUT")
686 (url-request-data
687 (cond
688 ((bufferp obj)
f1bfaf65 Stefan Monnier2004-04-16 21:58:11 +0000689 (with-current-buffer obj
8c8b8430
SM
Stefan Monnier2004-04-04 01:21:46 +0000690 (buffer-string)))
691 ((stringp obj)
692 obj)
693 (t
694 (error "Invalid object to url-dav-save-resource")))))
695
696 (if lock-token
697 (push
698 (cons "If" (concat "(<" lock-token ">)"))
699 url-request-extra-headers))
700
701 ;; Everything must always have a content-type when we submit it.
702 (push
703 (cons "Content-type" (or content-type "application/octet-stream"))
704 url-request-extra-headers)
705
706 ;; Do the save...
707 (setq buffer (url-retrieve-synchronously url))
708
709 ;; Sanity checking
710 (when buffer
711 (unwind-protect
f1bfaf65 Stefan Monnier2004-04-16 21:58:11 +0000712 (with-current-buffer buffer
8c8b8430
SM
Stefan Monnier2004-04-04 01:21:46 +0000713 (setq result (url-dav-http-success-p url-http-response-status)))
714 (kill-buffer buffer)))
715 result))
716
717(eval-when-compile
718 (defmacro url-dav-delete-something (url lock-token &rest error-checking)
719 "Delete URL completely, with no sanity checking whatsoever. DO NOT USE.
720This is defined as a macro that will not be visible from compiled files.
d1ce47b0 Juanma Barranquero2008-07-02 11:14:38 +0000721Use with care, and even then think three times."
8c8b8430
SM
Stefan Monnier2004-04-04 01:21:46 +0000722 `(progn
723 ,@error-checking
724 (url-dav-request ,url "DELETE" nil nil -1
725 (if ,lock-token
726 (list
727 (cons "If"
728 (concat "(<" ,lock-token ">)"))))))))
729
730
8c8b8430
SM
Stefan Monnier2004-04-04 01:21:46 +0000731(defun url-dav-delete-directory (url &optional recursive lock-token)
732 "Delete the WebDAV collection URL.
733If optional second argument RECURSIVE is non-nil, then delete all
76827ca4 Stefan Monnier2004-04-12 20:42:44 +0000734files in the collection as well."
8c8b8430
SM
Stefan Monnier2004-04-04 01:21:46 +0000735 (let ((status nil)
736 (props nil)
737 (props nil))
738 (setq props (url-dav-delete-something
739 url lock-token
740 (setq props (url-dav-get-properties url '(DAV:getcontenttype) 1))
741 (if (and (not recursive)
742 (/= (length props) 1))
743 (signal 'file-error (list "Removing directory"
8dd58a2d Paul Eggert2015-01-21 20:21:45 -0800744 "Directory not empty" url)))))
8c8b8430
SM
Stefan Monnier2004-04-04 01:21:46 +0000745
746 (mapc (lambda (result)
747 (setq status (plist-get (cdr result) 'DAV:status))
748 (if (not (url-dav-http-success-p status))
749 (signal 'file-error (list "Removing directory"
3d54861a Glenn Morris2007-12-02 18:01:10 +0000750 "Error removing"
8c8b8430
SM
Stefan Monnier2004-04-04 01:21:46 +0000751 (car result) status))))
752 props))
753 nil)
754
8c8b8430
SM
Stefan Monnier2004-04-04 01:21:46 +0000755(defun url-dav-delete-file (url &optional lock-token)
756 "Delete file named URL."
757 (let ((props nil)
758 (status nil))
759 (setq props (url-dav-delete-something
760 url lock-token
761 (setq props (url-dav-get-properties url))
762 (if (eq (plist-get (cdar props) 'DAV:resourcetype) 'DAV:collection)
8dd58a2d Paul Eggert2015-01-21 20:21:45 -0800763 (signal 'file-error (list "Removing old name" "Is a collection" url)))))
8c8b8430
SM
Stefan Monnier2004-04-04 01:21:46 +0000764
765 (mapc (lambda (result)
766 (setq status (plist-get (cdr result) 'DAV:status))
767 (if (not (url-dav-http-success-p status))
768 (signal 'file-error (list "Removing old name"
c7015153 Juanma Barranquero2011-11-15 18:37:37 +0100769 "Error removing"
8c8b8430
SM
Stefan Monnier2004-04-04 01:21:46 +0000770 (car result) status))))
771 props))
772 nil)
773
8c8b8430 Stefan Monnier2004-04-04 01:21:46 +0000774(defun url-dav-directory-files (url &optional full match nosort files-only)
d1ce47b0 Juanma Barranquero2008-07-02 11:14:38 +0000775 "Return a list of names of files in URL.
8c8b8430 Stefan Monnier2004-04-04 01:21:46 +0000776There are three optional arguments:
7fa20d96
DE
David Engster2012-07-28 13:07:17 +0200777If FULL is non-nil, return absolute URLs. Otherwise return names
778 that are relative to the specified URL.
8c8b8430
SM
Stefan Monnier2004-04-04 01:21:46 +0000779If MATCH is non-nil, mention only file names that match the regexp MATCH.
780If NOSORT is non-nil, the list is not sorted--its order is unpredictable.
76827ca4 Stefan Monnier2004-04-12 20:42:44 +0000781 NOSORT is useful if you plan to sort the result yourself."
8c8b8430
SM
Stefan Monnier2004-04-04 01:21:46 +0000782 (let ((properties (url-dav-get-properties url '(DAV:resourcetype) 1))
783 (child-url nil)
784 (child-props nil)
785 (files nil)
786 (parsed-url (url-generic-parse-url url)))
787
7fa20d96
DE
David Engster2012-07-28 13:07:17 +0200788 (when (and (= (length properties) 1)
789 (not (url-dav-file-directory-p url)))
8dd58a2d Paul Eggert2015-01-21 20:21:45 -0800790 (signal 'file-error (list "Opening directory" "Not a directory" url)))
8c8b8430
SM
Stefan Monnier2004-04-04 01:21:46 +0000791
792 (while properties
793 (setq child-props (pop properties)
794 child-url (pop child-props))
795 (if (and (eq (plist-get child-props 'DAV:resourcetype) 'DAV:collection)
796 files-only)
797 ;; It is a directory, and we were told to return just files.
798 nil
799
800 ;; Fully expand the URL and then rip off the beginning if we
801 ;; are not supposed to return fully-qualified names.
802 (setq child-url (url-expand-file-name child-url parsed-url))
803 (if (not full)
7fa20d96
DE
David Engster2012-07-28 13:07:17 +0200804 ;; Parts of the URL might be hex'ed.
805 (setq child-url (substring (url-unhex-string child-url)
806 (length url))))
8c8b8430
SM
Stefan Monnier2004-04-04 01:21:46 +0000807
808 ;; We don't want '/' as the last character in filenames...
809 (if (string-match "/$" child-url)
810 (setq child-url (substring child-url 0 -1)))
811
812 ;; If we have a match criteria, then apply it.
813 (if (or (and match (not (string-match match child-url)))
814 (string= child-url "")
815 (string= child-url url))
816 nil
817 (push child-url files))))
818
819 (if nosort
820 files
821 (sort files 'string-lessp))))
822
8c8b8430
SM
Stefan Monnier2004-04-04 01:21:46 +0000823(defun url-dav-file-directory-p (url)
824 "Return t if URL names an existing DAV collection."
825 (let ((properties (cdar (url-dav-get-properties url '(DAV:resourcetype)))))
7fa20d96
DE
David Engster2012-07-28 13:07:17 +0200826 (when (member 'DAV:collection (plist-get properties 'DAV:resourcetype))
827 t)))
8c8b8430 Stefan Monnier2004-04-04 01:21:46 +0000828
8c8b8430
SM
Stefan Monnier2004-04-04 01:21:46 +0000829(defun url-dav-make-directory (url &optional parents)
830 "Create the directory DIR and any nonexistent parent dirs."
8c8b8430
SM
Stefan Monnier2004-04-04 01:21:46 +0000831 (let* ((url-request-extra-headers nil)
832 (url-request-method "MKCOL")
833 (url-request-data nil)
834 (buffer (url-retrieve-synchronously url))
835 (result nil))
836 (when buffer
837 (unwind-protect
f1bfaf65 Stefan Monnier2004-04-16 21:58:11 +0000838 (with-current-buffer buffer
a464a6c7 Stefan Monnier2012-07-11 19:13:41 -0400839 (pcase url-http-response-status
8c8b8430
SM
Stefan Monnier2004-04-04 01:21:46 +0000840 (201 ; Collection created in its entirety
841 (setq result t))
842 (403 ; Forbidden
843 nil)
844 (405 ; Method not allowed
845 nil)
846 (409 ; Conflict
847 nil)
848 (415 ; Unsupported media type (WTF?)
849 nil)
850 (507 ; Insufficient storage
851 nil)
a464a6c7 Stefan Monnier2012-07-11 19:13:41 -0400852 (_
8c8b8430
SM
Stefan Monnier2004-04-04 01:21:46 +0000853 nil)))
854 (kill-buffer buffer)))
855 result))
856
8c8b8430
SM
Stefan Monnier2004-04-04 01:21:46 +0000857(defun url-dav-rename-file (oldname newname &optional overwrite)
858 (if (not (and (string-match url-handler-regexp oldname)
859 (string-match url-handler-regexp newname)))
0aa70d32
SM
Stefan Monnier2004-04-12 04:03:16 +0000860 (signal 'file-error
861 (list "Cannot rename between different URL backends"
862 oldname newname)))
8c8b8430
SM
Stefan Monnier2004-04-04 01:21:46 +0000863
864 (let* ((headers nil)
865 (props nil)
866 (status nil)
867 (directory-p (url-dav-file-directory-p oldname))
868 (exists-p (url-http-file-exists-p newname)))
869
870 (if (and exists-p
259b63b4 Juanma Barranquero2007-09-26 00:39:23 +0000871 (or
8c8b8430
SM
Stefan Monnier2004-04-04 01:21:46 +0000872 (null overwrite)
873 (and (numberp overwrite)
874 (not (yes-or-no-p
875 (format "File %s already exists; rename to it anyway? "
876 newname))))))
877 (signal 'file-already-exists (list "File already exists" newname)))
878
879 ;; Honor the overwrite flag...
880 (if overwrite (push '("Overwrite" . "T") headers))
881
882 ;; Have to tell them where to copy it to!
883 (push (cons "Destination" newname) headers)
884
885 ;; Always send a depth of -1 in case we are moving a collection.
886 (setq props (url-dav-request oldname "MOVE" nil nil (if directory-p -1 0)
887 headers))
888
889 (mapc (lambda (result)
890 (setq status (plist-get (cdr result) 'DAV:status))
891
892 (if (not (url-dav-http-success-p status))
893 (signal 'file-error (list "Renaming" oldname newname status))))
894 props)
895 t))
896
8c8b8430 Stefan Monnier2004-04-04 01:21:46 +0000897(defun url-dav-file-name-all-completions (file url)
d1ce47b0
JB
Juanma Barranquero2008-07-02 11:14:38 +0000898 "Return a list of all completions of file name FILE in URL.
899These are all file names in URL which begin with FILE."
8c8b8430
SM
Stefan Monnier2004-04-04 01:21:46 +0000900 (url-dav-directory-files url nil (concat "^" file ".*")))
901
8c8b8430 Stefan Monnier2004-04-04 01:21:46 +0000902(defun url-dav-file-name-completion (file url)
d1ce47b0
JB
Juanma Barranquero2008-07-02 11:14:38 +0000903 "Complete file name FILE in URL.
904Returns the longest string common to all file names in URL
905that start with FILE.
8c8b8430 Stefan Monnier2004-04-04 01:21:46 +0000906If there is only one and FILE matches it exactly, returns t.
d1ce47b0 Juanma Barranquero2008-07-02 11:14:38 +0000907Returns nil if URL contains no name starting with FILE."
8c8b8430
SM
Stefan Monnier2004-04-04 01:21:46 +0000908 (let ((matches (url-dav-file-name-all-completions file url))
909 (result nil))
910 (cond
911 ((null matches)
912 ;; No matches
913 nil)
914 ((and (= (length matches) 1)
915 (string= file (car matches)))
916 ;; Only one file and FILE matches it exactly...
917 t)
918 (t
da6062e6 Paul Eggert2011-11-14 23:55:13 -0800919 ;; Need to figure out the longest string that they have in common
8c8b8430
SM
Stefan Monnier2004-04-04 01:21:46 +0000920 (setq matches (sort matches (lambda (a b) (> (length a) (length b)))))
921 (let ((n (length file))
922 (searching t)
923 (regexp nil)
924 (failed nil))
925 (while (and searching
926 (< n (length (car matches))))
927 (setq regexp (concat "^" (substring (car matches) 0 (1+ n)))
928 failed nil)
929 (dolist (potential matches)
930 (if (not (string-match regexp potential))
931 (setq failed t)))
932 (if failed
933 (setq searching nil)
a464a6c7 Stefan Monnier2012-07-11 19:13:41 -0400934 (cl-incf n)))
8c8b8430
SM
Stefan Monnier2004-04-04 01:21:46 +0000935 (substring (car matches) 0 n))))))
936
937(defun url-dav-register-handler (op)
938 (put op 'url-file-handlers (intern-soft (format "url-dav-%s" op))))
939
259b63b4
JB
Juanma Barranquero2007-09-26 00:39:23 +0000940(mapc 'url-dav-register-handler
941 ;; These handlers are disabled because they incorrectly presume that
942 ;; the URL specifies an HTTP location and thus break FTP URLs.
943 '(;; file-name-all-completions
944 ;; file-name-completion
945 ;; rename-file
946 ;; make-directory
947 ;; file-directory-p
948 ;; directory-files
949 ;; delete-file
950 ;; delete-directory
951 ;; file-attributes
952 ))
8c8b8430
SM
Stefan Monnier2004-04-04 01:21:46 +0000953
954\f
955;;; Version Control backend cruft
956
957;(put 'vc-registered 'url-file-handlers 'url-dav-vc-registered)
958
959;;;###autoload
960(defun url-dav-vc-registered (url)
961 (if (and (string-match "\\`https?" url)
962 (plist-get (url-http-options url) 'dav))
963 (progn
964 (vc-file-setprop url 'vc-backend 'dav)
965 t)))
966
967\f
968;;; Miscellaneous stuff.
969
970(provide 'url-dav)
e5566bd5 Miles Bader2004-04-04 04:44:10 +0000971
76827ca4 Stefan Monnier2004-04-12 20:42:44 +0000972;;; url-dav.el ends here