summaryrefslogtreecommitdiff
path: root/test-suite/tests/sxml.ssax.test
diff options
context:
space:
mode:
Diffstat (limited to 'test-suite/tests/sxml.ssax.test')
-rw-r--r--test-suite/tests/sxml.ssax.test140
1 files changed, 140 insertions, 0 deletions
diff --git a/test-suite/tests/sxml.ssax.test b/test-suite/tests/sxml.ssax.test
new file mode 100644
index 000000000..63984b874
--- /dev/null
+++ b/test-suite/tests/sxml.ssax.test
@@ -0,0 +1,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")))