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
10 ;;; * Redistributions of source code must retain the above copyright
11 ;;; notice, this list of conditions and the following disclaimer.
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.
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
)
60 ;;; Translate catalog.xml into an actually usable katalog.xml
61 ;;; by running the test cases through xsltproc to see what it thinks
64 (defun simplify-tests (&optional
(d *tests-directory
*))
65 (with-open-file (stream (merge-pathnames "katalog.xml" d
)
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
)))
82 while
(klacks:find-event source
:start-element
)
83 for lname
= (klacks:current-lname source
)
86 ((equal lname
"major-path")
87 (klacks:skip source
:start-element
)
90 (merge-pathnames (klacks:consume-characters source
)))))
91 ((equal lname
"test-case")
94 (klacks:serialize-element source
(stp:make-builder
))))
95 (test-case (parse-original-test major-path
<test-case
>)))
96 (when (funcall test test-case
)
98 (when (funcall run-test test-case
)
101 (klacks:skip source
:start-element
))))
102 (format t
"~&Passed ~D/~D tests.~%" pass total
)))
104 (defun parse-original-test (major-path <test-case
>)
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
))
111 (stp:find-recursively-if
(stp:of-name
"scenario") <test-case
>))
114 supplemental-stylesheet
118 (dolist (<input
> (stp:filter-recursively
(stp:of-name
"input-file")
120 (let ((role (stp:attribute-value
<input
> "role"))
121 (path (concatenate 'string base
"/" (stp:string-value
<input
>))))
123 ((equal role
"principal-data")
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")
135 (let ((role (stp:attribute-value
<output
> "role"))
136 (path (concatenate 'string out-base
138 (stp:string-value
<output
>))))
140 ((equal role
"principal")
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")
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
))
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
)
173 :defaults
(test-data-pathname test
)))
175 (defun sanitize-stylesheet (in out
)
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")))
184 (with-open-file (s out
186 :if-exists
:rename-and-delete
187 :element-type
'(unsigned-byte 8))
188 (stp:serialize d
(cxml:make-octet-stream-sink s
))))
190 (warn "ignoring bogus stylesheet ~A: ~A" in c
)
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]~?~%"
203 (test-category test-case
)
206 (let* ((data (test-data-pathname test-case
))
207 (stylesheet (test-stylesheet-pathname test-case
))
208 (noindent-stylesheet (noindent-stylesheet-pathname test-case
))
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")
216 #+xuriella
::xsltproc
(xsltproc noindent-stylesheet data out
)
217 (saxon noindent-stylesheet data saxon-out
)
219 (write-simplified-test test-case
"standard")
222 (report "FAIL" ": ~A" c
)
223 (write-simplified-test test-case
"execution-error")
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
234 (report "PASS" ": expected error ~A" c
)
235 (write-simplified-test test-case
"execution-error")
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"
245 (full-namestring stylesheet
)
246 (full-namestring input
)
247 (full-namestring output
))))
249 (error "running xsltproc failed with code ~A [~%~A~%]"
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"
260 (full-namestring input
)
261 (full-namestring stylesheet
)
262 (full-namestring output
))))
264 (error "running saxon failed with code ~A [~%~A~%]"
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")
279 (defun dribble-tests (&optional
(category *default-categories
*)
280 (d *tests-directory
*))
281 (let ((*package
* (find-package 'cl-user
))
282 (*print-circle
* nil
))
283 (with-open-file (dribble
284 (merge-pathnames "TEST"
285 (slot-value (asdf:find-system
:xuriella
)
286 'asdf
::relative-pathname
))
288 :if-exists
:supersede
289 :external-format
:utf-8
)
290 (let* ((dribble (make-broadcast-stream dribble
*standard-output
*))
291 (*standard-output
* dribble
)
292 (*trace-output
* dribble
)
293 (*error-output
* dribble
)
294 (*terminal-io
* (make-two-way-stream *standard-input
* dribble
)))
295 (handler-bind ((warning
297 (warn "~A" (replace-junk (princ-to-string c
)))
298 (muffle-warning c
))))
299 (run-tests category d
))))))
301 (defparameter *bad-tests
*
302 '( ;; some tests wants us to recover from this error, yet this one doesn't:
306 ;; we perform recovery, but saxon doesn't. Recovery results in non-XML
307 ;; output, which we can't parse for comparison against the official test
311 ;; we'd pass these tests, but the test authors forgot to declare the
312 ;; entity they're writing, so we can't parse it for comparison.
317 ;; another similar test where the output is unparsable, except that
318 ;; here an entity declaration wouldn't have helped either:
319 "Copying_ResultTreeFragmentWithEscapedText"
321 ;; the following tests take a lot of time due to the problems of current matching algorithm:
324 ;; stack exhaustion -- matching problem i think
326 ;; probably the same problem (but I haven't checked):
327 "numbering_numbering03"
328 "numbering_numbering10"
329 "numbering_numbering11"
330 "numbering_numbering80"
331 "numbering_numbering81"
332 "numbering_numbering94"
333 "numbering_numbering95"
336 (defun run-tests (&optional
(categories *default-categories
*)
337 (d *tests-directory
*))
338 (unless (listp categories
)
339 (setf categories
(list categories
)))
340 (klacks:with-open-source
341 (source (klacks:make-tapping-source
342 (cxml:make-source
(merge-pathnames "katalog.xml" d
))))
343 (let ((*default-pathname-defaults
* (merge-pathnames d
)))
344 (map-tests #'run-test
347 (and (or (null categories
)
348 (find (test-category test
)
351 (not (find (test-id test
)
353 :test
#'equal
))))))))
355 (defun run-named-test (name &optional
(d *tests-directory
*))
356 (klacks:with-open-source
357 (source (klacks:make-tapping-source
358 (cxml:make-source
(merge-pathnames "katalog.xml" d
))))
359 (let ((*default-pathname-defaults
* (merge-pathnames d
))
360 (*break-on-signals
* 'error
))
361 (map-tests #'run-test
363 :test
(lambda (test) (equal (test-id test
) name
))))))
365 (defun copy-file (p q
)
366 (with-open-file (in p
:element-type
'(unsigned-byte 8))
367 (with-open-file (out q
368 :element-type
'(unsigned-byte 8)
370 :if-exists
:rename-and-delete
)
371 (let ((buf (make-array 8192 :element-type
'(unsigned-byte 8))))
372 (loop for pos
= (read-sequence buf in
)
374 do
(write-sequence buf out
:end pos
))))))
376 (defun find-named-test (name &optional
(d *tests-directory
*))
377 (klacks:with-open-source
378 (source (klacks:make-tapping-source
379 (cxml:make-source
(merge-pathnames "katalog.xml" d
))))
381 (map-tests (lambda (test)
384 :test
(lambda (test) (equal (test-id test
) name
))))))
386 (defun copy-test-files (name &optional
(d *tests-directory
*))
387 (let* ((test (find-named-test name d
))
388 (*default-pathname-defaults
* (merge-pathnames d
))
389 (*break-on-signals
* 'error
)
390 (target-dir (merge-pathnames "copied-test/"
391 (asdf:component-pathname
392 (asdf:find-system
:xuriella
))))
393 (xsl (merge-pathnames "test.xsl" target-dir
))
394 (xml (merge-pathnames "test.xml" target-dir
))
395 (txt (merge-pathnames "official-output.txt" target-dir
))
396 (expected (merge-pathnames "expected.xml" target-dir
))
397 (actual (merge-pathnames "actual.xml" target-dir
)))
398 (ensure-directories-exist target-dir
)
399 (copy-file (test-stylesheet-pathname test
) xsl
)
400 (copy-file (test-data-pathname test
) xml
)
401 (when (test-official-output-pathname test
)
402 (copy-file (test-official-output-pathname test
) txt
))
403 (format t
"Test stylesheet copied to:~% ~A~%~%" xsl
)
404 (format t
"Test data copied to:~% ~A~%~%" xml
)
405 (when (test-official-output-pathname test
)
406 (format t
"Official output file:~% ~A~%~%" txt
))
407 (format t
"Run xsltproc like this:~% cd ~A~% xsltproc ~A ~A >~A~%~%"
408 (namestring target-dir
)
409 (enough-namestring xsl target-dir
)
410 (enough-namestring xml target-dir
)
411 (enough-namestring expected target-dir
))
412 (format t
"Run saxon like this:~% cd ~A~% java -jar /usr/share/java/saxon.jar ~A ~A >~A~%~%"
413 (namestring target-dir
)
414 (enough-namestring xml target-dir
)
415 (enough-namestring xsl target-dir
)
416 (enough-namestring expected target-dir
))
417 (format t
"Run MSXSL like this:~% cd ~A~% wine msxsl.exe ~A ~A >~A~%~%"
418 (namestring target-dir
)
419 (enough-namestring xml target-dir
)
420 (enough-namestring xsl target-dir
)
421 (enough-namestring expected target-dir
))
422 (format t
"Run xuriella like this:~%")
423 `(apply-stylesheet ,xsl
,xml
:output
,actual
)))
425 (defun map-tests (run-test source
&key
(test (constantly t
)))
429 while
(klacks:find-event source
:start-element
)
430 for lname
= (klacks:current-lname source
)
433 ((equal lname
"test-case")
435 (stp:document-element
436 (klacks:serialize-element source
(stp:make-builder
))))
437 (test-case (parse-test <test-case
>)))
438 (when (funcall test test-case
)
440 (when (funcall run-test test-case
)
443 (klacks:skip source
:start-element
))))
444 (format t
"~&Passed ~D/~D tests.~%" pass total
)))
446 (defun parse-test (<test-case
>)
447 (stp:with-attributes
(id category operation
448 data stylesheet data-2 stylesheet-2
451 (make-instance 'test-case
456 :stylesheet-pathname stylesheet
457 :data-pathname-2 data-2
458 :stylesheet-pathname-2 stylesheet-2
459 :output-pathname output
460 :output-compare compare
)))
462 ;; read from file P, skipping the XMLDecl or TextDecl and Doctype at the
463 ;; beginning, if any.
464 (defun slurp-for-comparison (p)
465 (with-open-file (s p
:element-type
'(unsigned-byte 8))
466 (unless (and (eql (read-byte s nil
) #xef
)
467 (eql (read-byte s nil
) #xbb
)
468 (eql (read-byte s nil
) #xbf
))
470 (if (plusp (file-length s
))
471 (slurp-for-comparison-1 p s t
)
474 (defun slurp-for-comparison-1 (p s junk-info
)
475 (let ((pos (file-position s
)) ;for UTF-8 "BOM"
476 (xstream (runes:make-xstream s
:speed
1))
478 (setf (runes:xstream-name xstream
)
479 (cxml::make-stream-name
480 :entity-name
"main document"
482 :uri
(cxml::pathname-to-uri
(merge-pathnames p
))))
486 (flexi-streams:make-in-memory-input-stream
488 (cxml:make-source xstream
490 :entity-resolver
#'er
))))
491 (unless (eq junk-info
:nada
)
494 (setf prev-pos
(runes:xstream-position xstream
))
495 (klacks:peek-next source
))
496 until
(eq key
:start-document
))
497 (cxml::with-source
(source cxml
::context
)
498 (when (eq (cxml::zstream-token-category
499 (cxml::main-zstream cxml
::context
))
501 ;; oops, doesn't look like XML at all
502 (file-position s pos
)
503 (return-from slurp-for-comparison-1
504 (slurp-for-comparison-1 p s
:nada
)))))
507 (dotimes (x junk-info
)
508 (setf prev-pos
(runes:xstream-position xstream
))
509 (klacks:peek-next source
)))
514 (case (klacks:peek-next source
)
515 (:start-element
(return))
517 (if (whitespacep (klacks:current-characters source
))
522 ((or file-error cxml
:xml-parse-error
) ()
526 (with-open-file (u p
:element-type
'(unsigned-byte 8))
527 (file-position u pos
)
528 (return-from slurp-for-comparison-1
529 (slurp-for-comparison-1 p u nskip
)))))
530 ((member nil
:nada
)))
531 (with-output-to-string (r)
533 (cxml::with-source
(source cxml
::context
)
534 (ecase (cxml::zstream-token-category
535 (cxml::main-zstream cxml
::context
))
539 (setf prev-pos
(runes:xstream-position xstream
))
541 (off-by-one-p (or seen-char
(eq junk-info
:nada
)))
542 (new-pos (- prev-pos
(if off-by-one-p
1 0))))
544 (with-open-file (u p
:element-type
'(unsigned-byte 8))
545 (file-position u pos
)
546 (let ((y (runes:make-xstream u
:speed
1)))
548 while
(< (runes:xstream-position y
) new-pos
)
549 do
(write-char (runes:read-rune y
) r
))))
550 (write-line "<wrapper>" r
)
552 (write-char seen-char r
)))
554 for char
= (runes:read-rune xstream
)
556 do
(write-char char r
))
557 (write-line "</wrapper>" r
)))))
559 (defun parse-for-comparison (p)
560 (let* ((d (flet ((er (pub sys
)
562 (flexi-streams:make-in-memory-input-stream
564 (cxml:parse
(slurp-for-comparison p
)
565 (make-text-normalizer (stp:make-builder
))
566 :entity-resolver
#'er
)))
567 (de (stp:document-element d
)))
568 (let ((first (stp:first-child de
)))
569 (when (typep first
'stp
:text
)
571 ((whitespacep (stp:data first
))
572 (stp:delete-child first de
))
574 (setf (stp:data first
)
575 (cl-ppcre:regex-replace
#.
(format nil
"^[~A]+" *whitespace
*)
578 (let ((last (stp:last-child de
)))
579 (when (typep last
'stp
:text
)
581 ((whitespacep (stp:data last
))
582 (stp:delete-child last de
))
584 (setf (stp:data last
)
585 (cl-ppcre:regex-replace
#.
(format nil
"[~A]+$" *whitespace
*)
590 (defun output-equal-p (compare p q
&key normalize
)
593 (:xml
(xml-output-equal-p p q normalize
))
594 (:html
(html-output-equal-p p q
))
595 (:text
(text-output-equal-p p q
)))
596 ((or error parse-number
::invalid-number
) (c)
597 (warn "comparison failed: ~A" c
)
600 ;; Workaround for namespace_namespace23 and other tests:
601 ;; - For these tests, saxon and msxsl output a declaration for the XSL
602 ;; namespace without using that declaration.
603 ;; - I think saxon and msxsl are both wrong.
604 ;; - The official test output agrees with my assessment.
605 ;; (So does libxslt, but that's not to be trusted. :-))
606 ;; - Here's the catch: The official test output is broken in its whitespace
608 ;; So let's normalize spaces in test output that looks like an XSLT
609 ;; stylesheet, allowing us to pass these tests using the official test output.
610 (defun maybe-normalize-test-spaces (wrapper force
)
611 (stp:do-children
(wrapper-child wrapper
)
612 (when (and (typep wrapper-child
'stp
:element
)
613 (or (equal (stp:namespace-uri wrapper-child
) *xsl
*)
615 (strip-stylesheet wrapper-child
)
616 (labels ((recurse (e &optional preserve
)
617 (stp:do-children
(child e
)
620 (setf (stp:data child
)
621 (normalize-whitespace (stp:data child
))))
623 (stp:with-attributes
((space "space" *xml
*))
627 ((namep child
"text") t
)
628 ((not space
) preserve
)
629 ((equal space
"preserve") t
)
631 (recurse child new-preserve
))))))))
632 (recurse wrapper-child
)))))
634 (defun xml-output-equal-p (p q normalize
)
635 (let ((r (parse-for-comparison p
))
636 (s (parse-for-comparison q
)))
637 (maybe-normalize-test-spaces (stp:document-element r
) normalize
)
638 (maybe-normalize-test-spaces (stp:document-element s
) normalize
)
639 (and (let ((u (stp:document-type r
))
640 (v (stp:document-type s
)))
644 (node= (stp:document-element r
) (stp:document-element s
)))))
646 ;; FIXME: don't do this in <pre> etc.
647 (defun normalize-html-whitespace (node)
648 (when (typep node
'stp
:parent-node
)
649 ;; ignore newlines after start tags completely
650 (let ((first (stp:first-child node
)))
651 (when (and (typep first
'stp
:text
)
652 (alexandria:starts-with
#\newline
(stp:data first
)))
653 (setf (stp:data first
) (subseq (stp:data first
) 1))))
654 ;; ignore newlines before end tags completely
655 (let ((last (stp:last-child node
)))
656 (when (and (typep last
'stp
:text
)
657 (alexandria:ends-with
#\newline
(stp:data last
)))
658 (setf (stp:data last
)
659 (subseq (stp:data last
) 0 (length (stp:data last
))))))
660 ;; normalize sequences of whitespace
661 (stp:do-children
(child node
)
662 (if (typep child
'stp
:text
)
663 (setf (stp:data child
)
664 (let ((str (normalize-whitespace (stp:data child
))))
666 ;; FIXME! Here we remove whitespace entirely.
667 ;; Totally incorrect, but I don't see how we could
668 ;; watch Saxon's output otherwise.
672 (normalize-html-whitespace child
)))
673 ;; just to be sure, join adjacent nodes
674 (cxml-stp-impl::normalize-text-nodes
! node
)))
676 ;; FIXME: this check is too lenient, because chtml is an error-correcting
678 (defun html-output-equal-p (p q
)
679 (let ((r (chtml:parse
(pathname p
) (stp:make-builder
)))
680 (s (chtml:parse
(pathname q
) (stp:make-builder
))))
681 (normalize-html-whitespace r
)
682 (normalize-html-whitespace s
)
683 (node= (stp:document-element r
) (stp:document-element s
))))
685 (defun text-output-equal-p (p q
)
686 (with-open-file (a p
:element-type
'(unsigned-byte 8))
687 (with-open-file (b q
:element-type
'(unsigned-byte 8))
688 (let ((len (file-length a
)))
689 (and (eql len
(file-length b
))
690 (let ((d (make-array len
:element-type
'(unsigned-byte 8)))
691 (e (make-array len
:element-type
'(unsigned-byte 8))))
696 (defun strip-addresses (str)
697 (cl-ppcre:regex-replace-all
"{[0-9a-fA-F]+}\\>" str
"{xxxxxxxx}>"))
699 (defun slurp-output-method (p)
700 (xpath:with-namespaces
((nil #.
*xsl
*))
701 (let* ((d (handler-bind
702 ((warning #'muffle-warning
))
703 (cxml:parse
(pathname p
) (stp:make-builder
))))
704 (output (xpath:first-node
(xpath:evaluate
"//output" d
))))
706 (let ((method (stp:attribute-value output
"method")))
708 (intern (string-upcase method
) :keyword
)
712 (defun replace-junk (str)
713 (cl-ppcre:regex-replace-all
714 `(:group
,(namestring *tests-directory
*))
717 (if (or (eql c
#\newline
) (<= 32 (char-code c
) 126))
723 (defun run-test (test)
724 (let ((expected-saxon (test-output-pathname test
"saxon"))
726 (expected-xsltproc (test-output-pathname test
"xsltproc"))
727 (actual (test-output-pathname test
"xuriella"))
728 (official (test-official-output-pathname test
))
730 (find (test-id test
) '("Namespace-alias__91782") :test
#'equal
))
732 (handler-bind ((|hey test suite
, this is an HTML document|
735 (setf output-method
:html
))))
736 (labels ((uri-resolver (uri)
737 (if (search "%5c%5c%5c%5cwebxtest%5c%5cmanagedshadow%5c%5cmanaged_b2%5c%5ctestdata%5c%5cxslt%5c%5celement%5c%5cxslt_element_NSShared.xml"
739 (cxml::pathname-to-uri
741 "MSFT_Conformance_Tests/Elements/xslt_element_NSShared.xml"
745 (with-open-file (s actual
746 :if-exists
:rename-and-delete
748 :element-type
'(unsigned-byte 8))
749 (handler-bind ((xslt-error
752 (when (find-restart 'recover
)
753 (invoke-restart 'recover
)))))
754 (apply-stylesheet (pathname (test-stylesheet-pathname test
))
755 (pathname (test-data-pathname test
))
757 :uri-resolver
#'uri-resolver
))))
760 (format t
" ~A: ~A~%"
762 (enough-namestring pathname
*tests-directory
*))))
763 (report (ok &optional
(fmt "") &rest args
)
767 (format nil
"~&~:[FAIL~;PASS~] ~A [~A]~?~%"
773 (pp "Stylesheet" (test-stylesheet-pathname test
))
774 (pp "Data" (test-data-pathname test
))
775 (pp "Supplemental stylesheet"
776 (test-stylesheet-pathname-2 test
))
777 (pp "Supplemental data" (test-data-pathname-2 test
))
778 (pp "Expected output (1)" expected-saxon
)
780 (pp "Expected output (2)" expected-xsltproc
)
781 (pp "Actual output" actual
)
785 ((equal (test-operation test
) "standard")
788 (when (find (test-id test
)
789 nil
;;'("axes_axes47" "attribset_attribset20")
791 (error "skipping problematic test"))
793 (let* ((output-method
796 (test-stylesheet-pathname test
))))
798 (output-equal-p output-method
803 (output-equal-p output-method
807 (output-equal-p output-method
810 :normalize force-normalization
)))
813 #+xuriella
::xsltproc xsltproc-matches-p
817 (report t
": saxon ~A, xsltproc ~A~:[~; (MISMATCH)~]"
821 (not xsltproc-matches-p
)
822 xsltproc-matches-p
)))
824 (report nil
": output doesn't match")))))
825 ((or error parse-number
::invalid-number
) (c)
826 (report nil
": ~A" c
))))
831 (report t
": raised an xslt-error as expected" c
))
832 ((or error parse-number
::invalid-number
) (c)
833 (report nil
": condition of incorrect type: ~%~A" c
))
836 ((not (and official
(probe-file official
)))
837 (report nil
": expected error not signalled: " result
))
840 (slurp-output-method (test-stylesheet-pathname test
)))
843 :normalize force-normalization
)
846 (report nil
": saxon error not signalled and official output not a match")))))))))))
848 (defun run-xpath-tests ()
849 (run-tests '("XPath-Expression" "XSLT-Data-Model")))
852 ;;;; from cxml-stp-test
854 (defun assert-node= (a b
)
856 (error "assertion failed: ~S and ~S are not NODE=" a b
)))
858 (defun child-count (node)
859 (stp:count-children-if
(constantly t
) node
))
861 (defun named-node-= (a b
)
862 (and (equal (stp:namespace-uri a
) (stp:namespace-uri b
))
863 ;; (equal (stp:namespace-prefix a) (stp:namespace-prefix b))
864 (equal (stp:local-name a
) (stp:local-name b
))))
866 (defun parent-node-= (e f
)
867 (and (eql (child-count e
)
869 (every #'node
= (stp:list-children e
) (stp:list-children f
))))
871 (defmethod node= ((e stp
:element
) (f stp
:element
))
872 (and (named-node-= e f
)
875 (set-exclusive-or (stp:list-attributes e
) (stp:list-attributes f
)
878 (flet ((check-namespaces (a b
)
880 (stp:map-extra-namespaces
882 (unless (equal v
(stp:find-namespace k b
))
886 (check-namespaces e f
)
887 (check-namespaces f e
))
890 (defmethod node= ((a stp
:node
) (b stp
:node
))
893 (defmethod node= ((e stp
:document
) (f stp
:document
))
896 (defmethod node= ((a stp
:attribute
) (b stp
:attribute
))
897 (and (named-node-= a b
)
898 (equal (stp:value a
) (stp:value b
))))
900 (defmethod node= ((a stp
:comment
) (b stp
:comment
))
901 (equal (stp:data a
) (stp:data b
)))
903 (defmethod node= ((a stp
:text
) (b stp
:text
))
904 (equal (stp:data a
) (stp:data b
)))
906 (defmethod node= ((a stp
:processing-instruction
)
907 (b stp
:processing-instruction
))
908 (and (equal (stp:data a
) (stp:data b
))
909 (equal (stp:target a
) (stp:target b
))))
911 (defmethod node= ((a stp
:document-type
) (b stp
:document-type
))
912 (and (equal (stp:root-element-name a
) (stp:root-element-name b
))
913 (equal (stp:public-id a
) (stp:public-id b
))
914 (equal (stp:system-id a
) (stp:system-id b
))
915 (equal (stp:internal-subset a
) (stp:internal-subset b
))))
917 (xpath-sys:define-xpath-function
/eager
920 (if (xpath:node-set-p thing
)
922 initially
(format t
";;; node set:~%")
924 for node in
(xpath:all-nodes thing
)
926 (format t
";;; ~D: ~A~%" i
(type-of node
)))
927 (format t
";;; ~A~%" thing
))