test.lisp

   1 ;;; -*- show-trailing-whitespace: t; indent-tabs: 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 ;; temporary configuration until we support enough XSLT that it's worth
 274 ;; running all tests:
 275 (defparameter *default-categories*
 276   ;; '("XSLT-Data-Model" "XPath-Expression" "XPath-Data-Model")
 277   nil)
 278
 279 (defun dribble-tests (&optional (category *default-categories*)
 280                       (d *tests-directory*))
 281   (let ((*package* (find-package 'cl-user)))
 282     (with-open-file (dribble
 283                      (merge-pathnames "TEST"
 284                                       (slot-value (asdf:find-system :xuriella)
 285                                                   'asdf::relative-pathname))
 286                      :direction :output
 287                      :if-exists :supersede
 288                      :external-format :utf-8)
 289       (let* ((dribble (make-broadcast-stream dribble *standard-output*))
 290              (*standard-output* dribble)
 291              (*trace-output* dribble)
 292              (*error-output* dribble)
 293              (*terminal-io* (make-two-way-stream *standard-input* dribble)))
 294         (run-tests category d)))))
 295
 296 (defparameter *bad-tests*
 297   '( ;; some tests wants us to recover from this error, yet this one doesn't:
 298     "copy_copy61"
 299     "copy_copy62"
 300     ;; the following tests take a lot of time due to the problems of current matching algorithm:
 301     "impincl_impincl16"
 302     "match_match13"
 303     ;; the following test is actually okay, but running it takes longer
 304     ;; than I'm willing to wait before every checkin:
 305     "Import__91164"))
 306
 307 (defun run-tests (&optional (categories *default-categories*)
 308                   (d *tests-directory*))
 309   (unless (listp categories)
 310     (setf categories (list categories)))
 311   (klacks:with-open-source
 312       (source (klacks:make-tapping-source
 313                (cxml:make-source (merge-pathnames "katalog.xml" d))))
 314     (let ((*default-pathname-defaults* (merge-pathnames d)))
 315       (map-tests #'run-test
 316                  source
 317                  :test (lambda (test)
 318                          (and (or (null categories)
 319                                   (find (test-category test)
 320                                         categories
 321                                         :test #'equal))
 322                               (not (find (test-id test)
 323                                          *bad-tests*
 324                                          :test #'equal))))))))
 325
 326 (defun run-named-test (name &optional (d *tests-directory*))
 327   (klacks:with-open-source
 328       (source (klacks:make-tapping-source
 329                (cxml:make-source (merge-pathnames "katalog.xml" d))))
 330     (let ((*default-pathname-defaults* (merge-pathnames d))
 331           (*break-on-signals* 'error))
 332       (map-tests #'run-test
 333                  source
 334                  :test (lambda (test) (equal (test-id test) name))))))
 335
 336 (defun copy-file (p q)
 337   (with-open-file (in p :element-type '(unsigned-byte 8))
 338     (with-open-file (out q
 339                          :element-type '(unsigned-byte 8)
 340                          :direction :output
 341                          :if-exists :rename-and-delete)
 342       (let ((buf (make-array 8192 :element-type '(unsigned-byte 8))))
 343         (loop for pos = (read-sequence buf in)
 344            until (zerop pos)
 345            do (write-sequence buf out :end pos))))))
 346
 347 (defun find-named-test (name &optional (d *tests-directory*))
 348   (klacks:with-open-source
 349       (source (klacks:make-tapping-source
 350                (cxml:make-source (merge-pathnames "katalog.xml" d))))
 351     (block nil
 352       (map-tests (lambda (test)
 353                    (return test))
 354                  source
 355                  :test (lambda (test) (equal (test-id test) name))))))
 356
 357 (defun copy-test-files (name &optional (d *tests-directory*))
 358   (let* ((test (find-named-test name d))
 359          (*default-pathname-defaults* (merge-pathnames d))
 360          (*break-on-signals* 'error)
 361          (target-dir (merge-pathnames "copied-test/"
 362                                       (asdf:component-pathname
 363                                        (asdf:find-system :xuriella))))
 364          (xsl (merge-pathnames "test.xsl" target-dir))
 365          (xml (merge-pathnames "test.xml" target-dir))
 366          (txt (merge-pathnames "official-output.txt" target-dir))
 367          (expected (merge-pathnames "expected.xml" target-dir))
 368          (actual (merge-pathnames "actual.xml" target-dir)))
 369     (ensure-directories-exist target-dir)
 370     (copy-file (test-stylesheet-pathname test) xsl)
 371     (copy-file (test-data-pathname test) xml)
 372     (when (test-official-output-pathname test)
 373       (copy-file (test-official-output-pathname test) txt))
 374     (format t "Test stylesheet copied to:~%  ~A~%~%" xsl)
 375     (format t "Test data copied to:~%  ~A~%~%" xml)
 376     (when (test-official-output-pathname test)
 377       (format t "Official output file:~%  ~A~%~%" txt))
 378     (format t "Run xsltproc like this:~%  cd ~A~%  xsltproc ~A ~A >~A~%~%"
 379             (namestring target-dir)
 380             (enough-namestring xsl target-dir)
 381             (enough-namestring xml target-dir)
 382             (enough-namestring expected target-dir))
 383     (format t "Run saxon like this:~%  cd ~A~%  java -jar /usr/share/java/saxon.jar ~A ~A >~A~%~%"
 384             (namestring target-dir)
 385             (enough-namestring xml target-dir)
 386             (enough-namestring xsl target-dir)
 387             (enough-namestring expected target-dir))
 388     (format t "Run MSXSL like this:~%  cd ~A~%  wine msxsl.exe ~A ~A >~A~%~%"
 389             (namestring target-dir)
 390             (enough-namestring xml target-dir)
 391             (enough-namestring xsl target-dir)
 392             (enough-namestring expected target-dir))
 393     (format t "Run xuriella like this:~%")
 394     `(apply-stylesheet ,xsl ,xml :output ,actual)))
 395
 396 (defun map-tests (run-test source &key (test (constantly t)))
 397   (let ((total 0)
 398         (pass 0))
 399     (loop
 400        while (klacks:find-event source :start-element)
 401        for lname = (klacks:current-lname source)
 402        do
 403        (cond
 404          ((equal lname "test-case")
 405           (let* ((<test-case>
 406                   (stp:document-element
 407                    (klacks:serialize-element source (stp:make-builder))))
 408                  (test-case (parse-test <test-case>)))
 409             (when (funcall test test-case)
 410               (incf total)
 411               (when (funcall run-test test-case)
 412                 (incf pass)))))
 413          (t
 414           (klacks:skip source :start-element))))
 415     (format t "~&Passed ~D/~D tests.~%" pass total)))
 416
 417 (defun parse-test (<test-case>)
 418   (stp:with-attributes (id category operation
 419                            data stylesheet data-2 stylesheet-2
 420                            output compare)
 421       <test-case>
 422     (make-instance 'test-case
 423                    :id id
 424                    :category category
 425                    :operation operation
 426                    :data-pathname data
 427                    :stylesheet-pathname stylesheet
 428                    :data-pathname-2 data-2
 429                    :stylesheet-pathname-2 stylesheet-2
 430                    :output-pathname output
 431                    :output-compare compare)))
 432
 433 ;; read from file P, skipping the XMLDecl or TextDecl and Doctype at the
 434 ;; beginning, if any.
 435 (defun slurp-for-comparison (p)
 436   (with-open-file (s p :element-type '(unsigned-byte 8))
 437     (unless (and (eql (read-byte s nil) #xef)
 438                  (eql (read-byte s nil) #xbb)
 439                  (eql (read-byte s nil) #xbf))
 440       (file-position s 0))
 441     (if (plusp (file-length s))
 442         (let ((xstream (runes:make-xstream s :speed 1)))
 443           (setf (runes:xstream-name xstream)
 444                 (cxml::make-stream-name
 445                  :entity-name "main document"
 446                  :entity-kind :main
 447                  :uri (cxml::pathname-to-uri (merge-pathnames p))))
 448           (let ((source (cxml:make-source xstream :pathname p)))
 449             (loop
 450                for key = (klacks:peek-next source)
 451                until (eq key :start-document))
 452             (with-output-to-string (r)
 453               (write-line "<wrapper>" r)
 454               (cxml::with-source (source cxml::context)
 455                 (when (eq (cxml::zstream-token-category
 456                            (cxml::main-zstream cxml::context))
 457                           :seen-<)
 458                   (write-char #\< r)))
 459               (loop
 460                  for char = (runes:read-rune xstream)
 461                  until (eq char :eof)
 462                  do (write-char char r))
 463               (write-line "</wrapper>" r))))
 464         "<wrapper/>")))
 465
 466 (defun parse-for-comparison (p)
 467   (let* ((d (cxml:parse (slurp-for-comparison p)
 468                         (make-text-normalizer (stp:make-builder))))
 469          (de (stp:document-element d)))
 470     (let ((first (stp:first-child de)))
 471       (when (typep first 'stp:text)
 472         (cond
 473           ((whitespacep (stp:data first))
 474            (stp:delete-child first de))
 475           (t
 476            (setf (stp:data first)
 477                  (cl-ppcre:regex-replace #.(format nil "^[~A]+" *whitespace*)
 478                                          (stp:data first)
 479                                          ""))))))
 480     (let ((last (stp:last-child de)))
 481       (when (typep last 'stp:text)
 482         (cond
 483           ((whitespacep (stp:data last))
 484            (stp:delete-child last de))
 485           (t
 486            (setf (stp:data last)
 487                  (cl-ppcre:regex-replace #.(format nil "[~A]+$" *whitespace*)
 488                                          (stp:data last)
 489                                          ""))))))
 490     d))
 491
 492 (defun output-equal-p (compare p q)
 493   (handler-case
 494       (ecase compare
 495         (:xml (xml-output-equal-p p q))
 496         (:html (html-output-equal-p p q)))
 497     ((or error parse-number::invalid-number) (c)
 498       (warn "comparison failed: ~A" c)
 499       nil)))
 500
 501 (defun xml-output-equal-p (p q)
 502   (let ((r (parse-for-comparison p))
 503         (s (parse-for-comparison q)))
 504     (node= (stp:document-element r) (stp:document-element s))))
 505
 506 ;; FIXME: don't do this in <pre> etc.
 507 (defun normalize-html-whitespace (node)
 508   (when (typep node 'stp:parent-node)
 509     ;; ignore newlines after start tags completely
 510     (let ((first (stp:first-child node)))
 511       (when (and (typep first 'stp:text)
 512                  (alexandria:starts-with #\newline (stp:data first)))
 513         (setf (stp:data first) (subseq (stp:data first) 1))))
 514     ;; ignore newlines before end tags completely
 515     (let ((last (stp:last-child node)))
 516       (when (and (typep last 'stp:text)
 517                  (alexandria:ends-with #\newline (stp:data last)))
 518         (setf (stp:data last)
 519               (subseq (stp:data last) 0 (length (stp:data last))))))
 520     ;; normalize sequences of whitespace
 521     (stp:do-children (child node)
 522       (if (typep child 'stp:text)
 523           (setf (stp:data child)
 524                 (let ((str (normalize-whitespace (stp:data child))))
 525                   (when
 526                       ;; FIXME!  Here we remove whitespace entirely.
 527                       ;; Totally incorrect, but I don't see how we could
 528                       ;; watch Saxon's output otherwise.
 529                       (equal str " ")
 530                     (setf str ""))
 531                   str))
 532           (normalize-html-whitespace child)))
 533     ;; just to be sure, join adjacent nodes
 534     (cxml-stp-impl::normalize-text-nodes! node)))
 535
 536 ;; FIXME: this check is too lenient, because chtml is an error-correcting
 537 ;; parser.
 538 (defun html-output-equal-p (p q)
 539   (let ((r (chtml:parse (pathname p) (stp:make-builder)))
 540         (s (chtml:parse (pathname q) (stp:make-builder))))
 541     (normalize-html-whitespace r)
 542     (normalize-html-whitespace s)
 543     (node= (stp:document-element r) (stp:document-element s))))
 544
 545 (defun strip-addresses (str)
 546   (cl-ppcre:regex-replace-all "{[0-9a-fA-F]+}\\>" str "{xxxxxxxx}>"))
 547
 548 (defun slurp-output-method (p)
 549   (xpath:with-namespaces ((nil #.*xsl*))
 550     (let* ((d (handler-bind
 551                   ((warning #'muffle-warning))
 552                 (cxml:parse (pathname p) (stp:make-builder))))
 553            (output (xpath:first-node (xpath:evaluate "//output" d))))
 554       (if output
 555           (let ((method (stp:attribute-value output "method")))
 556             (if method
 557                 (intern (string-upcase method) :keyword)
 558                 :xml))
 559           :xml))))
 560
 561 (defun replace-junk (str)
 562   (map 'string
 563        (lambda (c)
 564          (if (or (eql c #\newline) (<= 32 (char-code c) 126))
 565              c
 566              #\?))
 567        str))
 568
 569 (defun run-test (test)
 570   (let ((expected-saxon (test-output-pathname test "saxon"))
 571         #+xuriella::xsltproc
 572         (expected-xsltproc (test-output-pathname test "xsltproc"))
 573         (actual (test-output-pathname test "xuriella"))
 574         (official (test-official-output-pathname test)))
 575     (labels ((uri-resolver (uri)
 576                (if (search "%5c%5c%5c%5cwebxtest%5c%5cmanagedshadow%5c%5cmanaged_b2%5c%5ctestdata%5c%5cxslt%5c%5celement%5c%5cxslt_element_NSShared.xml"
 577                            uri)
 578                    (cxml::pathname-to-uri
 579                     (merge-pathnames
 580                      "MSFT_Conformance_Tests/Elements/xslt_element_NSShared.xml"
 581                      *tests-directory*))
 582                    uri))
 583              (doit ()
 584                (with-open-file (s actual
 585                                   :if-exists :rename-and-delete
 586                                   :direction :output
 587                                   :element-type '(unsigned-byte 8))
 588                  (handler-bind ((xslt-error
 589                                  (lambda (c)
 590                                    (declare (ignore c))
 591                                    (when (find-restart 'recover)
 592                                      (invoke-restart 'recover)))))
 593                    (apply-stylesheet (pathname (test-stylesheet-pathname test))
 594                                      (pathname (test-data-pathname test))
 595                                      :output s
 596                                      :uri-resolver #'uri-resolver))))
 597              (pp (label pathname)
 598                (when pathname
 599                  (format t "  ~A: ~A~%"
 600                          label
 601                          (enough-namestring pathname *tests-directory*))))
 602              (report (ok &optional (fmt "") &rest args)
 603                (write-string
 604                 (replace-junk
 605                  (strip-addresses
 606                   (format nil "~&~:[FAIL~;PASS~] ~A [~A]~?~%"
 607                           ok
 608                           (test-id test)
 609                           (test-category test)
 610                           fmt
 611                           args))))
 612                (pp "Stylesheet" (test-stylesheet-pathname test))
 613                (pp "Data" (test-data-pathname test))
 614                (pp "Supplemental stylesheet"
 615                    (test-stylesheet-pathname-2 test))
 616                (pp "Supplemental data" (test-data-pathname-2 test))
 617                (pp "Expected output (1)" expected-saxon)
 618                #+xuriella::xsltproc
 619                (pp "Expected output (2)" expected-xsltproc)
 620                (pp "Actual output" actual)
 621                (terpri)
 622                ok))
 623       (cond
 624         ((equal (test-operation test) "standard")
 625          (handler-case
 626              (let ((output-method
 627                     (slurp-output-method (test-stylesheet-pathname test))))
 628                (when (find (test-id test)
 629                            nil ;;'("axes_axes47" "attribset_attribset20")
 630                            :test #'equal)
 631                  (error "skipping problematic test"))
 632                (doit)
 633                (let ((saxon-matches-p
 634                       (output-equal-p output-method
 635                                       expected-saxon
 636                                       actual))
 637                      #+xuriella::xsltproc
 638                      (xsltproc-matches-p
 639                       (output-equal-p output-method
 640                                       expected-xsltproc
 641                                       actual))
 642                      (official-matches-p
 643                       (output-equal-p output-method
 644                                       official
 645                                       actual)))
 646                  (cond
 647                    ((or saxon-matches-p
 648                         #+xuriella::xsltproc xsltproc-matches-p
 649                         official-matches-p)
 650                     (report t)
 651                     #+xuriella::xsltproc
 652                     (report t ": saxon ~A, xsltproc ~A~:[~; (MISMATCH)~]"
 653                             saxon-matches-p
 654                             xsltproc-matches-p
 655                             (if saxon-matches-p
 656                                 (not xsltproc-matches-p)
 657                                 xsltproc-matches-p)))
 658                    (t
 659                     (report nil ": output doesn't match")))))
 660            ((or error parse-number::invalid-number) (c)
 661             (report nil ": ~A" c))))
 662         (t
 663          (handler-case
 664              (doit)
 665            (xslt-error (c)
 666              (report t ": raised an xslt-error as expected" c))
 667            ((or error parse-number::invalid-number) (c)
 668              (report nil ": condition of incorrect type: ~%~A" c))
 669            (:no-error (result)
 670              (cond
 671                ((not (and official (probe-file official)))
 672                 (report nil ": expected error not signalled: " result))
 673                ((output-equal-p
 674                  (slurp-output-method (test-stylesheet-pathname test))
 675                  official
 676                  actual)
 677                 (report t))
 678                (t
 679                 (report nil ": saxon error not signalled and official output not a match"))))))))))
 680
 681 (defun run-xpath-tests ()
 682   (run-tests '("XPath-Expression" "XSLT-Data-Model")))
 683
 684
 685 ;;;; from cxml-stp-test
 686
 687 (defun assert-node= (a b)
 688   (unless (node= a b)
 689     (error "assertion failed: ~S and ~S are not NODE=" a b)))
 690
 691 (defun child-count (node)
 692   (stp:count-children-if (constantly t) node))
 693
 694 (defun named-node-= (a b)
 695   (and (equal (stp:namespace-uri a) (stp:namespace-uri b))
 696        ;; (equal (stp:namespace-prefix a) (stp:namespace-prefix b))
 697        (equal (stp:local-name a) (stp:local-name b))))
 698
 699 (defun parent-node-= (e f)
 700   (and (eql (child-count e)
 701             (child-count f))
 702        (every #'node= (stp:list-children e) (stp:list-children f))))
 703
 704 (defmethod node= ((e stp:element) (f stp:element))
 705   (and (named-node-= e f)
 706        (parent-node-= e f)
 707        (null
 708         (set-exclusive-or (stp:list-attributes e) (stp:list-attributes f)
 709                           :test #'node=))
 710        (flet ((collect-namespaces (elt)
 711                 (let ((result ()))
 712                   (stp:map-extra-namespaces
 713                    (lambda (k v) (push (cons k v) result))
 714                    elt)
 715                   result)))
 716          (null
 717           (set-exclusive-or (collect-namespaces e) (collect-namespaces f)
 718                             :test #'equal)))))
 719
 720 (defmethod node= ((a stp:node) (b stp:node))
 721   nil)
 722
 723 (defmethod node= ((e stp:document) (f stp:document))
 724   (parent-node-= e f))
 725
 726 (defmethod node= ((a stp:attribute) (b stp:attribute))
 727   (and (named-node-= a b)
 728        (equal (stp:value a) (stp:value b))))
 729
 730 (defmethod node= ((a stp:comment) (b stp:comment))
 731   (equal (stp:data a) (stp:data b)))
 732
 733 (defmethod node= ((a stp:text) (b stp:text))
 734   (equal (stp:data a) (stp:data b)))
 735
 736 (defmethod node= ((a stp:processing-instruction)
 737                   (b stp:processing-instruction))
 738   (and (equal (stp:data a) (stp:data b))
 739        (equal (stp:target a) (stp:target b))))
 740
 741 (defmethod node= ((a stp:document-type) (b stp:document-type))
 742   (and (equal (stp:root-element-name a) (stp:root-element-name b))
 743        (equal (stp:public-id a) (stp:public-id b))
 744        (equal (stp:system-id a) (stp:system-id b))
 745        (equal (stp:internal-subset a) (stp:internal-subset b))))
 746
 747 (xpath:define-xpath-function/eager
 748     xslt :print
 749     (thing)
 750   (if (xpath:node-set-p thing)
 751       (loop
 752          initially (format t ";;; node set:~%")
 753          for i from 0
 754          for node in (xpath:all-nodes thing)
 755          do
 756            (format t ";;;   ~D: ~A~%" i (type-of node)))
 757       (format t ";;; ~A~%" thing))
 758   thing)