lisp/url/url-dav.el

35 (require 'xml)
55   (and (featurep 'xml)
56        (fboundp 'xml-expand-namespace)
60 (defun url-dav-node-text (node)
61   "Return the text data from the XML node NODE."
65 		 "")) (xml-node-children node) " "))
69 ;;; Parsing routines for the actual node contents.
78 (defun url-dav-process-integer-property (node)
79   (truncate (string-to-number (url-dav-node-text node))))
81 (defun url-dav-process-number-property (node)
82   (string-to-number (url-dav-node-text node)))
111 (defun url-dav-process-date-property (node)
116 	 (date-string (url-dav-node-text node))
149 		 (xml-node-name node) date-string))
152 (defun url-dav-process-boolean-property (node)
153   (/= 0 (string-to-number (url-dav-node-text node))))
155 (defun url-dav-process-uri-property (node)
157   (url-generic-parse-url (url-dav-node-text node)))
159 (defun url-dav-find-parser (node)
160   "Find a function to parse the XML node NODE."
161   (or (get (xml-node-name node) 'dav-parser)
162       (let ((fn (intern (format "url-dav-process-%s" (xml-node-name node)))))
164 	    (setq fn 'url-dav-node-text)
165 	  (put (xml-node-name node) 'dav-parser fn))
168 (defmacro url-dav-dispatch-node (node)
169   `(funcall (url-dav-find-parser ,node) ,node))
171 (defun url-dav-process-DAV:prop (node)
172   ;; A prop node has content model of ANY
182   ;; DAV:resourcetype     - node who's name is the resource type
187   (let ((children (xml-node-children node))
188 	(node-type nil)
196       (setq node (car children)
197 	    node-type (intern
200 					(xml-node-attributes node)))
204       (case node-type
212 	 (setq value (url-dav-process-date-property node)))
215 	 (setq value (url-dav-process-integer-property node)))
217 	 (setq value (url-dav-process-number-property node)))
219 	 (setq value (url-dav-process-boolean-property node)))
221 	 (setq value (url-dav-process-uri-property node)))
223 	 (if (not (eq node-type 'unknown))
225 			node-type))
226 	 (setq value (url-dav-dispatch-node node))))
228       (setq props (plist-put props (xml-node-name node) value)
232 (defun url-dav-process-DAV:supportedlock (node)
235   ;; The DAV:lockscope must have a single node beneath it, ditto for
237   (let ((children (xml-node-children node))
242 		 (eq (xml-node-name (car children)) 'DAV:lockentry))
243 	(setq scope (assq 'DAV:lockscope (xml-node-children (car children)))
244 	      type (assq 'DAV:locktype (xml-node-children (car children))))
246 	  (setq scope (xml-node-name (car (xml-node-children scope)))
247 		type (xml-node-name (car (xml-node-children type))))
252 (defun url-dav-process-subnode-property (node)
253   ;; Returns a list of child node names.
254   (delq nil (mapcar 'car-safe (xml-node-children node))))
266 (defun url-dav-process-DAV:locktoken (node)
271 			(url-dav-dispatch-node n)))
272 		    (xml-node-children node))))
274 (defun url-dav-process-DAV:owner (node)
279 			(url-dav-dispatch-node n)))
280 		    (xml-node-children node))))
282 (defun url-dav-process-DAV:activelock (node)
290   (let ((children (xml-node-children node))
294 	  (push (cons (xml-node-name (car children))
295 		      (url-dav-dispatch-node (car children)))
300 (defun url-dav-process-DAV:lockdiscovery (node)
302   (let ((children (xml-node-children node))
307 	;; text node? why?
309        ((eq (xml-node-name (car children)) 'DAV:activelock)
310 	(push (url-dav-dispatch-node (car children)) results))
317 (defun url-dav-process-DAV:status (node)
318   ;; The node contains a standard HTTP/1.1 response line... we really
320   (let ((status (url-dav-node-text node)))
325 (defun url-dav-process-DAV:propstat (node)
326   ;; A propstate node can have the following children...
330   (let ((children (xml-node-children node))
336     (setq props (url-dav-dispatch-node (assq 'DAV:prop children))
337 	  status (url-dav-dispatch-node (assq 'DAV:status children)))
343 (defun url-dav-process-DAV:response (node)
344   (let ((children (xml-node-children node))
350     ;; A response node can have the following children...
364     (setq propstat (url-dav-dispatch-node propstat)
365 	  href (url-dav-dispatch-node href))
368 (defun url-dav-process-DAV:multistatus (node)
369   (let ((children (xml-node-children node))
372       (push (url-dav-dispatch-node (car children)) results)
395 	    ;; XML documents can be transferred as either text/xml or
396 	    ;; application/xml, and we are required to accept both of
400 		 (string-match "\\`\\(text\\|application\\)/xml"
402 		(setq tree (xml-parse-region (point) (point-max)))))
407     (if (eq (xml-node-name (car tree)) 'DAV:multistatus)
408 	(url-dav-dispatch-node (car tree))
410       (let ((properties (url-dav-dispatch-node (car tree))))
411 	;; We need to make sure we have a DAV:status node in there for
445 				      ("Content-type" . "text/xml")
451 	       "<?xml version=\"1.0\" encoding=\"utf-8\" ?>\n"
462 (defun url-dav-get-properties (url &optional attributes depth namespaces)
469 		   (if attributes
474 				  attributes "\n  ")
586 (defun url-dav-file-attributes-mode-string (properties)
625 (autoload 'url-http-head-file-attributes "url-http")
627 (defun url-dav-file-attributes (url &optional id-format)
665          (url-dav-file-attributes-mode-string properties)
677       (url-http-head-file-attributes url id-format))))
951 	  ;; file-attributes