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