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
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
81be any Scheme object. If it's a procedure (e.g. @code{newline}), it's
82called 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
89be any Scheme object. If it's a procedure (e.g. @code{newline}), it's
90called 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")))
141