← Back to branch summary

~ubuntu-branches/ubuntu/maverick/uim/maverick

« back to all changes in this revision

Viewing changes to test/uim-test-utils.scm

  • Committer: Bazaar Package Importer
  • Author(s): Masahito Omote
  • Date: 2008-06-25 19:56:33 UTC
  • mfrom: (3.1.18 intrepid)
  • Revision ID: james.westby@ubuntu.com-20080625195633-8jljph4rfq00l8o7
Tags: 1:1.5.1-2
http://bugs.debian.org/482659
http://bugs.debian.org/483078
* uim-tcode: provide tutcode-custom.scm, tutcode-bushudic.scm
  and tutcode-rule.scm (Closes: #482659)
* Fix FTBFS: segv during compile (Closes: #483078).
  I personally think this bug is not specific for uim but is a optimization
  problem on gcc-4.3.1. (https://bugs.freedesktop.org/show_bug.cgi?id=16477)

Show diffs side-by-side

added added

removed removed

Lines of Context:
test/uim-test-utils.scm
1
 
;;; Copyright (c) 2004-2006 uim Project http://uim.freedesktop.org/
 
1
;;; Copyright (c) 2004-2008 uim Project http://code.google.com/p/uim/
2
2
;;;
3
3
;;; All rights reserved.
4
4
;;;
41
41
(if (version<? *gaunit-version* "0.1.1")
42
42
    (error "GaUnit 0.1.1 is required"))
43
43
 
44
 
(sys-putenv "LIBUIM_SCM_FILES" "./scm")
 
44
(sys-putenv "LIBUIM_SYSTEM_SCM_FILES" (string-append (sys-realpath ".")
 
45
                                                     "/sigscheme/lib"))
 
46
(sys-putenv "LIBUIM_SCM_FILES" (string-append (sys-realpath ".") "/scm"))
 
47
;; FIXME: '.libs' is hardcoded
 
48
(sys-putenv "LIBUIM_PLUGIN_LIB_DIR"
 
49
            (string-append (sys-realpath ".") "/uim/.libs"))
45
50
(sys-putenv "LIBUIM_VERBOSE" "2")  ;; must be 1 or 2 (2 enables backtrace)
46
51
(sys-putenv "LIBUIM_VANILLA" "1")
47
52
 
76
81
                           #f)
77
82
                         (lambda ()
78
83
                           (read in)))))
79
 
    (if (eq? 'ERROR: uim-sh-output)
 
84
    (if (eq? 'Error: uim-sh-output)
80
85
        (error (uim-sh-read-error in))
81
86
        uim-sh-output)))
82
87
 
100
105
  (uim-sh-read (process-output *uim-sh-process*)))
101
106
 
102
107
(define (uim-bool sexp)
103
 
  (not (null? (uim sexp))))
 
108
  (not (not (uim sexp))))
 
109
 
 
110
;; only the tricky tests require this 'require' emulation.
 
111
(define (uim-define-siod-compatible-require)
 
112
  (uim
 
113
   '(begin
 
114
      (define require
 
115
        (lambda (filename)
 
116
          (let* ((provided-str (string-append "*" filename "-loaded*"))
 
117
                 (provided-sym (string->symbol provided-str)))
 
118
            (if (not (symbol-bound? provided-sym))
 
119
                (begin
 
120
                  (load filename)
 
121
                  (eval (list 'define provided-sym #t)
 
122
                        (interaction-environment))))
 
123
            provided-sym)))
 
124
      #t)))
104
125
 
105
126
(eval
106
 
 (if (version>=? *gaunit-version* "0.0.6")
107
127
   '(begin
108
128
      (define (*uim-sh-setup-proc*)
109
129
        (set! *uim-sh-process* (run-process "uim/uim-sh"
110
130
                                            "-b"
111
131
                                            :input :pipe
112
 
                                            :output :pipe)))
 
132
                                            :output :pipe))
 
133
        (uim '(%%set-current-error-port! (current-output-port))))
113
134
      (define (*uim-sh-teardown-proc*)
114
135
        (close-input-port (process-input *uim-sh-process*))
115
136
        (set! *uim-sh-process* #f))
123
144
             (define-test-case arg ...)
124
145
             (gaunit-delete-default-setup-proc! *uim-sh-setup-proc*)
125
146
             (gaunit-delete-default-teardown-proc! *uim-sh-teardown-proc*))))))
126
 
 
127
 
   '(begin
128
 
      (define (**default-test-suite**)
129
 
        (with-module test.unit *default-test-suite*))
130
 
      (define <test-case>
131
 
        (with-module test.unit <test-case>))
132
 
      (define make-tests
133
 
        (with-module test.unit make-tests))
134
 
      (define add-test-case!
135
 
        (with-module test.unit add-test-case!))
136
 
 
137
 
      (define (make-uim-sh-setup-proc . args)
138
 
        (let-optionals* args ((additional-setup-proc (lambda () #f)))
139
 
          (lambda ()
140
 
            (set! *uim-sh-process* (run-process "uim/uim-sh"
141
 
                                                "-b"
142
 
                                                :input :pipe
143
 
                                                :output :pipe))
144
 
            (additional-setup-proc))))
145
 
 
146
 
      (define (make-uim-sh-teardown-proc . args)
147
 
        (let-optionals* args ((additional-teardown-proc (lambda () #f)))
148
 
          (lambda ()
149
 
            (close-input-port (process-input *uim-sh-process*))
150
 
            (set! *uim-sh-process* #f)
151
 
            (additional-teardown-proc))))
152
 
 
153
 
      (define-syntax define-uim-test-case
154
 
        (syntax-rules ()
155
 
          ((_ name) #f)
156
 
          ((_ name rest ...)
157
 
           (add-test-case! (**default-test-suite**)
158
 
                           (make-uim-test-case name rest ...)))))
159
 
 
160
 
      (define-syntax make-uim-test-case
161
 
        (syntax-rules (setup teardown)
162
 
          ((_ name (setup setup-proc) (teardown teardown-proc) test ...)
163
 
           (make <test-case>
164
 
             :name name
165
 
             :setup (make-uim-sh-setup-proc setup-proc)
166
 
             :teardown (make-uim-sh-teardown-proc teardown-proc)
167
 
             :tests (make-tests test ...)))
168
 
          ((_ name (setup proc) test ...)
169
 
           (make <test-case>
170
 
             :name name
171
 
             :setup (make-uim-sh-setup-proc proc)
172
 
             :teardown (make-uim-sh-teardown-proc)
173
 
             :tests (make-tests test ...)))
174
 
          ((_ name (teardown proc) test ...)
175
 
           (make <test-case>
176
 
             :name name
177
 
             :setup (make-uim-sh-setup-proc)
178
 
             :teardown (make-uim-sh-teardown-proc proc)
179
 
             :tests (make-tests test ...)))
180
 
          ((_ name test ...)
181
 
           (make <test-case>
182
 
             :name name
183
 
             :setup (make-uim-sh-setup-proc)
184
 
             :teardown (make-uim-sh-teardown-proc)
185
 
             :tests (make-tests test ...)))))))
186
147
 (current-module))
187
148
 
188
149
(provide "test/uim-test-utils")