1
;;; custom-rt.scm: Partial customization support for runtime input
4
;;; Copyright (c) 2003-2006 uim Project http://uim.freedesktop.org/
6
;;; All rights reserved.
8
;;; Redistribution and use in source and binary forms, with or without
9
;;; modification, are permitted provided that the following conditions
11
;;; 1. Redistributions of source code must retain the above copyright
12
;;; notice, this list of conditions and the following disclaimer.
13
;;; 2. Redistributions in binary form must reproduce the above copyright
14
;;; notice, this list of conditions and the following disclaimer in the
15
;;; documentation and/or other materials provided with the distribution.
16
;;; 3. Neither the name of authors nor the names of its contributors
17
;;; may be used to endorse or promote products derived from this software
18
;;; without specific prior written permission.
20
;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS IS'' AND
21
;;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
22
;;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
23
;;; ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE
24
;;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
25
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
26
;;; OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
27
;;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
28
;;; LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
29
;;; OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
33
;; This file provides partial custom definition support for runtime
34
;; input processes. The processes that wants full-featured custom API
35
;; such as uim-pref must overrides these definitions by loading
38
;; The name 'custom-rt' is not the best to represent this partial
39
;; functionality. Give me better name. -- YamaKen 2005-01-14
41
;; TODO: write test-custom-rt.scm
46
(define custom-full-featured? #f)
48
(define custom-enable-mtime-aware-user-conf-reloading? #f)
50
(define-record 'custom-choice-rec
55
(define custom-required-custom-files ())
56
(define custom-rt-primary-groups ())
57
(define custom-set-hooks ())
59
(define custom-group-conf-freshnesses ()) ;; (gsym . mtime)
61
(define custom-file-path
63
(let* ((group-name (symbol->string gsym))
64
(path (string-append (getenv "HOME")
65
"/.uim.d/customs/custom-"
71
(define custom-update-group-conf-freshness
73
(let ((mtime (file-mtime (custom-file-path gsym))))
74
(set! custom-group-conf-freshnesses
75
(alist-replace (cons gsym mtime)
76
custom-group-conf-freshnesses))
80
(define custom-group-conf-updated?
82
(let ((prev-mtime (assq-cdr gsym custom-group-conf-freshnesses)))
84
(not (= (file-mtime (custom-file-path gsym))
88
(define custom-load-updated-group-conf
90
(or (not (custom-group-conf-updated? gsym))
91
(and (try-load (custom-file-path gsym))
92
(custom-update-group-conf-freshness gsym)))))
94
;; full implementation
95
;; This proc is existing for DUMB loading. No more processing such as
96
;; mtime comparation or history recording must not be added. Please
97
;; keep in mind responsibility separation, and don't alter an API
98
;; specification previously stabilized, without discussion.
99
;; -- YamaKen 2005-08-09
100
(define custom-load-group-conf
102
(try-load (custom-file-path gsym))))
104
;; TODO: disable all newly defined customs when an error occurred in loading
105
;; full implementation
106
(define require-custom
108
(let ((pre-groups (custom-list-primary-groups)))
110
(if (not (member filename custom-required-custom-files))
111
(set! custom-required-custom-files
112
(cons filename custom-required-custom-files)))
113
(let* ((post-groups (custom-list-primary-groups))
114
(new-groups (list-tail post-groups (length pre-groups))))
115
(if (and (not (getenv "LIBUIM_VANILLA"))
117
(for-each (lambda (gsym)
118
(custom-load-group-conf gsym)
119
(custom-update-group-conf-freshness gsym))
120
(reverse new-groups)))))))
122
;; full implementation
123
(define custom-reload-customs
125
(for-each load (reverse custom-required-custom-files))
126
(custom-call-all-hook-procs custom-set-hooks)))
128
;; full implementation
129
(define custom-modify-key-predicate-names
137
;; lightweight implementation
138
(define custom-choice-range-reflect-olist-val
139
(lambda (dst-sym src-sym indication-alist)
142
;; full implementation
143
(define custom-rt-add-primary-groups
145
(if (not (member gsym custom-rt-primary-groups))
146
(set! custom-rt-primary-groups
147
(cons gsym custom-rt-primary-groups)))))
149
;; lightweight implementation
150
(define custom-list-primary-groups
152
(reverse custom-rt-primary-groups)))
155
;; lightweight implementation
156
(define custom-add-hook
157
(lambda (custom-sym hook-sym proc)
160
(set! custom-set-hooks
161
(alist-replace (cons custom-sym proc)
162
custom-set-hooks)))))
165
;; lightweight implementation
166
(define custom-call-hook-procs
168
(let ((proc (assq sym hook)))
173
;; full implementation
174
(define custom-call-all-hook-procs
176
(for-each (lambda (pair)
180
;; lightweight implementation
181
(define define-custom-group
182
(lambda (gsym label desc)
185
;; lightweight implementation
186
(define custom-exist?
188
(symbol-bound? sym)))
190
;; lightweight implementation
191
(define custom-key-exist?
193
(let ((key-sym (symbolconc sym '?)))
194
(and (symbol-bound? sym)
195
(list? (symbol-value sym))
196
(symbol-bound? key-sym)
197
(procedure? (symbol-value key-sym))))))
199
;; lightweight implementation
204
;; TODO: rewrite test
205
;; lightweight implementation
206
(define custom-set-value!
209
((custom-key-exist? sym)
210
(set-symbol-value! sym val)
211
(let ((key-val (custom-modify-key-predicate-names val)))
212
(eval (list 'define (symbolconc sym '?)
213
(list 'make-key-predicate (list 'quote key-val)))
214
(interaction-environment)))
216
((custom-exist? sym #f)
217
(set-symbol-value! sym val)
222
(custom-call-hook-procs sym custom-set-hooks)
225
;; TODO: rewrite test
226
;; lightweight implementation
227
(define define-custom
228
(lambda (sym default groups type label desc)
229
(custom-rt-add-primary-groups (car groups))
230
(if (not (custom-exist? sym type))
232
(let ((quoted-default (if (or (symbol? default)
234
(list 'quote default)
236
(eval (list 'define sym quoted-default)
237
(interaction-environment))
238
(if (custom-key-exist? sym)
239
;; already define-key'ed in ~/.uim
240
(custom-call-hook-procs sym custom-set-hooks)
244
(eval (list 'define (symbolconc sym '?) list)
245
(interaction-environment)))
246
(custom-set-value! sym default)))))))) ;; to apply hooks
248
;; lightweight implementation
249
;; warning: no validation performed
250
(define custom-prop-update-custom-handler
251
(lambda (context custom-sym val)
252
(custom-set-value! custom-sym val)))
254
;; custom-reload-user-configs can switch its behavior by
255
;; custom-enable-mtime-aware-user-conf-reloading? since the
256
;; experimental code breaks the semantics of custom variable
259
;; For example, an arbitrary uim-enabled process can update a custom
260
;; variable by its own code without any helper message passing. In
261
;; such case, the previously defined broadcasting behavior overwrites
262
;; the variable locally modified even if the corresponding custom file
265
;; To make the latter code default, a discussion is required.
266
;; -- YamaKen 2005-08-09
267
(define custom-reload-user-configs
269
(and (not (getenv "LIBUIM_VANILLA"))
271
(let ((load-conf (if custom-enable-mtime-aware-user-conf-reloading?
272
custom-load-updated-group-conf
273
custom-load-group-conf))) ;; original behavior
274
(for-each load-conf (custom-list-primary-groups))
275
(custom-call-all-hook-procs custom-set-hooks)))))
added
removed
scm/custom-rt.scm
