Observe doctype in xuriella:document
[xuriella.git] / test.lisp
blob429710d33f3088ad5f0cffbb160d377084845551
1 ;;; -*- show-trailing-whitespace: t; indent-tabs-mode: 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 (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))))))
296 (defparameter *bad-tests*
297 '(;; Inconsistent tests:
299 ;; Some tests wants us to recover from this error, yet this one doesn't:
300 "copy_copy61"
301 "copy_copy62"
303 ;; Should we fix this?
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"
309 ;; We would pass this:
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"
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"
322 ;; another similar test where the output is unparsable, except that
323 ;; here an entity declaration wouldn't have helped either:
324 "Copying_ResultTreeFragmentWithEscapedText"
326 ;; Broken test:
328 ;; Input document isn't ns-wf.
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?
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"
345 ;; Someone commented out most of this test...
346 "BVTs_bvt045"
348 ;; FIXME: should re-enable these at some point:
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"
355 ;; stack exhaustion -- matching problem i think
356 "Keys_PerfRepro3"
358 ;; test stylesheet doesn't exist?!
359 "ConflictResolution__77833"
360 "Include__77736"
362 ;; har har
363 "XSLTFunctions__84049"
364 "XSLTFunctions__84050"
366 ;; these test the value of generate-id(), which isn't specified
367 "Keys__91832"
368 "Keys__91833"))
370 ;; Tests where the output isn't a match because of extraneous whitespace.
371 ;; For these tests, we force space normalization before comparing.
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.
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 )"))
397 (defparameter *known-failures*
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"
404 ;; uses KOI, which Babel doesn't support
405 "BVTs_bvt019"
407 ;; ... shift_jis
408 "Include__77515"
409 "Output__78222"
411 ;; ... iso-2022-jp
412 "Output__78223"
413 "Output__78224"
414 "Output__78225"
415 "Output__78226"
416 "Output__78227"
417 "Output__78229"
419 ;; non-english sorting, which we don't support (yet?)
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"
437 ;; FIXME?
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"
449 ;; FIXME!
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"))
513 (defun known-failure-p (id)
514 (find id *known-failures* :test #'equal))
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))))))))
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)))
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))))))
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))))))
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)))
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)
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))))))
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))))
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)))
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/>")))
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)))
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)))))
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))
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))
767 (setf (stp:data last)
768 (cl-ppcre:regex-replace #.(format nil "[~A]+$" *whitespace*)
769 (stp:data last)
770 ""))))))
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)))))
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))
826 (incf i)))))))
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)))))
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)))
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))))
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)))))))
898 (defun strip-addresses (str)
899 (cl-ppcre:regex-replace-all "{[0-9a-fA-F]+}\\>" str "{xxxxxxxx}>"))
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))))
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))
921 #\?))
922 str)
923 "..."))
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*)))
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*))
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
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")
1002 "FAIL"))
1003 (test-id test)
1004 (test-category test)
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)))
1059 (report nil ": output doesn't match")))))
1060 ((or error parse-number::invalid-number) (c)
1061 (report nil ": ~A" c))))
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))
1081 (report nil ": saxon error not signalled and official output not a match")))))))))))
1083 (defun run-xpath-tests ()
1084 (run-tests :filter "XPath-Expression/|XSLT-Data-Model/"))
1087 ;;;; from cxml-stp-test
1089 (defun assert-node= (a b)
1090 (unless (node= a b)
1091 (error "assertion failed: ~S and ~S are not NODE=" a b)))
1093 (defun child-count (node)
1094 (stp:count-children-if (constantly t) node))
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))))
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))))
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)))
1120 result)))
1121 (check-namespaces e f)
1122 (check-namespaces f e))
1123 t)))
1125 (defmethod node= ((a stp:node) (b stp:node))
1126 nil)
1128 (defmethod node= ((e stp:document) (f stp:document))
1129 (parent-node-= e f))
1131 (defmethod node= ((a stp:attribute) (b stp:attribute))
1132 (and (named-node-= a b)
1133 (equal (stp:value a) (stp:value b))))
1135 (defmethod node= ((a stp:comment) (b stp:comment))
1136 (equal (stp:data a) (stp:data b)))
1138 (defmethod node= ((a stp:text) (b stp:text))
1139 (equal (stp:data a) (stp:data b)))
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))))
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))))
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)
1161 (format t ";;; ~D: ~A~%" i (type-of node)))
1162 (format t ";;; ~A~%" thing))
1163 thing)