Utilities for namespaced sxml.

5 files changed, 58 insertions, 7 deletions

diff --git a/module/calp/webdav/propfind.scm b/module/calp/webdav/propfind.scm
index 3e86304c..83725825 100644
--- a/module/calp/webdav/propfind.scm
+++ b/module/calp/webdav/propfind.scm
@@ -4,6 +4,7 @@
   :use-module (calp namespaces)
   :use-module (srfi srfi-1)
   :use-module (sxml namespaced)
+  :use-module (sxml namespaced util)
   :export (propfind-selected-properties
            propfind-all-live-properties
            propfind-most-live-properties
diff --git a/module/calp/webdav/resource/base.scm b/module/calp/webdav/resource/base.scm
index 5f308cc7..95e9ad43 100644
--- a/module/calp/webdav/resource/base.scm
+++ b/module/calp/webdav/resource/base.scm
@@ -5,6 +5,7 @@
   :use-module (srfi srfi-88)
   :use-module (oop goops)
   :use-module (sxml namespaced)
+  :use-module (sxml namespaced util)
   :use-module (calp webdav property)
   :use-module (calp namespaces)
   :use-module ((hnh util) :select (unless))
@@ -22,7 +23,6 @@
            ;; resource-children
            resource?
            children
-           xml-element-hash-key
 
 
 
@@ -276,10 +276,6 @@
        status)
       ((collision) 'collision))))
 
-(define (xml-element-hash-key tag)
-  "Returns a value suitable as a key to hash-ref (and family)"
-  (cons (xml-element-namespace tag)
-        (xml-element-tagname tag)))
 
 ;; Only tagname and namespaces are checked on the <xml-element> for the {get,set}-property
 
diff --git a/module/calp/webdav/resource/virtual.scm b/module/calp/webdav/resource/virtual.scm
index 2fcaa76a..1d2d5d31 100644
--- a/module/calp/webdav/resource/virtual.scm
+++ b/module/calp/webdav/resource/virtual.scm
@@ -4,6 +4,7 @@
   :use-module (rnrs bytevectors)
   :use-module (hnh util)
   :use-module (sxml namespaced)
+  :use-module (sxml namespaced util)
   :use-module (calp webdav resource)
   :use-module (calp webdav property)
   :use-module (calp namespaces)
diff --git a/module/sxml/namespaced.scm b/module/sxml/namespaced.scm
index 846f8f25..e5a334da 100644
--- a/module/sxml/namespaced.scm
+++ b/module/sxml/namespaced.scm
@@ -15,10 +15,13 @@
            namespaced-sxml->sxml/namespaces
            sxml->namespaced-sxml
            xml
+           attribute
 
            make-xml-element
            xml-element?
-           xml-element-tagname xml-element-namespace xml-element-attributes
+           xml-element-tagname
+           xml-element-namespace
+           xml-element-attributes
 
            make-pi-element
            pi-element?
@@ -52,6 +55,9 @@
     ((ns tag) (make-xml-element tag ns '()))
     ((ns tag attrs) (make-xml-element tag ns attrs))))
 
+(define (attribute xml attr)
+  (assoc-ref (xml-element-attributes xml) attr))
+
 
 (define* (parser key: trim-whitespace?)
  (ssax:make-parser
@@ -226,7 +232,8 @@
 (define* (namespaced-sxml->xml tree key:
                                (namespaces '())
                                (port (current-output-port)))
-  ((@ (sxml simple) sxml->xml) (namespaced-sxml->sxml tree namespaces) port))
+  ((@ (sxml simple) sxml->xml)
+   (namespaced-sxml->sxml tree namespaces) port))
 
 ;; Takes a tree of namespaced-sxml, and optionally an assoc list from namespace symbols, to prefered prefix.
 ;; Returns two values: a sxml tree without declared namespaces
@@ -256,3 +263,4 @@
 ;;; TODO Figure out how to still use (sxml match) and (sxml xpath) with these
 ;;;      new trees (probably rewriting to a "regular" sxml tree, and keeping
 ;;;      a strict mapping of namespaces)
+
diff --git a/module/sxml/namespaced/util.scm b/module/sxml/namespaced/util.scm
new file mode 100644
index 00000000..6f93e362
--- /dev/null
+++ b/module/sxml/namespaced/util.scm
@@ -0,0 +1,45 @@
+(define-module (sxml namespaced util)
+  :use-module (sxml namespaced)
+  :use-module (srfi srfi-1)
+  :use-module ((ice-9 control) :select (call/ec))
+  :export (xml-element-hash-key
+           find-element
+           element-matches?
+           on-root-element
+           root-element
+           ))
+
+(define (xml-element-hash-key tag)
+  "Returns a value suitable as a key to hash-ref (and family)"
+  (cons (xml-element-namespace tag)
+        (xml-element-tagname tag)))
+
+(define (find-element target list)
+  (define target* (xml-element-hash-key target))
+  (find (lambda (x) (and (list? x)
+                    (not (null? x))
+                    (xml-element? (car x))
+                    (equal? target* (xml-element-hash-key (car x)))))
+        list))
+
+
+(define (element-matches? target-el tree)
+  (and (not (null? tree))
+       (equal?
+        (xml-element-hash-key target-el)
+        (xml-element-hash-key (car tree)))))
+
+
+(define (on-root-element proc tree)
+  (cond ((and (eq? '*TOP* (car tree))
+              (pi-element? (cadr tree)))
+         (cons* (car tree) (cadr tree)
+                (proc (caddr tree))))
+        ((eq? '*TOP* (car tree))
+         (cons (car tree)
+               (proc (cadr tree))))
+        (else (proc (car tree)))))
+
+(define (root-element tree)
+  (call/ec (lambda (return)
+             (on-root-element return tree))))