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

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

C5 port (still uses regex)

File size: 4.7 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;Delays initialization
66;TLS (via current-locale-dictionary)
67
68;;
69
70(define (current-timezone . args)
71  (ensure-setup)
72  (if (null? args)
73    (locale-category-component-ref 'timezone 'name)
74    (let-optionals args ((obj #f) (src "USER"))
75      (cond
76        ((not obj)
77          (set-locale-category! 'timezone #f) )
78        ((string? obj)
79          (set-locale-category! 'timezone
80            (posix-timezone-string->timezone-components obj src)) )
81        ((timezone-components? obj)
82          (set-locale-category! 'timezone obj) )
83        (else
84          (warning-argument-type 'current-timezone obj "string, #f or timezone-components")
85          (current-timezone) ) ) ) ) )
86
87;; A'la MzScheme
88;; Treat locale as messages category
89
90(define (current-locale . args)
91  (ensure-setup)
92  (if (null? args)
93    (locale-category-component-ref 'current 'name)
94    (let-optionals args ((obj #f) (src "USER"))
95      (cond
96        ((not obj)
97          (set-locale-category! 'current #f) )
98        ((string? obj)
99          (set-locale-category!
100            'current
101            (posix-locale-string->locale-components obj src)) )
102        ((language-components? obj)
103          (set-locale-category! 'current obj) )
104        (else
105          (warning-argument-type 'current-locale obj "string, #f or locale-components")
106          (current-locale) ) ) ) ) )
107
108;;
109
110(define (current-timezone-components)
111  (ensure-setup)
112  (locale-category-ref 'timezone) )
113
114(define (current-locale-components)
115  (ensure-setup)
116  (locale-category-ref 'current) )
117
118;;
119
120;Chicken platform extension
121
122(define (nonnull-getenv varnam)
123  (let (
124    (str (get-environment-variable varnam)) )
125    (and
126      (string? str) (not (string-null? str))
127      str ) ) )
128
129(define (tm-dst? tm) (vector-ref tm 8))
130(define (tm-off tm) (vector-ref tm 9))
131
132(define (synthetic-posix-timezone-components tz-str tz-src)
133  (let* (
134    (tz (make-timezone-components tz-str tz-src))
135    (tm (seconds->local-time))
136    (keys (if (tm-dst? tm) '(dst-name . dst-offset) '(std-name . std-offset))) )
137    (set-timezone-component! tz 'dst? (tm-dst? tm))
138    (set-timezone-component! tz (car keys) (local-timezone-abbreviation))
139    (set-timezone-component! tz (cdr keys) (tm-off tm))
140    tz ) )
141
142(define (synthetic-posix-timezone)
143  (and-let* (
144    (tz-str (nonnull-getenv "TZ")) )
145    (let (
146      (tz (synthetic-posix-timezone-components tz-str (list "POSIX" "TZ"))) )
147      (set-locale-category! 'timezone tz) ) ) )
148
149;;
150
151(define (locale-setup . args)
152  ;Native locale system 1st
153  ;FIXME platform locale system here
154  ;
155  ;Posix locale system 2nd
156  (unless (current-timezone) (posix-load-timezone))
157  (unless (current-locale) (posix-load-locale))
158  ;
159  ;TZ Posix locale
160  (unless (current-timezone) (synthetic-posix-timezone))
161  ;
162  ;GNU locale system extension
163  (unless (locale-category-ref 'language)
164    ;GNU says only obey when locale specified
165    (when (current-locale) (gnu-load-locale)) )
166  ;
167  ;Builtin (faked) locale system last
168  (unless (current-timezone) (use-builtin-timezone))
169  (unless (current-locale) (use-builtin-locale))
170  ;
171  ;Utility check
172  (unless (current-timezone-components) (warning "cannot determine a timezone"))
173  (unless (current-locale-components) (warning "cannot determine a locale"))
174  ;
175  ;Chicken platform extensions
176  (and-let* (
177    (tz (locale-category-ref 'timezone)) )
178    (unless (locale-component-exists? tz 'dst?)
179      (set-timezone-component! tz 'dst? (current-dst?)) ) ) )
180
181) ;module locale
Note: See TracBrowser for help on using the repository browser.