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