test-suite/tests/sxml.simple.test

   1 ;;;; sxml.simple.test --- (sxml simple)  -*- mode: scheme; coding: utf-8; -*-
   2 ;;;;
   3 ;;;;    Copyright (C) 2010, 2013 Free Software Foundation, Inc.
   4 ;;;;
   5 ;;;; This library is free software; you can redistribute it and/or
   6 ;;;; modify it under the terms of the GNU Lesser General Public
   7 ;;;; License as published by the Free Software Foundation; either
   8 ;;;; version 3 of the License, or (at your option) any later version.
   9 ;;;;
  10 ;;;; This library is distributed in the hope that it will be useful,
  11 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13 ;;;; Lesser General Public License for more details.
  14 ;;;;
  15 ;;;; You should have received a copy of the GNU Lesser General Public
  16 ;;;; License along with this library; if not, write to the Free Software
  17 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  18
  19 (define-module (test-sxml-simple)
  20   #:use-module (test-suite lib)
  21   #:use-module (sxml simple))
  22
  23 (define parser-error '(parser-error . ""))
  24
  25 (define %xml-sample
  26   ;; An XML sample without any space in between tags, to make it easier.
  27   (string-append "<?xml version='1.0' encoding='utf-8'?>"
  28                  "<foo chbouib=\"yes\">"
  29                    "<bar/>"
  30                    "<baz>"
  31                      "<smurf one=\"1\"/>"
  32                    "</baz>"
  33                  "</foo>"))
  34
  35 \f
  36 (with-test-prefix "simple"
  37
  38   (pass-if "xml->sxml"
  39     (equal?  (xml->sxml (open-input-string %xml-sample))
  40             '(*TOP*
  41               (*PI* xml "version='1.0' encoding='utf-8'")
  42               (foo (@ (chbouib "yes"))
  43                    (bar)
  44                    (baz (smurf (@ (one "1"))))))))
  45
  46   (pass-if "xml->sxml->xml->sxml"
  47     ;; Regression test for bug #29260.
  48     (equal? (xml->sxml (open-input-string %xml-sample))
  49             (xml->sxml
  50              (open-input-string
  51               (with-output-to-string
  52                 (lambda ()
  53                   (sxml->xml
  54                    (xml->sxml (open-input-string %xml-sample))))))))))
  55
  56 (with-test-prefix "namespaces"
  57   (pass-if-equal
  58       (xml->sxml "<foo xmlns=\"http://example.org/ns1\">text</foo>")
  59       '(*TOP* (http://example.org/ns1:foo "text")))
  60
  61   (pass-if-equal
  62       (xml->sxml "<foo xmlns=\"http://example.org/ns1\">text</foo>"
  63                  #:namespaces '((ns1 . "http://example.org/ns1")))
  64       '(*TOP* (ns1:foo "text")))
  65
  66   (pass-if-equal
  67       (xml->sxml "<foo xmlns:bar=\"http://example.org/ns2\"><bar:baz/></foo>"
  68                  #:namespaces '((ns2 . "http://example.org/ns2")))
  69       '(*TOP* (foo (ns2:baz))))
  70
  71   (pass-if-equal
  72       (xml->sxml "<foo><ns2:baz/></foo>"
  73                  #:namespaces '((ns2 . "http://example.org/ns2")))
  74       '(*TOP* (foo (ns2:baz))))
  75
  76   (pass-if-exception "namespace undeclared" parser-error
  77     (xml->sxml "<foo><ns2:baz/></foo>"
  78                #:namespaces '((ns2 . "http://example.org/ns2"))
  79                #:declare-namespaces? #f)))
  80
  81 (with-test-prefix "whitespace"
  82   (pass-if-equal
  83       (xml->sxml "<foo>\n<bar> Alfie the parrot! </bar>\n</foo>")
  84       '(*TOP* (foo "\n" (bar " Alfie the parrot! ") "\n")))
  85
  86   (pass-if-equal
  87       (xml->sxml "<foo>\n<bar> Alfie the parrot! </bar>\n</foo>"
  88                  #:trim-whitespace? #t)
  89       '(*TOP* (foo (bar " Alfie the parrot! ")))))
  90
  91 (with-test-prefix "parsed entities"
  92   (pass-if-equal
  93       '(*TOP* (foo "&"))
  94       (xml->sxml "<foo>&amp;</foo>"))
  95
  96   (pass-if-exception "nbsp undefined" parser-error
  97     (xml->sxml "<foo>&nbsp;</foo>"))
  98
  99   (pass-if-equal
 100       '(*TOP* (foo "\xA0"))
 101       (xml->sxml "<foo>&nbsp;</foo>"
 102                  #:entities '((nbsp . "\xA0"))))
 103
 104   (pass-if-equal
 105       '(*TOP* (foo "\xA0"))
 106       (xml->sxml "<foo>&#xA0;</foo>"))
 107
 108   (let ((ents '()))
 109     (pass-if-equal
 110         (xml->sxml "<foo>&nbsp; &foo;</foo>"
 111                    #:default-entity-handler
 112                    (lambda (port name)
 113                      (case name
 114                        ((nbsp) "\xa0")
 115                        (else
 116                         (set! ents (cons name ents))
 117                         "qux"))))
 118         '(*TOP* (foo "\xa0 qux")))
 119
 120     (pass-if-equal
 121         ents
 122         '(foo))))
 123
 124 (with-test-prefix "doctype handlers"
 125   (define (handle-foo docname systemid internal-subset)
 126     (case docname
 127       ((foo)
 128        (values #:entities '((greets . "<i>Hello, world!</i>"))))
 129       (else
 130        (values))))
 131
 132   (pass-if-equal
 133       (xml->sxml "<!DOCTYPE foo><p>&greets;</p>"
 134                  #:doctype-handler handle-foo)
 135       '(*TOP* (p (i "Hello, world!")))))