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