1 ;;; -*- show-trailing-whitespace: t; indent-tabs: nil -*-
3 ;;; Copyright (c) 2007 David Lichteblau. All rights reserved.
4 ;;; (mostly transcribed from nu/xom/tests/*)
6 ;;; Redistribution and use in source and binary forms, with or without
7 ;;; modification, are permitted provided that the following conditions
10 ;;; * Redistributions of source code must retain the above copyright
11 ;;; notice, this list of conditions and the following disclaimer.
13 ;;; * Redistributions in binary form must reproduce the above
14 ;;; copyright notice, this list of conditions and the following
15 ;;; disclaimer in the documentation and/or other materials
16 ;;; provided with the distribution.
18 ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
19 ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
20 ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
21 ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
22 ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
23 ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
24 ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
25 ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
26 ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
27 ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
28 ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
30 (defpackage :cxml-stp-test
32 #+openmcl
(:shadow
#:check-type
))
34 (in-package :cxml-stp-test
)
37 (defmacro check-type
(place type
)
38 `(assert (typep ,place
',type
)))
40 (defmethod xmlconf::serialize-document
((document node
))
41 (serialize document
(cxml:make-octet-vector-sink
:canonical
2)))
43 (defun stp-test (filename handler
&rest args
)
44 (declare (ignore handler
))
45 (apply #'cxml
:parse-file
47 (read-from-string "#.(cxml-stp:make-builder)")
53 (let ((cxml-stp::*serialize-canonical-notations-only-p
* t
))
54 (xmlconf::run-all-tests
'xmlconf
::stp-test
55 "/home/david/2001/XML-Test-Suite/xmlconf/"))
58 (defun assert-equal (a b
)
60 (error "assertion failed: ~S and ~S are not EQUAL" a b
)))
62 (defun assert-node= (a b
)
64 (error "assertion failed: ~S and ~S are not NODE=" a b
)))
66 (defmacro expect-condition
(form type
&optional data
)
70 (error "expected a condition of type ~A in:~%~A~@[~%for value ~A~]"
76 (defun serialize-to-string (node)
77 (let ((sink (cxml:make-string-sink
)))
79 (sax:end-document sink
)))
81 (defmacro define-condition-test
(name form type
)
84 (expect-condition ,form
,type
)
87 (defun child-count (node)
88 (count-children-if (constantly t
) node
))
90 (defun named-node-= (a b
)
91 (and (equal (namespace-uri a
) (namespace-uri b
))
92 (equal (namespace-prefix a
) (namespace-prefix b
))
93 (equal (local-name a
) (local-name b
))))
95 (defun parent-node-= (e f
)
96 (and (eql (child-count e
)
98 (every #'node
= (list-children e
) (list-children f
))))
100 (defmethod node= ((e element
) (f element
))
101 (and (named-node-= e f
)
104 (set-exclusive-or (list-attributes e
) (list-attributes f
)
106 (flet ((collect-namespaces (elt)
108 (map-extra-namespaces (lambda (k v
) (push (cons k v
) result
))
112 (set-exclusive-or (collect-namespaces e
) (collect-namespaces f
)
115 (defmethod node= ((a node
) (b node
))
118 (defmethod node= ((e document
) (f document
))
121 (defmethod node= ((a attribute
) (b attribute
))
122 (and (named-node-= a b
)
123 (equal (value a
) (value b
))))
125 (defmethod node= ((a comment
) (b comment
))
126 (equal (data a
) (data b
)))
128 (defmethod node= ((a text
) (b text
))
129 (equal (data a
) (data b
)))
131 (defmethod node= ((a processing-instruction
) (b processing-instruction
))
132 (and (equal (data a
) (data b
))
133 (equal (target a
) (target b
))))
135 (defmethod node= ((a document-type
) (b document-type
))
136 (and (equal (root-element-name a
) (root-element-name b
))
137 (equal (public-id a
) (public-id b
))
138 (equal (system-id a
) (system-id b
))
139 (equal (internal-subset a
) (internal-subset b
))))
146 (deftest text.constructor
147 (data (make-text "test"))
151 (let ((text (make-text "name")))
152 (dolist (str '("Hello"
154 " spaces on both ends "
155 " quotes \" \" quotes"
156 " single \'\' quotes"
157 " both double and single \"\'\"\' quotes"
158 " angle brackets < > <<<"
159 #.
(format nil
" carriage returns ~C~C"
160 (code-char 13) (code-char 13))
161 #.
(format nil
" newlines ~C~C"
162 (code-char 10) (code-char 10))
163 #.
(format nil
" both ~C~C"
164 (code-char 13) (code-char 10))
165 #.
(format nil
" tab ~C foo"
168 " <![CDATA[ CDATA end: ]]>"
170 " ampersands & &&& &name; "))
171 (setf (data text
) str
)
172 (assert-equal (data text
) str
)
173 (assert-equal (string-value text
) str
))
177 (let ((text (make-text "name")))
178 (setf (data text
) nil
)
182 (define-condition-test text.illegal
183 (let ((text (make-text "name")))
184 (setf (data text
) (format nil
"test ~C test" (code-char 0))))
187 (deftest text.serialize
188 (let ((text (make-text "name"))
191 " spaces on both ends "
192 ;; zzz CXML traditionally escapes quotes without good
194 (" quotes \" \" quotes"
195 " quotes " " quotes")
196 (" both double and single \"\'\"\' quotes"
197 " both double and single "\'"\' quotes")
198 " single \'\' quotes"
200 ("&" "&amp;")
202 (#.
(string (code-char 13)) " ")
203 "=,.!@#$%^*()_-'[]{}+/?;:`|\\")))
205 for
(in out
) in
(mapcar (lambda (x) (if (listp x
) x
(list x x
)))
208 (setf (data text
) in
)
209 (assert-equal (serialize-to-string text
) out
))
213 (let* ((c1 (make-text "test"))
215 (assert (not (eq c1 c2
)))
216 (assert-equal (data c1
) (data c2
))
217 (assert-equal nil
(parent c2
))
218 (assert-equal (type-of c2
) 'text
)
221 ;;; zzz surrogate testing is going to be a bit more work, because cxml
222 ;;; supports both Lisps with 16 bit and with 21 bit characters.
226 ;;; - testHighSurrogateWithNoLowSurrogate
228 (deftest text.leaf-node
229 (let ((c1 (make-text "data")))
230 (assert-equal 0 (child-count c1
))
231 (expect-condition (nth-child 0 c1
) error
)
232 (assert-equal nil
(parent c1
))
233 (let ((e (make-element "test")))
235 (assert-equal e
(parent c1
))
236 (assert-equal c1
(nth-child 0 e
))
238 (assert-equal 0 (child-count e
)))
241 (deftest text.print-object
242 (let ((n (make-text "heyho")))
243 (assert-node= n
(read-from-string (write-to-string n
)))
249 (deftest comment.constructor
250 (data (make-comment "test"))
253 (deftest comment.constructor2
254 (data (make-comment ""))
257 (deftest comment.constructor3
258 (data (make-comment "- - "))
261 (deftest comment.copy
262 (let* ((c1 (make-comment "test"))
264 (assert (not (eq c1 c2
)))
265 (assert-equal (data c1
) (data c2
))
266 (assert-equal nil
(parent c2
))
267 (assert-equal (type-of c2
) 'comment
)
270 (deftest comment.serialize
271 (let ((c (make-comment "0123456789012345678901234567890123456789")))
272 (assert-equal (serialize-to-string c
)
273 "<!--0123456789012345678901234567890123456789-->")
276 ;;; zzz das pruefen wir nicht
277 ;; (define-condition-test comment.cr
278 ;; (make-comment (format nil "foo ~C bar" (code-char 13)))
281 (deftest comment.setf
282 (let ((c (make-comment "test")))
283 (setf (data c
) "legal")
284 (assert-equal (data c
) "legal")
285 (assert-equal (string-value c
) "legal")
286 (expect-condition (setf (data c
) "test -- test") stp-error
)
287 (expect-condition (setf (data c
) "test-") stp-error
)
289 (assert-equal (data c
) "")
294 ;;; - testForbidUnmatchedSurrogatesInComments
296 (deftest comment.leaf-node
297 (let ((c1 (make-comment "data")))
298 (assert-equal 0 (child-count c1
))
299 (expect-condition (nth-child 0 c1
) error
)
300 (assert-equal nil
(parent c1
))
301 (let ((e (make-element "test")))
303 (assert-equal e
(parent c1
))
304 (assert-equal c1
(nth-child 0 e
))
306 (assert-equal 0 (child-count e
)))
309 (deftest comment.document
310 (let ((c1 (make-comment "data"))
311 (root (make-element "root")))
312 (assert-equal nil
(document c1
))
313 (append-child root c1
)
314 (assert-equal nil
(document c1
))
315 (let ((document (make-document root
)))
316 (assert-equal document
(document c1
)))
319 (deftest comment.funny-characters-allowed
320 (assert-equal (serialize-to-string (make-comment "<test>&&greater;"))
321 "<!--<test>&&greater;-->")
324 (define-condition-test comment.only-char-allowed
325 (make-comment (format nil
" ~C " (code-char 1)))
328 (deftest comment.print-object
329 (let ((n (make-comment "heyho")))
330 (assert-node= n
(read-from-string (write-to-string n
)))
334 ;;;; PROCESSING-INSTRUCTION
336 (deftest pi.constructor
.1
337 (let ((p-i (make-processing-instruction "abc" "def")))
338 (assert-equal (target p-i
) "abc")
339 (assert-equal (data p-i
) "def")
342 (deftest pi.constructor
.2
343 (data (make-processing-instruction "abc" ""))
346 (deftest pi.constructor
.3
347 (data (make-processing-instruction "abc" nil
))
350 (deftest pi.constructor
.4
351 (target (make-processing-instruction "abc123" nil
))
354 (deftest pi.constructor.illegal
356 (expect-condition (make-processing-instruction "test:test" "test")
358 (expect-condition (make-processing-instruction "" "test")
360 (expect-condition (make-processing-instruction nil
"test")
362 (expect-condition (make-processing-instruction "12345" "test")
366 (deftest pi.serialize
367 (serialize-to-string (make-processing-instruction "abc" "def"))
370 (deftest pi.serialize
.2
371 (serialize-to-string (make-processing-instruction "abc" ""))
374 (deftest pi.serialize
.3
376 (make-processing-instruction "target" "<test>&&greater;"))
377 "<?target <test>&&greater;?>")
380 (let* ((c1 (make-processing-instruction "target" "data"))
382 (assert (not (eq c1 c2
)))
383 (assert-equal (data c1
) (data c2
))
384 (assert-equal (target c1
) (target c2
))
385 (assert-equal nil
(parent c2
))
386 (assert-equal (type-of c2
) 'processing-instruction
)
390 (let* ((p-i (make-processing-instruction "target" "data")))
391 (expect-condition (setf (data p-i
) "?>") stp-error
)
392 (expect-condition (setf (data p-i
) "uhesta ?>") stp-error
)
393 (expect-condition (setf (data p-i
) "uhesta ?> hst") stp-error
)
394 (setf (data p-i
) nil
)
395 (assert-equal (data p-i
) "")
396 (dolist (str '("<html></html>"
400 "salkdhsalkjhdkjsadhkj sadhsajkdh"
404 (setf (data p-i
) str
)
405 (assert-equal (data p-i
) str
))
409 (let* ((p-i (make-processing-instruction "target" "data")))
410 (expect-condition (setf (data p-i
) (string (code-char 0))) stp-error
)
411 (assert-equal (data p-i
) "data")
414 ;;; zzz testCorrectSurrogates
415 ;;; zzz testSurrogates
417 (deftest pi.leaf-node
418 (let ((c1 (make-processing-instruction "target" "data")))
419 (assert-equal 0 (child-count c1
))
420 (expect-condition (nth-child 0 c1
) error
)
421 (assert-equal nil
(parent c1
))
422 (let ((e (make-element "test")))
424 (assert-equal e
(parent c1
))
425 (assert-equal c1
(nth-child 0 e
))
427 (assert-equal 0 (child-count e
)))
430 ;;; zzz das pruefen wir nicht
431 ;; (define-condition-test pi.cr
432 ;; (make-processing-instruction "target" (format nil "foo ~C bar" (code-char 13)))
436 (dolist (str (list " initial spaces"
437 (format nil
"~Cinitial tab" (code-char 9))
438 (format nil
"~Cinitial newline" (code-char 10))
439 (format nil
"~Cinitial cr" (code-char 13)))
441 (expect-condition (make-processing-instruction "target" str
) stp-error
)))
443 (deftest pi.invalid.xml
444 (dolist (str (list "xml" "XML" "Xml")
446 (expect-condition (make-processing-instruction str
"data") stp-error
)))
448 (deftest pi.invalid.colon
449 (dolist (str (list "pre:target" "pre:" ":target")
451 (expect-condition (make-processing-instruction str
"data") stp-error
)))
453 (deftest pi.string-value
454 (let ((n (make-processing-instruction "target" "data")))
458 (deftest pi.print-object
459 (let ((n (make-processing-instruction "target" "data")))
460 (assert-node= n
(read-from-string (write-to-string n
)))
466 (defparameter +name
+ "Ottokar")
467 (defparameter +sysid
+ "http://www.w3.org/TR/some.dtd")
468 (defparameter +pubid
+ "-//Me//some public ID")
470 (deftest doctype.constructor
.1
471 (let ((doctype (make-document-type +name
+ +sysid
+ +pubid
+)))
472 (assert-equal (root-element-name doctype
) +name
+)
473 (assert-equal (system-id doctype
) +sysid
+)
474 (assert-equal (public-id doctype
) +pubid
+)
477 (deftest doctype.constructor
.2
478 (let ((doctype (make-document-type +name
+ +sysid
+)))
479 (assert-equal (root-element-name doctype
) +name
+)
480 (assert-equal (system-id doctype
) +sysid
+)
481 (assert-equal (public-id doctype
) nil
)
484 (deftest doctype.constructor
.3
485 (let ((doctype (make-document-type +name
+)))
486 (assert-equal (root-element-name doctype
) +name
+)
487 (assert-equal (system-id doctype
) nil
)
488 (assert-equal (public-id doctype
) nil
)
491 (deftest doctype.constructor
.3a
492 (let ((doctype (make-document-type "try:name")))
493 (assert-equal (root-element-name doctype
) "try:name")
494 (assert-equal (system-id doctype
) nil
)
495 (assert-equal (public-id doctype
) nil
)
498 (define-condition-test doctype.constructor
.4
499 (make-document-type "try name")
502 (define-condition-test doctype.constructor
.5
503 (make-document-type nil
)
506 (define-condition-test doctype.constructor
.6
507 (make-document-type "")
510 (define-condition-test doctype.constructor
.7
511 (make-document-type ":try")
514 (deftest doctype.constructor
.8
515 (let* ((root (make-element "root"))
516 (document (make-document root
))
517 (new-root (make-element "new-root")))
518 (assert-equal root
(document-element document
))
519 (assert-equal 1 (child-count document
))
521 (setf (document-element document
) new-root
)
522 (assert-equal new-root
(document-element document
))
523 (assert-equal 1 (child-count document
))
525 (append-child document
(make-comment "test"))
526 (assert-equal 2 (child-count document
))
528 (prepend-child document
(make-comment "prolog comment"))
529 (assert-equal 3 (child-count document
))
530 (check-type (nth-child 0 document
) comment
)
531 (check-type (nth-child 1 document
) element
)
532 (check-type (nth-child 2 document
) comment
)
534 (insert-child document
(make-processing-instruction "t" "d") 1)
535 (check-type (nth-child 0 document
) comment
)
536 (check-type (nth-child 1 document
) processing-instruction
)
537 (check-type (nth-child 2 document
) element
)
538 (check-type (nth-child 3 document
) comment
)
540 (insert-child document
(make-processing-instruction "epilog" "d") 3)
541 (check-type (nth-child 0 document
) comment
)
542 (check-type (nth-child 1 document
) processing-instruction
)
543 (check-type (nth-child 2 document
) element
)
544 (check-type (nth-child 3 document
) processing-instruction
)
545 (check-type (nth-child 4 document
) comment
)
547 (expect-condition (make-document nil
) type-error
)
549 (deftest doctype.serialize
.1
550 (let ((name "Ottokar")
551 (sysid "http://www.w3.org/TR/some.dtd")
552 (pubid "-//Me//some public ID"))
553 (assert-equal (serialize-to-string (make-document-type name sysid pubid
))
554 (format nil
"<!DOCTYPE ~A PUBLIC \"~A\" \"~A\">~%"
556 (assert-equal (serialize-to-string (make-document-type name sysid
))
557 (format nil
"<!DOCTYPE ~A SYSTEM \"~A\">~%" name sysid
))
558 (assert-equal (serialize-to-string (make-document-type name
))
559 (format nil
"<!DOCTYPE ~A>~%" name
))
562 (deftest doctype.serialize
.2
563 (let* ((str "<?xml version=\"1.0\" encoding=\"UTF-8\"?>
565 <!ELEMENT test #PCDATA>
568 (d (cxml:parse str
(make-builder) :validate t
)))
569 (assert-equal (serialize-to-string d
) str
)
572 (deftest doctype.serialize
.3
573 (let* ((subset " <!--comment-->
574 <!ELEMENT test #PCDATA>
579 "<?xml version=\"1.0\" encoding=\"UTF-8\"?>
584 (test (make-element "test"))
585 (d (make-document test
))
586 (doctype (make-document-type "test")))
587 (prepend-child d doctype
)
588 (setf (internal-subset doctype
) subset
)
589 (assert-equal (serialize-to-string d
) expected
)
592 (deftest doctype.setf
593 (let ((doctype (make-document-type "root")))
594 (setf (root-element-name doctype
) "newval")
595 (assert-equal (root-element-name doctype
) "newval")
596 (setf (root-element-name doctype
) "new:val")
597 (assert-equal (root-element-name doctype
) "new:val")
598 (expect-condition (setf (root-element-name doctype
) ":newval")
600 (expect-condition (setf (root-element-name doctype
) "new val")
604 (deftest doctype.setf.internal-subset
.1
605 (let ((doctype (make-document-type "root")))
606 (setf (internal-subset doctype
) "")
607 (assert-equal (internal-subset doctype
) "")
610 (deftest doctype.setf.internal-subset
.2
611 (let ((doctype (make-document-type "root")))
612 (setf (internal-subset doctype
) nil
)
613 (assert-equal (internal-subset doctype
) "")
616 (deftest doctype.setf.internal-subset
.3
617 (let ((doctype (make-document-type "root")))
618 (setf (internal-subset doctype
) #1="<!ELEMENT test (PCDATA)>")
619 (internal-subset doctype
))
622 ;;; FIXME: sollen wir das nun pruefen oder nicht?
623 ;; (deftest doctype.setf.internal-subset.4
624 ;; (let ((doctype (make-document-type "root")))
625 ;; (setf (internal-subset doctype)
626 ;; #1="<!ENTITY % test SYSTEM 'http://www.example.com/notexists.dtd'>
628 ;; (internal-subset doctype))
631 (define-condition-test doctype.setf.internal-subset
.5
632 (let ((doctype (make-document-type "root")))
633 (setf (internal-subset doctype
) "<!ELEMENT test (PCDATA>"))
636 (deftest doctype.leaf-node
637 (list-children (make-document-type "root"))
640 (deftest doctype.pubid
641 (labels ((legal (pubid)
645 (integer (string (code-char pubid
)))
646 (character (string pubid
)))))
648 (public-id (make-document-type
650 "http://www.w3.org/TR/some.dtd"
654 (expect-condition (legal pubid
) stp-error pubid
)))
655 (loop for i from
0 to
9 do
(illegal i
))
658 (loop for i from
14 below
32 do
(illegal i
))
659 (loop for i from
126 below
1000 do
(illegal i
))
660 (map nil
#'illegal
"<>`^&\"[]{}|\\~")
661 (map nil
#'legal
"-'()+,./:=?;!*#@$_%")
662 (loop for i from
(char-code #\a) to
(char-code #\z
) do
(legal i
))
663 (loop for i from
(char-code #\A
) to
(char-code #\Z
) do
(legal i
))
664 (loop for i from
(char-code #\
0) to
(char-code #\
9) do
(legal i
))
667 (progn ;sehe ich nicht ein
671 (illegal (format nil
"foo~Cbar" (code-char 10)))
672 (illegal (format nil
"foo~Cbar" (code-char 13)))))
675 (deftest doctype.sysid
676 (labels ((legal (sysid)
680 (integer (string (code-char sysid
)))
681 (character (string sysid
)))))
683 (system-id (make-document-type
688 (expect-condition (legal sysid
) stp-error sysid
)))
689 (legal "http://www.example.com/test$red/limit,data.xml")
690 (legal "smb://domain;user:pass@server/share/path/to/file")
691 (illegal "http://www.example.com/index.html#test")
692 (illegal "http://www.example.com/index.html#")
695 (illegal "both \" and '"))
698 (deftest doctype.copy
699 (let* ((name "Ottokar")
700 (sysid "http://www.w3.org/TR/some.dtd")
701 (pubid "-//Me//some public ID")
702 (c1 (make-document-type name sysid pubid
))
704 (assert-equal (root-element-name c1
) (root-element-name c2
))
705 (assert-equal (public-id c1
) (public-id c2
))
706 (assert-equal (system-id c1
) (system-id c2
))
707 (assert-equal (internal-subset c1
) (internal-subset c2
))
708 (assert (not (eq c1 c2
)))
711 (define-condition-test doctype.pubid-needs-sysid
712 (setf (public-id (make-document-type "Ottokar")) "-//Me//some public ID")
715 (deftest doctype.remove
716 (let* ((name "Ottokar")
717 (sysid "http://www.w3.org/TR/some.dtd")
718 (pubid "-//Me//some public ID")
719 (doctype (make-document-type name sysid pubid
)))
720 (setf (public-id doctype
) nil
)
721 (assert-equal nil
(public-id doctype
))
722 (setf (public-id doctype
) pubid
)
723 (assert-equal pubid
(public-id doctype
))
724 (expect-condition (setf (system-id doctype
) nil
) stp-error
)
725 (setf (public-id doctype
) nil
)
726 (assert-equal nil
(public-id doctype
))
727 (setf (system-id doctype
) nil
)
728 (assert-equal nil
(system-id doctype
))
731 (deftest doctype.print-object
732 (let* ((name "Ottokar")
733 (sysid "http://www.w3.org/TR/some.dtd")
734 (pubid "-//Me//some public ID")
735 (n (make-document-type name sysid pubid
)))
736 (assert-node= n
(read-from-string (write-to-string n
)))
739 (deftest doctype.string-value
740 (let* ((name "Ottokar")
741 (sysid "http://www.w3.org/TR/some.dtd")
742 (pubid "-//Me//some public ID")
744 (string-value (make-document-type name sysid pubid
)))
747 (deftest doctype.setf.public-id.nil
748 (let* ((name "Ottokar")
749 (sysid "http://www.w3.org/TR/some.dtd")
750 (pubid "-//Me//some public ID")
751 (n (make-document-type name sysid pubid
)))
752 (setf (public-id n
) "")
753 (assert-equal sysid
(system-id n
))
754 (assert-equal nil
(public-id n
))
757 (deftest doctype.setf.system-id.nil
758 (let* ((name "Ottokar")
759 (sysid "http://www.w3.org/TR/some.dtd")
760 (pubid "-//Me//some public ID")
761 (n (make-document-type name sysid pubid
)))
762 (setf (public-id n
) nil
)
763 (assert-equal sysid
(system-id n
))
764 (setf (system-id n
) "")
765 (assert-equal nil
(system-id n
))
771 (deftest document.insertion
772 (let* ((root (make-element "root"))
773 (document (make-document root
))
774 (doctype (make-document-type "root")))
775 (expect-condition (insert-child document doctype
1) stp-error
)
776 (insert-child document doctype
0)
777 (assert-equal (document-type document
) doctype
)
778 (let ((doctype2 (make-document-type "test")))
779 (expect-condition (insert-child document doctype2
1) stp-error
)
780 (assert-equal (document-type document
) doctype
)
781 (assert-equal (first-child document
) doctype
)
782 (assert-equal nil
(parent doctype2
))
784 (setf (document-type document
) doctype2
)
785 (assert-equal (document-type document
) doctype2
)
786 (assert-equal (first-child document
) doctype2
)
787 (assert-equal nil
(parent doctype
))
789 (setf (document-type document
) doctype2
)
790 (assert-equal (document-type document
) doctype2
)
791 (assert-equal (first-child document
) doctype2
)
792 (assert-equal nil
(parent doctype
))
794 (expect-condition (setf (document-type document
) nil
) type-error
)
795 (assert-equal (document-type document
) doctype2
)
796 ;; two parents not allowed
797 (let ((document2 (make-document (make-element "root"))))
798 (expect-condition (setf (document-type document2
) doctype2
)
800 (assert-equal (parent doctype2
) document
)))
803 (deftest document.base-uri
804 (let* ((root (make-element "root"))
805 (document (make-document root
)))
806 (assert-equal (base-uri document
) "")
807 (dolist (url '("http://www.example.com/index.xml"
808 "http://www.example.com/index.xml"
809 "file:///home/elharo/XO%4D/data/test.xml"))
810 (setf (base-uri document
) url
)
811 (assert-equal (base-uri document
) url
))
814 (define-condition-test document.second-root
815 (let* ((root (make-element "root"))
816 (document (make-document root
)))
817 (insert-child document
(make-element "root2") 0))
820 (deftest document.setf.document-element
821 (let* ((root (make-element "root"))
822 (document (make-document root
))
823 (new-root (make-element "new-root")))
825 (setf (document-element document
) new-root
)
826 (assert-equal (document-element document
) new-root
)
827 (assert-equal nil
(parent root
))
828 (expect-condition (setf (document-element document
) nil
) type-error
)
829 ;; no multiple parents
830 (let ((top (make-element "top"))
831 (child (make-element "child")))
832 (append-child top child
)
833 (expect-condition (setf (document-element document
) child
) stp-error
))
835 (setf (document-element document
) new-root
)
836 (assert-equal (document-element document
) new-root
)
837 (assert-equal nil
(parent root
))
840 ;; like document.setf.document-element, but using replace-child instead
841 (deftest document.setf.replace-child
842 (let* ((root (make-element "root"))
843 (document (make-document root
))
844 (new-root (make-element "new-root")))
846 (replace-child document root new-root
)
847 (assert-equal (document-element document
) new-root
)
848 (assert-equal nil
(parent root
))
849 (expect-condition (setf (document-element document
) nil
) type-error
)
850 ;; no multiple parents
851 (let ((top (make-element "top"))
852 (child (make-element "child")))
853 (append-child top child
)
854 (expect-condition (replace-child document child new-root
) stp-error
))
856 (replace-child document new-root new-root
)
857 (assert-equal (document-element document
) new-root
)
858 (assert-equal nil
(parent root
))
861 (deftest document.insertion-allowed
862 (let* ((root (make-element "root"))
863 (document (make-document root
))
864 (original (make-comment "original"))
865 (c2 (make-comment "new comment"))
866 (temp (make-element "temp")))
867 (prepend-child document original
)
868 (append-child temp c2
)
869 (expect-condition (replace-child document original c2
) stp-error
)
870 (assert-equal (list-children document
) (list original root
))
873 (deftest document.replace-doctype
.1
874 (let* ((root (make-element "root"))
875 (document (make-document root
))
876 (new (make-document-type "new"))
877 (old (make-document-type "old")))
878 (setf (document-type document
) old
)
879 (replace-child document old new
)
880 (assert-equal new
(document-type document
))
881 (assert-equal nil
(parent old
))
882 (assert-equal document
(parent new
))
885 (deftest document.replace-doctype
.2
886 (let* ((root (make-element "root"))
887 (document (make-document root
))
888 (new (make-document-type "new"))
889 (old (make-document-type "old"))
890 (temp (make-document (make-element "root"))))
891 (setf (document-type temp
) new
)
892 (setf (document-type document
) old
)
893 (expect-condition (setf (document-type document
) new
) stp-error
)
894 (assert-equal old
(document-type document
))
895 (assert-equal document
(parent old
))
896 (assert-equal new
(document-type temp
))
897 (assert-equal temp
(parent new
))
900 (deftest document.replacement-allowed
.1
901 (let* ((root (make-element "root"))
902 (document (make-document root
))
903 (comment (make-comment "c")))
904 (expect-condition (replace-child document root comment
) stp-error
)
905 (assert-equal root
(document-element document
))
906 (assert-equal document
(parent root
))
907 (assert-equal nil
(parent comment
))
910 (deftest document.replacement-allowed
.2
911 (let* ((document (make-document (make-element "root")))
912 (comment (make-comment "not a doctype"))
913 (doctype (make-document-type "new")))
914 (prepend-child document comment
)
915 (replace-child document comment doctype
)
916 (assert-equal doctype
(document-type document
))
917 (assert-equal document
(parent doctype
))
918 (assert-equal nil
(parent comment
))
921 (deftest document.detach
922 (let* ((document (make-document (make-element "root")))
923 (comment (make-comment "c")))
924 (append-child document comment
)
925 (assert-equal document
(parent comment
))
927 (assert-equal nil
(parent comment
))
930 (deftest document.document
931 (let ((document (make-document (make-element "root"))))
932 (assert-equal document
(document document
))
935 (deftest document.root
936 (let ((document (make-document (make-element "root"))))
937 (assert-equal document
(root document
))
940 (deftest document.copy
941 (let* ((root (make-element "root"))
942 (document (make-document root
)))
943 (prepend-child document
(make-comment "text"))
944 (insert-child document
(make-processing-instruction "text" "data") 1)
945 (insert-child document
(make-document-type "text") 2)
946 (append-child root
(make-comment "after"))
947 (append-child document
(make-processing-instruction "text" "after"))
948 (assert-node= document
(copy document
))
951 (deftest document.append-child
952 (let* ((root (make-element "root"))
953 (document (make-document root
)))
954 (expect-condition (append-child document
(make-text "test")) stp-error
)
955 (expect-condition (append-child document
(make-text " ")) stp-error
)
956 (append-child document
(make-comment "foo"))
957 (expect-condition (append-child document
(make-element "test"))
959 (expect-condition (insert-child document
(make-element "foo") 0)
963 (deftest document.delete-child
964 (let* ((root (make-element "root"))
965 (document (make-document root
)))
966 (expect-condition (detach root
) stp-error
)
967 (expect-condition (delete-child root document
) stp-error
)
968 (expect-condition (delete-child-if #'identity document
:start
0 :count
1)
970 (append-child document
(make-comment "test"))
971 (delete-child-if #'identity document
:start
1 :count
1)
972 (assert-equal 1 (child-count document
))
973 (let ((test (make-comment "test")))
974 (append-child document test
)
975 (delete-child test document
)
976 (assert-equal 1 (child-count document
)))
977 (delete-child (make-comment "sd") document
)
979 (delete-child-if #'identity document
:start
20 :count
1)
983 (deftest document.delete-child
.2
984 (let* ((root (make-element "root"))
985 (document (make-document root
))
986 (a (make-element "a"))
987 (b (make-element "b"))
988 (c (make-element "c"))
989 (d (make-element "d")))
990 (append-child root a
)
991 (append-child root b
)
992 (append-child root c
)
993 (append-child root d
)
994 (delete-child-if #'identity root
:count
1 :start
1 :end
3)
995 (assert-equal (list a c d
) (list-children root
))
998 (deftest document.delete-child
.3
999 (let* ((root (make-element "root"))
1000 (document (make-document root
))
1001 (a (make-element "a"))
1002 (b (make-element "b"))
1003 (c (make-element "c"))
1004 (d (make-element "d")))
1005 (append-child root a
)
1006 (append-child root b
)
1007 (append-child root c
)
1008 (append-child root d
)
1009 (delete-child-if #'identity root
:count
1 :start
1 :end
3 :from-end t
)
1010 (assert-equal (list a b d
) (list-children root
))
1013 (deftest document.serialize
1014 (let* ((root (make-element "root"))
1015 (document (make-document root
)))
1016 (serialize-to-string document
))
1017 "<?xml version=\"1.0\" encoding=\"UTF-8\"?>
1020 (deftest document.string-value
1021 (let* ((root (make-element "root"))
1022 (document (make-document root
)))
1023 (append-child root
(make-text "frob"))
1024 (string-value document
))
1027 (deftest document.print-object
1028 (let ((n (make-document (make-element "root"))))
1029 (assert-node= n
(read-from-string (write-to-string n
)))
1035 (defmacro with-element-test
((&optional
) &body body
)
1036 `(let* ((child1 (make-element "test"))
1037 (child2 (make-text "test2"))
1038 (child3 (make-comment "test3"))
1039 (child4 (make-element "pre:test" "http://www.example.com"))
1040 (child5 (make-element "test" "http://www.example.com"))
1041 (element (make-element "name")))
1042 (append-child element child1
)
1043 (append-child element child2
)
1044 (append-child element child3
)
1045 (append-child element child4
)
1046 (append-child element child5
)
1047 (let ((str (format nil
" ~C~C" (code-char 13) (code-char 10))))
1048 (append-child element
(make-text str
)))
1051 (deftest element.of-name
.1
1052 (with-element-test ()
1053 (length (filter-children (of-name nil
"http://www.example.com") element
)))
1056 (deftest element.of-name
.2
1057 (with-element-test ()
1058 (length (filter-children (of-name nil
) element
)))
1061 (deftest element.find-if
1062 (with-element-test ()
1063 (assert-equal child1
(find-child-if (of-name "test") element
))
1064 (assert-equal child4
1065 (find-child-if (of-name "test" "http://www.example.com")
1067 (assert-equal nil
(find-child-if (of-name "none") element
))
1068 (expect-condition (of-name "pre:test") stp-error
)
1070 (find-child-if (of-name "none" "http://www.example.com")
1074 (deftest element.xmlns-name
1075 (let* ((name "xmlns")
1076 (e (make-element name
)))
1077 (assert-equal name
(local-name e
))
1078 (assert-equal name
(qualified-name e
))
1079 (assert-equal "" (namespace-prefix e
))
1080 (assert-equal "" (namespace-uri e
))
1083 (define-condition-test element.xmlns-prefix
1084 (make-element "xmlns:foo" "http://www.example.org/")
1087 (deftest element.constructor
.1
1088 (let* ((name "Jethro")
1089 (e (make-element name
)))
1090 (assert-equal name
(local-name e
))
1091 (assert-equal name
(qualified-name e
))
1092 (assert-equal "" (namespace-prefix e
))
1093 (assert-equal "" (namespace-uri e
))
1096 (deftest element.constructor
.2
1097 (let* ((name "sakjdhjhd")
1098 (uri "http://www.something.com/")
1099 (e (make-element name uri
)))
1100 (assert-equal name
(local-name e
))
1101 (assert-equal name
(qualified-name e
))
1102 (assert-equal "" (namespace-prefix e
))
1103 (assert-equal uri
(namespace-uri e
))
1106 (deftest element.constructor
.3
1107 (let* ((name "red:sakjdhjhd")
1108 (uri "http://www.something.com/")
1109 (e (make-element name uri
)))
1110 (assert-equal "sakjdhjhd" (local-name e
))
1111 (assert-equal name
(qualified-name e
))
1112 (assert-equal "red" (namespace-prefix e
))
1113 (assert-equal uri
(namespace-uri e
))
1116 (deftest element.emptyns
.1
1117 (let* ((name "sakjdhjhd")
1118 (uri "http://www.something.com/")
1119 (e (make-element name uri
)))
1120 (setf (namespace-uri e
) "")
1121 (assert-equal "" (namespace-uri e
))
1124 (deftest element.emptyns
.2
1125 (let* ((name "sakjdhjhd")
1126 (uri "http://www.something.com/")
1127 (e (make-element name uri
)))
1128 (serialize-to-string e
))
1129 "<sakjdhjhd xmlns=\"http://www.something.com/\"/>")
1131 (deftest element.emptyns
.3
1132 (let ((e (make-element "e")))
1133 (add-attribute e
(make-attribute "en"
1135 "http://www.w3.org/XML/1998/namespace"))
1136 (serialize-to-string e
))
1137 "<e xml:lang=\"en\"/>")
1139 (deftest element.doctype
1140 (let* ((name "sakjdhjhd")
1141 (uri "http://www.something.com/")
1142 (e (make-element name uri
)))
1143 (expect-condition (append-child e
(make-document-type name
)) stp-error
)
1146 (deftest element.xml-namespace
1147 (let* ((name "sakjdhjhd")
1148 (uri "http://www.something.com/")
1149 (e (make-element name uri
))
1150 (xml "http://www.w3.org/XML/1998/namespace"))
1151 (assert-equal xml
(find-namespace "xml" e
))
1152 (expect-condition (add-extra-namespace e
"xml" "http://www.yahoo.com/")
1154 (assert-equal xml
(find-namespace "xml" e
))
1155 (add-extra-namespace e
"xml" xml
)
1156 (assert-equal xml
(find-namespace "xml" e
))
1159 (deftest element.undeclare-default
1160 (let* ((name "red:sakjdhjhd")
1161 (uri "http://www.red.com/")
1162 (child (make-element name uri
))
1163 (parent (make-element "parent" "http://www.example.com/")))
1164 (assert-equal "http://www.example.com/" (find-namespace "" parent
))
1165 (append-child parent child
)
1166 (add-extra-namespace child
"" "")
1167 (assert-equal "" (find-namespace "" child
))
1168 (assert-equal "http://www.example.com/" (find-namespace "" parent
))
1169 (let ((child2 (make-element "name" "http://www.default.com")))
1170 (append-child parent child2
)
1171 (expect-condition (add-extra-namespace child2
"" "") stp-error
))
1174 (deftest element.setf-namespace-uri
.1
1175 (let* ((name "sakjdhjhd")
1176 (uri "http://www.red.com/")
1177 (element (make-element name uri
)))
1178 (add-attribute element
(make-attribute "test" "attribute"))
1179 (setf (namespace-uri element
) "")
1180 (assert-equal "" (find-namespace "" element
))
1183 (deftest element.setf-namespace-uri
.2
1184 (let* ((name "sakjdhjhd")
1185 (uri "http://www.red.com/")
1186 (element (make-element name uri
)))
1187 (add-attribute element
(make-attribute "test" "red:attribute" uri
))
1188 (setf (namespace-uri element
) uri
)
1189 (assert-equal uri
(namespace-uri element
))
1190 (assert-equal uri
(find-namespace "red" element
))
1193 (deftest element.setf-namespace-uri
.3
1195 (uri "http://www.w3.org/1999/xhtml")
1196 (element (make-element name
)))
1197 (add-attribute element
(make-attribute "http://www.elharo.com" "href"))
1198 (setf (namespace-uri element
) uri
)
1199 (assert-equal uri
(namespace-uri element
))
1202 (deftest element.setf-namespace-uri
.4
1204 (uri "http://www.w3.org/1999/xhtml")
1205 (element (make-element name
)))
1206 (add-attribute element
(make-attribute "http://www.elharo.com"
1209 (setf (namespace-uri element
) "http://www.example.com")
1210 (setf (namespace-prefix element
) "pre")
1211 (setf (namespace-uri element
) uri
)
1212 (setf (namespace-prefix element
) "html")
1213 (assert-equal uri
(namespace-uri element
))
1214 (assert-equal "html" (namespace-prefix element
))
1217 (deftest element.serialize
.1
1218 (let ((element (make-element "test")))
1219 (add-attribute element
1220 (make-attribute "preserve"
1222 "http://www.w3.org/XML/1998/namespace"))
1223 (add-attribute element
1224 (make-attribute "preserve"
1226 "http://www.example.org"))
1227 (serialize-to-string element
))
1228 "<test xmlns:zzz=\"http://www.example.org\" zzz:zzz=\"preserve\" xml:space=\"preserve\"/>")
1230 (deftest element.xml-prefix
1231 (let ((element (make-element "xml:test"
1232 "http://www.w3.org/XML/1998/namespace")))
1233 (map-extra-namespaces (lambda (k v
) (error "bogus extra namespace"))
1235 (assert-equal "<xml:test/>" (serialize-to-string element
))
1238 (deftest element.namespaces-mappings
1239 (let* ((name "red:sakjdhjhd")
1240 (uri "http://www.red.com/")
1241 (e (make-element name uri
)))
1242 (add-extra-namespace e
"blue" "http://www.blue.com/")
1243 (add-extra-namespace e
"green" "http://www.green.com/")
1244 (let ((a1 (make-attribute "test" "test"))
1245 (a2 (make-attribute "data" "pre1:green" "http://www.green.com/"))
1246 (a3 (make-attribute "data" "yellow:sfs" "http://www.yellow.com/")))
1247 (add-attribute e a1
)
1248 (add-attribute e a2
)
1249 (add-attribute e a3
))
1250 (assert-equal "http://www.red.com/" (find-namespace "red" e
))
1251 (assert-equal "http://www.green.com/" (find-namespace "green" e
))
1252 (assert-equal "http://www.blue.com/" (find-namespace "blue" e
))
1253 (assert-equal "http://www.green.com/" (find-namespace "pre1" e
))
1254 (assert-equal "http://www.yellow.com/" (find-namespace "yellow" e
))
1255 (let ((e2 (make-element "mauve:child" "http://www.mauve.com/")))
1257 (assert-equal "http://www.red.com/" (find-namespace "red" e2
))
1258 (assert-equal "http://www.green.com/" (find-namespace "green" e2
))
1259 (assert-equal "http://www.blue.com/" (find-namespace "blue" e2
))
1260 (assert-equal "http://www.green.com/" (find-namespace "pre1" e2
))
1261 (assert-equal "http://www.yellow.com/" (find-namespace "yellow" e2
))
1262 (assert-equal nil
(find-namespace "head" e2
)))
1263 (expect-condition (add-extra-namespace e
"pre1" "http://www.blue2.com")
1265 (let ((a (make-attribute "data" "pre1:mauve" "http://www.sadas.com/")))
1266 (expect-condition (add-attribute e a
) stp-error
))
1267 (let ((a (make-attribute "data" "pre1:green" "http://www.example.com/")))
1268 (expect-condition (add-attribute e a
) stp-error
))
1269 (remove-extra-namespace e
"green")
1270 (assert-equal nil
(find-namespace "green" e
))
1271 (add-extra-namespace e
"green" "http://www.green2.com/")
1272 (assert-equal "http://www.green2.com/" (find-namespace "green" e
))
1275 (deftest element.attributes
1276 (let* ((name "red:sakjdhjhd")
1277 (uri "http://www.red.com/")
1278 (e (make-element name uri
))
1279 (a1 (make-attribute "simple" "name"))
1280 (a2 (make-attribute "data" "pre1:green" "http://www.green.com/")))
1281 (add-attribute e a1
)
1282 (add-attribute e a2
)
1283 (assert-equal a2
(find-attribute-named e
"green" "http://www.green.com/"))
1284 (assert-equal a1
(find-attribute-named e
"name"))
1285 (assert-equal a1
(find-attribute-named e
"name" ""))
1286 (assert-equal e
(parent a1
))
1287 (assert-equal "simple" (value (find-attribute-named e
"name")))
1289 (assert-equal nil
(parent a1
))
1290 (assert-equal nil
(find-attribute-named e
"name"))
1291 (assert-equal a2
(remove-attribute e a2
))
1292 (assert-equal nil
(parent a2
))
1293 (assert-equal nil
(find-attribute-named e
"green" "http://www.green.com/"))
1296 (deftest element.remove-attribute
.1
1297 (let* ((name "red:sakjdhjhd")
1298 (uri "http://www.red.com/")
1299 (e (make-element name uri
))
1300 (a1 (make-attribute "simple" "name"))
1301 (a2 (make-attribute "data" "pre1:green" "http://www.green.com/")))
1302 (add-attribute e a1
)
1303 (add-attribute e a2
)
1304 (expect-condition (remove-attribute e nil
) type-error
)
1307 (deftest element.remove-attribute
.2
1308 (let* ((name "red:sakjdhjhd")
1309 (uri "http://www.red.com/")
1310 (e (make-element name uri
))
1311 (a (make-attribute "simple" "name")))
1312 (add-attribute e
(make-attribute "value" "name"))
1313 (expect-condition (remove-attribute e a
) stp-error
)
1316 (deftest element.string-value
1317 (let* ((name "red:sakjdhjhd")
1318 (uri "http://www.red.com/")
1319 (e (make-element name uri
)))
1320 (assert-equal (string-value e
) "")
1321 (append-child e
(make-text "data"))
1322 (assert-equal (string-value e
) "data")
1323 (append-child e
(make-text " moredata"))
1324 (assert-equal (string-value e
) "data moredata")
1325 (append-child e
(make-comment " more data"))
1326 (assert-equal (string-value e
) "data moredata")
1327 (append-child e
(make-processing-instruction "target" "more data"))
1328 (assert-equal (string-value e
) "data moredata")
1329 (let ((e2 (make-element "child")))
1331 (assert-equal (string-value e
) "data moredata")
1332 (append-child e2
(make-text "something"))
1333 (assert-equal (string-value e
) "data moredatasomething"))
1336 (deftest element.setf-local-name
1337 (let* ((name "red:sakjdhjhd")
1338 (uri "http://www.red.com/")
1339 (e (make-element name uri
)))
1340 (assert-equal (local-name e
) "sakjdhjhd")
1341 (dolist (x '("dude" "digits__" "digits1234" "digits-z"))
1342 (assert-equal x
(setf (local-name e
) x
))
1343 (assert-equal (local-name e
) x
))
1344 (expect-condition (setf (local-name e
) "spaces ") stp-error
)
1345 (expect-condition (setf (local-name e
) "digits:test") stp-error
)
1346 (expect-condition (setf (local-name e
) "digits!test") stp-error
)
1348 (setf (local-name e
) (format nil
"digits~Ctest" (code-char 0)))
1352 (deftest element.setf-namespace-prefix
1353 (let* ((name "red:sakjdhjhd")
1354 (uri "http://www.red.com/")
1355 (e (make-element name uri
)))
1356 (assert-equal (namespace-prefix e
) "red")
1357 (dolist (x '("dude" "digits__" "digits1234" "digits-z" ""))
1358 (assert-equal x
(setf (namespace-prefix e
) x
))
1359 (assert-equal (namespace-prefix e
) x
))
1360 (dolist (y '("spaces "
1363 #.
(format nil
"digits~Ctest" (code-char 0))))
1364 (expect-condition (setf (namespace-prefix e
) y
) stp-error
))
1367 (defparameter *legal-uris
*
1368 '("http://www.is.edu/sakdsk#sjadh"
1369 "http://www.is.edu/sakdsk?name=value&name=head"
1370 "uri:isbn:0832473864"
1371 "http://www.examples.com:80"
1372 "http://www.examples.com:80/"
1373 "http://www.is.edu/%20sakdsk#sjadh"))
1375 ;;; we don't actually check URI syntax, but we still have to prevent
1376 ;;; URIs from slipping in that aren't even make up of XML characters
1377 (defparameter *very-illegal-uris
*
1378 (list (string (code-char 0))
1379 (string (code-char 128))))
1381 (deftest element.setf-namespace-uri
.5
1383 (uri "http://www.w3.org/1999/xhtml")
1384 (element (make-element name uri
)))
1385 (assert-equal (namespace-uri element
) uri
)
1386 (dolist (legal *legal-uris
*)
1387 (setf (namespace-uri element
) legal
)
1388 (assert-equal (namespace-uri element
) legal
))
1389 (let ((prev (namespace-uri element
)))
1390 (dolist (illegal *very-illegal-uris
*)
1391 (expect-condition (setf (namespace-uri element
) illegal
) stp-error
))
1392 (assert-equal (namespace-uri element
) prev
))
1395 (deftest element.setf-namespace-uri
.6
1396 (let* ((name "red:sakjdhjhd")
1397 (uri "http://www.red.com/")
1398 (element (make-element name uri
)))
1399 (add-extra-namespace element
"red" "http://www.red.com/")
1400 (expect-condition (setf (namespace-uri element
) "http://www.example.com")
1404 (deftest element.setf-namespace-uri
.7
1405 (let* ((name "red:sakjdhjhd")
1406 (uri "http://www.red.com/")
1407 (element (make-element name uri
))
1408 (a (make-attribute "value" "red:test" "http://www.red.com/")))
1409 (add-attribute element a
)
1410 (expect-condition (setf (namespace-uri element
) "http://www.example.com")
1414 (deftest element.setf.namespace-uri
.8
1415 (let ((e (make-element "prefix:name" "http://www.foo.com/")))
1416 (expect-condition (setf (namespace-uri e
) "") stp-error
)
1417 (expect-condition (setf (namespace-uri e
) nil
) stp-error
)
1420 (deftest element.setf.namespace-prefix
.1
1421 (let* ((name "red:sakjdhjhd")
1422 (uri "http://www.red.com/")
1423 (element (make-element name uri
)))
1424 (add-extra-namespace element
"blue" "http://www.foo.com/")
1425 (add-attribute element
(make-attribute
1426 "value" "green:money" "http://www.example.com/"))
1427 (add-extra-namespace element
"purple" uri
)
1428 (add-attribute element
(make-attribute "value" "mauve:money" uri
))
1429 (expect-condition (setf (namespace-prefix element
) "blue")
1431 (expect-condition (setf (namespace-prefix element
) "green")
1433 (setf (namespace-prefix element
) "purple")
1434 (assert-equal "purple" (namespace-prefix element
))
1435 (setf (namespace-prefix element
) "mauve")
1436 (assert-equal "mauve" (namespace-prefix element
))
1439 (deftest element.setf.namespace-prefix
.2
1440 (let* ((name "red:sakjdhjhd")
1441 (uri "http://www.red.com/")
1442 (element (make-element name uri
)))
1443 (setf (namespace-prefix element
) nil
)
1444 (assert-equal "" (namespace-prefix element
))
1447 (deftest element.setf.namespace-prefix
.3
1448 (let ((element (make-element "sakjdhjhd")))
1449 (expect-condition (setf (namespace-prefix element
) "foo") stp-error
)
1452 (deftest element.add-extra-namespace
1453 (let* ((name "red:sakjdhjhd")
1454 (uri "http://www.red.com/")
1455 (element (make-element name uri
)))
1456 (dolist (legal *legal-uris
*)
1457 (remove-extra-namespace element
"prefix")
1458 (add-extra-namespace element
"prefix" legal
)
1459 (assert-equal legal
(find-namespace "prefix" element
)))
1460 (dolist (illegal *very-illegal-uris
*)
1461 (remove-extra-namespace element
"prefix")
1462 (expect-condition (add-extra-namespace element
"prefix" illegal
)
1466 (deftest element.add-extra-namespace
.2
1467 (let* ((name "red:sakjdhjhd")
1468 (uri "http://www.red.com/")
1469 (element (make-element name uri
)))
1470 (add-extra-namespace element
"xmlns" "")
1471 (remove-extra-namespace element
"xmlns")
1473 (add-extra-namespace element
"xmlns" "http://foo")
1477 (deftest element.add-extra-namespace
.3
1478 (let* ((name "red:sakjdhjhd")
1479 (uri "http://www.red.com/")
1480 (element (make-element name uri
)))
1481 (add-extra-namespace element
1483 "http://www.w3.org/XML/1998/namespace")
1484 (remove-extra-namespace element
"xml")
1486 (add-extra-namespace element
1488 "http://www.w3.org/XML/1998/namespace")
1492 (deftest element.add-extra-namespace
.4
1493 (let* ((name "red:sakjdhjhd")
1494 (uri "http://www.red.com/")
1495 (element (make-element name uri
)))
1496 (expect-condition (add-extra-namespace element
"foo" "hoppla") warning
)
1499 (deftest element.add-extra-namespace
.5
1500 (let* ((name "red:sakjdhjhd")
1501 (uri "http://www.red.com/")
1502 (element (make-element name uri
)))
1503 (add-extra-namespace element nil nil
)
1505 (map-extra-namespaces (lambda (prefix uri
)
1506 (assert-equal prefix
"")
1507 (assert-equal uri
"")
1510 (error "extra namespace not found"))
1513 (deftest element.add-extra-namespace
.6
1514 (let* ((name "red:sakjdhjhd")
1515 (uri "http://www.red.com/")
1516 (element (make-element name uri
)))
1518 (add-extra-namespace element
"foo" (string (code-char 0)))
1522 (deftest element.insert-child.nil
1523 (let* ((name "red:sakjdhjhd")
1524 (uri "http://www.red.com/")
1525 (element (make-element name uri
)))
1526 (expect-condition (insert-child element nil
0) error
)
1529 (deftest element.append-child.nil
1530 (let* ((name "red:sakjdhjhd")
1531 (uri "http://www.red.com/")
1532 (element (make-element name uri
)))
1533 (expect-condition (append-child element
0) error
)
1536 (deftest element.insert-child
.1
1537 (let* ((name "red:sakjdhjhd")
1538 (uri "http://www.red.com/")
1539 (e (make-element name uri
))
1540 (e2 (make-element "mv:child" "http://www.mauve.com"))
1541 (e3 (make-element "mv:child" "http://www.mauve.com"))
1542 (e4 (make-element "mv:child" "http://www.mauve.com")))
1543 (insert-child e e2
0)
1544 (insert-child e e3
0)
1545 (insert-child e3 e4
0)
1546 (assert-equal e3
(nth-child 0 e
))
1547 (let* ((root (make-element "root"))
1548 (doc (make-document root
)))
1549 (expect-condition (insert-child e doc
0) stp-error
))
1550 (expect-condition (insert-child e e2
0) stp-error
)
1551 (expect-condition (insert-child e e4
0) stp-error
)
1552 (expect-condition (insert-child e nil
0) error
)
1553 (expect-condition (insert-child e
(make-comment "test") 20) error
)
1554 (expect-condition (insert-child e
(make-comment "test") -
20) error
)
1557 (deftest element.filter-children
.1
1558 (with-element-test ()
1559 (let ((children (filter-children (alexandria:of-type
'element
) element
)))
1560 (assert-equal 3 (length children
))
1561 (assert-equal child1
(elt children
0))
1562 (assert-equal child4
(elt children
1))
1563 (assert-equal child5
(elt children
2)))
1564 (let ((children (filter-children (of-name "nonesuch") element
)))
1565 (assert-equal 0 (length children
)))
1566 (let ((children (filter-children (of-name "test") element
)))
1567 (assert-equal 1 (length children
))
1568 (assert-equal child1
(elt children
0)))
1570 (filter-children (of-name "test" "http://www.example.com")
1572 (assert-equal 2 (length children
))
1573 (assert-equal child4
(elt children
0))
1574 (assert-equal child5
(elt children
1)))
1577 (deftest element.add-attribute
.1
1578 (let ((element (make-element "name"))
1579 (a1 (make-attribute "name" "value"))
1580 (a2 (make-attribute "simple"
1582 "http://www.w3.org/TR/1999/xlink")))
1583 (add-attribute element a1
)
1584 (add-attribute element a2
)
1585 (assert-equal 2 (length (list-attributes element
)))
1586 (let ((element2 (make-element "name")))
1587 (expect-condition (add-attribute element2 a1
) stp-error
))
1589 (let ((funky (make-element "xlink:funky" "http://www.funky.org")))
1590 (expect-condition (add-attribute funky a2
) stp-error
))
1593 (make-element "prefix:funky" "http://www.w3.org/TR/1999/xlink")))
1594 (add-attribute notasfunky a2
))
1595 (let ((a3 (make-attribute "simple"
1597 "http://www.w3.org/TR/1999/xlink"))
1598 (a4 (make-attribute "simple"
1600 "http://www.w3.org/1998/xlink"))
1601 (test (make-element "test")))
1602 (add-attribute test a3
)
1603 (expect-condition (add-attribute test a4
) stp-error
))
1604 (let ((a5 (make-attribute "simple"
1606 "http://www.w3.org/TR/1999/xlink"))
1607 (a6 (make-attribute "simple"
1609 "http://www.w3.org/1998/xlink"))
1610 (test2 (make-element "test")))
1611 (add-attribute test2 a5
)
1612 (expect-condition (add-attribute test2 a6
) stp-error
))
1615 (deftest element.add-attribute
.2
1616 (let ((element (make-element "name")))
1617 (add-extra-namespace element
"xlink" "http://www.w3.org/TR/1999/xlink")
1618 (add-extra-namespace element
"pre" "http://www.example.com")
1619 (let ((a1 (make-attribute "values" "name"))
1620 (a2 (make-attribute "simple"
1622 "http://www.w3.org/TR/1999/xlink")))
1623 (add-attribute element a1
)
1624 (add-attribute element a2
)
1625 (assert-equal 2 (length (list-attributes element
))))
1627 (add-attribute element
1628 (make-attribute "value"
1630 "ftp://example.com/"))
1632 (add-attribute element
1633 (make-attribute "value"
1635 "ftp://example.com/"))
1636 (assert-equal 3 (length (list-attributes element
)))
1638 (add-extra-namespace element
"ok" "http://www.example.net")
1640 (assert-equal "ftp://example.com/" (find-namespace "ok" element
))
1641 (assert-equal "http://www.w3.org/TR/1999/xlink"
1642 (find-namespace "xlink" element
))
1643 (assert-equal "http://www.example.com" (find-namespace "pre" element
))
1646 (deftest element.add-attribute
.3
1647 (let ((element (make-element "pre:name" "http://www.example.com")))
1649 (setf (attribute-value element
"pre:a" "http://different") "value")
1653 (deftest element.add-attribute
.4
1654 (let ((element (make-element "pre:name" "http://www.example.com")))
1656 (add-attribute element
1657 (make-attribute"value" "pre:a" "http://different"))
1661 (deftest element.triple
1662 (serialize-to-string
1665 (cxml:parse
#1="<b><c1/><c2/></b>" (make-builder)))))
1668 (deftest element.copy
.1
1669 (let ((parent (make-element "parent"))
1670 (child (make-element "child")))
1671 (append-child parent child
)
1672 (assert-node= child
(copy child
))
1675 (deftest element.copy
.2
1676 (let ((parent (make-element "parent"))
1677 (child (make-element "child")))
1678 (append-child parent child
)
1679 (assert-node= parent
(copy parent
))
1682 (deftest element.copy
.3
1683 (let ((parent (make-element "parent"))
1684 (a (make-attribute "value" "name")))
1685 (add-attribute parent a
)
1686 (let ((copy (copy parent
)))
1687 (assert-node= parent copy
)
1688 (let ((copied (car (list-attributes copy
))))
1689 (assert-node= copied a
)
1690 (assert-equal copy
(parent copied
))))
1693 (deftest element.copy
.4
1694 (let ((parent (make-element "parent")))
1695 (assert-node= parent
(copy parent
))
1698 (deftest element.copy
.5
1699 (let* ((root (make-element "parent"))
1700 (d (make-document root
)))
1701 (assert-node= d
(copy d
))
1704 (deftest element.copy
.6
1705 (let* ((name "red:sakjdhjhd")
1706 (uri "http://www.red.com/")
1707 (base-uri "http://www.example.com/")
1708 (e (make-element name uri
)))
1709 (add-extra-namespace e
"blue" "http://www.blue.com")
1710 (add-extra-namespace e
"green" "http://www.green.com")
1711 (let ((a1 (make-attribute "test" "test"))
1712 (a2 (make-attribute "data" "pre1:green" "http://www.green.com"))
1713 (a3 (make-attribute "data"
1715 "http://www.yellow.com/")))
1716 (add-attribute e a1
)
1717 (add-attribute e a2
)
1718 (add-attribute e a3
))
1719 (append-child e
(make-element "mv:child" "http://www.mauve.com"))
1720 (let ((e3 (make-element "mv:child" "http://www.mauve.com")))
1721 (prepend-child e e3
)
1722 (append-child e3
(make-element "mv:child" "http://www.mauve.com")))
1723 (setf (base-uri e
) base-uri
)
1724 (let ((copy (copy e
)))
1725 (assert-equal (find-namespace "red" e
) (find-namespace "red" copy
))
1726 (assert-equal (find-namespace "blue" e
) (find-namespace "blue" copy
))
1727 (assert-equal (string-value e
) (string-value copy
))
1728 (let ((ea (find-attribute-named e
"test"))
1729 (ca (find-attribute-named copy
"test")))
1730 (assert-equal (value ea
) (value ca
)))
1731 (assert-equal (base-uri e
) (base-uri copy
)))
1734 (deftest element.copy
.7
1735 (let* ((top (make-element "e"))
1738 for parent
= top then child
1739 for i from
0 below
100
1740 for child
= (make-element (format nil
"e~D" i
))
1741 do
(append-child parent child
))
1742 (assert-node= top
(copy top
))
1745 (deftest element.delete-children
.1
1746 (let* ((name "red:sakjdhjhd")
1747 (uri "http://www.red.com/")
1748 (parent (make-element name uri
))
1749 (a1 (make-attribute "test" "test")))
1750 (add-attribute parent a1
)
1751 (let ((child1 (make-element "mv:child" "http://www.mauve.com"))
1752 (child2 (make-element "mv:child" "http://www.mauve.com"))
1753 (grandchild (make-element "mv:child" "http://www.mauve.com")))
1754 (append-child parent child1
)
1755 (append-child parent child2
)
1756 (append-child child2 grandchild
)
1757 (assert-equal child2
(parent grandchild
))
1758 (assert-equal parent
(parent child1
))
1759 (assert-equal parent
(parent child2
))
1760 (delete-children parent
)
1761 (assert-equal nil
(list-children parent
))
1762 (assert-equal nil
(parent child1
))
1763 (assert-equal nil
(parent child2
))
1764 (assert-equal child2
(parent grandchild
))
1765 (assert-equal parent
(parent a1
)))
1768 (deftest element.delete-children
.2
1769 (let ((base "http://www.example.com/")
1770 (parent (make-element "parent"))
1771 (child (make-element "child")))
1772 (setf (base-uri parent
) base
)
1773 (append-child parent child
)
1774 (delete-children parent
)
1775 (assert-equal base
(base-uri child
))
1778 (deftest element.delete-children
.3
1779 (let* ((name "red:sakjdhjhd")
1780 (uri "http://www.red.com/")
1781 (parent (make-element name uri
))
1782 (a1 (make-attribute "test" "test")))
1783 (add-attribute parent a1
)
1784 (let ((child1 (make-text "http://www.mauve.com"))
1785 (child2 (make-processing-instruction
1786 "child" "http://www.mauve.com"))
1787 (child3 (make-comment "http://www.mauve.com")))
1788 (append-child parent child1
)
1789 (append-child parent child2
)
1790 (append-child parent child3
)
1791 (assert-equal parent
(parent child3
))
1792 (assert-equal parent
(parent child1
))
1793 (assert-equal parent
(parent child2
))
1794 (delete-children parent
)
1795 (assert-equal nil
(list-children parent
))
1796 (assert-equal nil
(parent child1
))
1797 (assert-equal nil
(parent child2
))
1798 (assert-equal nil
(parent child3
))
1799 (assert-equal parent
(parent a1
))
1802 (deftest element.attribute-value
1803 (let* ((name "sakjdhjhd")
1804 (e (make-element name
)))
1805 (assert-equal nil
(attribute-value e
"test"))
1808 (attribute-value e
"base" "http://www.w3.org/XML/1998/namespace"))
1809 (add-attribute e
(make-attribute "value" "test"))
1810 (add-attribute e
(make-attribute
1811 "http://www.example.com/"
1813 "http://www.w3.org/XML/1998/namespace"))
1814 (assert-equal "value" (attribute-value e
"test"))
1816 "http://www.example.com/"
1817 (attribute-value e
"base" "http://www.w3.org/XML/1998/namespace"))
1818 ;; (assert-equal nil (attribute-value e "xml:base"))
1819 (assert-equal nil
(attribute-value e
"base"))
1822 (attribute-value e
"test" "http://www.w3.org/XML/1998/namespace"))
1825 (deftest element.setf.attribute-value
1826 (let* ((e (make-element "sakjdhjhd"))
1829 (add-attribute f
(make-attribute "1" "pre:foo" "http://pre"))
1830 (add-attribute g
(make-attribute "2" "pre:foo" "http://pre"))
1832 (setf (attribute-value e
"pre:foo" "http://pre") "1")
1834 ;; change existing attribute
1835 (setf (attribute-value e
"pre:foo" "http://pre") "2")
1839 (deftest element.setf.attribute-value
.2
1840 (let ((e (make-element "pre:sakjdhjhd" "http://pre")))
1841 (setf (attribute-value e
"pre:flubba") "value")
1842 (assert-equal (namespace-uri (car (list-attributes e
)))
1846 (deftest element.map-attributes
1847 (let* ((e (make-element "sakjdhjhd")))
1848 (add-attribute e
(make-attribute "1" "pre:foo" "http://pre"))
1849 (add-attribute e
(make-attribute "2" "pre:bar" "http://pre"))
1850 (assert-equal (list-attributes e
) (map-attributes 'list
#'identity e
))
1851 (assert-equal (mapcar #'qualified-name
(list-attributes e
))
1852 (map-attributes 'list
#'qualified-name e
))
1853 (assert (equalp (map 'vector
#'qualified-name
(list-attributes e
))
1854 (map-attributes 'vector
#'qualified-name e
)))
1857 (deftest element.with-attributes
1858 (let* ((e (make-element "sakjdhjhd")))
1859 (add-attribute e
(make-attribute "1" "pre:foo" "http://pre"))
1860 (add-attribute e
(make-attribute "2" "bar"))
1861 (add-attribute e
(make-attribute "gorilla" "ape"))
1862 (with-attributes ((foo "pre:foo" "http://pre")
1864 (baz "pre:baz" "http://pre")
1868 (setf foo
(format nil
"<~A>" foo
))
1869 (setf bar
(string #\newline
))
1870 (setf baz
"pre:xyz")
1871 (setf moose
"mangy")
1872 (assert-equal ape
"gorilla"))
1873 (assert-equal (attribute-value e
"foo" "http://pre") "<1>")
1874 (assert-equal (attribute-value e
"bar") (string #\newline
))
1875 (assert-equal (attribute-value e
"baz" "http://pre") "pre:xyz")
1876 (assert-equal (attribute-value e
"moose") "mangy")
1879 (deftest element.find-attribute-named
1880 (let* ((name "sakjdhjhd")
1881 (e (make-element name
)))
1882 (assert-equal nil
(find-attribute-named e
"test"))
1885 (find-attribute-named e
"base" "http://www.w3.org/XML/1998/namespace"))
1886 (let ((a1 (make-attribute "value" "test"))
1888 "http://www.example.com/"
1890 "http://www.w3.org/XML/1998/namespace")))
1891 (add-attribute e a1
)
1892 (add-attribute e a2
)
1893 (assert-equal a1
(find-attribute-named e
"test"))
1896 (find-attribute-named e
1898 "http://www.w3.org/XML/1998/namespace")))
1901 (deftest element.find-namespace.empty
.1
1902 (find-namespace "" (make-element "sakjdhjhd"))
1905 (deftest element.find-namespace.empty
.2
1906 (find-namespace nil
(make-element "sakjdhjhd"))
1909 (deftest element.namespace-prefix
.1
1910 (namespace-prefix (make-element "html"))
1913 (deftest element.namespace-prefix
.2
1914 (let ((test (make-element
1916 "http://www.w3.org/XML/1998/namespace")))
1917 (assert-equal "xml" (namespace-prefix test
))
1918 (assert-equal "http://www.w3.org/XML/1998/namespace"
1919 (namespace-uri test
))
1920 (assert-equal "xml:base" (qualified-name test
))
1923 (define-condition-test element.namespace-prefix
.3
1924 (make-element "xml:base" "http://www.example.org/")
1927 (define-condition-test element.namespace-prefix
.4
1928 (make-element "test:base" "http://www.w3.org/XML/1998/namespace")
1931 (define-condition-test element.name
.1
1935 (define-condition-test element.name
.2
1936 (make-element "1Kelvin")
1939 (define-condition-test element.name
.3
1943 (deftest element.print-object
1944 (let* ((name "red:sakjdhjhd")
1945 (uri "http://www.red.com/")
1946 (base-uri "http://www.example.com/")
1947 (e (make-element name uri
)))
1948 (add-extra-namespace e
"blue" "http://www.blue.com")
1949 (add-extra-namespace e
"green" "http://www.green.com")
1950 (let ((a1 (make-attribute "test" "test"))
1951 (a2 (make-attribute "data" "pre1:green" "http://www.green.com"))
1952 (a3 (make-attribute "data"
1954 "http://www.yellow.com/")))
1955 (add-attribute e a1
)
1956 (add-attribute e a2
)
1957 (add-attribute e a3
))
1958 (append-child e
(make-element "mv:child" "http://www.mauve.com"))
1959 (let ((e3 (make-element "mv:child" "http://www.mauve.com")))
1960 (prepend-child e e3
)
1961 (append-child e3
(make-element "mv:child" "http://www.mauve.com")))
1962 (setf (base-uri e
) base-uri
)
1963 (assert-node= e
(read-from-string (write-to-string e
)))
1966 (deftest element.map-extra-namespaces
1967 (let* ((name "red:sakjdhjhd")
1968 (uri "http://www.red.com/")
1969 (blue "http://www.blue.com")
1970 (green "http://www.green.com")
1971 (e (make-element name uri
)))
1972 (add-extra-namespace e
"blue" blue
)
1973 (add-extra-namespace e
"green" green
)
1974 (setf (attribute-value e
"pre1:green" green
) "data")
1977 (map-extra-namespaces
1978 (lambda (prefix uri
)
1980 ((equal prefix
"blue")
1981 (assert (not bluep
))
1983 (assert-equal uri blue
))
1984 ((equal prefix
"green")
1985 (assert (not greenp
))
1987 (assert-equal uri green
))
1989 (error "bogus namespace"))))
1993 (deftest element.base-uri
1994 (let* ((root (make-element "root"))
1995 (child (make-element "child"))
1996 (document (make-document root
)))
1997 (append-child root child
)
1998 (assert-equal (base-uri document
) "")
1999 (setf (base-uri root
) "file://etc")
2000 (setf (base-uri child
) "passwd")
2001 (assert (puri:uri
= (puri:parse-uri
"file://etc/passwd")
2005 (deftest element.root
2006 (let* ((de (make-element "root"))
2007 (child (make-element "child")))
2008 (append-child de child
)
2009 (assert-equal de
(root child
))
2010 (assert-equal de
(root de
))
2011 (let ((document (make-document de
)))
2012 (assert-equal document
(root de
))
2013 (assert-equal document
(root child
))
2014 (assert-equal document
(root document
)))
2020 (defmacro with-ATTRIBUTE-test
((&optional
) &body body
)
2021 `(let* ((a1 (make-attribute "value" "test"))
2022 (a2 (make-attribute " value " "test")))
2025 (deftest attribute.count-children
2026 (with-attribute-test ()
2030 (define-condition-test attribute.nth-child
2031 (with-attribute-test ()
2035 (deftest attribute.make-attribute
2036 (with-attribute-test ()
2037 (assert-equal "test" (local-name a1
))
2038 (assert-equal "test" (qualified-name a1
))
2039 (assert-equal "" (namespace-prefix a1
))
2040 (assert-equal "" (namespace-uri a1
))
2041 (assert-equal "value" (value a1
))
2042 (assert-equal " value " (value a2
))
2045 (deftest attribute.setf.local-name
2046 (let ((a (make-attribute "value" "name")))
2047 (setf (local-name a
) "newname")
2048 (assert-equal "newname" (local-name a
))
2049 (expect-condition (setf (local-name a
) "pre:a") stp-error
)
2052 (deftest attribute.setf.local-name
.2
2053 (let ((a (make-attribute "value" "pre:name" "http://www.example.org")))
2054 (setf (local-name a
) "newname")
2055 (assert-equal "newname" (local-name a
))
2056 (assert-equal "pre:newname" (qualified-name a
))
2059 (define-condition-test attribute.xmlns
.1
2060 (make-attribute "http://www.w3.org/TR" "xmlns")
2063 (define-condition-test attribute.xmlns
.2
2064 (make-attribute "http://www.w3.org/TR" "xmlns:prefix")
2067 (define-condition-test attribute.xmlns
.3
2068 (make-attribute "http://www.w3.org/"
2070 "http://www.w3.org/2000/xmlns/")
2073 (define-condition-test attribute.xmlns
.4
2074 (make-attribute "http://www.w3.org/"
2076 "http://www.w3.org/2000/xmlns/")
2079 (deftest attribute.xml-base
2080 (let* ((xml-namespace "http://www.w3.org/XML/1998/namespace")
2081 (a1 (make-attribute "http://www.w3.org/" "xml:base" xml-namespace
)))
2082 (assert-equal "base" (local-name a1
))
2083 (assert-equal "xml:base" (qualified-name a1
))
2084 (assert-equal xml-namespace
(namespace-uri a1
))
2085 (dolist (str '("http://www.example.com/>"
2086 "http://www.example.com/<"
2087 #.
(format nil
"http://www.example.com/~C"
2088 (code-char #x00FE
))))
2089 (setf (value a1
) str
)
2090 (assert-equal (value a1
) str
))
2093 (deftest attribute.xml-prefix
2095 (expect-condition (make-attribute "http://www.w3.org/" "xml:base")
2097 (expect-condition (make-attribute "preserve" "xml:space")
2099 (expect-condition (make-attribute "fr-FR" "xml:lang")
2101 (let* ((xml-namespace "http://www.w3.org/XML/1998/namespace")
2102 (a1 (make-attribute "http://www.w3.org/"
2105 (assert-equal "base" (local-name a1
))
2106 (assert-equal "xml:base" (qualified-name a1
))
2107 (assert-equal xml-namespace
(namespace-uri a1
))
2108 (let ((a2 (make-attribute "preserve"
2111 (assert-equal "space" (local-name a2
))
2112 (assert-equal "xml:space" (qualified-name a2
))
2113 (assert-equal xml-namespace
(namespace-uri a2
)))
2114 (let ((a3 (make-attribute "en-UK"
2117 (assert-equal "lang" (local-name a3
))
2118 (assert-equal "xml:lang" (qualified-name a3
))
2119 (assert-equal xml-namespace
(namespace-uri a3
)))
2121 (make-attribute "http://www.w3.org/"
2123 "http://www.notTheXMLNamespace")
2127 (deftest attribute.xml-lang
2128 (let* ((xml-namespace "http://www.w3.org/XML/1998/namespace")
2129 (a1 (make-attribute "" "xml:lang" xml-namespace
)))
2130 (assert-equal "" (value a1
))
2133 (define-condition-test attribute.xml-uri
2134 (make-attribute "value" "test:base" "http://www.w3.org/XML/1998/namespace")
2137 (deftest attribute.serialize
.1
2138 (let ((e (make-element "test")))
2139 (add-attribute e
(make-attribute "<" "a1"))
2140 (add-attribute e
(make-attribute ">" "a2"))
2141 (add-attribute e
(make-attribute "\"" "a3"))
2142 (add-attribute e
(make-attribute "'" "a4"))
2143 (add-attribute e
(make-attribute "&" "a5"))
2144 (serialize-to-string e
))
2145 "<test a5=\"&\" a4=\"'\" a3=\""\" a2=\">\" a1=\"<\"/>")
2147 (deftest attribute.serialize
.2
2148 (let ((e (make-element "test")))
2149 (add-attribute e
(make-attribute (string (code-char 32)) "a1"))
2150 (add-attribute e
(make-attribute (string (code-char 10)) "a2"))
2151 (add-attribute e
(make-attribute (string (code-char 13)) "a3"))
2152 (add-attribute e
(make-attribute (string (code-char 9)) "a4"))
2153 (serialize-to-string e
))
2154 "<test a4=\"	\" a3=\" \" a2=\" \" a1=\" \"/>")
2156 (deftest attribute.serialize
.3
2157 (let ((e (make-element "test")))
2158 (add-attribute e
(make-attribute "=,.!@#$%^*()_-'[]{}+/?;:`|\\" "a"))
2159 (serialize-to-string e
))
2160 "<test a=\"=,.!@#$%^*()_-'[]{}+/?;:`|\\\"/>")
2162 (deftest attribute.setf.value
2163 (let ((a (make-attribute "test" "test")))
2164 (dolist (legal '("Hello"
2166 " spaces on both ends "
2167 " quotes \" \" quotes"
2168 " single \'\' quotes"
2169 " both double and single \"\'\"\' quotes"
2170 " angle brackets < > <<<"
2171 " carriage returns \r\r\r"
2172 " ampersands & &&& &name; "))
2173 (setf (value a
) legal
)
2174 (assert-equal (value a
) legal
))
2175 (expect-condition (setf (value a
) (string (code-char 0))) stp-error
)
2178 (deftest attribute.names
2179 (let* ((prefix "testPrefix")
2181 (uri "http://www.elharo.com/")
2182 (value " here's some data")
2183 (qname (concatenate 'string prefix
":" name
))
2184 (a1 (make-attribute value qname uri
)))
2185 (assert-equal name
(local-name a1
))
2186 (assert-equal qname
(qualified-name a1
))
2187 (assert-equal uri
(namespace-uri a1
))
2190 (deftest attribute.copy
.1
2191 (let* ((c1 (make-attribute "data" "test"))
2193 (assert-equal (value c1
) (value c2
))
2194 (assert-equal (local-name c1
) (local-name c2
))
2195 (assert-equal (qualified-name c1
) (qualified-name c2
))
2196 (assert (not (eql c1 c2
)))
2197 (assert-equal nil
(parent c2
))
2200 ;;; fixme: testSurrogates
2202 (deftest attribute.rename-attribute
.1
2203 (let ((a (make-attribute "data" "red:prefix" "http://www.example.com")))
2204 (rename-attribute a nil nil
)
2205 (assert-equal "" (namespace-uri a
))
2206 (assert-equal "" (namespace-prefix a
))
2209 (deftest attribute.rename-attribute
.2
2210 (let ((a (make-attribute "data" "red:prefix" "http://www.example.com"))
2211 (e (make-element "pre:test" "http://www.example.org/")))
2213 (rename-attribute a
"pre" "http://www.example.org/")
2214 (assert-equal "http://www.example.org/" (namespace-uri a
))
2215 (assert-equal "pre" (namespace-prefix a
))
2216 (assert-equal "http://www.example.org/" (namespace-uri e
))
2217 (assert-equal "pre" (namespace-prefix e
))
2220 (deftest attribute.rename-attribute
.3
2221 (let* ((name "red:sakjdhjhd")
2222 (uri "http://www.red.com/")
2224 (a (make-attribute "" name uri
)))
2225 (assert-equal uri
(namespace-uri a
))
2226 (dolist (legal *legal-uris
*)
2227 (rename-attribute a prefix legal
)
2228 (assert-equal legal
(namespace-uri a
)))
2229 (dolist (illegal *very-illegal-uris
*)
2230 (expect-condition (rename-attribute a prefix illegal
) stp-error
))
2233 (deftest attribute.rename-attribute
.4
2234 (let ((a (make-attribute "value" "name")))
2235 (expect-condition (rename-attribute a
"pre" "") stp-error
)
2236 (expect-condition (rename-attribute a
"" "http://www.example.com")
2240 (deftest attribute.rename-attribute
.5
2241 (let ((element (make-element "test"))
2242 (a (make-attribute "bar" "pre:foo" "http://pre.com"))
2243 (b (make-attribute "bar" "post:bar" "http://post.com")))
2244 (add-attribute element a
)
2245 (add-attribute element b
)
2246 (expect-condition (rename-attribute b
"pre" "http://post.com")
2250 (deftest attribute.node-properties
2251 (let ((a (make-attribute "data" "test")))
2252 (assert-equal nil
(parent a
))
2253 (let ((element (make-element "test")))
2254 (add-attribute element a
)
2255 (assert-equal element
(parent a
))
2256 (assert-equal a
(find-attribute-named element
"test"))
2257 (remove-attribute element a
)
2258 (assert-equal nil
(find-attribute-named element
"test")))
2261 (deftest attribute.constraints
2262 (let ((element (make-element "test"))
2263 (a1 (make-attribute "valueFoo" "foo:data" "http://www.example.com"))
2264 (a2 (make-attribute "valueBar" "bar:data" "http://www.example.com"))
2265 (a3 (make-attribute "valueFoo" "data"))
2266 (a4 (make-attribute "valueBar" "data")))
2267 ;; add initial attribute
2268 (add-attribute element a1
)
2269 (assert-equal "valueFoo"
2270 (attribute-value element
"data" "http://www.example.com"))
2271 (assert-equal (list a1
) (list-attributes element
))
2273 (add-attribute element a2
)
2274 (assert-equal "valueBar"
2275 (attribute-value element
"data" "http://www.example.com"))
2276 (assert-equal (list a2
) (list-attributes element
))
2277 ;; add a different one
2278 (add-attribute element a3
)
2279 (assert-equal "valueFoo" (attribute-value element
"data"))
2280 (assert-equal "valueBar"
2281 (attribute-value element
"data" "http://www.example.com"))
2282 (assert-equal 2 (length (list-attributes element
)))
2284 (add-attribute element a4
)
2285 (assert-equal "valueBar" (attribute-value element
"data"))
2286 (assert-equal "valueBar"
2287 (attribute-value element
"data" "http://www.example.com"))
2288 (assert-equal 2 (length (list-attributes element
)))
2290 (let ((a5 (make-attribute "valueRed" "red:ab" "http://www.example.org"))
2292 "valueGreen" "green:cd" "http://www.example.org")))
2293 (add-attribute element a5
)
2294 (add-attribute element a6
)
2295 (assert-equal "valueRed"
2296 (attribute-value element
"ab" "http://www.example.org"))
2297 (assert-equal "valueGreen"
2298 (attribute-value element
"cd" "http://www.example.org")))
2301 (deftest attribute.double-add
2302 (let ((element (make-element "test"))
2303 (a (make-attribute "bar" "foo")))
2304 (add-attribute element a
)
2305 (remove-attribute element a
)
2306 (let ((copy (copy element
)))
2307 (add-attribute copy
(make-attribute "newvalue" "a"))
2308 (assert-equal 1 (length (list-attributes copy
))))
2311 (deftest attribute.string-value
2312 (string-value (make-attribute "bar" "foo"))
2315 (define-condition-test attribute.serialize
2316 (serialize (make-attribute "bar" "foo") nil
)
2319 (deftest attribute.print-object
2320 (let ((a (make-attribute "bar" "pre:foo" "http://uri")))
2321 (assert-node= a
(read-from-string (write-to-string a
)))
2327 (defmacro with-parent-node-test
((&optional
) &body body
)
2328 `(let* ((empty (make-element "empty"))
2329 (not-empty (make-element "not-empty"))
2330 (child (make-comment "Hello")))
2331 (append-child not-empty child
)
2334 (deftest parent-node.detach
2335 (with-parent-node-test ()
2336 (let ((text (make-text "This will be attached then detached")))
2337 (append-child empty text
)
2338 (assert-equal empty
(parent text
))
2340 (assert-equal nil
(parent text
))
2343 (deftest parent-node.append-child
2344 (with-parent-node-test ()
2345 (let ((child (make-element "test")))
2346 (append-child empty child
)
2347 (assert-equal (parent child
) empty
)
2348 (assert-equal (list-children empty
) (list child
))
2350 (append-child not-empty child
)
2351 (assert (not (eql (nth-child 0 not-empty
) child
)))
2352 (assert-equal (nth-child 1 not-empty
) child
)
2355 (define-condition-test parent-node.append-child
.2
2356 (let ((child (make-element "test")))
2357 (append-child child child
))
2360 (deftest parent-node.append-child
.3
2361 (let ((a (make-element "test"))
2362 (b (make-element "test")))
2364 (expect-condition (append-child b a
) stp-error
)
2367 (deftest parent-node.insert-child
2368 (let ((parent (make-element "parent"))
2369 (child1 (make-element "child"))
2370 (child2 (make-element "child2"))
2371 (child3 (make-element "child3"))
2372 (child4 (make-element "child4"))
2373 (child5 (make-element "child5")))
2375 (insert-child parent child1
0)
2376 (assert (plusp (child-count parent
)))
2377 (assert-equal 0 (child-position child1 parent
))
2379 (insert-child parent child2
0)
2380 (assert-equal 0 (child-position child2 parent
))
2381 (assert-equal 1 (child-position child1 parent
))
2383 (insert-child parent child3
1)
2384 (assert-equal 0 (child-position child2 parent
))
2385 (assert-equal 1 (child-position child3 parent
))
2386 (assert-equal 2 (child-position child1 parent
))
2387 ;; at beginning with children
2388 (insert-child parent child4
0)
2389 (assert-equal 0 (child-position child4 parent
))
2390 (assert-equal 1 (child-position child2 parent
))
2391 (assert-equal 2 (child-position child3 parent
))
2392 (assert-equal 3 (child-position child1 parent
))
2393 ;; at end with children
2394 (insert-child parent child5
4)
2395 (assert-equal 0 (child-position child4 parent
))
2396 (assert-equal 1 (child-position child2 parent
))
2397 (assert-equal 2 (child-position child3 parent
))
2398 (assert-equal 3 (child-position child1 parent
))
2399 (assert-equal 4 (child-position child5 parent
))
2401 (expect-condition (insert-child parent nil
0) error
)
2404 (define-condition-test parent-node.append-child
.4
2405 (with-parent-node-test ()
2406 (append-child empty
(make-document not-empty
)))
2409 (define-condition-test parent-node.append-child
.5
2410 (with-parent-node-test ()
2411 (append-child empty child
))
2414 (deftest parent-node.replace-child
2415 (with-parent-node-test ()
2416 (let ((old1 (make-element "old1"))
2417 (old2 (make-element "old2"))
2418 (old3 (make-element "old3"))
2419 (new1 (make-element "new1"))
2420 (new2 (make-element "new2"))
2421 (new3 (make-element "new3")))
2422 (append-child empty old1
)
2423 (append-child empty old2
)
2424 (append-child empty old3
)
2425 (replace-child empty old1 new1
)
2426 (replace-child empty old3 new3
)
2427 (replace-child empty old2 new2
)
2428 (assert-equal (list new1 new2 new3
) (list-children empty
))
2429 (expect-condition (replace-child empty new1 nil
) error
)
2430 (expect-condition (replace-child empty old1 nil
) error
)
2431 (let ((new4 (make-element "new4")))
2432 (expect-condition (replace-child empty new4
(make-element "test"))
2434 (replace-child empty new1 new1
)
2435 (assert-equal new1
(nth-child 0 empty
))
2436 (assert-equal empty
(parent new1
))
2437 (expect-condition (replace-child empty new1 new2
) stp-error
))
2440 (deftest parent-node.child-position
2441 (with-parent-node-test ()
2442 (let ((child1 (make-element "old1"))
2443 (child2 (make-text "old2"))
2444 (child3 (make-comment "old3")))
2445 (assert-equal nil
(child-position child1 empty
))
2446 (append-child empty child1
)
2447 (append-child empty child2
)
2448 (append-child empty child3
)
2449 (assert-equal 0 (child-position child1 empty
))
2450 (assert-equal 1 (child-position child2 empty
))
2451 (assert-equal 2 (child-position child3 empty
))
2452 (assert-equal nil
(child-position empty empty
))
2453 (assert-equal nil
(child-position (make-text "test") empty
)))
2456 (deftest parent-node.nth-child
2457 (with-parent-node-test ()
2458 (let ((old1 (make-element "old1"))
2459 (old2 (make-element "old2"))
2460 (old3 (make-comment "old3")))
2461 (expect-condition (nth-child 0 empty
) error
)
2462 (append-child empty old1
)
2463 (append-child empty old2
)
2464 (append-child empty old3
)
2465 (assert-equal old1
(nth-child 0 empty
))
2466 (assert-equal old2
(nth-child 1 empty
))
2467 (assert-equal old3
(nth-child 2 empty
))
2468 (expect-condition (nth-child 5 empty
) error
))
2471 (deftest parent-node.delete-child
2472 (with-parent-node-test ()
2473 (expect-condition (delete-nth-child 0 empty
) error
)
2474 (let ((old1 (make-element "old1"))
2475 (old2 (make-element "old2"))
2476 (old3 (make-element "old3")))
2477 (expect-condition (delete-child old1 empty
) error
)
2478 (append-child empty old1
)
2479 (append-child empty old2
)
2480 (append-child empty old3
)
2481 (delete-nth-child 1 empty
)
2482 (assert-equal old1
(nth-child 0 empty
))
2483 (assert-equal old3
(nth-child 1 empty
))
2484 (delete-nth-child 1 empty
)
2485 (delete-nth-child 0 empty
)
2486 (assert-equal nil
(parent old2
))
2487 (assert-equal nil
(list-children empty
))
2488 (append-child empty old1
)
2489 (append-child empty old2
)
2490 (append-child empty old3
)
2491 (assert-equal (list old1 old2 old3
) (list-children empty
))
2492 (delete-child old3 empty
)
2493 (delete-child old1 empty
)
2494 (delete-child old2 empty
)
2495 (assert-equal nil
(list-children empty
))
2496 (assert-equal nil
(parent old1
)))
2499 (deftest parent-node.replace-child
.2
2500 (with-parent-node-test ()
2501 (let ((old1 (make-element "old1"))
2502 (old2 (make-element "old2"))
2503 (old3 (make-element "old3"))
2504 (new1 (make-element "new1"))
2505 (new3 (make-element "new3")))
2506 (append-child empty old1
)
2507 (append-child empty old2
)
2508 (expect-condition (replace-child empty old3 new3
) stp-error
)
2509 (expect-condition (replace-child empty old1 nil
) error
)
2510 (expect-condition (replace-child empty nil new1
) error
))
2513 (deftest parent-node.replace-child
.3
2514 (with-parent-node-test ()
2515 (let ((test1 (make-element "test1"))
2516 (test2 (make-element "test2")))
2517 (expect-condition (replace-child empty test1 test2
) stp-error
))
2520 (deftest parent-node.replace-child
.4
2521 (with-parent-node-test ()
2522 (let ((parent (make-element "parent"))
2523 (test1 (make-element "test1"))
2524 (test2 (make-element "test2")))
2525 (append-child parent test1
)
2526 (append-child parent test2
)
2527 (expect-condition (replace-child parent test1 test2
) stp-error
)
2528 (assert-equal (list test1 test2
) (list-children parent
)))
2531 (deftest parent-node.insert-child
.2
2532 (with-parent-node-test ()
2533 (let ((parent (make-element "parent"))
2534 (test1 (make-element "test1"))
2535 (test2 (make-element "test2")))
2536 (append-child parent test1
)
2537 (append-child parent test2
)
2538 (expect-condition (insert-child parent test2
0) stp-error
)
2539 (expect-condition (insert-child parent test2
1) stp-error
)
2540 (assert-equal (list test1 test2
) (list-children parent
)))
2543 (deftest parent-node.replace-child
.4
2544 (with-parent-node-test ()
2545 (let ((parent (make-element "parent"))
2546 (child (make-element "child")))
2547 (append-child parent child
)
2549 (replace-child parent child
(make-document-type "root"))
2551 (let ((e (make-element "e"))
2552 (child2 (make-text "child2")))
2553 (append-child e child2
)
2554 (expect-condition (replace-child parent child child2
) stp-error
)))
2557 (deftest node.insert-child-before
.1
2558 (let ((parent (make-element "parent"))
2559 (a (make-element "child"))
2560 (b (make-text "text"))
2561 (new1 (make-text "new"))
2562 (new2 (make-text "new2")))
2563 (expect-condition (insert-child-before parent new1 a
) stp-error
)
2564 (expect-condition (insert-child-before parent new2 b
) stp-error
)
2565 (append-child parent a
)
2566 (append-child parent b
)
2567 (insert-child-before parent new1 a
)
2568 (insert-child-before parent new2 b
)
2569 (assert-equal (list new1 a new2 b
) (list-children parent
))
2572 (deftest node.insert-child-after
.1
2573 (let ((parent (make-element "parent"))
2574 (a (make-element "child"))
2575 (b (make-text "text"))
2576 (new1 (make-text "new1"))
2577 (new2 (make-text "new2")))
2578 (expect-condition (insert-child-after parent new1 a
) stp-error
)
2579 (expect-condition (insert-child-after parent new2 b
) stp-error
)
2580 (append-child parent a
)
2581 (append-child parent b
)
2582 (insert-child-after parent new1 a
)
2583 (insert-child-after parent new2 b
)
2584 (assert-equal (list a new1 b new2
) (list-children parent
))
2591 (deftest node.first-child
.1
2592 (let ((parent (make-element "parent"))
2593 (a (make-element "child"))
2594 (b (make-text "text")))
2595 (assert-equal nil
(first-child parent
))
2596 (append-child parent a
)
2597 (append-child parent b
)
2598 (assert-equal a
(first-child parent
))
2601 (assert-equal nil
(first-child parent
))
2604 (deftest node.last-child
.1
2605 (let ((parent (make-element "parent"))
2606 (a (make-element "child"))
2607 (b (make-text "text")))
2608 (assert-equal nil
(last-child parent
))
2609 (append-child parent a
)
2610 (append-child parent b
)
2611 (assert-equal b
(last-child parent
))
2614 (assert-equal nil
(last-child parent
))
2617 (deftest node.previous-sibling
.1
2618 (let ((parent (make-element "parent"))
2619 (a (make-element "child"))
2620 (b (make-text "text")))
2621 (expect-condition (previous-sibling a
) stp-error
)
2622 (expect-condition (previous-sibling b
) stp-error
)
2623 (append-child parent a
)
2624 (append-child parent b
)
2625 (expect-condition (previous-sibling a
) stp-error
)
2626 (assert-equal a
(previous-sibling b
))
2629 (deftest node.next-sibling
.1
2630 (let ((parent (make-element "parent"))
2631 (a (make-element "child"))
2632 (b (make-text "text")))
2633 (expect-condition (next-sibling a
) stp-error
)
2634 (expect-condition (next-sibling b
) stp-error
)
2635 (append-child parent a
)
2636 (append-child parent b
)
2637 (assert-equal b
(next-sibling a
))
2638 (expect-condition (next-sibling b
) stp-error
)
2641 (defmacro with-sequence-test
((&optional
) &body body
)
2642 `(let ((e (make-element "test"))
2643 (a (make-element "a"))
2644 (a2 (make-element "a"))
2645 (b (make-element "b"))
2646 (s (make-text "foo"))
2647 (x (make-element "x")))
2648 (declare (ignorable x
))
2655 (defun maybe-local-name (x)
2657 (element (local-name x
))
2660 (deftest node.count-children
.0
2661 (with-sequence-test ()
2662 (count-children x e
))
2665 (deftest node.count-children
.1
2666 (with-sequence-test ()
2667 (count-children a e
))
2670 (deftest node.count-children
.2
2671 (with-sequence-test ()
2672 (count-children a e
:test
#'eql
))
2675 (deftest node.count-children
.3
2676 (with-sequence-test ()
2677 (count-children a e
:test
'eql
))
2680 (deftest node.count-children
.4
2681 (with-sequence-test ()
2682 (count-children "a" e
:key
#'maybe-local-name
:test
#'equal
))
2685 (deftest node.count-children
.5
2686 (with-sequence-test ()
2687 (count-children "a" e
:key
'maybe-local-name
:test
'equal
))
2690 (deftest node.count-children
.6
2691 (with-sequence-test ()
2692 (count-children (copy-seq "a") e
:key
'maybe-local-name
))
2695 (deftest node.count-children
.7
2696 (with-sequence-test ()
2697 (count-children a e
:from-end t
))
2700 (deftest node.count-children
.8
2702 (with-sequence-test ()
2704 (count-children a e
:key
(lambda (c) (push c seen
) c
))
2705 (assert-equal seen
(list s b a2 a
)))))
2708 (deftest node.count-children
.9
2710 (with-sequence-test ()
2712 (count-children a e
:from-end t
:key
(lambda (c) (push c seen
) c
))
2713 (assert-equal seen
(list a a2 b s
)))))
2716 (deftest node.count-children
.10
2717 (with-sequence-test ()
2720 :key
'maybe-local-name
2725 (deftest node.count-children
.11
2726 (with-sequence-test ()
2729 :key
'maybe-local-name
2734 (deftest node.count-children
.12
2735 (with-sequence-test ()
2738 :key
'maybe-local-name
2743 (deftest node.count-children
.13
2744 (with-sequence-test ()
2747 :key
'maybe-local-name
2753 (deftest node.count-children
.14
2754 (with-sequence-test ()
2755 (count-children "a" e
:key
'maybe-local-name
:test
'equal
:end nil
))
2758 (deftest node.count-children
.15
2759 (with-sequence-test ()
2760 (count-children "a" e
:test
(constantly t
) :start
1))
2763 (deftest node.count-children-if
.1
2764 (with-sequence-test ()
2765 (count-children-if #'identity e
))
2768 (deftest node.count-children-if
.2
2769 (with-sequence-test ()
2770 (count-children-if (alexandria:of-type
'element
) e
))
2773 (deftest node.count-children-if
.3
2774 (with-sequence-test ()
2775 (count-children-if #'break a
))
2778 (deftest node.count-children-if
.4
2779 (with-sequence-test ()
2780 (count-children-if (lambda (x) (equal x
"a"))
2782 :key
'maybe-local-name
))
2785 (deftest node.count-children-if
.5
2786 (with-sequence-test ()
2787 (count-children-if 'identity e
:key
'identity
))
2790 (deftest node.count-children-if
.8
2791 (count-if #'identity
'(a b nil c d nil e
) :key
'not
)
2794 (deftest node.count-children-if
.9
2795 (count-if #'evenp
'(1 2 3 4 4 1 8 10 1))
2798 (deftest node.count-children-if
.10
2799 (count-if #'evenp
'(1 2 3 4 4 1 8 10 1) :key
#'1+)
2802 (deftest node.count-children-if
.11
2804 (with-sequence-test ()
2806 (count-children-if (constantly t
)
2808 :key
(lambda (c) (push c seen
) c
))
2809 (assert-equal seen
(list b a2 a
)))))
2812 (deftest node.count-children-if
.12
2814 (with-sequence-test ()
2816 (count-children-if (constantly t
)
2819 :key
(lambda (c) (push c seen
) c
))
2820 (assert-equal seen
(list a a2 b
)))))
2823 (deftest node.count-children-if
.10
2824 (with-sequence-test ()
2825 (count-children-if (lambda (x) (equal x
"a"))
2827 :key
'maybe-local-name
2831 (deftest node.count-children-if
.11
2832 (with-sequence-test ()
2833 (count-children-if (lambda (x) (equal x
"a"))
2835 :key
'maybe-local-name
2839 (deftest node.count-children-if
.12
2840 (with-sequence-test ()
2841 (count-children-if (lambda (x) (equal x
"a"))
2843 :key
'maybe-local-name
2847 (deftest node.count-children-if
.13
2848 (with-sequence-test ()
2849 (count-children-if (lambda (x) (equal x
"a"))
2851 :key
'maybe-local-name
2856 ;;;; FIXME: find-child-if, child-position, filter-children
2858 (deftest node.map-recursively
.1
2859 (let* ((root (make-element "foo"))
2860 (child (make-element "bar"))
2861 (text (make-text "bla"))
2862 (document (make-document root
)))
2863 (setf (attribute-value child
"ignoreme") "value")
2864 (append-child root child
)
2865 (append-child root text
)
2868 (map-recursively (lambda (x) (push x seen
)) document
)
2870 (list document root child text
))
2873 (deftest node.do-recursively
.1
2874 (let* ((root (make-element "foo"))
2875 (child (make-element "bar"))
2876 (text (make-text "bla"))
2877 (document (make-document root
)))
2878 (setf (attribute-value child
"ignoreme") "value")
2879 (append-child root child
)
2880 (append-child root text
)
2883 (do-recursively (x document
(nreverse seen
))
2885 (list document root child text
))
2888 (deftest node.find-recursively
.1
2889 (let* ((root (make-element "foo"))
2890 (child (make-element "bar"))
2891 (text (make-text "bla"))
2892 (document (make-document root
)))
2893 (setf (attribute-value child
"ignoreme") "value")
2894 (append-child root child
)
2895 (append-child root text
)
2896 (assert-equal (find-recursively 'text document
:key
#'type-of
)
2898 (assert-equal (find-recursively "element"
2905 (deftest node.filter-recursively
.1
2906 (let* ((root (make-element "foo"))
2907 (child (make-element "bar"))
2908 (text (make-text "bla"))
2909 (document (make-document root
)))
2910 (setf (attribute-value child
"ignoreme") "value")
2911 (append-child root child
)
2912 (append-child root text
)
2913 (assert-equal (filter-recursively (lambda (x) (eq x
'text
))
2917 (assert-equal (filter-recursively (lambda (x) (string-equal x
"element"))
2926 ;;;; the XML Test suite is a good test for the builder, so we need only few
2929 (deftest builder.extra-namespaces
2930 (serialize-to-string
2932 (cxml:parse
#1="<b xmlns:extra=\"http://because-it.s-extra/\"/>"
2939 ;; next: testRemoveNonElementChildren