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 (deftest document.setf.document-element.regression
.1
841 (let* ((root (make-element "root"))
842 (document (make-document root
))
843 (new-root (make-element "new-root")))
844 (stp:prepend-child document
(make-comment "test"))
846 (setf (document-element document
) 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 (setf (document-element document
) child
) stp-error
))
856 (setf (document-element document
) new-root
)
857 (assert-equal (document-element document
) new-root
)
858 (assert-equal nil
(parent root
))
861 ;; like document.setf.document-element, but using replace-child instead
862 (deftest document.setf.replace-child
863 (let* ((root (make-element "root"))
864 (document (make-document root
))
865 (new-root (make-element "new-root")))
867 (replace-child document root new-root
)
868 (assert-equal (document-element document
) new-root
)
869 (assert-equal nil
(parent root
))
870 (expect-condition (setf (document-element document
) nil
) type-error
)
871 ;; no multiple parents
872 (let ((top (make-element "top"))
873 (child (make-element "child")))
874 (append-child top child
)
875 (expect-condition (replace-child document child new-root
) stp-error
))
877 (replace-child document new-root new-root
)
878 (assert-equal (document-element document
) new-root
)
879 (assert-equal nil
(parent root
))
882 (deftest document.insertion-allowed
883 (let* ((root (make-element "root"))
884 (document (make-document root
))
885 (original (make-comment "original"))
886 (c2 (make-comment "new comment"))
887 (temp (make-element "temp")))
888 (prepend-child document original
)
889 (append-child temp c2
)
890 (expect-condition (replace-child document original c2
) stp-error
)
891 (assert-equal (list-children document
) (list original root
))
894 (deftest document.replace-doctype
.1
895 (let* ((root (make-element "root"))
896 (document (make-document root
))
897 (new (make-document-type "new"))
898 (old (make-document-type "old")))
899 (setf (document-type document
) old
)
900 (replace-child document old new
)
901 (assert-equal new
(document-type document
))
902 (assert-equal nil
(parent old
))
903 (assert-equal document
(parent new
))
906 (deftest document.replace-doctype
.2
907 (let* ((root (make-element "root"))
908 (document (make-document root
))
909 (new (make-document-type "new"))
910 (old (make-document-type "old"))
911 (temp (make-document (make-element "root"))))
912 (setf (document-type temp
) new
)
913 (setf (document-type document
) old
)
914 (expect-condition (setf (document-type document
) new
) stp-error
)
915 (assert-equal old
(document-type document
))
916 (assert-equal document
(parent old
))
917 (assert-equal new
(document-type temp
))
918 (assert-equal temp
(parent new
))
921 (deftest document.replacement-allowed
.1
922 (let* ((root (make-element "root"))
923 (document (make-document root
))
924 (comment (make-comment "c")))
925 (expect-condition (replace-child document root comment
) stp-error
)
926 (assert-equal root
(document-element document
))
927 (assert-equal document
(parent root
))
928 (assert-equal nil
(parent comment
))
931 (deftest document.replacement-allowed
.2
932 (let* ((document (make-document (make-element "root")))
933 (comment (make-comment "not a doctype"))
934 (doctype (make-document-type "new")))
935 (prepend-child document comment
)
936 (replace-child document comment doctype
)
937 (assert-equal doctype
(document-type document
))
938 (assert-equal document
(parent doctype
))
939 (assert-equal nil
(parent comment
))
942 (deftest document.detach
943 (let* ((document (make-document (make-element "root")))
944 (comment (make-comment "c")))
945 (append-child document comment
)
946 (assert-equal document
(parent comment
))
948 (assert-equal nil
(parent comment
))
951 (deftest document.document
952 (let ((document (make-document (make-element "root"))))
953 (assert-equal document
(document document
))
956 (deftest document.root
957 (let ((document (make-document (make-element "root"))))
958 (assert-equal document
(root document
))
961 (deftest document.copy
962 (let* ((root (make-element "root"))
963 (document (make-document root
)))
964 (prepend-child document
(make-comment "text"))
965 (insert-child document
(make-processing-instruction "text" "data") 1)
966 (insert-child document
(make-document-type "text") 2)
967 (append-child root
(make-comment "after"))
968 (append-child document
(make-processing-instruction "text" "after"))
969 (assert-node= document
(copy document
))
972 (deftest document.append-child
973 (let* ((root (make-element "root"))
974 (document (make-document root
)))
975 (expect-condition (append-child document
(make-text "test")) stp-error
)
976 (expect-condition (append-child document
(make-text " ")) stp-error
)
977 (append-child document
(make-comment "foo"))
978 (expect-condition (append-child document
(make-element "test"))
980 (expect-condition (insert-child document
(make-element "foo") 0)
984 (deftest document.delete-child
985 (let* ((root (make-element "root"))
986 (document (make-document root
)))
987 (expect-condition (detach root
) stp-error
)
988 (expect-condition (delete-child root document
) stp-error
)
989 (expect-condition (delete-child-if #'identity document
:start
0 :count
1)
991 (append-child document
(make-comment "test"))
992 (delete-child-if #'identity document
:start
1 :count
1)
993 (assert-equal 1 (child-count document
))
994 (let ((test (make-comment "test")))
995 (append-child document test
)
996 (delete-child test document
)
997 (assert-equal 1 (child-count document
)))
998 (delete-child (make-comment "sd") document
)
1000 (delete-child-if #'identity document
:start
20 :count
1)
1004 (deftest document.delete-child
.2
1005 (let* ((root (make-element "root"))
1006 (document (make-document root
))
1007 (a (make-element "a"))
1008 (b (make-element "b"))
1009 (c (make-element "c"))
1010 (d (make-element "d")))
1011 (append-child root a
)
1012 (append-child root b
)
1013 (append-child root c
)
1014 (append-child root d
)
1015 (delete-child-if #'identity root
:count
1 :start
1 :end
3)
1016 (assert-equal (list a c d
) (list-children root
))
1019 (deftest document.delete-child
.3
1020 (let* ((root (make-element "root"))
1021 (document (make-document root
))
1022 (a (make-element "a"))
1023 (b (make-element "b"))
1024 (c (make-element "c"))
1025 (d (make-element "d")))
1026 (append-child root a
)
1027 (append-child root b
)
1028 (append-child root c
)
1029 (append-child root d
)
1030 (delete-child-if #'identity root
:count
1 :start
1 :end
3 :from-end t
)
1031 (assert-equal (list a b d
) (list-children root
))
1034 (deftest document.serialize
1035 (let* ((root (make-element "root"))
1036 (document (make-document root
)))
1037 (serialize-to-string document
))
1038 "<?xml version=\"1.0\" encoding=\"UTF-8\"?>
1041 (deftest document.string-value
1042 (let* ((root (make-element "root"))
1043 (document (make-document root
)))
1044 (append-child root
(make-text "frob"))
1045 (string-value document
))
1048 (deftest document.print-object
1049 (let ((n (make-document (make-element "root"))))
1050 (assert-node= n
(read-from-string (write-to-string n
)))
1056 (defmacro with-element-test
((&optional
) &body body
)
1057 `(let* ((child1 (make-element "test"))
1058 (child2 (make-text "test2"))
1059 (child3 (make-comment "test3"))
1060 (child4 (make-element "pre:test" "http://www.example.com"))
1061 (child5 (make-element "test" "http://www.example.com"))
1062 (element (make-element "name")))
1063 (append-child element child1
)
1064 (append-child element child2
)
1065 (append-child element child3
)
1066 (append-child element child4
)
1067 (append-child element child5
)
1068 (let ((str (format nil
" ~C~C" (code-char 13) (code-char 10))))
1069 (append-child element
(make-text str
)))
1072 (deftest element.of-name
.1
1073 (with-element-test ()
1074 (length (filter-children (of-name nil
"http://www.example.com") element
)))
1077 (deftest element.of-name
.2
1078 (with-element-test ()
1079 (length (filter-children (of-name nil
) element
)))
1082 (deftest element.find-if
1083 (with-element-test ()
1084 (assert-equal child1
(find-child-if (of-name "test") element
))
1085 (assert-equal child4
1086 (find-child-if (of-name "test" "http://www.example.com")
1088 (assert-equal nil
(find-child-if (of-name "none") element
))
1089 (expect-condition (of-name "pre:test") stp-error
)
1091 (find-child-if (of-name "none" "http://www.example.com")
1095 (deftest element.xmlns-name
1096 (let* ((name "xmlns")
1097 (e (make-element name
)))
1098 (assert-equal name
(local-name e
))
1099 (assert-equal name
(qualified-name e
))
1100 (assert-equal "" (namespace-prefix e
))
1101 (assert-equal "" (namespace-uri e
))
1104 (define-condition-test element.xmlns-prefix
1105 (make-element "xmlns:foo" "http://www.example.org/")
1108 (deftest element.constructor
.1
1109 (let* ((name "Jethro")
1110 (e (make-element name
)))
1111 (assert-equal name
(local-name e
))
1112 (assert-equal name
(qualified-name e
))
1113 (assert-equal "" (namespace-prefix e
))
1114 (assert-equal "" (namespace-uri e
))
1117 (deftest element.constructor
.2
1118 (let* ((name "sakjdhjhd")
1119 (uri "http://www.something.com/")
1120 (e (make-element name uri
)))
1121 (assert-equal name
(local-name e
))
1122 (assert-equal name
(qualified-name e
))
1123 (assert-equal "" (namespace-prefix e
))
1124 (assert-equal uri
(namespace-uri e
))
1127 (deftest element.constructor
.3
1128 (let* ((name "red:sakjdhjhd")
1129 (uri "http://www.something.com/")
1130 (e (make-element name uri
)))
1131 (assert-equal "sakjdhjhd" (local-name e
))
1132 (assert-equal name
(qualified-name e
))
1133 (assert-equal "red" (namespace-prefix e
))
1134 (assert-equal uri
(namespace-uri e
))
1137 (deftest element.emptyns
.1
1138 (let* ((name "sakjdhjhd")
1139 (uri "http://www.something.com/")
1140 (e (make-element name uri
)))
1141 (setf (namespace-uri e
) "")
1142 (assert-equal "" (namespace-uri e
))
1145 (deftest element.emptyns
.2
1146 (let* ((name "sakjdhjhd")
1147 (uri "http://www.something.com/")
1148 (e (make-element name uri
)))
1149 (serialize-to-string e
))
1150 "<sakjdhjhd xmlns=\"http://www.something.com/\"/>")
1152 (deftest element.emptyns
.3
1153 (let ((e (make-element "e")))
1154 (add-attribute e
(make-attribute "en"
1156 "http://www.w3.org/XML/1998/namespace"))
1157 (serialize-to-string e
))
1158 "<e xml:lang=\"en\"/>")
1160 (deftest element.doctype
1161 (let* ((name "sakjdhjhd")
1162 (uri "http://www.something.com/")
1163 (e (make-element name uri
)))
1164 (expect-condition (append-child e
(make-document-type name
)) stp-error
)
1167 (deftest element.xml-namespace
1168 (let* ((name "sakjdhjhd")
1169 (uri "http://www.something.com/")
1170 (e (make-element name uri
))
1171 (xml "http://www.w3.org/XML/1998/namespace"))
1172 (assert-equal xml
(find-namespace "xml" e
))
1173 (expect-condition (add-extra-namespace e
"xml" "http://www.yahoo.com/")
1175 (assert-equal xml
(find-namespace "xml" e
))
1176 (add-extra-namespace e
"xml" xml
)
1177 (assert-equal xml
(find-namespace "xml" e
))
1180 (deftest element.undeclare-default
1181 (let* ((name "red:sakjdhjhd")
1182 (uri "http://www.red.com/")
1183 (child (make-element name uri
))
1184 (parent (make-element "parent" "http://www.example.com/")))
1185 (assert-equal "http://www.example.com/" (find-namespace "" parent
))
1186 (append-child parent child
)
1187 (add-extra-namespace child
"" "")
1188 (assert-equal "" (find-namespace "" child
))
1189 (assert-equal "http://www.example.com/" (find-namespace "" parent
))
1190 (let ((child2 (make-element "name" "http://www.default.com")))
1191 (append-child parent child2
)
1192 (expect-condition (add-extra-namespace child2
"" "") stp-error
))
1195 (deftest element.setf-namespace-uri
.1
1196 (let* ((name "sakjdhjhd")
1197 (uri "http://www.red.com/")
1198 (element (make-element name uri
)))
1199 (add-attribute element
(make-attribute "test" "attribute"))
1200 (setf (namespace-uri element
) "")
1201 (assert-equal "" (find-namespace "" element
))
1204 (deftest element.setf-namespace-uri
.2
1205 (let* ((name "sakjdhjhd")
1206 (uri "http://www.red.com/")
1207 (element (make-element name uri
)))
1208 (add-attribute element
(make-attribute "test" "red:attribute" uri
))
1209 (setf (namespace-uri element
) uri
)
1210 (assert-equal uri
(namespace-uri element
))
1211 (assert-equal uri
(find-namespace "red" element
))
1214 (deftest element.setf-namespace-uri
.3
1216 (uri "http://www.w3.org/1999/xhtml")
1217 (element (make-element name
)))
1218 (add-attribute element
(make-attribute "http://www.elharo.com" "href"))
1219 (setf (namespace-uri element
) uri
)
1220 (assert-equal uri
(namespace-uri element
))
1223 (deftest element.setf-namespace-uri
.4
1225 (uri "http://www.w3.org/1999/xhtml")
1226 (element (make-element name
)))
1227 (add-attribute element
(make-attribute "http://www.elharo.com"
1230 (setf (namespace-uri element
) "http://www.example.com")
1231 (setf (namespace-prefix element
) "pre")
1232 (setf (namespace-uri element
) uri
)
1233 (setf (namespace-prefix element
) "html")
1234 (assert-equal uri
(namespace-uri element
))
1235 (assert-equal "html" (namespace-prefix element
))
1238 (deftest element.serialize
.1
1239 (let ((element (make-element "test")))
1240 (add-attribute element
1241 (make-attribute "preserve"
1243 "http://www.w3.org/XML/1998/namespace"))
1244 (add-attribute element
1245 (make-attribute "preserve"
1247 "http://www.example.org"))
1248 (serialize-to-string element
))
1249 "<test xmlns:zzz=\"http://www.example.org\" zzz:zzz=\"preserve\" xml:space=\"preserve\"/>")
1251 (deftest element.xml-prefix
1252 (let ((element (make-element "xml:test"
1253 "http://www.w3.org/XML/1998/namespace")))
1254 (map-extra-namespaces (lambda (k v
) (error "bogus extra namespace"))
1256 (assert-equal "<xml:test/>" (serialize-to-string element
))
1259 (deftest element.namespaces-mappings
1260 (let* ((name "red:sakjdhjhd")
1261 (uri "http://www.red.com/")
1262 (e (make-element name uri
)))
1263 (add-extra-namespace e
"blue" "http://www.blue.com/")
1264 (add-extra-namespace e
"green" "http://www.green.com/")
1265 (let ((a1 (make-attribute "test" "test"))
1266 (a2 (make-attribute "data" "pre1:green" "http://www.green.com/"))
1267 (a3 (make-attribute "data" "yellow:sfs" "http://www.yellow.com/")))
1268 (add-attribute e a1
)
1269 (add-attribute e a2
)
1270 (add-attribute e a3
))
1271 (assert-equal "http://www.red.com/" (find-namespace "red" e
))
1272 (assert-equal "http://www.green.com/" (find-namespace "green" e
))
1273 (assert-equal "http://www.blue.com/" (find-namespace "blue" e
))
1274 (assert-equal "http://www.green.com/" (find-namespace "pre1" e
))
1275 (assert-equal "http://www.yellow.com/" (find-namespace "yellow" e
))
1276 (let ((e2 (make-element "mauve:child" "http://www.mauve.com/")))
1278 (assert-equal "http://www.red.com/" (find-namespace "red" e2
))
1279 (assert-equal "http://www.green.com/" (find-namespace "green" e2
))
1280 (assert-equal "http://www.blue.com/" (find-namespace "blue" e2
))
1281 (assert-equal "http://www.green.com/" (find-namespace "pre1" e2
))
1282 (assert-equal "http://www.yellow.com/" (find-namespace "yellow" e2
))
1283 (assert-equal nil
(find-namespace "head" e2
)))
1284 (expect-condition (add-extra-namespace e
"pre1" "http://www.blue2.com")
1286 (let ((a (make-attribute "data" "pre1:mauve" "http://www.sadas.com/")))
1287 (expect-condition (add-attribute e a
) stp-error
))
1288 (let ((a (make-attribute "data" "pre1:green" "http://www.example.com/")))
1289 (expect-condition (add-attribute e a
) stp-error
))
1290 (remove-extra-namespace e
"green")
1291 (assert-equal nil
(find-namespace "green" e
))
1292 (add-extra-namespace e
"green" "http://www.green2.com/")
1293 (assert-equal "http://www.green2.com/" (find-namespace "green" e
))
1296 (deftest element.attributes
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 (assert-equal a2
(find-attribute-named e
"green" "http://www.green.com/"))
1305 (assert-equal a1
(find-attribute-named e
"name"))
1306 (assert-equal a1
(find-attribute-named e
"name" ""))
1307 (assert-equal e
(parent a1
))
1308 (assert-equal "simple" (value (find-attribute-named e
"name")))
1310 (assert-equal nil
(parent a1
))
1311 (assert-equal nil
(find-attribute-named e
"name"))
1312 (assert-equal a2
(remove-attribute e a2
))
1313 (assert-equal nil
(parent a2
))
1314 (assert-equal nil
(find-attribute-named e
"green" "http://www.green.com/"))
1317 (deftest element.remove-attribute
.1
1318 (let* ((name "red:sakjdhjhd")
1319 (uri "http://www.red.com/")
1320 (e (make-element name uri
))
1321 (a1 (make-attribute "simple" "name"))
1322 (a2 (make-attribute "data" "pre1:green" "http://www.green.com/")))
1323 (add-attribute e a1
)
1324 (add-attribute e a2
)
1325 (expect-condition (remove-attribute e nil
) type-error
)
1328 (deftest element.remove-attribute
.2
1329 (let* ((name "red:sakjdhjhd")
1330 (uri "http://www.red.com/")
1331 (e (make-element name uri
))
1332 (a (make-attribute "simple" "name")))
1333 (add-attribute e
(make-attribute "value" "name"))
1334 (expect-condition (remove-attribute e a
) stp-error
)
1337 (deftest element.string-value
1338 (let* ((name "red:sakjdhjhd")
1339 (uri "http://www.red.com/")
1340 (e (make-element name uri
)))
1341 (assert-equal (string-value e
) "")
1342 (append-child e
(make-text "data"))
1343 (assert-equal (string-value e
) "data")
1344 (append-child e
(make-text " moredata"))
1345 (assert-equal (string-value e
) "data moredata")
1346 (append-child e
(make-comment " more data"))
1347 (assert-equal (string-value e
) "data moredata")
1348 (append-child e
(make-processing-instruction "target" "more data"))
1349 (assert-equal (string-value e
) "data moredata")
1350 (let ((e2 (make-element "child")))
1352 (assert-equal (string-value e
) "data moredata")
1353 (append-child e2
(make-text "something"))
1354 (assert-equal (string-value e
) "data moredatasomething"))
1357 (deftest element.setf-local-name
1358 (let* ((name "red:sakjdhjhd")
1359 (uri "http://www.red.com/")
1360 (e (make-element name uri
)))
1361 (assert-equal (local-name e
) "sakjdhjhd")
1362 (dolist (x '("dude" "digits__" "digits1234" "digits-z"))
1363 (assert-equal x
(setf (local-name e
) x
))
1364 (assert-equal (local-name e
) x
))
1365 (expect-condition (setf (local-name e
) "spaces ") stp-error
)
1366 (expect-condition (setf (local-name e
) "digits:test") stp-error
)
1367 (expect-condition (setf (local-name e
) "digits!test") stp-error
)
1369 (setf (local-name e
) (format nil
"digits~Ctest" (code-char 0)))
1373 (deftest element.setf-namespace-prefix
1374 (let* ((name "red:sakjdhjhd")
1375 (uri "http://www.red.com/")
1376 (e (make-element name uri
)))
1377 (assert-equal (namespace-prefix e
) "red")
1378 (dolist (x '("dude" "digits__" "digits1234" "digits-z" ""))
1379 (assert-equal x
(setf (namespace-prefix e
) x
))
1380 (assert-equal (namespace-prefix e
) x
))
1381 (dolist (y '("spaces "
1384 #.
(format nil
"digits~Ctest" (code-char 0))))
1385 (expect-condition (setf (namespace-prefix e
) y
) stp-error
))
1388 (defparameter *legal-uris
*
1389 '("http://www.is.edu/sakdsk#sjadh"
1390 "http://www.is.edu/sakdsk?name=value&name=head"
1391 "uri:isbn:0832473864"
1392 "http://www.examples.com:80"
1393 "http://www.examples.com:80/"
1394 "http://www.is.edu/%20sakdsk#sjadh"))
1396 ;;; we don't actually check URI syntax, but we still have to prevent
1397 ;;; URIs from slipping in that aren't even make up of XML characters
1398 (defparameter *very-illegal-uris
*
1399 (list (string (code-char 0))
1400 (string (code-char 128))))
1402 (deftest element.setf-namespace-uri
.5
1404 (uri "http://www.w3.org/1999/xhtml")
1405 (element (make-element name uri
)))
1406 (assert-equal (namespace-uri element
) uri
)
1407 (dolist (legal *legal-uris
*)
1408 (setf (namespace-uri element
) legal
)
1409 (assert-equal (namespace-uri element
) legal
))
1410 (let ((prev (namespace-uri element
)))
1411 (dolist (illegal *very-illegal-uris
*)
1412 (expect-condition (setf (namespace-uri element
) illegal
) stp-error
))
1413 (assert-equal (namespace-uri element
) prev
))
1416 (deftest element.setf-namespace-uri
.6
1417 (let* ((name "red:sakjdhjhd")
1418 (uri "http://www.red.com/")
1419 (element (make-element name uri
)))
1420 (add-extra-namespace element
"red" "http://www.red.com/")
1421 (expect-condition (setf (namespace-uri element
) "http://www.example.com")
1425 (deftest element.setf-namespace-uri
.7
1426 (let* ((name "red:sakjdhjhd")
1427 (uri "http://www.red.com/")
1428 (element (make-element name uri
))
1429 (a (make-attribute "value" "red:test" "http://www.red.com/")))
1430 (add-attribute element a
)
1431 (expect-condition (setf (namespace-uri element
) "http://www.example.com")
1435 (deftest element.setf.namespace-uri
.8
1436 (let ((e (make-element "prefix:name" "http://www.foo.com/")))
1437 (expect-condition (setf (namespace-uri e
) "") stp-error
)
1438 (expect-condition (setf (namespace-uri e
) nil
) stp-error
)
1441 (deftest element.setf.namespace-prefix
.1
1442 (let* ((name "red:sakjdhjhd")
1443 (uri "http://www.red.com/")
1444 (element (make-element name uri
)))
1445 (add-extra-namespace element
"blue" "http://www.foo.com/")
1446 (add-attribute element
(make-attribute
1447 "value" "green:money" "http://www.example.com/"))
1448 (add-extra-namespace element
"purple" uri
)
1449 (add-attribute element
(make-attribute "value" "mauve:money" uri
))
1450 (expect-condition (setf (namespace-prefix element
) "blue")
1452 (expect-condition (setf (namespace-prefix element
) "green")
1454 (setf (namespace-prefix element
) "purple")
1455 (assert-equal "purple" (namespace-prefix element
))
1456 (setf (namespace-prefix element
) "mauve")
1457 (assert-equal "mauve" (namespace-prefix element
))
1460 (deftest element.setf.namespace-prefix
.2
1461 (let* ((name "red:sakjdhjhd")
1462 (uri "http://www.red.com/")
1463 (element (make-element name uri
)))
1464 (setf (namespace-prefix element
) nil
)
1465 (assert-equal "" (namespace-prefix element
))
1468 (deftest element.setf.namespace-prefix
.3
1469 (let ((element (make-element "sakjdhjhd")))
1470 (expect-condition (setf (namespace-prefix element
) "foo") stp-error
)
1473 (deftest element.add-extra-namespace
1474 (let* ((name "red:sakjdhjhd")
1475 (uri "http://www.red.com/")
1476 (element (make-element name uri
)))
1477 (dolist (legal *legal-uris
*)
1478 (remove-extra-namespace element
"prefix")
1479 (add-extra-namespace element
"prefix" legal
)
1480 (assert-equal legal
(find-namespace "prefix" element
)))
1481 (dolist (illegal *very-illegal-uris
*)
1482 (remove-extra-namespace element
"prefix")
1483 (expect-condition (add-extra-namespace element
"prefix" illegal
)
1487 (deftest element.add-extra-namespace
.2
1488 (let* ((name "red:sakjdhjhd")
1489 (uri "http://www.red.com/")
1490 (element (make-element name uri
)))
1491 (add-extra-namespace element
"xmlns" "")
1492 (remove-extra-namespace element
"xmlns")
1494 (add-extra-namespace element
"xmlns" "http://foo")
1498 (deftest element.add-extra-namespace
.3
1499 (let* ((name "red:sakjdhjhd")
1500 (uri "http://www.red.com/")
1501 (element (make-element name uri
)))
1502 (add-extra-namespace element
1504 "http://www.w3.org/XML/1998/namespace")
1505 (remove-extra-namespace element
"xml")
1507 (add-extra-namespace element
1509 "http://www.w3.org/XML/1998/namespace")
1513 (deftest element.add-extra-namespace
.4
1514 (let* ((name "red:sakjdhjhd")
1515 (uri "http://www.red.com/")
1516 (element (make-element name uri
)))
1517 (expect-condition (add-extra-namespace element
"foo" "hoppla") warning
)
1520 (deftest element.add-extra-namespace
.5
1521 (let* ((name "red:sakjdhjhd")
1522 (uri "http://www.red.com/")
1523 (element (make-element name uri
)))
1524 (add-extra-namespace element nil nil
)
1526 (map-extra-namespaces (lambda (prefix uri
)
1527 (assert-equal prefix
"")
1528 (assert-equal uri
"")
1531 (error "extra namespace not found"))
1534 (deftest element.add-extra-namespace
.6
1535 (let* ((name "red:sakjdhjhd")
1536 (uri "http://www.red.com/")
1537 (element (make-element name uri
)))
1539 (add-extra-namespace element
"foo" (string (code-char 0)))
1543 (deftest element.insert-child.nil
1544 (let* ((name "red:sakjdhjhd")
1545 (uri "http://www.red.com/")
1546 (element (make-element name uri
)))
1547 (expect-condition (insert-child element nil
0) error
)
1550 (deftest element.append-child.nil
1551 (let* ((name "red:sakjdhjhd")
1552 (uri "http://www.red.com/")
1553 (element (make-element name uri
)))
1554 (expect-condition (append-child element
0) error
)
1557 (deftest element.insert-child
.1
1558 (let* ((name "red:sakjdhjhd")
1559 (uri "http://www.red.com/")
1560 (e (make-element name uri
))
1561 (e2 (make-element "mv:child" "http://www.mauve.com"))
1562 (e3 (make-element "mv:child" "http://www.mauve.com"))
1563 (e4 (make-element "mv:child" "http://www.mauve.com")))
1564 (insert-child e e2
0)
1565 (insert-child e e3
0)
1566 (insert-child e3 e4
0)
1567 (assert-equal e3
(nth-child 0 e
))
1568 (let* ((root (make-element "root"))
1569 (doc (make-document root
)))
1570 (expect-condition (insert-child e doc
0) stp-error
))
1571 (expect-condition (insert-child e e2
0) stp-error
)
1572 (expect-condition (insert-child e e4
0) stp-error
)
1573 (expect-condition (insert-child e nil
0) error
)
1574 (expect-condition (insert-child e
(make-comment "test") 20) error
)
1575 (expect-condition (insert-child e
(make-comment "test") -
20) error
)
1578 (deftest element.filter-children
.1
1579 (with-element-test ()
1580 (let ((children (filter-children (alexandria:of-type
'element
) element
)))
1581 (assert-equal 3 (length children
))
1582 (assert-equal child1
(elt children
0))
1583 (assert-equal child4
(elt children
1))
1584 (assert-equal child5
(elt children
2)))
1585 (let ((children (filter-children (of-name "nonesuch") element
)))
1586 (assert-equal 0 (length children
)))
1587 (let ((children (filter-children (of-name "test") element
)))
1588 (assert-equal 1 (length children
))
1589 (assert-equal child1
(elt children
0)))
1591 (filter-children (of-name "test" "http://www.example.com")
1593 (assert-equal 2 (length children
))
1594 (assert-equal child4
(elt children
0))
1595 (assert-equal child5
(elt children
1)))
1598 (deftest element.add-attribute
.1
1599 (let ((element (make-element "name"))
1600 (a1 (make-attribute "name" "value"))
1601 (a2 (make-attribute "simple"
1603 "http://www.w3.org/TR/1999/xlink")))
1604 (add-attribute element a1
)
1605 (add-attribute element a2
)
1606 (assert-equal 2 (length (list-attributes element
)))
1607 (let ((element2 (make-element "name")))
1608 (expect-condition (add-attribute element2 a1
) stp-error
))
1610 (let ((funky (make-element "xlink:funky" "http://www.funky.org")))
1611 (expect-condition (add-attribute funky a2
) stp-error
))
1614 (make-element "prefix:funky" "http://www.w3.org/TR/1999/xlink")))
1615 (add-attribute notasfunky a2
))
1616 (let ((a3 (make-attribute "simple"
1618 "http://www.w3.org/TR/1999/xlink"))
1619 (a4 (make-attribute "simple"
1621 "http://www.w3.org/1998/xlink"))
1622 (test (make-element "test")))
1623 (add-attribute test a3
)
1624 (expect-condition (add-attribute test a4
) stp-error
))
1625 (let ((a5 (make-attribute "simple"
1627 "http://www.w3.org/TR/1999/xlink"))
1628 (a6 (make-attribute "simple"
1630 "http://www.w3.org/1998/xlink"))
1631 (test2 (make-element "test")))
1632 (add-attribute test2 a5
)
1633 (expect-condition (add-attribute test2 a6
) stp-error
))
1636 (deftest element.add-attribute
.2
1637 (let ((element (make-element "name")))
1638 (add-extra-namespace element
"xlink" "http://www.w3.org/TR/1999/xlink")
1639 (add-extra-namespace element
"pre" "http://www.example.com")
1640 (let ((a1 (make-attribute "values" "name"))
1641 (a2 (make-attribute "simple"
1643 "http://www.w3.org/TR/1999/xlink")))
1644 (add-attribute element a1
)
1645 (add-attribute element a2
)
1646 (assert-equal 2 (length (list-attributes element
))))
1648 (add-attribute element
1649 (make-attribute "value"
1651 "ftp://example.com/"))
1653 (add-attribute element
1654 (make-attribute "value"
1656 "ftp://example.com/"))
1657 (assert-equal 3 (length (list-attributes element
)))
1659 (add-extra-namespace element
"ok" "http://www.example.net")
1661 (assert-equal "ftp://example.com/" (find-namespace "ok" element
))
1662 (assert-equal "http://www.w3.org/TR/1999/xlink"
1663 (find-namespace "xlink" element
))
1664 (assert-equal "http://www.example.com" (find-namespace "pre" element
))
1667 (deftest element.add-attribute
.3
1668 (let ((element (make-element "pre:name" "http://www.example.com")))
1670 (setf (attribute-value element
"pre:a" "http://different") "value")
1674 (deftest element.add-attribute
.4
1675 (let ((element (make-element "pre:name" "http://www.example.com")))
1677 (add-attribute element
1678 (make-attribute"value" "pre:a" "http://different"))
1682 (deftest element.triple
1683 (serialize-to-string
1686 (cxml:parse
#1="<b><c1/><c2/></b>" (make-builder)))))
1689 (deftest element.copy
.1
1690 (let ((parent (make-element "parent"))
1691 (child (make-element "child")))
1692 (append-child parent child
)
1693 (assert-node= child
(copy child
))
1696 (deftest element.copy
.2
1697 (let ((parent (make-element "parent"))
1698 (child (make-element "child")))
1699 (append-child parent child
)
1700 (assert-node= parent
(copy parent
))
1703 (deftest element.copy
.3
1704 (let ((parent (make-element "parent"))
1705 (a (make-attribute "value" "name")))
1706 (add-attribute parent a
)
1707 (let ((copy (copy parent
)))
1708 (assert-node= parent copy
)
1709 (let ((copied (car (list-attributes copy
))))
1710 (assert-node= copied a
)
1711 (assert-equal copy
(parent copied
))))
1714 (deftest element.copy
.4
1715 (let ((parent (make-element "parent")))
1716 (assert-node= parent
(copy parent
))
1719 (deftest element.copy
.5
1720 (let* ((root (make-element "parent"))
1721 (d (make-document root
)))
1722 (assert-node= d
(copy d
))
1725 (deftest element.copy
.6
1726 (let* ((name "red:sakjdhjhd")
1727 (uri "http://www.red.com/")
1728 (base-uri "http://www.example.com/")
1729 (e (make-element name uri
)))
1730 (add-extra-namespace e
"blue" "http://www.blue.com")
1731 (add-extra-namespace e
"green" "http://www.green.com")
1732 (let ((a1 (make-attribute "test" "test"))
1733 (a2 (make-attribute "data" "pre1:green" "http://www.green.com"))
1734 (a3 (make-attribute "data"
1736 "http://www.yellow.com/")))
1737 (add-attribute e a1
)
1738 (add-attribute e a2
)
1739 (add-attribute e a3
))
1740 (append-child e
(make-element "mv:child" "http://www.mauve.com"))
1741 (let ((e3 (make-element "mv:child" "http://www.mauve.com")))
1742 (prepend-child e e3
)
1743 (append-child e3
(make-element "mv:child" "http://www.mauve.com")))
1744 (setf (base-uri e
) base-uri
)
1745 (let ((copy (copy e
)))
1746 (assert-equal (find-namespace "red" e
) (find-namespace "red" copy
))
1747 (assert-equal (find-namespace "blue" e
) (find-namespace "blue" copy
))
1748 (assert-equal (string-value e
) (string-value copy
))
1749 (let ((ea (find-attribute-named e
"test"))
1750 (ca (find-attribute-named copy
"test")))
1751 (assert-equal (value ea
) (value ca
)))
1752 (assert-equal (base-uri e
) (base-uri copy
)))
1755 (deftest element.copy
.7
1756 (let* ((top (make-element "e"))
1759 for parent
= top then child
1760 for i from
0 below
100
1761 for child
= (make-element (format nil
"e~D" i
))
1762 do
(append-child parent child
))
1763 (assert-node= top
(copy top
))
1766 (deftest element.delete-children
.1
1767 (let* ((name "red:sakjdhjhd")
1768 (uri "http://www.red.com/")
1769 (parent (make-element name uri
))
1770 (a1 (make-attribute "test" "test")))
1771 (add-attribute parent a1
)
1772 (let ((child1 (make-element "mv:child" "http://www.mauve.com"))
1773 (child2 (make-element "mv:child" "http://www.mauve.com"))
1774 (grandchild (make-element "mv:child" "http://www.mauve.com")))
1775 (append-child parent child1
)
1776 (append-child parent child2
)
1777 (append-child child2 grandchild
)
1778 (assert-equal child2
(parent grandchild
))
1779 (assert-equal parent
(parent child1
))
1780 (assert-equal parent
(parent child2
))
1781 (delete-children parent
)
1782 (assert-equal nil
(list-children parent
))
1783 (assert-equal nil
(parent child1
))
1784 (assert-equal nil
(parent child2
))
1785 (assert-equal child2
(parent grandchild
))
1786 (assert-equal parent
(parent a1
)))
1789 (deftest element.delete-children
.2
1790 (let ((base "http://www.example.com/")
1791 (parent (make-element "parent"))
1792 (child (make-element "child")))
1793 (setf (base-uri parent
) base
)
1794 (append-child parent child
)
1795 (delete-children parent
)
1796 (assert-equal base
(base-uri child
))
1799 (deftest element.delete-children
.3
1800 (let* ((name "red:sakjdhjhd")
1801 (uri "http://www.red.com/")
1802 (parent (make-element name uri
))
1803 (a1 (make-attribute "test" "test")))
1804 (add-attribute parent a1
)
1805 (let ((child1 (make-text "http://www.mauve.com"))
1806 (child2 (make-processing-instruction
1807 "child" "http://www.mauve.com"))
1808 (child3 (make-comment "http://www.mauve.com")))
1809 (append-child parent child1
)
1810 (append-child parent child2
)
1811 (append-child parent child3
)
1812 (assert-equal parent
(parent child3
))
1813 (assert-equal parent
(parent child1
))
1814 (assert-equal parent
(parent child2
))
1815 (delete-children parent
)
1816 (assert-equal nil
(list-children parent
))
1817 (assert-equal nil
(parent child1
))
1818 (assert-equal nil
(parent child2
))
1819 (assert-equal nil
(parent child3
))
1820 (assert-equal parent
(parent a1
))
1823 (deftest element.attribute-value
1824 (let* ((name "sakjdhjhd")
1825 (e (make-element name
)))
1826 (assert-equal nil
(attribute-value e
"test"))
1829 (attribute-value e
"base" "http://www.w3.org/XML/1998/namespace"))
1830 (add-attribute e
(make-attribute "value" "test"))
1831 (add-attribute e
(make-attribute
1832 "http://www.example.com/"
1834 "http://www.w3.org/XML/1998/namespace"))
1835 (assert-equal "value" (attribute-value e
"test"))
1837 "http://www.example.com/"
1838 (attribute-value e
"base" "http://www.w3.org/XML/1998/namespace"))
1839 ;; (assert-equal nil (attribute-value e "xml:base"))
1840 (assert-equal nil
(attribute-value e
"base"))
1843 (attribute-value e
"test" "http://www.w3.org/XML/1998/namespace"))
1846 (deftest element.setf.attribute-value
1847 (let* ((e (make-element "sakjdhjhd"))
1850 (add-attribute f
(make-attribute "1" "pre:foo" "http://pre"))
1851 (add-attribute g
(make-attribute "2" "pre:foo" "http://pre"))
1853 (setf (attribute-value e
"pre:foo" "http://pre") "1")
1855 ;; change existing attribute
1856 (setf (attribute-value e
"pre:foo" "http://pre") "2")
1860 (deftest element.setf.attribute-value
.2
1861 (let ((e (make-element "pre:sakjdhjhd" "http://pre")))
1862 (setf (attribute-value e
"pre:flubba") "value")
1863 (assert-equal (namespace-uri (car (list-attributes e
)))
1867 (deftest element.map-attributes
1868 (let* ((e (make-element "sakjdhjhd")))
1869 (add-attribute e
(make-attribute "1" "pre:foo" "http://pre"))
1870 (add-attribute e
(make-attribute "2" "pre:bar" "http://pre"))
1871 (assert-equal (list-attributes e
) (map-attributes 'list
#'identity e
))
1872 (assert-equal (mapcar #'qualified-name
(list-attributes e
))
1873 (map-attributes 'list
#'qualified-name e
))
1874 (assert (equalp (map 'vector
#'qualified-name
(list-attributes e
))
1875 (map-attributes 'vector
#'qualified-name e
)))
1878 (deftest element.with-attributes
1879 (let* ((e (make-element "sakjdhjhd")))
1880 (add-attribute e
(make-attribute "1" "pre:foo" "http://pre"))
1881 (add-attribute e
(make-attribute "2" "bar"))
1882 (add-attribute e
(make-attribute "gorilla" "ape"))
1883 (with-attributes ((foo "pre:foo" "http://pre")
1885 (baz "pre:baz" "http://pre")
1889 (setf foo
(format nil
"<~A>" foo
))
1890 (setf bar
(string #\newline
))
1891 (setf baz
"pre:xyz")
1892 (setf moose
"mangy")
1893 (assert-equal ape
"gorilla"))
1894 (assert-equal (attribute-value e
"foo" "http://pre") "<1>")
1895 (assert-equal (attribute-value e
"bar") (string #\newline
))
1896 (assert-equal (attribute-value e
"baz" "http://pre") "pre:xyz")
1897 (assert-equal (attribute-value e
"moose") "mangy")
1900 (deftest element.find-attribute-named
1901 (let* ((name "sakjdhjhd")
1902 (e (make-element name
)))
1903 (assert-equal nil
(find-attribute-named e
"test"))
1906 (find-attribute-named e
"base" "http://www.w3.org/XML/1998/namespace"))
1907 (let ((a1 (make-attribute "value" "test"))
1909 "http://www.example.com/"
1911 "http://www.w3.org/XML/1998/namespace")))
1912 (add-attribute e a1
)
1913 (add-attribute e a2
)
1914 (assert-equal a1
(find-attribute-named e
"test"))
1917 (find-attribute-named e
1919 "http://www.w3.org/XML/1998/namespace")))
1922 (deftest element.find-namespace.empty
.1
1923 (find-namespace "" (make-element "sakjdhjhd"))
1926 (deftest element.find-namespace.empty
.2
1927 (find-namespace nil
(make-element "sakjdhjhd"))
1930 (deftest element.namespace-prefix
.1
1931 (namespace-prefix (make-element "html"))
1934 (deftest element.namespace-prefix
.2
1935 (let ((test (make-element
1937 "http://www.w3.org/XML/1998/namespace")))
1938 (assert-equal "xml" (namespace-prefix test
))
1939 (assert-equal "http://www.w3.org/XML/1998/namespace"
1940 (namespace-uri test
))
1941 (assert-equal "xml:base" (qualified-name test
))
1944 (define-condition-test element.namespace-prefix
.3
1945 (make-element "xml:base" "http://www.example.org/")
1948 (define-condition-test element.namespace-prefix
.4
1949 (make-element "test:base" "http://www.w3.org/XML/1998/namespace")
1952 (define-condition-test element.name
.1
1956 (define-condition-test element.name
.2
1957 (make-element "1Kelvin")
1960 (define-condition-test element.name
.3
1964 (deftest element.print-object
1965 (let* ((name "red:sakjdhjhd")
1966 (uri "http://www.red.com/")
1967 (base-uri "http://www.example.com/")
1968 (e (make-element name uri
)))
1969 (add-extra-namespace e
"blue" "http://www.blue.com")
1970 (add-extra-namespace e
"green" "http://www.green.com")
1971 (let ((a1 (make-attribute "test" "test"))
1972 (a2 (make-attribute "data" "pre1:green" "http://www.green.com"))
1973 (a3 (make-attribute "data"
1975 "http://www.yellow.com/")))
1976 (add-attribute e a1
)
1977 (add-attribute e a2
)
1978 (add-attribute e a3
))
1979 (append-child e
(make-element "mv:child" "http://www.mauve.com"))
1980 (let ((e3 (make-element "mv:child" "http://www.mauve.com")))
1981 (prepend-child e e3
)
1982 (append-child e3
(make-element "mv:child" "http://www.mauve.com")))
1983 (setf (base-uri e
) base-uri
)
1984 (assert-node= e
(read-from-string (write-to-string e
)))
1987 (deftest element.map-extra-namespaces
1988 (let* ((name "red:sakjdhjhd")
1989 (uri "http://www.red.com/")
1990 (blue "http://www.blue.com")
1991 (green "http://www.green.com")
1992 (e (make-element name uri
)))
1993 (add-extra-namespace e
"blue" blue
)
1994 (add-extra-namespace e
"green" green
)
1995 (setf (attribute-value e
"pre1:green" green
) "data")
1998 (map-extra-namespaces
1999 (lambda (prefix uri
)
2001 ((equal prefix
"blue")
2002 (assert (not bluep
))
2004 (assert-equal uri blue
))
2005 ((equal prefix
"green")
2006 (assert (not greenp
))
2008 (assert-equal uri green
))
2010 (error "bogus namespace"))))
2014 (deftest element.base-uri
2015 (let* ((root (make-element "root"))
2016 (child (make-element "child"))
2017 (document (make-document root
)))
2018 (append-child root child
)
2019 (assert-equal (base-uri document
) "")
2020 (setf (base-uri root
) "file://etc")
2021 (setf (base-uri child
) "passwd")
2022 (assert (puri:uri
= (puri:parse-uri
"file://etc/passwd")
2026 (deftest element.root
2027 (let* ((de (make-element "root"))
2028 (child (make-element "child")))
2029 (append-child de child
)
2030 (assert-equal de
(root child
))
2031 (assert-equal de
(root de
))
2032 (let ((document (make-document de
)))
2033 (assert-equal document
(root de
))
2034 (assert-equal document
(root child
))
2035 (assert-equal document
(root document
)))
2041 (defmacro with-ATTRIBUTE-test
((&optional
) &body body
)
2042 `(let* ((a1 (make-attribute "value" "test"))
2043 (a2 (make-attribute " value " "test")))
2046 (deftest attribute.count-children
2047 (with-attribute-test ()
2051 (define-condition-test attribute.nth-child
2052 (with-attribute-test ()
2056 (deftest attribute.make-attribute
2057 (with-attribute-test ()
2058 (assert-equal "test" (local-name a1
))
2059 (assert-equal "test" (qualified-name a1
))
2060 (assert-equal "" (namespace-prefix a1
))
2061 (assert-equal "" (namespace-uri a1
))
2062 (assert-equal "value" (value a1
))
2063 (assert-equal " value " (value a2
))
2066 (deftest attribute.setf.local-name
2067 (let ((a (make-attribute "value" "name")))
2068 (setf (local-name a
) "newname")
2069 (assert-equal "newname" (local-name a
))
2070 (expect-condition (setf (local-name a
) "pre:a") stp-error
)
2073 (deftest attribute.setf.local-name
.2
2074 (let ((a (make-attribute "value" "pre:name" "http://www.example.org")))
2075 (setf (local-name a
) "newname")
2076 (assert-equal "newname" (local-name a
))
2077 (assert-equal "pre:newname" (qualified-name a
))
2080 (define-condition-test attribute.xmlns
.1
2081 (make-attribute "http://www.w3.org/TR" "xmlns")
2084 (define-condition-test attribute.xmlns
.2
2085 (make-attribute "http://www.w3.org/TR" "xmlns:prefix")
2088 (define-condition-test attribute.xmlns
.3
2089 (make-attribute "http://www.w3.org/"
2091 "http://www.w3.org/2000/xmlns/")
2094 (define-condition-test attribute.xmlns
.4
2095 (make-attribute "http://www.w3.org/"
2097 "http://www.w3.org/2000/xmlns/")
2100 (deftest attribute.xml-base
2101 (let* ((xml-namespace "http://www.w3.org/XML/1998/namespace")
2102 (a1 (make-attribute "http://www.w3.org/" "xml:base" xml-namespace
)))
2103 (assert-equal "base" (local-name a1
))
2104 (assert-equal "xml:base" (qualified-name a1
))
2105 (assert-equal xml-namespace
(namespace-uri a1
))
2106 (dolist (str '("http://www.example.com/>"
2107 "http://www.example.com/<"
2108 #.
(format nil
"http://www.example.com/~C"
2109 (code-char #x00FE
))))
2110 (setf (value a1
) str
)
2111 (assert-equal (value a1
) str
))
2114 (deftest attribute.xml-prefix
2116 (expect-condition (make-attribute "http://www.w3.org/" "xml:base")
2118 (expect-condition (make-attribute "preserve" "xml:space")
2120 (expect-condition (make-attribute "fr-FR" "xml:lang")
2122 (let* ((xml-namespace "http://www.w3.org/XML/1998/namespace")
2123 (a1 (make-attribute "http://www.w3.org/"
2126 (assert-equal "base" (local-name a1
))
2127 (assert-equal "xml:base" (qualified-name a1
))
2128 (assert-equal xml-namespace
(namespace-uri a1
))
2129 (let ((a2 (make-attribute "preserve"
2132 (assert-equal "space" (local-name a2
))
2133 (assert-equal "xml:space" (qualified-name a2
))
2134 (assert-equal xml-namespace
(namespace-uri a2
)))
2135 (let ((a3 (make-attribute "en-UK"
2138 (assert-equal "lang" (local-name a3
))
2139 (assert-equal "xml:lang" (qualified-name a3
))
2140 (assert-equal xml-namespace
(namespace-uri a3
)))
2142 (make-attribute "http://www.w3.org/"
2144 "http://www.notTheXMLNamespace")
2148 (deftest attribute.xml-lang
2149 (let* ((xml-namespace "http://www.w3.org/XML/1998/namespace")
2150 (a1 (make-attribute "" "xml:lang" xml-namespace
)))
2151 (assert-equal "" (value a1
))
2154 (define-condition-test attribute.xml-uri
2155 (make-attribute "value" "test:base" "http://www.w3.org/XML/1998/namespace")
2158 (deftest attribute.serialize
.1
2159 (let ((e (make-element "test")))
2160 (add-attribute e
(make-attribute "<" "a1"))
2161 (add-attribute e
(make-attribute ">" "a2"))
2162 (add-attribute e
(make-attribute "\"" "a3"))
2163 (add-attribute e
(make-attribute "'" "a4"))
2164 (add-attribute e
(make-attribute "&" "a5"))
2165 (serialize-to-string e
))
2166 "<test a5=\"&\" a4=\"'\" a3=\""\" a2=\">\" a1=\"<\"/>")
2168 (deftest attribute.serialize
.2
2169 (let ((e (make-element "test")))
2170 (add-attribute e
(make-attribute (string (code-char 32)) "a1"))
2171 (add-attribute e
(make-attribute (string (code-char 10)) "a2"))
2172 (add-attribute e
(make-attribute (string (code-char 13)) "a3"))
2173 (add-attribute e
(make-attribute (string (code-char 9)) "a4"))
2174 (serialize-to-string e
))
2175 "<test a4=\"	\" a3=\" \" a2=\" \" a1=\" \"/>")
2177 (deftest attribute.serialize
.3
2178 (let ((e (make-element "test")))
2179 (add-attribute e
(make-attribute "=,.!@#$%^*()_-'[]{}+/?;:`|\\" "a"))
2180 (serialize-to-string e
))
2181 "<test a=\"=,.!@#$%^*()_-'[]{}+/?;:`|\\\"/>")
2183 (deftest attribute.setf.value
2184 (let ((a (make-attribute "test" "test")))
2185 (dolist (legal '("Hello"
2187 " spaces on both ends "
2188 " quotes \" \" quotes"
2189 " single \'\' quotes"
2190 " both double and single \"\'\"\' quotes"
2191 " angle brackets < > <<<"
2192 " carriage returns \r\r\r"
2193 " ampersands & &&& &name; "))
2194 (setf (value a
) legal
)
2195 (assert-equal (value a
) legal
))
2196 (expect-condition (setf (value a
) (string (code-char 0))) stp-error
)
2199 (deftest attribute.names
2200 (let* ((prefix "testPrefix")
2202 (uri "http://www.elharo.com/")
2203 (value " here's some data")
2204 (qname (concatenate 'string prefix
":" name
))
2205 (a1 (make-attribute value qname uri
)))
2206 (assert-equal name
(local-name a1
))
2207 (assert-equal qname
(qualified-name a1
))
2208 (assert-equal uri
(namespace-uri a1
))
2211 (deftest attribute.copy
.1
2212 (let* ((c1 (make-attribute "data" "test"))
2214 (assert-equal (value c1
) (value c2
))
2215 (assert-equal (local-name c1
) (local-name c2
))
2216 (assert-equal (qualified-name c1
) (qualified-name c2
))
2217 (assert (not (eql c1 c2
)))
2218 (assert-equal nil
(parent c2
))
2221 ;;; fixme: testSurrogates
2223 (deftest attribute.rename-attribute
.1
2224 (let ((a (make-attribute "data" "red:prefix" "http://www.example.com")))
2225 (rename-attribute a nil nil
)
2226 (assert-equal "" (namespace-uri a
))
2227 (assert-equal "" (namespace-prefix a
))
2230 (deftest attribute.rename-attribute
.2
2231 (let ((a (make-attribute "data" "red:prefix" "http://www.example.com"))
2232 (e (make-element "pre:test" "http://www.example.org/")))
2234 (rename-attribute a
"pre" "http://www.example.org/")
2235 (assert-equal "http://www.example.org/" (namespace-uri a
))
2236 (assert-equal "pre" (namespace-prefix a
))
2237 (assert-equal "http://www.example.org/" (namespace-uri e
))
2238 (assert-equal "pre" (namespace-prefix e
))
2241 (deftest attribute.rename-attribute
.3
2242 (let* ((name "red:sakjdhjhd")
2243 (uri "http://www.red.com/")
2245 (a (make-attribute "" name uri
)))
2246 (assert-equal uri
(namespace-uri a
))
2247 (dolist (legal *legal-uris
*)
2248 (rename-attribute a prefix legal
)
2249 (assert-equal legal
(namespace-uri a
)))
2250 (dolist (illegal *very-illegal-uris
*)
2251 (expect-condition (rename-attribute a prefix illegal
) stp-error
))
2254 (deftest attribute.rename-attribute
.4
2255 (let ((a (make-attribute "value" "name")))
2256 (expect-condition (rename-attribute a
"pre" "") stp-error
)
2257 (expect-condition (rename-attribute a
"" "http://www.example.com")
2261 (deftest attribute.rename-attribute
.5
2262 (let ((element (make-element "test"))
2263 (a (make-attribute "bar" "pre:foo" "http://pre.com"))
2264 (b (make-attribute "bar" "post:bar" "http://post.com")))
2265 (add-attribute element a
)
2266 (add-attribute element b
)
2267 (expect-condition (rename-attribute b
"pre" "http://post.com")
2271 (deftest attribute.node-properties
2272 (let ((a (make-attribute "data" "test")))
2273 (assert-equal nil
(parent a
))
2274 (let ((element (make-element "test")))
2275 (add-attribute element a
)
2276 (assert-equal element
(parent a
))
2277 (assert-equal a
(find-attribute-named element
"test"))
2278 (remove-attribute element a
)
2279 (assert-equal nil
(find-attribute-named element
"test")))
2282 (deftest attribute.constraints
2283 (let ((element (make-element "test"))
2284 (a1 (make-attribute "valueFoo" "foo:data" "http://www.example.com"))
2285 (a2 (make-attribute "valueBar" "bar:data" "http://www.example.com"))
2286 (a3 (make-attribute "valueFoo" "data"))
2287 (a4 (make-attribute "valueBar" "data")))
2288 ;; add initial attribute
2289 (add-attribute element a1
)
2290 (assert-equal "valueFoo"
2291 (attribute-value element
"data" "http://www.example.com"))
2292 (assert-equal (list a1
) (list-attributes element
))
2294 (add-attribute element a2
)
2295 (assert-equal "valueBar"
2296 (attribute-value element
"data" "http://www.example.com"))
2297 (assert-equal (list a2
) (list-attributes element
))
2298 ;; add a different one
2299 (add-attribute element a3
)
2300 (assert-equal "valueFoo" (attribute-value element
"data"))
2301 (assert-equal "valueBar"
2302 (attribute-value element
"data" "http://www.example.com"))
2303 (assert-equal 2 (length (list-attributes element
)))
2305 (add-attribute element a4
)
2306 (assert-equal "valueBar" (attribute-value element
"data"))
2307 (assert-equal "valueBar"
2308 (attribute-value element
"data" "http://www.example.com"))
2309 (assert-equal 2 (length (list-attributes element
)))
2311 (let ((a5 (make-attribute "valueRed" "red:ab" "http://www.example.org"))
2313 "valueGreen" "green:cd" "http://www.example.org")))
2314 (add-attribute element a5
)
2315 (add-attribute element a6
)
2316 (assert-equal "valueRed"
2317 (attribute-value element
"ab" "http://www.example.org"))
2318 (assert-equal "valueGreen"
2319 (attribute-value element
"cd" "http://www.example.org")))
2322 (deftest attribute.double-add
2323 (let ((element (make-element "test"))
2324 (a (make-attribute "bar" "foo")))
2325 (add-attribute element a
)
2326 (remove-attribute element a
)
2327 (let ((copy (copy element
)))
2328 (add-attribute copy
(make-attribute "newvalue" "a"))
2329 (assert-equal 1 (length (list-attributes copy
))))
2332 (deftest attribute.string-value
2333 (string-value (make-attribute "bar" "foo"))
2336 (define-condition-test attribute.serialize
2337 (serialize (make-attribute "bar" "foo") nil
)
2340 (deftest attribute.print-object
2341 (let ((a (make-attribute "bar" "pre:foo" "http://uri")))
2342 (assert-node= a
(read-from-string (write-to-string a
)))
2348 (defmacro with-parent-node-test
((&optional
) &body body
)
2349 `(let* ((empty (make-element "empty"))
2350 (not-empty (make-element "not-empty"))
2351 (child (make-comment "Hello")))
2352 (append-child not-empty child
)
2355 (deftest parent-node.detach
2356 (with-parent-node-test ()
2357 (let ((text (make-text "This will be attached then detached")))
2358 (append-child empty text
)
2359 (assert-equal empty
(parent text
))
2361 (assert-equal nil
(parent text
))
2364 (deftest parent-node.append-child
2365 (with-parent-node-test ()
2366 (let ((child (make-element "test")))
2367 (append-child empty child
)
2368 (assert-equal (parent child
) empty
)
2369 (assert-equal (list-children empty
) (list child
))
2371 (append-child not-empty child
)
2372 (assert (not (eql (nth-child 0 not-empty
) child
)))
2373 (assert-equal (nth-child 1 not-empty
) child
)
2376 (define-condition-test parent-node.append-child
.2
2377 (let ((child (make-element "test")))
2378 (append-child child child
))
2381 (deftest parent-node.append-child
.3
2382 (let ((a (make-element "test"))
2383 (b (make-element "test")))
2385 (expect-condition (append-child b a
) stp-error
)
2388 (deftest parent-node.insert-child
2389 (let ((parent (make-element "parent"))
2390 (child1 (make-element "child"))
2391 (child2 (make-element "child2"))
2392 (child3 (make-element "child3"))
2393 (child4 (make-element "child4"))
2394 (child5 (make-element "child5")))
2396 (insert-child parent child1
0)
2397 (assert (plusp (child-count parent
)))
2398 (assert-equal 0 (child-position child1 parent
))
2400 (insert-child parent child2
0)
2401 (assert-equal 0 (child-position child2 parent
))
2402 (assert-equal 1 (child-position child1 parent
))
2404 (insert-child parent child3
1)
2405 (assert-equal 0 (child-position child2 parent
))
2406 (assert-equal 1 (child-position child3 parent
))
2407 (assert-equal 2 (child-position child1 parent
))
2408 ;; at beginning with children
2409 (insert-child parent child4
0)
2410 (assert-equal 0 (child-position child4 parent
))
2411 (assert-equal 1 (child-position child2 parent
))
2412 (assert-equal 2 (child-position child3 parent
))
2413 (assert-equal 3 (child-position child1 parent
))
2414 ;; at end with children
2415 (insert-child parent child5
4)
2416 (assert-equal 0 (child-position child4 parent
))
2417 (assert-equal 1 (child-position child2 parent
))
2418 (assert-equal 2 (child-position child3 parent
))
2419 (assert-equal 3 (child-position child1 parent
))
2420 (assert-equal 4 (child-position child5 parent
))
2422 (expect-condition (insert-child parent nil
0) error
)
2425 (define-condition-test parent-node.append-child
.4
2426 (with-parent-node-test ()
2427 (append-child empty
(make-document not-empty
)))
2430 (define-condition-test parent-node.append-child
.5
2431 (with-parent-node-test ()
2432 (append-child empty child
))
2435 (deftest parent-node.replace-child
2436 (with-parent-node-test ()
2437 (let ((old1 (make-element "old1"))
2438 (old2 (make-element "old2"))
2439 (old3 (make-element "old3"))
2440 (new1 (make-element "new1"))
2441 (new2 (make-element "new2"))
2442 (new3 (make-element "new3")))
2443 (append-child empty old1
)
2444 (append-child empty old2
)
2445 (append-child empty old3
)
2446 (replace-child empty old1 new1
)
2447 (replace-child empty old3 new3
)
2448 (replace-child empty old2 new2
)
2449 (assert-equal (list new1 new2 new3
) (list-children empty
))
2450 (expect-condition (replace-child empty new1 nil
) error
)
2451 (expect-condition (replace-child empty old1 nil
) error
)
2452 (let ((new4 (make-element "new4")))
2453 (expect-condition (replace-child empty new4
(make-element "test"))
2455 (replace-child empty new1 new1
)
2456 (assert-equal new1
(nth-child 0 empty
))
2457 (assert-equal empty
(parent new1
))
2458 (expect-condition (replace-child empty new1 new2
) stp-error
))
2461 (deftest parent-node.child-position
2462 (with-parent-node-test ()
2463 (let ((child1 (make-element "old1"))
2464 (child2 (make-text "old2"))
2465 (child3 (make-comment "old3")))
2466 (assert-equal nil
(child-position child1 empty
))
2467 (append-child empty child1
)
2468 (append-child empty child2
)
2469 (append-child empty child3
)
2470 (assert-equal 0 (child-position child1 empty
))
2471 (assert-equal 1 (child-position child2 empty
))
2472 (assert-equal 2 (child-position child3 empty
))
2473 (assert-equal nil
(child-position empty empty
))
2474 (assert-equal nil
(child-position (make-text "test") empty
)))
2477 (deftest parent-node.nth-child
2478 (with-parent-node-test ()
2479 (let ((old1 (make-element "old1"))
2480 (old2 (make-element "old2"))
2481 (old3 (make-comment "old3")))
2482 (expect-condition (nth-child 0 empty
) error
)
2483 (append-child empty old1
)
2484 (append-child empty old2
)
2485 (append-child empty old3
)
2486 (assert-equal old1
(nth-child 0 empty
))
2487 (assert-equal old2
(nth-child 1 empty
))
2488 (assert-equal old3
(nth-child 2 empty
))
2489 (expect-condition (nth-child 5 empty
) error
))
2492 (deftest parent-node.delete-child
2493 (with-parent-node-test ()
2494 (expect-condition (delete-nth-child 0 empty
) error
)
2495 (let ((old1 (make-element "old1"))
2496 (old2 (make-element "old2"))
2497 (old3 (make-element "old3")))
2498 (expect-condition (delete-child old1 empty
) error
)
2499 (append-child empty old1
)
2500 (append-child empty old2
)
2501 (append-child empty old3
)
2502 (delete-nth-child 1 empty
)
2503 (assert-equal old1
(nth-child 0 empty
))
2504 (assert-equal old3
(nth-child 1 empty
))
2505 (delete-nth-child 1 empty
)
2506 (delete-nth-child 0 empty
)
2507 (assert-equal nil
(parent old2
))
2508 (assert-equal nil
(list-children empty
))
2509 (append-child empty old1
)
2510 (append-child empty old2
)
2511 (append-child empty old3
)
2512 (assert-equal (list old1 old2 old3
) (list-children empty
))
2513 (delete-child old3 empty
)
2514 (delete-child old1 empty
)
2515 (delete-child old2 empty
)
2516 (assert-equal nil
(list-children empty
))
2517 (assert-equal nil
(parent old1
)))
2520 (deftest parent-node.replace-child
.2
2521 (with-parent-node-test ()
2522 (let ((old1 (make-element "old1"))
2523 (old2 (make-element "old2"))
2524 (old3 (make-element "old3"))
2525 (new1 (make-element "new1"))
2526 (new3 (make-element "new3")))
2527 (append-child empty old1
)
2528 (append-child empty old2
)
2529 (expect-condition (replace-child empty old3 new3
) stp-error
)
2530 (expect-condition (replace-child empty old1 nil
) error
)
2531 (expect-condition (replace-child empty nil new1
) error
))
2534 (deftest parent-node.replace-child
.3
2535 (with-parent-node-test ()
2536 (let ((test1 (make-element "test1"))
2537 (test2 (make-element "test2")))
2538 (expect-condition (replace-child empty test1 test2
) stp-error
))
2541 (deftest parent-node.replace-child
.4
2542 (with-parent-node-test ()
2543 (let ((parent (make-element "parent"))
2544 (test1 (make-element "test1"))
2545 (test2 (make-element "test2")))
2546 (append-child parent test1
)
2547 (append-child parent test2
)
2548 (expect-condition (replace-child parent test1 test2
) stp-error
)
2549 (assert-equal (list test1 test2
) (list-children parent
)))
2552 (deftest parent-node.insert-child
.2
2553 (with-parent-node-test ()
2554 (let ((parent (make-element "parent"))
2555 (test1 (make-element "test1"))
2556 (test2 (make-element "test2")))
2557 (append-child parent test1
)
2558 (append-child parent test2
)
2559 (expect-condition (insert-child parent test2
0) stp-error
)
2560 (expect-condition (insert-child parent test2
1) stp-error
)
2561 (assert-equal (list test1 test2
) (list-children parent
)))
2564 (deftest parent-node.replace-child
.4
2565 (with-parent-node-test ()
2566 (let ((parent (make-element "parent"))
2567 (child (make-element "child")))
2568 (append-child parent child
)
2570 (replace-child parent child
(make-document-type "root"))
2572 (let ((e (make-element "e"))
2573 (child2 (make-text "child2")))
2574 (append-child e child2
)
2575 (expect-condition (replace-child parent child child2
) stp-error
)))
2578 (deftest node.insert-child-before
.1
2579 (let ((parent (make-element "parent"))
2580 (a (make-element "child"))
2581 (b (make-text "text"))
2582 (new1 (make-text "new"))
2583 (new2 (make-text "new2")))
2584 (expect-condition (insert-child-before parent new1 a
) stp-error
)
2585 (expect-condition (insert-child-before parent new2 b
) stp-error
)
2586 (append-child parent a
)
2587 (append-child parent b
)
2588 (insert-child-before parent new1 a
)
2589 (insert-child-before parent new2 b
)
2590 (assert-equal (list new1 a new2 b
) (list-children parent
))
2593 (deftest node.insert-child-after
.1
2594 (let ((parent (make-element "parent"))
2595 (a (make-element "child"))
2596 (b (make-text "text"))
2597 (new1 (make-text "new1"))
2598 (new2 (make-text "new2")))
2599 (expect-condition (insert-child-after parent new1 a
) stp-error
)
2600 (expect-condition (insert-child-after parent new2 b
) stp-error
)
2601 (append-child parent a
)
2602 (append-child parent b
)
2603 (insert-child-after parent new1 a
)
2604 (insert-child-after parent new2 b
)
2605 (assert-equal (list a new1 b new2
) (list-children parent
))
2612 (deftest node.first-child
.1
2613 (let ((parent (make-element "parent"))
2614 (a (make-element "child"))
2615 (b (make-text "text")))
2616 (assert-equal nil
(first-child parent
))
2617 (append-child parent a
)
2618 (append-child parent b
)
2619 (assert-equal a
(first-child parent
))
2622 (assert-equal nil
(first-child parent
))
2625 (deftest node.last-child
.1
2626 (let ((parent (make-element "parent"))
2627 (a (make-element "child"))
2628 (b (make-text "text")))
2629 (assert-equal nil
(last-child parent
))
2630 (append-child parent a
)
2631 (append-child parent b
)
2632 (assert-equal b
(last-child parent
))
2635 (assert-equal nil
(last-child parent
))
2638 (deftest node.previous-sibling
.1
2639 (let ((parent (make-element "parent"))
2640 (a (make-element "child"))
2641 (b (make-text "text")))
2642 (expect-condition (previous-sibling a
) stp-error
)
2643 (expect-condition (previous-sibling b
) stp-error
)
2644 (append-child parent a
)
2645 (append-child parent b
)
2646 (expect-condition (previous-sibling a
) stp-error
)
2647 (assert-equal a
(previous-sibling b
))
2650 (deftest node.next-sibling
.1
2651 (let ((parent (make-element "parent"))
2652 (a (make-element "child"))
2653 (b (make-text "text")))
2654 (expect-condition (next-sibling a
) stp-error
)
2655 (expect-condition (next-sibling b
) stp-error
)
2656 (append-child parent a
)
2657 (append-child parent b
)
2658 (assert-equal b
(next-sibling a
))
2659 (expect-condition (next-sibling b
) stp-error
)
2662 (defmacro with-sequence-test
((&optional
) &body body
)
2663 `(let ((e (make-element "test"))
2664 (a (make-element "a"))
2665 (a2 (make-element "a"))
2666 (b (make-element "b"))
2667 (s (make-text "foo"))
2668 (x (make-element "x")))
2669 (declare (ignorable x
))
2676 (defun maybe-local-name (x)
2678 (element (local-name x
))
2681 (deftest node.count-children
.0
2682 (with-sequence-test ()
2683 (count-children x e
))
2686 (deftest node.count-children
.1
2687 (with-sequence-test ()
2688 (count-children a e
))
2691 (deftest node.count-children
.2
2692 (with-sequence-test ()
2693 (count-children a e
:test
#'eql
))
2696 (deftest node.count-children
.3
2697 (with-sequence-test ()
2698 (count-children a e
:test
'eql
))
2701 (deftest node.count-children
.4
2702 (with-sequence-test ()
2703 (count-children "a" e
:key
#'maybe-local-name
:test
#'equal
))
2706 (deftest node.count-children
.5
2707 (with-sequence-test ()
2708 (count-children "a" e
:key
'maybe-local-name
:test
'equal
))
2711 (deftest node.count-children
.6
2712 (with-sequence-test ()
2713 (count-children (copy-seq "a") e
:key
'maybe-local-name
))
2716 (deftest node.count-children
.7
2717 (with-sequence-test ()
2718 (count-children a e
:from-end t
))
2721 (deftest node.count-children
.8
2723 (with-sequence-test ()
2725 (count-children a e
:key
(lambda (c) (push c seen
) c
))
2726 (assert-equal seen
(list s b a2 a
)))))
2729 (deftest node.count-children
.9
2731 (with-sequence-test ()
2733 (count-children a e
:from-end t
:key
(lambda (c) (push c seen
) c
))
2734 (assert-equal seen
(list a a2 b s
)))))
2737 (deftest node.count-children
.10
2738 (with-sequence-test ()
2741 :key
'maybe-local-name
2746 (deftest node.count-children
.11
2747 (with-sequence-test ()
2750 :key
'maybe-local-name
2755 (deftest node.count-children
.12
2756 (with-sequence-test ()
2759 :key
'maybe-local-name
2764 (deftest node.count-children
.13
2765 (with-sequence-test ()
2768 :key
'maybe-local-name
2774 (deftest node.count-children
.14
2775 (with-sequence-test ()
2776 (count-children "a" e
:key
'maybe-local-name
:test
'equal
:end nil
))
2779 (deftest node.count-children
.15
2780 (with-sequence-test ()
2781 (count-children "a" e
:test
(constantly t
) :start
1))
2784 (deftest node.count-children-if
.1
2785 (with-sequence-test ()
2786 (count-children-if #'identity e
))
2789 (deftest node.count-children-if
.2
2790 (with-sequence-test ()
2791 (count-children-if (alexandria:of-type
'element
) e
))
2794 (deftest node.count-children-if
.3
2795 (with-sequence-test ()
2796 (count-children-if #'break a
))
2799 (deftest node.count-children-if
.4
2800 (with-sequence-test ()
2801 (count-children-if (lambda (x) (equal x
"a"))
2803 :key
'maybe-local-name
))
2806 (deftest node.count-children-if
.5
2807 (with-sequence-test ()
2808 (count-children-if 'identity e
:key
'identity
))
2811 (deftest node.count-children-if
.8
2812 (count-if #'identity
'(a b nil c d nil e
) :key
'not
)
2815 (deftest node.count-children-if
.9
2816 (count-if #'evenp
'(1 2 3 4 4 1 8 10 1))
2819 (deftest node.count-children-if
.10
2820 (count-if #'evenp
'(1 2 3 4 4 1 8 10 1) :key
#'1+)
2823 (deftest node.count-children-if
.11
2825 (with-sequence-test ()
2827 (count-children-if (constantly t
)
2829 :key
(lambda (c) (push c seen
) c
))
2830 (assert-equal seen
(list b a2 a
)))))
2833 (deftest node.count-children-if
.12
2835 (with-sequence-test ()
2837 (count-children-if (constantly t
)
2840 :key
(lambda (c) (push c seen
) c
))
2841 (assert-equal seen
(list a a2 b
)))))
2844 (deftest node.count-children-if
.10
2845 (with-sequence-test ()
2846 (count-children-if (lambda (x) (equal x
"a"))
2848 :key
'maybe-local-name
2852 (deftest node.count-children-if
.11
2853 (with-sequence-test ()
2854 (count-children-if (lambda (x) (equal x
"a"))
2856 :key
'maybe-local-name
2860 (deftest node.count-children-if
.12
2861 (with-sequence-test ()
2862 (count-children-if (lambda (x) (equal x
"a"))
2864 :key
'maybe-local-name
2868 (deftest node.count-children-if
.13
2869 (with-sequence-test ()
2870 (count-children-if (lambda (x) (equal x
"a"))
2872 :key
'maybe-local-name
2877 ;;;; FIXME: find-child-if, child-position, filter-children
2879 (deftest node.map-recursively
.1
2880 (let* ((root (make-element "foo"))
2881 (child (make-element "bar"))
2882 (text (make-text "bla"))
2883 (document (make-document root
)))
2884 (setf (attribute-value child
"ignoreme") "value")
2885 (append-child root child
)
2886 (append-child root text
)
2889 (map-recursively (lambda (x) (push x seen
)) document
)
2891 (list document root child text
))
2894 (deftest node.do-recursively
.1
2895 (let* ((root (make-element "foo"))
2896 (child (make-element "bar"))
2897 (text (make-text "bla"))
2898 (document (make-document root
)))
2899 (setf (attribute-value child
"ignoreme") "value")
2900 (append-child root child
)
2901 (append-child root text
)
2904 (do-recursively (x document
(nreverse seen
))
2906 (list document root child text
))
2909 (deftest node.find-recursively
.1
2910 (let* ((root (make-element "foo"))
2911 (child (make-element "bar"))
2912 (text (make-text "bla"))
2913 (document (make-document root
)))
2914 (setf (attribute-value child
"ignoreme") "value")
2915 (append-child root child
)
2916 (append-child root text
)
2917 (assert-equal (find-recursively 'text document
:key
#'type-of
)
2919 (assert-equal (find-recursively "element"
2926 (deftest node.filter-recursively
.1
2927 (let* ((root (make-element "foo"))
2928 (child (make-element "bar"))
2929 (text (make-text "bla"))
2930 (document (make-document root
)))
2931 (setf (attribute-value child
"ignoreme") "value")
2932 (append-child root child
)
2933 (append-child root text
)
2934 (assert-equal (filter-recursively (lambda (x) (eq x
'text
))
2938 (assert-equal (filter-recursively (lambda (x) (string-equal x
"element"))
2947 ;;;; the XML Test suite is a good test for the builder, so we need only few
2950 (deftest builder.extra-namespaces
2951 (serialize-to-string
2953 (cxml:parse
#1="<b xmlns:extra=\"http://because-it.s-extra/\"/>"
2960 ;; next: testRemoveNonElementChildren