test.lisp

   1 ;;; -*- show-trailing-whitespace: t; indent-tabs-mode: nil -*-
   2
   3 ;;; Copyright (c) 2007,2008 David Lichteblau, Ivan Shvedunov.
   4 ;;; All rights reserved.
   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 (in-package :xuriella)
  31
  32 (defparameter *tests-directory*
  33   "/home/david/src/XSLT-testsuite-04/testsuite/TESTS/")
  34
  35 (defclass test-case ()
  36   ((id :initarg :id :accessor test-id)
  37    (category :initarg :category :accessor test-category)
  38    (operation :initarg :operation :accessor test-operation)
  39    (data-pathname :initarg :data-pathname :accessor test-data-pathname)
  40    (stylesheet-pathname :initarg :stylesheet-pathname
  41                         :accessor test-stylesheet-pathname)
  42    (data-pathname-2 :initarg :data-pathname-2 :accessor test-data-pathname-2)
  43    (stylesheet-pathname-2 :initarg :stylesheet-pathname-2
  44                           :accessor test-stylesheet-pathname-2)
  45    (output-pathname :initarg :output-pathname
  46                     :accessor test-official-output-pathname)
  47    (output-compare :initarg :output-compare
  48                    :accessor test-output-compare)))
  49
  50 (defmethod print-object ((object test-case) stream)
  51   (print-unreadable-object (object stream :identity nil :type t)
  52     (format stream "~A ~A/~A"
  53             (test-operation object)
  54             (test-category object)
  55             (test-id object))))
  56
  57
  58 ;;;; SIMPLIFY-TESTS
  59
  60 ;;; Translate catalog.xml into an actually usable katalog.xml
  61 ;;; by running the test cases through xsltproc to see what it thinks
  62 ;;; about them.
  63
  64 (defun simplify-tests (&optional (d *tests-directory*))
  65   (with-open-file (stream (merge-pathnames "katalog.xml" d)
  66                           :direction :output
  67                           :if-exists :supersede
  68                           :element-type '(unsigned-byte 8))
  69     (cxml:with-xml-output (cxml:make-octet-stream-sink stream)
  70       (cxml:with-element "simplified-test-suite"
  71         (klacks:with-open-source
  72             (source (klacks:make-tapping-source
  73                      (cxml:make-source (merge-pathnames "catalog.xml" d))))
  74           (let ((*default-pathname-defaults* (merge-pathnames d)))
  75             (map-original-tests #'simplify-test source)))))))
  76
  77 (defun map-original-tests (run-test source &key (test (constantly t)))
  78   (let ((total 0)
  79         (pass 0)
  80         major-path)
  81     (loop
  82        while (klacks:find-event source :start-element)
  83        for lname = (klacks:current-lname source)
  84        do
  85        (cond
  86          ((equal lname "major-path")
  87           (klacks:skip source :start-element)
  88           (setf major-path
  89                 (namestring
  90                  (merge-pathnames (klacks:consume-characters source)))))
  91          ((equal lname "test-case")
  92           (let* ((<test-case>
  93                   (stp:document-element
  94                    (klacks:serialize-element source (stp:make-builder))))
  95                  (test-case (parse-original-test major-path <test-case>)))
  96             (when (funcall test test-case)
  97               (incf total)
  98               (when (funcall run-test test-case)
  99                 (incf pass)))))
 100          (t
 101           (klacks:skip source :start-element))))
 102     (format t "~&Passed ~D/~D tests.~%" pass total)))
 103
 104 (defun parse-original-test (major-path <test-case>)
 105   (let* ((file-path
 106           (stp:string-value
 107            (stp:find-recursively-if (stp:of-name "file-path") <test-case>)))
 108          (base (concatenate 'string major-path "/" file-path))
 109          (out-base (concatenate 'string major-path "/REF_OUT/" file-path))
 110          (scenario
 111           (stp:find-recursively-if (stp:of-name "scenario") <test-case>))
 112          data
 113          stylesheet
 114          supplemental-stylesheet
 115          supplemental-data
 116          output
 117          compare)
 118     (dolist (<input> (stp:filter-recursively (stp:of-name "input-file")
 119                                              <test-case>))
 120       (let ((role (stp:attribute-value <input> "role"))
 121             (path (concatenate 'string base "/" (stp:string-value <input>))))
 122         (cond
 123           ((equal role "principal-data")
 124            (setf data path))
 125           ((equal role "principal-stylesheet")
 126            (setf stylesheet path))
 127           ((equal role "supplemental-stylesheet")
 128            (setf supplemental-stylesheet path))
 129           ((equal role "supplemental-data")
 130            (setf supplemental-data path))
 131           (t
 132            (error "unrecognized role: ~A" role)))))
 133     (dolist (<output> (stp:filter-recursively (stp:of-name "output-file")
 134                                             <test-case>))
 135       (let ((role (stp:attribute-value <output> "role"))
 136             (path (concatenate 'string out-base
 137                                "/"
 138                                (stp:string-value <output>))))
 139         (cond
 140           ((equal role "principal")
 141            (setf output path)
 142            (setf compare (stp:attribute-value <output> "compare")))
 143           (t
 144            (error "unrecognized role: ~A" role)))))
 145     (make-instance 'test-case
 146                    :id (stp:attribute-value <test-case> "id")
 147                    :category (stp:attribute-value <test-case> "category")
 148                    :operation (stp:attribute-value scenario "operation")
 149                    :data-pathname data
 150                    :stylesheet-pathname stylesheet
 151                    :stylesheet-pathname-2 supplemental-stylesheet
 152                    :data-pathname-2 supplemental-data
 153                    :output-pathname output
 154                    :output-compare compare)))
 155
 156 (defun write-simplified-test (test-case operation)
 157   (cxml:with-element "test-case"
 158     (cxml:attribute "id" (test-id test-case))
 159     (cxml:attribute "category" (test-category test-case))
 160     (flet ((p (l p)
 161              (cxml:attribute l (and p (namestring p)))))
 162       (p "data" (test-data-pathname test-case))
 163       (p "stylesheet" (noindent-stylesheet-pathname test-case))
 164       (p "data-2" (test-data-pathname-2 test-case))
 165       (p "stylesheet-2" (test-stylesheet-pathname-2 test-case))
 166       (p "output" (test-official-output-pathname test-case))
 167       (p "compare" (test-output-compare test-case)))
 168     (cxml:attribute "operation" operation)))
 169
 170 (defun test-output-pathname (test type)
 171   (make-pathname :name (test-id test)
 172                  :type type
 173                  :defaults (test-data-pathname test)))
 174
 175 (defun sanitize-stylesheet (in out)
 176   (if (probe-file in)
 177       (handler-case
 178           (let ((d (cxml:parse (pathname in) (stp:make-builder))))
 179             (xpath:with-namespaces ((nil #.*xsl*))
 180               (xpath:do-node-set (output (xpath:evaluate "//output" d))
 181                 (let ((a (stp:find-attribute-named output "indent")))
 182                   (when a
 183                     (stp:detach a)))))
 184             (with-open-file (s out
 185                                :direction :output
 186                                :if-exists :rename-and-delete
 187                                :element-type '(unsigned-byte 8))
 188               (stp:serialize d (cxml:make-octet-stream-sink s))))
 189         (error (c)
 190           (warn "ignoring bogus stylesheet ~A: ~A" in c)
 191           (copy-file in out)))
 192       (warn "oops, ignoring missing stylesheet: ~A" in)))
 193
 194 (defun noindent-stylesheet-pathname (test-case)
 195   (make-pathname :type "noindent-xsl"
 196                  :defaults (test-stylesheet-pathname test-case)))
 197
 198 (defun simplify-test (test-case)
 199   (flet ((report (status &optional (fmt "") &rest args)
 200            (format t "~&~A ~A [~A]~?~%"
 201                    status
 202                    (test-id test-case)
 203                    (test-category test-case)
 204                    fmt
 205                    args)))
 206     (let* ((data (test-data-pathname test-case))
 207            (stylesheet (test-stylesheet-pathname test-case))
 208            (noindent-stylesheet (noindent-stylesheet-pathname test-case))
 209            #+xuriella::xsltproc
 210            (out (test-output-pathname test-case "xsltproc"))
 211            (saxon-out (test-output-pathname test-case "saxon")))
 212       (sanitize-stylesheet stylesheet noindent-stylesheet)
 213       (if (equal (test-operation test-case) "standard")
 214           (handler-case
 215               (progn
 216                 #+xuriella::xsltproc (xsltproc noindent-stylesheet data out)
 217                 (saxon noindent-stylesheet data saxon-out)
 218                 (report "PASS")
 219                 (write-simplified-test test-case "standard")
 220                 t)
 221             (error (c)
 222               (report "FAIL" ": ~A" c)
 223               (write-simplified-test test-case "execution-error")
 224               nil))
 225           (handler-case
 226               (progn
 227                 #+xuriella::xsltproc
 228                 (xsltproc noindent-stylesheet data "/dev/null")
 229                 (saxon noindent-stylesheet data "/dev/null")
 230                 (report "FAIL" ": expected error not signalled")
 231                 ;; let's ignore unexpected successes for now
 232                 nil)
 233             (error (c)
 234               (report "PASS" ": expected error ~A" c)
 235               (write-simplified-test test-case "execution-error")
 236               t))))))
 237
 238 (defun xsltproc (stylesheet input output)
 239   (flet ((full-namestring (x)
 240            (namestring (merge-pathnames x))))
 241     (let* ((asdf::*verbose-out* (make-string-output-stream))
 242            (code (asdf:run-shell-command
 243                   "cd ~S && xsltproc ~S ~S >~S"
 244                   (full-namestring "")
 245                   (full-namestring stylesheet)
 246                   (full-namestring input)
 247                   (full-namestring output))))
 248       (unless (zerop code)
 249         (error "running xsltproc failed with code ~A [~%~A~%]"
 250                code
 251                (get-output-stream-string asdf::*verbose-out*))))))
 252
 253 (defun saxon (stylesheet input output)
 254   (flet ((full-namestring (x)
 255            (namestring (merge-pathnames x))))
 256     (let* ((asdf::*verbose-out* (make-string-output-stream))
 257            (code (asdf:run-shell-command
 258                   "cd ~S && java -jar /usr/share/java/saxon.jar ~S ~S >~S"
 259                   (full-namestring "")
 260                   (full-namestring input)
 261                   (full-namestring stylesheet)
 262                   (full-namestring output))))
 263       (unless (zerop code)
 264         (error "running saxon failed with code ~A [~%~A~%]"
 265                code
 266                (get-output-stream-string asdf::*verbose-out*))))))
 267
 268
 269 ;;;; RUN-TESTS and DRIBBLE-TESTS
 270
 271 ;;; Process katalog.xml
 272
 273 (defun dribble-tests
 274     (&key filter (directory *tests-directory*) (file "TEST"))
 275   (let ((*package* (find-package 'cl-user))
 276         (*print-circle* nil))
 277     (with-open-file (dribble
 278                      (merge-pathnames file
 279                                       (slot-value (asdf:find-system :xuriella)
 280                                                   'asdf::relative-pathname))
 281                      :direction :output
 282                      :if-exists :supersede
 283                      :external-format :utf-8)
 284       (let* ((dribble (make-broadcast-stream dribble *standard-output*))
 285              (*standard-output* dribble)
 286              (*trace-output* dribble)
 287              (*error-output* dribble)
 288              (*terminal-io* (make-two-way-stream *standard-input* dribble)))
 289         (handler-bind ((warning
 290                         (lambda (c)
 291                           (warn "~A" (replace-junk (princ-to-string c)))
 292                           (muffle-warning c))))
 293           (run-tests :filter filter
 294                      :directory directory))))))
 295
 296 (defparameter *bad-tests*
 297   '(;; Inconsistent tests:
 298     ;;
 299     ;; Some tests wants us to recover from this error, yet this one doesn't:
 300     "copy_copy61"
 301     "copy_copy62"
 302
 303     ;; Should we fix this?
 304     ;;
 305     ;; We signal a run-time error when and if it's actually used.  The test
 306     ;; wants a compilation-time error...
 307     "AttributeSets_RefToUndefinedAttributeSet"
 308
 309     ;; We would pass this:
 310     ;;
 311     ;; We perform recovery, but saxon doesn't.  Recovery results in non-XML
 312     ;; output, which we can't parse for comparison against the official
 313     ;; test case.
 314     "output_output75"
 315     ;;
 316     ;; we'd pass these tests, but the test authors forgot to declare the
 317     ;; entity they're writing, so we can't parse it for comparison.
 318     "output_output06"
 319     "output_output10"
 320     "output_output61"
 321     ;;
 322     ;; another similar test where the output is unparsable, except that
 323     ;; here an entity declaration wouldn't have helped either:
 324     "Copying_ResultTreeFragmentWithEscapedText"
 325
 326     ;; Broken test:
 327     ;;
 328     ;; Input document isn't ns-wf.
 329     ;;
 330     ;; FIXME: Tweak the test suite driver to consider a test a success
 331     ;; if Saxon fails and the input isn't well-formed, since that's what
 332     ;; the tests are probably meant to assert.  Or signal an XSLT-ERROR
 333     ;; in this situation after all?
 334     ;;
 335     "Attributes__78387"
 336     "Miscellaneous__84001"
 337     "Namespace_XPath_Conflict_XPath_XSLT"
 338     "Namespace_XPath_DefaultNamespace"
 339     "Namespace_XPath_NavigatorMethods"
 340     "Namespace_XPath_PredefinedPrefix_XMLNS"
 341     "Namespace_XPath_SameQuery_DiffNamespace"
 342     "Namespace_XPath_ScopingRules"
 343
 344     ;;
 345     ;; Someone commented out most of this test...
 346     "BVTs_bvt045"
 347
 348     ;; FIXME: should re-enable these at some point:
 349     ;;
 350     ;; the following tests take a lot of time due to the problems of current matching algorithm:
 351     "impincl_impincl16"
 352     ;; probably the same problem (but I haven't checked):
 353     "Import__91164"
 354
 355     ;; stack exhaustion -- matching problem i think
 356     "Keys_PerfRepro3"
 357
 358     ;; test stylesheet doesn't exist?!
 359     "ConflictResolution__77833"
 360     "Include__77736"
 361
 362     ;; har har
 363     "XSLTFunctions__84049"
 364     "XSLTFunctions__84050"
 365
 366     ;; these test the value of generate-id(), which isn't specified
 367     "Keys__91832"
 368     "Keys__91833"))
 369
 370 ;; Tests where the output isn't a match because of extraneous whitespace.
 371 ;; For these tests, we force space normalization before comparing.
 372 ;;
 373 ;; Possible reasons for this problem are:
 374 ;;   a. The output method is declared in an imported stylesheet.
 375 ;;      SANITIZE-STYLESHEET is supposed to get rid of indent="yes", but it
 376 ;;      misses imported stylesheets.
 377 ;;   b. Saxon output isn't a match, but the official output is.
 378 ;;      But the official output is unaffected by SANITIZE-STYLESHEET.
 379 ;;
 380 (defparameter *whitespace-issues*
 381   (cl-ppcre:create-scanner
 382    "(?smx)
 383     ^(BVTs_bvt044$
 384        |Namespace-alias__91782$
 385        |AttributeSets__91038$
 386        |BVTs_bvt041$
 387        |BVTs_bvt042$
 388        |BVTs_bvt054$
 389        |BVTs_bvt058$
 390        |Import__
 391        |Include__
 392        |Output__77931$
 393        |Output_EmptyElement1$
 394        |BVTs_bvt020$
 395        )"))
 396
 397 (defparameter *known-failures*
 398   '(
 399     ;; uses EBCDIC-CP-IT (whatever that is), but Babel's only got EBCDIC-US.
 400     ;; Doesn't actually test any differences between the two, so it's
 401     ;; probably just there to annoy us.
 402     "output_output22"
 403
 404     ;; uses KOI, which Babel doesn't support
 405     "BVTs_bvt019"
 406     ;;
 407     ;; ... shift_jis
 408     "Include__77515"
 409     "Output__78222"
 410     ;;
 411     ;; ... iso-2022-jp
 412     "Output__78223"
 413     "Output__78224"
 414     "Output__78225"
 415     "Output__78226"
 416     "Output__78227"
 417     "Output__78229"
 418
 419     ;; non-english sorting, which we don't support (yet?)
 420     ;;
 421     "Sorting__77977"
 422     "Sorting__91689"
 423     "Sorting__91691"
 424     "Sorting__91693"
 425     "Sorting__91694"
 426     "Sorting__91695"
 427     "Sorting__91696"
 428     "Sorting__91697"
 429     "Sorting__91698"
 430     "Sorting__91699"
 431     "Sorting__91700"
 432     "Sorting__91701"
 433     "Sorting__91752"
 434     "Sorting__91753"
 435     "Sorting_TurkishISortingTest"
 436
 437     ;; FIXME?
 438     ;;
 439     ;; This is an HTML output method issue.  The spec says the HTML
 440     ;; output method should output elements with a null namespace URI as
 441     ;; HTML, and if their name isn't recognized, as an inline element.
 442     ;; <xml> here is such an element.  It has an attribute with a
 443     ;; namespace though, and the spec doesn't say what we should do with that
 444     ;; attribute.  We currently output it using Closure HTML, and
 445     ;; lose its namespace.  This test wants the attribute and its
 446     ;; namespace to survive.
 447     "BVTs_bvt054"
 448
 449     ;; FIXME!
 450     ;;
 451     ;; Review the following test cases.  Many of them are actual bugs
 452     ;; in Xuriella.
 453     "BVTs_bvt058"
 454     "BVTs_bvt061"
 455     "BVTs_bvt067"
 456     "BVTs_bvt075"
 457     "BVTs_bvt077"
 458     "BVTs_bvt085"
 459     "BVTs_bvt086"
 460     "Elements__78362"
 461     "Number__10052"
 462     "Number__10053"
 463     "Number__84692"
 464     "Number__84700"
 465     "Number__84705"
 466     "Number__84706"
 467     "Number__84714"
 468     "Number__84715"
 469     "Number__84716"
 470     "Number__84717"
 471     "Number__84719"
 472     "Number__84720"
 473     "Number__84722"
 474     "Number__84723"
 475     "Number__84724"
 476     "Number__84725"
 477     "Number__84726"
 478     "Number__91026"
 479     "Number__91028"
 480     "Number__91029"
 481     "Output__84011"
 482     "Output__84012"
 483     "Output__84014"
 484     "Output__84016"
 485     "Output__84017"
 486     "Output__84018"
 487     "Output__84019"
 488     "Output__84020"
 489     "Output__84021"
 490     "Output__84022"
 491     "Output__84458"
 492     "Output_EmptyElement1"
 493     "Sorting_Sort_TextNodesSpanMultipleLines"
 494     "Template_ApplyTemplateWithDuplicateParameter"
 495     "Text__78272"
 496     "Text__78309"
 497     "Text__91137"
 498     "Text__78282"
 499     "XSLTFunctions__defaultPattern"
 500     "XSLTFunctions__EuropeanPattern"
 501     "XSLTFunctions__minimalValue"
 502     "XSLTFunctions__minimumValue"
 503     "XSLTFunctions__Non_DigitPattern"
 504     "XSLTFunctions__Pattern-separator"
 505     "XSLTFunctions__percentPattern"
 506     "XSLTFunctions__testWithNumber"
 507     "XSLTFunctions_BooleanFunction"
 508     "XSLTFunctions_DocumentFunctionWithAbsoluteArgument"
 509     "XSLTFunctions_DocumentFunctionWithEntityRef"
 510     "XSLTFunctions_DocumentFunctionWithNonExistingFilename"
 511     "XSLTFunctions_Bug76984"))
 512
 513 (defun known-failure-p (id)
 514   (find id *known-failures* :test #'equal))
 515
 516 (defun run-tests (&key filter (directory *tests-directory*))
 517   (when (typep filter '(or string cons))
 518     (setf filter (cl-ppcre:create-scanner filter)))
 519   (klacks:with-open-source
 520       (source (klacks:make-tapping-source
 521                (cxml:make-source (merge-pathnames "katalog.xml" directory))))
 522     (let ((*default-pathname-defaults* (merge-pathnames directory)))
 523       (map-tests #'run-test
 524                  source
 525                  :test (lambda (test)
 526                          (and (or (null filter)
 527                                   (cl-ppcre:all-matches
 528                                    filter
 529                                    (format nil "~A/~A"
 530                                            (test-category test)
 531                                            (test-id test))))
 532                               (not (find (test-id test)
 533                                          *bad-tests*
 534                                          :test #'equal))))))))
 535
 536 (defun run-named-test (name &optional (d *tests-directory*))
 537   (let ((*break-on-signals*
 538          '(and error (not babel-encodings:character-encoding-error))))
 539     (run-tests :filter (format nil "/~A$" name) :directory d)))
 540
 541 (defun copy-file (p q)
 542   (with-open-file (in p :element-type '(unsigned-byte 8))
 543     (with-open-file (out q
 544                          :element-type '(unsigned-byte 8)
 545                          :direction :output
 546                          :if-exists :rename-and-delete)
 547       (let ((buf (make-array 8192 :element-type '(unsigned-byte 8))))
 548         (loop for pos = (read-sequence buf in)
 549            until (zerop pos)
 550            do (write-sequence buf out :end pos))))))
 551
 552 (defun find-named-test (name &optional (d *tests-directory*))
 553   (klacks:with-open-source
 554       (source (klacks:make-tapping-source
 555                (cxml:make-source (merge-pathnames "katalog.xml" d))))
 556     (block nil
 557       (map-tests (lambda (test)
 558                    (return test))
 559                  source
 560                  :test (lambda (test) (equal (test-id test) name))))))
 561
 562 (defun copy-test-files (name &optional (d *tests-directory*))
 563   (let* ((test (find-named-test name d))
 564          (*default-pathname-defaults* (merge-pathnames d))
 565          (*break-on-signals*
 566           '(and error (not babel-encodings:character-encoding-error)))
 567          (target-dir (merge-pathnames "copied-test/"
 568                                       (asdf:component-pathname
 569                                        (asdf:find-system :xuriella))))
 570          (xsl (merge-pathnames "test.xsl" target-dir))
 571          (xml (merge-pathnames "test.xml" target-dir))
 572          (txt (merge-pathnames "official-output.txt" target-dir))
 573          (expected (merge-pathnames "expected.xml" target-dir))
 574          (actual (merge-pathnames "actual.xml" target-dir)))
 575     (ensure-directories-exist target-dir)
 576     (copy-file (test-stylesheet-pathname test) xsl)
 577     (copy-file (test-data-pathname test) xml)
 578     (when (test-official-output-pathname test)
 579       (copy-file (test-official-output-pathname test) txt))
 580     (format t "Test stylesheet copied to:~%  ~A~%~%" xsl)
 581     (format t "Test data copied to:~%  ~A~%~%" xml)
 582     (when (test-official-output-pathname test)
 583       (format t "Official output file:~%  ~A~%~%" txt))
 584     (format t "Run xsltproc like this:~%  cd ~A~%  xsltproc ~A ~A >~A~%~%"
 585             (namestring target-dir)
 586             (enough-namestring xsl target-dir)
 587             (enough-namestring xml target-dir)
 588             (enough-namestring expected target-dir))
 589     (format t "Run saxon like this:~%  cd ~A~%  java -jar /usr/share/java/saxon.jar ~A ~A >~A~%~%"
 590             (namestring target-dir)
 591             (enough-namestring xml target-dir)
 592             (enough-namestring xsl target-dir)
 593             (enough-namestring expected target-dir))
 594     (format t "Run MSXSL like this:~%  cd ~A~%  wine msxsl.exe ~A ~A >~A~%~%"
 595             (namestring target-dir)
 596             (enough-namestring xml target-dir)
 597             (enough-namestring xsl target-dir)
 598             (enough-namestring expected target-dir))
 599     (format t "Run xuriella like this:~%")
 600     `(apply-stylesheet ,xsl ,xml :output ,actual)))
 601
 602 (defun map-tests (run-test source &key (test (constantly t)))
 603   (let ((total 0)
 604         (pass 0)
 605         (known 0))
 606     (loop
 607        while (klacks:find-event source :start-element)
 608        for lname = (klacks:current-lname source)
 609        do
 610        (cond
 611          ((equal lname "test-case")
 612           (let* ((<test-case>
 613                   (stp:document-element
 614                    (klacks:serialize-element source (stp:make-builder))))
 615                  (test-case (parse-test <test-case>)))
 616             (when (funcall test test-case)
 617               (incf total)
 618               (ecase (funcall run-test test-case)
 619                 ((nil))
 620                 ((t)
 621                  (incf pass))
 622                 (:known-failure
 623                  (incf known))))))
 624          (t
 625           (klacks:skip source :start-element))))
 626     (format t "~&Passed ~D/~D tests (~D expected failures, ~D unexpected failures).~%"
 627             pass total known (- total pass known))))
 628
 629 (defun parse-test (<test-case>)
 630   (stp:with-attributes (id category operation
 631                            data stylesheet data-2 stylesheet-2
 632                            output compare)
 633       <test-case>
 634     (make-instance 'test-case
 635                    :id id
 636                    :category category
 637                    :operation operation
 638                    :data-pathname data
 639                    :stylesheet-pathname stylesheet
 640                    :data-pathname-2 data-2
 641                    :stylesheet-pathname-2 stylesheet-2
 642                    :output-pathname output
 643                    :output-compare compare)))
 644
 645 ;; read from file P, skipping the XMLDecl or TextDecl and Doctype at the
 646 ;; beginning, if any.
 647 (defun slurp-for-comparison (p)
 648   (with-open-file (s p :element-type '(unsigned-byte 8))
 649     (unless (and (eql (read-byte s nil) #xef)
 650                  (eql (read-byte s nil) #xbb)
 651                  (eql (read-byte s nil) #xbf))
 652       (file-position s 0))
 653     (if (plusp (file-length s))
 654         (slurp-for-comparison-1 p s t)
 655         "<wrapper/>")))
 656
 657 (defun slurp-for-comparison-1 (p s junk-info)
 658   (let ((pos (file-position s))         ;for UTF-8 "BOM"
 659         (xstream (runes:make-xstream s :speed 1))
 660         (prev-pos 0))
 661     (setf (runes:xstream-name xstream)
 662           (cxml::make-stream-name
 663            :entity-name "main document"
 664            :entity-kind :main
 665            :uri (cxml::pathname-to-uri (merge-pathnames p))))
 666     (let ((source
 667            (flet ((er (pub sys)
 668                     pub sys
 669                     (flexi-streams:make-in-memory-input-stream
 670                      #())))
 671              (cxml:make-source xstream
 672                                :pathname p
 673                                :entity-resolver #'er))))
 674       (unless (eq junk-info :nada)
 675         (loop
 676            for key = (progn
 677                        (setf prev-pos (runes:xstream-position xstream))
 678                        (klacks:peek-next source))
 679            until (eq key :start-document))
 680         (cxml::with-source (source cxml::context)
 681           (when (eq (cxml::zstream-token-category
 682                      (cxml::main-zstream cxml::context))
 683                     :NMTOKEN)
 684             ;; oops, doesn't look like XML at all
 685             (file-position s pos)
 686             (return-from slurp-for-comparison-1
 687               (slurp-for-comparison-1 p s :nada)))))
 688       (etypecase junk-info
 689         (integer
 690          (dotimes (x junk-info)
 691            (setf prev-pos (runes:xstream-position xstream))
 692            (klacks:peek-next source)))
 693         ((eql t)
 694          (let ((nskip 0))
 695            (handler-case
 696                (loop
 697                   (case (klacks:peek-next source)
 698                     (:start-element (return))
 699                     (:characters
 700                      (if (whitespacep (klacks:current-characters source))
 701                          (incf nskip)
 702                          (return)))
 703                     (t
 704                      (incf nskip))))
 705              ((or file-error cxml:xml-parse-error) ()
 706                (when (zerop nskip)
 707                  (setf nskip nil))))
 708            ;; retry
 709            (with-open-file (u p :element-type '(unsigned-byte 8))
 710              (file-position u pos)
 711              (return-from slurp-for-comparison-1
 712                (slurp-for-comparison-1 p u nskip)))))
 713         ((member nil :nada)))
 714       (with-output-to-string (r)
 715         (let* ((seen-char
 716                 (cxml::with-source (source cxml::context)
 717                   (ecase (cxml::zstream-token-category
 718                           (cxml::main-zstream cxml::context))
 719                     (:seen-< #\<)
 720                     (:? #\?)
 721                     ((nil :s)
 722                      (setf prev-pos (runes:xstream-position xstream))
 723                      nil))))
 724                (off-by-one-p (or seen-char (eq junk-info :nada)))
 725                (new-pos (- prev-pos (if off-by-one-p 1 0))))
 726           ;; copy doctype over
 727           (with-open-file (u p :element-type '(unsigned-byte 8))
 728             (file-position u pos)
 729             (let ((y (runes:make-xstream u :speed 1)))
 730               (loop
 731                  while (< (runes:xstream-position y) new-pos)
 732                  do (write-char (runes:read-rune y) r))))
 733           (write-line "<wrapper>" r)
 734           (when seen-char
 735             (write-char seen-char r)))
 736         (loop
 737            for char = (runes:read-rune xstream)
 738            until (eq char :eof)
 739            do (write-char char r))
 740         (write-line "</wrapper>" r)))))
 741
 742 (defun parse-for-comparison (p)
 743   (let* ((d (flet ((er (pub sys)
 744                     pub sys
 745                     (flexi-streams:make-in-memory-input-stream
 746                      #())))
 747               (cxml:parse (slurp-for-comparison p)
 748                           (make-text-normalizer (stp:make-builder))
 749                           :entity-resolver #'er)))
 750          (de (stp:document-element d)))
 751     (let ((first (stp:first-child de)))
 752       (when (typep first 'stp:text)
 753         (cond
 754           ((whitespacep (stp:data first))
 755            (stp:delete-child first de))
 756           (t
 757            (setf (stp:data first)
 758                  (cl-ppcre:regex-replace #.(format nil "^[~A]+" *whitespace*)
 759                                          (stp:data first)
 760                                          ""))))))
 761     (let ((last (stp:last-child de)))
 762       (when (typep last 'stp:text)
 763         (cond
 764           ((whitespacep (stp:data last))
 765            (stp:delete-child last de))
 766           (t
 767            (setf (stp:data last)
 768                  (cl-ppcre:regex-replace #.(format nil "[~A]+$" *whitespace*)
 769                                          (stp:data last)
 770                                          ""))))))
 771     d))
 772
 773 (defun output-equal-p (compare p q &key normalize)
 774   (handler-case
 775       (case compare
 776         (:html (html-output-equal-p p q))
 777         (:text (text-output-equal-p p q))
 778         (t (xml-output-equal-p p q normalize)))
 779     ((or error parse-number::invalid-number) (c)
 780       (warn "comparison failed: ~A" c)
 781       ;; try again using a plain-text comparision, sometimes it helps:
 782       (and (not (eq compare :text))
 783            (output-equal-p :text p q :normalize normalize)))))
 784
 785 ;; Workaround for namespace_namespace23 and other tests:
 786 ;;  - For these tests, saxon and msxsl output a declaration for the XSL
 787 ;;    namespace without using that declaration.
 788 ;;  - I think saxon and msxsl are both wrong.
 789 ;;  - The official test output agrees with my assessment.
 790 ;;    (So does libxslt, but that's not to be trusted. :-))
 791 ;;  - Here's the catch: The official test output is broken in its whitespace
 792 ;;    handling.
 793 ;; So let's normalize spaces in test output that looks like an XSLT
 794 ;; stylesheet, allowing us to pass these tests using the official test output.
 795 (defun maybe-normalize-test-spaces (wrapper force)
 796   (let ((i 0))
 797     (loop while (< i (length (cxml-stp-impl::%children wrapper))) do
 798          (let ((wrapper-child (stp:nth-child i wrapper)))
 799            (cond
 800              ((not (typep wrapper-child 'stp:element))
 801               (if force
 802                   (stp:delete-nth-child i wrapper)
 803                   (incf i)))
 804              ((or (equal (stp:namespace-uri wrapper-child) *xsl*)
 805                   force)
 806               (strip-stylesheet wrapper-child)
 807               (labels ((recurse (e &optional preserve)
 808                          (stp:do-children (child e)
 809                            (typecase child
 810                              (stp:text
 811                               (setf (stp:data child)
 812                                     (normalize-whitespace (stp:data child))))
 813                              (stp:element
 814                                  (stp:with-attributes ((space "space" *xml*))
 815                                      child
 816                                    (let ((new-preserve
 817                                           (cond
 818                                             ((namep child "text") t)
 819                                             ((not space) preserve)
 820                                             ((equal space "preserve") t)
 821                                             (t nil))))
 822                                      (recurse child new-preserve))))))))
 823                 (recurse wrapper-child))
 824               (incf i))
 825              (t
 826               (incf i)))))))
 827
 828 (defun xml-output-equal-p (p q normalize)
 829   (let ((r (parse-for-comparison p))
 830         (s (parse-for-comparison q)))
 831     (maybe-normalize-test-spaces (stp:document-element r) normalize)
 832     (maybe-normalize-test-spaces (stp:document-element s) normalize)
 833     (and (let ((u (stp:document-type r))
 834                (v (stp:document-type s)))
 835            (if u
 836                (and v (node= u v))
 837                (null v)))
 838          (node= (stp:document-element r) (stp:document-element s)))))
 839
 840 ;; FIXME: don't do this in <pre> etc.
 841 (defun normalize-html-whitespace (node)
 842   (when (typep node 'stp:parent-node)
 843     ;; ignore newlines after start tags completely
 844     (let ((first (stp:first-child node)))
 845       (when (and (typep first 'stp:text)
 846                  (alexandria:starts-with #\newline (stp:data first)))
 847         (setf (stp:data first) (subseq (stp:data first) 1))))
 848     ;; ignore newlines before end tags completely
 849     (let ((last (stp:last-child node)))
 850       (when (and (typep last 'stp:text)
 851                  (alexandria:ends-with #\newline (stp:data last)))
 852         (setf (stp:data last)
 853               (subseq (stp:data last) 0 (length (stp:data last))))))
 854     ;; normalize sequences of whitespace
 855     (stp:do-children (child node)
 856       (if (typep child 'stp:text)
 857           (setf (stp:data child)
 858                 (let ((str (normalize-whitespace (stp:data child))))
 859                   (when
 860                       ;; FIXME!  Here we remove whitespace entirely.
 861                       ;; Totally incorrect, but I don't see how we could
 862                       ;; watch Saxon's output otherwise.
 863                       (equal str " ")
 864                     (setf str ""))
 865                   str))
 866           (normalize-html-whitespace child)))
 867     ;; just to be sure, join adjacent nodes
 868     (cxml-stp-impl::normalize-text-nodes! node)))
 869
 870 ;; FIXME: this check is too lenient, because chtml is an error-correcting
 871 ;; parser.
 872 (defun html-output-equal-p (p q)
 873   (let ((r (chtml:parse (pathname p) (stp:make-builder)))
 874         (s (chtml:parse (pathname q) (stp:make-builder))))
 875     (normalize-html-whitespace r)
 876     (normalize-html-whitespace s)
 877     (flet ((fix-case (node)
 878              (xpath:with-namespaces (("xhtml" "http://www.w3.org/1999/xhtml"))
 879                (xpath:do-node-set
 880                    (content (xpath:evaluate "//xhtml:meta/@content" node))
 881                  (setf (stp:value content)
 882                        (string-downcase (stp:value content)))))))
 883       (fix-case r)
 884       (fix-case s))
 885     (node= (stp:document-element r) (stp:document-element s))))
 886
 887 (defun text-output-equal-p (p q)
 888   (with-open-file (a p :element-type '(unsigned-byte 8))
 889     (with-open-file (b q :element-type '(unsigned-byte 8))
 890       (let ((len (file-length a)))
 891         (and (eql len (file-length b))
 892              (let ((d (make-array len :element-type '(unsigned-byte 8)))
 893                    (e (make-array len :element-type '(unsigned-byte 8))))
 894                (read-sequence d a)
 895                (read-sequence e b)
 896                (equalp d e)))))))
 897
 898 (defun strip-addresses (str)
 899   (cl-ppcre:regex-replace-all "{[0-9a-fA-F]+}\\>" str "{xxxxxxxx}>"))
 900
 901 (defun slurp-output-method (p)
 902   (xpath:with-namespaces ((nil #.*xsl*))
 903     (let* ((d (handler-bind
 904                   ((warning #'muffle-warning))
 905                 (cxml:parse (pathname p) (stp:make-builder))))
 906            (output (xpath:first-node (xpath:evaluate "//output" d))))
 907       (if output
 908           (let ((method (stp:attribute-value output "method")))
 909             (if method
 910                 (intern (string-upcase method) :keyword)
 911                 :xml))
 912           :xml))))
 913
 914 (defun replace-junk (str)
 915   (cl-ppcre:regex-replace-all
 916    `(:group ,(namestring *tests-directory*))
 917    (map 'string
 918         (lambda (c)
 919           (if (or (eql c #\newline) (<= 32 (char-code c) 126))
 920               c
 921               #\?))
 922         str)
 923    "..."))
 924
 925 (defun run-test (test)
 926   (let ((expected-saxon (test-output-pathname test "saxon"))
 927         #+xuriella::xsltproc
 928         (expected-xsltproc (test-output-pathname test "xsltproc"))
 929         (actual (test-output-pathname test "xuriella"))
 930         (official (test-official-output-pathname test))
 931         (force-normalization
 932          (cl-ppcre:all-matches *whitespace-issues* (test-id test)))
 933         (output-method nil))
 934     (handler-bind ((|hey test suite, this is an HTML document|
 935                     (lambda (c)
 936                       (declare (ignore c))
 937                       (setf output-method :html))))
 938       (labels ((uri-resolver (uri)
 939                  (let ((str (puri:render-uri uri nil)))
 940                    (cond
 941                      ((search "%5c%5c%5c%5cwebxtest%5c%5cmanagedshadow%5c%5cmanaged_b2%5c%5ctestdata%5c%5cxslt%5c%5celement%5c%5cxslt_element_NSShared.xml"
 942                               str)
 943                       (cxml::pathname-to-uri
 944                        (merge-pathnames
 945                         "MSFT_Conformance_Tests/Elements/xslt_element_NSShared.xml"
 946                         *tests-directory*)))
 947                      ((search "webxtest/testcases/91156a.xsl" str)
 948                       (cxml::pathname-to-uri
 949                        (merge-pathnames
 950                         "MSFT_Conformance_Tests/Import/91156a.xsl"
 951                         *tests-directory*)))
 952                      (t
 953                       uri))))
 954                (doit ()
 955                  (with-open-file (s actual
 956                                     :if-exists :rename-and-delete
 957                                     :direction :output
 958                                     :element-type '(unsigned-byte 8))
 959                    (handler-bind ((xslt-error
 960                                    (lambda (c)
 961                                      (declare (ignore c))
 962                                      (when (find-restart 'recover)
 963                                        (invoke-restart 'recover)))))
 964                      (apply-stylesheet (pathname (test-stylesheet-pathname test))
 965                                        (let ((p (test-data-pathname test)))
 966                                          (cond
 967                                            ((search "Elements/Plants.xml" p)
 968                                             (merge-pathnames
 969                                              "MSFT_Conformance_Tests/Elements/plants.xml"
 970                                              *tests-directory*))
 971                                            ((search "/OutputText.xml" p)
 972                                             (merge-pathnames
 973                                              "MSFT_Conformance_Tests/Output/Outputtext.xml"
 974                                              *tests-directory*))
 975                                            ((search "Text/text.xml" p)
 976                                             (merge-pathnames
 977                                              "MSFT_Conformance_Tests/Text/Text.xml"
 978                                              *tests-directory*))
 979                                            (t
 980                                             (pathname p))))
 981                                        :output s
 982                                        :uri-resolver #'uri-resolver))))
 983                (pp (label pathname)
 984                  (when pathname
 985                    (format t "  ~A: ~A~%"
 986                            label
 987                            (enough-namestring pathname *tests-directory*))))
 988                (report (ok &optional (fmt "") &rest args)
 989                  (write-string
 990                   (replace-junk
 991                    (strip-addresses
 992                     (format nil "~&~A ~A [~A]~?~%"
 993                             (cond
 994                               (ok
 995                                (if (known-failure-p (test-id test))
 996                                    "UNEXPECTED-SUCCESS"
 997                                    "PASS"))
 998                               ((known-failure-p (test-id test))
 999                                (setf ok :known-failure)
1000                                "KNOWNFAIL")
1001                               (t
1002                                "FAIL"))
1003                             (test-id test)
1004                             (test-category test)
1005                             fmt
1006                             args))))
1007                  (pp "Stylesheet" (test-stylesheet-pathname test))
1008                  (pp "Data" (test-data-pathname test))
1009                  (pp "Supplemental stylesheet"
1010                      (test-stylesheet-pathname-2 test))
1011                  (pp "Supplemental data" (test-data-pathname-2 test))
1012                  (pp "Expected output (1)" expected-saxon)
1013                  #+xuriella::xsltproc
1014                  (pp "Expected output (2)" expected-xsltproc)
1015                  (pp "Actual output" actual)
1016                  (terpri)
1017                  ok))
1018         (cond
1019           ((equal (test-operation test) "standard")
1020            (handler-case
1021                (progn
1022                  (when (find (test-id test)
1023                              nil ;;'("axes_axes47" "attribset_attribset20")
1024                              :test #'equal)
1025                    (error "skipping problematic test"))
1026                  (doit)
1027                  (let* ((output-method
1028                          (or output-method
1029                              (slurp-output-method
1030                               (test-stylesheet-pathname test))))
1031                         (saxon-matches-p
1032                          (output-equal-p output-method
1033                                          expected-saxon
1034                                          actual
1035                                          :normalize force-normalization))
1036                         #+xuriella::xsltproc
1037                         (xsltproc-matches-p
1038                          (output-equal-p output-method
1039                                          expected-xsltproc
1040                                          actual))
1041                         (official-matches-p
1042                          (output-equal-p output-method
1043                                          official
1044                                          actual
1045                                          :normalize force-normalization)))
1046                    (cond
1047                      ((or saxon-matches-p
1048                           #+xuriella::xsltproc xsltproc-matches-p
1049                           official-matches-p)
1050                       (report t)
1051                       #+xuriella::xsltproc
1052                       (report t ": saxon ~A, xsltproc ~A~:[~; (MISMATCH)~]"
1053                               saxon-matches-p
1054                               xsltproc-matches-p
1055                               (if saxon-matches-p
1056                                   (not xsltproc-matches-p)
1057                                   xsltproc-matches-p)))
1058                      (t
1059                       (report nil ": output doesn't match")))))
1060              ((or error parse-number::invalid-number) (c)
1061                (report nil ": ~A" c))))
1062           (t
1063            (handler-case
1064                (doit)
1065              (xslt-error (c)
1066                (report t ": raised an xslt-error as expected" c))
1067              ((or error parse-number::invalid-number) (c)
1068                (report nil ": condition of incorrect type: ~%~A" c))
1069              (:no-error (result)
1070                (cond
1071                  ((not (and official (probe-file official)))
1072                   (report nil ": expected error not signalled: " result))
1073                  ((output-equal-p
1074                    (or output-method
1075                        (slurp-output-method (test-stylesheet-pathname test)))
1076                    official
1077                    actual
1078                    :normalize force-normalization)
1079                   (report t))
1080                  (t
1081                   (report nil ": saxon error not signalled and official output not a match")))))))))))
1082
1083 (defun run-xpath-tests ()
1084   (run-tests :filter "XPath-Expression/|XSLT-Data-Model/"))
1085
1086
1087 ;;;; from cxml-stp-test
1088
1089 (defun assert-node= (a b)
1090   (unless (node= a b)
1091     (error "assertion failed: ~S and ~S are not NODE=" a b)))
1092
1093 (defun child-count (node)
1094   (stp:count-children-if (constantly t) node))
1095
1096 (defun named-node-= (a b)
1097   (and (equal (stp:namespace-uri a) (stp:namespace-uri b))
1098        ;; (equal (stp:namespace-prefix a) (stp:namespace-prefix b))
1099        (equal (stp:local-name a) (stp:local-name b))))
1100
1101 (defun parent-node-= (e f)
1102   (and (eql (child-count e)
1103             (child-count f))
1104        (every #'node= (stp:list-children e) (stp:list-children f))))
1105
1106 (defmethod node= ((e stp:element) (f stp:element))
1107   (and (named-node-= e f)
1108        (parent-node-= e f)
1109        (null
1110         (set-exclusive-or (stp:list-attributes e) (stp:list-attributes f)
1111                           :test #'node=))
1112        (block nil
1113          (flet ((check-namespaces (a b)
1114                   (let ((result ()))
1115                     (stp:map-extra-namespaces
1116                      (lambda (k v)
1117                        (unless (equal v (stp:find-namespace k b))
1118                          (return nil)))
1119                      a)
1120                     result)))
1121            (check-namespaces e f)
1122            (check-namespaces f e))
1123          t)))
1124
1125 (defmethod node= ((a stp:node) (b stp:node))
1126   nil)
1127
1128 (defmethod node= ((e stp:document) (f stp:document))
1129   (parent-node-= e f))
1130
1131 (defmethod node= ((a stp:attribute) (b stp:attribute))
1132   (and (named-node-= a b)
1133        (equal (stp:value a) (stp:value b))))
1134
1135 (defmethod node= ((a stp:comment) (b stp:comment))
1136   (equal (stp:data a) (stp:data b)))
1137
1138 (defmethod node= ((a stp:text) (b stp:text))
1139   (equal (stp:data a) (stp:data b)))
1140
1141 (defmethod node= ((a stp:processing-instruction)
1142                   (b stp:processing-instruction))
1143   (and (equal (stp:data a) (stp:data b))
1144        (equal (stp:target a) (stp:target b))))
1145
1146 (defmethod node= ((a stp:document-type) (b stp:document-type))
1147   (and (equal (stp:root-element-name a) (stp:root-element-name b))
1148        (equal (stp:public-id a) (stp:public-id b))
1149        (equal (stp:system-id a) (stp:system-id b))
1150        (equal (stp:internal-subset a) (stp:internal-subset b))))
1151
1152 (xpath-sys:define-xpath-function/eager
1153     xslt :print
1154     (thing)
1155   (if (xpath:node-set-p thing)
1156       (loop
1157          initially (format t ";;; node set:~%")
1158          for i from 0
1159          for node in (xpath:all-nodes thing)
1160          do
1161            (format t ";;;   ~D: ~A~%" i (type-of node)))
1162       (format t ";;; ~A~%" thing))
1163   thing)