source: project/release/3/locale/trunk/locale-posix.scm @ 13860

Last change on this file since 13860 was 13860, checked in by Kon Lovett, 12 years ago

Save. Mvd params into locale.scm

File size: 10.9 KB
Line 
1;;;; locale-posix.scm
2;;; Kon Lovett, Dec '05
3
4;; Issues
5;;
6;; - Does not interact w/ setlocale or tzset
7;;
8;; - If LC_ALL or LANG is not set but any LC_* is set then (current-locale)
9;; will still be #f, while some locale-categories will be valued
10
11(declare
12  (usual-integrations)
13  (fixnum)
14  (inline)
15  (no-procedure-checks)
16  (export
17    make-posix-timezone
18    posix-timezone-string->timezone-components
19    posix-locale-string->locale-components
20    gnu-language-string->locale-components
21    posix-load-timezone
22    posix-load-locale
23    gnu-load-locale) )
24
25(require-extension srfi-1 srfi-13 regex data-structures locale-categories locale-components)
26
27;;;
28
29;;
30
31(define (nonnull-getenv varnam)
32  (let ((str (getenv "TZ")))
33                (and (string? str)
34                     (not (string-null? str))
35                     str ) ) )
36
37;;
38
39(define-constant SEC/HR   3600)
40(define-constant SEC/MIN  60)
41
42(define make-posix-timezone
43  (let ((hms
44          (lambda (secs)
45            (let* ((asecs (abs secs))
46                   (rsecs (remainder asecs SEC/HR)))
47              (string-append
48                (if (negative? secs) "-" "+")
49                (number->string (quotient asecs SEC/HR))
50                ":" (number->string (quotient rsecs SEC/MIN))
51                ":" (number->string (remainder rsecs SEC/MIN)))))))
52    (lambda (dst-tzn dst-off std-tzn std-off)
53      (string-append dst-tzn (hms dst-off) std-tzn (hms std-off)) ) ) )
54
55;; Splits an IEEEÊStdÊ1003.1-2001 TZ specifier string into components.
56;;
57;; Returns a timezone components object or #f, indicating a parse error.
58;;
59;; - doesn't handle implementation defined entries
60;;
61;; - cannot differentiate a relative timezone filename that is a valid
62;; timezone specifier
63
64(define parse-posix-standard-timezone-value
65        (let ((name-re (regexp "((A-Za-z)+)|<((^>)+)>"))
66                                (offset-re (regexp "((+-))?((0-9)+)(:(0-9)+)?(:(0-9)+)?"))
67                                (date-re (regexp ",((MJ))?((0-9)+)(\\.(0-9)+)?(\\.(0-9)+)?"))
68                                (time-re (regexp "/((0-9)+)(:(0-9)+)?(:(0-9)+)?"))
69                                (+defoff+ 3600))
70                (lambda (tz str)
71                        (let ((strpos 0)
72            (strend (string-length str)))
73        (letrec (
74            (next-match
75              (lambda (re)
76                (and-let* ((ml (string-match re str strpos)))
77                  (set! strpos (+ strpos (string-length (car ml))))
78                  ml ) ))
79            (all-parsed
80              (lambda () (>= strpos strend)))
81            (fake-dst-rule
82              (lambda ()
83                (set-timezone-component! tz 'dst-start (make-timezone-dst-rule-mwd 4 1 0 +defoff+))
84                (set-timezone-component! tz 'dst-end (make-timezone-dst-rule-mwd 10 5 0 +defoff+))
85                #t))
86            (to-num
87              (lambda (numstr)
88                (string->number
89                  (cond ((not numstr)                 "0")
90                        ((string-prefix? ":" numstr)  (string-trim numstr #\:))
91                        ((string-prefix? "." numstr)  (string-trim numstr #\.))
92                        (else                         numstr)))))
93            (to-offset
94              (lambda (sgnstr hms-lst)
95                (let ((secs (+ (* (string->number (car hms-lst)) 3600)
96                               (* (to-num (cadr hms-lst)) 60) 
97                               (to-num (caddr hms-lst)))))
98                  (if (equal? sgnstr "-") (- secs) secs))))
99            (parse-nam+off
100              (lambda (namkey offkey)
101                (and-let* ((n-m (next-match name-re))
102                           (o-m (next-match offset-re)))
103                  (set-timezone-component! tz namkey (cadr n-m))
104                  (set-timezone-component! tz offkey (to-offset (cadr o-m) (cddr o-m)))
105                  #t ) ))
106            (decode-dst-rule
107              (lambda (rulstr dat-lst off)
108                (let ((n1 (string->number (car dat-lst))))
109                  (if (not rulstr)
110                      ; Then assume Julian style rule
111                      (make-timezone-dst-rule-julian-leap n1 off)
112                      ; Else select rule
113                      (let ((rch (string-ref rulstr 0)))
114                        (case rch
115                          ((#\J)  ; Julian
116                            (make-timezone-dst-rule-julian-noleap n1 off))
117                          ((#\M)  ; Date
118                            (make-timezone-dst-rule-mwd n1 (to-num (cadr dat-lst))
119                                                           (to-num (caddr dat-lst)) off))
120                          (else
121                            (warning "unknown DST rule type; assuming julian-leap" rch)
122                            (make-timezone-dst-rule-julian-leap n1 off) ) ) ) ) ) ) )
123            (parse-dst-rule
124              (lambda (key)
125                (and-let* ((d-m (next-match date-re)))
126                  (let* ((t-m (next-match time-re))
127                         (off (if t-m (to-offset #f (cdr t-m)) +defoff+)))
128                    (set-timezone-component! tz key (decode-dst-rule (cadr d-m) (cddr d-m) off))
129                    #t)))) )
130          ; Walk the match set
131          (and ; At least standard timezone info
132               (parse-nam+off 'std-name 'std-offset)
133               ; Ok, then try optional DST section
134               (or (not (parse-nam+off 'dst-name 'dst-offset))
135                   ; Ok, then try optional DST start+end
136                   (or (and (parse-dst-rule 'dst-start)
137                            (parse-dst-rule 'dst-end))
138                       ; Else dummy something up
139                       (fake-dst-rule)))
140               ; Matched at least the minimum
141               (all-parsed)
142               ; Valid timezone info
143               tz ) ) ) ) ) )
144
145(define (parse-posix-implementation-defined-timezone-value tz str)
146  (warning "cannot understand implementation-defined values" str)
147  #f )
148
149(define (parse-posix-pathname-timezone-value tz str)
150  (warning "cannot understand pathname values" str)
151  #f )
152
153(define (posix-timezone-string->timezone-components str . src)
154  (let ((tz (make-timezone-components str (optional src "POSIX"))))
155    (cond ((string-prefix? ":" str)
156            (parse-posix-implementation-defined-timezone-value tz str) )
157          ((string-prefix? "/" str)
158            (parse-posix-pathname-timezone-value tz str) )
159          (else
160            (parse-posix-standard-timezone-value tz str) ) ) ) )
161
162;; Splits an IEEEÊStdÊ1003.1-2001 locale specifier string into
163;; string components. The standard is extended to support a RFC 3066bis
164;; Script specifier.
165;;
166;; Returns a locale-components object or #f, indicating a parse error.
167;;
168;;     name: language(-script)(_territory)(.codeset)(@modifier)
169;; language: ISO 639-1 or ISO 639-2
170;;   script: RFC 3066bis
171;;   region: ISO 3166-1
172;;  codeset:
173;; modifier:
174
175(define parse-posix-standard-locale
176        (let ((locale-re (regexp "((a-zA-Z)+)(-(a-zA-Z)+)?(_(a-zA-Z)+)?(\\.(^@)+)?(@.+)?")))
177                (lambda (lc str)
178                        (and-let* ((r (string-match locale-re str))
179                 (matched-len 0))
180        (let ((l (cadr r))
181              (s (caddr r))
182              (t (cadddr r))
183              (c (car (cddddr r)))
184              (m (cadr (cddddr r)))
185              (inc-matched-len
186                (lambda (v)
187                  (set! matched-len (+ matched-len (string-length v))))))
188          (when l
189            (inc-matched-len l)
190            (set-locale-component! lc 'language (string-downcase l)))
191          (when s
192            (inc-matched-len s)
193            (set-locale-component! lc 'script (string-titlecase (substring s 1))))
194          (when t
195            (inc-matched-len t)
196            (set-locale-component! lc 'region (string-upcase (substring t 1))))
197          (when c
198            (inc-matched-len c)
199            (set-locale-component! lc 'codeset (substring c 1)))
200          (when m
201            (inc-matched-len m)
202            (set-locale-component! lc 'modifier (substring m 1)))
203          (and (= matched-len (string-length str))
204               lc ) ) ) ) ) )
205
206(define (parse-posix-pathname-locale lc str)
207  (warning "cannot understand pathname locale values" str)
208  #f )
209
210(define (posix-locale-string->locale-components str . args)
211  (let-optionals args ((src "POSIX") (tag 'locale))
212    (let ((lc (make-locale-components str src tag)))
213      (cond ((or (string=? str "C") (string=? str "POSIX"))
214              #f )
215            ((string-prefix? "/" str)
216              (parse-posix-pathname-locale lc str) )
217            (else
218              (parse-posix-standard-locale lc str) ) ) ) ) )
219
220;; The POSIX/GNU locale categories
221
222(define *posix-locale-category-names*
223        '(("LC_COLLATE" . collate)
224                ("LC_CTYPE" . character)
225                ("LC_MESSAGES" . messages)
226                ("LC_MONETARY" . monetary)
227                ("LC_NUMERIC" . numberic)
228                ("LC_ADDRESS" . address)
229                ("LC_IDENTIFICATION" . identification)
230                ("LC_MEASUREMENT" . measurement)
231                ("LC_NAME" . name)
232                ("LC_PAPER" . paper)
233                ("LC_TELEPHONE" . telephone)
234                ("LC_TIME" . time)) )
235
236(define (set-posix-locale-categories func)
237  (for-each
238   (lambda (p)
239     (let ((cat (cdr p)))
240       ; Will not override existing category value
241       (unless (locale-category-ref cat)
242         (cond ((func (car p) cat) => (cute set-locale-category! cat <>))) ) ) )
243   *posix-locale-category-names*) )
244
245;;
246
247(define (gnu-language-string->locale-components str . args)
248  (let-optionals args ((src "GNU") (tag 'language))
249    (let ((lst
250            (map
251              (lambda (lclstr)
252                (let ((lc (posix-locale-string->locale-components lclstr src)))
253                  (unless (locale-component-ref lc 'region)
254                    (set-locale-component! lc
255                      'region (string-upcase (locale-component-ref lc 'language))) )
256                  lc ) )
257              (string-split str ":"))))
258        (let ((lc (make-locale-components str src tag)))
259          (update-locale-components! lc 'locales lst)
260          lc ) ) ) )
261
262;;;
263
264;; Sets the current timezone posix style
265
266(define (posix-load-timezone)
267  (unless (locale-category-ref 'timezone)
268    (and-let* ((str (nonnull-getenv "TZ")))
269      (let ((lc (posix-timezone-string->timezone-components str "POSIX")))
270        (set-locale-category! 'timezone lc)) ) ) )
271
272;; Create all local category values from the environment
273
274(define (posix-load-locale)
275  ; POSIX standard
276        (let ((str (nonnull-getenv "LC_ALL")))
277                (if str
278        ; Then LC_ALL overrides
279        (let ((lc (posix-locale-string->locale-components str)))
280          (set-posix-locale-categories (lambda (e c) lc)) )
281        ; Else set individually, w/ LANG as default
282        (let* ((str (nonnull-getenv "LANG"))
283               (lc (and str
284                        (posix-locale-string->locale-components str))))
285          (set-posix-locale-categories
286           (lambda (e c)
287             (cond ((nonnull-getenv e)
288                    => (cute posix-locale-string->locale-components <>))
289                   (else
290                    lc)))) ) ) ) )
291
292;; GNU LANGUAGE (PATH-sytle list of LANG)
293
294(define (gnu-load-locale)
295  (unless (locale-category-ref 'language)
296    (and-let* ((str (nonnull-getenv "LANGUAGE")))
297      (let ((lc (gnu-language-string->locale-components str)))
298        (set-locale-category! 'language lc) ) ) ) )
Note: See TracBrowser for help on using the repository browser.