From 6d397148565e581f9546b3b8dfb882a78890b60f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Tue, 18 Apr 2023 19:26:42 +0200 Subject: Utilities for namespaced sxml. --- module/calp/webdav/propfind.scm | 1 + module/calp/webdav/resource/base.scm | 6 +---- module/calp/webdav/resource/virtual.scm | 1 + module/sxml/namespaced.scm | 12 +++++++-- module/sxml/namespaced/util.scm | 45 +++++++++++++++++++++++++++++++++ 5 files changed, 58 insertions(+), 7 deletions(-) create mode 100644 module/sxml/namespaced/util.scm 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 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)))) -- cgit v1.2.3