test.lisp

   1 ;;; -*- show-trailing-whitespace: t; indent-tabs: nil -*-
   2
   3 ;;; Copyright (c) 2007 David Lichteblau. All rights reserved.
   4 ;;; (but mostly transcribed from nu/xom/tests/*)
   5
   6 ;;; Redistribution and use in source and binary forms, with or without
   7 ;;; modification, are permitted provided that the following conditions
   8 ;;; are met:
   9 ;;;
  10 ;;;   * Redistributions of source code must retain the above copyright
  11 ;;;     notice, this list of conditions and the following disclaimer.
  12 ;;;
  13 ;;;   * Redistributions in binary form must reproduce the above
  14 ;;;     copyright notice, this list of conditions and the following
  15 ;;;     disclaimer in the documentation and/or other materials
  16 ;;;     provided with the distribution.
  17 ;;;
  18 ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
  19 ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
  20 ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
  21 ;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
  22 ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
  23 ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
  24 ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
  25 ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
  26 ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
  27 ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
  28 ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  29
  30 (defpackage :cxml-stp-test
  31   (:use :cl :rt :stp))
  32
  33 (in-package :cxml-stp-test)
  34
  35 (defmethod xmlconf::serialize-document ((document node))
  36   (serialize document (cxml:make-octet-vector-sink :canonical 2)))
  37
  38 (defun stp-test (filename handler &rest args)
  39   (declare (ignore handler))
  40   (apply #'cxml:parse-file
  41          filename
  42          (read-from-string "#.(cxml-stp:make-builder)")
  43          :recode t
  44          args))
  45
  46
  47 #+(or)
  48 (let ((cxml-stp::*serialize-canonical-notations-only-p* t))
  49   (xmlconf::run-all-tests 'xmlconf::stp-test
  50                           "/home/david/2001/XML-Test-Suite/xmlconf/"))
  51
  52
  53 (defun assert-equal (a b)
  54   (unless (equal a b)
  55     (error "assertion failed: ~S and ~S are not EQUAL" a b)))
  56
  57 (defmacro expect-condition (form type)
  58   `(handler-case
  59        (progn
  60          ,form
  61          (error "expected a condition of type ~A" ',type))
  62      (,type ())))
  63
  64 (defun serialize-to-string (node)
  65   (let ((sink (cxml:make-string-sink)))
  66     (serialize node sink)
  67     (sax:end-document sink)))
  68
  69 (defmacro define-exception-test (name form type)
  70   `(deftest ,name
  71        (progn
  72          (expect-condition ,form ,type)
  73          (values))))
  74
  75 (rem-all-tests)
  76
  77
  78 ;;;; TEXT
  79
  80 (deftest text.constructor
  81     (data (make-text "test"))
  82   "test")
  83
  84 (deftest text.legal
  85     (let ((text (make-text "name")))
  86       (dolist (str '("Hello"
  87                      "hello there"
  88                      "  spaces on both ends  "
  89                      " quotes \" \" quotes"
  90                      " single \'\' quotes"
  91                      " both double and single \"\'\"\' quotes"
  92                      " angle brackets <  > <<<"
  93                      #.(format nil " carriage returns ~C~C"
  94                         (code-char 13) (code-char 13))
  95                      #.(format nil " newlines ~C~C"
  96                         (code-char 10) (code-char 10))
  97                      #.(format nil " both ~C~C"
  98                         (code-char 13) (code-char 10))
  99                      #.(format nil " tab ~C foo"
 100                         (code-char 9))
 101                      " CDATA end: ]]>"
 102                      " <![CDATA[ CDATA end: ]]>"
 103                      " &amp; "
 104                      " ampersands & &&& &name; "))
 105         (setf (data text) str)
 106         (assert-equal (data text) str)
 107         (assert-equal (string-value text) str))
 108       (values)))
 109
 110 (deftest text.nil
 111     (let ((text (make-text "name")))
 112       (setf (data text) nil)
 113       (data text))
 114   "")
 115
 116 (define-exception-test text.illegal
 117     (let ((text (make-text "name")))
 118       (setf (data text) (format nil "test ~C test" (code-char 0))))
 119   stp-error)
 120
 121 (deftest text.serialize
 122     (let ((text (make-text "name"))
 123           (pairs '("Hello"
 124                    "hello there"
 125                    "  spaces on both ends  "
 126                    ;; zzz CXML traditionally escapes quotes without good
 127                    ;; reason:
 128                    (" quotes \" \" quotes"
 129                     " quotes &quot; &quot; quotes")
 130                    (" both double and single \"\'\"\' quotes"
 131                     " both double and single &quot;\'&quot;\' quotes")
 132                    " single \'\' quotes"
 133                    ("<>" "&lt;&gt;")
 134                    ("&amp;" "&amp;amp;")
 135                    ("]]>" "]]&gt;")
 136                    (#.(string (code-char 13)) "&#13;")
 137                    "=,.!@#$%^*()_-'[]{}+/?;:`|\\")))
 138       (loop
 139          for (in out) in (mapcar (lambda (x) (if (listp x) x (list x x)))
 140                                  pairs)
 141          do
 142            (setf (data text) in)
 143            (assert-equal (serialize-to-string text) out))
 144       (values)))
 145
 146 (deftest text.copy
 147     (let* ((c1 (make-text "test"))
 148            (c2 (copy c1)))
 149       (assert (not (eq c1 c2)))
 150       (assert-equal (data c1) (data c2))
 151       (assert-equal nil (parent c2))
 152       (assert-equal (type-of c2) 'text)
 153       (values)))
 154
 155 ;;; zzz surrogate testing is going to be a mess, because cxml will have to
 156 ;;; support both Lisps with 16 bit and with 21 bit characters.  Not the
 157 ;;; mention all the surrogate-related bugs we've got.
 158 ;;;   - testSurrogates
 159 ;;;   - testNonBMPText
 160 ;;;   - testEndOfBMP
 161 ;;;   - testHighSurrogateWithNoLowSurrogate
 162
 163 (deftest text.leaf-node
 164     (let ((c1 (make-text "data")))
 165       (assert-equal 0 (count-children-if #'identity c1))
 166       (expect-condition (nth-child 0 c1) error)
 167       (assert-equal nil (parent c1))
 168       (let ((e (make-element "test")))
 169         (append-child e c1)
 170         (assert-equal e (parent c1))
 171         (assert-equal c1 (nth-child 0 e))
 172         (delete-child c1 e)
 173         (assert-equal 0 (count-children-if #'identity e)))
 174       (values)))
 175
 176
 177 ;;;; COMMENT
 178
 179 (deftest comment.constructor
 180     (data (make-comment "test"))
 181   "test")
 182
 183 (deftest comment.constructor2
 184     (data (make-comment ""))
 185   "")
 186
 187 (deftest comment.constructor3
 188     (data (make-comment "- - "))
 189   "- - ")
 190
 191 (deftest comment.copy
 192     (let* ((c1 (make-comment "test"))
 193            (c2 (copy c1)))
 194       (assert (not (eq c1 c2)))
 195       (assert-equal (data c1) (data c2))
 196       (assert-equal nil (parent c2))
 197       (assert-equal (type-of c2) 'comment)
 198       (values)))
 199
 200 (deftest comment.serialize
 201     (let ((c (make-comment "0123456789012345678901234567890123456789")))
 202       (assert-equal (serialize-to-string c)
 203                     "<!--0123456789012345678901234567890123456789-->")
 204       (values)))
 205
 206 ;;; zzz das pruefen wir nicht
 207 ;; (define-exception-test comment.cr
 208 ;;     (make-comment (format nil "foo ~C bar" (code-char 13)))
 209 ;;   stp-error)
 210
 211 (deftest comment.setf
 212     (let ((c (make-comment "test")))
 213       (setf (data c) "legal")
 214       (assert-equal (data c) "legal")
 215       (assert-equal (string-value c) "legal")
 216       (expect-condition (setf (data c) "test -- test") stp-error)
 217       (expect-condition (setf (data c) "test-") stp-error)
 218       (setf (data c) nil)
 219       (assert-equal (data c) "")
 220       (values)))
 221
 222 ;;; zzz
 223 ;;;   - testSurrogates
 224 ;;;   - testForbidUnmatchedSurrogatesInComments
 225
 226 (deftest comment.leaf-node
 227     (let ((c1 (make-comment "data")))
 228       (assert-equal 0 (count-children-if #'identity c1))
 229       (expect-condition (nth-child 0 c1) error)
 230       (assert-equal nil (parent c1))
 231       (let ((e (make-element "test")))
 232         (append-child e c1)
 233         (assert-equal e (parent c1))
 234         (assert-equal c1 (nth-child 0 e))
 235         (delete-child c1 e)
 236         (assert-equal 0 (count-children-if #'identity e)))
 237       (values)))
 238
 239 (deftest comment.document
 240     (let ((c1 (make-comment "data"))
 241           (root (make-element "root")))
 242       (assert-equal nil (document c1))
 243       (append-child root c1)
 244       (assert-equal nil (document c1))
 245       (let ((document (make-document root)))
 246         (assert-equal document (document c1)))
 247       (values)))
 248
 249 (deftest comment.funny-characters-allowed
 250     (assert-equal (serialize-to-string (make-comment "<test>&amp;&greater;"))
 251                   "<!--<test>&amp;&greater;-->")
 252   nil)
 253
 254 (define-exception-test comment.only-char-allowed
 255     (make-comment (format nil " ~C " (code-char 1)))
 256   stp-error)
 257
 258
 259 ;;;; PROCESSING-INSTRUCTION
 260
 261 (deftest pi.constructor.1
 262     (let ((p-i (make-processing-instruction "abc" "def")))
 263       (assert-equal (target p-i) "abc")
 264       (assert-equal (data p-i) "def")
 265       (values)))
 266
 267 (deftest pi.constructor.2
 268     (data (make-processing-instruction "abc" ""))
 269   "")
 270
 271 (deftest pi.constructor.3
 272     (data (make-processing-instruction "abc" nil))
 273   "")
 274
 275 (deftest pi.constructor.4
 276     (target (make-processing-instruction "abc123" nil))
 277   "abc123")
 278
 279 (deftest pi.constructor.illegal
 280     (progn
 281       (expect-condition (make-processing-instruction "test:test" "test")
 282                         stp-error)
 283       (expect-condition (make-processing-instruction "" "test")
 284                         stp-error)
 285       (expect-condition (make-processing-instruction nil "test")
 286                         stp-error)
 287       (expect-condition (make-processing-instruction "12345" "test")
 288                         stp-error)
 289       (values)))
 290
 291 (deftest pi.serialize
 292     (serialize-to-string (make-processing-instruction "abc" "def"))
 293   "<?abc def?>")
 294
 295 (deftest pi.serialize.2
 296     (serialize-to-string (make-processing-instruction "abc" ""))
 297   "<?abc?>")
 298
 299 (deftest pi.serialize.3
 300     (serialize-to-string
 301      (make-processing-instruction "target" "<test>&amp;&greater;"))
 302   "<?target <test>&amp;&greater;?>")
 303
 304 (deftest pi.copy
 305     (let* ((c1 (make-processing-instruction "target" "data"))
 306            (c2 (copy c1)))
 307       (assert (not (eq c1 c2)))
 308       (assert-equal (data c1) (data c2))
 309       (assert-equal (target c1) (target c2))
 310       (assert-equal nil (parent c2))
 311       (assert-equal (type-of c2) 'processing-instruction)
 312       (values)))
 313
 314 (deftest pi.setf
 315     (let* ((p-i (make-processing-instruction "target" "data")))
 316       (expect-condition (setf (data p-i) "?>") stp-error)
 317       (expect-condition (setf (data p-i) "uhesta ?>") stp-error)
 318       (expect-condition (setf (data p-i) "uhesta ?> hst") stp-error)
 319       (setf (data p-i) nil)
 320       (assert-equal (data p-i) "")
 321       (dolist (str '("<html></html>"
 322                      "name=value"
 323                      "name='value'"
 324                      "name=\"value\""
 325                      "salkdhsalkjhdkjsadhkj sadhsajkdh"
 326                      "<?"
 327                      "? >"
 328                      "--"))
 329         (setf (data p-i) str)
 330         (assert-equal (data p-i) str))
 331       (values)))
 332
 333 ;;; zzz testCorrectSurrogates
 334 ;;; zzz testSurrogates
 335
 336 (deftest pi.leaf-node
 337     (let ((c1 (make-processing-instruction "target" "data")))
 338       (assert-equal 0 (count-children-if #'identity c1))
 339       (expect-condition (nth-child 0 c1) error)
 340       (assert-equal nil (parent c1))
 341       (let ((e (make-element "test")))
 342         (append-child e c1)
 343         (assert-equal e (parent c1))
 344         (assert-equal c1 (nth-child 0 e))
 345         (delete-child c1 e)
 346         (assert-equal 0 (count-children-if #'identity e)))
 347       (values)))
 348
 349 ;;; zzz das pruefen wir nicht
 350 ;; (define-exception-test pi.cr
 351 ;;     (make-processing-instruction "target" (format nil "foo ~C bar" (code-char 13)))
 352 ;;   stp-error)
 353
 354 (deftest pi.invalid
 355     (dolist (str (list "  initial spaces"
 356                        (format nil "~Cinitial tab" (code-char 9))
 357                        (format nil "~Cinitial newline" (code-char 10))
 358                        (format nil "~Cinitial cr" (code-char 13)))
 359              (values))
 360       (expect-condition (make-processing-instruction "target" str) stp-error)))
 361
 362 (deftest pi.invalid.xml
 363     (dolist (str (list "xml" "XML" "Xml")
 364              (values))
 365       (expect-condition (make-processing-instruction str "data") stp-error)))
 366
 367 (deftest pi.invalid.colon
 368     (dolist (str (list "pre:target" "pre:" ":target")
 369              (values))
 370       (expect-condition (make-processing-instruction str "data") stp-error)))
 371
 372
 373 (do-tests)