source: project/release/3/srfi-29/tags/1.12.0/srfi-29.scm @ 11835

Last change on this file since 11835 was 11835, checked in by Kon Lovett, 13 years ago

Bug fix release.

File size: 11.3 KB
Line 
1;;;; srfi-29.scm
2;;;; Kon Lovett, Dec '05
3
4;; ISSUES
5;;
6;; - Bit of a dither about (disable-interrupts). Suspect not really
7;; necessary but w/o the binary grows by ~10%!
8;;
9;; - Locale component symbols must have lowercase printname, as
10;; such they do not truely reflect ISO 639-1 & ISO 3166-1.
11;;
12;; - The locale details component of the SRFI is ill-defined, which
13;; symbol means what?
14;;
15;; - Possible race condition creating a bundle file or directory
16
17;; Default Bundles Directory is '(repository-path) "srfi-29-bundles"'.
18
19;; Within the bundle directory the structure
20;; is [(language) [(country) [(details)]]] (module).
21
22(eval-when (compile)
23  (declare
24    (usual-integrations)
25    (disable-interrupts) ; We got shared data
26    (fixnum)
27    (inline)
28    (no-procedure-checks)
29    (no-bound-checks)
30    (bound-to-procedure ; Forward references
31      most-specific-bundle-specifier
32      invalidate-package-bundle-cache )
33    (export
34      ;; Extensions
35      most-specific-bundle-specifier
36      localized-template/default
37      localized-template-set!
38      remove-bundle!
39      undeclare-bundle!
40      reset-locale-parameters
41      remove-bundle-directory!
42      load-best-available-bundle!
43      current-locale-format-function
44      localized-format
45      ;; SRFI 29
46      current-language
47      current-country
48      current-locale-details
49      load-bundle!
50      store-bundle!
51      declare-bundle!
52      localized-template ) ) )
53
54(use srfi-1 srfi-12 srfi-13 posix files
55     miscmacros lookup-table locale misc-extn-directory)
56
57(register-feature! 'srfi-29)
58
59;;;
60
61;;
62
63(define-inline (->symbol obj)
64  (string->symbol (->string obj)) )
65
66;; Constants
67
68(define-constant DEFAULT-BUNDLE-DIR "srfi-29-bundles")
69
70;; System bundles are here:
71
72(define SYSTEM-BUNDLES (make-pathname (repository-path) DEFAULT-BUNDLE-DIR))
73
74;; Um, the user really should set a locale
75
76(define LANGUAGE-DEFAULT 'en)
77(define COUNTRY-DEFAULT 'us)
78
79;;
80
81(define (make-srfi-29-exception loc msg . args)
82  (make-composite-condition
83   (make-property-condition 'exn 'message msg 'location loc 'arguments args)
84   (make-property-condition 'srfi-29)) )
85
86(define (signal-srfi-29-exception loc msg . args)
87  (abort (apply make-srfi-29-exception loc msg args)) )
88
89;;
90
91(define-inline (locale-item? x)
92  (or (not x) (symbol? x)) )
93
94(define-inline (locale-details? obj)
95  (and (list? obj)
96       (every locale-item? obj)) )
97
98;; bundle-specifier: (list-of symbol)
99;; i.e. package + locale, (package-name [language] [country] [details ...])
100
101(define (bundle-specification->pathname bundle-specifier)
102  (if (null? bundle-specifier)
103      (signal-srfi-29-exception 'load-bundle! "must specify package name" bundle-specifier)
104      (make-pathname (reverse! (fold (lambda (x l)
105                                       (if x
106                                           (cons (symbol->string x) l)
107                                           l ) )
108                                     '()
109                                     (cdr bundle-specifier)))
110                     (symbol->string (car bundle-specifier))) ) )
111
112(define-inline (bundle-specification->absolute-pathname bundle-specifier alternate-dir)
113  (make-pathname (optional alternate-dir SYSTEM-BUNDLES)
114                 (bundle-specification->pathname bundle-specifier)) )
115
116;; Bundles Dictionary
117
118(define *localization-bundles* (make-dict 1 equal?))
119
120(define-inline (find-bundle bundle-specifier)
121  (dict-ref *localization-bundles* bundle-specifier) )
122
123(define-inline (set-bundle! bundle-specifier bundle-alist)
124  (dict-set! *localization-bundles* bundle-specifier (alist->dict bundle-alist equal?)) )
125
126(define-inline (reset-bundle! bundle-specifier)
127  (invalidate-package-bundle-cache bundle-specifier)
128  (dict-delete! *localization-bundles* bundle-specifier) )
129
130;; Package Bundle Cache
131
132(define *package-bundle-cache* (make-dict 1 eq?))
133
134(define (invalidate-package-bundle-cache . bundle-specifier)
135  (if (not (null? bundle-specifier))
136      (dict-delete! *package-bundle-cache* (caar bundle-specifier))
137      (set! *package-bundle-cache* (make-dict 1 eq?)) ) )
138
139(define (cached-package-bundle package-name)
140  (or (dict-ref *package-bundle-cache* package-name)
141      (let loop ([specifier (remove! not (most-specific-bundle-specifier package-name))])
142        (and (not (null? specifier))
143             (if* (find-bundle specifier)
144                  (begin
145                    (dict-set! *package-bundle-cache* package-name it)
146                    it )
147                  (loop (drop-right! specifier 1)) ) ) ) ) )
148
149;; Canonical current locale
150
151(define (locale-ref what)
152  (let ([locale
153          (current-locale-components)]
154        [as-sym
155          (lambda (v)
156            (cond [(locale-item? v)  v]
157                  [(string? v)       (string->symbol (string-downcase v))]
158                  [else              (->symbol v)]) ) ] )
159    (select what
160      [('language)
161        (as-sym (locale-component-ref locale 'language LANGUAGE-DEFAULT))]
162      [('country)
163        (as-sym (locale-component-ref locale 'region COUNTRY-DEFAULT))]
164      [else
165        `(,(as-sym (locale-component-ref locale  'script))
166          ,(as-sym (locale-component-ref locale  'codeset))
167          ,(as-sym (locale-component-ref locale  'modifier))) ] ) ) )
168
169;;; Locale Parameters
170
171;; The default 'format' procedure
172;; Any supplied procedure MUST have the same signature as SRFI 28 'format'
173;; The initial procedure is the builtin
174
175(define-parameter current-locale-format-function
176  format
177  (lambda (x)
178    (if (procedure? x)
179        x
180        (begin
181          (warning 'current-locale-format-function "invalid procedure" x)
182          (current-locale-format-function) ) ) ) )
183
184;; The default language
185
186(define-parameter current-language
187  (locale-ref 'language)
188  (lambda (x)
189    (cond [(locale-item? x)
190           (invalidate-package-bundle-cache)
191           x ]
192          [else
193           (warning 'current-language "invalid locale item" x)
194           (current-language) ] ) ) )
195
196;; The default country
197
198(define-parameter current-country
199  (locale-ref 'country)
200  (lambda (x)
201    (cond [(locale-item? x)
202           (invalidate-package-bundle-cache)
203           x ]
204          [else
205           (warning 'current-country "invalid locale item" x)
206           (current-country) ] ) ) )
207
208;; The default locale-details
209
210(define-parameter current-locale-details
211  (locale-ref 'details)
212  (lambda (x)
213    (cond [(locale-details? x)
214           (invalidate-package-bundle-cache)
215           x ]
216          [else
217            (warning 'current-locale-details "invalid locale item" x)
218            (current-locale-details) ] ) ) )
219
220;; If you change (current-locale), you don't have to set current-*
221;; by hand, you can simply call this procedure, and it will update
222;; those parameters to the values in the new locale. (Reset as in
223;; set anew.)
224
225(define (reset-locale-parameters)
226  (current-language (locale-ref 'language))
227  (current-country (locale-ref 'country))
228  (current-locale-details (locale-ref 'details)) )
229
230;;; Bundle Operations
231
232;; Returns the full bundle specifier for the specified package using the default locale
233
234(define (most-specific-bundle-specifier package-name)
235  `(,package-name ,(current-language) ,(current-country) ,@(current-locale-details)) )
236
237;; Returns the localized template from the most specific bundle given
238;; its' package name and a template name, if the package exists. Otherwise
239;; returns the not-found argument, default #f.
240
241(define (localized-template package-name template-name #!optional not-found)
242  (if* (cached-package-bundle package-name)
243       (dict-ref it template-name)
244       not-found ) )
245
246;; Returns the localized template from the most specific bundle given
247;; its' package name and a template name, if the package exists. Otherwise
248;; returns the not-found argument, default is the template-name.
249
250(define (localized-template/default package-name template-name #!optional (not-found template-name))
251  (localized-template package-name template-name not-found) )
252
253;; Returns the application of the default 'format' procedure to the
254;; supplied arguments, using the package template as the format-string.
255;; When a format-string is unavailable an emergency display of the
256;; relevant details is made to proper destination.
257
258(define (localized-format package-name template-name port . fmtargs)
259  (let ([fmtstr (or (localized-template package-name template-name)
260                    (and (string? template-name)
261                         template-name))])
262    (if fmtstr
263        (apply (current-locale-format-function) port fmtstr fmtargs)
264        (let ([str (conc #\[ package-name #\/ template-name
265                             #\space
266                             (apply conc (intersperse fmtargs #\space))
267                         #\])])
268          (cond [(port? port)                     (display str port)]
269                [(or (string? port) (not port))   str]
270                [else                             (display str) ] ) ) ) ) )
271
272;; Create or update the value for a template in an existing package.
273;; Returns #t for success & #f when no such package.
274
275(define (localized-template-set! package-name template-name value)
276  (and-let* ([bundle (cached-package-bundle package-name)])
277    (dict-set! bundle template-name value)
278    #t ) )
279
280;; Declare a bundle of templates with a given bundle specifier
281
282(define (declare-bundle! bundle-specifier bundle-alist)
283  (set-bundle! bundle-specifier bundle-alist)
284  #t )
285
286;; Remove declared bundle, if any
287
288(define (undeclare-bundle! bundle-specifier)
289  (reset-bundle! bundle-specifier)
290  #t )
291
292;; Reads bundle file & declares.
293
294(define (load-bundle! bundle-specifier . alternate-dir)
295  (let ([path (bundle-specification->absolute-pathname bundle-specifier alternate-dir)])
296    (and (file-exists? path)
297         (declare-bundle! bundle-specifier (with-input-from-file path read)) ) ) )
298
299;; Write bundle to file
300
301(define (store-bundle! bundle-specifier . alternate-dir)
302  (let ([path (bundle-specification->absolute-pathname bundle-specifier alternate-dir)]
303        [bundle (find-bundle bundle-specifier)] )
304    (unless bundle
305      (signal-srfi-29-exception 'store-bundle! "no such declared bundle" bundle-specifier) )
306    (create-pathname-directory path)
307    (delete-file* path)
308    (with-output-to-file path (lambda () (write (dict->alist bundle))))
309    #t ) )
310
311;; Remove declared bundle and file, if any
312
313(define (remove-bundle! bundle-specifier . alternate-dir)
314  (let ([path (bundle-specification->absolute-pathname bundle-specifier alternate-dir)])
315    (reset-bundle! bundle-specifier)
316    (delete-file* path)
317    #t ) )
318
319;; Remove declared bundle and file, if any
320
321(define (remove-bundle-directory! bundle-specifier . alternate-dir)
322  (let ([pathname (bundle-specification->absolute-pathname bundle-specifier alternate-dir)])
323    (delete-file* pathname)
324    (let ([topdir (optional alternate-dir SYSTEM-BUNDLES)])
325      (let loop ([path pathname])
326        (let* ([dir (pathname-directory path)]
327               [fillst (directory dir)])
328          (cond [(string=? dir topdir)        #t]
329                [(positive? (length fillst))  #f]
330                [else
331                  (delete-directory dir)
332                  (loop dir)]) ) ) ) ) )
333
334;; Try loading from most to least specific, returns #f when failure.
335
336(define (load-best-available-bundle! bundle-specifier . alternate-dir)
337  (let loop ([specifier (remove not bundle-specifier)])
338    (and (not (null? specifier))
339         (or (apply load-bundle! specifier alternate-dir)
340             (loop (drop-right! specifier 1)))) ) )
Note: See TracBrowser for help on using the repository browser.