source: project/release/5/locale/trunk/locale-current.scm @ 37419

Last change on this file since 37419 was 37419, checked in by Kon Lovett, 17 months ago

fix srfi 1 & 13 dep

File size: 4.6 KB
Line 
1;;;; locale-current.scm
2;;;; Kon Lovett, Mar '19
3;;;; Kon Lovett, May '06
4
5;; Issues
6;;
7;; - Only Posix for now.
8;;
9;; - Uses the `messages' locale category as a proxy for the singleton
10;; concept of locale.
11
12(module locale-current
13
14(;export
15  current-timezone
16  current-locale
17  current-timezone-components
18  current-locale-components
19  current-dst?
20  ;
21  locale-setup)
22
23(import scheme
24  (chicken base)
25  (chicken type)
26  (only (chicken time posix) seconds->local-time local-timezone-abbreviation)
27  (only (chicken process-context) get-environment-variable)
28  (only (srfi 13) string-null?)
29  (only type-errors warning-argument-type)
30  locale-builtin
31  locale-posix
32  locale-components
33  locale-categories)
34
35;;; Local Utility
36
37;;
38
39;TLS
40(define *setup?* (make-parameter #f))
41
42(define-inline (ensure-setup)
43  ;critical region ?
44  (unless (*setup?*)
45    (*setup?* #t)
46    (locale-setup)) )
47
48;;
49
50;only useful for non-scalar (non-boolean) component
51(define-inline (locale-category-component-ref catnam cmpnam)
52  (and-let* (
53    (lc (locale-category-ref catnam)) )
54    (locale-component-ref lc cmpnam)) )
55
56(define-inline (language-components? obj)
57  (and (not (timezone-components? obj)) (locale-components? obj)) )
58
59;;; Utility
60
61(define (current-dst?) (vector-ref (seconds->local-time) 8))
62
63;;; Parameters (Well, parameter-like)
64
65;;
66
67(define (current-timezone . args)
68  (ensure-setup)
69  (if (null? args)
70    (locale-category-component-ref 'timezone 'name)
71    (let-optionals args ((obj #f) (src "USER"))
72      (cond
73        ((not obj)
74          (set-locale-category! 'timezone #f) )
75        ((string? obj)
76          (set-locale-category! 'timezone
77            (posix-timezone-string->timezone-components obj src)) )
78        ((timezone-components? obj)
79          (set-locale-category! 'timezone obj) )
80        (else
81          (warning-argument-type 'current-timezone obj "string, #f or timezone-components")
82          (current-timezone) ) ) ) ) )
83
84;; A'la MzScheme
85;; Treat locale as messages category
86
87(define (current-locale . args)
88  (ensure-setup)
89  (if (null? args)
90    (locale-category-component-ref 'current 'name)
91    (let-optionals args ((obj #f) (src "USER"))
92      (cond
93        ((not obj)
94          (set-locale-category! 'current #f) )
95        ((string? obj)
96          (set-locale-category!
97            'current
98            (posix-locale-string->locale-components obj src)) )
99        ((language-components? obj)
100          (set-locale-category! 'current obj) )
101        (else
102          (warning-argument-type 'current-locale obj "string, #f or locale-components")
103          (current-locale) ) ) ) ) )
104
105;;
106
107(define (current-timezone-components)
108  (ensure-setup)
109  (locale-category-ref 'timezone) )
110
111(define (current-locale-components)
112  (ensure-setup)
113  (locale-category-ref 'current) )
114
115;;
116
117;Chicken platform extension
118
119(define (nonnull-getenv varnam)
120  (let ((str (get-environment-variable varnam)))
121    (and (string? str) (not (string-null? str)) str) ) )
122
123(define (tm-dst? tm) (vector-ref tm 8))
124(define (tm-off tm) (vector-ref tm 9))
125
126(define (synthetic-posix-timezone-components tz-str tz-src)
127  (let* (
128    (tz (make-timezone-components tz-str tz-src))
129    (tm (seconds->local-time))
130    (keys (if (tm-dst? tm) '(dst-name . dst-offset) '(std-name . std-offset))) )
131    (set-timezone-component! tz 'dst? (tm-dst? tm))
132    (set-timezone-component! tz (car keys) (local-timezone-abbreviation))
133    (set-timezone-component! tz (cdr keys) (tm-off tm))
134    tz ) )
135
136(define (synthetic-posix-timezone)
137  (and-let* ((tz-str (nonnull-getenv "TZ")))
138    (let (
139      (tz (synthetic-posix-timezone-components tz-str (list "POSIX" "TZ"))) )
140      (set-locale-category! 'timezone tz) ) ) )
141
142;;
143
144(define (locale-setup . args)
145  ;Native locale system 1st
146  ;FIXME platform locale system here
147  ;
148  ;Posix locale system 2nd
149  (unless (current-timezone) (posix-load-timezone))
150  (unless (current-locale) (posix-load-locale))
151  ;
152  ;TZ Posix locale
153  (unless (current-timezone) (synthetic-posix-timezone))
154  ;
155  ;GNU locale system extension
156  (unless (locale-category-ref 'language)
157    ;GNU says only obey when locale specified
158    (when (current-locale) (gnu-load-locale)) )
159  ;
160  ;Builtin (faked) locale system last
161  (unless (current-timezone) (use-builtin-timezone))
162  (unless (current-locale) (use-builtin-locale))
163  ;
164  ;Utility check
165  (unless (current-timezone-components) (warning "cannot determine a timezone"))
166  (unless (current-locale-components) (warning "cannot determine a locale"))
167  ;
168  ;Chicken platform extensions
169  (and-let* ((tz (locale-category-ref 'timezone)))
170    (unless (locale-component-exists? tz 'dst?)
171      (set-timezone-component! tz 'dst? (current-dst?)) ) ) )
172
173) ;module locale
Note: See TracBrowser for help on using the repository browser.