From 3513efa939a3811f221ea82ff8d91467c9aea6c1 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= <hugo@lysator.liu.se>
Date: Sat, 21 Oct 2023 16:58:44 +0200
Subject: Add tests for sxml namespaced + fix 'root-element'.

* Removes on-root-element since it was never used
* Handle the case of root-elemnt with no *TOP*
---
 module/sxml/namespaced/util.scm          | 15 +++---------
 tests/unit/sxml/sxml-namespaced-util.scm | 42 ++++++++++++++++++++++++++++++++
 2 files changed, 46 insertions(+), 11 deletions(-)
 create mode 100644 tests/unit/sxml/sxml-namespaced-util.scm

diff --git a/module/sxml/namespaced/util.scm b/module/sxml/namespaced/util.scm
index 6f93e362..e05f2fa1 100644
--- a/module/sxml/namespaced/util.scm
+++ b/module/sxml/namespaced/util.scm
@@ -5,7 +5,6 @@
   :export (xml-element-hash-key
            find-element
            element-matches?
-           on-root-element
            root-element
            ))
 
@@ -30,16 +29,10 @@
         (xml-element-hash-key (car tree)))))
 
 
-(define (on-root-element proc tree)
+(define (root-element tree)
   (cond ((and (eq? '*TOP* (car tree))
               (pi-element? (cadr tree)))
-         (cons* (car tree) (cadr tree)
-                (proc (caddr tree))))
+         (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))))
+         (cadr tree))
+        (else tree)))
diff --git a/tests/unit/sxml/sxml-namespaced-util.scm b/tests/unit/sxml/sxml-namespaced-util.scm
new file mode 100644
index 00000000..6f48105f
--- /dev/null
+++ b/tests/unit/sxml/sxml-namespaced-util.scm
@@ -0,0 +1,42 @@
+(define-module (test sxml-namespaced-util)
+  :use-module (srfi srfi-64)
+  :use-module (sxml namespaced)
+  :use-module (sxml namespaced util))
+
+(define ns (gensym "xmlns-"))
+
+(test-equal "XML Hash key"
+  (cons 'a ns)
+  (xml-element-hash-key (xml 'a ns)))
+
+(test-group "Find element"
+  (let ((el `(,(xml ns 'a))))
+    (test-eq "Found element is the source element"
+      el
+      (find-element
+       (car el)
+       `((,(xml ns 'b)) ,el (,(xml ns 'a))))))
+  ;; TODO Test "find" failure
+  )
+
+(test-group "Element Match"
+ (test-assert "Positive element match"
+   (element-matches? (xml 'a ns)
+                     (list (xml 'a ns)
+                           "Content here")))
+ (test-assert "Negative element match"
+   (not (element-matches? (xml 'a ns)
+                          (list (xml 'b ns)
+                                "Content here")))))
+
+(let ((el `(,(xml 'a) "Content")))
+ (test-group "root-element"
+   (test-equal "With PI"
+     el (root-element `(*TOP* ,(pi-element 'doctype "HTML") ,el)))
+   (test-equal "Without PI"
+     el (root-element `(*TOP* ,el)))
+
+   (test-equal "Bare"
+     el (root-element el))))
+
+'((sxml namespaced util))
-- 
cgit v1.2.3