Author: koutou
Date: Sun Mar 22 06:28:08 2009
New Revision: 5933
Modified:
trunk/test/test-lazy-load.scm
trunk/test/uim-test-utils-new.scm
Log:
* test/uim-test-utils-new.scm: use uim-eval instead of uim.
* test/test-lazy-load.scm: use new style.
Modified: trunk/test/test-lazy-load.scm
==============================================================================
--- trunk/test/test-lazy-load.scm (original)
+++ trunk/test/test-lazy-load.scm Sun Mar 22 06:28:08 2009
@@ -1,5 +1,3 @@
-#!/usr/bin/env gosh
-
;;; Copyright (c) 2005-2009 uim Project http://code.google.com/p/uim/
;;;
;;; All rights reserved.
@@ -29,222 +27,241 @@
;;; SUCH DAMAGE.
;;;;
-;; These tests are passed at revision 5329 (new repository)
-
-(use test.unit)
-
-(require "test/uim-test-utils")
+(define-module test.test-foo
+ (use test.unit.test-case)
+ (use test.uim-test))
+(select-module test.test-foo)
+
+(define (setup)
+ (uim-test-setup)
+ ;; Cancels LIBUIM_VANILLA=1. See init.scm for further details.
+ (uim-eval '(load-enabled-modules))
+ (uim-define-siod-compatible-require)
+ (uim-eval '(require "lazy-load.scm")))
+
+(define (teardown)
+ (uim-test-teardown))
+
+(define (test-stub-im-generate-init-handler)
+ (uim-eval
+ '(begin
+ (set! im-list ())
+ (undefine *hangul.scm-loaded*)))
+ (assert-false (uim-bool '(symbol-bound? '*hangul.scm-loaded*)))
+
+ (uim-eval
+ '(define init-handler
+ (stub-im-generate-init-handler 'hangul2 "hangul")))
+ (assert-true (uim-bool '(procedure? init-handler)))
+ (assert-false (uim-bool '(retrieve-im 'hangul2)))
+ (uim-eval
+ '(define test-context
+ (init-handler 0 #f #f)))
+ (assert-equal 'hangul2
+ (uim '(im-name (retrieve-im 'hangul2))))
+ (assert-equal "hangul"
+ (uim '(im-module-name (retrieve-im 'hangul2))))
+ (assert-equal 'hangul2
+ (uim '(im-name (context-im test-context))))
+ (assert-equal "hangul"
+ (uim '(im-module-name (context-im test-context))))
+ #f)
+
+(define (test-register-stub-im)
+ (uim-eval
+ '(begin
+ (set! im-list ())
+ (undefine *hangul.scm-loaded*)))
+ (assert-false (uim-bool '(symbol-bound? '*hangul.scm-loaded*)))
+
+ (uim-eval
+ '(begin
+ (register-stub-im
+ 'hangul2
+ "ko"
+ "UTF-8"
+ "Hangul (2-bul)"
+ "2-bul style hangul input method"
+ "hangul")
+ (define init-handler (im-init-handler (retrieve-im 'hangul2)))
+ (im-set-init-handler! (retrieve-im 'hangul2) 'init)))
+ (assert-equal '(hangul2
+ "ko"
+ "UTF-8"
+ "Hangul (2-bul)"
+ "2-bul style hangul input method"
+ ;; replace () with #f for R5RS compliant interpreter
+ #f ;; arg
+ init
+ #f ;; release-handler
+ #f ;; mode-handler
+ #f ;; press-key-handler
+ #f ;; release-key-handler
+ #f ;; reset-handler
+ #f ;; get-candidate-handler
+ #f ;; set-candidate-index-handler
+ #f ;; prop-activate-handler
+ #f ;; input-string-handler
+ #f ;; focus-in-handler
+ #f ;; focus-out-handler
+ #f ;; place-handler
+ #f ;; displace-handler
+ "hangul")
+ (uim '(retrieve-im 'hangul2)))
+ (uim-eval '(im-set-init-handler! (retrieve-im 'hangul2) init-handler))
+
+ (assert-true (uim-bool '(procedure? (im-init-handler
+ (retrieve-im 'hangul2)))))
+ ;; to prevent SEGV on create-context
+ (uim-eval
+ '(begin
+ (define im-set-encoding (lambda arg #f))
+ (define im-clear-preedit (lambda arg #f))
+ (define im-pushback-preedit (lambda arg #f))
+ (define im-update-preedit (lambda arg #f))
+ (define im-update-prop-list (lambda arg #f))
+ (define im-clear-mode-list (lambda arg #f))
+ (define im-pushback-mode-list (lambda arg #f))
+ (define im-update-mode-list (lambda arg #f))
+ (define im-update-mode (lambda arg #f))
+ (create-context 0 #f 'hangul2)
+
+ (define test-context (assv 0 context-list))))
+
+ (assert-equal 'hangul2
+ (uim '(im-name (context-im test-context))))
+ (assert-equal "hangul"
+ (uim '(im-module-name (context-im test-context))))
+ (uim-eval '(define test-hangul2 (retrieve-im 'hangul2)))
+ (assert-equal 'hangul2
+ (uim '(im-name test-hangul2)))
+ (assert-equal "hangul"
+ (uim '(im-module-name test-hangul2)))
+ (assert-true (uim-bool '(procedure? (im-init-handler test-hangul2))))
+ (assert-false (uim-bool '(procedure? (im-release-handler test-hangul2))))
+ (assert-true (uim-bool '(procedure? (im-mode-handler test-hangul2))))
+ (assert-true (uim-bool '(procedure? (im-key-press-handler
test-hangul2))))
+ (assert-true (uim-bool '(procedure? (im-key-release-handler
test-hangul2))))
+ (assert-true (uim-bool '(procedure? (im-reset-handler test-hangul2))))
+ (assert-true (uim-bool '(procedure? (im-get-candidate-handler
test-hangul2))))
+ (assert-true (uim-bool '(procedure? (im-set-candidate-index-handler
test-hangul2))))
+ (assert-true (uim-bool '(procedure? (im-prop-activate-handler
test-hangul2))))
+ #f)
+
+(define (test-stub-im-generate-stub-im-list)
+ (uim-eval
+ '(begin
+ (set! im-list ())
+ (undefine *tcode.scm-loaded*)
+ (undefine *hangul.scm-loaded*)))
+ (assert-false (uim-bool '(symbol-bound? '*tcode.scm-loaded*)))
+ (assert-false (uim-bool '(symbol-bound? '*hangul.scm-loaded*)))
+
+ (assert-false (uim-bool '(retrieve-im 'tcode)))
+ (assert-false (uim-bool '(retrieve-im 'hangul2)))
+ (assert-false (uim-bool '(retrieve-im 'hangul3)))
+
+ (assert-equal ()
+ (uim '(stub-im-generate-stub-im-list ())))
+ (assert-equal (list
+ (string-append
+ " (hangul2\n"
+ " \"ko\"\n"
+ " \"UTF-8\"\n"
+ " \"Hangul (2-beol)\"\n"
+ " \"2-beol style hangul input method\"\n"
+ " \"hangul\")\n"))
+ (uim '(stub-im-generate-stub-im-list '(hangul2))))
+ (assert-equal (list
+ (string-append
+ " (hangul3\n"
+ " \"ko\"\n"
+ " \"UTF-8\"\n"
+ " \"Hangul (3-beol)\"\n"
+ " \"3-beol style hangul input method\"\n"
+ " \"hangul\")\n"))
+ (uim '(stub-im-generate-stub-im-list '(hangul3))))
+ (assert-equal (list
+ (string-append
+ " (tcode\n"
+ " \"ja\"\n"
+ " \"EUC-JP\"\n"
+ " \"T-Code\"\n"
+ " \"A kanji direct input method\"\n"
+ " \"tcode\")\n"))
+ (uim '(stub-im-generate-stub-im-list '(tcode))))
+
+ (assert-equal (list
+ (string-append
+ " (hangul2\n"
+ " \"ko\"\n"
+ " \"UTF-8\"\n"
+ " \"Hangul (2-beol)\"\n"
+ " \"2-beol style hangul input method\"\n"
+ " \"hangul\")\n")
+ (string-append
+ " (tcode\n"
+ " \"ja\"\n"
+ " \"EUC-JP\"\n"
+ " \"T-Code\"\n"
+ " \"A kanji direct input method\"\n"
+ " \"tcode\")\n")
+ (string-append
+ " (hangul3\n"
+ " \"ko\"\n"
+ " \"UTF-8\"\n"
+ " \"Hangul (3-beol)\"\n"
+ " \"3-beol style hangul input method\"\n"
+ " \"hangul\")\n"))
+ (uim '(stub-im-generate-stub-im-list '(hangul2 tcode
hangul3))))
+ #f)
+
+(define (test-stub-im-generate-all-stub-im-list)
+ (uim-eval
+ '(begin
+ (set! im-list ())
+ (undefine *tcode.scm-loaded*)
+ (undefine *hangul.scm-loaded*)
+ (set! installed-im-module-list '("tcode" "hangul"))))
+ (assert-equal (list
+ (string-append
+ " (tcode\n"
+ " \"ja\"\n"
+ " \"EUC-JP\"\n"
+ " \"T-Code\"\n"
+ " \"A kanji direct input method\"\n"
+ " \"tcode\")\n")
+ (string-append
+ " (hangul2\n"
+ " \"ko\"\n"
+ " \"UTF-8\"\n"
+ " \"Hangul (2-beol)\"\n"
+ " \"2-beol style hangul input method\"\n"
+ " \"hangul\")\n")
+ (string-append
+ " (hangul3\n"
+ " \"ko\"\n"
+ " \"UTF-8\"\n"
+ " \"Hangul (3-beol)\"\n"
+ " \"3-beol style hangul input method\"\n"
+ " \"hangul\")\n")
+ (string-append
+ " (romaja\n"
+ " \"ko\"\n"
+ " \"UTF-8\"\n"
+ " \"Hangul (Romaja)\"\n"
+ " \"Romaja input style hangul input method\"\n"
+ " \"hangul\")\n"))
+ (uim '(stub-im-generate-all-stub-im-list)))
+
+ (uim-eval
+ '(begin
+ (set! im-list ())
+ (undefine *tcode.scm-loaded*)
+ (undefine *hangul.scm-loaded*)
+ (set! installed-im-module-list '())))
+ (assert-equal ()
+ (uim '(stub-im-generate-all-stub-im-list)))
+ #f)
-(define-uim-test-case "testcase stub-im"
- (setup
- (lambda ()
- ;; Cancels LIBUIM_VANILLA=1. See init.scm for further details.
- (uim '(load-enabled-modules))
-
- (uim-define-siod-compatible-require)
- (uim '(require "lazy-load.scm"))))
-
- ("test stub-im-generate-init-handler"
- (uim '(set! im-list ()))
- (uim '(undefine *hangul.scm-loaded*))
- (assert-false (uim-bool '(symbol-bound? '*hangul.scm-loaded*)))
-
- (uim '(define init-handler (stub-im-generate-init-handler 'hangul2
- "hangul")))
- (assert-true (uim-bool '(procedure? init-handler)))
- (assert-false (uim-bool '(retrieve-im 'hangul2)))
- (uim '(define test-context (init-handler 0 #f #f)))
- (assert-equal 'hangul2
- (uim '(im-name (retrieve-im 'hangul2))))
- (assert-equal "hangul"
- (uim '(im-module-name (retrieve-im 'hangul2))))
- (assert-equal 'hangul2
- (uim '(im-name (context-im test-context))))
- (assert-equal "hangul"
- (uim '(im-module-name (context-im test-context)))))
-
- ("test register-stub-im"
- (uim '(set! im-list ()))
- (uim '(undefine *hangul.scm-loaded*))
- (assert-false (uim-bool '(symbol-bound? '*hangul.scm-loaded*)))
-
- (uim '(register-stub-im
- 'hangul2
- "ko"
- "UTF-8"
- "Hangul (2-bul)"
- "2-bul style hangul input method"
- "hangul"))
- (uim '(define init-handler (im-init-handler (retrieve-im 'hangul2))))
- (uim '(im-set-init-handler! (retrieve-im 'hangul2) 'init))
- (assert-equal '(hangul2
- "ko"
- "UTF-8"
- "Hangul (2-bul)"
- "2-bul style hangul input method"
- ;; replace () with #f for R5RS compliant interpreter
- #f ;; arg
- init
- #f ;; release-handler
- #f ;; mode-handler
- #f ;; press-key-handler
- #f ;; release-key-handler
- #f ;; reset-handler
- #f ;; get-candidate-handler
- #f ;; set-candidate-index-handler
- #f ;; prop-activate-handler
- #f ;; input-string-handler
- #f ;; focus-in-handler
- #f ;; focus-out-handler
- #f ;; place-handler
- #f ;; displace-handler
- "hangul")
- (uim '(retrieve-im 'hangul2)))
- (uim '(im-set-init-handler! (retrieve-im 'hangul2) init-handler))
-
- (assert-true (uim-bool '(procedure? (im-init-handler
- (retrieve-im 'hangul2)))))
- ;; to prevent SEGV on create-context
- (uim '(define im-set-encoding (lambda arg #f)))
- (uim '(define im-clear-preedit (lambda arg #f)))
- (uim '(define im-pushback-preedit (lambda arg #f)))
- (uim '(define im-update-preedit (lambda arg #f)))
- (uim '(define im-update-prop-list (lambda arg #f)))
- (uim '(define im-clear-mode-list (lambda arg #f)))
- (uim '(define im-pushback-mode-list (lambda arg #f)))
- (uim '(define im-update-mode-list (lambda arg #f)))
- (uim '(define im-update-mode (lambda arg #f)))
-
- (uim '(begin
- (create-context 0 #f 'hangul2)
- #f))
- (uim '(begin
- (define test-context (assv 0 context-list))
- #f))
-
- (assert-equal 'hangul2
- (uim '(im-name (context-im test-context))))
- (assert-equal "hangul"
- (uim '(im-module-name (context-im test-context))))
- (uim '(define test-hangul2 (retrieve-im 'hangul2)))
- (assert-equal 'hangul2
- (uim '(im-name test-hangul2)))
- (assert-equal "hangul"
- (uim '(im-module-name test-hangul2)))
- (assert-true (uim-bool '(procedure? (im-init-handler test-hangul2))))
- (assert-false (uim-bool '(procedure? (im-release-handler
test-hangul2))))
- (assert-true (uim-bool '(procedure? (im-mode-handler test-hangul2))))
- (assert-true (uim-bool '(procedure? (im-key-press-handler
test-hangul2))))
- (assert-true (uim-bool '(procedure? (im-key-release-handler
test-hangul2))))
- (assert-true (uim-bool '(procedure? (im-reset-handler test-hangul2))))
- (assert-true (uim-bool '(procedure? (im-get-candidate-handler
test-hangul2))))
- (assert-true (uim-bool '(procedure? (im-set-candidate-index-handler
test-hangul2))))
- (assert-true (uim-bool '(procedure? (im-prop-activate-handler
test-hangul2)))))
-
- ("test stub-im-generate-stub-im-list"
- (uim '(set! im-list ()))
- (uim '(undefine *tcode.scm-loaded*))
- (uim '(undefine *hangul.scm-loaded*))
- (assert-false (uim-bool '(symbol-bound? '*tcode.scm-loaded*)))
- (assert-false (uim-bool '(symbol-bound? '*hangul.scm-loaded*)))
-
- (assert-false (uim-bool '(retrieve-im 'tcode)))
- (assert-false (uim-bool '(retrieve-im 'hangul2)))
- (assert-false (uim-bool '(retrieve-im 'hangul3)))
-
- (assert-equal ()
- (uim '(stub-im-generate-stub-im-list ())))
- (assert-equal (list
- (string-append
- " (hangul2\n"
- " \"ko\"\n"
- " \"UTF-8\"\n"
- " \"Hangul (2-beol)\"\n"
- " \"2-beol style hangul input method\"\n"
- " \"hangul\")\n"))
- (uim '(stub-im-generate-stub-im-list '(hangul2))))
- (assert-equal (list
- (string-append
- " (hangul3\n"
- " \"ko\"\n"
- " \"UTF-8\"\n"
- " \"Hangul (3-beol)\"\n"
- " \"3-beol style hangul input method\"\n"
- " \"hangul\")\n"))
- (uim '(stub-im-generate-stub-im-list '(hangul3))))
- (assert-equal (list
- (string-append
- " (tcode\n"
- " \"ja\"\n"
- " \"EUC-JP\"\n"
- " \"T-Code\"\n"
- " \"A kanji direct input method\"\n"
- " \"tcode\")\n"))
- (uim '(stub-im-generate-stub-im-list '(tcode))))
-
- (assert-equal (list
- (string-append
- " (hangul2\n"
- " \"ko\"\n"
- " \"UTF-8\"\n"
- " \"Hangul (2-beol)\"\n"
- " \"2-beol style hangul input method\"\n"
- " \"hangul\")\n")
- (string-append
- " (tcode\n"
- " \"ja\"\n"
- " \"EUC-JP\"\n"
- " \"T-Code\"\n"
- " \"A kanji direct input method\"\n"
- " \"tcode\")\n")
- (string-append
- " (hangul3\n"
- " \"ko\"\n"
- " \"UTF-8\"\n"
- " \"Hangul (3-beol)\"\n"
- " \"3-beol style hangul input method\"\n"
- " \"hangul\")\n"))
- (uim '(stub-im-generate-stub-im-list '(hangul2 tcode
hangul3)))))
-
- ("test stub-im-generate-all-stub-im-list"
- (uim '(set! im-list ()))
- (uim '(undefine *tcode.scm-loaded*))
- (uim '(undefine *hangul.scm-loaded*))
- (uim '(set! installed-im-module-list '("tcode" "hangul")))
- (assert-equal (list
- (string-append
- " (tcode\n"
- " \"ja\"\n"
- " \"EUC-JP\"\n"
- " \"T-Code\"\n"
- " \"A kanji direct input method\"\n"
- " \"tcode\")\n")
- (string-append
- " (hangul2\n"
- " \"ko\"\n"
- " \"UTF-8\"\n"
- " \"Hangul (2-beol)\"\n"
- " \"2-beol style hangul input method\"\n"
- " \"hangul\")\n")
- (string-append
- " (hangul3\n"
- " \"ko\"\n"
- " \"UTF-8\"\n"
- " \"Hangul (3-beol)\"\n"
- " \"3-beol style hangul input method\"\n"
- " \"hangul\")\n")
- (string-append
- " (romaja\n"
- " \"ko\"\n"
- " \"UTF-8\"\n"
- " \"Hangul (Romaja)\"\n"
- " \"Romaja input style hangul input method\"\n"
- " \"hangul\")\n"))
- (uim '(stub-im-generate-all-stub-im-list)))
-
- (uim '(set! im-list ()))
- (uim '(undefine *tcode.scm-loaded*))
- (uim '(undefine *hangul.scm-loaded*))
- (uim '(set! installed-im-module-list '()))
- (assert-equal ()
- (uim '(stub-im-generate-all-stub-im-list)))))
+(provide "test/test-lazy-load")
Modified: trunk/test/uim-test-utils-new.scm
==============================================================================
--- trunk/test/uim-test-utils-new.scm (original)
+++ trunk/test/uim-test-utils-new.scm Sun Mar 22 06:28:08 2009
@@ -129,19 +129,17 @@
;; only the tricky tests require this 'require' emulation.
(define (uim-define-siod-compatible-require)
- (uim
- '(begin
- (define require
- (lambda (filename)
- (let* ((provided-str (string-append "*" filename "-loaded*"))
- (provided-sym (string->symbol provided-str)))
- (if (not (symbol-bound? provided-sym))
- (begin
- (load filename)
- (eval (list 'define provided-sym #t)
- (interaction-environment))))
- provided-sym)))
- #t)))
+ (uim-eval
+ '(define require
+ (lambda (filename)
+ (let* ((provided-str (string-append "*" filename "-loaded*"))
+ (provided-sym (string->symbol provided-str)))
+ (if (not (symbol-bound? provided-sym))
+ (begin
+ (load filename)
+ (eval (list 'define provided-sym #t)
+ (interaction-environment))))
+ provided-sym)))))
(define (uim-sh-setup)
(set! *uim-sh-process* (run-process
`(,(uim-test-build-path "uim" "uim-sh")
