test-suite/tests/sxml.ssax.test

   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
  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")))