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