;; core-tests.scm: test procedures for SDOM core ;; Copyright (C) 2007 Julian Graham ;; SDOM is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2 of the License, or ;; (at your option) any later version. ;; ;; SDOM is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with SDOM; if not, write to the Free Software ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ;;@PRELUDE@ (define xmlns "http://www.w3.org/XML/1998/namespace") (define xhtmlns "http://www.w3.org/1999/xhtml") (define domns "http://www.w3.org/DOM") (define hc-staff (sdom:xml->sdom (open-input-file "test-xml/hc_staff.xml") '())) (define hc-nodtd-staff (sdom:xml->sdom (open-input-file "test-xml/hc_nodtdstaff.xml") '())) (define barfoo (sdom:xml->sdom (open-input-file "test-xml/barfoo.xml") '())) (define barfoo-base (sdom:xml->sdom (open-input-file "test-xml/barfoo_base.xml") '())) (define barfoo-nodefaultns (sdom:xml->sdom (open-input-file "test-xml/barfoo_nodefaultns.xml") '())) (define test-error-handler (lambda err (throw #t "test-error-handler invoked!"))) (define attrisid-1 (lambda () (let* ((hc-staff-dom (sdom:clone-node hc-staff #t)) (elem-list (sdom:get-elements-by-tag-name hc-staff-dom "acronym")) (acronym-elem (list-ref elem-list 0)) (attr (sdom:get-attribute-node acronym-elem "title"))) (if (sdom:get-dom-property attr "sdom:is-id") (throw #t "attr is not id!") #t)))) (define attrisid-2 (lambda () (let* ((hc-staff-dom (sdom:clone-node hc-staff #t)) (elem-list (sdom:get-elements-by-tag-name hc-staff-dom "acronym")) (acronym-elem (list-ref elem-list 0))) (sdom:set-attribute! acronym-elem "xml:lang" "FR-fr" xmlns) (sdom:set-id-attribute! acronym-elem "lang" #t xmlns) (let ((attr (sdom:get-attribute-node acronym-elem "lang" xmlns))) (if (not (sdom:get-dom-property attr "sdom:is-id")) (throw #t "attr is id!") #t))))) (define attrisid-3 (lambda () (let* ((hc-staff-dom (sdom:clone-node hc-staff #t)) (elem-list (sdom:get-elements-by-tag-name hc-staff-dom "acronym")) (acronym-elem (list-ref elem-list 0))) (sdom:set-attribute! acronym-elem "xml:lang" "FR-fr" xmlns) (sdom:set-id-attribute! acronym-elem "lang" #f xmlns) (let ((attr (sdom:get-attribute-node acronym-elem "lang" xmlns))) (if (sdom:get-dom-property attr "sdom:is-id") (throw #t "attr is not id!") #t))))) (define attrisid-6 (lambda () (let* ((hc-staff-dom (sdom:clone-node hc-staff #t)) (attr (sdom:create-node hc-staff-dom sdom:node-type-attr "xml:lang" xmlns))) (if (sdom:get-dom-property attr "sdom:is-id") (throw #t "attr is not id!") #t)))) (define attrisid-7 (lambda () (let* ((hc-staff-dom (sdom:clone-node hc-staff #t)) (elt-lst (sdom:get-elements-by-tag-name hc-staff-dom "acronym" "*")) (acronym-elem (list-ref elt-lst 0))) (sdom:set-attribute! acronym-elem "dom3:newAttr" "null" domns) (sdom:set-id-attribute! acronym-elem "newAttr" #t domns) (let ((attr (sdom:get-attribute-node acronym-elem "newAttr" domns))) (if (not (sdom:get-dom-property attr "sdom:is-id")) (throw #t "attr is id!") (let ((imported-attr (sdom:import-node hc-staff-dom attr #f))) (if (sdom:get-dom-property imported-attr "sdom:is-id") (throw #t "attr is not id!") #t))))))) (define canonicalform-1 (lambda () (let* ((barfoo-dom (sdom:clone-node barfoo #t)) (p-list (sdom:get-elements-by-tag-name barfoo-dom "p")) (p-elem (list-ref p-list 0)) (entref (sdom:create-node barfoo-dom sdom:node-type-entity-reference "ent1"))) (sdom:set-dom-config-parameter! barfoo-dom "canonical-form" #t) (sdom:append-child! p-elem entref) (sdom:normalize-document! barfoo-dom) (let* ((p-list (sdom:get-elements-by-tag-name barfoo-dom "p")) (p-elem (list-ref p-list 0)) (child (sdom:get-dom-property p-elem "sdom:last-child"))) (if (null? child) (throw #t "last child should not be null after normalization")) (if (not (equal? (sdom:get-dom-property child "sdom:node-name") "#text")) (throw #t "first child name should be #text after normalization")) (if (not (equal? (sdom:get-dom-property child "sdom:node-value") "barfoo")) (throw #t "first child value should barfoo after normalization") #t))))) (define canonicalform-2 (lambda () (let* ((barfoo-dom (sdom:clone-node barfoo #t)) (p-list (sdom:get-elements-by-tag-name barfoo-dom "p")) (p-elem (list-ref p-list 0)) (text (sdom:create-node barfoo-dom sdom:node-type-text "suc on"))) (sdom:set-dom-config-parameter! barfoo-dom "canonical-form" #t) (sdom:append-child! p-elem text) (sdom:normalize-document! barfoo-dom) (let* ((p-list (sdom:get-elements-by-tag-name barfoo-dom "p")) (p-elem (list-ref p-list 0)) (child (sdom:get-dom-property p-elem "sdom:last-child"))) (if (not (equal? (sdom:get-dom-property child "sdom:node-value") "barsuc on")) (throw #t "no character normalization under canonical form") #t))))) (define canonicalform-3 (lambda () (let* ((hc-staff-dom (sdom:clone-node hc-staff #t))) (sdom:set-dom-config-parameter! hc-staff-dom "canonical-form" #t) (sdom:normalize-document! hc-staff-dom) (let* ((elem-list (sdom:get-elements-by-tag-name hc-staff-dom "strong")) (elem-name (list-ref elem-list 1)) (text (sdom:get-dom-property elem-name "sdom:last-child"))) (if (not (equal? (sdom:get-dom-property text "sdom:node-name") "#text")) (throw #t "cdata sections should be removed during canonicalization") #t))))) (define canonicalform-4 (lambda () (let* ((barfoo-dom (sdom:clone-node barfoo #t))) (sdom:set-dom-config-parameter! barfoo-dom "canonical-form" #t) (sdom:normalize-document! barfoo-dom) (let* ((doc-elem (sdom:get-dom-property barfoo-dom "sdom:document-element")) (xmlns-attr (sdom:get-attribute-node doc-elem "xmlns"))) (if (null? xmlns-attr) (throw #t "xmlns should be set on document element") #t))))) (define cdatasections-1 (lambda () (let* ((barfoo-dom (sdom:clone-node barfoo #t)) (elem-list (sdom:get-elements-by-tag-name barfoo-dom "p")) (new-cdata (sdom:create-node barfoo-dom sdom:node-type-cdata-section "CDATA"))) (sdom:append-child! (list-ref elem-list 0) new-cdata) (sdom:set-dom-config-parameter! barfoo-dom "cdata-sections" #f) (sdom:set-dom-config-parameter! barfoo-dom "error-handler" test-error-handler) (sdom:normalize! barfoo-dom) (let* ((elem-list (sdom:get-elements-by-tag-name barfoo-dom "p")) (cdata (sdom:get-dom-property (list-ref elem-list 0) "sdom:last-child"))) (if (not (equal? (sdom:get-dom-property cdata "sdom:node-name") "#cdata-section")) (throw #t "cdata section should be named \"#cdata-section\"") #t))))) (define comments-1 (lambda () (let* ((barfoo-dom (sdom:clone-node barfoo #t)) (elem-list (sdom:get-elements-by-tag-name barfoo-dom "p")) (comment (sdom:create-node barfoo-dom sdom:node-type-comment "COMMENT_NODE"))) (sdom:append-child! (list-ref elem-list 0) comment) (sdom:set-dom-config-parameter! barfoo-dom "cdata-sections" #f) (sdom:set-dom-config-parameter! barfoo-dom "error-handler" test-error-handler) (sdom:normalize! barfoo-dom) (let* ((elem-list (sdom:get-elements-by-tag-name barfoo-dom "p")) (cdata (sdom:get-dom-property (list-ref elem-list 0) "sdom:last-child"))) (if (not (equal? (sdom:get-dom-property cdata "sdom:node-name") "#comment")) (throw #t "cdata section should be named \"#comment\"") #t))))) (define documentadoptnode-3 (lambda () (let* ((hc-staff-dom (sdom:clone-node hc-staff #t)) (attr (sdom:create-node hc-staff-dom sdom:node-type-attr "xml:lang" xmlns))) (sdom:adopt-node! hc-staff-dom attr) (cond ((not (equal? (sdom:get-dom-property attr "sdom:node-name") "xml:lang")) (throw #t "attr name should be \"xml:lang\"")) ((not (equal? (sdom:get-dom-property attr "sdom:namespace-uri") xmlns)) (throw #t "attr namespace-uri should be xmlns")) ((not (equal? (sdom:get-dom-property attr "sdom:prefix") "xml")) (throw #t "attr prefix should be \"xml\"")) ((sdom:get-dom-property attr "sdom:owner-element") (throw #t "attr owner-element should be null")) ((not (sdom:get-dom-property attr "sdom:specified")) (throw #t "attr should be specified"))) #t))) (define documentadoptnode-4 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (doc-elem (sdom:get-dom-property doc "sdom:document-element")) (root-name (sdom:get-dom-property doc-elem "sdom:tag-name")) (root-ns (sdom:get-dom-property doc-elem "sdom:namespace-uri")) (new-doc (sdom:create-document root-name '() root-ns)) (attr (sdom:create-node doc sdom:node-type-attr "xml:lang" xmlns))) (sdom:adopt-node! new-doc attr) (cond ((not (equal? (sdom:get-dom-property attr "sdom:node-name") "xml:lang")) (throw #t "attr name should be \"xml:lang\"")) ((not (equal? (sdom:get-dom-property attr "sdom:namespace-uri") xmlns)) (throw #t "attr namespace-uri should be xmlns")) ((not (equal? (sdom:get-dom-property attr "sdom:prefix") "xml")) (throw #t "attr prefix should be \"xml\"")) ((sdom:get-dom-property attr "sdom:owner-element") (throw #t "attr owner-element should be null")) ((not (sdom:get-dom-property attr "sdom:specified")) (throw #t "attr should be specified"))) #t))) (define documentadoptnode-7 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (success #f)) (sdom:catch 'sdom:exception (lambda () (sdom:adopt-node! doc doc)) (lambda exn (if (and (not (null? (cdr exn))) (eqv? (cadr exn) sdom:exception-code-not-supported-err)) (set! success #t)))) (if (not success) (throw #t "adopting self as node should not be supported!") #t)))) (define documentadoptnode-8 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (doc-elem (sdom:get-dom-property doc "sdom:document-element")) (root-name (sdom:get-dom-property doc-elem "sdom:tag-name")) (root-ns (sdom:get-dom-property doc-elem "sdom:namespace-uri")) (new-doc (sdom:create-document root-name '() root-ns)) (success #f)) (sdom:catch 'sdom:exception (lambda () (sdom:adopt-node! doc new-doc)) (lambda exn (if (and (not (null? (cdr exn))) (eqv? (cadr exn) sdom:exception-code-not-supported-err)) (set! success #t)))) (if (not success) (throw #t "document adoption should not be supported!") #t)))) (define documentadoptnode-9 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (doc-elem (sdom:get-dom-property doc "sdom:document-element")) (root-name (sdom:get-dom-property doc-elem "sdom:tag-name")) (root-ns (sdom:get-dom-property doc-elem "sdom:namespace-uri")) (new-doc (sdom:create-document root-name '() root-ns)) (success #f)) (sdom:catch 'sdom:exception (lambda () (sdom:adopt-node! new-doc doc)) (lambda exn (if (and (not (null? (cdr exn))) (eqv? (cadr exn) sdom:exception-code-not-supported-err)) (set! success #t)))) (if (not success) (throw #t "document adoption should not be supported!") #t)))) (define documentadoptnode-11 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (doc-elem (sdom:get-dom-property doc "sdom:document-element")) (root-name (sdom:get-dom-property doc-elem "sdom:tag-name")) (doc-type (sdom:create-document-type root-name '() '())) (success #f)) (sdom:catch 'sdom:exception (lambda () (sdom:adopt-node! doc doc-type)) (lambda exn (if (and (not (null? (cdr exn))) (eqv? (cadr exn) sdom:exception-code-not-supported-err)) (set! success #t)))) (if (not success) (throw #t "document type adoption should not be supported!") #t)))) (define documentadoptnode-12 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (doc-elem (sdom:get-dom-property doc "sdom:document-element")) (root-name (sdom:get-dom-property doc-elem "sdom:tag-name")) (root-ns (sdom:get-dom-property doc-elem "sdom:namespace-uri")) (doc-type (sdom:create-document-type root-name '() '())) (new-doc (sdom:create-document root-name doc-type root-ns)) (success #f)) (sdom:catch 'sdom:exception (lambda () (sdom:adopt-node! new-doc doc-type)) (lambda exn (if (and (not (null? (cdr exn))) (eqv? (cadr exn) sdom:exception-code-not-supported-err)) (set! success #t)))) (if (not success) (throw #t "document type adoption should not be supported!") #t)))) (define documentadoptnode-13 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (doc-frag (sdom:create-node doc sdom:node-type-document-fragment)) (child-list (sdom:get-elements-by-tag-name doc "acronym")) (acronym-node (list-ref child-list 0))) (sdom:append-child! doc-frag acronym-node) (sdom:adopt-node! doc doc-frag) (if (not (sdom:has-child-nodes? doc-frag)) (throw #t "document fragment children should be adopted recursively") #t)))) (define documentadoptnode-14 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (doc-elem (sdom:get-dom-property doc "sdom:document-element")) (root-name (sdom:get-dom-property doc-elem "sdom:tag-name")) (root-ns (sdom:get-dom-property doc-elem "sdom:namespace-uri")) (new-doc (sdom:create-document root-name '() root-ns)) (doc-frag (sdom:create-node new-doc sdom:node-type-document-fragment)) (imported (sdom:import-node new-doc doc-elem #t)) (doc-elem (sdom:get-dom-property new-doc "sdom:document-element"))) (sdom:append-child! doc-elem imported) (sdom:append-child! doc-frag (list-ref (sdom:get-elements-by-tag-name new-doc "acronym") 0)) (sdom:adopt-node! new-doc doc-frag) (if (not (sdom:has-child-nodes? doc-frag)) (throw #t "document fragment children should be adopted recursively") #t)))) (define documentadoptnode-15 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (doc-frag (sdom:create-node doc sdom:node-type-document-fragment))) (sdom:adopt-node! doc doc-frag) (if (sdom:has-child-nodes? doc-frag) (throw #t "newly-created document fragment should have no children") #t)))) (define documentadoptnode-21 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (child-list (sdom:get-elements-by-tag-name doc "acronym")) (attr (sdom:get-attribute-node (list-ref child-list 0) "title"))) (sdom:adopt-node! doc attr) (if (not (equal? (sdom:get-dom-property attr "sdom:node-name") "title")) (throw #t "node adoption should preserve node-name")) (if (not (eqv? (sdom:get-dom-property attr "sdom:node-type") 2)) (throw #t "node adoption should preserve node-type")) (if (not (equal? (sdom:get-dom-property attr "sdom:node-value") "Yes")) (throw #t "node adoption should preserve node-value")) (if (sdom:get-dom-property attr "sdom:owner-element") (throw #t "owner-element should be null for newly-adopted nodes")) #t))) (define documentadoptnode-22 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (doc-elem (sdom:get-dom-property doc "sdom:document-element")) (adopted-node (sdom:adopt-node! doc doc-elem))) (if (not (sdom:has-child-nodes? adopted-node)) (throw #t "children of adopted node should be recursively adopted")) (if (not (equal? (sdom:get-dom-property doc-elem "sdom:node-name") (sdom:get-dom-property adopted-node "sdom:node-name"))) (throw #t "node adoption should preserve node-name")) #t))) (define documentadoptnode-23 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (child-list (sdom:get-elements-by-tag-name doc "acronym")) (acronym-elem (list-ref child-list 0)) (adopted-node (sdom:adopt-node! doc acronym-elem))) (if (not (eqv? (length (sdom:get-dom-property acronym-elem "sdom:child-nodes")) (length (sdom:get-dom-property adopted-node "sdom:child-nodes")))) (throw #t "node adoption should preserve number of child nodes") #t)))) (define documentadoptnode-24 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (new-doc (sdom:create-document "dom:test" '() "http://www.w3.org/DOM/Test")) (child-list (sdom:get-elements-by-tag-name doc "code" "*")) (code-elem (list-ref child-list 0)) (adopted-node (sdom:adopt-node! new-doc code-elem))) (if (not (eqv? (length (sdom:get-dom-property code-elem "sdom:child-nodes")) (length (sdom:get-dom-property adopted-node "sdom:child-nodes")))) (throw #t "node adoption should preserve number of nodes") #t)))) (define documentadoptnode-25 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (doc-elem (sdom:get-dom-property doc "sdom:document-element")) (root-ns (sdom:get-dom-property doc-elem "sdom:namespace-uri")) (root-name (sdom:get-dom-property doc-elem "sdom:tag-name")) (new-elem (sdom:create-node doc sdom:node-type-element "th" "http://www.w3.org/1999/xhtml")) (new-doc (sdom:create-document root-name '() root-ns)) (adopted-node (sdom:adopt-node! new-doc new-elem))) (if (not (equal? "th" (sdom:get-dom-property adopted-node "sdom:node-name"))) (throw #t "node adoption should preserve node-name")) (if (not (equal? "http://www.w3.org/1999/xhtml" (sdom:get-dom-property adopted-node "sdom:namespace-uri"))) (throw #t "node adoption should preserve namespace-uri") #t)))) (define documentadoptnode-26 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (doc-elem (sdom:get-dom-property doc "sdom:document-element")) (root-ns (sdom:get-dom-property doc-elem "sdom:namespace-uri")) (root-tagname (sdom:get-dom-property doc-elem "sdom:tag-name")) (new-doc (sdom:create-document root-tagname '() root-ns)) (new-elem (sdom:create-node new-doc sdom:node-type-element "head" "http://www.w3.org/1999/xhtml"))) (sdom:set-attribute! doc-elem "xml:lang" "en-US" xmlns) (let* ((doc-elem (sdom:get-dom-property new-doc "sdom:document-element")) (appended-child (sdom:append-child! doc-elem new-elem)) (adopted-node (sdom:adopt-node! doc new-elem))) (if (not (equal? (sdom:get-dom-property adopted-node "sdom:node-name") "head")) (throw #t "node adoption should preserve node-name")) (if (not (equal? (sdom:get-dom-property adopted-node "sdom:namespace-uri") xhtmlns)) (throw #t "node adoption should preserve namespace-uri") #t))))) (define documentadoptnode-27 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (doc-elem (sdom:get-dom-property doc "sdom:document-element")) (root-ns (sdom:get-dom-property doc-elem "sdom:namespace-uri")) (root-tagname (sdom:get-dom-property doc-elem "sdom:tag-name")) (new-doc (sdom:create-document root-tagname '() root-ns)) (new-elem (sdom:create-node new-doc sdom:node-type-element "xhtml:head" xhtmlns))) (sdom:set-attribute! new-elem "xml:lang" "en-US" xmlns) (let* ((doc-elem (sdom:get-dom-property new-doc "sdom:document-element")) (appended-child (sdom:append-child! doc-elem new-elem)) (new-imp-elem (sdom:import-node doc new-elem #t)) (adopted-node (sdom:adopt-node! doc new-imp-elem))) (if (not (equal? (sdom:get-dom-property adopted-node "sdom:node-name") "xhtml:head")) (throw #t "node adoption should preserve node-name")) (if (not (equal? (sdom:get-dom-property adopted-node "sdom:namespace-uri") xhtmlns)) (throw #t "node adoption should preserve namespace-uri") #t))))) (define documentadoptnode-30 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (new-text (sdom:create-node doc sdom:node-type-text "sdom:adopt-node! test for a TEXT_NODE")) (adopted-text (sdom:adopt-node! doc new-text))) (if (not (equal? (sdom:get-dom-property adopted-text "sdom:node-value") "sdom:adopt-node! test for a TEXT_NODE")) (throw #t "node adoption should preserve text node value") #t)))) (define documentadoptnode-31 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (doc-elem (sdom:get-dom-property doc "sdom:document-element")) (root-name (sdom:get-dom-property doc-elem "sdom:tag-name")) (root-ns (sdom:get-dom-property doc-elem "sdom:namespace-uri")) (new-doc (sdom:create-document root-name '() root-ns)) (new-text (sdom:create-node new-doc sdom:node-type-text "new sdom:adopt-node! test for a TEXT_NODE")) (adopted-text (sdom:adopt-node! doc new-text))) (if (not (equal? (sdom:get-dom-property adopted-text "sdom:node-value") "new sdom:adopt-node! test for a TEXT_NODE")) (throw #t "node adoption should preserve text node value") #t)))) (define documentadoptnode-32 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (doc-adopter (sdom:clone-node hc-staff #t)) (new-cdata (sdom:create-node doc sdom:node-type-cdata-section "sdom:adopt-node! test for a CDATASECTION_NODE")) (adopted-cdata (sdom:adopt-node! doc-adopter new-cdata))) (if (not (equal? (sdom:get-dom-property adopted-cdata "sdom:node-value") "sdom:adopt-node! test for a CDATASECTION_NODE")) (throw #t "node adoption should preserve cdata section value") #t)))) (define documentadoptnode-33 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (doc-elem (sdom:get-dom-property doc "sdom:document-element")) (root-ns (sdom:get-dom-property doc-elem "sdom:namespace-uri")) (root-name (sdom:get-dom-property doc-elem "sdom:tag-name")) (new-doc (sdom:create-document root-name '() root-ns)) (new-cdata (sdom:create-node new-doc sdom:node-type-cdata-section "sdom:adopt-node! test for a CDATASECTION_NODE")) (adopted-cdata (sdom:adopt-node! doc new-cdata))) (if (not (equal? (sdom:get-dom-property adopted-cdata "sdom:node-value") "sdom:adopt-node! test for a CDATASECTION_NODE")) (throw #t "node adoption should preserve cdata section value") #t)))) (define documentadoptnode-34 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (doc-elem (sdom:get-dom-property doc "sdom:document-element")) (root-ns (sdom:get-dom-property doc-elem "sdom:namespace-uri")) (root-name (sdom:get-dom-property doc-elem "sdom:tag-name")) (new-doc (sdom:create-document root-name '() root-ns)) (new-comment (sdom:create-node new-doc sdom:node-type-comment "sdom:adopt-node! test for a COMMENT_NODE")) (adopted-comment (sdom:adopt-node! new-doc new-comment))) (if (not (equal? (sdom:get-dom-property adopted-comment "sdom:node-value") "sdom:adopt-node! test for a COMMENT_NODE")) (throw #t "node adoption should preserve comment value") #t)))) (define documentadoptnode-35 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (doc-elem (sdom:get-dom-property doc "sdom:document-element")) (root-ns (sdom:get-dom-property doc-elem "sdom:namespace-uri")) (root-name (sdom:get-dom-property doc-elem "sdom:tag-name")) (new-doc (sdom:create-document root-name '() root-ns)) (new-pi (sdom:create-node new-doc sdom:node-type-processing-instruction "PITarget" "PIData")) (adopted-pi (sdom:adopt-node! doc new-pi))) (if (not (equal? (sdom:get-dom-property adopted-pi "sdom:target") "PITarget")) (throw #t "node adoption should preserve PI target")) (if (not (equal? (sdom:get-dom-property adopted-pi "sdom:data") "PIData")) (throw #t "node adoption should preserve PI data") #t)))) (define documentadoptnode-36 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (doc-elem (sdom:get-dom-property doc "sdom:document-element")) (root-ns (sdom:get-dom-property doc-elem "sdom:namespace-uri")) (root-name (sdom:get-dom-property doc-elem "sdom:node-name")) (new-doc (sdom:create-document root-name '() root-ns)) (new-pi-1 (sdom:create-node new-doc sdom:node-type-processing-instruction "PITarget" "PIData")) (new-pi-2 (sdom:create-node doc sdom:node-type-processing-instruction "PITarget" "PIData")) (adopted-pi-1 (sdom:adopt-node! new-doc new-pi-1)) (adopted-pi-2 (sdom:adopt-node! new-doc new-pi-2))) (if (or (not (equal? (sdom:get-dom-property adopted-pi-1 "sdom:target") "PITarget")) (not (equal? (sdom:get-dom-property adopted-pi-2 "sdom:target") "PITarget"))) (throw #t "node adoption should preserve PI target")) (if (or (not (equal? (sdom:get-dom-property adopted-pi-1 "sdom:data") "PIData")) (not (equal? (sdom:get-dom-property adopted-pi-2 "sdom:data") "PIData"))) (throw #t "node adoption should preserve PI data") #t)))) (define documentgetstricterrorchecking-1 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (strict (sdom:get-dom-config-parameter doc "strict-error-checking"))) (if (not strict) (throw #t "error checking should be strict by default") #t)))) (define documentgetstricterrorchecking-2 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (doc-elem (sdom:get-dom-property doc "sdom:document-element")) (root-ns (sdom:get-dom-property doc "sdom:namespace-uri")) (root-name (sdom:get-dom-property doc-elem "sdom:tag-name")) (new-doc (sdom:create-document root-name '() root-ns)) (strict (sdom:get-dom-config-parameter new-doc "strict-error-checking"))) (if (not strict) (throw #t "error checking should be strict for new documents") #t)))) (define documentnormalizedocument-1 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (doc-elem (sdom:get-dom-property doc "sdom:document-element")) (orig-node-name (sdom:get-dom-property doc-elem "sdom:node-name")) (found-error #f)) (sdom:set-dom-config-parameter! doc "error-handler" (lambda err (set! found-error #t))) (sdom:normalize-document! doc) (if found-error (throw #t "error during document normalization")) (let* ((doc-elem (sdom:get-dom-property doc "sdom:document-element")) (node-name (sdom:get-dom-property doc-elem "sdom:node-name"))) (if (not (equal? orig-node-name node-name)) (throw #t "document normalization should not affect node name") #t))))) (define documentnormalizedocument-3 (lambda () (let* ((doc (sdom:clone-node barfoo #t)) (p-list (sdom:get-elements-by-tag-name doc "p")) (elem (list-ref p-list 0)) (new-cdata (sdom:create-node doc sdom:node-type-cdata-section "CDATA")) (appended-child (sdom:append-child! elem new-cdata)) (found-error #f)) (sdom:set-dom-config-parameter! doc "cdata-sections" #t) (sdom:set-dom-config-parameter! doc "error-handler" (lambda err (set! found-error #t))) (sdom:normalize-document! doc) (if found-error (throw #t "error during document normalization")) (let* ((p-list (sdom:get-elements-by-tag-name doc "p")) (elem (list-ref p-list 0)) (cdata (sdom:get-dom-property elem "sdom:last-child")) (node-name (sdom:get-dom-property cdata "sdom:node-name"))) (if (not (equal? node-name "#cdata-section")) (throw #t "document normalization should preserve cdata sections")) (sdom:set-dom-config-parameter! doc "cdata-sections" #f) (sdom:normalize-document! doc) (if found-error (throw #t "error during document normalization")) (let* ((p-list (sdom:get-elements-by-tag-name doc "p")) (elem (list-ref p-list 0)) (text (sdom:get-dom-property elem "sdom:last-child")) (node-name (sdom:get-dom-property text "sdom:node-name"))) (if (not (equal? node-name "#text")) (throw #t "document normalization should convert cdata sections")) (let* ((node-value (sdom:get-dom-property text "sdom:node-value"))) (if (not (equal? node-value "barCDATA")) (throw #t "cdata section content should be converted") #t))))))) (define documentnormalizedocument-4 (lambda () (let* ((doc (sdom:clone-node barfoo #t)) (p-list (sdom:get-elements-by-tag-name doc "p")) (elem (list-ref p-list 0)) (new-comment (sdom:create-node doc sdom:node-type-comment "COMMENT_NODE")) (appended-child (sdom:append-child! elem new-comment)) (found-error #f)) (sdom:set-dom-config-parameter! doc "comments" #t) (sdom:set-dom-config-parameter! doc "error-handler" (lambda err (set! found-error #t))) (sdom:normalize-document! doc) (if found-error (throw #t "error during document normalization")) (let* ((p-list (sdom:get-elements-by-tag-name doc "p")) (elem (list-ref p-list 0)) (last-child (sdom:get-dom-property elem "sdom:last-child")) (node-name (sdom:get-dom-property last-child "sdom:node-name"))) (if (not (equal? node-name "#comment")) (throw #t "document normalization should preserve comments")) (sdom:set-dom-config-parameter! doc "comments" #f) (sdom:normalize-document! doc) (if found-error (throw #t "error during document normalization")) (let* ((p-list (sdom:get-elements-by-tag-name doc "p")) (elem (list-ref p-list 0)) (last-child (sdom:get-dom-property elem "sdom:last-child")) (node-name (sdom:get-dom-property last-child "sdom:node-name"))) (if (not (equal? node-name "#text")) (throw #t "document normalization should remove comments") #t)))))) (define documentnormalizedocument-8 (lambda () (let* ((doc (sdom:clone-node barfoo #t)) (elem-list (sdom:get-elements-by-tag-name doc "p")) (elem (list-ref elem-list 0)) (new-child (sdom:create-node doc sdom:node-type-cdata-section "this is not ]]> good")) (old-child (sdom:get-dom-property elem "sdom:first-child")) (ret-val (sdom:replace-child! elem new-child old-child)) (new-child (sdom:create-node doc sdom:node-type-cdata-section "this is not ]]> good")) (ret-val (sdom:append-child! elem new-child)) (split-warnings 0)) (sdom:set-dom-config-parameter! doc "split-cdata-sections" #t) (sdom:set-dom-config-parameter! doc "error-handler" (lambda (s m t e d l) (if (eqv? s sdom:error-severity-warning) (if (equal? t "cdata-sections-splitted") (set! split-warnings (+ split-warnings 1))) (throw #t "error or severe error during normalization")))) (sdom:normalize-document! doc) (if (not (eqv? split-warnings 2)) (throw #t "normalization should have split 2 cdata sections")) (let* ((elem-list (sdom:get-elements-by-tag-name doc "p")) (elem (list-ref elem-list 0)) (child-nodes (sdom:get-dom-property elem "sdom:child-nodes")) (len (length child-nodes))) (if (not (> len 3)) (throw #t "document normalize should split cdata sections") #t))))) (define documentnormalizedocument-11 (lambda () (let* ((doc (sdom:clone-node hc-staff #t))) (sdom:set-dom-config-parameter! doc "namespace-declarations" #t) (sdom:normalize-document! doc) (let* ((elem-list (sdom:get-elements-by-tag-name doc "acronym" "*")) (elem-name (list-ref elem-list 0))) (if (null? elem-name) (throw #t "normalization should preserve node name")) (if (sdom:can-set-dom-config-parameter? doc "namespace-declarations" #f) (sdom:set-dom-config-parameter! doc "namespace-declarations" #f)) (sdom:normalize-document! doc) (let* ((elem-list (sdom:get-elements-by-tag-name doc "acronym" "*")) (elem-name (list-ref elem-list 0)) (node-name (sdom:get-dom-property elem-name "sdom:node-name"))) (if (not (equal? node-name "acronym")) (throw #t "normalization should preserve node name") #t)))))) (define documentrenamenode-1 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (child-list (sdom:get-elements-by-tag-name doc "acronym")) (element (list-ref child-list 0)) (attr (sdom:get-attribute-node element "title")) (renamedclass (sdom:rename-node! attr "renamedNode" "http://www.w3.org/DOM/Test")) (node-name (sdom:get-dom-property renamedclass "sdom:node-name")) (namespace-uri (sdom:get-dom-property renamedclass "sdom:namespace-uri")) (node-type (sdom:get-dom-property renamedclass "sdom:node-type"))) (if (not (equal? node-name "renamedNode")) (throw #t "renaming node should change node name")) (if (not (eqv? node-type 2)) (throw #t "renaming node should preserve node type")) (if (not (equal? namespace-uri "http://www.w3.org/DOM/Test")) (throw #t "renaming node should change namespace URI")) #t))) (define documentrenamenode-2 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (child-list (sdom:get-elements-by-tag-name doc "acronym")) (element (list-ref child-list 0)) (attr (sdom:get-attribute-node element "title")) (renamedclass (sdom:rename-node! attr "prefi0x:renamedNode" "http://www.w3.org/DOM/Test")) (node-name (sdom:get-dom-property renamedclass "sdom:node-name")) (namespace-uri (sdom:get-dom-property renamedclass "sdom:namespace-uri")) (node-type (sdom:get-dom-property renamedclass "sdom:node-type"))) (if (not (equal? node-name "prefi0x:renamedNode")) (throw #t "renaming node should change prefix")) (if (not (equal? namespace-uri "http://www.w3.org/DOM/Test")) (throw #t "renaming node should change namespace URI")) #t))) (define documentrenamenode-3 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (attr (sdom:create-node doc sdom:node-type-attr "test")) (renamed-node (sdom:rename-node! attr "pre0:fix1" "http://www.w3.org/DOM/Test")) (node-name (sdom:get-dom-property renamed-node "sdom:node-name")) (namespace-uri (sdom:get-dom-property renamed-node "sdom:namespace-uri"))) (if (not (equal? node-name "pre0:fix1")) (throw #t "renaming node should change node name")) (if (not (equal? namespace-uri "http://www.w3.org/DOM/Test")) (throw #t "renaming node should change namespace URI")) #t))) (define documentrenamenode-4 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (attr (sdom:create-node doc sdom:node-type-attr "xml:lang" xmlns)) (renamed-node (sdom:rename-node! attr "title" "")) (node-name (sdom:get-dom-property renamed-node "sdom:node-name")) (namespace-uri (sdom:get-dom-property renamed-node "sdom:namespace-uri"))) (if (not (equal? node-name "title")) (throw #t "renaming node should change node name")) (if namespace-uri (throw #t "renaming node should change namespace URI")) #t))) (define documentrenamenode-5 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (attr (sdom:create-node doc sdom:node-type-attr "xml:lang" xmlns)) (renamed-node (sdom:rename-node! attr "title" '())) (node-name (sdom:get-dom-property renamed-node "sdom:node-name")) (namespace-uri (sdom:get-dom-property renamed-node "sdom:namespace-uri"))) (if (not (equal? node-name "title")) (throw #t "renaming node should change node name")) (if namespace-uri (throw #t "renaming node should change namespace URI")) #t))) (define documentrenamenode-7 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (doc-elem (sdom:get-dom-property doc "sdom:document-element")) (root-ns (sdom:get-dom-property doc-elem "sdom:namespace-uri")) (root-name (sdom:get-dom-property doc-elem "sdom:tag-name")) (new-doc (sdom:create-document root-name '() root-ns)) (attr (sdom:create-node new-doc sdom:node-type-attr "xml:lang" xmlns)) (renamed-node (sdom:rename-node! attr "xml:dom" xmlns)) (node-name (sdom:get-dom-property renamed-node "sdom:node-name")) (namespace-uri (sdom:get-dom-property renamed-node "sdom:namespace-uri"))) (if (not (equal? node-name "xml:dom")) (throw #t "renaming node should change node name")) (if (not (equal? namespace-uri xmlns)) (throw #t "renaming node should change namespace URI")) #t))) (define documentrenamenode-10 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (text-node (sdom:create-node doc sdom:node-type-text "hello")) (qualified-names (list "_:" ":0" ":" "a0:0" "_:0;" "a:::::c")) (success #f)) (for-each (lambda (x) (sdom:catch 'sdom:exception (lambda () (sdom:rename-node! text-node x xmlns)) (lambda exn (if (and (list? exn) (eqv? (cadr exn) sdom:exception-code-not-supported-err)) (set! success #t))))) qualified-names) (if (not success) (throw #t "renaming node should raise error on invalid node type")) #t))) (define documentrenamenode-11 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (text-node (sdom:create-node doc sdom:node-type-text "hello")) (success #f)) (sdom:catch 'sdom:exception (lambda () (sdom:rename-node! text-node "pre:fix" '())) (lambda exn (if (and (list? exn) (eqv? (cadr exn) sdom:exception-code-not-supported-err)) (set! success #t)))) (if (not success) (throw #t "renaming node should raise error on invalid node type")) #t))) (define documentrenamenode-12 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (text-node (sdom:create-node doc sdom:node-type-text "hello")) (success #f)) (sdom:catch 'sdom:exception (lambda () (sdom:rename-node! text-node "xml:prefix" xmlns)) (lambda exn (if (and (list? exn) (eqv? (cadr exn) sdom:exception-code-not-supported-err)) (set! success #t)))) (if (not success) (throw #t "renaming node should raise error on invalid node type")) #t))) (define documentrenamenode-13 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (text-node (sdom:create-node doc sdom:node-type-text "hello")) (success #f)) (sdom:catch 'sdom:exception (lambda () (sdom:rename-node! text-node "xmlns:prefix" xmlns)) (lambda exn (if (and (list? exn) (eqv? (cadr exn) sdom:exception-code-not-supported-err)) (set! success #t)))) (if (not success) (throw #t "renaming node should raise error on invalid node type")) #t))) (define documentrenamenode-14 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (text-node (sdom:create-node doc sdom:node-type-text "hello")) (success #f)) (sdom:catch 'sdom:exception (lambda () (sdom:rename-node! text-node "xmlns" "http://www.w3.org/2000/xmlns")) (lambda exn (if (and (list? exn) (eqv? (cadr exn) sdom:exception-code-not-supported-err)) (set! success #t)))) (if (not success) (throw #t "renaming node should raise error on invalid node type")) #t))) (define documentrenamenode-15 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (child-list (sdom:get-elements-by-tag-name doc "acronym")) (element (list-ref child-list 0)) (renamedclass (sdom:rename-node! element "qnam:renamedNode" "http://www.w3.org/DOM/Test")) (node-name (sdom:get-dom-property renamedclass "sdom:node-name")) (namespace-uri (sdom:get-dom-property renamedclass "sdom:namespace-uri")) (node-type (sdom:get-dom-property renamedclass "sdom:node-type"))) (if (not (equal? node-name "qnam:renamedNode")) (throw #t "renaming node should change node name")) (if (not (eqv? node-type 1)) (throw #t "renaming node should preserve node type")) (if (not (equal? namespace-uri "http://www.w3.org/DOM/Test")) (throw #t "renaming node should change namespace URI")) #t))) (define documentrenamenode-16 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (child-list (sdom:get-elements-by-tag-name doc "acronym")) (element (list-ref child-list 0)) (renamedclass (sdom:rename-node! element "renamedNode" '())) (node-name (sdom:get-dom-property renamedclass "sdom:node-name")) (namespace-uri (sdom:get-dom-property renamedclass "sdom:namespace-uri")) (node-type (sdom:get-dom-property renamedclass "sdom:node-type"))) (if (not (equal? node-name "renamedNode")) (throw #t "renaming node should change node name")) (if (not (eqv? node-type 1)) (throw #t "renaming node should preserve node type")) (if namespace-uri (throw #t "renaming node should change namespace URI")) #t))) (define documentrenamenode-17 (lambda () (let* ((doc (sdom:clone-node barfoo #t)) (doc-elem (sdom:get-dom-property doc "sdom:document-element")) (root-ns (sdom:get-dom-property doc-elem "sdom:namespace-uri")) (root-tagname (sdom:get-dom-property doc-elem "sdom:tag-name")) (new-doc (sdom:create-document root-tagname '() root-ns)) (element (sdom:create-node new-doc sdom:node-type-element "body" xhtmlns)) (renamed-node (sdom:rename-node! element "xhtml:head" xhtmlns)) (node-name (sdom:get-dom-property renamed-node "sdom:node-name")) (namespace-uri (sdom:get-dom-property renamed-node "sdom:namespace-uri")) (node-type (sdom:get-dom-property renamed-node "sdom:node-type"))) (if (not (equal? node-name "xhtml:head")) (throw #t "renaming node should change node name")) (if (not (eqv? node-type 1)) (throw #t "renaming node should preserve node type")) (if (not (equal? namespace-uri xhtmlns)) (throw #t "renaming node should change namespace URI")) #t))) (define documentrenamenode-19 (lambda () (let* ((qualified-names (list "a_:" "_:" ":" "::0;" "a:-:c")) (doc (sdom:clone-node hc-staff #t)) (new-doc (sdom:create-document "newD" '() "http://www.w3.org/DOM/Test")) (element (sdom:create-node doc sdom:node-type-element "test" "http://www.w3.org/DOM/Test")) (success #f)) (for-each (lambda (x) (sdom:catch 'sdom:exception (lambda () (sdom:rename-node! element x "http://www.w3.org/2000/XMLNS")) (lambda exn (if (and (not (null? (cdr exn))) (eqv? (cadr exn) sdom:exception-code-namespace-err)) (set! success #t)))) (if (not success) (throw #t "renaming node should fail with bad qname"))) qualified-names) #t))) (define documentrenamenode-20 (lambda () (let* ((doc (sdom:clone-node barfoo #t)) (doc-elem (sdom:get-dom-property doc "sdom:document-element")) (root-ns (sdom:get-dom-property doc-elem "sdom:namespace-uri")) (root-tagname (sdom:get-dom-property doc-elem "sdom:tag-name")) (element (sdom:create-node doc sdom:node-type-element root-tagname root-ns)) (success #f)) (sdom:catch 'sdom:exception (lambda () (sdom:rename-node! element "xml:html" "http://www.example.com/xml")) (lambda exn (if (and (not (null? (cdr exn))) (eqv? (cadr exn) sdom:exception-code-namespace-err)) (set! success #t)))) (if (not success) (throw #t "renaming node should fail with illegal namespace") #t)))) (define documentrenamenode-21 (lambda () (let* ((doc (sdom:clone-node barfoo #t)) (doc-elem (sdom:get-dom-property doc "sdom:document-element")) (root-ns (sdom:get-dom-property doc-elem "sdom:namespace-uri")) (root-tagname (sdom:get-dom-property doc-elem "sdom:tag-name")) (attr (sdom:create-node doc sdom:node-type-attr "xml:lang" xmlns)) (success #f)) (sdom:catch 'sdom:exception (lambda () (sdom:rename-node! attr "xmlns:xml" "http://www.w3.org/2000/XMLNS")) (lambda exn (if (and (not (null? (cdr exn))) (eqv? (cadr exn) sdom:exception-code-namespace-err)) (set! success #t)))) (if (not success) (throw #t "renaming node should fail with illegal namespace") #t)))) (define documentrenamenode-22 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (attr (sdom:create-node doc sdom:node-type-attr "xml:lang" xmlns)) (success #f)) (sdom:catch 'sdom:exception (lambda () (sdom:rename-node! attr "xmlns" "http://www.w3.org/1999/xmlns/")) (lambda exn (if (and (not (null? (cdr exn))) (eqv? (cadr exn) sdom:exception-code-namespace-err)) (set! success #t)))) (if (not success) (throw #t "renaming node should fail with illegal namespace") #t)))) (define documentrenamenode-23 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (success #f)) (sdom:catch 'sdom:exception (lambda () (sdom:rename-node! doc "root" "http://www.w3.org/DOM/Test")) (lambda exn (if (and (not (null? (cdr exn))) (eqv? (cadr exn) sdom:exception-code-not-supported-err)) (set! success #t)))) (if (not success) (throw #t "renaming node should fail on illegal node type") #t)))) (define documentrenamenode-24 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (success #f)) (sdom:catch 'sdom:exception (lambda () (sdom:rename-node! doc "doc:root" '())) (lambda exn (if (and (not (null? (cdr exn))) (eqv? (cadr exn) sdom:exception-code-not-supported-err)) (set! success #t)))) (if (not success) (throw #t "renaming node should fail on illegal node type") #t)))) (define documentrenamenode-26 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (doc-frag (sdom:create-node doc sdom:node-type-document-fragment)) (success #f)) (sdom:catch 'sdom:exception (lambda () (sdom:rename-node! doc-frag "root" "http://www.w3.org/DOM/Test")) (lambda exn (if (and (not (null? (cdr exn))) (eqv? (cadr exn) sdom:exception-code-not-supported-err)) (set! success #t)))) (if (not success) (throw #t "renaming node should fail on illegal node type") #t)))) (define documentrenamenode-27 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (doc-elem (sdom:get-dom-property doc "sdom:document-element")) (root-ns (sdom:get-dom-property doc-elem "sdom:namespace-uri")) (root-name (sdom:get-dom-property doc-elem "sdom:tag-name")) (new-doc (sdom:create-document root-name '() root-ns)) (text (sdom:create-node new-doc sdom:node-type-text "text")) (comment (sdom:create-node new-doc sdom:node-type-comment "comment")) (cdata (sdom:create-node new-doc sdom:node-type-cdata-section "cdata")) (pi (sdom:create-node new-doc sdom:node-type-processing-instruction "pit" "pid")) (entref (sdom:create-node new-doc sdom:node-type-entity-reference "alpha"))) (let ((success #f)) (sdom:catch 'sdom:exception (lambda () (sdom:rename-node! text "text" "http://www.w3.org/DOM/Test")) (lambda exn (if (and (not (null? (cdr exn))) (eqv? (cadr exn) sdom:exception-code-not-supported-err)) (set! success #t)))) (if (not success) (throw #t "renaming node should fail for text node"))) (let ((success #f)) (sdom:catch 'sdom:exception (lambda () (sdom:rename-node! comment "comment" "http://www.w3.org/DOM/Test")) (lambda exn (if (and (not (null? (cdr exn))) (eqv? (cadr exn) sdom:exception-code-not-supported-err)) (set! success #t)))) (if (not success) (throw #t "renaming node should fail for comment node"))) (let ((success #f)) (sdom:catch 'sdom:exception (lambda () (sdom:rename-node! cdata "cdata" "http://www.w3.org/DOM/Test")) (lambda exn (if (and (not (null? (cdr exn))) (eqv? (cadr exn) sdom:exception-code-not-supported-err)) (set! success #t)))) (if (not success) (throw #t "renaming node should fail for cdata section"))) (let ((success #f)) (sdom:catch 'sdom:exception (lambda () (sdom:rename-node! pi "pi" "http://www.w3.org/DOM/Test")) (lambda exn (if (and (not (null? (cdr exn))) (eqv? (cadr exn) sdom:exception-code-not-supported-err)) (set! success #t)))) (if (not success) (throw #t "renaming node should fail on processing instruction nodes"))) (let ((success #f)) (sdom:catch 'sdom:exception (lambda () (sdom:rename-node! entref "entref" "http://www.w3.org/DOM/Test")) (lambda exn (if (and (not (null? (cdr exn))) (eqv? (cadr exn) sdom:exception-code-not-supported-err)) (set! success #t)))) (if (not success) (throw #t "renaming node should fail on entity reference"))) #t))) (define documentrenamenode-29 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (doc-elem (sdom:get-dom-property doc "sdom:document-element")) (success #f)) (sdom:catch 'sdom:exception (lambda () (sdom:rename-node! doc-elem "@" "http://www.w3.org/DOM/Test")) (lambda exn (if (and (not (null? (cdr exn))) (eqv? (cadr exn) sdom:exception-code-invalid-character-err)) (set! success #t)))) (if (not success) (throw #t "renaming node should fail for invalid characters") #t)))) (define domconfigcdatasections-1 (lambda () (let* ((parameter "cDaTa-sections") (doc (sdom:create-document "html" '() xhtmlns)) (state (sdom:get-dom-config-parameter doc parameter))) (if (not state) (throw #t "cdata-sections should be true by default")) (if (not (sdom:can-set-dom-config-parameter? doc parameter #f)) (throw #t "should be able to set cdata-sections to #f")) (if (not (sdom:can-set-dom-config-parameter? doc parameter #t)) (throw #t "should be able to set cdata-sections to #t")) (sdom:set-dom-config-parameter! doc parameter #f) (let ((state (sdom:get-dom-config-parameter doc parameter))) (if state (throw #t "cdata-sections should be #f after set!") #t))))) (define domconfigcomments-1 (lambda () (let* ((parameter "cOmments") (doc (sdom:create-document "html" '() xhtmlns)) (state (sdom:get-dom-config-parameter doc parameter))) (if (not state) (throw #t "comments should be true by default")) (if (not (sdom:can-set-dom-config-parameter? doc parameter #f)) (throw #t "should be able to set comments to #f")) (if (not (sdom:can-set-dom-config-parameter? doc parameter #t)) (throw #t "should be able to set comments to #t")) (sdom:set-dom-config-parameter! doc parameter #f) (let ((state (sdom:get-dom-config-parameter doc parameter))) (if state (throw #t "comments should be #f after set!") #t))))) (define domconfigentities-1 (lambda () (let* ((parameter "eNtIties") (doc (sdom:create-document "html" '() xhtmlns)) (state (sdom:get-dom-config-parameter doc parameter))) (if (not state) (throw #t "entities should be true by default")) (if (not (sdom:can-set-dom-config-parameter? doc parameter #f)) (throw #t "should be able to set entities to #f")) (if (not (sdom:can-set-dom-config-parameter? doc parameter #t)) (throw #t "should be able to set entities to #t")) (sdom:set-dom-config-parameter! doc parameter #f) (let ((state (sdom:get-dom-config-parameter doc parameter))) (if state (throw #t "entities should be #f after set!") #t))))) (define domconfigerrorhandler-1 (lambda () (let* ((parameter "eRrOr-handler") (doc (sdom:create-document "html" '() xhtmlns)) (error-handler (lambda () #t)) (orig-handler (sdom:get-dom-config-parameter doc parameter))) (if (not (sdom:can-set-dom-config-parameter? doc parameter error-handler)) (throw #t "should be able to set new error-handler")) (if (not (sdom:can-set-dom-config-parameter? doc parameter orig-handler)) (throw #t "should be able to reset original error-handler")) (sdom:set-dom-config-parameter! doc parameter error-handler) (let ((state (sdom:get-dom-config-parameter doc parameter))) (if (not (eq? state error-handler)) (throw #t "error-handler should be new after set!")) (sdom:set-dom-config-parameter! doc parameter orig-handler) (let ((state (sdom:get-dom-config-parameter doc parameter))) (if (not (eq? state orig-handler)) (throw #t "error-handler should be new after set!") #t)))))) (define domconfigerrorhandler-2 (lambda () (let* ((parameter "error-handler") (doc (sdom:create-document "html" '() xhtmlns))) (if (not (sdom:can-set-dom-config-parameter? doc parameter '())) (throw #t "should be able to set null error handler")) (sdom:set-dom-config-parameter! doc parameter error-handler) (let ((state (sdom:get-dom-config-parameter doc parameter))) (if state (throw #t "error-handler should be null after set!") #t))))) (define domconfiginfoset-1 (lambda () (let* ((parameter "iNfOset") (doc (sdom:create-document "html" '() xhtmlns))) (if (sdom:get-dom-config-parameter doc parameter) (throw #t "infoset should be false before setting")) (if (not (sdom:can-set-dom-config-parameter? doc parameter #f)) (throw #t "should be able to set infoset to false")) (if (not (sdom:can-set-dom-config-parameter? doc parameter #t)) (throw #t "should be able to set infoset to true")) (sdom:set-dom-config-parameter! doc parameter #t) (if (not (sdom:get-dom-config-parameter doc parameter)) (throw #t "infoset should be true after set")) (if (sdom:get-dom-config-parameter doc "entities") (throw #t "entities should be false after setting infoset true")) (if (sdom:get-dom-config-parameter doc "cdata-sections") (throw #t "cdata-sections should be false after setting infoset")) (sdom:set-dom-config-parameter! doc parameter #f) (if (not (sdom:get-dom-config-parameter doc parameter)) (throw #t "setting infoset false should be a no-op")) (sdom:set-dom-config-parameter! doc "entities" #t) (if (not (sdom:get-dom-config-parameter doc parameter)) (throw #t "setting entities true should invalidate infoset") #t)))) (define domconfignamespacedeclarations-1 (lambda () (let* ((parameter "nAmEspace-declarations") (doc (sdom:create-document "html" '() xhtmlns))) (if (not (sdom:get-dom-config-parameter doc parameter)) (throw #t "namespace-declarations should be true before setting")) (if (not (sdom:can-set-dom-config-parameter? doc parameter #f)) (throw #t "should be able to set namespace-declarations to false")) (if (not (sdom:can-set-dom-config-parameter? doc parameter #t)) (throw #t "should be able to set namespace-declarations to true")) (sdom:set-dom-config-parameter! doc parameter #t) (if (not (sdom:get-dom-config-parameter doc parameter)) (throw #t "namespace-declaration should be true after set")) (sdom:set-dom-config-parameter! doc parameter #f) (if (sdom:get-dom-config-parameter doc parameter) (throw #t "namespace-declaration should be false after set") #t)))) (define domconfigparameternames-1 (lambda () (let* ((doc (sdom:clone-node barfoo #t)) (match-count 0)) (for-each (lambda (x) (let ((def (sdom:get-dom-config-parameter doc x))) (if (not (sdom:can-set-dom-config-parameter? doc x def)) (throw #t "should be able to set config to default")) (sdom:set-dom-config-parameter! doc x def) (if (member x `("canonical-form" "cdata-sections" "check-character-normalization" "comments" "datatype-normalization" "element-content-whitespace" "entities" "error-handler" "infoset" "namespaces" "namespace-declarations" "normalize-characters" "split-cdata-sections" "validate" "validate-if-schema" "well-formed")) (set! match-count (+ match-count 1))))) sdom:config-parameter-names) (if (not (eqv? match-count 16)) (throw #t "one or more config parameters not found") #t)))) (define domconfigsplitcdatasections-1 (lambda () (let* ((parameter "sPlIt-cdata-sections") (doc (sdom:create-document "html" '() xhtmlns))) (if (not (sdom:get-dom-config-parameter doc parameter)) (throw #t "split-cdata-sections should be true by default")) (if (not (sdom:can-set-dom-config-parameter? doc parameter #f)) (throw #t "should be able to set split-cdata-sections to false")) (if (not (sdom:can-set-dom-config-parameter? doc parameter #t)) (throw #t "should be able to set split-cdata-sections to true")) (sdom:set-dom-config-parameter! doc parameter #t) (if (not (sdom:get-dom-config-parameter doc parameter)) (throw #t "split-cdata-sections should be true after set")) (sdom:set-dom-config-parameter! doc parameter #f) (if (sdom:get-dom-config-parameter doc parameter) (throw #t "split-cdata-sections should be false after set")) #t))) (define domconfigurationcansetparameter-1 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (new-comment (sdom:create-node doc sdom:node-type-comment "This is a new Comment node")) (doc-elem (sdom:get-dom-property doc "sdom:document-element"))) (sdom:append-child! doc-elem new-comment) (if (not (sdom:can-set-dom-config-parameter? doc "comments" #f)) (throw #t "should be able to set comments to false")) (sdom:normalize-document! doc) (let ((last-child (sdom:get-dom-property doc-elem "sdom:last-child"))) (if (not (equal? (sdom:get-dom-property last-child "sdom:node-value") "This is a new Comment node")) (throw #t "can-set? should not affect configuration setting")) #t)))) (define domconfigurationgetparameter-1 (lambda () (let ((doc (sdom:clone-node hc-staff #t))) (if (not (sdom:get-dom-config-parameter doc "comments")) (throw #t "comments should be true by default")) (if (not (sdom:get-dom-config-parameter doc "cdata-sections")) (throw #t "cdata-sections should be true by default")) (if (not (sdom:get-dom-config-parameter doc "entities")) (throw #t "entities should be true by default")) (if (not (sdom:get-dom-config-parameter doc "namespace-declarations")) (throw #t "namespace-declarations should be true by default")) (if (sdom:get-dom-config-parameter doc "infoset") (throw #t "infoset should be false by default")) #t))) (define domconfigurationgetparameter-2 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (failure #t)) (sdom:catch 'sdom:exception (lambda () (sdom:get-dom-config-parameter doc "not-found-param")) (lambda exn (set! failure #f))) (if failure (throw #t "get should fail for invalid parameter") #t)))) (define elementsetidattribute-3 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (elem-list (sdom:get-elements-by-tag-name doc "acronym")) (acronym-node (list-ref elem-list 0))) (sdom:set-attribute! acronym-node "class" "Maybe") (sdom:set-id-attribute! acronym-node "class" #t) (let ((attr-node (sdom:get-attribute-node acronym-node "class"))) (if (not (sdom:get-dom-property attr-node "sdom:is-id")) (throw #t "attr should be id after set-id-attribute #t"))) (let ((elem (sdom:get-element-by-id doc "Maybe"))) (if (not (equal? (sdom:get-dom-property elem "sdom:tag-name") "acronym")) (throw #t "id should turn up under get-element-by-id"))) (sdom:set-id-attribute! acronym-node "class" #f) (let ((attr-node (sdom:get-attribute-node acronym-node "class"))) (if (sdom:get-dom-property attr-node "sdom:is-id") (throw #t "attr should not be id after set-id-attribute #f") #t))))) (define elementsetidattribute-5 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (elem-list (sdom:get-elements-by-tag-name doc "strong")) (strong-node (list-ref elem-list 0)) (success #f)) (sdom:catch 'sdom:exception (lambda () (sdom:set-id-attribute! strong-node "hasMiddleName" #t)) (lambda exn (if (eqv? (cadr exn) sdom:exception-code-not-found-err) (set! success #t)))) (if (not success) (throw #t "should throw exception on set-id-attribute with bad name") #t)))) (define elementsetidattribute-9 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (elem-list1 (sdom:get-elements-by-tag-name doc "strong")) (elem-list2 (sdom:get-elements-by-tag-name doc "sup")) (name-node (list-ref elem-list1 0)) (salary-node (list-ref elem-list2 0))) (sdom:set-attribute! name-node "hasMiddleName" "Antoine") (sdom:set-attribute! salary-node "annual" "2002") (sdom:set-id-attribute! name-node "hasMiddleName" #t) (sdom:set-id-attribute! salary-node "annual" #t) (let ((attr-node (sdom:get-attribute-node name-node "hasMiddleName"))) (if (not (sdom:get-dom-property attr-node "sdom:is-id")) (throw #t "attr should be id after set-id-attribute"))) (let ((attr-node (sdom:get-attribute-node salary-node "annual"))) (if (not (sdom:get-dom-property attr-node "sdom:is-id")) (throw #t "attr should be id after set-id-attribute"))) (let ((elem (sdom:get-element-by-id doc "Antoine"))) (if (not (equal? (sdom:get-dom-property elem "sdom:tag-name") "strong")) (throw #t "id should turn up under get-element-by-id"))) (let ((elem (sdom:get-element-by-id doc "2002"))) (if (not (equal? (sdom:get-dom-property elem "sdom:tag-name") "sup")) (throw #t "id should turn up under get-element-by-id") #t))))) (define elementsetidattribute-10 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (elem-list (sdom:get-elements-by-tag-name doc "acronym")) (acronym-node (list-ref elem-list 0))) (sdom:set-id-attribute! acronym-node "title" #t) (let ((attr-node (sdom:get-attribute-node acronym-node "title"))) (if (not (sdom:get-dom-property attr-node "sdom:is-id")) (throw #t "attr should be id after set-id-attribute")) (sdom:set-id-attribute! acronym-node "title" #t) (if (not (sdom:get-dom-property attr-node "sdom:is-id")) (throw #t "attr should be id after set-id-attribute")) (sdom:set-id-attribute! acronym-node "title" #f) (if (sdom:get-dom-property attr-node "sdom:is-id") (throw #t "attr should be id after set-id-attribute") #t))))) (define elementsetidattributenode-2 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (elem-list (sdom:get-elements-by-tag-name doc "acronym")) (acronym-node (list-ref elem-list 0)) (attr-node (sdom:get-attribute-node acronym-node "title"))) (sdom:set-id-attribute-node! attr-node #t) (if (not (sdom:get-dom-property attr-node "sdom:is-id")) (throw #t "attr should be id after set-id-attribute-node #t")) (let ((elem (sdom:get-element-by-id doc "Yes"))) (if (not (equal? (sdom:get-dom-property elem "sdom:tag-name") "acronym")) (throw #t "id should turn up under get-element-by-id"))) (sdom:set-id-attribute-node! attr-node #f) (if (sdom:get-dom-property attr-node "sdom:is-id") (throw #t "attr should not be id after set-id-attribute-node #f") #t)))) (define elementsetidattributenode-3 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (elem-list (sdom:get-elements-by-tag-name doc "strong")) (strong-node (list-ref elem-list 0))) (sdom:set-attribute! strong-node "foo" "Karen") (let ((attr-node (sdom:get-attribute-node strong-node "foo"))) (sdom:set-id-attribute-node! attr-node #t) (if (not (sdom:get-dom-property attr-node "sdom:is-id")) (throw #t "attr should be id after set-id-attribute-node #t")) (let ((elem (sdom:get-element-by-id doc "Karen"))) (if (not (equal? (sdom:get-dom-property elem "sdom:tag-name") "strong")) (throw #t "id should turn up under get-element-by-id"))) (sdom:set-id-attribute-node! attr-node #f) (if (sdom:get-dom-property attr-node "sdom:is-id") (throw #t "attr should not be id after set-id-attribute-node #f") #t))))) (define entities-1 (lambda () (let* ((doc (sdom:clone-node barfoo #t)) (p-list (sdom:get-elements-by-tag-name doc "p")) (p-elem (list-ref p-list 0)) (ent-ref (sdom:create-node doc sdom:node-type-entity-reference "ent1"))) (sdom:set-dom-config-parameter! doc "entities" #t) (sdom:append-child! p-elem ent-ref) (sdom:normalize-document! doc) (let* ((p-list (sdom:get-elements-by-tag-name doc "p")) (p-elem (list-ref p-list 0)) (child (sdom:get-dom-property p-elem "sdom:last-child"))) (if (null? child) (throw #t "entity references should be preserved")) (if (not (equal? (sdom:get-dom-property child "sdom:node-name") "ent1")) (throw #t "entity references should be preserved")) (if (not (find (lambda (x) (equal? (sdom:get-dom-property x "sdom:node-name") "ent2")) (sdom:get-dom-property (sdom:get-dom-property doc "sdom:doc-type") "sdom:entities"))) (throw #t "entity definitions should be preserved") #t))))) (define entities-2 (lambda () (let* ((doc (sdom:clone-node barfoo #t)) (p-list (sdom:get-elements-by-tag-name doc "p")) (p-elem (list-ref p-list 0)) (ent-ref (sdom:create-node doc sdom:node-type-entity-reference "ent1"))) (sdom:set-dom-config-parameter! doc "entities" #f) (sdom:append-child! p-elem ent-ref) (sdom:normalize-document! doc) (let* ((p-list (sdom:get-elements-by-tag-name doc "p")) (p-elem (list-ref p-list 0)) (child (sdom:get-dom-property p-elem "sdom:last-child"))) (if (null? child) (throw #t "entity references should be resolved")) (if (not (equal? (sdom:get-dom-property child "sdom:node-name") "#text")) (throw #t "entity references should be resolved")) (if (not (equal? (sdom:get-dom-property child "sdom:node-value") "barfoo")) (throw #t "entity references should be resolved")) (if (not (find (lambda (x) (equal? (sdom:get-dom-property x "sdom:node-name") "ent2")) (sdom:get-dom-property (sdom:get-dom-property doc "sdom:doc-type") "sdom:entities"))) (throw #t "entity definitions should be preserved") #t))))) (define entities-3 (lambda () (let* ((doc (sdom:clone-node barfoo #t)) (p-list (sdom:get-elements-by-tag-name doc "p")) (p-elem (list-ref p-list 0)) (ent-ref (sdom:create-node doc sdom:node-type-entity-reference "ent3"))) (sdom:set-dom-config-parameter! doc "entities" #f) (sdom:append-child! p-elem ent-ref) (sdom:normalize-document! doc) (let* ((p-list (sdom:get-elements-by-tag-name doc "p")) (p-elem (list-ref p-list 0)) (child (sdom:get-dom-property p-elem "sdom:last-child"))) (if (null? child) (throw #t "entity references should be left unresolved")) (if (not (eqv? (sdom:get-dom-property child "sdom:node-type") 5)) (throw #t "entity references should be left unresolved")) (if (not (equal? (sdom:get-dom-property child "sdom:node-name") "ent3")) (throw #t "entity references should be left unresolved")) #t)))) (define entities-4 (lambda () (let* ((doc (sdom:clone-node barfoo #t)) (p-list (sdom:get-elements-by-tag-name doc "p")) (p-elem (list-ref p-list 0)) (ent-ref (sdom:create-node doc sdom:node-type-entity-reference "ent1"))) (sdom:set-dom-config-parameter! doc "entities" #f) (sdom:append-child! p-elem ent-ref) (sdom:normalize! doc) (let* ((p-list (sdom:get-elements-by-tag-name doc "p")) (p-elem (list-ref p-list 0)) (child (sdom:get-dom-property p-elem "sdom:last-child"))) (if (null? child) (throw #t "entity references should be left unresolved")) (if (not (equal? (sdom:get-dom-property child "sdom:node-name") "ent1")) (throw #t "entity references should be left unresolved")) (if (not (find (lambda (x) (equal? (sdom:get-dom-property x "sdom:node-name") "ent2")) (sdom:get-dom-property (sdom:get-dom-property doc "sdom:doc-type") "sdom:entities"))) (throw #t "entity definitions should be preserved") #t))))) (define handleerror-1 (lambda () (let* ((handler (lambda (severity msg type excep data loc) #f)) (doc (sdom:clone-node barfoo #t)) (elem-list (sdom:get-elements-by-tag-name doc "p")) (elem (list-ref elem-list 0)) (old-child (sdom:get-dom-property elem "sdom:first-child")) (new-child (sdom:create-node doc sdom:node-type-cdata-section "this is not ]]> good"))) (sdom:replace-child! elem new-child old-child) (let ((new-child (sdom:create-node doc sdom:node-type-cdata-section "this is not ]]> bad"))) (sdom:append-child! elem new-child)) (sdom:set-dom-config-parameter! doc "split-cdata-sections" #t) (sdom:set-dom-config-parameter! doc "error-handler" handler) (sdom:normalize-document! doc) (let* ((elem-list (sdom:get-elements-by-tag-name doc "p")) (elem (list-ref elem-list 0)) (child (sdom:get-dom-property elem "sdom:last-child")) (value (sdom:get-dom-property child "sdom:node-value"))) (if (equal? value "this is not ]]> bad") (if (not (eqv? (sdom:get-dom-property child "sdom:node-type") 4)) (throw #t "last child should be CDATA after normalization") (let* ((child (sdom:get-dom-property elem "sdom:first-child")) (value (sdom:get-dom-property child "sdom:node-value"))) (if (equal? value "this is not ]]> good") (throw #t "first child should not be intact") #t))) (let* ((child (sdom:get-dom-property elem "sdom:first-child")) (value (sdom:get-dom-property child "sdom:node-value"))) (if (not (equal? value "this is not ]]> good")) (throw #t "first child should be intact") #t))))))) (define infoset-2 (lambda () (let* ((failure #f) (handler (lambda (severity msg type excep data loc) (if (>= severity 2) (set! failure #t)) #t)) (doc (sdom:clone-node barfoo #t))) (sdom:set-dom-config-parameter! doc "infoset" #t) (sdom:set-dom-config-parameter! doc "error-handler" handler) (let* ((plist (sdom:get-elements-by-tag-name doc "p")) (pelem (list-ref plist 0)) (entref (sdom:create-node doc sdom:node-type-entity-reference "ent3"))) (sdom:append-child! pelem entref) (sdom:normalize-document! doc) (if failure (throw #t "should not have been severe errors")) (let* ((plist (sdom:get-elements-by-tag-name doc "p")) (pelem (list-ref plist 0)) (child (sdom:get-dom-property pelem "sdom:last-child"))) (if (not child) (throw #t "last child should not be null")) (if (not (eqv? (sdom:get-dom-property child "sdom:node-type") 5)) (throw #t "last child should have type entity-reference")) (if (not (equal? (sdom:get-dom-property child "sdom:node-name") "ent3")) (throw #t "last child should have name ent3") #t)))))) (define infoset-4 (lambda () (let* ((failure #f) (handler (lambda (severity msg type excep data loc) (if (>= severity 2) (set! failure #t)) #t)) (doc (sdom:clone-node barfoo #t)) (plist (sdom:get-elements-by-tag-name doc "p")) (pelem (list-ref plist 0)) (newcdata (sdom:create-node doc sdom:node-type-cdata-section "CDATA"))) (sdom:append-child! pelem newcdata) (sdom:set-dom-config-parameter! doc "infoset" #t) (sdom:set-dom-config-parameter! doc "error-handler" handler) (sdom:normalize-document! doc) (if failure (throw #t "should not have been severe errors")) (let* ((plist (sdom:get-elements-by-tag-name doc "p")) (pelem (list-ref plist 0)) (text (sdom:get-dom-property pelem "sdom:last-child"))) (if (not (equal? (sdom:get-dom-property text "sdom:node-name") "#text")) (throw #t "last element should have been converted to text node")) (if (not (equal? (sdom:get-dom-property text "sdom:node-value") "barCDATA")) (throw #t "last element should have been coalesced with CDATA") #t))))) (define infoset-8 (lambda () (let* ((failure #f) (handler (lambda (severity msg type excep data loc) (if (>= severity 2) (set! failure #t)) #t)) (doc (sdom:clone-node barfoo #t))) (sdom:set-dom-config-parameter! doc "infoset" #t) (sdom:set-dom-config-parameter! doc "error-handler" handler) (let* ((bodylist (sdom:get-elements-by-tag-name doc "body")) (body (list-ref bodylist 0)) (child (sdom:get-dom-property body "sdom:first-child")) (text (sdom:create-node doc sdom:node-type-text " "))) (sdom:insert-before! body text child)) (sdom:normalize-document! doc) (if failure (throw #t "should not have been severe errors")) (let* ((bodylist (sdom:get-elements-by-tag-name doc "body")) (body (list-ref bodylist 0)) (child (sdom:get-dom-property body "sdom:first-child"))) (if (not child) (throw #t "first child should not be null")) (if (not (equal? (sdom:get-dom-property child "sdom:node-name") "#text")) (throw #t "first child should be text node")) (let ((child (sdom:get-dom-property child "sdom:next-sibling"))) (if (not child) (throw #t "second child should not be null")) (if (not (equal? (sdom:get-dom-property child "sdom:node-name") "p")) (throw #t "second child should be p element") #t)))))) (define infoset-9 (lambda () (let* ((failure #f) (handler (lambda (severity msg type excep data loc) (if (>= severity 2) (set! failure #t)) #t)) (doc (sdom:clone-node barfoo #t)) (plist (sdom:get-elements-by-tag-name doc "p")) (elem (list-ref plist 0)) (newcomment (sdom:create-node doc sdom:node-type-comment "COMMENT_NODE"))) (sdom:append-child! elem newcomment) (sdom:set-dom-config-parameter! doc "comments" #f) (sdom:set-dom-config-parameter! doc "infoset" #t) (sdom:set-dom-config-parameter! doc "error-handler" handler) (sdom:normalize-document! doc) (if failure (throw #t "should not have been severe errors")) (let* ((plist (sdom:get-elements-by-tag-name doc "p")) (elem (list-ref plist 0)) (lastchild (sdom:get-dom-property elem "sdom:last-child"))) (if (not (equal? (sdom:get-dom-property lastchild "sdom:node-name") "#comment")) (throw #t "comments should have been preserved") #t))))) (define nodeappendchild-2 (lambda () (let* ((doc (sdom:clone-node barfoo #t)) (docelem (sdom:get-dom-property doc "sdom:document-element")) (tagname (sdom:get-dom-property docelem "sdom:tag-name")) (rootns (sdom:get-dom-property docelem "sdom:namespace-uri")) (newelem (sdom:create-node doc sdom:node-type-element tagname rootns))) (sdom:catch 'sdom:exception (lambda () (sdom:append-child! doc newelem) (throw #t "exception should have been thrown")) (lambda exn (let ((code (cadr exn))) (if (and (not (eqv? code 3)) (not (eqv? code 9))) (throw #t "wrong exception type was thrown"))))) #t))) (define nodecomparedocumentposition-3 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (doccomp (sdom:clone-node hc-staff #t)) (pos1 (sdom:compare-document-position doc doccomp)) (pos2 (sdom:compare-document-position doccomp doc))) (if (not (eqv? (logand 33 57) (logand pos1 57))) (throw #t "documents should be disconnected")) (if (eqv? (logand pos1 2) (logand pos2 2)) (throw #t "documents should not both be preceding")) (if (eqv? (logand pos1 4) (logand pos2 4)) (throw #t "documents should not both be following")) (let ((pos3 (sdom:compare-document-position doc doccomp))) (if (not (eqv? pos1 pos3)) (throw #t "document position should be consistent across calls") #t))))) (define nodecomparedocumentposition-4 (lambda () (let ((doc (sdom:clone-node hc-staff #t))) (if (not (eqv? (sdom:compare-document-position doc doc) 0)) (throw #t "no flags should be set when comparing doc with itself") #t)))) (define nodecomparedocumentposition-5 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (docelem (sdom:get-dom-property doc "sdom:document-element")) (rootname (sdom:get-dom-property docelem "sdom:tag-name")) (rootns (sdom:get-dom-property docelem "sdom:namespace-uri")) (newdoc (sdom:create-document rootname '() rootns)) (pos1 (sdom:compare-document-position doc newdoc)) (pos2 (sdom:compare-document-position newdoc doc))) (if (not (eqv? (logand 33 57) (logand pos1 57))) (throw #t "documents should be disconnected")) (if (eqv? (logand pos1 2) (logand pos2 2)) (throw #t "documents should not both be preceding")) (if (eqv? (logand pos1 4) (logand pos2 4)) (throw #t "documents should not both be following")) (let ((pos3 (sdom:compare-document-position doc newdoc))) (if (not (eqv? pos1 pos3)) (throw #t "document position should be consistent across calls") #t))))) (define nodecomparedocumentposition-6 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (docelem (sdom:get-dom-property doc "sdom:document-element")) (pos1 (sdom:compare-document-position doc docelem)) (pos2 (sdom:compare-document-position docelem doc))) (if (not (eqv? 20 pos1)) (throw #t "document element should be contained and following")) (if (not (eqv? 10 pos2)) (throw #t "document should be preceding and containing") #t)))) (define nodecomparedocumentposition-7 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (docelem (sdom:get-dom-property doc "sdom:document-element")) (newelem (sdom:create-node doc sdom:node-type-element "br" xhtmlns))) (sdom:append-child! docelem newelem) (let ((pos1 (sdom:compare-document-position doc newelem)) (pos2 (sdom:compare-document-position newelem doc))) (if (not (eqv? 20 pos1)) (throw #t "new element should be contained and following")) (if (not (eqv? 10 pos2)) (throw #t "document should be preceding and containing") #t))))) (define nodecomparedocumentposition-8 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (elemlist (sdom:get-elements-by-tag-name doc "p")) (elem (list-ref elemlist 0)) (pos1 (sdom:compare-document-position doc elem)) (pos2 (sdom:compare-document-position elem doc))) (if (not (eqv? 20 pos1)) (throw #t "element should be contained and following")) (if (not (eqv? 10 pos2)) (throw #t "document should be preceding and containing") #t)))) (define nodecomparedocumentposition-9 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (elemlist (sdom:get-elements-by-tag-name doc "p")) (elem (list-ref elemlist 0)) (newelem (sdom:create-node doc sdom:node-type-element "br" xhtmlns))) (sdom:append-child! elem newelem) (let ((pos1 (sdom:compare-document-position doc newelem)) (pos2 (sdom:compare-document-position newelem doc))) (if (not (eqv? 20 pos1)) (throw #t "new element should be contained and following")) (if (not (eqv? 10 pos2)) (throw #t "document should be preceding and containing") #t))))) (define nodecomparedocumentposition-11 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (elemlist (sdom:get-elements-by-tag-name doc "p")) (elem (list-ref elemlist 0)) (newattr (sdom:create-node doc sdom:node-type-attr "xml:lang" xmlns))) (sdom:set-attribute-node! elem newattr) (if (not (eqv? (sdom:compare-document-position newattr doc) 10)) (throw #t "document should precede and contain attribute") #t)))) (define nodecomparedocumentposition-12 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (pi (sdom:create-node doc sdom:node-type-processing-instruction "PITarget" "PIDATA"))) (sdom:append-child! doc pi) (if (not (eqv? (sdom:compare-document-position doc pi) 20)) (throw #t "PI should be contained and following")) (if (not (eqv? (sdom:compare-document-position pi doc) 10)) (throw #t "document should precede and contain PI") #t)))) (define nodecomparedocumentposition-13 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (comment (sdom:create-node doc sdom:node-type-comment "Another Comment")) (elemlist (sdom:get-elements-by-tag-name doc "p")) (elem (list-ref elemlist 0))) (sdom:append-child! elem comment) (if (not (eqv? (sdom:compare-document-position doc comment) 20)) (throw #t "comment should be contained and following")) (if (not (eqv? (sdom:compare-document-position comment doc) 10)) (throw #t "document should precede and contain comment") #t)))) (define nodecomparedocumentposition-14 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (docelem (sdom:get-dom-property doc "sdom:document-element")) (docfrag (sdom:create-node doc sdom:node-type-document-fragment))) (sdom:append-child! docfrag docelem) (let* ((docfragchild (sdom:get-dom-property docfrag "sdom:first-child")) (dfpos1 (sdom:compare-document-position docfrag docfragchild)) (dfpos2 (sdom:compare-document-position docfragchild docfrag))) (if (not (eqv? dfpos1 20)) (throw #t "element should be contained and following")) (if (not (eqv? dfpos2 10)) (throw #t "document fragment should precede and contain element") #t))))) (define nodecomparedocumentposition-15 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (docelem (sdom:get-dom-property doc "sdom:document-element")) (docfrag (sdom:create-node doc sdom:node-type-document-fragment)) (attr (sdom:create-node doc sdom:node-type-attr "xml:lang" xmlns))) (sdom:set-attribute-node! docelem attr) (sdom:append-child! docfrag docelem) (let ((docfragchild (sdom:get-dom-property docfrag "sdom:first-child"))) (if (not (eqv? (sdom:compare-document-position docfragchild attr) 20)) (throw #t "attr should be contained and following")) (if (not (eqv? (sdom:compare-document-position attr docfragchild) 10)) (throw #t "element should precede and contain attribute") #t))))) (define nodecomparedocumentposition-16 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (docfrag (sdom:create-node doc sdom:node-type-document-fragment)) (attr (sdom:create-node doc sdom:node-type-attr "xml:lang" xmlns)) (attrcloned (sdom:clone-node attr #t)) (pos1 (sdom:compare-document-position docfrag attrcloned)) (pos2 (sdom:compare-document-position attrcloned docfrag))) (if (not (eqv? (logand 33 57) (logand pos1 57))) (throw #t "fragment and attribute should be disconnected")) (if (eqv? (logand pos1 2) (logand pos2 2)) (throw #t "nodes should not both be preceding")) (if (eqv? (logand pos1 4) (logand pos2 4)) (throw #t "nodes should not both be following")) (if (not (eqv? pos1 (sdom:compare-document-position docfrag attrcloned))) (throw #t "node position should be consistent") #t)))) (define nodecomparedocumentposition-17 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (pi1 (sdom:create-node doc sdom:node-type-processing-instruction "PI1" "")) (pi2 (sdom:create-node doc sdom:node-type-processing-instruction "PI2" ""))) (sdom:append-child! doc pi1) (sdom:append-child! doc pi2) (if (not (eqv? (sdom:compare-document-position pi1 pi2) 4)) (throw #t "second PI should be following first PI")) (if (not (eqv? (sdom:compare-document-position pi2 pi1) 2)) (throw #t "first PI should be preceding second PI") #t)))) (define nodecomparedocumentposition-18 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (docelem (sdom:get-dom-property doc "sdom:document-element")) (txt1 (sdom:create-node doc sdom:node-type-text "T1")) (txt2 (sdom:create-node doc sdom:node-type-text "T2"))) (sdom:append-child! docelem txt1) (sdom:append-child! docelem txt2) (if (not (eqv? (sdom:compare-document-position txt1 txt2) 4)) (throw #t "second text node should be following first text node")) (if (not (eqv? (sdom:compare-document-position txt2 txt1) 2)) (throw #t "first text node should be preceding second text node") #t)))) (define nodecomparedocumentposition-19 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (elemlist (sdom:get-elements-by-tag-name doc "strong" "*")) (elemstrong (list-ref elemlist 0)) (textnode (sdom:get-dom-property elemstrong "sdom:first-child")) (cdata1 (sdom:create-node doc sdom:node-type-cdata-section "FOO")) (cdata2 (sdom:create-node doc sdom:node-type-cdata-section "BAR"))) (sdom:insert-before! elemstrong cdata1 textnode) (sdom:insert-after! elemstrong cdata2 textnode) (if (not (eqv? (sdom:compare-document-position cdata1 cdata2) 4)) (throw #t "second cdata section should be following first")) (if (not (eqv? (sdom:compare-document-position cdata2 cdata1) 2)) (throw #t "first cdata section should be preceding second") #t)))) (define nodecomparedocumentposition-20 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (elemlist (sdom:get-elements-by-tag-name doc "strong" "*")) (elemstrong (list-ref elemlist 0)) (textnode (sdom:get-dom-property elemstrong "sdom:first-child")) (cdata1 (sdom:create-node doc sdom:node-type-cdata-section "FOO"))) (sdom:insert-after! elemstrong cdata1 textnode) (if (not (eqv? (sdom:compare-document-position textnode cdata1) 4)) (throw #t "cdata section should follow text node")) (if (not (eqv? (sdom:compare-document-position cdata1 textnode) 2)) (throw #t "text node should precede cdata section") #t)))) (define nodecomparedocumentposition-21 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (plist (sdom:get-elements-by-tag-name doc "p")) (blist (sdom:get-elements-by-tag-name doc "body")) (pelem (list-ref plist 0)) (belem (list-ref blist 0)) (pclone (sdom:clone-node pelem #t))) (sdom:append-child! belem pclone) (let* ((elemlist (sdom:get-elements-by-tag-name doc "strong")) (name1 (list-ref elemlist 0)) (name2 (list-ref elemlist 1)) (txt1 (sdom:get-dom-property name1 "sdom:first-child")) (txt2 (sdom:get-dom-property name2 "sdom:first-child"))) (if (not (eqv? (sdom:compare-document-position txt1 txt2) 4)) (throw #t "second text node should follow first text node")) (if (not (eqv? (sdom:compare-document-position txt2 txt1) 2)) (throw #t "first text node should precede second text node") #t))))) (define nodecomparedocumentposition-25 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (elemlist (sdom:get-elements-by-tag-name doc "var")) (elem (list-ref elemlist 0)) (entref (sdom:create-node doc sdom:node-type-entity-reference "F"))) (sdom:insert-before! elem entref (sdom:get-dom-property elem "sdom:first-child")) (if (not (eqv? (sdom:compare-document-position elem entref) 20)) (throw #t "entity reference should be contained and following")) (if (not (eqv? (sdom:compare-document-position entref elem) 10)) (throw #t "element should be containing and preceding") #t)))) (define nodecomparedocumentposition-30 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (elemlist (sdom:get-elements-by-tag-name doc "strong")) (strong (list-ref elemlist 0)) (positionlist (sdom:get-elements-by-tag-name doc "code")) (code (list-ref positionlist 0))) (if (not (eqv? (sdom:compare-document-position code strong) 2)) (throw #t "strong element should precede code element") #t)))) (define nodecomparedocumentposition-31 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (p (sdom:clone-node (list-ref (sdom:get-elements-by-tag-name doc "p") 0) #t)) (body (list-ref (sdom:get-elements-by-tag-name doc "body") 0))) (sdom:append-child! body (cadr p)) (let* ((namelist (sdom:get-elements-by-tag-name doc "strong")) (strong (list-ref namelist 0)) (positionlist (sdom:get-elements-by-tag-name doc "em")) (code (list-ref positionlist 1)) (newelem (sdom:create-node doc sdom:node-type-element "br" xhtmlns))) (sdom:append-child! code newelem) (if (not (eqv? (sdom:compare-document-position strong newelem) 4)) (throw #t "strong element should precede new element")) (if (not (eqv? (sdom:compare-document-position newelem strong) 2)) (throw #t "new element should follow strong element") #t))))) (define nodecomparedocumentposition-33 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (elem (sdom:create-node doc sdom:node-type-element "br" xhtmlns)) (attr (sdom:create-node doc sdom:node-type-attr "xml:lang" xmlns))) (sdom:set-attribute-node! elem attr) (if (not (eqv? (sdom:compare-document-position elem attr) 20)) (throw #t "attr should be contained by and follow element")) (if (not (eqv? (sdom:compare-document-position attr elem) 10)) (throw #t "element should contain and precede attr")) (let ((pos1 (sdom:compare-document-position doc elem)) (pos2 (sdom:compare-document-position elem doc))) (if (not (eqv? (logand pos1 57) (logand 33 57))) (throw #t "document and new element should be disconnected")) (if (eqv? (logand pos1 2) (logand pos2 2)) (throw #t "document and element should not both be following")) (if (eqv? (logand pos1 4) (logand pos2 4)) (throw #t "document and element should not both be preceding")) (if (not (eqv? pos1 (sdom:compare-document-position doc elem))) (throw #t "document position should be consistent") #t))))) (define nodecomparedocumentposition-34 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (elemmain (sdom:create-node doc sdom:node-type-element "p" xhtmlns)) (elem (sdom:create-node doc sdom:node-type-element "br" xhtmlns)) (txt (sdom:create-node doc sdom:node-type-text "TEXT")) (pi (sdom:create-node doc sdom:node-type-processing-instruction "PIT" "PID"))) (sdom:append-child! elemmain txt) (sdom:append-child! elemmain elem) (sdom:append-child! elemmain pi) (if (not (eqv? (sdom:compare-document-position txt elem) 4)) (throw #t "element should be following text node")) (if (not (eqv? (sdom:compare-document-position pi txt) 2)) (throw #t "processing instruction should precede text node") #t)))) (define nodecomparedocumentposition-37 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (elemlist (sdom:get-elements-by-tag-name doc "acronym")) (elem (list-ref elemlist 0)) (attr (sdom:get-attribute-node elem "title")) (txt (sdom:get-dom-property elem "sdom:first-child"))) (if (not (eqv? (sdom:compare-document-position attr txt) 4)) (throw #t "text node should follow attribute node")) (if (not (eqv? (sdom:compare-document-position txt attr) 2)) (throw #t "attribute node should precede text node") #t)))) (define nodecomparedocumentposition-38 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (elemlist (sdom:get-elements-by-tag-name doc "acronym")) (elem (list-ref elemlist 0)) (attr (sdom:get-attribute-node elem "title")) (txt (sdom:get-dom-property attr "sdom:first-child"))) (if (not (eqv? (sdom:compare-document-position attr txt) 20)) (throw #t "text node should be contained by and follow attr")) (if (not (eqv? (sdom:compare-document-position txt attr) 10)) (throw #t "attr should contain and precede txt") #t)))) (define nodecomparedocumentposition-39 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (elemlist (sdom:get-elements-by-tag-name doc "acronym")) (elem (list-ref elemlist 3)) (attr1 (sdom:get-attribute-node elem "class")) (attr2 (sdom:get-attribute-node elem "xsi:noNamespaceSchemaLocation")) (attrpos (sdom:compare-document-position attr1 attr2))) (if (not (eqv? (logand attrpos 32) (logand 32 32))) (throw #t "relative attribute position should be impl. specific")) (if (not (eqv? (logand attrpos 25) (logand 0 25))) (throw #t "other bits should be zero")) (if (eqv? (logand 0 6) (logand attrpos 6)) (throw #t "should be either preceding or following")) (let ((swappedpos (sdom:compare-document-position attr2 attr1))) (if (eqv? (logand swappedpos 2) (logand attrpos 2)) (throw #t "only one attr should be preceding")) (if (eqv? (logand swappedpos 4) (logand attrpos 4)) (throw #t "only one attr should be following") #t))))) (define nodecomparedocumentposition-40 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (elemlist (sdom:get-elements-by-tag-name doc "acronym")) (elem (list-ref elemlist 0)) (attr1 (sdom:get-attribute-node elem "title"))) (sdom:set-attribute! elem "xml:lang" "FR-fr" xmlns) (let* ((attr2 (sdom:get-attribute-node elem "xml:lang")) (attrpos (sdom:compare-document-position attr1 attr2))) (if (not (eqv? (logand 32 32) (logand attrpos 32))) (throw #t "relative attribute position should be impl. specific")) (if (not (eqv? (logand 0 25) (logand attrpos 25))) (throw #t "other bits should be zero")) (if (eqv? (logand 0 6) (logand attrpos 6)) (throw #t "should be either preceding or following")) (let ((swappedpos (sdom:compare-document-position attr2 attr1))) (if (eqv? (logand swappedpos 2) (logand attrpos 2)) (throw #t "only one attr should be preceding")) (if (eqv? (logand swappedpos 4) (logand attrpos 4)) (throw #t "only one attr should be following") #t)))))) (define nodegetbaseuri-2 (lambda () (let* ((doc (sdom:clone-node barfoo #t)) (docelem (sdom:get-dom-property doc "sdom:document-element")) (rootns (sdom:get-dom-property docelem "sdom:namespace-uri")) (rootname (sdom:get-dom-property docelem "sdom:tag-name")) (newdoc (sdom:create-document rootname '() rootns)) (baseuri (sdom:get-dom-property newdoc "sdom:base-uri"))) (if baseuri (throw #t "base URI should be null for newly created document")) (sdom:set-dom-property! newdoc "sdom:document-uri" "http://www.example.com/sample.xml") (if (not (equal? (sdom:get-dom-property newdoc "sdom:base-uri") "http://www.example.com/sample.xml")) (throw #t "base URI should be equal to document URI") #t)))) (define nodegetbaseuri-4 (lambda () (let* ((doc (sdom:clone-node barfoo #t)) (docelem (sdom:get-dom-property doc "sdom:document-element")) (baseuri (sdom:get-dom-property docelem "sdom:base-uri")) (docuri (sdom:get-dom-property doc "sdom:document-uri"))) (if (not (equal? baseuri docuri)) (throw #t "base URI should be equal to document URI") #t)))) (define nodegetbaseuri-5 (lambda () (let* ((doc (sdom:clone-node barfoo-base #t)) (docelem (sdom:get-dom-property doc "sdom:document-element")) (baseuri (sdom:get-dom-property docelem "sdom:base-uri"))) (if (not (equal? baseuri "http://www.w3.org/DOM/L3Test")) (throw #t "base URI should be equal to base attribute") #t)))) (define nodegetbaseuri-7 (lambda () (let* ((doc (sdom:clone-node barfoo-base #t)) (bodylist (sdom:get-elements-by-tag-name doc "body")) (bodyelem (list-ref bodylist 0)) (newelem (sdom:create-node doc sdom:node-type-element "meta" xhtmlns))) (sdom:set-attribute! newelem "content" "text/xml") (sdom:append-child! bodyelem newelem) (if (not (equal? (sdom:get-dom-property newelem "sdom:base-uri") "http://www.w3.org/DOM/EmployeeID")) (throw #t "base URI should be equal to inherited base attribute") #t)))) (define nodegetbaseuri-9 (lambda () (let* ((doc (sdom:clone-node barfoo-base #t)) (bodylist (sdom:get-elements-by-tag-name doc "body")) (bodyelem (list-ref bodylist 0)) (baseuri (sdom:get-dom-property bodyelem "sdom:base-uri"))) (if (not (equal? baseuri "http://www.w3.org/DOM/EmployeeID")) (throw #t "explicit base attribute should produce base URI") #t)))) (define nodegetbaseuri-10 (lambda () (let* ((doc (sdom:clone-node barfoo-base #t)) (docelem (sdom:get-dom-property doc "sdom:document-element")) (newpi (sdom:create-node doc sdom:node-type-processing-instruction "TARGET" "DATA"))) (sdom:append-child! docelem newpi) (if (not (equal? (sdom:get-dom-property newpi "sdom:base-uri") "http://www.w3.org/DOM/L3Test")) (throw #t "processing instruction should inherit URI from element") #t)))) (define nodegetbaseuri-15 (lambda () (let* ((doc (sdom:clone-node barfoo-base #t)) (bodylist (sdom:get-elements-by-tag-name doc "body")) (bodyelem (list-ref bodylist 0)) (attrnode (sdom:get-attribute-node bodyelem "id")) (baseuri (sdom:get-dom-property attrnode "sdom:base-uri"))) (if baseuri (throw #t "base URI for attr should be null") #t)))) (define nodegetbaseuri-17 (lambda () (let* ((doc (sdom:clone-node barfoo-base #t)) (plist (sdom:get-elements-by-tag-name doc "p")) (pelem (list-ref plist 0)) (textnode (sdom:get-dom-property pelem "sdom:first-child")) (baseuri (sdom:get-dom-property textnode "sdom:base-uri"))) (if baseuri (throw #t "base URI for text should be null") #t)))) (define nodegetbaseuri-18 (lambda () (let* ((doc (sdom:clone-node barfoo-base #t)) (blist (sdom:get-elements-by-tag-name doc "body")) (belem (list-ref blist 0)) (comment (sdom:create-node doc sdom:node-type-comment "BLAH"))) (sdom:append-child! belem comment) (if (sdom:get-dom-property comment "sdom:base-uri") (throw #t "base URI for comment should be null") #t)))) (define nodegettextcontent-1 (lambda () (let* ((doc (sdom:clone-node hc-staff #t))) (if (sdom:get-dom-property doc "sdom:text-content") (throw #t "text content for document node should be null") #t)))) (define nodegettextcontent-2 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (docelem (sdom:get-dom-property doc "sdom:document-element")) (rootns (sdom:get-dom-property docelem "sdom:namespace-uri")) (rootname (sdom:get-dom-property docelem "sdom:tag-name")) (newdoc (sdom:create-document rootname '() rootns))) (if (sdom:get-dom-property newdoc "sdom:text-content") (throw #t "text content for document node should be null") #t)))) (define nodegettextcontent-6 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (elemlist (sdom:get-elements-by-tag-name doc "acronym")) (elem (list-ref elemlist 0)) (attr (sdom:get-attribute-node elem "title"))) (if (not (equal? "Yes" (sdom:get-dom-property attr "sdom:text-content"))) (throw #t "text content should equal attribute value") #t)))) (define nodegettextcontent-7 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (elemlist (sdom:get-elements-by-tag-name doc "p")) (elem (list-ref elemlist 0))) (sdom:set-attribute! elem "xml:lang" "en-US" xmlns) (let ((attr (sdom:get-attribute-node elem "lang" xmlns))) (if (not (equal? "en-US" (sdom:get-dom-property attr "sdom:text-content"))) (throw #t "text content should equal attribute value") #t))))) (define nodegettextcontent-8 (lambda () (let* ((doc (sdom:clone-node barfoo #t)) (elem (sdom:create-node doc sdom:node-type-element "p" xhtmlns)) (att (sdom:create-node doc sdom:node-type-attr "xml:lang" xmlns))) (sdom:set-attribute-node! elem att) (if (not (equal? (sdom:get-dom-property att "sdom:text-content") "")) (throw #t "text content should be nothing on childless attr") #t)))) (define nodegettextcontent-9 (lambda () (let* ((doc (sdom:clone-node barfoo #t)) (elem (sdom:create-node doc sdom:node-type-element "p" xhtmlns)) (txt (sdom:create-node doc sdom:node-type-text "Replacement Text"))) (sdom:append-child! elem txt) (if (not (equal? (sdom:get-dom-property txt "sdom:text-content") "Replacement Text")) (throw #t "text content should be value of text node") #t)))) (define nodegettextcontent-10 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (elemlist (sdom:get-elements-by-tag-name doc "em")) (elem (list-ref elemlist 0)) (txt (sdom:get-dom-property elem "sdom:first-child"))) (if (not (equal? (sdom:get-dom-property txt "sdom:text-content") "EMP0001")) (throw #t "text content should be value of text node") #t)))) (define nodegettextcontent-11 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (cdata (sdom:create-node doc sdom:node-type-cdata-section "FOO"))) (if (not (equal? (sdom:get-dom-property cdata "sdom:text-content") "FOO")) (throw #t "text content should be value of cdata section") #t)))) (define nodegettextcontent-12 (lambda () (let* ((doc (sdom:clone-node barfoo #t)) (elem (sdom:create-node doc sdom:node-type-element "body" xhtmlns)) (comment (sdom:create-node doc sdom:node-type-comment "Comment"))) (sdom:append-child! elem comment) (if (not (equal? (sdom:get-dom-property comment "sdom:text-content") "Comment")) (throw #t "text content should be value of comment") #t)))) (define nodegettextcontent-13 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (elemlist (sdom:get-elements-by-tag-name doc "strong")) (elem (list-ref elemlist 0)) (cdata (sdom:create-node doc sdom:node-type-cdata-section "FOO"))) (sdom:append-child! elem cdata) (if (not (equal? (sdom:get-dom-property elem "sdom:text-content") "Margaret MartinFOO")) (throw #t "text content should be concat of children") #t)))) (define nodegettextcontent-14 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (elemlist (sdom:get-elements-by-tag-name doc "p")) (elem (list-ref elemlist 0))) (if (not (equal? (sdom:get-dom-property elem "sdom:text-content") (string-append "EMP0001Margaret MartinAccountant56,000" "Female1230 North Ave. Dallas, Texas " "98551"))) (throw #t "text content should be concat of children") #t)))) (define nodegettextcontent-19 (lambda () (let* ((doc (sdom:clone-node barfoo #t)) (elemlist (sdom:get-elements-by-tag-name doc "body")) (elem (list-ref elemlist 0))) (if (not (equal? (sdom:get-dom-property elem "sdom:text-content") "bar")) (throw #t "text content should ignore element whitespace") #t)))) (define nodegetuserdata-1 (lambda () (let* ((doc (sdom:clone-node hc-staff #t))) (if (sdom:get-user-data doc "key1") (throw #t "unset userdata key should be null") #t)))) (define nodegetuserdata-3 (lambda () (let* ((doc (sdom:clone-node barfoo #t)) (elem (sdom:create-node doc sdom:node-type-element "body" xhtmlns))) (sdom:set-user-data! doc "something" elem '()) (if (not (sdom:same-node? elem (sdom:get-user-data doc "something"))) (throw #t "user data should preserve node data") #t)))) (define nodegetuserdata-6 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (txt (sdom:create-node doc sdom:node-type-text "TEXT"))) (if (sdom:get-user-data txt "") (throw #t "unset userdata should be null on new text node") #t)))) (define nodegetuserdata-7 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (pi (sdom:create-node doc sdom:node-type-processing-instruction "PITARGET" "PIDATA"))) (sdom:set-user-data! pi "key" pi '()) (if (not (sdom:same-node? pi (sdom:get-user-data pi "key"))) (throw #t "should be able to set node as its own user data") #t)))) (define nodeinsertbefore-1 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (docelem (sdom:get-dom-property doc "sdom:document-element")) (newcomment (sdom:create-node doc sdom:node-type-comment "Comment")) (newpi (sdom:create-node doc sdom:node-type-processing-instruction "PITarget" "PIData"))) (sdom:insert-before! doc newcomment docelem) (if (not (equal? (sdom:get-dom-property (sdom:insert-before! doc newcomment docelem) "sdom:data") "Comment")) (throw #t "inserting node should not change value")) (sdom:insert-before! doc newpi newcomment) (if (not (equal? (sdom:get-dom-property (sdom:insert-before! doc newpi docelem) "sdom:target") "PITarget")) (throw #t "inserting node should not change value") #t)))) (define nodeinsertbefore-6 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (docelem (sdom:get-dom-property doc "sdom:document-element")) (rootns (sdom:get-dom-property docelem "sdom:namespace-uri")) (roottagname (sdom:get-dom-property docelem "sdom:tag-name")) (newelem (sdom:create-node doc sdom:node-type-element roottagname rootns))) (sdom:catch 'sdom:exception (lambda () (sdom:insert-before! doc newelem docelem) (throw #t "exception should be thrown on previous line")) (lambda exn (if (not (and (list? exn) (memv (cadr exn) (list 3 9)))) (throw #t "exception did not have correct code")))) #t))) (define nodeinsertbefore-7 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (docalt (sdom:clone-node hc-staff #t)) (docelem (sdom:get-dom-property doc "sdom:document-element")) (newcomment (sdom:create-node docalt sdom:node-type-comment "Comment")) (success #f)) (sdom:catch 'sdom:exception (lambda () (sdom:insert-before! doc newcomment docelem)) (lambda exn (if (and (list? exn) (eqv? (cadr exn) sdom:exception-code-wrong-document-err)) (set! success #t)))) (if (not success) (throw #t "exception should be thrown when documents do not match") #t)))) (define nodeinsertbefore-8 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (docalt (sdom:clone-node hc-staff #t)) (docelem (sdom:get-dom-property docalt "sdom:document-element")) (newcomment (sdom:create-node doc sdom:node-type-comment "Comment"))) (sdom:catch 'sdom:exception (lambda () (sdom:insert-before! doc newcomment docelem)) (lambda exn (if (not (and (list? exn) (eqv? (cadr exn) sdom:exception-code-not-found-err))) (throw #t "not-found-err should be thrown on mismatch")))) #t))) (define nodeinsertbefore-9 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (newcomment (sdom:create-node doc sdom:node-type-comment "Comment"))) (sdom:append-child! doc newcomment) (let* ((docfrag (sdom:create-node doc sdom:node-type-document-fragment)) (insertcomment (sdom:create-node doc sdom:node-type-comment "insertComment"))) (sdom:append-child! docfrag insertcomment) (sdom:insert-before! doc docfrag newcomment) (let* ((comment (sdom:get-dom-property newcomment "sdom:previous-sibling")) (data (sdom:get-dom-property comment "sdom:data"))) (if (not (equal? data "insertComment")) (throw #t "sequential insertions should produce desired order") #t)))))) (define nodeinsertbefore-10 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (docelem (sdom:get-dom-property doc "sdom:document-element")) (rootns (sdom:get-dom-property docelem "sdom:namespace-uri")) (tagname (sdom:get-dom-property docelem "sdom:tag-name")) (elemlist (sdom:get-elements-by-tag-name doc "p")) (elem (list-ref elemlist 0)) (newelem (sdom:create-node doc sdom:node-type-element tagname rootns))) (sdom:catch 'sdom:exception (lambda () (sdom:insert-before! doc newelem elem) (throw #t "exception should have been thrown")) (lambda exn (if (not (memv (cadr exn) (list 3 8 9))) (throw #t "wrong exception type thrown")))) #t))) (define nodeinsertbefore-11 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (docfrag (sdom:create-node doc sdom:node-type-document-fragment)) (elem (sdom:create-node doc sdom:node-type-element "body" xhtmlns)) (pi (sdom:create-node doc sdom:node-type-processing-instruction "PITarget" "PIData")) (comment (sdom:create-node doc sdom:node-type-comment "Comment")) (txt (sdom:create-node doc sdom:node-type-text "Text")) (cdata (sdom:create-node doc sdom:node-type-cdata-section "CDATA")) (eref (sdom:create-node doc sdom:node-type-entity-reference "alpha"))) (sdom:append-child! docfrag elem) (sdom:append-child! docfrag pi) (sdom:append-child! docfrag comment) (sdom:append-child! docfrag txt) (sdom:append-child! docfrag cdata) (sdom:append-child! docfrag eref) (if (not (equal? (sdom:get-dom-property (sdom:insert-before! docfrag comment pi) "sdom:data") "Comment")) (throw #t "should be able to reinsert comment before PI")) (if (not (equal? (sdom:get-dom-property (sdom:insert-before! docfrag txt comment) "sdom:data") "Text")) (throw #t "should be able to reinsert text node before comment")) (if (not (equal? (sdom:get-dom-property (sdom:insert-before! docfrag cdata txt) "sdom:data") "CDATA")) (throw #t "should be able to reinsert cdata before text node")) (if (not (equal? (sdom:get-dom-property (sdom:insert-before! docfrag eref cdata) "sdom:node-name") "alpha")) (throw #t "should be able to reinsert entity ref before cdata")) #t))) (define nodeinsertbefore-12 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (docfrag (sdom:create-node doc sdom:node-type-document-fragment)) (docfragnew (sdom:create-node doc sdom:node-type-document-fragment)) (elem (sdom:create-node doc sdom:node-type-element "dom3:elem" "http://www.w3.org/DOM/Test"))) (sdom:append-child! docfrag elem) (sdom:insert-before! docfrag docfragnew elem) (if (not (equal? (sdom:get-dom-property (sdom:get-dom-property docfrag "sdom:last-child") "sdom:node-name") "dom3:elem")) (throw #t "inserting empty doc fragment should have no effect") #t)))) (define nodeinsertbefore-13 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (docelem (sdom:get-dom-property doc "sdom:document-element")) (rootns (sdom:get-dom-property docelem "sdom:namespace-uri")) (tagname (sdom:get-dom-property docelem "sdom:tag-name")) (docalt (sdom:clone-node hc-staff #t)) (docfrag (sdom:create-node doc sdom:node-type-document-fragment)) (elem (sdom:create-node doc sdom:node-type-element tagname rootns)) (elemalt (sdom:create-node docalt sdom:node-type-element tagname rootns))) (sdom:append-child! docfrag elem) (sdom:catch 'sdom:exception (lambda () (sdom:insert-before! docfrag elemalt elem) (throw #t "exception should have been thrown")) (lambda exn (if (not (eqv? (cadr exn) sdom:exception-code-wrong-document-err)) (throw error #t "wrong exception type thrown")))) #t))) (define nodeinsertbefore-16 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (childlist (sdom:get-elements-by-tag-name doc "p")) (elem (list-ref childlist 0)) (first-child (sdom:get-dom-property elem "sdom:first-child")) (ref-elem (sdom:get-dom-property first-child "sdom:next-sibling")) (newelem (sdom:create-node doc sdom:node-type-element "xhtml:br" xhtmlns))) (sdom:insert-before! elem newelem ref-elem) (let* ((childlist (sdom:get-elements-by-tag-name doc "p")) (elem (list-ref childlist 0)) (first-child (sdom:get-dom-property elem "sdom:first-child"))) (if (not (equal? (sdom:get-dom-property (sdom:get-dom-property first-child "sdom:next-sibling") "sdom:node-name") "xhtml:br")) (throw #t "should be able to insert new node before first child") #t))))) (define nodeinsertbefore-17 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (childlist (sdom:get-elements-by-tag-name doc "p" "*")) (elem (list-ref childlist 0)) (refnode (sdom:get-dom-property elem "sdom:first-child")) (newtext (sdom:create-node doc sdom:node-type-text "newText"))) (sdom:insert-before! elem newtext refnode) (if (not (equal? (sdom:get-dom-property (sdom:get-dom-property elem "sdom:first-child") "sdom:node-name") "#text")) (throw #t "should be able to insert text node before first child") #t)))) (define nodeinsertbefore-18 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (element (sdom:create-node doc sdom:node-type-element "element")) (newelem (sdom:create-node doc sdom:node-type-element "dom3:elem" "http://www.w3.org/DOM")) (newcomment (sdom:create-node doc sdom:node-type-comment "Comment")) (newcdata (sdom:create-node doc sdom:node-type-cdata-section "CDATASection")) (newpi (sdom:create-node doc sdom:node-type-processing-instruction "target" "data"))) (sdom:append-child! element newelem) (sdom:append-child! element newcomment) (sdom:append-child! element newpi) (sdom:append-child! element newcdata) (sdom:insert-before! element newcomment newelem) (if (not (equal? (sdom:get-dom-property (sdom:get-dom-property element "sdom:first-child") "sdom:data") "Comment")) (throw #t "should be able to reinsert comment node") #t)))) (define nodeinsertbefore-19 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (childlist (sdom:get-elements-by-tag-name doc "var")) (elem (list-ref childlist 0)) (refnode (sdom:get-dom-property elem "sdom:first-child")) (newnode (sdom:create-node doc sdom:node-type-entity-reference "alpha"))) (if (not (equal? (sdom:get-dom-property (sdom:insert-before! elem newnode refnode) "sdom:node-name") "alpha")) (throw #t "should be able to insert entity ref before node") #t)))) (define nodeinsertbefore-20 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (childlist (sdom:get-elements-by-tag-name doc "var")) (elem (list-ref childlist 0)) (refnode (sdom:get-dom-property elem "sdom:first-child")) (newnode (sdom:create-node doc sdom:node-type-attr "xml:lang" xmlns))) (sdom:catch 'sdom:exception (lambda () (sdom:insert-before! elem newnode refnode) (throw #t "exception should have been thrown")) (lambda exn (if (not (eqv? (cadr exn) sdom:exception-code-hierarchy-request-err)) (throw #t "wrong exception type thrown")))) #t))) (define nodeinsertbefore-21 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (childlist (sdom:get-elements-by-tag-name doc "var")) (elem (list-ref childlist 0)) (refnode (sdom:get-dom-property elem "sdom:first-child")) (newnode (sdom:get-dom-property elem "sdom:parent-node"))) (sdom:catch 'sdom:exception (lambda () (sdom:insert-before! elem newnode refnode) (throw #t "exception should have been thrown")) (lambda exn (if (not (eqv? (cadr exn) sdom:exception-code-hierarchy-request-err)) (throw #t "wrong exception type thrown")))) #t))) (define nodeinsertbefore-22 (lambda () (let* ((doc (sdom:clone-node barfoo #t)) (elem (sdom:create-node doc sdom:node-type-element "xhtml:body" xhtmlns)) (refnode (sdom:create-node doc sdom:node-type-element "xhtml:a" xhtmlns)) (ancestor (sdom:create-node doc sdom:node-type-element "xhtml:p" xhtmlns))) (sdom:append-child! elem refnode) (sdom:append-child! ancestor elem) (sdom:catch 'sdom:exception (lambda () (sdom:insert-before! elem ancestor refnode) (throw #t "exception should have been thrown")) (lambda exn (if (not (eqv? (cadr exn) sdom:exception-code-hierarchy-request-err)) (throw #t "wrong exception type thrown")))) #t))) (define nodeinsertbefore-23 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (doc2 (sdom:clone-node hc-staff #t)) (elem (sdom:create-node doc sdom:node-type-element "xhtml:body" xhtmlns)) (refnode (sdom:create-node doc sdom:node-type-element "xhtml:p" xhtmlns)) (newnode (sdom:create-node doc2 sdom:node-type-text "Text"))) (sdom:append-child! elem refnode) (sdom:catch 'sdom:exception (lambda () (sdom:insert-before! elem newnode refnode) (throw #t "exception should have been thrown")) (lambda exn (if (not (eqv? (cadr exn) sdom:exception-code-wrong-document-err)) (throw #t "wrong exception type thrown")))) #t))) (define nodeinsertbefore-24 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (elem (sdom:create-node doc sdom:node-type-element "xhtml:p" xhtmlns)) (refnode (sdom:create-node doc sdom:node-type-cdata-section "CDATASection")) (newnode (sdom:create-node doc sdom:node-type-comment "Comment"))) (sdom:catch 'sdom:exception (lambda () (sdom:insert-before! elem newnode refnode) (throw #t "exception should have been thrown")) (lambda exn (if (not (eqv? (cadr exn) sdom:exception-code-not-found-err)) (throw #t "wrong exception type thrown")))) #t))) (define nodeisequalnode-1 (lambda () (let* ((doc1 (sdom:clone-node hc-staff #t)) (doc2 (sdom:clone-node hc-staff #t))) (if (not (sdom:equal-node? doc1 doc2)) (throw #t "equal documents should be evaluated as equal nodes") #t)))) (define nodeisequalnode-2 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (docelem (sdom:get-dom-property doc "sdom:document-element")) (rootns (sdom:get-dom-property docelem "sdom:namespace-uri")) (rootname (sdom:get-dom-property docelem "sdom:tag-name")) (doc1 (sdom:create-document rootname '() rootns)) (doc2 (sdom:create-document rootname '() rootns))) (if (not (sdom:equal-node? doc1 doc2)) (throw #t "newly-created equal documents should be evaluated equal") #t)))) (define nodeisequalnode-4 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (elem (sdom:create-node doc sdom:node-type-element "xhtml:p" xhtmlns)) (ownerdoc (sdom:get-dom-property elem "sdom:owner-document"))) (if (not (sdom:equal-node? doc ownerdoc)) (throw #t "owner document and document should be equal nodes") #t)))) (define nodeisequalnode-6 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (elem1 (sdom:create-node doc sdom:node-type-element "xhtml:html" xhtmlns)) (elem2 (sdom:create-node doc sdom:node-type-element "xhtml:html" xhtmlns))) (if (not (sdom:equal-node? elem1 elem2)) (throw #t "newly-created equal elements should be evaluated equal") #t)))) (define nodeisequalnode-7 (lambda () (let* ((doc1 (sdom:clone-node hc-staff #t)) (doc2 (sdom:clone-node hc-staff #t)) (elem1 (sdom:create-node doc1 sdom:node-type-element "xhtml:html" xhtmlns)) (elem2 (sdom:create-node doc2 sdom:node-type-element "xhtml:html" xhtmlns))) (if (not (sdom:equal-node? elem1 elem2)) (throw #t "equal elements should be equal across equal documents") #t)))) (define nodeisequalnode-8 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (elist (sdom:get-elements-by-tag-name doc "em")) (elem1 (list-ref elist 0)) (elem2 (sdom:create-node doc sdom:node-type-element "em" xhtmlns)) (text (sdom:create-node doc sdom:node-type-text "EMP0001"))) (sdom:append-child! elem2 text) (if (not (sdom:equal-node? elem1 elem2)) (throw #t "equal node hierarchies should be evaluated equal") #t)))) (define nodeisequalnode-9 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (docelem (sdom:get-dom-property doc "sdom:document-element")) (rootns (sdom:get-dom-property docelem "sdom:namespace-uri")) (rootname (sdom:get-dom-property docelem "sdom:tag-name")) (newdoc (sdom:create-document rootname '() rootns)) (elist (sdom:get-elements-by-tag-name doc "em")) (elem1 (list-ref elist 0)) (elem2 (sdom:create-node doc sdom:node-type-element "em" xhtmlns)) (text (sdom:create-node doc sdom:node-type-text "EMP0001"))) (sdom:append-child! elem2 text) (if (not (sdom:equal-node? elem1 elem2)) (throw #t "equal node hierarchies should be evaluated equal") #t)))) (define nodeisequalnode-11 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (docelem (sdom:get-dom-property doc "sdom:document-element")) (rootns (sdom:get-dom-property docelem "sdom:namespace-uri")) (rootname (sdom:get-dom-property docelem "sdom:tag-name")) (newdoc (sdom:create-document rootname '() rootns)) (elist (sdom:get-elements-by-tag-name doc "p")) (elem1 (list-ref elist 0)) (elem2 (sdom:import-node newdoc elem1 #f))) (if (sdom:equal-node? elem1 elem2) (throw #t "unequal node hierarchies should not be evaluated equal")) (let* ((dupdoc (sdom:clone-node hc-staff #t)) (elem4 (sdom:import-node dupdoc elem1 #t))) (if (not (sdom:equal-node? elem1 elem4)) (throw #t "equal node hierarchies should be evaluated equal") #t))))) (define nodeisequalnode-12 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (elem1 (sdom:get-dom-property doc "sdom:document-element")) (elem2 (sdom:get-dom-property doc "sdom:document-element"))) (if (not (sdom:equal-node? elem1 elem2)) (throw #t "document elements of same node should be equal") #t)))) (define nodeisequalnode-13 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (docelem (sdom:get-dom-property doc "sdom:document-element")) (rootns (sdom:get-dom-property docelem "sdom:namespace-uri")) (rootname (sdom:get-dom-property docelem "sdom:tag-name")) (newdoc (sdom:create-document rootname '() rootns)) (elist (sdom:get-elements-by-tag-name doc "p")) (elem1 (list-ref elist 0)) (elem2 (sdom:clone-node elem1 #f))) (if (sdom:equal-node? elem1 elem2) (throw #t "unequal node hierarchies should not be evaluated equal")) (let ((elem3 (sdom:clone-node elem1 #t))) (if (not (sdom:equal-node? elem1 elem3)) (throw #t "equal node hierarchies should be evaluated equal") #t))))) (define nodeisequalnode-15 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (elist (sdom:get-elements-by-tag-name doc "acronym")) (addrelement (list-ref elist 0)) (attr1 (sdom:get-attribute-node addrelement "title")) (attr2 (sdom:create-node doc sdom:node-type-attr "title" '()))) (sdom:set-dom-property! attr2 "sdom:value" "Yes") (if (not (sdom:equal-node? attr1 attr2)) (throw #t "equal attrs should be evaluated equal") #t)))) (define nodeisequalnode-17 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (docelem (sdom:get-dom-property doc "sdom:document-element")) (rootns (sdom:get-dom-property docelem "sdom:namespace-uri")) (rootname (sdom:get-dom-property docelem "sdom:tag-name")) (newdoc (sdom:create-document rootname '() rootns)) (attr1 (sdom:create-node doc sdom:node-type-attr "root" '())) (attr2 (sdom:import-node newdoc attr1 #t))) (if (not (sdom:equal-node? attr1 attr2)) (throw #t "equal attrs should be evaluated equal across documents") #t)))) (define nodeisequalnode-18 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (docelem (sdom:get-dom-property doc "sdom:document-element")) (rootname (sdom:get-dom-property docelem "sdom:tag-name")) (rootns (sdom:get-dom-property docelem "sdom:namespace-uri")) (newdoc (sdom:create-document rootname '() rootns)) (attr1 (sdom:create-node doc sdom:node-type-attr "title" '())) (attr2 (sdom:adopt-node! newdoc attr1))) (if (not (sdom:equal-node? attr1 attr2)) (throw #t "equal attrs should be evaluated equal across documents") #t)))) (define nodeisequalnode-19 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (attr1 (sdom:create-node doc sdom:node-type-attr "lang" xmlns)) (attr2 (sdom:create-node doc sdom:node-type-attr "lang" '()))) (if (sdom:equal-node? attr1 attr2) (throw #t "namespace inequality should preclude node equality") #t)))) (define nodeisequalnode-20 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (elem1 (sdom:create-node doc sdom:node-type-element "xhtml:html" xhtmlns)) (attr1 (sdom:create-node doc sdom:node-type-attr "xhtml:html" xhtmlns))) (if (sdom:equal-node? elem1 attr1) (throw #t "node type inequality should preclude node equality") #t)))) (define nodeisequalnode-28 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (text1 (sdom:create-node doc sdom:node-type-text "")) (text2 (sdom:create-node doc sdom:node-type-text "")) (text3 (sdom:create-node doc sdom:node-type-text "#Text"))) (if (not (sdom:equal-node? text1 text2)) (throw #t "null text node text should not preclude equality")) (if (sdom:equal-node? text1 text3) (throw #t "different text node text should preclude equality") #t)))) (define nodeisequalnode-29 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (comment1 (sdom:create-node doc sdom:node-type-comment "comment")) (comment2 (sdom:create-node doc sdom:node-type-comment "comment")) (comment3 (sdom:create-node doc sdom:node-type-comment "#Comment"))) (if (not (sdom:equal-node? comment1 comment2)) (throw #t "comments with equal comment text should be equal")) (if (sdom:equal-node? comment1 comment3) (throw #t "comments with unequal comment text should be unequal") #t)))) (define nodeisequalnode-31 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (cdata1 (sdom:create-node doc sdom:node-type-cdata-section "cdata")) (cdata2 (sdom:create-node doc sdom:node-type-cdata-section "cdata")) (cdata3 (sdom:create-node doc sdom:node-type-cdata-section "#CDATASection"))) (if (not (sdom:equal-node? cdata1 cdata2)) (throw #t "cdata nodes with same content should be evaluated equal")) (if (sdom:equal-node? cdata1 cdata3) (throw #t "cdata nodes with different content should not be equal") #t)))) (define nodeisequalnode-32 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (pi1 (sdom:create-node doc sdom:node-type-processing-instruction "Target1" "pi")) (pi2 (sdom:create-node doc sdom:node-type-processing-instruction "Target1" "pi")) (pi3 (sdom:create-node doc sdom:node-type-processing-instruction "Target1" "#ProcessingInstruction"))) (if (not (sdom:equal-node? pi1 pi2)) (throw #t "PIs with same target and data should be evaluated equal")) (if (sdom:equal-node? pi1 pi3) (throw #t "PIs with different target and data should not be equal") #t)))) (define nodelookupnamespaceuri-1 (lambda () (let* ((doc (sdom:clone-node barfoo-nodefaultns #t))) (if (sdom:get-dom-property doc "sdom:namespace-uri") (throw #t "namespace uri should be null when there is no default") #t)))) (define nodelookupnamespaceuri-2 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (docelem (sdom:get-dom-property doc "sdom:document-element")) (rootns (sdom:get-dom-property docelem "sdom:namespace-uri")) (rootname (sdom:get-dom-property docelem "sdom:local-name")) (qname (string-append "dom3:" rootname)) (newdoc (sdom:create-document qname '() rootns)) (namespaceuri (sdom:lookup-namespace-uri newdoc "dom3"))) (if (not (equal? rootns namespaceuri)) (throw #t "namespace URIs should be portable across prefixes") #t)))) (define nodelookupnamespaceuri-5 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (docelem (sdom:get-dom-property doc "sdom:document-element")) (rootns (sdom:get-dom-property docelem "sdom:namespace-uri")) (rootname (sdom:get-dom-property docelem "sdom:local-name")) (qname (string-append "dom3:" rootname)) (newdoc (sdom:create-document qname '() rootns)) (elem (sdom:get-dom-property newdoc "sdom:document-element"))) (if (not (equal? (sdom:lookup-namespace-uri elem "dom3") rootns)) (throw #t "namespace URIs should be portable across prefixes") #t)))) (define noderemovechild-1 (lambda () (let* ((doc (sdom:clone-node hc-staff #t))) (sdom:catch 'sdom:exception (lambda () (sdom:remove-child! doc doc) (throw #t "exception should have been thrown")) (lambda exn (if (not (eqv? (cadr exn) sdom:exception-code-not-found-err)) (throw #t "wrong exception type thrown")))) #t))) (define noderemovechild-2 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (docelem (sdom:get-dom-property doc "sdom:document-element")) (rootns (sdom:get-dom-property docelem "sdom:namespace-uri")) (rootname (sdom:get-dom-property docelem "sdom:tag-name")) (newdoc (sdom:create-document rootname '() rootns))) (sdom:catch 'sdom:exception (lambda () (sdom:remove-child! doc newdoc) (throw #t "exception should have been thrown")) (lambda exn (if (not (eqv? (cadr exn) sdom:exception-code-not-found-err)) (throw #t "wrong exception type thrown")))) #t))) (define noderemovechild-3 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (docelem (sdom:get-dom-property doc "sdom:document-element"))) (sdom:remove-child! doc docelem) (if (sdom:get-dom-property doc "sdom:document-element") (throw #t "removing child should remove it from document")) (sdom:catch 'sdom:exception (lambda () (sdom:remove-child! docelem doc) (throw #t "exception should have been thrown")) (lambda exn (if (not (eqv? (cadr exn) sdom:exception-code-not-found-err)) (throw #t "wrong exception type thrown")))) #t))) (define noderemovechild-8 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (comment (sdom:create-node doc sdom:node-type-comment "Comment"))) (sdom:append-child! doc comment) (if (not (equal? (sdom:get-dom-property (sdom:remove-child! doc comment) "sdom:data") "Comment")) (throw #t "removing child should not affect data value") #t)))) (define noderemovechild-9 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (pi (sdom:create-node doc sdom:node-type-processing-instruction "PIT" "PID"))) (sdom:append-child! doc pi) (if (not (equal? (sdom:get-dom-property (sdom:remove-child! doc pi) "sdom:target") "PIT")) (throw #t "removing child should not affect PI target") #t)))) (define noderemovechild-10 (lambda () (let* ((doc (sdom:clone-node barfoo #t)) (docfrag (sdom:create-node doc sdom:node-type-document-fragment)) (elem (sdom:create-node doc sdom:node-type-element "dom3:br" xhtmlns))) (sdom:append-child! docfrag elem) (if (not (equal? (sdom:get-dom-property (sdom:remove-child! docfrag elem) "sdom:node-name") "dom3:br")) (throw #t "removing child should not affect element name") #t)))) (define noderemovechild-11 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (docfrag (sdom:create-node doc sdom:node-type-document-fragment)) (txt (sdom:create-node doc sdom:node-type-text "TEXT"))) (sdom:append-child! docfrag txt) (sdom:remove-child! docfrag txt) (if (sdom:get-dom-property docfrag "sdom:first-child") (throw #t "should be able to remove text node from fragment") #t)))) (define noderemovechild-12 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (docfrag (sdom:create-node doc sdom:node-type-document-fragment)) (eref (sdom:create-node doc sdom:node-type-entity-reference "ent1"))) (sdom:append-child! docfrag eref) (sdom:remove-child! docfrag eref) (if (sdom:get-dom-property docfrag "sdom:first-child") (throw #t "should be able to remove entity reference from fragment")) (sdom:catch 'sdom:exception (lambda () (sdom:remove-child! eref docfrag) (throw #t "should have thrown exception")) (lambda exn (if (not (memv (cadr exn) (list 8 7))) (throw #t "wrong exception type thrown")))) #t))) (define noderemovechild-16 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (parentlist (sdom:get-elements-by-tag-name doc "em")) (child (list-ref parentlist 0)) (parent (sdom:get-dom-property child "sdom:parent-node"))) (if (not (equal? (sdom:get-dom-property (sdom:remove-child! parent child) "sdom:node-name") "em")) (throw #t "removing child should not affect node name")) (sdom:catch 'sdom:exception (lambda () (sdom:remove-child! child parent) (throw #t "should have thrown exception")) (lambda exn (if (not (eqv? (cadr exn) sdom:exception-code-not-found-err)) (throw #t "wrong exception type thrown")))) #t))) (define noderemovechild-17 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (parentlist (sdom:get-elements-by-tag-name doc "em")) (parent (list-ref parentlist 0)) (child (sdom:get-dom-property parent "sdom:first-child"))) (if (not (equal? (sdom:get-dom-property (sdom:remove-child! parent child) "sdom:node-value") "EMP0001")) (throw #t "removing text node should not affect node value")) (sdom:catch 'sdom:exception (lambda () (sdom:remove-child! child parent) (throw #t "should have thrown exception")) (lambda exn (if (not (eqv? (cadr exn) sdom:exception-code-not-found-err)) (throw #t "wrong exception type thrown")))) #t))) (define noderemovechild-20 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (parentlist (sdom:get-elements-by-tag-name doc "p")) (parent (list-ref parentlist 0)) (child (sdom:create-node doc sdom:node-type-element "dom3:br" xhtmlns))) (sdom:append-child! parent child) (if (not (equal? (sdom:get-dom-property (sdom:remove-child! parent child) "sdom:node-name") "dom3:br")) (throw #t "removing new node should not affect node name")) (let ((clonedchild (sdom:clone-node child #t))) (sdom:catch 'sdom:exception (lambda () (sdom:remove-child! parent clonedchild) (throw #t "exception should be thrown")) (lambda exn (if (not (eqv? (cadr exn) sdom:exception-code-not-found-err)) (throw #t "wrong exception type thrown")))) #t)))) (define noderemovechild-21 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (docelem (sdom:get-dom-property doc "sdom:document-element")) (parent (sdom:create-node doc sdom:node-type-element "dom3:p" xhtmlns)) (child (sdom:create-node doc sdom:node-type-element "dom3:br" xhtmlns))) (sdom:append-child! parent child) (sdom:append-child! docelem parent) (if (not (equal? (sdom:get-dom-property (sdom:remove-child! parent child) "sdom:node-name") "dom3:br")) (throw #t "removing document element should not affect node name")) (sdom:catch 'sdom:exception (lambda () (sdom:remove-child! docelem child) (throw #t "should have thrown exception")) (lambda exn (if (not (eqv? (cadr exn) sdom:exception-code-not-found-err)) (throw #t "wrong exception type thrown")))) #t))) (define noderemovechild-22 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (parent (sdom:create-node doc sdom:node-type-element "dom3:p" xhtmlns)) (child (sdom:create-node doc sdom:node-type-comment "DATA"))) (sdom:append-child! parent child) (if (not (equal? (sdom:get-dom-property (sdom:remove-child! parent child) "sdom:node-value") "DATA")) (throw #t "removing comment node should not affect node value")) (sdom:catch 'sdom:exception (lambda () (sdom:remove-child! parent child) (throw #t "should have thrown exception")) (lambda exn (if (not (eqv? (cadr exn) sdom:exception-code-not-found-err)) (throw #t "wrong exception type thrown")))) #t))) (define noderemovechild-23 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (parent (sdom:create-node doc sdom:node-type-element "dom3:p" xhtmlns)) (child (sdom:create-node doc sdom:node-type-processing-instruction "TARGET" "DATA"))) (sdom:append-child! parent child) (if (not (equal? (sdom:get-dom-property (sdom:remove-child! parent child) "sdom:target") "TARGET")) (throw #t "removing PI should not affect PI target")) (sdom:catch 'sdom:exception (lambda () (sdom:remove-child! parent child) (throw #t "should have thrown exception")) (lambda exn (if (not (eqv? (cadr exn) sdom:exception-code-not-found-err)) (throw #t "wrong exception type thrown")))) #t))) (define noderemovechild-28 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (parentlist (sdom:get-elements-by-tag-name doc "acronym")) (elem (list-ref parentlist 0)) (parent (sdom:get-attribute-node elem "title")) (child (sdom:get-dom-property parent "sdom:first-child"))) (if (not (equal? (sdom:get-dom-property (sdom:remove-child! parent child) "sdom:node-value") "Yes")) (throw #t "removing attr text should not affect node value")) (sdom:catch 'sdom:exception (lambda () (sdom:remove-child! child parent) (throw #t "should have thrown exception")) (lambda exn (if (not (eqv? (cadr exn) sdom:exception-code-not-found-err)) (throw #t "wrong exception type thrown")))) #t))) (define nodereplacechild-1 (lambda () (let* ((doc (sdom:clone-node hc-staff #t))) (sdom:catch 'sdom:exception (lambda () (sdom:replace-child! doc doc doc) (throw #t "should have thrown exception")) (lambda exn (if (not (memv (cadr exn) (list 3 8))) (throw #t "wrong exception type thrown")))) #t))) (define nodereplacechild-3 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (newdoc (sdom:create-document "dom3:doc" '() "http://www.w3.org/DOM"))) (sdom:catch 'sdom:exception (lambda () (sdom:replace-child! doc newdoc doc) (throw #t "should have thrown exception")) (lambda exn (if (not (memv (cadr exn) (list 3 4 8))) (throw #t "wrong exception type thrown")))) #t))) (define nodereplacechild-4 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (docelem (sdom:get-dom-property doc "sdom:document-element"))) (sdom:catch 'sdom:exception (lambda () (sdom:replace-child! doc doc docelem) (throw #t "should have thrown exception")) (lambda exn (if (not (memv (cadr exn) (list 3 8))) (throw #t "wrong exception type thrown")))) #t))) (define nodereplacechild-6 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (docelem (sdom:get-dom-property doc "sdom:document-element")) (childlist (sdom:get-elements-by-tag-name doc "p")) (elem (list-ref childlist 0))) (sdom:catch 'sdom:exception (lambda () (sdom:replace-child! doc elem docelem) (if (not (equal? (sdom:get-dom-property (sdom:get-dom-property doc "sdom:document-element") "sdom:node-name") "p")) (throw #t "replacing node should preserve node name"))) (lambda exn (if (not (eqv? (cadr exn) 9)) (throw #t "wrong exception type thrown")))) #t))) (define nodereplacechild-7 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (docelem (sdom:get-dom-property doc "sdom:document-element")) (rootname (sdom:get-dom-property docelem "sdom:tag-name")) (rootns (sdom:get-dom-property docelem "sdom:namespace-uri")) (elem (sdom:create-node doc sdom:node-type-element rootname rootns))) (sdom:catch 'sdom:exception (lambda () (sdom:replace-child! doc elem docelem) (if (not (equal? (sdom:get-dom-property (sdom:get-dom-property doc "sdom:document-element") "sdom:node-name") rootname)) (throw #t "failed replace should not affect node name"))) (lambda exn (if (not (eqv? (cadr exn) 9)) (throw #t "wrong exception type thrown")))) #t))) (define nodereplacechild-8 (lambda () (let* ((doc (sdom:clone-node barfoo #t)) (docelem (sdom:get-dom-property doc "sdom:document-element")) (rootname (sdom:get-dom-property docelem "sdom:tag-name")) (rootns (sdom:get-dom-property docelem "sdom:namespace-uri")) (doc2 (sdom:create-document rootname '() rootns)) (elem (sdom:create-node doc2 sdom:node-type-element rootname rootns))) (sdom:catch 'sdom:exception (lambda () (sdom:replace-child! doc elem docelem) (throw #t "should have thrown exception")) (lambda exn (if (not (memv (cadr exn) (list 4 9))) (throw #t "wrong exception type thrown")))) #t))) (define nodereplacechild-12 (lambda () (let* ((doc (sdom:clone-node barfoo #t)) (comment (sdom:create-node doc sdom:node-type-comment "dom3:doc")) (pi (sdom:create-node doc sdom:node-type-processing-instruction "PITarget" "PIData"))) (sdom:append-child! doc comment) (sdom:append-child! doc pi) (let ((rc (sdom:replace-child! doc comment pi))) (if (not rc) (throw #t "value of replaced child should not be null")) (if (not (equal? (sdom:get-dom-property rc "sdom:node-name") "PITarget")) (throw #t "replacement should not affect node name"))) (let ((lc (sdom:get-dom-property doc "sdom:last-child"))) (if (not lc) (throw #t "replacement should succeed")) (if (not (equal? (sdom:get-dom-property lc "sdom:node-name") "#comment")) (throw #t "replacement should not affect node name") #t))))) (define nodereplacechild-14 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (elem (sdom:create-node doc sdom:node-type-element "dom3:doc1elem" "http://www.w3.org/DOM/Test")) (newdoc (sdom:create-document "dom3:doc" '() "http://www.w3.org/DOM/Test")) (elem2 (sdom:create-node newdoc sdom:node-type-element "dom3:doc2elem" "http://www.w3.org/DOM/Test")) (docelem (sdom:get-dom-property newdoc "sdom:document-element"))) (let* ((elem3 (sdom:import-node newdoc elem #t))) (sdom:append-child! docelem elem3) (sdom:append-child! docelem elem2) (if (not (equal? (sdom:get-dom-property (sdom:replace-child! docelem elem3 elem2) "sdom:node-name") "dom3:doc2elem")) (throw #t "replacement should not affect node name") #t))))) (define nodereplacechild-15 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (docelem (sdom:get-dom-property doc "sdom:document-element")) (rootname (sdom:get-dom-property docelem "sdom:tag-name")) (rootns (sdom:get-dom-property docelem "sdom:namespace-uri")) (elem (sdom:create-node doc sdom:node-type-element rootname rootns)) (docfrag (sdom:create-node doc sdom:node-type-document-fragment)) (elem2 (sdom:create-node doc sdom:node-type-element rootname rootns))) (sdom:set-attribute! elem2 "title" "new element") (sdom:append-child! docfrag elem2) (if (not (equal? (sdom:get-attribute (sdom:replace-child! docfrag elem elem2) "title") "new element")) (throw #t "replacement should not affect attribute content") #t)))) (define nodereplacechild-16 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (elem (sdom:create-node doc sdom:node-type-element "dom3:p" xhtmlns)) (docfrag (sdom:create-node doc sdom:node-type-document-fragment)) (txt (sdom:create-node doc sdom:node-type-text "Comment"))) (sdom:append-child! docfrag txt) (sdom:append-child! docfrag elem) (if (not (equal? (sdom:get-dom-property (sdom:replace-child! docfrag txt elem) "sdom:node-name") "dom3:p")) (throw #t "replacement should not affect node name") #t)))) (define nodereplacechild-17 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (docfrag (sdom:create-node doc sdom:node-type-document-fragment)) (cmt (sdom:create-node doc sdom:node-type-comment "Comment")) (pi (sdom:create-node doc sdom:node-type-processing-instruction "target" "Comment"))) (sdom:append-child! docfrag pi) (sdom:append-child! docfrag cmt) (if (not (equal? (sdom:get-dom-property (sdom:replace-child! docfrag pi cmt) "sdom:data") "Comment")) (throw #t "replacement should not affect node data")) (if (not (equal? (sdom:get-dom-property (sdom:replace-child! docfrag cmt pi) "sdom:target") "target")) (throw #t "replacement should not affect PI target") #t)))) (define nodereplacechild-18 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (docfrag (sdom:create-node doc sdom:node-type-document-fragment)) (cdata (sdom:create-node doc sdom:node-type-cdata-section "CDATASection")) (entref (sdom:create-node doc sdom:node-type-entity-reference "alpha"))) (sdom:append-child! docfrag entref) (sdom:append-child! docfrag cdata) (if (not (equal? (sdom:get-dom-property (sdom:replace-child! docfrag entref cdata) "sdom:node-value") "CDATASection")) (throw #t "replacement should not affect node value")) (if (not (equal? (sdom:get-dom-property (sdom:replace-child! docfrag cdata entref) "sdom:node-name") "alpha")) (throw #t "replacement should not affect node name") #t)))) (define nodereplacechild-19 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (docfrag (sdom:create-node doc sdom:node-type-document-fragment)) (elem (sdom:create-node doc sdom:node-type-element "dom3:p" xhtmlns)) (entref (sdom:create-node doc sdom:node-type-entity-reference "alpha"))) (sdom:append-child! elem entref) (sdom:append-child! docfrag elem) (if (not (equal? (sdom:get-dom-property (sdom:replace-child! docfrag entref elem) "sdom:node-name") "dom3:p")) (throw #t "replacement should not affect node name") #t)))) (define nodereplacechild-20 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (docfrag (sdom:create-node doc sdom:node-type-document-fragment)) (elem (sdom:create-node doc sdom:node-type-element "dom3:p" xhtmlns)) (attr (sdom:create-node doc sdom:node-type-attr "xml:lang" xmlns))) (sdom:append-child! docfrag elem) (sdom:catch 'sdom:exception (lambda () (sdom:replace-child! docfrag attr elem) (throw #t "exception should have been thrown")) (lambda exn (if (not (eqv? (cadr exn) sdom:exception-code-hierarchy-request-err)) (throw #t "wrong exception type thrown")))) #t))) (define nodereplacechild-22 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (elem (sdom:create-node doc sdom:node-type-element "dom3:p" xhtmlns)) (entrefmain (sdom:create-node doc sdom:node-type-entity-reference "delta")) (entref (sdom:create-node doc sdom:node-type-entity-reference "beta"))) (sdom:append-child! elem entref) (sdom:catch 'sdom:exception (lambda () (sdom:replace-child! entrefmain elem entref) (throw #t "exception should have been thrown")) (lambda exn (if (not (eqv? (cadr exn) sdom:exception-code-no-modification-allowed-err)) (throw #t "wrong exception type thrown")))) (sdom:catch 'sdom:exception (lambda () (sdom:replace-child! entrefmain entref elem) (throw #t "exception should have been thrown")) (lambda exn (if (not (eqv? (cadr exn) sdom:exception-code-no-modification-allowed-err)) (throw #t "wrong exception type thrown")))) (sdom:catch 'sdom:exception (lambda () (sdom:replace-child! entrefmain entrefmain entref) (throw #t "exception should have been thrown")) (lambda exn (if (not (eqv? (cadr exn) sdom:exception-code-hierarchy-request-err)) (throw #t "wrong exception type thrown")))) #t))) (define nodereplacechild-23 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (elem (sdom:create-node doc sdom:node-type-element "dom3:p" xhtmlns)) (entref (sdom:create-node doc sdom:node-type-entity-reference "delta")) (txt (sdom:create-node doc sdom:node-type-text "Text")) (comment (sdom:create-node doc sdom:node-type-comment "Comment")) (cdata (sdom:create-node doc sdom:node-type-cdata-section "CDATASection")) (pi (sdom:create-node doc sdom:node-type-processing-instruction "target" "data"))) (sdom:append-child! elem entref) (sdom:append-child! elem txt) (sdom:append-child! elem comment) (sdom:append-child! elem pi) (sdom:append-child! elem cdata) (sdom:catch 'sdom:exception (lambda () (sdom:replace-child! entref cdata elem) (throw #t "exception should have been thrown")) (lambda exn (if (not (eqv? (cadr exn) sdom:exception-code-no-modification-allowed-err)) (throw #t "wrong exception type thrown")))) (sdom:catch 'sdom:exception (lambda () (sdom:replace-child! entref pi cdata) (throw #t "exception should have been thrown")) (lambda exn (if (not (eqv? (cadr exn) sdom:exception-code-no-modification-allowed-err)) (throw #t "wrong exception type thrown")))) (sdom:catch 'sdom:exception (lambda () (sdom:replace-child! entref comment pi) (throw #t "exception should have been thrown")) (lambda exn (if (not (eqv? (cadr exn) sdom:exception-code-no-modification-allowed-err)) (throw #t "wrong exception type thrown")))) (sdom:catch 'sdom:exception (lambda () (sdom:replace-child! entref txt comment) (throw #t "exception should have been thrown")) (lambda exn (if (not (eqv? (cadr exn) sdom:exception-code-no-modification-allowed-err)) (throw #t "wrong exception type thrown")))) (sdom:catch 'sdom:exception (lambda () (sdom:replace-child! entref elem txt) (throw #t "exception should have been thrown")) (lambda exn (if (not (eqv? (cadr exn) sdom:exception-code-no-modification-allowed-err)) (throw #t "wrong exception type thrown")))) #t))) (define nodereplacechild-26 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (docelem (sdom:get-dom-property doc "sdom:document-element")) (childlist (sdom:get-elements-by-tag-name doc "p")) (elem (list-ref childlist 0)) (firstchild (sdom:get-dom-property elem "sdom:first-child"))) (sdom:catch 'sdom:exception (lambda () (sdom:replace-child! elem docelem firstchild) (throw #t "exception should have been thrown")) (lambda exn (if (not (eqv? (cadr exn) sdom:exception-code-hierarchy-request-err)) (throw #t "wrong exception type thrown")))) #t))) (define nodereplacechild-27 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (childlist (sdom:get-elements-by-tag-name doc "p" "*")) (elem (list-ref childlist 0)) (firstchild (sdom:get-dom-property elem "sdom:first-child")) (doc2 (sdom:clone-node hc-staff #t)) (childlist2 (sdom:get-elements-by-tag-name doc2 "p" "*")) (elem2 (list-ref childlist2 0))) (sdom:catch 'sdom:exception (lambda () (sdom:replace-child! elem elem2 firstchild) (throw #t "exception should have been thrown")) (lambda exn (if (not (eqv? (cadr exn) sdom:exception-code-wrong-document-err)) (throw #t "wrong exception type thrown")))) #t))) (define nodereplacechild-29 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (childlist (sdom:get-elements-by-tag-name doc "p")) (elem (list-ref childlist 0)) (oldchild (sdom:create-node doc sdom:node-type-element "dom3:br" xhtmlns)) (newchild (sdom:create-node doc sdom:node-type-element "dom3:span" xhtmlns))) (sdom:catch 'sdom:exception (lambda () (sdom:replace-child! elem newchild oldchild) (throw #t "exception should have been thrown")) (lambda exn (if (not (eqv? (cadr exn) sdom:exception-code-not-found-err)) (throw #t "wrong exception type thrown")))) #t))) (define nodereplacechild-30 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (parent (sdom:create-node doc sdom:node-type-element "xhtml:html" xhtmlns)) (oldchild (sdom:create-node doc sdom:node-type-element "xhtml:head" xhtmlns)) (newelement (sdom:create-node doc sdom:node-type-element "xhtml:body" xhtmlns)) (newtext (sdom:create-node doc sdom:node-type-text "Text")) (newcomment (sdom:create-node doc sdom:node-type-comment "Comment")) (newpi (sdom:create-node doc sdom:node-type-processing-instruction "target" "data")) (newcdata (sdom:create-node doc sdom:node-type-cdata-section "Cdata")) (neweref (sdom:create-node doc sdom:node-type-entity-reference "delta"))) (sdom:append-child! parent oldchild) (sdom:append-child! parent newelement) (sdom:append-child! parent newcomment) (sdom:append-child! parent newpi) (sdom:append-child! parent newcdata) (sdom:append-child! parent neweref) (if (not (equal? (sdom:get-dom-property (sdom:replace-child! parent newelement oldchild) "sdom:node-name") "xhtml:head")) (throw #t "elem replacement should preserve node name on elem")) (if (not (equal? (sdom:get-dom-property (sdom:replace-child! parent oldchild newelement) "sdom:node-name") "xhtml:body")) (throw #t "elem replacement should preserve node name on elem")) (if (not (equal? (sdom:get-dom-property (sdom:replace-child! parent newtext oldchild) "sdom:node-name") "xhtml:head")) (throw #t "text replacement should preserve node name on elem")) (if (not (equal? (sdom:get-dom-property (sdom:replace-child! parent oldchild newtext) "sdom:node-name") "#text")) (throw #t "elem replacement should preserve node name on text")) (if (not (equal? (sdom:get-dom-property (sdom:replace-child! parent newcomment oldchild) "sdom:node-name") "xhtml:head")) (throw #t "comment replacement should preserve node name on elem")) (if (not (equal? (sdom:get-dom-property (sdom:replace-child! parent oldchild newcomment) "sdom:node-name") "#comment")) (throw #t "elem replacement should preserve node name on comment")) (if (not (equal? (sdom:get-dom-property (sdom:replace-child! parent oldchild newpi) "sdom:node-name") "target")) (throw #t "elem replacement should preserve node name on PI")) (if (not (equal? (sdom:get-dom-property (sdom:replace-child! parent oldchild newcdata) "sdom:node-name") "#cdata-section")) (throw #t "elem replacement should preserve node name on CDATA")) (if (not (equal? (sdom:get-dom-property (sdom:replace-child! parent oldchild neweref) "sdom:node-name") "delta")) (throw #t "elem replacement should preserve node name on ent-ref") #t)))) (define nodereplacechild-32 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (newchild (sdom:create-node doc sdom:node-type-text "Text")) (childlist (sdom:get-elements-by-tag-name doc "acronym" "*")) (elem (list-ref childlist 0)) (parent (sdom:get-attribute-node elem "title")) (entref (sdom:create-node doc sdom:node-type-entity-reference "entity1"))) (sdom:append-child! parent entref) (if (not (equal? (sdom:get-dom-property (sdom:replace-child! parent newchild entref) "sdom:node-name") "entity1")) (throw #t "replacement should preserve entity reference name") #t)))) (define nodereplacechild-34 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (parent (sdom:create-node doc sdom:node-type-attr "xml:lang" xmlns)) (oldchild (sdom:create-node doc sdom:node-type-entity-reference "delta")) (newchild (sdom:create-node doc sdom:node-type-text "Text"))) (sdom:append-child! parent oldchild) (sdom:replace-child! parent newchild oldchild) (if (not (equal? (sdom:get-dom-property parent "sdom:value") "Text")) (throw #t "replaced node should have correct value") #t)))) (define nodereplacechild-35 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (parent (sdom:create-node doc sdom:node-type-attr "xml:lang" xmlns)) (oldchild (sdom:create-node doc sdom:node-type-entity-reference "delta")) (newchild (sdom:create-node doc sdom:node-type-attr "xml:lang" xmlns))) (sdom:append-child! parent oldchild) (sdom:catch 'sdom:exception (lambda () (sdom:replace-child! parent newchild oldchild) (throw #t "exception should have been thrown")) (lambda exn (if (not (eqv? (cadr exn) sdom:exception-code-hierarchy-request-err)) (throw #t "wrong exception type thrown")))) #t))) (define nodereplacechild-36 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (parent (sdom:create-node doc sdom:node-type-attr "xml:lang" xmlns)) (oldchild (sdom:create-node doc sdom:node-type-entity-reference "delta")) (newchild (sdom:create-node doc sdom:node-type-text "Text"))) (sdom:catch 'sdom:exception (lambda () (sdom:replace-child! parent newchild oldchild) (throw #t "exception should have been thrown")) (lambda exn (if (not (eqv? (cadr exn) sdom:exception-code-not-found-err)) (throw #t "wrong exception type thrown")))) #t))) (define nodereplacechild-37 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (doc2 (sdom:clone-node hc-staff #t)) (parent (sdom:create-node doc sdom:node-type-attr "xml:lang" xmlns)) (oldchild (sdom:create-node doc sdom:node-type-text "Text")) (newchild (sdom:create-node doc2 sdom:node-type-entity-reference "delta"))) (sdom:append-child! parent oldchild) (sdom:catch 'sdom:exception (lambda () (sdom:replace-child! parent newchild oldchild) (throw #t "exception should have been thrown")) (lambda exn (if (not (eqv? (cadr exn) sdom:exception-code-wrong-document-err)) (throw #t "wrong exception type thrown")))) #t))) (define nodereplacechild-39 (lambda () (let* ((doc (sdom:clone-node barfoo #t)) (docelem (sdom:get-dom-property doc "sdom:document-element")) (rootname (sdom:get-dom-property docelem "sdom:tag-name")) (rootns (sdom:get-dom-property docelem "sdom:namespace-uri")) (newelement (sdom:create-node doc sdom:node-type-element rootname rootns)) (newcomment (sdom:create-node doc sdom:node-type-comment "second element goes here"))) (sdom:append-child! doc newcomment) (sdom:catch 'sdom:exception (lambda () (sdom:replace-child! doc newelement newcomment) (throw #t "exception should have been thrown")) (lambda exn (if (not (memv (cadr exn) (list 3 9))) (throw #t "wrong exception type thrown")))) #t))) (define nodesettextcontent-1 (lambda () (let ((doc (sdom:clone-node hc-staff #t))) (sdom:set-dom-property! doc "sdom:text-content" "textContent") (let* ((elemlist (sdom:get-elements-by-tag-name doc "acronym")) (elem (list-ref elemlist 0))) (if (null? elem) (throw #t "setting text content should preserve structure")) (if (not (equal? (sdom:get-dom-property elem "sdom:node-name") "acronym")) (throw #t "setting text content should preserve node name") #t))))) (define nodesettextcontent-2 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (newdoc (sdom:create-document "dom3:elem" '() "http://www.w3.org/DOM/Test")) (newelem (sdom:create-node newdoc sdom:node-type-element "dom3:childElem" "http://www.w3.org/DOM/Test")) (docelem (sdom:get-dom-property newdoc "sdom:document-element"))) (sdom:append-child! docelem newelem) (sdom:set-dom-property! newdoc "sdom:text-content" "textContent") (let* ((elemlist (sdom:get-elements-by-tag-name newdoc "childElem" "*")) (elemchild (list-ref elemlist 0))) (if (not (equal? (sdom:get-dom-property elemchild "sdom:node-name") "dom3:childElem")) (throw #t "setting text content should not affect node name") #t))))) (define nodesettextcontent-6 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (elem (sdom:create-node doc sdom:node-type-element "p" xhtmlns)) (attr (sdom:create-node doc sdom:node-type-attr "xml:lang" xmlns))) (sdom:set-attribute-node! elem attr) (sdom:set-dom-property! attr "sdom:text-content" "NA") (if (not (equal? (sdom:get-dom-property attr "sdom:text-content") "NA")) (throw #t "setting text content should change text content") #t)))) (define nodesettextcontent-7 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (elemlist (sdom:get-elements-by-tag-name doc "em")) (elem (list-ref elemlist 0)) (txt (sdom:get-dom-property elem "sdom:first-child"))) (sdom:set-dom-property! elem "sdom:text-content" "Text") (if (not (equal? (sdom:get-dom-property elem "sdom:text-content") "Text")) (throw #t "setting text content should change text content") #t)))) (define nodesettextcontent-8 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (elem (sdom:create-node doc sdom:node-type-element "xhtml:p" xhtmlns)) (pi (sdom:create-node doc sdom:node-type-processing-instruction "PIT" "PID"))) (sdom:append-child! elem pi) (sdom:set-dom-property! pi "sdom:text-content" "PID") (if (not (equal? (sdom:get-dom-property pi "sdom:text-content") "PID")) (throw #t "setting text content should change text content") #t)))) (define nodesettextcontent-10 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (elem (sdom:create-node doc sdom:node-type-element "dom3:elem" "http://www.w3.org/DOM/Test")) (txt (sdom:create-node doc sdom:node-type-text "Text")) (comment (sdom:create-node doc sdom:node-type-comment "Comment")) (entref (sdom:create-node doc sdom:node-type-entity-reference "ent1")) (pi (sdom:create-node doc sdom:node-type-processing-instruction "PIT" "PIData")) (cdata (sdom:create-node doc sdom:node-type-cdata-section "CData"))) (sdom:append-child! elem txt) (sdom:append-child! elem comment) (sdom:append-child! elem entref) (sdom:append-child! elem pi) (sdom:append-child! elem cdata) (sdom:set-dom-property! elem "sdom:text-content" "ELEMENT") (if (not (equal? (sdom:get-dom-property elem "sdom:text-content") "ELEMENT")) (throw #t "setting text content should change text content") #t)))) (define nodesettextcontent-11 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (docfrag (sdom:create-node doc sdom:node-type-document-fragment)) (elem (sdom:create-node doc sdom:node-type-element "xhtml:p" xhtmlns)) (txt (sdom:create-node doc sdom:node-type-text "Text ")) (comment (sdom:create-node doc sdom:node-type-comment "Comment")) (entref (sdom:create-node doc sdom:node-type-entity-reference "alpha")) (pi (sdom:create-node doc sdom:node-type-processing-instruction "PIT" "PIData ")) (cdata (sdom:create-node doc sdom:node-type-cdata-section "CData"))) (sdom:append-child! elem txt) (sdom:append-child! elem comment) (sdom:append-child! elem entref) (sdom:append-child! elem pi) (sdom:append-child! elem cdata) (sdom:append-child! docfrag elem) (sdom:set-dom-property! docfrag "sdom:text-content" "DOCUMENTFRAGMENT") (if (not (equal? (sdom:get-dom-property (sdom:get-dom-property docfrag "sdom:last-child") "sdom:text-content") "DOCUMENTFRAGMENT")) (throw #t "setting text content should change text content") #t)))) (define nodesettextcontent-12 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (elem (sdom:get-dom-property doc "sdom:document-element")) (entref (sdom:create-node doc sdom:node-type-entity-reference "beta"))) (sdom:append-child! elem entref) (sdom:catch 'sdom:exception (lambda () (sdom:set-dom-property! entref "sdom:text-content" "NA") (throw #t "exception should have been thrown")) (lambda exn (if (not (eqv? (cadr exn) sdom:exception-code-no-modification-allowed-err)) (throw #t "wrong exception type thrown")))) #t))) (define nodesetuserdata-1 (lambda () (let* ((doc (sdom:clone-node hc-staff #t))) (if (sdom:set-user-data! doc "something" '() '()) (throw #t "user data should be null initially") #t)))) (define nodesetuserdata-3 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (elem (sdom:create-node doc sdom:node-type-element "xhtml:p" xhtmlns)) (txt (sdom:create-node doc sdom:node-type-text "TEXT"))) (sdom:set-user-data! doc "Key1" elem '()) (if (not (sdom:equal-node? (sdom:set-user-data! doc "Key1" txt '()) elem)) (throw #t "setting user data should return previous value") #t)))) (define nodesetuserdata-4 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (elem (sdom:create-node doc sdom:node-type-element "p" xhtmlns)) (txt (sdom:create-node doc sdom:node-type-text "TEXT"))) (sdom:set-user-data! elem "Key1" txt '()) (sdom:set-user-data! elem "Key2" txt '()) (let* ((ret1 (sdom:get-user-data elem "Key1")) (ret2 (sdom:get-user-data elem "Key2"))) (if (not (sdom:equal-node? ret1 ret2)) (throw #t "setting user data should not affect node equality") #t))))) (define nodesetuserdata-5 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (doc2 (sdom:clone-node hc-staff #t)) (attr (sdom:create-node doc sdom:node-type-attr "lang" xmlns))) (sdom:set-user-data! attr "Key1" doc '()) (sdom:set-user-data! attr "Key2" doc2 '()) (if (not (sdom:equal-node? (sdom:get-user-data attr "Key1") (sdom:get-user-data attr "Key2"))) (throw #t "setting user data should not affect node equality") #t)))) (define nodesetuserdata-8 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (docelem (sdom:get-dom-property doc "sdom:document-element")) (entref (sdom:create-node doc sdom:node-type-entity-reference "delta")) (cdata (sdom:create-node doc sdom:node-type-cdata-section "CDATASection"))) (sdom:set-user-data! entref "Key1" doc '()) (sdom:set-user-data! cdata "Key2" docelem '()) (if (sdom:equal-node? (sdom:get-user-data entref "Key1") (sdom:get-user-data cdata "Key2")) (throw #t "setting user data should not affect node inequality") #t)))) (define nodesetuserdata-9 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (docelem (sdom:get-dom-property doc "sdom:document-element"))) (sdom:set-user-data! docelem "Key1" doc '()) (if (sdom:get-user-data doc "Key1") (throw #t "setting user data should affectly only target node") #t)))) (define nodesetuserdata-10 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (docelem (sdom:get-dom-property doc "sdom:document-element")) (entref (sdom:create-node doc sdom:node-type-entity-reference "delta")) (cdata (sdom:create-node doc sdom:node-type-cdata-section "CDATASection"))) (sdom:set-user-data! entref "Key1" doc '()) (sdom:set-user-data! cdata "Key2" docelem '()) (if (sdom:equal-node? (sdom:get-user-data entref "Key1") (sdom:get-user-data cdata "Key2")) (throw #t "setting user data should not affect node inequality") #t)))) (define textreplacewholetext-1 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (itemlist (sdom:get-elements-by-tag-name doc "strong")) (elem (list-ref itemlist 0)) (textnode (sdom:get-dom-property elem "sdom:first-child")) (replaced (sdom:replace-whole-text! textnode "New Content"))) (if (not (equal? (sdom:get-dom-property replaced "sdom:whole-text") "New Content")) (throw #t "replacing whole text should affect node text") #t)))) (define textreplacewholetext-2 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (itemlist (sdom:get-elements-by-tag-name doc "strong")) (elem (list-ref itemlist 0)) (textnode (sdom:get-dom-property elem "sdom:first-child"))) (if (sdom:replace-whole-text! textnode "") (throw #t "replacing whole text with empty string should be null") #t)))) (define textreplacewholetext-3 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (textnode (sdom:create-node doc sdom:node-type-text "New Text")) (replacedtext (sdom:replace-whole-text! textnode " a b c b "))) (if (not (equal? (sdom:get-dom-property replacedtext "sdom:whole-text") " a b c b ")) (throw #t "replacing whole text should affect disconnected nodes") #t)))) (define textreplacewholetext-4 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (textnode (sdom:create-node doc sdom:node-type-text "New Text"))) (if (sdom:replace-whole-text! textnode "") (throw #t "replacing whole text with empty string should be null") #t)))) (define textreplacewholetext-5 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (itemlist (sdom:get-elements-by-tag-name doc "strong")) (elemname (list-ref itemlist 0)) (textnode (sdom:create-node doc sdom:node-type-text "New Text")) (cdatasection (sdom:create-node doc sdom:node-type-cdata-section "New CDATA"))) (sdom:append-child! elemname textnode) (sdom:append-child! elemname cdatasection) (let* ((textnode (sdom:get-dom-property elemname "sdom:first-child")) (replacedtext (sdom:replace-whole-text! textnode "New Text and Cdata"))) (if (not (equal? (sdom:get-dom-property replacedtext "sdom:whole-text") "New Text and Cdata")) (throw #t "replacing whole text should affect node text") #t))))) (define textreplacewholetext-6 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (itemlist (sdom:get-elements-by-tag-name doc "strong")) (elemstrong (list-ref itemlist 0)) (textnode (sdom:create-node doc sdom:node-type-text "New Text")) (erefnode (sdom:create-node doc sdom:node-type-entity-reference "beta"))) (sdom:append-child! elemstrong textnode) (sdom:append-child! elemstrong erefnode) (let* ((textnode (sdom:get-dom-property elemstrong "sdom:first-child")) (replacedtext (sdom:replace-whole-text! textnode "New Text and Cdata"))) (if (not (equal? (sdom:get-dom-property replacedtext "sdom:node-value") "New Text and Cdata")) (throw #t "replacing whole text should affect node text") #t))))) (define textreplacewholetext-7 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (itemlist (sdom:get-elements-by-tag-name doc "strong")) (elemname (list-ref itemlist 0)) (erefnode (sdom:create-node doc sdom:node-type-entity-reference "ent4")) (textnode (sdom:create-node doc sdom:node-type-text "New Text"))) (sdom:append-child! elemname erefnode) (sdom:append-child! elemname textnode) (let* ((textnode (sdom:get-dom-property elemname "sdom:first-child")) (replacedtext (sdom:replace-whole-text! textnode "New Text and Cdata")) (textnode (sdom:get-dom-property elemname "sdom:first-child"))) (if (not (sdom:same-node? textnode replacedtext)) (throw #t "replaced text should be same as new first child")) (if (not (equal? (sdom:get-dom-property textnode "sdom:node-value") "New Text and Cdata")) (throw #t "replacing whole text should affect node value")) (let ((node (sdom:get-dom-property textnode "sdom:next-sibling"))) (if (not node) (throw #t "replacing text should not affect unrelated nodes")) (if (not (eqv? (sdom:node-type node) sdom:node-type-entity-reference)) (throw #t "replacing text should not affect unrelated node type") #t)))))) (define textwholetext-1 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (itemlist (sdom:get-elements-by-tag-name doc "strong")) (elemname (list-ref itemlist 0)) (textnode (sdom:get-dom-property elemname "sdom:first-child")) (nametext (sdom:get-dom-property textnode "sdom:whole-text"))) (if (not (equal? nametext "Margaret Martin")) (throw #t "retrieving whole text should retrieve all adjacent text") #t)))) (define textwholetext-2 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (itemlist (sdom:get-elements-by-tag-name doc "strong")) (elemname (list-ref itemlist 0)) (newtext (sdom:create-node doc sdom:node-type-text "New Text"))) (sdom:append-child! elemname newtext) (if (not (equal? (sdom:get-dom-property (sdom:get-dom-property elemname "sdom:first-child") "sdom:whole-text") "Margaret MartinNew Text")) (throw #t "retrieving whole text should retrieve all adjacent text") #t)))) (define textwholetext-3 (lambda () (let* ((doc (sdom:clone-node hc-staff #t)) (elem (sdom:create-node doc sdom:node-type-element "p" xhtmlns)) (text1 (sdom:create-node doc sdom:node-type-text "Text I")) (text2 (sdom:create-node doc sdom:node-type-text " Text II"))) (sdom:append-child! elem text1) (sdom:append-child! elem text2) (if (not (equal? (sdom:get-dom-property text1 "sdom:whole-text") "Text I Text II")) (throw #t "retrieving whole text should retrieve all adjacent text") #t)))) (define userdatahandler-1 (lambda () (let* ((doc (sdom:clone-node barfoo #t)) (notifications (list)) (handler (lambda (op key data src dst) (let ((newnot (list op key data src dst))) (if (null? notifications) (set! notifications (list newnot)) (append! notifications (list newnot)))))) (hello "Hello") (mister "Mr.") (plist (sdom:get-elements-by-tag-name doc "p")) (node (list-ref plist 0))) (sdom:set-user-data! node "greeting" hello handler) (sdom:set-user-data! node "salutation" mister handler) (let* ((elemns (sdom:get-dom-property node "sdom:namespace-uri")) (newnode (sdom:rename-node! node "div" elemns)) (greetingcount 0) (salutationcount 0)) (if (not (eqv? (length notifications) 2)) (throw #t "handler should receive both notifications")) (for-each (lambda (x) (if (not (eqv? (car x) sdom:user-data-event-node-renamed)) (throw #t "wrong operation for notification")) (cond ((equal? (list-ref x 1) "greeting") (set! greetingcount (+ greetingcount 1)) (if (not (equal? (list-ref x 2) hello)) (throw #t "wrong data for greeting"))) ((equal? (list-ref x 1) "salutation") (set! salutationcount (+ salutationcount 1)) (if (not (equal? (list-ref x 2) mister)) (throw #t "wrong data for salutation"))) (else (throw #t "wrong key for notification"))) (if (not (sdom:same-node? node (list-ref x 3))) (throw #t "source node should be old node")) (let ((dst (list-ref x 4))) (if (null? dst) (if (not (sdom:same-node? node newnode)) (throw #t "node should be reused under rename")) (if (not (sdom:same-node? newnode dst)) (throw #t "wrong destination node"))))) notifications) (if (not (eqv? greetingcount 1)) (throw #t "wrong number of greetings received")) (if (not (eqv? salutationcount 1)) (throw #t "wrong number of salutations received") #t))))) (define userdatahandler-2 (lambda () (let* ((doc (sdom:clone-node barfoo #t)) (notifications (list)) (handler (lambda (op key data src dst) (let ((newnot (list op key data src dst))) (if (null? notifications) (set! notifications (list newnot)) (append! notifications (list newnot)))))) (hello "Hello") (mister "Mr.") (plist (sdom:get-elements-by-tag-name doc "p")) (node (list-ref plist 0))) (sdom:set-user-data! node "greeting" hello handler) (sdom:set-user-data! node "salutation" mister handler) (let* ((elemns (sdom:get-dom-property node "sdom:namespace-uri")) (newnode (sdom:clone-node node #t)) (greetingcount 0) (salutationcount 0)) (if (not (eqv? (length notifications) 2)) (throw #t "handler should receive both notifications")) (for-each (lambda (x) (if (not (eqv? (car x) sdom:user-data-event-node-cloned)) (throw #t "wrong operation for notification")) (cond ((equal? (list-ref x 1) "greeting") (set! greetingcount (+ greetingcount 1)) (if (not (equal? (list-ref x 2) hello)) (throw #t "wrong data for greeting"))) ((equal? (list-ref x 1) "salutation") (set! salutationcount (+ salutationcount 1)) (if (not (equal? (list-ref x 2) mister)) (throw #t "wrong data for salutation"))) (else (throw #t "wrong key for notification"))) (if (not (sdom:same-node? node (list-ref x 3))) (throw #t "source node should be old node")) (if (not (sdom:same-node? newnode (list-ref x 4))) (throw #t "destination node should be new node"))) notifications) (if (not (eqv? greetingcount 1)) (throw #t "wrong number of greetings received")) (if (not (eqv? salutationcount 1)) (throw #t "wrong number of salutations received") #t))))) (define userdatahandler-3 (lambda () (let* ((doc (sdom:clone-node barfoo #t)) (docelem (sdom:get-dom-property doc "sdom:document-element")) (rootns (sdom:get-dom-property docelem "sdom:namespace-uri")) (rootname (sdom:get-dom-property docelem "sdom:tag-name")) (newdoc (sdom:create-document rootname '() rootns)) (notifications (list)) (handler (lambda (op key data src dst) (let ((newnot (list op key data src dst))) (if (null? notifications) (set! notifications (list newnot)) (append! notifications (list newnot)))))) (hello "Hello") (mister "Mr.") (plist (sdom:get-elements-by-tag-name doc "p")) (node (list-ref plist 0))) (sdom:set-user-data! node "greeting" hello handler) (sdom:set-user-data! node "salutation" mister handler) (let* ((elemns (sdom:get-dom-property node "sdom:namespace-uri")) (newnode (sdom:import-node doc node #t)) (greetingcount 0) (salutationcount 0)) (if (not (eqv? (length notifications) 2)) (throw #t "handler should receive both notifications")) (for-each (lambda (x) (if (not (eqv? (car x) sdom:user-data-event-node-imported)) (throw #t "wrong operation for notification")) (cond ((equal? (list-ref x 1) "greeting") (set! greetingcount (+ greetingcount 1)) (if (not (equal? (list-ref x 2) hello)) (throw #t "wrong data for greeting"))) ((equal? (list-ref x 1) "salutation") (set! salutationcount (+ salutationcount 1)) (if (not (equal? (list-ref x 2) mister)) (throw #t "wrong data for salutation"))) (else (throw #t "wrong key for notification"))) (if (not (sdom:same-node? node (list-ref x 3))) (throw #t "source node should be old node")) (if (not (sdom:same-node? newnode (list-ref x 4))) (throw #t "destination node should be new node"))) notifications) (if (not (eqv? greetingcount 1)) (throw #t "wrong number of greetings received")) (if (not (eqv? salutationcount 1)) (throw #t "wrong number of salutations received") #t))))) (define userdatahandler-4 (lambda () (let* ((doc (sdom:clone-node barfoo #t)) (docelem (sdom:get-dom-property doc "sdom:document-element")) (rootns (sdom:get-dom-property docelem "sdom:namespace-uri")) (rootname (sdom:get-dom-property docelem "sdom:tag-name")) (newdoc (sdom:create-document rootname '() rootns)) (notifications (list)) (handler (lambda (op key data src dst) (let ((newnot (list op key data src dst))) (if (null? notifications) (set! notifications (list newnot)) (append! notifications (list newnot)))))) (hello "Hello") (mister "Mr.") (plist (sdom:get-elements-by-tag-name doc "p")) (node (list-ref plist 0))) (sdom:set-user-data! node "greeting" hello handler) (sdom:set-user-data! node "salutation" mister handler) (let* ((elemns (sdom:get-dom-property node "sdom:namespace-uri")) (newnode (sdom:adopt-node! doc node)) (greetingcount 0) (salutationcount 0)) (if (not (eqv? (length notifications) 2)) (throw #t "handler should receive both notifications")) (for-each (lambda (x) (if (not (eqv? (car x) sdom:user-data-event-node-adopted)) (throw #t "wrong operation for notification")) (cond ((equal? (list-ref x 1) "greeting") (set! greetingcount (+ greetingcount 1)) (if (not (equal? (list-ref x 2) hello)) (throw #t "wrong data for greeting"))) ((equal? (list-ref x 1) "salutation") (set! salutationcount (+ salutationcount 1)) (if (not (equal? (list-ref x 2) mister)) (throw #t "wrong data for salutation"))) (else (throw #t "wrong key for notification"))) (if (not (sdom:same-node? node (list-ref x 3))) (throw #t "source node should be old node")) (if (not (null? (list-ref x 4))) (throw #t "destination node should be null"))) notifications) (if (not (eqv? greetingcount 1)) (throw #t "wrong number of greetings received")) (if (not (eqv? salutationcount 1)) (throw #t "wrong number of salutations received") #t))))) (define tests `((attrisid-1) (attrisid-2) (attrisid-3) (attrisid-6) (attrisid-7) (canonicalform-1) (canonicalform-2) (canonicalform-3) (canonicalform-4) (cdatasections-1) (comments-1) (documentadoptnode-3) (documentadoptnode-4) (documentadoptnode-7) (documentadoptnode-8) (documentadoptnode-9) (documentadoptnode-11) (documentadoptnode-12) (documentadoptnode-13) (documentadoptnode-14) (documentadoptnode-15) (documentadoptnode-21) (documentadoptnode-22) (documentadoptnode-23) (documentadoptnode-24) (documentadoptnode-25) (documentadoptnode-26) (documentadoptnode-27) (documentadoptnode-30) (documentadoptnode-31) (documentadoptnode-32) (documentadoptnode-33) (documentadoptnode-34) (documentadoptnode-35) (documentadoptnode-36) (documentgetstricterrorchecking-1) (documentgetstricterrorchecking-2) (documentnormalizedocument-1) (documentnormalizedocument-3) (documentnormalizedocument-4) (documentnormalizedocument-8) (documentnormalizedocument-11) (documentrenamenode-1) (documentrenamenode-2) (documentrenamenode-3) (documentrenamenode-4) (documentrenamenode-5) (documentrenamenode-7) (documentrenamenode-10) (documentrenamenode-11) (documentrenamenode-12) (documentrenamenode-13) (documentrenamenode-14) (documentrenamenode-15) (documentrenamenode-16) (documentrenamenode-17) (documentrenamenode-19) (documentrenamenode-20) (documentrenamenode-21) (documentrenamenode-22) (documentrenamenode-23) (documentrenamenode-24) (documentrenamenode-26) (documentrenamenode-27) (documentrenamenode-29) (domconfigcdatasections-1) (domconfigcomments-1) (domconfigentities-1) (domconfigerrorhandler-1) (domconfiginfoset-1) (domconfignamespacedeclarations-1) (domconfigparameternames-1) (domconfigsplitcdatasections-1) (domconfigurationcansetparameter-1) (domconfigurationgetparameter-1) (domconfigurationgetparameter-2) (elementsetidattribute-3) (elementsetidattribute-5) (elementsetidattribute-9) (elementsetidattribute-10) (elementsetidattributenode-2) (elementsetidattributenode-3) (entities-1) (entities-2) (entities-3) (entities-4) (handleerror-1) (infoset-2) (infoset-4) (infoset-8) (infoset-9) (nodeappendchild-2) (nodecomparedocumentposition-3) (nodecomparedocumentposition-4) (nodecomparedocumentposition-5) (nodecomparedocumentposition-6) (nodecomparedocumentposition-7) (nodecomparedocumentposition-8) (nodecomparedocumentposition-9) (nodecomparedocumentposition-11) (nodecomparedocumentposition-12) (nodecomparedocumentposition-13) (nodecomparedocumentposition-14) (nodecomparedocumentposition-15) (nodecomparedocumentposition-16) (nodecomparedocumentposition-17) (nodecomparedocumentposition-18) (nodecomparedocumentposition-19) (nodecomparedocumentposition-20) (nodecomparedocumentposition-21) (nodecomparedocumentposition-25) (nodecomparedocumentposition-30) (nodecomparedocumentposition-31) (nodecomparedocumentposition-33) (nodecomparedocumentposition-34) (nodecomparedocumentposition-37) (nodecomparedocumentposition-38) (nodecomparedocumentposition-39) (nodecomparedocumentposition-40) (nodegetbaseuri-2) (nodegetbaseuri-4) (nodegetbaseuri-5) (nodegetbaseuri-7) (nodegetbaseuri-9) (nodegetbaseuri-10) (nodegetbaseuri-15) (nodegetbaseuri-17) (nodegetbaseuri-18) (nodegettextcontent-1) (nodegettextcontent-2) (nodegettextcontent-6) (nodegettextcontent-7) (nodegettextcontent-8) (nodegettextcontent-9) (nodegettextcontent-10) (nodegettextcontent-11) (nodegettextcontent-12) (nodegettextcontent-13) (nodegettextcontent-14) (nodegettextcontent-19) (nodegetuserdata-1) (nodegetuserdata-3) (nodegetuserdata-6) (nodegetuserdata-7) (nodeinsertbefore-1) (nodeinsertbefore-6) (nodeinsertbefore-7) (nodeinsertbefore-8) (nodeinsertbefore-9) (nodeinsertbefore-10) (nodeinsertbefore-11) (nodeinsertbefore-12) (nodeinsertbefore-13) (nodeinsertbefore-16) (nodeinsertbefore-17) (nodeinsertbefore-18) (nodeinsertbefore-19) (nodeinsertbefore-20) (nodeinsertbefore-21) (nodeinsertbefore-22) (nodeinsertbefore-23) (nodeinsertbefore-24) (nodeisequalnode-1) (nodeisequalnode-2) (nodeisequalnode-4) (nodeisequalnode-6) (nodeisequalnode-7) (nodeisequalnode-8) (nodeisequalnode-9) (nodeisequalnode-11) (nodeisequalnode-12) (nodeisequalnode-13) (nodeisequalnode-15) (nodeisequalnode-17) (nodeisequalnode-18) (nodeisequalnode-19) (nodeisequalnode-20) (nodeisequalnode-28) (nodeisequalnode-29) (nodeisequalnode-31) (nodeisequalnode-31) (nodelookupnamespaceuri-1) (nodelookupnamespaceuri-2) (nodelookupnamespaceuri-5) (noderemovechild-1) (noderemovechild-2) (noderemovechild-3) (noderemovechild-8) (noderemovechild-9) (noderemovechild-10) (noderemovechild-11) (noderemovechild-12) (noderemovechild-16) (noderemovechild-17) (noderemovechild-20) (noderemovechild-21) (noderemovechild-22) (noderemovechild-23) (noderemovechild-28) (nodereplacechild-1) (nodereplacechild-3) (nodereplacechild-4) (nodereplacechild-6) (nodereplacechild-7) (nodereplacechild-8) (nodereplacechild-12) (nodereplacechild-14) (nodereplacechild-15) (nodereplacechild-16) (nodereplacechild-17) (nodereplacechild-18) (nodereplacechild-19) (nodereplacechild-20) (nodereplacechild-22) (nodereplacechild-23) (nodereplacechild-26) (nodereplacechild-27) (nodereplacechild-29) (nodereplacechild-30) (nodereplacechild-32) (nodereplacechild-34) (nodereplacechild-35) (nodereplacechild-36) (nodereplacechild-37) (nodereplacechild-39) (nodesettextcontent-1) (nodesettextcontent-2) (nodesettextcontent-6) (nodesettextcontent-7) (nodesettextcontent-8) (nodesettextcontent-10) (nodesettextcontent-11) (nodesettextcontent-12) (nodesetuserdata-1) (nodesetuserdata-3) (nodesetuserdata-4) (nodesetuserdata-5) (nodesetuserdata-8) (nodesetuserdata-9) (nodesetuserdata-10) (textreplacewholetext-1) (textreplacewholetext-2) (textreplacewholetext-3) (textreplacewholetext-4) (textreplacewholetext-5) (textreplacewholetext-6) (textreplacewholetext-7) (textwholetext-1) (textwholetext-2) (textwholetext-3) (userdatahandler-1) (userdatahandler-2) (userdatahandler-3) (userdatahandler-4))) (define run-tests (lambda () (let ((failures 0)) (for-each (lambda (x) (let* ((name (symbol->string (car x))) (dots (make-string (- 38 (string-length name)) #\.)) (s (current-milliseconds))) (display name) (display dots) (display (sdom:catch #t (lambda () (begin (apply (eval-string name) '()) #t)) (lambda exn (begin (set! failures (+ failures 1)) #f)))) (display " (") (display (number->string (- (current-milliseconds) s))) (display ")") (newline))) tests)))) ;;@POSTMORTEM@