source: project/release/4/locale/trunk/locale-current.scm @ 35430

Last change on this file since 35430 was 35430, checked in by kon, 5 months ago

reflow

File size: 3.5 KB
Line 
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
Note: See TracBrowser for help on using the repository browser.