1 | ;;;; locale-current.scm |
---|
2 | ;;;; Kon Lovett, May '06 |
---|
3 | |
---|
4 | ;; Issues |
---|
5 | ;; |
---|
6 | ;; - Only Posix for now. |
---|
7 | ;; - Uses the `messages' locale category as a proxy for the singleton |
---|
8 | ;; concept of locale. |
---|
9 | |
---|
10 | (module locale-current |
---|
11 | |
---|
12 | (;export |
---|
13 | current-timezone |
---|
14 | current-locale |
---|
15 | current-timezone-components |
---|
16 | current-locale-components |
---|
17 | current-second-dst? |
---|
18 | ; |
---|
19 | locale-setup) |
---|
20 | |
---|
21 | (import scheme chicken) |
---|
22 | (use |
---|
23 | (only posix seconds->local-time) |
---|
24 | (only type-errors warning-argument-type) |
---|
25 | locale-builtin |
---|
26 | locale-posix |
---|
27 | locale-components |
---|
28 | locale-categories) |
---|
29 | |
---|
30 | ;;; Local Utility |
---|
31 | |
---|
32 | ;; |
---|
33 | |
---|
34 | ;TLS |
---|
35 | (define *setup?* (make-parameter #f)) |
---|
36 | |
---|
37 | (define-inline (ensure-setup) |
---|
38 | ;critical region ? |
---|
39 | (unless (*setup?*) |
---|
40 | (*setup?* #t) |
---|
41 | (locale-setup)) ) |
---|
42 | |
---|
43 | ;; |
---|
44 | |
---|
45 | ;only useful for non-scalar (non-boolean) component |
---|
46 | (define-inline (locale-category-component-ref catnam cmpnam) |
---|
47 | (and-let* ( |
---|
48 | (lc (locale-category-ref catnam)) ) |
---|
49 | (locale-component-ref lc cmpnam)) ) |
---|
50 | |
---|
51 | (define-inline (language-components? obj) |
---|
52 | (and (not (timezone-components? obj)) (locale-components? obj)) ) |
---|
53 | |
---|
54 | ;;; Utility |
---|
55 | |
---|
56 | (define (current-second-dst?) |
---|
57 | (vector-ref (seconds->local-time (current-seconds)) 8) ) |
---|
58 | |
---|
59 | ;;; Parameters (Well, parameter-like) |
---|
60 | |
---|
61 | ;Delays initialization |
---|
62 | ;TLS (via current-locale-dictionary) |
---|
63 | |
---|
64 | ;; |
---|
65 | |
---|
66 | (define (current-timezone . args) |
---|
67 | (ensure-setup) |
---|
68 | (if (null? args) |
---|
69 | (locale-category-component-ref 'timezone 'name) |
---|
70 | (let-optionals args ((obj #f) (src "USER")) |
---|
71 | (cond |
---|
72 | ((not obj) |
---|
73 | (set-locale-category! 'timezone #f) ) |
---|
74 | ((string? obj) |
---|
75 | (set-locale-category! 'timezone |
---|
76 | (posix-timezone-string->timezone-components obj src)) ) |
---|
77 | ((timezone-components? obj) |
---|
78 | (set-locale-category! 'timezone obj) ) |
---|
79 | (else |
---|
80 | (warning-argument-type 'current-timezone obj "string, #f or timezone-components") |
---|
81 | (current-timezone) ) ) ) ) ) |
---|
82 | |
---|
83 | ;; A'la MzScheme |
---|
84 | ;; Treat locale as messages category |
---|
85 | |
---|
86 | (define (current-locale . args) |
---|
87 | (ensure-setup) |
---|
88 | (if (null? args) |
---|
89 | (locale-category-component-ref 'current 'name) |
---|
90 | (let-optionals args ((obj #f) (src "USER")) |
---|
91 | (cond |
---|
92 | ((not obj) |
---|
93 | (set-locale-category! 'current #f) ) |
---|
94 | ((string? obj) |
---|
95 | (set-locale-category! |
---|
96 | 'current |
---|
97 | (posix-locale-string->locale-components obj src)) ) |
---|
98 | ((language-components? obj) |
---|
99 | (set-locale-category! 'current obj) ) |
---|
100 | (else |
---|
101 | (warning-argument-type 'current-locale obj "string, #f or locale-components") |
---|
102 | (current-locale) ) ) ) ) ) |
---|
103 | |
---|
104 | ;; |
---|
105 | |
---|
106 | (define (current-timezone-components) |
---|
107 | (ensure-setup) |
---|
108 | (locale-category-ref 'timezone) ) |
---|
109 | |
---|
110 | (define (current-locale-components) |
---|
111 | (ensure-setup) |
---|
112 | (locale-category-ref 'current) ) |
---|
113 | |
---|
114 | ;; |
---|
115 | |
---|
116 | (define (locale-setup . args) |
---|
117 | ;Native locale system 1st |
---|
118 | ;FIXME platform locale system here |
---|
119 | ; |
---|
120 | ;Posix locale system 2nd |
---|
121 | (unless (current-timezone) (posix-load-timezone)) |
---|
122 | (unless (current-locale) (posix-load-locale)) |
---|
123 | ; |
---|
124 | ;GNU locale system extension |
---|
125 | (unless (locale-category-ref 'language) |
---|
126 | ;GNU says only obey when locale specified |
---|
127 | (when (current-locale) (gnu-load-locale)) ) |
---|
128 | ; |
---|
129 | ;Builtin (faked) locale system last |
---|
130 | (unless (current-timezone) (use-builtin-timezone)) |
---|
131 | (unless (current-locale) (use-builtin-locale)) |
---|
132 | ; |
---|
133 | ;Utility check |
---|
134 | (unless (current-timezone-components) (warning "cannot determine a timezone")) |
---|
135 | (unless (current-locale-components) (warning "cannot determine a locale")) |
---|
136 | ; |
---|
137 | ;Chicken platform extensions |
---|
138 | (when (current-timezone-components) |
---|
139 | (set-timezone-component! |
---|
140 | (current-timezone-components) 'dst? |
---|
141 | (current-second-dst?))) ) |
---|
142 | |
---|
143 | ) ;module locale |
---|