[uim-commit] r318 - in trunk: scm test uim
yamaken@freedesktop.org
yamaken@freedesktop.org
Tue Jan 18 00:11:18 PST 2005
Author: yamaken
Date: 2005-01-18 00:11:15 -0800 (Tue, 18 Jan 2005)
New Revision: 318
Added:
trunk/test/test-custom-rt.scm
Modified:
trunk/scm/custom-rt.scm
trunk/test/test-slib.scm
trunk/uim/slib.c
Log:
* This commit adds on-the-fly custom variable update of live
uim-enabled processes via uim-helper-server
* uim/slib.c
- (procedurep): New function
- (init_subrs): Add initialization of procedurep
* scm/custom-rt.scm
- (custom-key-exist?, custom-set-value!): New procedure
- (define-custom): Add definition of 'key' custom variable in
addition to key predicate
- (custom-prop-update-custom-handler): Implement. warning: no
validation performed
* test/test-slib.scm
- (testcase procedures): New testcase
- (test precedure?): New test
* test/test-custom-rt.scm
- New file
- (testcase custom define-custom, testcase custom methods): New
testcase
- (test define-custom (choice), test define-custom (choice) #2, test
define-custom (key), test define-custom (key) #2, test
custom-key-exist?, test custom-value, test custom-set-value!):
New test
Modified: trunk/scm/custom-rt.scm
===================================================================
--- trunk/scm/custom-rt.scm 2005-01-18 07:49:03 UTC (rev 317)
+++ trunk/scm/custom-rt.scm 2005-01-18 08:11:15 UTC (rev 318)
@@ -112,28 +112,53 @@
(symbol-bound? sym)))
;; lightweight implementation
+(define custom-key-exist?
+ (lambda (sym)
+ (let ((key-sym (symbolconc sym '?)))
+ (and (symbol-bound? sym)
+ (list? (symbol-value sym))
+ (symbol-bound? key-sym)
+ (procedure? (symbol-value key-sym))))))
+
+;; lightweight implementation
(define custom-value
(lambda (sym)
(symbol-value sym)))
;; lightweight implementation
+(define custom-set-value!
+ (lambda (sym val)
+ (cond
+ ((custom-key-exist? sym)
+ (set-symbol-value! sym val)
+ (define-key-internal (symbolconc sym '?)
+ (custom-modify-key-predicate-names val))
+ #t)
+ ((custom-exist? sym #f)
+ (set-symbol-value! sym val)
+ #t)
+ (else
+ #f))))
+
+;; lightweight implementation
(define define-custom
(lambda (sym default groups type label desc)
(custom-rt-add-primary-groups (car groups))
(if (not (custom-exist? sym type))
- (if (eq? (car type)
- 'key)
- (define-key-internal (symbolconc sym '?)
- (custom-modify-key-predicate-names default))
- (let ((quoted-default (if (or (symbol? default)
- (list? default))
- (list 'quote default)
- default)))
- (eval (list 'define sym quoted-default)
- toplevel-env))))))
+ (begin
+ (let ((quoted-default (if (or (symbol? default)
+ (list? default))
+ (list 'quote default)
+ default)))
+ (eval (list 'define sym quoted-default)
+ toplevel-env))
+ (if (eq? (car type)
+ 'key)
+ (define-key-internal (symbolconc sym '?)
+ (custom-modify-key-predicate-names default)))))))
;; lightweight implementation
-;; TODO: implement
+;; warning: no validation performed
(define custom-prop-update-custom-handler
(lambda (context custom-sym val)
- #f))
+ (custom-set-value! custom-sym val)))
Added: trunk/test/test-custom-rt.scm
===================================================================
--- trunk/test/test-custom-rt.scm 2005-01-18 07:49:03 UTC (rev 317)
+++ trunk/test/test-custom-rt.scm 2005-01-18 08:11:15 UTC (rev 318)
@@ -0,0 +1,315 @@
+#!/usr/bin/env gosh
+
+;;; Copyright (c) 2003-2005 uim Project http://uim.freedesktop.org/
+;;;
+;;; All rights reserved.
+;;;
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+;;; 1. Redistributions of source code must retain the above copyright
+;;; notice, this list of conditions and the following disclaimer.
+;;; 2. Redistributions in binary form must reproduce the above copyright
+;;; notice, this list of conditions and the following disclaimer in the
+;;; documentation and/or other materials provided with the distribution.
+;;; 3. Neither the name of authors nor the names of its contributors
+;;; may be used to endorse or promote products derived from this software
+;;; without specific prior written permission.
+;;;
+;;; THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND
+;;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+;;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;;; ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE
+;;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+;;; OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+;;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+;;; LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+;;; OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+;;; SUCH DAMAGE.
+;;;;
+
+(use test.unit)
+
+(require "test/uim-test-utils")
+
+
+(define-uim-test-case "testcase custom define-custom"
+ (setup
+ (lambda ()
+ (uim '(require "custom.scm"))))
+
+ ("test define-custom (choice)"
+ (assert-false (uim-bool '(symbol-bound? 'test-style)))
+
+ (uim '(define-custom 'test-style 'test-style-ddskk
+ '(global)
+ '(choice
+ (test-style-uim "uim" "uim native")
+ (test-style-ddskk "ddskk like" "Similar to ddskk")
+ (test-style-canna "canna like" "Similar to canna"))
+ "Test style"
+ "long description will be here."))
+
+ (assert-true (uim-bool '(symbol-bound? 'test-style)))
+ (assert-equal 'test-style-ddskk
+ (uim 'test-style)))
+
+ ("test define-custom (choice) #2"
+ (uim '(define test-style 'test-style-uim))
+
+ (uim '(define-custom 'test-style 'test-style-ddskk
+ '(global)
+ '(choice
+ (test-style-uim "uim" "uim native")
+ (test-style-ddskk "ddskk like" "Similar to ddskk")
+ (test-style-canna "canna like" "Similar to canna"))
+ "Test style"
+ "long description will be here."))
+
+ (assert-true (uim-bool '(symbol-bound? 'test-style)))
+ ;; preexisting value is not overridden
+ (assert-equal 'test-style-uim
+ (uim 'test-style)))
+
+ ("test define-custom (key)"
+ ;; single key str
+ (assert-false (uim-bool '(symbol-bound? 'test-foo-key)))
+ (assert-false (uim-bool '(symbol-bound? 'test-foo-key?)))
+
+ (uim '(define-custom 'test-foo-key '("a")
+ '(global)
+ '(key)
+ "test foo key"
+ "long description will be here"))
+
+ (assert-true (uim-bool '(symbol-bound? 'test-foo-key)))
+ (assert-equal '("a")
+ (uim 'test-foo-key))
+ (assert-true (uim-bool '(symbol-bound? 'test-foo-key?)))
+ (assert-true (uim-bool '(test-foo-key? (string->charcode "a") 0)))
+
+ ;; key reference + key str
+ (assert-false (uim-bool '(symbol-bound? 'test-bar-key)))
+ (assert-false (uim-bool '(symbol-bound? 'test-bar-key?)))
+
+ (uim '(define-custom 'test-bar-key '(test-foo-key "b")
+ '(global)
+ '(key)
+ "test bar key"
+ "long description will be here"))
+
+ (assert-true (uim-bool '(symbol-bound? 'test-bar-key)))
+ (assert-equal '(test-foo-key "b")
+ (uim 'test-bar-key))
+ (assert-true (uim-bool '(symbol-bound? 'test-bar-key?)))
+ (assert-true (uim-bool '(test-bar-key? (string->charcode "a") 0)))
+ (assert-true (uim-bool '(test-bar-key? (string->charcode "b") 0))))
+
+ ("test define-custom (key) #2"
+ (uim '(define test-foo-key '("b")))
+ (assert-false (uim-bool '(symbol-bound? 'test-foo-key?)))
+
+ (uim '(define-custom 'test-foo-key '("a")
+ '(global)
+ '(key)
+ "test foo key"
+ "long description will be here"))
+
+ ;; preexisting value is not overridden
+ (assert-equal '("b")
+ (uim 'test-foo-key))
+ ;; key predicate is not defined since custom-set-value! is not
+ ;; invoked
+ (assert-false (uim-bool '(symbol-bound? 'test-foo-key?)))))
+
+(define-uim-test-case "testcase custom methods"
+ (setup
+ (lambda ()
+ (uim '(define-custom 'test-style 'test-style-ddskk
+ '(global)
+ '(choice
+ (test-style-uim "uim" "uim native")
+ (test-style-ddskk "ddskk like" "Similar to ddskk")
+ (test-style-canna "canna like" "Similar to canna"))
+ "Test style"
+ "long description will be here."))
+ (uim '(define-custom 'test-available-ims '(anthy canna skk)
+ '(global)
+ '(ordered-list
+ (anthy "Anthy" "Anthy")
+ (canna "Cannd" "Canna")
+ (skk "SKK" "SKK"))
+ "Test avalilable IMs"
+ "long description will be here."))
+ (uim '(define-custom 'test-cancel-key '("<Control>g" "escape")
+ '(global)
+ '(key)
+ "test cancel key"
+ "long description will be here."))
+ (uim '(define-custom 'test-foo-key '("a" test-cancel-key)
+ '(global)
+ '(key)
+ "test foo key"
+ "long description will be here."))
+ (uim '(define-custom 'test-bar-key '("b")
+ '(global)
+ '(key)
+ "test bar key"
+ "long description will be here."))
+ (uim '(define-custom 'test-use-candidate-window? #t
+ '(test ui)
+ '(boolean)
+ "Use candidate window"
+ "long description will be here."))
+ (uim '(define-custom 'test-nr-candidate-max 10
+ '(test advanced ui)
+ '(integer 1 20)
+ "Number of candidates in candidate window at a time"
+ "long description will be here."))
+ (uim '(define-custom 'test-string "a string"
+ '(test)
+ '(string ".+")
+ "A string for testing purpose"
+ "long description will be here."))
+ (uim '(define-custom 'test-dic-file-name "/usr/share/skk/SKK-JISYO.L"
+ '(test)
+ '(pathname)
+ "Dictionary file"
+ "long description will be here."))))
+
+ ("test custom-key-exist?"
+ (assert-true (uim-bool '(custom-key-exist? 'test-cancel-key)))
+ (assert-false (uim-bool '(custom-key-exist? 'test-baz-key)))
+ (uim '(define-key test-baz-key? '("z")))
+ (assert-false (uim-bool '(custom-key-exist? 'test-baz-key)))
+ (uim '(define-custom 'test-baz-key '("z")
+ '(global)
+ '(key)
+ "test foo key"
+ "long description will be here."))
+ (assert-true (uim-bool '(custom-key-exist? 'test-baz-key))))
+
+ ("test custom-value"
+ (assert-equal 'test-style-ddskk
+ (uim '(custom-value 'test-style)))
+ (assert-equal '(anthy canna skk)
+ (uim '(custom-value 'test-available-ims)))
+ (assert-equal '("<Control>g" "escape")
+ (uim '(custom-value 'test-cancel-key)))
+ (assert-true (uim-bool '(custom-value 'test-use-candidate-window?)))
+ (assert-equal 10
+ (uim '(custom-value 'test-nr-candidate-max)))
+ (assert-equal "a string"
+ (uim '(custom-value 'test-string)))
+ (assert-equal "/usr/share/skk/SKK-JISYO.L"
+ (uim '(custom-value 'test-dic-file-name))))
+
+ ("test custom-set-value!"
+ ;;; choice
+ ;; default value
+ (assert-equal 'test-style-ddskk
+ (uim '(custom-value 'test-style)))
+ ;; valid value
+ (assert-true (uim-bool '(custom-set-value! 'test-style 'test-style-uim)))
+ (assert-equal 'test-style-uim
+ (uim '(custom-value 'test-style)))
+ ;; invalid value is also accepted
+ (assert-true (uim-bool '(custom-set-value! 'test-style 'test-style-invalid)))
+ (assert-equal 'test-style-invalid
+ (uim '(custom-value 'test-style)))
+
+ ;;; ordered-list
+ ;; default value
+ (assert-equal '(anthy canna skk)
+ (uim '(custom-value 'test-available-ims)))
+ ;; valid value
+ (assert-true (uim-bool '(custom-set-value! 'test-available-ims
+ ())))
+ (assert-equal ()
+ (uim '(custom-value 'test-available-ims)))
+ (assert-true (uim-bool '(custom-set-value! 'test-available-ims
+ '(anthy))))
+ (assert-equal '(anthy)
+ (uim '(custom-value 'test-available-ims)))
+ (assert-true (uim-bool '(custom-set-value! 'test-available-ims
+ '(anthy skk))))
+ (assert-equal '(anthy skk)
+ (uim '(custom-value 'test-available-ims)))
+ (assert-true (uim-bool '(custom-set-value! 'test-available-ims
+ '(skk anthy))))
+ (assert-equal '(skk anthy)
+ (uim '(custom-value 'test-available-ims)))
+ (assert-true (uim-bool '(custom-set-value! 'test-available-ims
+ '(skk anthy canna))))
+ (assert-equal '(skk anthy canna)
+ (uim '(custom-value 'test-available-ims)))
+ ;; invalid value is also accepted
+ (assert-true (uim-bool '(custom-set-value! 'test-available-ims
+ '(nonexistent))))
+ (assert-equal '(nonexistent)
+ (uim '(custom-value 'test-available-ims)))
+
+ ;;; key
+ ;; default value
+ (assert-equal '("<Control>g" "escape")
+ (uim '(custom-value 'test-cancel-key)))
+ ;; valid value
+ (assert-true (uim-bool '(custom-set-value! 'test-cancel-key '("a"))))
+ (assert-equal '("a")
+ (uim '(custom-value 'test-cancel-key)))
+ (assert-true (uim-bool '(procedure? test-cancel-key?)))
+ ;; invalid value is also accepted
+ (assert-true (uim-bool '(custom-set-value! 'test-cancel-key
+ '(test-nonexistent "a"))))
+ (assert-equal '(test-nonexistent "a")
+ (uim '(custom-value 'test-cancel-key)))
+ (assert-true (uim-bool '(procedure? test-cancel-key?)))
+
+ ;;; boolean
+ ;; default value
+ (assert-true (uim-bool '(custom-value 'test-use-candidate-window?)))
+ ;; valid value
+ (assert-true (uim-bool '(custom-set-value! 'test-use-candidate-window? #f)))
+ (assert-false (uim-bool '(custom-value 'test-use-candidate-window?)))
+ ;; boolean regards all non-#f value as true
+ (assert-true (uim-bool '(custom-set-value! 'test-use-candidate-window? 10)))
+ (assert-true (uim-bool '(custom-value 'test-use-candidate-window?)))
+
+ ;;; integer
+ ;; default value
+ (assert-equal 10
+ (uim '(custom-value 'test-nr-candidate-max)))
+ ;; valid value
+ (assert-true (uim-bool '(custom-set-value! 'test-nr-candidate-max 5)))
+ (assert-equal 5
+ (uim '(custom-value 'test-nr-candidate-max)))
+ ;; invalid value is also accepted
+ (assert-true (uim-bool '(custom-set-value! 'test-nr-candidate-max 25)))
+ (assert-equal 25
+ (uim '(custom-value 'test-nr-candidate-max)))
+
+ ;;; string
+ ;; default value
+ (assert-equal "a string"
+ (uim '(custom-value 'test-string)))
+ ;; valid value
+ (assert-true (uim-bool '(custom-set-value! 'test-string "a altered string")))
+ (assert-equal "a altered string"
+ (uim '(custom-value 'test-string)))
+ ;; invalid value is also accepted
+ (assert-true (uim-bool '(custom-set-value! 'test-string #f)))
+ (assert-false (uim-bool '(custom-value 'test-string)))
+
+ ;;; pathname
+ ;; default value
+ (assert-equal "/usr/share/skk/SKK-JISYO.L"
+ (uim '(custom-value 'test-dic-file-name)))
+ ;; valid value
+ (assert-true (uim-bool '(custom-set-value! 'test-dic-file-name
+ "/usr/local/share/skk/SKK-JISYO.ML")))
+ (assert-equal "/usr/local/share/skk/SKK-JISYO.ML"
+ (uim '(custom-value 'test-dic-file-name)))
+ ;; invalid value is also accepted
+ (assert-true (uim-bool '(custom-set-value! 'test-dic-file-name #f)))
+ (assert-false (uim-bool '(custom-value 'test-dic-file-name)))))
Modified: trunk/test/test-slib.scm
===================================================================
--- trunk/test/test-slib.scm 2005-01-18 07:49:03 UTC (rev 317)
+++ trunk/test/test-slib.scm 2005-01-18 08:11:15 UTC (rev 318)
@@ -1,6 +1,6 @@
#!/usr/bin/env gosh
-;;; Copyright (c) 2003,2004 uim Project http://uim.freedesktop.org/
+;;; Copyright (c) 2003-2005 uim Project http://uim.freedesktop.org/
;;;
;;; All rights reserved.
;;;
@@ -79,3 +79,25 @@
(else #f))))))
(assert-false (uim-bool '(case 2
((2) #f))))))
+
+(define-uim-test-case "testcase procedures"
+ ("test precedure?"
+ (assert-true (uim-bool '(procedure? eof-val))) ;; 0
+ (assert-true (uim-bool '(procedure? car))) ;; 1
+ (assert-true (uim-bool '(procedure? cons))) ;; 2
+ (assert-true (uim-bool '(procedure? set-symbol-value!))) ;; 3
+ (assert-true (uim-bool '(procedure? im-register-im))) ;; 4
+ (assert-true (uim-bool '(procedure? dcngettext))) ;; 5
+ (assert-true (uim-bool '(procedure? +))) ;; 2n
+ (assert-true (uim-bool '(procedure? append))) ;; lsubr
+ (assert-true (uim-bool '(procedure? define))) ;; fsubr
+ (assert-true (uim-bool '(procedure? cond))) ;; msubr
+ (assert-true (uim-bool '(procedure? (lambda (x) x)))) ;; closure
+
+ (assert-false (uim-bool '(procedure? 0)))
+ (assert-false (uim-bool '(procedure? "str")))
+ (assert-false (uim-bool '(procedure? 'sym)))
+ (assert-false (uim-bool '(procedure? '(foo bar))))
+ (assert-false (uim-bool '(procedure? #t)))
+ (assert-false (uim-bool '(procedure? #f)))
+ (assert-false (uim-bool '(procedure? ())))))
Modified: trunk/uim/slib.c
===================================================================
--- trunk/uim/slib.c 2005-01-18 07:49:03 UTC (rev 317)
+++ trunk/uim/slib.c 2005-01-18 08:11:15 UTC (rev 318)
@@ -2018,6 +2018,28 @@
return (z);
}
+static LISP
+procedurep (LISP x)
+{
+ switch (TYPE (x))
+ {
+ case tc_subr_0:
+ case tc_subr_1:
+ case tc_subr_2:
+ case tc_subr_3:
+ case tc_lsubr:
+ case tc_fsubr:
+ case tc_msubr:
+ case tc_closure:
+ case tc_subr_4:
+ case tc_subr_5:
+ case tc_subr_2n:
+ return (sym_t);
+ default:
+ return (NIL);
+ }
+}
+
static void
gc_protect_n (LISP * location, long n)
{
@@ -4629,6 +4651,7 @@
init_subr_1 ("pair?", consp);
init_subr_1 ("symbol?", symbolp);
init_subr_1 ("number?", numberp);
+ init_subr_1 ("procedure?", procedurep);
init_msubr ("let-internal", leval_let);
init_subr_1 ("let-internal-macro", let_macro);
init_subr_1 ("let*-macro", letstar_macro);
More information about the Uim-commit
mailing list