1 ;;; url-dav.el --- WebDAV support
3 ;; Copyright (C) 2001, 2004-2012 Free Software Foundation, Inc.
5 ;; Author: Bill Perry <wmperry@gnu.org>
6 ;; Maintainer: Bill Perry <wmperry@gnu.org>
9 ;; This file is part of GNU Emacs.
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 3 of the License, or
14 ;; (at your option) any later version.
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.
21 ;; You should have received a copy of the GNU General Public License
22 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
24 ;; DAV is in RFC 2518.
30 (eval-when-compile (require 'cl-lib
))
34 (require 'url-handlers
)
36 (defvar url-dav-supported-protocols
'(1 2)
37 "List of supported DAV versions.")
39 (defvar url-http-content-type
)
40 (defvar url-http-response-status
)
41 (defvar url-http-end-of-headers
)
43 (defun url-intersection (l1 l2
)
44 "Return a list of the elements occurring in both of the lists L1 and L2."
49 (if (member (car l1
) l2
)
50 (setq result
(cons (pop l1
) result
))
55 (defun url-dav-supported-p (url)
57 (fboundp 'xml-expand-namespace
)
58 (url-intersection url-dav-supported-protocols
59 (plist-get (url-http-options url
) 'dav
))))
61 (defun url-dav-node-text (node)
62 "Return the text data from the XML node NODE."
63 (mapconcat (lambda (txt)
66 "")) (xml-node-children node
) " "))
69 ;;; Parsing routines for the actual node contents.
71 ;; I am not incredibly happy with how this code looks/works right
72 ;; now, but it DOES work, and if we get the API right, our callers
73 ;; won't have to worry about the internal representation.
75 (defconst url-dav-datatype-attribute
76 'urn
:uuid
:c2f41010-65b3-11d1-a29f-00aa00c14882
/dt
)
78 (defun url-dav-process-integer-property (node)
79 (truncate (string-to-number (url-dav-node-text node
))))
81 (defun url-dav-process-number-property (node)
82 (string-to-number (url-dav-node-text node
)))
84 (defconst url-dav-iso8601-regexp
87 (4digit "\\([0-9][0-9][0-9][0-9]\\)")
88 (2digit "\\([0-9][0-9]\\)")
89 (date-fullyear 4digit
)
95 (time-secfrac "\\(\\.[0-9]+\\)?")
96 (time-numoffset (concat "[-+]\\(" time-hour
"\\):" time-minute
))
97 (time-offset (concat "Z" time-numoffset
))
98 (partial-time (concat time-hour colon time-minute colon time-second
100 (full-date (concat date-fullyear dash date-month dash date-mday
))
101 (full-time (concat partial-time time-offset
))
102 (date-time (concat full-date
"T" full-time
)))
103 (list (concat "^" full-date
)
104 (concat "T" partial-time
)
105 (concat "Z" time-numoffset
)))
106 "List of regular expressions matching ISO 8601 dates.
107 1st regular expression matches the date.
108 2nd regular expression matches the time.
109 3rd regular expression matches the (optional) timezone specification.")
111 (defun url-dav-process-date-property (node)
112 (require 'parse-time
)
113 (let* ((date-re (nth 0 url-dav-iso8601-regexp
))
114 (time-re (nth 1 url-dav-iso8601-regexp
))
115 (tz-re (nth 2 url-dav-iso8601-regexp
))
116 (date-string (url-dav-node-text node
))
118 time seconds minute hour fractional-seconds
119 day month year day-of-week dst tz
)
120 ;; We need to populate 'time' with
121 ;; (SEC MIN HOUR DAY MON YEAR DOW DST TZ)
123 ;; Nobody else handles iso8601 correctly, let's do it ourselves.
124 (when (string-match date-re date-string re-start
)
125 (setq year
(string-to-number (match-string 1 date-string
))
126 month
(string-to-number (match-string 2 date-string
))
127 day
(string-to-number (match-string 3 date-string
))
128 re-start
(match-end 0))
129 (when (string-match time-re date-string re-start
)
130 (setq hour
(string-to-number (match-string 1 date-string
))
131 minute
(string-to-number (match-string 2 date-string
))
132 seconds
(string-to-number (match-string 3 date-string
))
133 fractional-seconds
(string-to-number (or
134 (match-string 4 date-string
)
136 re-start
(match-end 0))
137 (when (string-match tz-re date-string re-start
)
138 (setq tz
(match-string 1 date-string
)))
139 (url-debug 'dav
"Parsed iso8601%s date" (if tz
"tz" ""))
140 (setq time
(list seconds minute hour day month year day-of-week dst tz
))))
142 ;; Fall back to having Gnus do fancy things for us.
144 (setq time
(parse-time-string date-string
)))
147 (setq time
(apply 'encode-time time
))
148 (url-debug 'dav
"Unable to decode date (%S) (%s)"
149 (xml-node-name node
) date-string
))
152 (defun url-dav-process-boolean-property (node)
153 (/= 0 (string-to-number (url-dav-node-text node
))))
155 (defun url-dav-process-uri-property (node)
156 ;; Returns a parsed representation of the URL...
157 (url-generic-parse-url (url-dav-node-text node
)))
159 (defun url-dav-find-parser (node)
160 "Find a function to parse the XML node NODE."
161 (or (get (xml-node-name node
) 'dav-parser
)
162 (let ((fn (intern (format "url-dav-process-%s" (xml-node-name node
)))))
163 (if (not (fboundp fn
))
164 (setq fn
'url-dav-node-text
)
165 (put (xml-node-name node
) 'dav-parser fn
))
168 (defmacro url-dav-dispatch-node
(node)
169 `(funcall (url-dav-find-parser ,node
) ,node
))
171 (defun url-dav-process-DAV:prop
(node)
172 ;; A prop node has content model of ANY
174 ;; Some predefined nodes have special meanings though.
176 ;; DAV:supportedlock - list of DAV:lockentry
178 ;; DAV:iscollection - boolean
179 ;; DAV:getcontentlength - integer
180 ;; DAV:ishidden - boolean
181 ;; DAV:getcontenttype - string
182 ;; DAV:resourcetype - node who's name is the resource type
183 ;; DAV:getlastmodified - date
184 ;; DAV:creationdate - date
185 ;; DAV:displayname - string
186 ;; DAV:getetag - unknown
187 (let ((children (xml-node-children node
))
193 (error "No child nodes in DAV:prop"))
196 (setq node
(car children
)
199 (cdr-safe (assq url-dav-datatype-attribute
200 (xml-node-attributes node
)))
205 ((or `dateTime.iso8601tz
210 `date
) ; date is our 'special' one...
211 ;; Some type of date/time string.
212 (setq value
(url-dav-process-date-property node
)))
215 (setq value
(url-dav-process-integer-property node
)))
217 (setq value
(url-dav-process-number-property node
)))
219 (setq value
(url-dav-process-boolean-property node
)))
221 (setq value
(url-dav-process-uri-property node
)))
223 (if (not (eq node-type
'unknown
))
224 (url-debug 'dav
"Unknown data type in url-dav-process-prop: %s"
226 (setq value
(url-dav-dispatch-node node
))))
228 (setq props
(plist-put props
(xml-node-name node
) value
)
229 children
(cdr children
)))
232 (defun url-dav-process-DAV:supportedlock
(node)
233 ;; DAV:supportedlock is a list of DAV:lockentry items.
234 ;; DAV:lockentry in turn contains a DAV:lockscope and DAV:locktype.
235 ;; The DAV:lockscope must have a single node beneath it, ditto for
237 (let ((children (xml-node-children node
))
241 (when (and (not (stringp (car children
)))
242 (eq (xml-node-name (car children
)) 'DAV
:lockentry
))
243 (setq scope
(assq 'DAV
:lockscope
(xml-node-children (car children
)))
244 type
(assq 'DAV
:locktype
(xml-node-children (car children
))))
245 (when (and scope type
)
246 (setq scope
(xml-node-name (car (xml-node-children scope
)))
247 type
(xml-node-name (car (xml-node-children type
))))
248 (push (cons type scope
) results
)))
249 (setq children
(cdr children
)))
252 (defun url-dav-process-subnode-property (node)
253 ;; Returns a list of child node names.
254 (delq nil
(mapcar 'car-safe
(xml-node-children node
))))
256 (defalias 'url-dav-process-DAV
:depth
'url-dav-process-integer-property
)
257 (defalias 'url-dav-process-DAV
:resourcetype
'url-dav-process-subnode-property
)
258 (defalias 'url-dav-process-DAV
:locktype
'url-dav-process-subnode-property
)
259 (defalias 'url-dav-process-DAV
:lockscope
'url-dav-process-subnode-property
)
260 (defalias 'url-dav-process-DAV
:getcontentlength
'url-dav-process-integer-property
)
261 (defalias 'url-dav-process-DAV
:getlastmodified
'url-dav-process-date-property
)
262 (defalias 'url-dav-process-DAV
:creationdate
'url-dav-process-date-property
)
263 (defalias 'url-dav-process-DAV
:iscollection
'url-dav-process-boolean-property
)
264 (defalias 'url-dav-process-DAV
:ishidden
'url-dav-process-boolean-property
)
266 (defun url-dav-process-DAV:locktoken
(node)
267 ;; DAV:locktoken can have one or more DAV:href children.
268 (delq nil
(mapcar (lambda (n)
271 (url-dav-dispatch-node n
)))
272 (xml-node-children node
))))
274 (defun url-dav-process-DAV:owner
(node)
275 ;; DAV:owner can contain anything.
276 (delq nil
(mapcar (lambda (n)
279 (url-dav-dispatch-node n
)))
280 (xml-node-children node
))))
282 (defun url-dav-process-DAV:activelock
(node)
283 ;; DAV:activelock can contain:
287 ;; DAV:owner (optional)
288 ;; DAV:timeout (optional)
289 ;; DAV:locktoken (optional)
290 (let ((children (xml-node-children node
))
293 (if (listp (car children
))
294 (push (cons (xml-node-name (car children
))
295 (url-dav-dispatch-node (car children
)))
297 (setq children
(cdr children
)))
300 (defun url-dav-process-DAV:lockdiscovery
(node)
301 ;; Can only contain a list of DAV:activelock objects.
302 (let ((children (xml-node-children node
))
306 ((stringp (car children
))
309 ((eq (xml-node-name (car children
)) 'DAV
:activelock
)
310 (push (url-dav-dispatch-node (car children
)) results
))
312 ;; Ignore unknown nodes...
314 (setq children
(cdr children
)))
317 (defun url-dav-process-DAV:status
(node)
318 ;; The node contains a standard HTTP/1.1 response line... we really
319 ;; only care about the numeric status code.
320 (let ((status (url-dav-node-text node
)))
321 (if (string-match "\\`[ \r\t\n]*HTTP/[0-9.]+ \\([0-9]+\\)" status
)
322 (string-to-number (match-string 1 status
))
325 (defun url-dav-process-DAV:propstat
(node)
326 ;; A propstate node can have the following children...
328 ;; DAV:prop - a list of properties and values
329 ;; DAV:status - An HTTP/1.1 status line
330 (let ((children (xml-node-children node
))
334 (error "No child nodes in DAV:propstat"))
336 (setq props
(url-dav-dispatch-node (assq 'DAV
:prop children
))
337 status
(url-dav-dispatch-node (assq 'DAV
:status children
)))
339 ;; Need to parse out the HTTP status
340 (setq props
(plist-put props
'DAV
:status status
))
343 (defun url-dav-process-DAV:response
(node)
344 (let ((children (xml-node-children node
))
348 (error "No child nodes in DAV:response"))
350 ;; A response node can have the following children...
352 ;; DAV:href - URL the response is for.
353 ;; DAV:propstat - see url-dav-process-propstat
354 ;; DAV:responsedescription - text description of the response
355 (setq propstat
(assq 'DAV
:propstat children
)
356 href
(assq 'DAV
:href children
))
359 (error "No href in DAV:response"))
362 (error "No propstat in DAV:response"))
364 (setq propstat
(url-dav-dispatch-node propstat
)
365 href
(url-dav-dispatch-node href
))
366 (cons href propstat
)))
368 (defun url-dav-process-DAV:multistatus
(node)
369 (let ((children (xml-node-children node
))
372 (push (url-dav-dispatch-node (car children
)) results
)
373 (setq children
(cdr children
)))
377 ;;; DAV request/response generation/processing
378 (defun url-dav-process-response (buffer url
)
379 "Parse a WebDAV response from BUFFER, interpreting it relative to URL.
381 The buffer must have been retrieved by HTTP or HTTPS and contain an
384 (overall-status nil
))
387 (with-current-buffer buffer
388 (goto-char url-http-end-of-headers
)
389 (setq overall-status url-http-response-status
)
391 ;; XML documents can be transferred as either text/xml or
392 ;; application/xml, and we are required to accept both of
395 url-http-content-type
396 (string-match "\\`\\(text\\|application\\)/xml"
397 url-http-content-type
))
398 (setq tree
(xml-parse-region (point) (point-max)))))
399 ;; Clean up after ourselves.
400 (kill-buffer buffer
)))
403 (if (eq (xml-node-name (car tree
)) 'DAV
:multistatus
)
404 (url-dav-dispatch-node (car tree
))
405 (url-debug 'dav
"Got back singleton response for URL(%S)" url
)
406 (let ((properties (url-dav-dispatch-node (car tree
))))
407 ;; We need to make sure we have a DAV:status node in there for
408 ;; higher-level code;
409 (setq properties
(plist-put properties
'DAV
:status overall-status
))
410 ;; Make this look like a DAV:multistatus parse tree so that
411 ;; nobody but us needs to know the difference.
412 (list (cons url properties
))))))
414 (defun url-dav-request (url method tag body
415 &optional depth headers namespaces
)
416 "Perform WebDAV operation METHOD on URL. Return the parsed responses.
417 Automatically creates an XML request body if TAG is non-nil.
418 BODY is the XML document fragment to be enclosed by <TAG></TAG>.
420 DEPTH is how deep the request should propagate. Default is 0, meaning
421 it should apply only to URL. A negative number means to use
422 `Infinity' for the depth. Not all WebDAV servers support this depth
425 HEADERS is an assoc list of extra headers to send in the request.
427 NAMESPACES is an assoc list of (NAMESPACE . EXPANSION), and these are
428 added to the <TAG> element. The DAV=DAV: namespace is automatically
429 added to this list, so most requests can just pass in nil."
430 ;; Take care of the default value for depth...
431 (setq depth
(or depth
0))
433 ;; Now let's translate it into something webdav can understand.
435 (setq depth
"Infinity")
436 (setq depth
(int-to-string depth
)))
437 (if (not (assoc "DAV" namespaces
))
438 (setq namespaces
(cons '("DAV" .
"DAV:") namespaces
)))
440 (let* ((url-request-extra-headers `(("Depth" .
,depth
)
441 ("Content-type" .
"text/xml")
443 (url-request-method method
)
447 "<?xml version=\"1.0\" encoding=\"utf-8\" ?>\n"
448 "<" (symbol-name tag
) " "
449 ;; add in the appropriate namespaces...
450 (mapconcat (lambda (ns)
451 (concat "xmlns:" (car ns
) "='" (cdr ns
) "'"))
455 "</" (symbol-name tag
) ">\n"))))
456 (url-dav-process-response (url-retrieve-synchronously url
) url
)))
458 (defun url-dav-get-properties (url &optional attributes depth namespaces
)
459 "Return properties for URL, up to DEPTH levels deep.
461 Returns an assoc list, where the key is the filename (possibly a full
462 URI), and the value is a standard property list of DAV property
463 names (ie: DAV:resourcetype)."
464 (url-dav-request url
"PROPFIND" 'DAV
:propfind
466 (mapconcat (lambda (attr)
467 (concat "<DAV:prop><"
472 depth nil namespaces
))
474 (defmacro url-dav-http-success-p
(status)
475 "Return whether STATUS was the result of a successful DAV request."
476 `(= (/ (or ,status
500) 100) 2))
480 (defvar url-dav-lock-identifier
(concat "mailto:" user-mail-address
)
481 "URL used as contact information when creating locks in DAV.
482 This will be used as the contents of the DAV:owner/DAV:href tag to
483 identify the owner of a LOCK when requesting it. This will be shown
484 to other users when the DAV:lockdiscovery property is requested, so
485 make sure you are comfortable with it leaking to the outside world.")
487 (defun url-dav-lock-resource (url exclusive
&optional depth
)
488 "Request a lock on URL. If EXCLUSIVE is non-nil, get an exclusive lock.
489 Optional 3rd argument DEPTH says how deep the lock should go, default is 0
490 \(lock only the resource and none of its children\).
492 Returns a cons-cell of (SUCCESSFUL-RESULTS . FAILURE-RESULTS).
493 SUCCESSFUL-RESULTS is a list of (URL STATUS locktoken).
494 FAILURE-RESULTS is a list of (URL STATUS)."
495 (setq exclusive
(if exclusive
"<DAV:exclusive/>" "<DAV:shared/>"))
498 " <DAV:lockscope>" exclusive
"</DAV:lockscope>\n"
499 " <DAV:locktype> <DAV:write/> </DAV:locktype>\n"
501 " <DAV:href>" url-dav-lock-identifier
"</DAV:href>\n"
503 (response nil
) ; Responses to the LOCK request
504 (result nil
) ; For walking thru the response list
507 (failures nil
) ; List of failure cases (URL . STATUS)
508 (successes nil
)) ; List of success cases (URL . STATUS)
509 (setq response
(url-dav-request url
"LOCK" 'DAV
:lockinfo body
510 depth
'(("Timeout" .
"Infinite"))))
512 ;; Get the parent URL ready for expand-file-name
513 (if (not (vectorp url
))
514 (setq url
(url-generic-parse-url url
)))
516 ;; Walk thru the response list, fully expand the URL, and grab the
519 (setq result
(pop response
)
520 child-url
(url-expand-file-name (pop result
) url
)
521 child-status
(or (plist-get result
'DAV
:status
) 500))
522 (if (url-dav-http-success-p child-status
)
523 (push (list url child-status
"huh") successes
)
524 (push (list url child-status
) failures
)))
525 (cons successes failures
)))
527 (defun url-dav-active-locks (url &optional depth
)
528 "Return an assoc list of all active locks on URL."
529 (let ((response (url-dav-get-properties url
'(DAV:lockdiscovery
) depth
))
535 (if (not (vectorp url
))
536 (setq url
(url-generic-parse-url url
)))
539 (setq child
(pop response
)
540 child-url
(pop child
)
542 (when (and (url-dav-http-success-p (plist-get child
'DAV
:status
))
543 (setq child
(plist-get child
'DAV
:lockdiscovery
)))
544 ;; After our parser has had its way with it, The
545 ;; DAV:lockdiscovery property is a list of DAV:activelock
546 ;; objects, which are comprised of DAV:activelocks, which
547 ;; assoc lists of properties and values.
549 (if (assq 'DAV
:locktoken
(car child
))
550 (let ((tokens (cdr (assq 'DAV
:locktoken
(car child
))))
551 (owners (cdr (assq 'DAV
:owner
(car child
)))))
552 (dolist (token tokens
)
553 (dolist (owner owners
)
554 (push (cons token owner
) child-results
)))))
557 (push (cons (url-expand-file-name child-url url
) child-results
)
561 (defun url-dav-unlock-resource (url lock-token
)
562 "Release the lock on URL represented by LOCK-TOKEN.
563 Returns t if the lock was successfully released."
564 (let* ((url-request-extra-headers (list (cons "Lock-Token"
565 (concat "<" lock-token
">"))))
566 (url-request-method "UNLOCK")
567 (url-request-data nil
)
568 (buffer (url-retrieve-synchronously url
))
572 (with-current-buffer buffer
573 (setq result
(url-dav-http-success-p url-http-response-status
)))
574 (kill-buffer buffer
)))
578 ;;; file-name-handler stuff
579 (defun url-dav-file-attributes-mode-string (properties)
580 (let ((modes (make-string 10 ?-
))
581 (supported-locks (plist-get properties
'DAV
:supportedlock
))
582 (executable-p (equal (plist-get properties
'http
://apache.org
/dav
/props
/executable
)
584 (directory-p (memq 'DAV
:collection
(plist-get properties
'DAV
:resourcetype
)))
587 ;; Assume we can read this, otherwise the PROPFIND would have
602 (while supported-locks
603 (setq lock
(car supported-locks
)
604 supported-locks
(cdr supported-locks
))
608 (`DAV
:shared
; group permissions (possibly world)
611 (aset modes
2 ?w
)) ; owner permissions?
613 (url-debug 'dav
"Unrecognized DAV:lockscope (%S)" (cdr lock
)))))
615 (url-debug 'dav
"Unrecognized DAV:locktype (%S)" (car lock
)))))
618 (autoload 'url-http-head-file-attributes
"url-http")
620 (defun url-dav-file-attributes (url &optional id-format
)
621 (let ((properties (cdar (url-dav-get-properties url
))))
623 (url-dav-http-success-p (plist-get properties
'DAV
:status
)))
624 ;; We got a good DAV response back..
626 ;; t for directory, string for symbolic link, or nil
627 ;; Need to support DAV Bindings to figure out the
628 ;; symbolic link issues.
629 (if (memq 'DAV
:collection
(plist-get properties
'DAV
:resourcetype
)) t nil
)
631 ;; Number of links to file... Needs DAV Bindings.
634 ;; File uid - no way to figure out?
637 ;; File gid - no way to figure out?
640 ;; Last access time - ???
643 ;; Last modification time
644 (plist-get properties
'DAV
:getlastmodified
)
646 ;; Last status change time... just reuse last-modified
648 (plist-get properties
'DAV
:getlastmodified
)
651 (or (plist-get properties
'DAV
:getcontentlength
) 0)
653 ;; file modes as a string like `ls -l'
655 ;; Should be able to build this up from the
656 ;; DAV:supportedlock attribute pretty easily. Getting
657 ;; the group info could be impossible though.
658 (url-dav-file-attributes-mode-string properties
)
660 ;; t if file's gid would change if it were deleted &
661 ;; recreated. No way for us to know that thru DAV.
664 ;; inode number - meaningless
667 ;; device number - meaningless
669 ;; Fall back to just the normal http way of doing things.
670 (url-http-head-file-attributes url id-format
))))
672 (defun url-dav-save-resource (url obj
&optional content-type lock-token
)
673 "Save OBJ as URL using WebDAV.
674 URL must be a fully qualified URL.
675 OBJ may be a buffer or a string."
678 (url-request-extra-headers nil
)
679 (url-request-method "PUT")
683 (with-current-buffer obj
688 (error "Invalid object to url-dav-save-resource")))))
692 (cons "If" (concat "(<" lock-token
">)"))
693 url-request-extra-headers
))
695 ;; Everything must always have a content-type when we submit it.
697 (cons "Content-type" (or content-type
"application/octet-stream"))
698 url-request-extra-headers
)
701 (setq buffer
(url-retrieve-synchronously url
))
706 (with-current-buffer buffer
707 (setq result
(url-dav-http-success-p url-http-response-status
)))
708 (kill-buffer buffer
)))
712 (defmacro url-dav-delete-something
(url lock-token
&rest error-checking
)
713 "Delete URL completely, with no sanity checking whatsoever. DO NOT USE.
714 This is defined as a macro that will not be visible from compiled files.
715 Use with care, and even then think three times."
718 (url-dav-request ,url
"DELETE" nil nil -
1
722 (concat "(<" ,lock-token
">)"))))))))
725 (defun url-dav-delete-directory (url &optional recursive lock-token
)
726 "Delete the WebDAV collection URL.
727 If optional second argument RECURSIVE is non-nil, then delete all
728 files in the collection as well."
732 (setq props
(url-dav-delete-something
734 (setq props
(url-dav-get-properties url
'(DAV:getcontenttype
) 1))
735 (if (and (not recursive
)
736 (/= (length props
) 1))
737 (signal 'file-error
(list "Removing directory"
738 "directory not empty" url
)))))
740 (mapc (lambda (result)
741 (setq status
(plist-get (cdr result
) 'DAV
:status
))
742 (if (not (url-dav-http-success-p status
))
743 (signal 'file-error
(list "Removing directory"
745 (car result
) status
))))
749 (defun url-dav-delete-file (url &optional lock-token
)
750 "Delete file named URL."
753 (setq props
(url-dav-delete-something
755 (setq props
(url-dav-get-properties url
))
756 (if (eq (plist-get (cdar props
) 'DAV
:resourcetype
) 'DAV
:collection
)
757 (signal 'file-error
(list "Removing old name" "is a collection" url
)))))
759 (mapc (lambda (result)
760 (setq status
(plist-get (cdr result
) 'DAV
:status
))
761 (if (not (url-dav-http-success-p status
))
762 (signal 'file-error
(list "Removing old name"
764 (car result
) status
))))
768 (defun url-dav-directory-files (url &optional full match nosort files-only
)
769 "Return a list of names of files in URL.
770 There are three optional arguments:
771 If FULL is non-nil, return absolute file names. Otherwise return names
772 that are relative to the specified directory.
773 If MATCH is non-nil, mention only file names that match the regexp MATCH.
774 If NOSORT is non-nil, the list is not sorted--its order is unpredictable.
775 NOSORT is useful if you plan to sort the result yourself."
776 (let ((properties (url-dav-get-properties url
'(DAV:resourcetype
) 1))
780 (parsed-url (url-generic-parse-url url
)))
782 (if (= (length properties
) 1)
783 (signal 'file-error
(list "Opening directory" "not a directory" url
)))
786 (setq child-props
(pop properties
)
787 child-url
(pop child-props
))
788 (if (and (eq (plist-get child-props
'DAV
:resourcetype
) 'DAV
:collection
)
790 ;; It is a directory, and we were told to return just files.
793 ;; Fully expand the URL and then rip off the beginning if we
794 ;; are not supposed to return fully-qualified names.
795 (setq child-url
(url-expand-file-name child-url parsed-url
))
797 (setq child-url
(substring child-url
(length url
))))
799 ;; We don't want '/' as the last character in filenames...
800 (if (string-match "/$" child-url
)
801 (setq child-url
(substring child-url
0 -
1)))
803 ;; If we have a match criteria, then apply it.
804 (if (or (and match
(not (string-match match child-url
)))
805 (string= child-url
"")
806 (string= child-url url
))
808 (push child-url files
))))
812 (sort files
'string-lessp
))))
814 (defun url-dav-file-directory-p (url)
815 "Return t if URL names an existing DAV collection."
816 (let ((properties (cdar (url-dav-get-properties url
'(DAV:resourcetype
)))))
817 (eq (plist-get properties
'DAV
:resourcetype
) 'DAV
:collection
)))
819 (defun url-dav-make-directory (url &optional parents
)
820 "Create the directory DIR and any nonexistent parent dirs."
821 (let* ((url-request-extra-headers nil
)
822 (url-request-method "MKCOL")
823 (url-request-data nil
)
824 (buffer (url-retrieve-synchronously url
))
828 (with-current-buffer buffer
829 (pcase url-http-response-status
830 (201 ; Collection created in its entirety
834 (405 ; Method not allowed
838 (415 ; Unsupported media type (WTF?)
840 (507 ; Insufficient storage
844 (kill-buffer buffer
)))
847 (defun url-dav-rename-file (oldname newname
&optional overwrite
)
848 (if (not (and (string-match url-handler-regexp oldname
)
849 (string-match url-handler-regexp newname
)))
851 (list "Cannot rename between different URL backends"
857 (directory-p (url-dav-file-directory-p oldname
))
858 (exists-p (url-http-file-exists-p newname
)))
863 (and (numberp overwrite
)
865 (format "File %s already exists; rename to it anyway? "
867 (signal 'file-already-exists
(list "File already exists" newname
)))
869 ;; Honor the overwrite flag...
870 (if overwrite
(push '("Overwrite" .
"T") headers
))
872 ;; Have to tell them where to copy it to!
873 (push (cons "Destination" newname
) headers
)
875 ;; Always send a depth of -1 in case we are moving a collection.
876 (setq props
(url-dav-request oldname
"MOVE" nil nil
(if directory-p -
1 0)
879 (mapc (lambda (result)
880 (setq status
(plist-get (cdr result
) 'DAV
:status
))
882 (if (not (url-dav-http-success-p status
))
883 (signal 'file-error
(list "Renaming" oldname newname status
))))
887 (defun url-dav-file-name-all-completions (file url
)
888 "Return a list of all completions of file name FILE in URL.
889 These are all file names in URL which begin with FILE."
890 (url-dav-directory-files url nil
(concat "^" file
".*")))
892 (defun url-dav-file-name-completion (file url
)
893 "Complete file name FILE in URL.
894 Returns the longest string common to all file names in URL
895 that start with FILE.
896 If there is only one and FILE matches it exactly, returns t.
897 Returns nil if URL contains no name starting with FILE."
898 (let ((matches (url-dav-file-name-all-completions file url
))
904 ((and (= (length matches
) 1)
905 (string= file
(car matches
)))
906 ;; Only one file and FILE matches it exactly...
909 ;; Need to figure out the longest string that they have in common
910 (setq matches
(sort matches
(lambda (a b
) (> (length a
) (length b
)))))
911 (let ((n (length file
))
915 (while (and searching
916 (< n
(length (car matches
))))
917 (setq regexp
(concat "^" (substring (car matches
) 0 (1+ n
)))
919 (dolist (potential matches
)
920 (if (not (string-match regexp potential
))
925 (substring (car matches
) 0 n
))))))
927 (defun url-dav-register-handler (op)
928 (put op
'url-file-handlers
(intern-soft (format "url-dav-%s" op
))))
930 (mapc 'url-dav-register-handler
931 ;; These handlers are disabled because they incorrectly presume that
932 ;; the URL specifies an HTTP location and thus break FTP URLs.
933 '(;; file-name-all-completions
934 ;; file-name-completion
945 ;;; Version Control backend cruft
947 ;(put 'vc-registered 'url-file-handlers 'url-dav-vc-registered)
950 (defun url-dav-vc-registered (url)
951 (if (and (string-match "\\`https?" url
)
952 (plist-get (url-http-options url
) 'dav
))
954 (vc-file-setprop url
'vc-backend
'dav
)
958 ;;; Miscellaneous stuff.
962 ;;; url-dav.el ends here