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

Last change on this file since 35409 was 35409, checked in by Kon Lovett, 3 years ago

locale-setup on a per thread basis?

File size: 3.4 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;;;
31
32(define *setup?* (make-parameter #f))
33
34(define-inline (ensure-setup)
35  (unless (*setup?*)
36    (*setup?* #t)
37    (locale-setup)) )
38
39(define-inline (locale-category+component-ref catnam cmpnam)
40  (and-let* (
41    (lc (locale-category-ref catnam)) )
42    (locale-component-ref lc cmpnam)) )
43
44(define-inline (language-components? obj)
45  (and (not (timezone-components? obj)) (locale-components? obj)) )
46
47;;; Parameters (Well, parameter-like)
48
49;;
50
51(define (current-timezone . args)
52  (ensure-setup)
53  (if (null? args)
54    (locale-category+component-ref 'timezone 'name)
55    (let-optionals args ((obj #f) (src "USER"))
56      (cond
57        ((not obj)
58          (set-locale-category! 'timezone #f) )
59        ((string? obj)
60          (set-locale-category!
61            'timezone
62            (posix-timezone-string->timezone-components obj src)) )
63        ((timezone-components? obj)
64          (set-locale-category! 'timezone obj) )
65        (else
66          (warning-argument-type 'current-timezone obj "string, #f or timezone-components")
67          (current-timezone) ) ) ) ) )
68
69;; A'la MzScheme
70;; Treat locale as messages category
71
72(define (current-locale . args)
73  (ensure-setup)
74  (if (null? args)
75    (locale-category+component-ref 'current 'name)
76    (let-optionals args ((obj #f) (src "USER"))
77      (cond
78        ((not obj)
79          (set-locale-category! 'current #f) )
80        ((string? obj)
81          (set-locale-category!
82            'current
83            (posix-locale-string->locale-components obj src)) )
84        ((language-components? obj)
85          (set-locale-category! 'current obj) )
86        (else
87          (warning-argument-type 'current-locale obj "string, #f or locale-components")
88          (current-locale) ) ) ) ) )
89
90;;
91
92(define (current-timezone-components)
93  (ensure-setup)
94  (locale-category-ref 'timezone) )
95
96(define (current-locale-components)
97  (ensure-setup)
98  (locale-category-ref 'current) )
99
100(define (current-second-dst?)
101  (vector-ref (seconds->local-time (current-seconds)) 8) )
102
103;;
104
105(define (locale-setup . args)
106  ;Native locale system 1st
107  ;FIXME platform locale system here
108  ;
109  ;Posix locale system 2nd
110  (unless (current-timezone) (posix-load-timezone))
111  (unless (current-locale) (posix-load-locale))
112  ;
113  ;GNU locale system extension
114  (unless (locale-category-ref 'language)
115    ;GNU says only obey when locale specified
116    (when (current-locale) (gnu-load-locale)) )
117  ;
118  ;Builtin (faked) locale system last
119  (unless (current-timezone) (use-builtin-timezone))
120  (unless (current-locale) (use-builtin-locale))
121  ;
122  ;Utility check
123  (unless (current-timezone-components) (warning "cannot determine a timezone"))
124  (unless (current-locale-components) (warning "cannot determine a locale"))
125  ;
126  ;Chicken platform extensions
127  (when (current-timezone-components)
128    (set-timezone-component! (current-timezone-components) 'dst? (current-second-dst?))) )
129
130) ;module locale
Note: See TracBrowser for help on using the repository browser.