Mercurial > emacs
annotate lisp/url/url-dav.el @ 96849:d049ef97c446
* print.c (print_object): Check print_depth before searching for
circularities.
author | Chong Yidong <cyd@stupidchicken.com> |
---|---|
date | Mon, 21 Jul 2008 05:02:31 +0000 |
parents | 7369ded3b436 |
children | a9dc0e7c3f2b |
rev | line source |
---|---|
54695 | 1 ;;; url-dav.el --- WebDAV support |
2 | |
79720 | 3 ;; Copyright (C) 2001, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc. |
54695 | 4 |
5 ;; Author: Bill Perry <wmperry@gnu.org> | |
6 ;; Maintainer: Bill Perry <wmperry@gnu.org> | |
7 ;; Keywords: url, vc | |
8 | |
54828
2eb49bad7ea9
Comments and docstring fixups.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
54795
diff
changeset
|
9 ;; This file is part of GNU Emacs. |
2eb49bad7ea9
Comments and docstring fixups.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
54795
diff
changeset
|
10 |
94668
8259d0d8e107
Switch to recommended form of GPLv3 permissions notice.
Glenn Morris <rgm@gnu.org>
parents:
87649
diff
changeset
|
11 ;; GNU Emacs is free software: you can redistribute it and/or modify |
54695 | 12 ;; it under the terms of the GNU General Public License as published by |
94668
8259d0d8e107
Switch to recommended form of GPLv3 permissions notice.
Glenn Morris <rgm@gnu.org>
parents:
87649
diff
changeset
|
13 ;; the Free Software Foundation, either version 3 of the License, or |
8259d0d8e107
Switch to recommended form of GPLv3 permissions notice.
Glenn Morris <rgm@gnu.org>
parents:
87649
diff
changeset
|
14 ;; (at your option) any later version. |
54695 | 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 | |
94668
8259d0d8e107
Switch to recommended form of GPLv3 permissions notice.
Glenn Morris <rgm@gnu.org>
parents:
87649
diff
changeset
|
22 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. |
54695 | 23 |
54795
31399f1df768
(url-dav-rename-file): Fix args of `signal'.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
54770
diff
changeset
|
24 ;; DAV is in RFC 2518. |
31399f1df768
(url-dav-rename-file): Fix args of `signal'.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
54770
diff
changeset
|
25 |
54828
2eb49bad7ea9
Comments and docstring fixups.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
54795
diff
changeset
|
26 ;;; Commentary: |
2eb49bad7ea9
Comments and docstring fixups.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
54795
diff
changeset
|
27 |
2eb49bad7ea9
Comments and docstring fixups.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
54795
diff
changeset
|
28 ;;; Code: |
2eb49bad7ea9
Comments and docstring fixups.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
54795
diff
changeset
|
29 |
54695 | 30 (eval-when-compile |
31 (require 'cl)) | |
32 | |
33 (require 'xml) | |
34 (require 'url-util) | |
35 (require 'url-handlers) | |
36 | |
37 (defvar url-dav-supported-protocols '(1 2) | |
38 "List of supported DAV versions.") | |
39 | |
54795
31399f1df768
(url-dav-rename-file): Fix args of `signal'.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
54770
diff
changeset
|
40 (defun url-intersection (l1 l2) |
96486
7369ded3b436
Typo and docstring fixes.
Juanma Barranquero <lekktu@gmail.com>
parents:
94668
diff
changeset
|
41 "Return a list of the elements occurring in both of the lists L1 and L2." |
54795
31399f1df768
(url-dav-rename-file): Fix args of `signal'.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
54770
diff
changeset
|
42 (if (null l2) |
31399f1df768
(url-dav-rename-file): Fix args of `signal'.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
54770
diff
changeset
|
43 l2 |
31399f1df768
(url-dav-rename-file): Fix args of `signal'.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
54770
diff
changeset
|
44 (let (result) |
31399f1df768
(url-dav-rename-file): Fix args of `signal'.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
54770
diff
changeset
|
45 (while l1 |
31399f1df768
(url-dav-rename-file): Fix args of `signal'.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
54770
diff
changeset
|
46 (if (member (car l1) l2) |
31399f1df768
(url-dav-rename-file): Fix args of `signal'.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
54770
diff
changeset
|
47 (setq result (cons (pop l1) result)) |
31399f1df768
(url-dav-rename-file): Fix args of `signal'.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
54770
diff
changeset
|
48 (pop l1))) |
31399f1df768
(url-dav-rename-file): Fix args of `signal'.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
54770
diff
changeset
|
49 (nreverse result)))) |
31399f1df768
(url-dav-rename-file): Fix args of `signal'.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
54770
diff
changeset
|
50 |
54695 | 51 ;;;###autoload |
52 (defun url-dav-supported-p (url) | |
53 (and (featurep 'xml) | |
54 (fboundp 'xml-expand-namespace) | |
54795
31399f1df768
(url-dav-rename-file): Fix args of `signal'.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
54770
diff
changeset
|
55 (url-intersection url-dav-supported-protocols |
31399f1df768
(url-dav-rename-file): Fix args of `signal'.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
54770
diff
changeset
|
56 (plist-get (url-http-options url) 'dav)))) |
54695 | 57 |
58 (defun url-dav-node-text (node) | |
59 "Return the text data from the XML node NODE." | |
60 (mapconcat (lambda (txt) | |
61 (if (stringp txt) | |
62 txt | |
63 "")) (xml-node-children node) " ")) | |
64 | |
65 | |
66 ;;; Parsing routines for the actual node contents. | |
54828
2eb49bad7ea9
Comments and docstring fixups.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
54795
diff
changeset
|
67 ;; |
2eb49bad7ea9
Comments and docstring fixups.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
54795
diff
changeset
|
68 ;; I am not incredibly happy with how this code looks/works right |
2eb49bad7ea9
Comments and docstring fixups.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
54795
diff
changeset
|
69 ;; now, but it DOES work, and if we get the API right, our callers |
2eb49bad7ea9
Comments and docstring fixups.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
54795
diff
changeset
|
70 ;; won't have to worry about the internal representation. |
54695 | 71 |
72 (defconst url-dav-datatype-attribute | |
73 'urn:uuid:c2f41010-65b3-11d1-a29f-00aa00c14882/dt) | |
74 | |
75 (defun url-dav-process-integer-property (node) | |
76 (truncate (string-to-number (url-dav-node-text node)))) | |
77 | |
78 (defun url-dav-process-number-property (node) | |
79 (string-to-number (url-dav-node-text node))) | |
80 | |
81 (defconst url-dav-iso8601-regexp | |
82 (let* ((dash "-?") | |
83 (colon ":?") | |
84 (4digit "\\([0-9][0-9][0-9][0-9]\\)") | |
85 (2digit "\\([0-9][0-9]\\)") | |
86 (date-fullyear 4digit) | |
87 (date-month 2digit) | |
88 (date-mday 2digit) | |
89 (time-hour 2digit) | |
90 (time-minute 2digit) | |
91 (time-second 2digit) | |
92 (time-secfrac "\\(\\.[0-9]+\\)?") | |
93 (time-numoffset (concat "[-+]\\(" time-hour "\\):" time-minute)) | |
94 (time-offset (concat "Z" time-numoffset)) | |
95 (partial-time (concat time-hour colon time-minute colon time-second | |
96 time-secfrac)) | |
97 (full-date (concat date-fullyear dash date-month dash date-mday)) | |
98 (full-time (concat partial-time time-offset)) | |
99 (date-time (concat full-date "T" full-time))) | |
100 (list (concat "^" full-date) | |
101 (concat "T" partial-time) | |
102 (concat "Z" time-numoffset))) | |
96486
7369ded3b436
Typo and docstring fixes.
Juanma Barranquero <lekktu@gmail.com>
parents:
94668
diff
changeset
|
103 "List of regular expressions matching ISO 8601 dates. |
54695 | 104 1st regular expression matches the date. |
105 2nd regular expression matches the time. | |
54828
2eb49bad7ea9
Comments and docstring fixups.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
54795
diff
changeset
|
106 3rd regular expression matches the (optional) timezone specification.") |
54695 | 107 |
108 (defun url-dav-process-date-property (node) | |
109 (require 'parse-time) | |
110 (let* ((date-re (nth 0 url-dav-iso8601-regexp)) | |
111 (time-re (nth 1 url-dav-iso8601-regexp)) | |
112 (tz-re (nth 2 url-dav-iso8601-regexp)) | |
113 (date-string (url-dav-node-text node)) | |
114 re-start | |
115 time seconds minute hour fractional-seconds | |
116 day month year day-of-week dst tz) | |
117 ;; We need to populate 'time' with | |
118 ;; (SEC MIN HOUR DAY MON YEAR DOW DST TZ) | |
119 | |
120 ;; Nobody else handles iso8601 correctly, lets do it ourselves. | |
121 (when (string-match date-re date-string re-start) | |
62400
e30c08177a3b
Replace `string-to-int' by `string-to-number'.
Juanma Barranquero <lekktu@gmail.com>
parents:
54929
diff
changeset
|
122 (setq year (string-to-number (match-string 1 date-string)) |
e30c08177a3b
Replace `string-to-int' by `string-to-number'.
Juanma Barranquero <lekktu@gmail.com>
parents:
54929
diff
changeset
|
123 month (string-to-number (match-string 2 date-string)) |
e30c08177a3b
Replace `string-to-int' by `string-to-number'.
Juanma Barranquero <lekktu@gmail.com>
parents:
54929
diff
changeset
|
124 day (string-to-number (match-string 3 date-string)) |
54695 | 125 re-start (match-end 0)) |
126 (when (string-match time-re date-string re-start) | |
62400
e30c08177a3b
Replace `string-to-int' by `string-to-number'.
Juanma Barranquero <lekktu@gmail.com>
parents:
54929
diff
changeset
|
127 (setq hour (string-to-number (match-string 1 date-string)) |
e30c08177a3b
Replace `string-to-int' by `string-to-number'.
Juanma Barranquero <lekktu@gmail.com>
parents:
54929
diff
changeset
|
128 minute (string-to-number (match-string 2 date-string)) |
e30c08177a3b
Replace `string-to-int' by `string-to-number'.
Juanma Barranquero <lekktu@gmail.com>
parents:
54929
diff
changeset
|
129 seconds (string-to-number (match-string 3 date-string)) |
e30c08177a3b
Replace `string-to-int' by `string-to-number'.
Juanma Barranquero <lekktu@gmail.com>
parents:
54929
diff
changeset
|
130 fractional-seconds (string-to-number (or |
e30c08177a3b
Replace `string-to-int' by `string-to-number'.
Juanma Barranquero <lekktu@gmail.com>
parents:
54929
diff
changeset
|
131 (match-string 4 date-string) |
e30c08177a3b
Replace `string-to-int' by `string-to-number'.
Juanma Barranquero <lekktu@gmail.com>
parents:
54929
diff
changeset
|
132 "0")) |
54695 | 133 re-start (match-end 0)) |
134 (when (string-match tz-re date-string re-start) | |
135 (setq tz (match-string 1 date-string))) | |
136 (url-debug 'dav "Parsed iso8601%s date" (if tz "tz" "")) | |
137 (setq time (list seconds minute hour day month year day-of-week dst tz)))) | |
138 | |
139 ;; Fall back to having Gnus do fancy things for us. | |
140 (when (not time) | |
141 (setq time (parse-time-string date-string))) | |
142 | |
143 (if time | |
144 (setq time (apply 'encode-time time)) | |
145 (url-debug 'dav "Unable to decode date (%S) (%s)" | |
146 (xml-node-name node) date-string)) | |
147 time)) | |
148 | |
149 (defun url-dav-process-boolean-property (node) | |
62400
e30c08177a3b
Replace `string-to-int' by `string-to-number'.
Juanma Barranquero <lekktu@gmail.com>
parents:
54929
diff
changeset
|
150 (/= 0 (string-to-number (url-dav-node-text node)))) |
54695 | 151 |
152 (defun url-dav-process-uri-property (node) | |
153 ;; Returns a parsed representation of the URL... | |
154 (url-generic-parse-url (url-dav-node-text node))) | |
155 | |
156 (defun url-dav-find-parser (node) | |
157 "Find a function to parse the XML node NODE." | |
158 (or (get (xml-node-name node) 'dav-parser) | |
159 (let ((fn (intern (format "url-dav-process-%s" (xml-node-name node))))) | |
160 (if (not (fboundp fn)) | |
161 (setq fn 'url-dav-node-text) | |
162 (put (xml-node-name node) 'dav-parser fn)) | |
163 fn))) | |
164 | |
165 (defmacro url-dav-dispatch-node (node) | |
166 `(funcall (url-dav-find-parser ,node) ,node)) | |
167 | |
168 (defun url-dav-process-DAV:prop (node) | |
169 ;; A prop node has content model of ANY | |
170 ;; | |
171 ;; Some predefined nodes have special meanings though. | |
172 ;; | |
173 ;; DAV:supportedlock - list of DAV:lockentry | |
174 ;; DAV:source | |
175 ;; DAV:iscollection - boolean | |
176 ;; DAV:getcontentlength - integer | |
177 ;; DAV:ishidden - boolean | |
178 ;; DAV:getcontenttype - string | |
179 ;; DAV:resourcetype - node who's name is the resource type | |
180 ;; DAV:getlastmodified - date | |
181 ;; DAV:creationdate - date | |
182 ;; DAV:displayname - string | |
183 ;; DAV:getetag - unknown | |
184 (let ((children (xml-node-children node)) | |
185 (node-type nil) | |
186 (props nil) | |
187 (value nil) | |
188 (handler-func nil)) | |
189 (when (not children) | |
190 (error "No child nodes in DAV:prop")) | |
191 | |
192 (while children | |
193 (setq node (car children) | |
194 node-type (intern | |
84929
ffdba9eb7f4e
(top): Use `mapc' rather than `mapcar'.
Juanma Barranquero <lekktu@gmail.com>
parents:
78481
diff
changeset
|
195 (or |
54695 | 196 (cdr-safe (assq url-dav-datatype-attribute |
197 (xml-node-attributes node))) | |
198 "unknown")) | |
199 value nil) | |
200 | |
201 (case node-type | |
202 ((dateTime.iso8601tz | |
203 dateTime.iso8601 | |
204 dateTime.tz | |
205 dateTime.rfc1123 | |
206 dateTime | |
207 date) ; date is our 'special' one... | |
208 ;; Some type of date/time string. | |
209 (setq value (url-dav-process-date-property node))) | |
210 (int | |
211 ;; Integer type... | |
212 (setq value (url-dav-process-integer-property node))) | |
213 ((number float) | |
214 (setq value (url-dav-process-number-property node))) | |
215 (boolean | |
216 (setq value (url-dav-process-boolean-property node))) | |
217 (uri | |
218 (setq value (url-dav-process-uri-property node))) | |
219 (otherwise | |
220 (if (not (eq node-type 'unknown)) | |
221 (url-debug 'dav "Unknown data type in url-dav-process-prop: %s" | |
222 node-type)) | |
223 (setq value (url-dav-dispatch-node node)))) | |
224 | |
225 (setq props (plist-put props (xml-node-name node) value) | |
226 children (cdr children))) | |
227 props)) | |
228 | |
229 (defun url-dav-process-DAV:supportedlock (node) | |
230 ;; DAV:supportedlock is a list of DAV:lockentry items. | |
231 ;; DAV:lockentry in turn contains a DAV:lockscope and DAV:locktype. | |
232 ;; The DAV:lockscope must have a single node beneath it, ditto for | |
233 ;; DAV:locktype. | |
234 (let ((children (xml-node-children node)) | |
235 (results nil) | |
236 scope type) | |
237 (while children | |
238 (when (and (not (stringp (car children))) | |
239 (eq (xml-node-name (car children)) 'DAV:lockentry)) | |
240 (setq scope (assq 'DAV:lockscope (xml-node-children (car children))) | |
241 type (assq 'DAV:locktype (xml-node-children (car children)))) | |
242 (when (and scope type) | |
243 (setq scope (xml-node-name (car (xml-node-children scope))) | |
244 type (xml-node-name (car (xml-node-children type)))) | |
245 (push (cons type scope) results))) | |
246 (setq children (cdr children))) | |
247 results)) | |
248 | |
249 (defun url-dav-process-subnode-property (node) | |
250 ;; Returns a list of child node names. | |
251 (delq nil (mapcar 'car-safe (xml-node-children node)))) | |
252 | |
253 (defalias 'url-dav-process-DAV:depth 'url-dav-process-integer-property) | |
254 (defalias 'url-dav-process-DAV:resourcetype 'url-dav-process-subnode-property) | |
255 (defalias 'url-dav-process-DAV:locktype 'url-dav-process-subnode-property) | |
256 (defalias 'url-dav-process-DAV:lockscope 'url-dav-process-subnode-property) | |
257 (defalias 'url-dav-process-DAV:getcontentlength 'url-dav-process-integer-property) | |
258 (defalias 'url-dav-process-DAV:getlastmodified 'url-dav-process-date-property) | |
259 (defalias 'url-dav-process-DAV:creationdate 'url-dav-process-date-property) | |
260 (defalias 'url-dav-process-DAV:iscollection 'url-dav-process-boolean-property) | |
261 (defalias 'url-dav-process-DAV:ishidden 'url-dav-process-boolean-property) | |
262 | |
263 (defun url-dav-process-DAV:locktoken (node) | |
264 ;; DAV:locktoken can have one or more DAV:href children. | |
265 (delq nil (mapcar (lambda (n) | |
266 (if (stringp n) | |
267 n | |
268 (url-dav-dispatch-node n))) | |
269 (xml-node-children node)))) | |
270 | |
271 (defun url-dav-process-DAV:owner (node) | |
272 ;; DAV:owner can contain anything. | |
273 (delq nil (mapcar (lambda (n) | |
274 (if (stringp n) | |
275 n | |
276 (url-dav-dispatch-node n))) | |
277 (xml-node-children node)))) | |
278 | |
279 (defun url-dav-process-DAV:activelock (node) | |
280 ;; DAV:activelock can contain: | |
281 ;; DAV:lockscope | |
282 ;; DAV:locktype | |
283 ;; DAV:depth | |
284 ;; DAV:owner (optional) | |
285 ;; DAV:timeout (optional) | |
286 ;; DAV:locktoken (optional) | |
287 (let ((children (xml-node-children node)) | |
288 (results nil)) | |
289 (while children | |
290 (if (listp (car children)) | |
291 (push (cons (xml-node-name (car children)) | |
292 (url-dav-dispatch-node (car children))) | |
293 results)) | |
294 (setq children (cdr children))) | |
295 results)) | |
296 | |
297 (defun url-dav-process-DAV:lockdiscovery (node) | |
298 ;; Can only contain a list of DAV:activelock objects. | |
299 (let ((children (xml-node-children node)) | |
300 (results nil)) | |
301 (while children | |
302 (cond | |
303 ((stringp (car children)) | |
304 ;; text node? why? | |
305 nil) | |
306 ((eq (xml-node-name (car children)) 'DAV:activelock) | |
307 (push (url-dav-dispatch-node (car children)) results)) | |
308 (t | |
309 ;; Ignore unknown nodes... | |
310 nil)) | |
311 (setq children (cdr children))) | |
312 results)) | |
313 | |
314 (defun url-dav-process-DAV:status (node) | |
315 ;; The node contains a standard HTTP/1.1 response line... we really | |
316 ;; only care about the numeric status code. | |
317 (let ((status (url-dav-node-text node))) | |
318 (if (string-match "\\`[ \r\t\n]*HTTP/[0-9.]+ \\([0-9]+\\)" status) | |
62400
e30c08177a3b
Replace `string-to-int' by `string-to-number'.
Juanma Barranquero <lekktu@gmail.com>
parents:
54929
diff
changeset
|
319 (string-to-number (match-string 1 status)) |
54695 | 320 500))) |
321 | |
322 (defun url-dav-process-DAV:propstat (node) | |
323 ;; A propstate node can have the following children... | |
324 ;; | |
325 ;; DAV:prop - a list of properties and values | |
326 ;; DAV:status - An HTTP/1.1 status line | |
327 (let ((children (xml-node-children node)) | |
328 (props nil) | |
329 (status nil)) | |
330 (when (not children) | |
331 (error "No child nodes in DAV:propstat")) | |
332 | |
333 (setq props (url-dav-dispatch-node (assq 'DAV:prop children)) | |
334 status (url-dav-dispatch-node (assq 'DAV:status children))) | |
335 | |
336 ;; Need to parse out the HTTP status | |
337 (setq props (plist-put props 'DAV:status status)) | |
338 props)) | |
339 | |
340 (defun url-dav-process-DAV:response (node) | |
341 (let ((children (xml-node-children node)) | |
342 (propstat nil) | |
343 (href)) | |
344 (when (not children) | |
345 (error "No child nodes in DAV:response")) | |
346 | |
347 ;; A response node can have the following children... | |
348 ;; | |
349 ;; DAV:href - URL the response is for. | |
350 ;; DAV:propstat - see url-dav-process-propstat | |
351 ;; DAV:responsedescription - text description of the response | |
352 (setq propstat (assq 'DAV:propstat children) | |
353 href (assq 'DAV:href children)) | |
354 | |
355 (when (not href) | |
356 (error "No href in DAV:response")) | |
357 | |
358 (when (not propstat) | |
359 (error "No propstat in DAV:response")) | |
360 | |
361 (setq propstat (url-dav-dispatch-node propstat) | |
362 href (url-dav-dispatch-node href)) | |
363 (cons href propstat))) | |
364 | |
365 (defun url-dav-process-DAV:multistatus (node) | |
366 (let ((children (xml-node-children node)) | |
367 (results nil)) | |
368 (while children | |
369 (push (url-dav-dispatch-node (car children)) results) | |
370 (setq children (cdr children))) | |
371 results)) | |
372 | |
373 | |
374 ;;; DAV request/response generation/processing | |
375 (defun url-dav-process-response (buffer url) | |
54828
2eb49bad7ea9
Comments and docstring fixups.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
54795
diff
changeset
|
376 "Parse a WebDAV response from BUFFER, interpreting it relative to URL. |
54695 | 377 |
378 The buffer must have been retrieved by HTTP or HTTPS and contain an | |
54828
2eb49bad7ea9
Comments and docstring fixups.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
54795
diff
changeset
|
379 XML document." |
54695 | 380 (declare (special url-http-content-type |
381 url-http-response-status | |
382 url-http-end-of-headers)) | |
383 (let ((tree nil) | |
384 (overall-status nil)) | |
385 (when buffer | |
386 (unwind-protect | |
54929
42040974ab42
Use with-current-buffer.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
54828
diff
changeset
|
387 (with-current-buffer buffer |
54695 | 388 (goto-char url-http-end-of-headers) |
389 (setq overall-status url-http-response-status) | |
390 | |
391 ;; XML documents can be transferred as either text/xml or | |
392 ;; application/xml, and we are required to accept both of | |
393 ;; them. | |
394 (if (and | |
395 url-http-content-type | |
54929
42040974ab42
Use with-current-buffer.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
54828
diff
changeset
|
396 (string-match "\\`\\(text\\|application\\)/xml" |
42040974ab42
Use with-current-buffer.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
54828
diff
changeset
|
397 url-http-content-type)) |
54695 | 398 (setq tree (xml-parse-region (point) (point-max))))) |
399 ;; Clean up after ourselves. | |
54929
42040974ab42
Use with-current-buffer.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
54828
diff
changeset
|
400 (kill-buffer buffer))) |
54695 | 401 |
54929
42040974ab42
Use with-current-buffer.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
54828
diff
changeset
|
402 ;; We should now be |
54695 | 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)))))) | |
413 | |
414 (defun url-dav-request (url method tag body | |
415 &optional depth headers namespaces) | |
54828
2eb49bad7ea9
Comments and docstring fixups.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
54795
diff
changeset
|
416 "Perform WebDAV operation METHOD on URL. Return the parsed responses. |
54695 | 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>. | |
419 | |
420 DEPTH is how deep the request should propogate. 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 | |
423 though. | |
424 | |
425 HEADERS is an assoc list of extra headers to send in the request. | |
426 | |
427 NAMESPACES is an assoc list of (NAMESPACE . EXPANSION), and these are | |
428 added to the <TAG> element. The DAV=DAV: namespace is automatically | |
54828
2eb49bad7ea9
Comments and docstring fixups.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
54795
diff
changeset
|
429 added to this list, so most requests can just pass in nil." |
54695 | 430 ;; Take care of the default value for depth... |
431 (setq depth (or depth 0)) | |
432 | |
433 ;; Now lets translate it into something webdav can understand. | |
434 (if (< depth 0) | |
435 (setq depth "Infinity") | |
436 (setq depth (int-to-string depth))) | |
437 (if (not (assoc "DAV" namespaces)) | |
438 (setq namespaces (cons '("DAV" . "DAV:") namespaces))) | |
439 | |
440 (let* ((url-request-extra-headers `(("Depth" . ,depth) | |
441 ("Content-type" . "text/xml") | |
442 ,@headers)) | |
443 (url-request-method method) | |
444 (url-request-data | |
445 (if tag | |
446 (concat | |
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) "'")) | |
452 namespaces "\n ") | |
453 ">\n" | |
454 body | |
455 "</" (symbol-name tag) ">\n")))) | |
456 (url-dav-process-response (url-retrieve-synchronously url) url))) | |
457 | |
458 (defun url-dav-get-properties (url &optional attributes depth namespaces) | |
459 "Return properties for URL, up to DEPTH levels deep. | |
460 | |
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 | |
54828
2eb49bad7ea9
Comments and docstring fixups.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
54795
diff
changeset
|
463 names (ie: DAV:resourcetype)." |
54695 | 464 (url-dav-request url "PROPFIND" 'DAV:propfind |
465 (if attributes | |
466 (mapconcat (lambda (attr) | |
467 (concat "<DAV:prop><" | |
468 (symbol-name attr) | |
469 "/></DAV:prop>")) | |
470 attributes "\n ") | |
471 " <DAV:allprop/>") | |
472 depth nil namespaces)) | |
473 | |
474 (defmacro url-dav-http-success-p (status) | |
96486
7369ded3b436
Typo and docstring fixes.
Juanma Barranquero <lekktu@gmail.com>
parents:
94668
diff
changeset
|
475 "Return whether STATUS was the result of a successful DAV request." |
54695 | 476 `(= (/ (or ,status 500) 100) 2)) |
477 | |
478 | |
479 ;;; Locking support | |
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 | |
54828
2eb49bad7ea9
Comments and docstring fixups.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
54795
diff
changeset
|
485 make sure you are comfortable with it leaking to the outside world.") |
54695 | 486 |
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\). | |
491 | |
492 Returns a cons-cell of (SUCCESSFUL-RESULTS . FAILURE-RESULTS). | |
493 SUCCESSFUL-RESULTS is a list of (URL STATUS locktoken). | |
54828
2eb49bad7ea9
Comments and docstring fixups.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
54795
diff
changeset
|
494 FAILURE-RESULTS is a list of (URL STATUS)." |
54695 | 495 (setq exclusive (if exclusive "<DAV:exclusive/>" "<DAV:shared/>")) |
496 (let* ((body | |
497 (concat | |
498 " <DAV:lockscope>" exclusive "</DAV:lockscope>\n" | |
499 " <DAV:locktype> <DAV:write/> </DAV:locktype>\n" | |
500 " <DAV:owner>\n" | |
501 " <DAV:href>" url-dav-lock-identifier "</DAV:href>\n" | |
502 " </DAV:owner>\n")) | |
503 (response nil) ; Responses to the LOCK request | |
504 (result nil) ; For walking thru the response list | |
505 (child-url nil) | |
506 (child-status nil) | |
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")))) | |
511 | |
512 ;; Get the parent URL ready for expand-file-name | |
513 (if (not (vectorp url)) | |
514 (setq url (url-generic-parse-url url))) | |
515 | |
516 ;; Walk thru the response list, fully expand the URL, and grab the | |
517 ;; status code. | |
518 (while response | |
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))) | |
526 | |
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)) | |
530 (properties nil) | |
531 (child nil) | |
532 (child-url nil) | |
533 (child-results nil) | |
534 (results nil)) | |
535 (if (not (vectorp url)) | |
536 (setq url (url-generic-parse-url url))) | |
537 | |
538 (while response | |
539 (setq child (pop response) | |
540 child-url (pop child) | |
541 child-results nil) | |
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. | |
548 (while child | |
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))))) | |
555 (pop child))) | |
556 (if child-results | |
557 (push (cons (url-expand-file-name child-url url) child-results) | |
558 results))) | |
559 results)) | |
560 | |
561 (defun url-dav-unlock-resource (url lock-token) | |
562 "Release the lock on URL represented by LOCK-TOKEN. | |
78481
bc53aa750f3b
Replace `iff' in doc-strings and comments.
Glenn Morris <rgm@gnu.org>
parents:
78222
diff
changeset
|
563 Returns t if the lock was successfully released." |
54695 | 564 (declare (special url-http-response-status)) |
565 (let* ((url-request-extra-headers (list (cons "Lock-Token" | |
566 (concat "<" lock-token ">")))) | |
567 (url-request-method "UNLOCK") | |
568 (url-request-data nil) | |
569 (buffer (url-retrieve-synchronously url)) | |
570 (result nil)) | |
571 (when buffer | |
572 (unwind-protect | |
54929
42040974ab42
Use with-current-buffer.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
54828
diff
changeset
|
573 (with-current-buffer buffer |
54695 | 574 (setq result (url-dav-http-success-p url-http-response-status))) |
575 (kill-buffer buffer))) | |
576 result)) | |
577 | |
578 | |
579 ;;; file-name-handler stuff | |
580 (defun url-dav-file-attributes-mode-string (properties) | |
581 (let ((modes (make-string 10 ?-)) | |
582 (supported-locks (plist-get properties 'DAV:supportedlock)) | |
583 (executable-p (equal (plist-get properties 'http://apache.org/dav/props/executable) | |
584 "T")) | |
585 (directory-p (memq 'DAV:collection (plist-get properties 'DAV:resourcetype))) | |
586 (readable t) | |
587 (lock nil)) | |
588 ;; Assume we can read this, otherwise the PROPFIND would have | |
589 ;; failed. | |
590 (when readable | |
591 (aset modes 1 ?r) | |
592 (aset modes 4 ?r) | |
593 (aset modes 7 ?r)) | |
594 | |
595 (when directory-p | |
596 (aset modes 0 ?d)) | |
597 | |
598 (when executable-p | |
599 (aset modes 3 ?x) | |
600 (aset modes 6 ?x) | |
601 (aset modes 9 ?x)) | |
602 | |
603 (while supported-locks | |
604 (setq lock (car supported-locks) | |
605 supported-locks (cdr supported-locks)) | |
606 (case (car lock) | |
607 (DAV:write | |
608 (case (cdr lock) | |
609 (DAV:shared ; group permissions (possibly world) | |
610 (aset modes 5 ?w)) | |
611 (DAV:exclusive | |
612 (aset modes 2 ?w)) ; owner permissions? | |
613 (otherwise | |
614 (url-debug 'dav "Unrecognized DAV:lockscope (%S)" (cdr lock))))) | |
615 (otherwise | |
616 (url-debug 'dav "Unrecognized DAV:locktype (%S)" (car lock))))) | |
617 modes)) | |
618 | |
54795
31399f1df768
(url-dav-rename-file): Fix args of `signal'.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
54770
diff
changeset
|
619 (autoload 'url-http-head-file-attributes "url-http") |
31399f1df768
(url-dav-rename-file): Fix args of `signal'.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
54770
diff
changeset
|
620 |
54929
42040974ab42
Use with-current-buffer.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
54828
diff
changeset
|
621 (defun url-dav-file-attributes (url &optional id-format) |
73023
b401f081156a
(url-dav-file-attributes): Simplify.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
68640
diff
changeset
|
622 (let ((properties (cdar (url-dav-get-properties url)))) |
54695 | 623 (if (and properties |
624 (url-dav-http-success-p (plist-get properties 'DAV:status))) | |
625 ;; We got a good DAV response back.. | |
73023
b401f081156a
(url-dav-file-attributes): Simplify.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
68640
diff
changeset
|
626 (list |
b401f081156a
(url-dav-file-attributes): Simplify.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
68640
diff
changeset
|
627 ;; t for directory, string for symbolic link, or nil |
b401f081156a
(url-dav-file-attributes): Simplify.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
68640
diff
changeset
|
628 ;; Need to support DAV Bindings to figure out the |
b401f081156a
(url-dav-file-attributes): Simplify.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
68640
diff
changeset
|
629 ;; symbolic link issues. |
b401f081156a
(url-dav-file-attributes): Simplify.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
68640
diff
changeset
|
630 (if (memq 'DAV:collection (plist-get properties 'DAV:resourcetype)) t nil) |
54695 | 631 |
73023
b401f081156a
(url-dav-file-attributes): Simplify.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
68640
diff
changeset
|
632 ;; Number of links to file... Needs DAV Bindings. |
b401f081156a
(url-dav-file-attributes): Simplify.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
68640
diff
changeset
|
633 1 |
54695 | 634 |
73023
b401f081156a
(url-dav-file-attributes): Simplify.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
68640
diff
changeset
|
635 ;; File uid - no way to figure out? |
b401f081156a
(url-dav-file-attributes): Simplify.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
68640
diff
changeset
|
636 0 |
54695 | 637 |
73023
b401f081156a
(url-dav-file-attributes): Simplify.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
68640
diff
changeset
|
638 ;; File gid - no way to figure out? |
b401f081156a
(url-dav-file-attributes): Simplify.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
68640
diff
changeset
|
639 0 |
54695 | 640 |
73023
b401f081156a
(url-dav-file-attributes): Simplify.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
68640
diff
changeset
|
641 ;; Last access time - ??? |
b401f081156a
(url-dav-file-attributes): Simplify.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
68640
diff
changeset
|
642 nil |
54695 | 643 |
73023
b401f081156a
(url-dav-file-attributes): Simplify.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
68640
diff
changeset
|
644 ;; Last modification time |
b401f081156a
(url-dav-file-attributes): Simplify.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
68640
diff
changeset
|
645 (plist-get properties 'DAV:getlastmodified) |
54695 | 646 |
73023
b401f081156a
(url-dav-file-attributes): Simplify.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
68640
diff
changeset
|
647 ;; Last status change time... just reuse last-modified |
b401f081156a
(url-dav-file-attributes): Simplify.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
68640
diff
changeset
|
648 ;; for now. |
b401f081156a
(url-dav-file-attributes): Simplify.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
68640
diff
changeset
|
649 (plist-get properties 'DAV:getlastmodified) |
54695 | 650 |
73023
b401f081156a
(url-dav-file-attributes): Simplify.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
68640
diff
changeset
|
651 ;; size in bytes |
b401f081156a
(url-dav-file-attributes): Simplify.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
68640
diff
changeset
|
652 (or (plist-get properties 'DAV:getcontentlength) 0) |
54695 | 653 |
73023
b401f081156a
(url-dav-file-attributes): Simplify.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
68640
diff
changeset
|
654 ;; file modes as a string like `ls -l' |
78481
bc53aa750f3b
Replace `iff' in doc-strings and comments.
Glenn Morris <rgm@gnu.org>
parents:
78222
diff
changeset
|
655 ;; |
73023
b401f081156a
(url-dav-file-attributes): Simplify.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
68640
diff
changeset
|
656 ;; Should be able to build this up from the |
b401f081156a
(url-dav-file-attributes): Simplify.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
68640
diff
changeset
|
657 ;; DAV:supportedlock attribute pretty easily. Getting |
b401f081156a
(url-dav-file-attributes): Simplify.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
68640
diff
changeset
|
658 ;; the group info could be impossible though. |
b401f081156a
(url-dav-file-attributes): Simplify.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
68640
diff
changeset
|
659 (url-dav-file-attributes-mode-string properties) |
54695 | 660 |
78481
bc53aa750f3b
Replace `iff' in doc-strings and comments.
Glenn Morris <rgm@gnu.org>
parents:
78222
diff
changeset
|
661 ;; t if file's gid would change if it were deleted & |
73023
b401f081156a
(url-dav-file-attributes): Simplify.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
68640
diff
changeset
|
662 ;; recreated. No way for us to know that thru DAV. |
b401f081156a
(url-dav-file-attributes): Simplify.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
68640
diff
changeset
|
663 nil |
54695 | 664 |
73023
b401f081156a
(url-dav-file-attributes): Simplify.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
68640
diff
changeset
|
665 ;; inode number - meaningless |
b401f081156a
(url-dav-file-attributes): Simplify.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
68640
diff
changeset
|
666 nil |
54695 | 667 |
73023
b401f081156a
(url-dav-file-attributes): Simplify.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
68640
diff
changeset
|
668 ;; device number - meaningless |
b401f081156a
(url-dav-file-attributes): Simplify.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
68640
diff
changeset
|
669 nil) |
54695 | 670 ;; Fall back to just the normal http way of doing things. |
73023
b401f081156a
(url-dav-file-attributes): Simplify.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
68640
diff
changeset
|
671 (url-http-head-file-attributes url id-format)))) |
54695 | 672 |
673 (defun url-dav-save-resource (url obj &optional content-type lock-token) | |
674 "Save OBJ as URL using WebDAV. | |
675 URL must be a fully qualified URL. | |
676 OBJ may be a buffer or a string." | |
54795
31399f1df768
(url-dav-rename-file): Fix args of `signal'.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
54770
diff
changeset
|
677 (declare (special url-http-response-status)) |
54695 | 678 (let ((buffer nil) |
679 (result nil) | |
680 (url-request-extra-headers nil) | |
681 (url-request-method "PUT") | |
682 (url-request-data | |
683 (cond | |
684 ((bufferp obj) | |
54929
42040974ab42
Use with-current-buffer.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
54828
diff
changeset
|
685 (with-current-buffer obj |
54695 | 686 (buffer-string))) |
687 ((stringp obj) | |
688 obj) | |
689 (t | |
690 (error "Invalid object to url-dav-save-resource"))))) | |
691 | |
692 (if lock-token | |
693 (push | |
694 (cons "If" (concat "(<" lock-token ">)")) | |
695 url-request-extra-headers)) | |
696 | |
697 ;; Everything must always have a content-type when we submit it. | |
698 (push | |
699 (cons "Content-type" (or content-type "application/octet-stream")) | |
700 url-request-extra-headers) | |
701 | |
702 ;; Do the save... | |
703 (setq buffer (url-retrieve-synchronously url)) | |
704 | |
705 ;; Sanity checking | |
706 (when buffer | |
707 (unwind-protect | |
54929
42040974ab42
Use with-current-buffer.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
54828
diff
changeset
|
708 (with-current-buffer buffer |
54695 | 709 (setq result (url-dav-http-success-p url-http-response-status))) |
710 (kill-buffer buffer))) | |
711 result)) | |
712 | |
713 (eval-when-compile | |
714 (defmacro url-dav-delete-something (url lock-token &rest error-checking) | |
715 "Delete URL completely, with no sanity checking whatsoever. DO NOT USE. | |
716 This is defined as a macro that will not be visible from compiled files. | |
96486
7369ded3b436
Typo and docstring fixes.
Juanma Barranquero <lekktu@gmail.com>
parents:
94668
diff
changeset
|
717 Use with care, and even then think three times." |
54695 | 718 `(progn |
719 ,@error-checking | |
720 (url-dav-request ,url "DELETE" nil nil -1 | |
721 (if ,lock-token | |
722 (list | |
723 (cons "If" | |
724 (concat "(<" ,lock-token ">)")))))))) | |
725 | |
726 | |
727 (defun url-dav-delete-directory (url &optional recursive lock-token) | |
728 "Delete the WebDAV collection URL. | |
729 If optional second argument RECURSIVE is non-nil, then delete all | |
54828
2eb49bad7ea9
Comments and docstring fixups.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
54795
diff
changeset
|
730 files in the collection as well." |
54695 | 731 (let ((status nil) |
732 (props nil) | |
733 (props nil)) | |
734 (setq props (url-dav-delete-something | |
735 url lock-token | |
736 (setq props (url-dav-get-properties url '(DAV:getcontenttype) 1)) | |
737 (if (and (not recursive) | |
738 (/= (length props) 1)) | |
739 (signal 'file-error (list "Removing directory" | |
740 "directory not empty" url))))) | |
741 | |
742 (mapc (lambda (result) | |
743 (setq status (plist-get (cdr result) 'DAV:status)) | |
744 (if (not (url-dav-http-success-p status)) | |
745 (signal 'file-error (list "Removing directory" | |
86946
ef26aa002fe1
(url-dav-delete-directory): Fix message typo.
Glenn Morris <rgm@gnu.org>
parents:
84929
diff
changeset
|
746 "Error removing" |
54695 | 747 (car result) status)))) |
748 props)) | |
749 nil) | |
750 | |
751 (defun url-dav-delete-file (url &optional lock-token) | |
752 "Delete file named URL." | |
753 (let ((props nil) | |
754 (status nil)) | |
755 (setq props (url-dav-delete-something | |
756 url lock-token | |
757 (setq props (url-dav-get-properties url)) | |
758 (if (eq (plist-get (cdar props) 'DAV:resourcetype) 'DAV:collection) | |
759 (signal 'file-error (list "Removing old name" "is a collection" url))))) | |
760 | |
761 (mapc (lambda (result) | |
762 (setq status (plist-get (cdr result) 'DAV:status)) | |
763 (if (not (url-dav-http-success-p status)) | |
764 (signal 'file-error (list "Removing old name" | |
765 "Errror removing" | |
766 (car result) status)))) | |
767 props)) | |
768 nil) | |
769 | |
770 (defun url-dav-directory-files (url &optional full match nosort files-only) | |
96486
7369ded3b436
Typo and docstring fixes.
Juanma Barranquero <lekktu@gmail.com>
parents:
94668
diff
changeset
|
771 "Return a list of names of files in URL. |
54695 | 772 There are three optional arguments: |
773 If FULL is non-nil, return absolute file names. Otherwise return names | |
774 that are relative to the specified directory. | |
775 If MATCH is non-nil, mention only file names that match the regexp MATCH. | |
776 If NOSORT is non-nil, the list is not sorted--its order is unpredictable. | |
54828
2eb49bad7ea9
Comments and docstring fixups.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
54795
diff
changeset
|
777 NOSORT is useful if you plan to sort the result yourself." |
54695 | 778 (let ((properties (url-dav-get-properties url '(DAV:resourcetype) 1)) |
779 (child-url nil) | |
780 (child-props nil) | |
781 (files nil) | |
782 (parsed-url (url-generic-parse-url url))) | |
783 | |
784 (if (= (length properties) 1) | |
785 (signal 'file-error (list "Opening directory" "not a directory" url))) | |
786 | |
787 (while properties | |
788 (setq child-props (pop properties) | |
789 child-url (pop child-props)) | |
790 (if (and (eq (plist-get child-props 'DAV:resourcetype) 'DAV:collection) | |
791 files-only) | |
792 ;; It is a directory, and we were told to return just files. | |
793 nil | |
794 | |
795 ;; Fully expand the URL and then rip off the beginning if we | |
796 ;; are not supposed to return fully-qualified names. | |
797 (setq child-url (url-expand-file-name child-url parsed-url)) | |
798 (if (not full) | |
799 (setq child-url (substring child-url (length url)))) | |
800 | |
801 ;; We don't want '/' as the last character in filenames... | |
802 (if (string-match "/$" child-url) | |
803 (setq child-url (substring child-url 0 -1))) | |
804 | |
805 ;; If we have a match criteria, then apply it. | |
806 (if (or (and match (not (string-match match child-url))) | |
807 (string= child-url "") | |
808 (string= child-url url)) | |
809 nil | |
810 (push child-url files)))) | |
811 | |
812 (if nosort | |
813 files | |
814 (sort files 'string-lessp)))) | |
815 | |
816 (defun url-dav-file-directory-p (url) | |
817 "Return t if URL names an existing DAV collection." | |
818 (let ((properties (cdar (url-dav-get-properties url '(DAV:resourcetype))))) | |
819 (eq (plist-get properties 'DAV:resourcetype) 'DAV:collection))) | |
820 | |
821 (defun url-dav-make-directory (url &optional parents) | |
822 "Create the directory DIR and any nonexistent parent dirs." | |
823 (declare (special url-http-response-status)) | |
824 (let* ((url-request-extra-headers nil) | |
825 (url-request-method "MKCOL") | |
826 (url-request-data nil) | |
827 (buffer (url-retrieve-synchronously url)) | |
828 (result nil)) | |
829 (when buffer | |
830 (unwind-protect | |
54929
42040974ab42
Use with-current-buffer.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
54828
diff
changeset
|
831 (with-current-buffer buffer |
54695 | 832 (case url-http-response-status |
833 (201 ; Collection created in its entirety | |
834 (setq result t)) | |
835 (403 ; Forbidden | |
836 nil) | |
837 (405 ; Method not allowed | |
838 nil) | |
839 (409 ; Conflict | |
840 nil) | |
841 (415 ; Unsupported media type (WTF?) | |
842 nil) | |
843 (507 ; Insufficient storage | |
844 nil) | |
845 (otherwise | |
846 nil))) | |
847 (kill-buffer buffer))) | |
848 result)) | |
849 | |
850 (defun url-dav-rename-file (oldname newname &optional overwrite) | |
851 (if (not (and (string-match url-handler-regexp oldname) | |
852 (string-match url-handler-regexp newname))) | |
54795
31399f1df768
(url-dav-rename-file): Fix args of `signal'.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
54770
diff
changeset
|
853 (signal 'file-error |
31399f1df768
(url-dav-rename-file): Fix args of `signal'.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
54770
diff
changeset
|
854 (list "Cannot rename between different URL backends" |
31399f1df768
(url-dav-rename-file): Fix args of `signal'.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
54770
diff
changeset
|
855 oldname newname))) |
54695 | 856 |
857 (let* ((headers nil) | |
858 (props nil) | |
859 (status nil) | |
860 (directory-p (url-dav-file-directory-p oldname)) | |
861 (exists-p (url-http-file-exists-p newname))) | |
862 | |
863 (if (and exists-p | |
84929
ffdba9eb7f4e
(top): Use `mapc' rather than `mapcar'.
Juanma Barranquero <lekktu@gmail.com>
parents:
78481
diff
changeset
|
864 (or |
54695 | 865 (null overwrite) |
866 (and (numberp overwrite) | |
867 (not (yes-or-no-p | |
868 (format "File %s already exists; rename to it anyway? " | |
869 newname)))))) | |
870 (signal 'file-already-exists (list "File already exists" newname))) | |
871 | |
872 ;; Honor the overwrite flag... | |
873 (if overwrite (push '("Overwrite" . "T") headers)) | |
874 | |
875 ;; Have to tell them where to copy it to! | |
876 (push (cons "Destination" newname) headers) | |
877 | |
878 ;; Always send a depth of -1 in case we are moving a collection. | |
879 (setq props (url-dav-request oldname "MOVE" nil nil (if directory-p -1 0) | |
880 headers)) | |
881 | |
882 (mapc (lambda (result) | |
883 (setq status (plist-get (cdr result) 'DAV:status)) | |
884 | |
885 (if (not (url-dav-http-success-p status)) | |
886 (signal 'file-error (list "Renaming" oldname newname status)))) | |
887 props) | |
888 t)) | |
889 | |
890 (defun url-dav-file-name-all-completions (file url) | |
96486
7369ded3b436
Typo and docstring fixes.
Juanma Barranquero <lekktu@gmail.com>
parents:
94668
diff
changeset
|
891 "Return a list of all completions of file name FILE in URL. |
7369ded3b436
Typo and docstring fixes.
Juanma Barranquero <lekktu@gmail.com>
parents:
94668
diff
changeset
|
892 These are all file names in URL which begin with FILE." |
54695 | 893 (url-dav-directory-files url nil (concat "^" file ".*"))) |
894 | |
895 (defun url-dav-file-name-completion (file url) | |
96486
7369ded3b436
Typo and docstring fixes.
Juanma Barranquero <lekktu@gmail.com>
parents:
94668
diff
changeset
|
896 "Complete file name FILE in URL. |
7369ded3b436
Typo and docstring fixes.
Juanma Barranquero <lekktu@gmail.com>
parents:
94668
diff
changeset
|
897 Returns the longest string common to all file names in URL |
7369ded3b436
Typo and docstring fixes.
Juanma Barranquero <lekktu@gmail.com>
parents:
94668
diff
changeset
|
898 that start with FILE. |
54695 | 899 If there is only one and FILE matches it exactly, returns t. |
96486
7369ded3b436
Typo and docstring fixes.
Juanma Barranquero <lekktu@gmail.com>
parents:
94668
diff
changeset
|
900 Returns nil if URL contains no name starting with FILE." |
54695 | 901 (let ((matches (url-dav-file-name-all-completions file url)) |
902 (result nil)) | |
903 (cond | |
904 ((null matches) | |
905 ;; No matches | |
906 nil) | |
907 ((and (= (length matches) 1) | |
908 (string= file (car matches))) | |
909 ;; Only one file and FILE matches it exactly... | |
910 t) | |
911 (t | |
912 ;; Need to figure out the longest string that they have in commmon | |
913 (setq matches (sort matches (lambda (a b) (> (length a) (length b))))) | |
914 (let ((n (length file)) | |
915 (searching t) | |
916 (regexp nil) | |
917 (failed nil)) | |
918 (while (and searching | |
919 (< n (length (car matches)))) | |
920 (setq regexp (concat "^" (substring (car matches) 0 (1+ n))) | |
921 failed nil) | |
922 (dolist (potential matches) | |
923 (if (not (string-match regexp potential)) | |
924 (setq failed t))) | |
925 (if failed | |
926 (setq searching nil) | |
927 (incf n))) | |
928 (substring (car matches) 0 n)))))) | |
929 | |
930 (defun url-dav-register-handler (op) | |
931 (put op 'url-file-handlers (intern-soft (format "url-dav-%s" op)))) | |
932 | |
84929
ffdba9eb7f4e
(top): Use `mapc' rather than `mapcar'.
Juanma Barranquero <lekktu@gmail.com>
parents:
78481
diff
changeset
|
933 (mapc 'url-dav-register-handler |
ffdba9eb7f4e
(top): Use `mapc' rather than `mapcar'.
Juanma Barranquero <lekktu@gmail.com>
parents:
78481
diff
changeset
|
934 ;; These handlers are disabled because they incorrectly presume that |
ffdba9eb7f4e
(top): Use `mapc' rather than `mapcar'.
Juanma Barranquero <lekktu@gmail.com>
parents:
78481
diff
changeset
|
935 ;; the URL specifies an HTTP location and thus break FTP URLs. |
ffdba9eb7f4e
(top): Use `mapc' rather than `mapcar'.
Juanma Barranquero <lekktu@gmail.com>
parents:
78481
diff
changeset
|
936 '(;; file-name-all-completions |
ffdba9eb7f4e
(top): Use `mapc' rather than `mapcar'.
Juanma Barranquero <lekktu@gmail.com>
parents:
78481
diff
changeset
|
937 ;; file-name-completion |
ffdba9eb7f4e
(top): Use `mapc' rather than `mapcar'.
Juanma Barranquero <lekktu@gmail.com>
parents:
78481
diff
changeset
|
938 ;; rename-file |
ffdba9eb7f4e
(top): Use `mapc' rather than `mapcar'.
Juanma Barranquero <lekktu@gmail.com>
parents:
78481
diff
changeset
|
939 ;; make-directory |
ffdba9eb7f4e
(top): Use `mapc' rather than `mapcar'.
Juanma Barranquero <lekktu@gmail.com>
parents:
78481
diff
changeset
|
940 ;; file-directory-p |
ffdba9eb7f4e
(top): Use `mapc' rather than `mapcar'.
Juanma Barranquero <lekktu@gmail.com>
parents:
78481
diff
changeset
|
941 ;; directory-files |
ffdba9eb7f4e
(top): Use `mapc' rather than `mapcar'.
Juanma Barranquero <lekktu@gmail.com>
parents:
78481
diff
changeset
|
942 ;; delete-file |
ffdba9eb7f4e
(top): Use `mapc' rather than `mapcar'.
Juanma Barranquero <lekktu@gmail.com>
parents:
78481
diff
changeset
|
943 ;; delete-directory |
ffdba9eb7f4e
(top): Use `mapc' rather than `mapcar'.
Juanma Barranquero <lekktu@gmail.com>
parents:
78481
diff
changeset
|
944 ;; file-attributes |
ffdba9eb7f4e
(top): Use `mapc' rather than `mapcar'.
Juanma Barranquero <lekktu@gmail.com>
parents:
78481
diff
changeset
|
945 )) |
54695 | 946 |
947 | |
948 ;;; Version Control backend cruft | |
949 | |
950 ;(put 'vc-registered 'url-file-handlers 'url-dav-vc-registered) | |
951 | |
952 ;;;###autoload | |
953 (defun url-dav-vc-registered (url) | |
954 (if (and (string-match "\\`https?" url) | |
955 (plist-get (url-http-options url) 'dav)) | |
956 (progn | |
957 (vc-file-setprop url 'vc-backend 'dav) | |
958 t))) | |
959 | |
960 | |
961 ;;; Miscellaneous stuff. | |
962 | |
963 (provide 'url-dav) | |
54699 | 964 |
54828
2eb49bad7ea9
Comments and docstring fixups.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
54795
diff
changeset
|
965 ;; arch-tag: 2b14b7b3-888a-49b8-a490-17276a40e78e |
2eb49bad7ea9
Comments and docstring fixups.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
54795
diff
changeset
|
966 ;;; url-dav.el ends here |