3
;;; $Id: test-parser.scm,v 1.5 2001/07/16 20:40:25 cph Exp $
5
;;; Copyright (c) 2001 Massachusetts Institute of Technology
7
;;; This program is free software; you can redistribute it and/or
8
;;; modify it under the terms of the GNU General Public License as
9
;;; published by the Free Software Foundation; either version 2 of the
10
;;; License, or (at your option) any later version.
12
;;; This program is distributed in the hope that it will be useful,
13
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
14
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
15
;;; General Public License for more details.
17
;;; You should have received a copy of the GNU General Public License
18
;;; along with this program; if not, write to the Free Software
19
;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
22
(define (test-parser pathname)
23
(call-with-input-file pathname
25
(parse-xml-document (input-port->parser-buffer port)))))
3
$Id: test-parser.scm,v 1.10 2003/03/01 16:52:10 cph Exp $
5
Copyright 2001 Massachusetts Institute of Technology
7
This file is part of MIT/GNU Scheme.
9
MIT/GNU Scheme is free software; you can redistribute it and/or modify
10
it under the terms of the GNU General Public License as published by
11
the Free Software Foundation; either version 2 of the License, or (at
12
your option) any later version.
14
MIT/GNU Scheme is distributed in the hope that it will be useful, but
15
WITHOUT ANY WARRANTY; without even the implied warranty of
16
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
17
General Public License for more details.
19
You should have received a copy of the GNU General Public License
20
along with MIT/GNU Scheme; if not, write to the Free Software
21
Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
26
(define (run-xml-tests #!optional root)
28
(merge-pathnames "xmlconf/xmltest/"
29
(if (default-object? root)
31
(pathname-as-directory root)))))
32
(for-each (lambda (dir)
37
(test-directory (merge-pathnames dir root)))
38
'("valid/sa" "valid/ext-sa" "valid/not-sa"
40
"not-wf/sa" "not-wf/ext-sa" "not-wf/not-sa"))))
27
42
(define (test-directory directory)
28
43
(map (lambda (pathname)
30
45
(write-string (file-namestring pathname))
31
46
(write-string ":\t")
32
(let ((v (ignore-errors (lambda () (test-parser pathname)))))
47
(let ((v (ignore-errors (lambda () (read-xml-file pathname)))))
34
49
(write-string "No match."))
36
51
(write-condition-report v (current-output-port)))
38
(write-string "Parsed: ")
53
(let ((s (ignore-errors (lambda () (xml->string v)))))
56
(write-string "Can't write: ")
57
(write-condition-report s (current-output-port)))
58
(let ((x (ignore-errors (lambda () (string->xml s)))))
61
(write-string "Can't re-read: ")
62
(write-condition-report x
63
(current-output-port)))
65
(write-string "Parsed: ")
43
70
(merge-pathnames "*.xml" (pathname-as-directory directory)))))
45
(define (run-xml-tests root)
47
(merge-pathnames "xmlconf/xmltest/"
48
(pathname-as-directory root))))
49
(for-each (lambda (dir)
54
(test-directory (merge-pathnames dir root)))
55
'("valid/sa" "valid/ext-sa" "valid/not-sa"
57
"not-wf/sa" "not-wf/ext-sa" "not-wf/not-sa"))))
59
(define (run-output-tests root output)
61
(merge-pathnames "xmlconf/xmltest/"
62
(pathname-as-directory root)))
72
(define (run-output-tests output #!optional root)
74
(merge-pathnames "xmlconf/xmltest/"
75
(if (default-object? root)
77
(pathname-as-directory root))))
63
78
(output (pathname-as-directory output)))
64
79
(for-each (lambda (pathname)
66
81
(write-string (file-namestring pathname))
67
82
(write-string ":\t")
68
(let ((v (ignore-errors (lambda () (test-parser pathname)))))
83
(let ((v (ignore-errors (lambda () (read-xml-file pathname)))))
70
85
(write-string "No match.")
added
removed
src/xml/test-parser.scm
