1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
|
;;;; sxml.ssax.test -*- scheme -*-
;;;;
;;;; Copyright (C) 2010 Free Software Foundation, Inc.
;;;; Copyright (C) 2001,2002,2003,2004 Oleg Kiselyov <oleg at pobox dot com>
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;; Commentary:
;;
;; Unit tests for (sxml ssax). You can tweak this harness to get more
;; debugging information, but in the end I just wanted to keep Oleg's
;; tests in the file and see if we could work with them directly.
;;
;;; Code:
(define-module (test-suite sxml-ssax)
#:use-module (sxml ssax input-parse)
#:use-module (test-suite lib)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-13)
#:use-module (sxml ssax)
#:use-module (ice-9 pretty-print))
(define pp pretty-print)
(define-macro (import module . symbols)
`(begin
,@(map (lambda (sym)
`(module-define! (current-module) ',sym (module-ref (resolve-module ',module) ',sym)))
symbols)))
;; This list was arrived at over time. See the problem is that SSAX's
;; test cases are inline with its text, and written in the private
;; language of SSAX. That is to say, they use procedures that (sxml
;; ssax) doesn't export. So here we test that the procedures from (sxml
;; ssax) actually work, but in order to do so we have to pull in private
;; definitions. It's not the greatest solution, but it's what we got.
(import (sxml ssax)
ssax:read-NCName
ssax:read-QName
ssax:largest-unres-name
ssax:Prefix-XML
ssax:resolve-name
ssax:scan-Misc
ssax:assert-token
ssax:handle-parsed-entity
ssax:warn
ssax:skip-pi
ssax:S-chars
ssax:skip-S
ssax:ncname-starting-char?
ssax:define-labeled-arg-macro
let*-values
ssax:make-parser/positional-args
when
make-xml-token
nl
;unesc-string
parser-error
ascii->char
char->ascii
char-newline
char-return
char-tab
name-compare)
(define (cout . args)
"Similar to @code{cout << arguments << args}, where @var{argument} can
be any Scheme object. If it's a procedure (e.g. @code{newline}), it's
called without args rather than printed."
(for-each (lambda (x)
(if (procedure? x) (x) (display x)))
args))
(define (cerr . args)
"Similar to @code{cerr << arguments << args}, where @var{argument} can
be any Scheme object. If it's a procedure (e.g. @code{newline}), it's
called without args rather than printed."
(format (current-ssax-error-port)
";;; SSAX warning: ~a\n" args))
(define (list-intersperse src-l elem)
(if (null? src-l) src-l
(let loop ((l (cdr src-l)) (dest (cons (car src-l) '())))
(if (null? l) (reverse dest)
(loop (cdr l) (cons (car l) (cons elem dest)))))))
(define-syntax failed?
(syntax-rules ()
((_ e ...)
(not (false-if-exception (begin e ... #t))))))
(define *saved-port* (current-output-port))
(define-syntax assert
(syntax-rules ()
((assert expr ...)
(with-output-to-port *saved-port*
(lambda ()
(pass-if '(and expr ...)
(let* ((out (open-output-string))
(res (with-output-to-port out
(lambda ()
(with-ssax-error-to-port (current-output-port)
(lambda ()
(and expr ...)))))))
;; (get-output-string out)
res)))))))
(define (load-tests file)
(with-input-from-file (%search-load-path file)
(lambda ()
(let loop ((sexp (read)))
(cond
((eof-object? sexp))
((and (pair? sexp) (pair? (cdr sexp))
(eq? (cadr sexp) 'run-test))
(primitive-eval sexp)
(loop (read)))
((and (pair? sexp) (eq? (car sexp) 'run-test))
(primitive-eval sexp)
(loop (read)))
(else
(loop (read))))))))
(with-output-to-string
(lambda ()
(load-tests "sxml/upstream/SSAX.scm")))
|
