source: project/release/4/locale/tags/0.6.3/locale-posix.scm @ 15916

Last change on this file since 15916 was 15916, checked in by Kon Lovett, 11 years ago

Rel 0.6.3 - David Murray's patch for TZ envvar parsing.

File size: 13.4 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(module locale-posix (;export
12  ;
13  seconds->h:m:s-string
14  ;
15  make-posix-timezone
16  ;
17  posix-timezone-string->timezone-components
18  posix-locale-string->locale-components
19  gnu-language-string->locale-components
20  ;
21  posix-load-timezone
22  posix-load-locale
23  gnu-load-locale)
24
25  (import chicken scheme)
26  (require-extension srfi-1 srfi-13 regex data-structures files
27                     locale-categories locale-components)
28
29  (declare
30    (fixnum)
31    (inline)
32    (no-procedure-checks) )
33
34;;;
35
36(define-constant SEC/HR   3600)
37(define-constant SEC/MIN  60)
38
39;;
40
41(define (nonnull-getenv varnam)
42  (let ((str (getenv varnam)))
43                (and (string? str) (not (string-null? str))
44                     str ) ) )
45
46;;; Utility
47
48(define (seconds->h:m:s-string secs)
49  (let* ((asecs (abs secs))
50         (rsecs (remainder asecs SEC/HR)) )
51    (conc (if (negative? secs) #\- #\+) (quotient asecs SEC/HR)
52          #\: (quotient rsecs SEC/MIN)
53          #\: (remainder rsecs SEC/MIN)) ) )
54
55(define (make-posix-timezone dst-tzn dst-off std-tzn std-off)
56  (string-append dst-tzn (seconds->h:m:s-string dst-off) std-tzn (seconds->h:m:s-string std-off)) )
57
58;;; Timezone
59
60;; Splits an IEEEÊStdÊ1003.1-2001 TZ specifier string into components.
61;;
62;; Returns a timezone components object or #f, indicating a parse error.
63;;
64;; - doesn't handle implementation defined entries
65;;
66;; - cannot differentiate a relative timezone filename that is a valid
67;; timezone specifier
68
69(define parse-posix-literal-timezone
70        (let ((name-re (regexp "(^[^<:][^0-9,+-]+)|^<([^>]+)>"))
71                                (offset-re (regexp "^(\\+|-)?([0-9]+)(:[0-9]+)?(:[0-9]+)?"))
72                                ; For compatibility with System V Release 3.1, a semicolon (`;') may be
73                                ; used to separate the rule from the rest of the specification.
74                                ; Allow it to separate the "to DST" & "from DST" segments since no harm, no foul.
75                                (date-re (regexp "^[;,]([JM])?([0-9]+)(\\.[0-9]+)?(\\.[0-9]+)?"))
76                                (time-re (regexp "^/([0-9]+)(:[0-9]+)?(:[0-9]+)?"))
77                                (+0200hrs+ (* 2 SEC/HR)) )
78                (lambda (tz str)
79                        (let ((strpos 0)
80            (strend (string-length str)) )
81        (letrec (
82            (fail
83              (lambda (msg)
84                (error 'parse-posix-literal-timezone msg str) ) )
85            (next-match
86              (lambda (re)
87                (and-let* ((ml (string-search re str strpos)))
88                  (set! strpos (+ strpos (string-length (car ml))))
89                  ml ) ) )
90            (all-parsed
91              (lambda ()
92                (or (<= strend strpos)
93                    (fail "bad timezone format") ) ) )
94            (parse-number
95              (lambda (numstr)
96                (cond ((not numstr) 0 )
97                      ((char-numeric? (string-ref numstr 0)) (string->number numstr) )
98                      (else
99                        (fail "bad timezone number") ) ) ) )
100            (parse-delmcomp
101              (lambda (numstr delm)
102                (parse-number
103                  (if (not (and numstr (string-prefix? delm numstr))) numstr
104                      (string-trim numstr (string-ref delm 0)) ) ) ) )
105            (parse-timecomp
106              (lambda (numstr) 
107                (parse-delmcomp numstr ":")) )
108            (parse-daterulecomp
109              (lambda (numstr)
110                (parse-delmcomp numstr ".")) )
111            (hms->offset
112              (lambda (sgnstr hms-lst)
113                (and-let* ((hr (parse-number (car hms-lst)))
114                           (mn (parse-timecomp (cadr hms-lst)))
115                           (sc (parse-timecomp (caddr hms-lst))) )
116                  (let ((secs (+ (* hr SEC/HR) (* mn SEC/MIN) sc)))
117                    (if (and sgnstr (string=? sgnstr "-")) (- secs) secs)) ) ) )
118            (decode-dst-rule
119              (lambda (rulstr dat-lst off)
120                ; Must begin w/ a valid integer. Interpreted later.
121                (and-let* ((n1 (parse-number (car dat-lst))))
122                  (cond ((not rulstr) ;Julian Leap rule
123                          (make-timezone-dst-rule-julian-leap n1 off) )
124                      ; select rule kind & interpret rest of match
125                      (else
126                        (case (string-ref rulstr 0)
127                          ((#\J)  ; Julian No-Leap rule
128                            (make-timezone-dst-rule-julian-noleap n1 off) )
129                          ((#\M)  ; Date
130                            (and-let* ((n (parse-daterulecomp (cadr dat-lst)))
131                                       (d (parse-daterulecomp (caddr dat-lst))) )
132                              (make-timezone-dst-rule-mwd n1 n d off) ) )
133                          (else
134                            (fail "unknown timezone DST rule type") ) ) ) ) ) ) )
135            (parse-dst-rule
136              (lambda (key)
137                (and-let* ((d-m (next-match date-re)))
138                  ; Time component is optional & defaults to 02:00:00
139                  (let* ((t-m (next-match time-re))
140                         (off (if t-m (hms->offset #f (cdr t-m)) +0200hrs+)) )
141                    (set-timezone-component! tz key (decode-dst-rule (cadr d-m) (cddr d-m) off))
142                    #t ) ) ) )
143            (dst-parse
144              (lambda ()
145                ; DST section is optional
146                (let ((n-m (next-match name-re)))
147                  (or (not n-m)
148                      ; Offset is optional & defaults to 1hr
149                      (let* ((o-m (next-match offset-re))
150                             (off (if o-m (hms->offset (cadr o-m) (cddr o-m))
151                                      (- (timezone-component-ref tz 'std-offset) SEC/HR)
152                                      #; ;XXX What does "ahead" mean?
153                                      (+ (timezone-component-ref tz 'std-offset) SEC/HR) ) ) )
154                        (set-timezone-component! tz 'dst-name (cadr n-m))
155                        (set-timezone-component! tz 'dst-offset off)
156                        ; Rule, if present, must be complete
157                        (if (parse-dst-rule 'dst-start) (parse-dst-rule 'dst-end)
158                            #t ) ) ) ) ) )
159            (std-parse
160              (lambda ()
161                ; Must have name & offset components
162                (let ((n-m (next-match name-re)))
163                  (cond ((not n-m) (fail "bad timezone STD name") )
164                        (else
165                          (let ((o-m (next-match offset-re)))
166                            (cond ((not o-m) (fail "bad timezone STD offset") )
167                                  (else
168                                    (set-timezone-component! tz 'std-name (cadr n-m))
169                                    (set-timezone-component! tz 'std-offset (hms->offset (cadr o-m) (cddr o-m)))
170                                    #t ) ) ) ) ) ) ) ) )
171          ; Walk the match set
172          (cond ((string-null? str) (fail "empty timezone") )
173                (else
174                 (and (std-parse)   ; Required
175                      (dst-parse)   ; Optional
176                      (all-parsed)  ; Must have successfully scanned entire string
177                      ; Then valid timezone info
178                      tz ) ) ) ) ) ) ) )
179
180;;
181
182#| ;NOT YET
183(cond-expand
184  (macosx
185    (define *system-timezone-directory* "/usr/share/zoneinfo") )
186  (else
187    (define *system-timezone-directory* #f) ) )
188
189(define (parse-posix-tzfile tz pn)
190  (warning "cannot understand Posix pathname timezone" pn)
191  #f )
192
193(define (parse-posix-pathname-timezone tz str)
194  (let ((pn (if (string-prefix? "/" str) str (make-pathname *system-timezone-directory* str))))
195    (if (file-exists? pn) (parse-posix-tzfile tz pn)
196        #f ) ) )
197|#
198
199(define (parse-posix-implementation-defined-timezone tz str)
200  (warning "cannot understand Posix implementation-defined timezone" str)
201  #f
202  #; ;NOT YET
203  (or (parse-posix-pathname-timezone tz (substring str 1))
204      (begin
205        (warning "cannot understand Posix implementation-defined timezone" str)
206        #f ) ) )
207
208;;
209
210(define (posix-timezone-string->timezone-components str . src)
211  (let ((tz (make-timezone-components str (optional src "POSIX"))))
212    (cond ((and (string? str) (string-prefix? ":" str))
213            (parse-posix-implementation-defined-timezone tz str) )
214          ((or (not (string? str)) (string=? "" str))
215            #f )
216          (else
217            (parse-posix-literal-timezone tz str) ) ) ) )
218
219;;; Locale
220
221;; Splits an IEEEÊStdÊ1003.1-2001 locale specifier string into
222;; string components. The standard is extended to support a RFC 3066bis
223;; Script specifier.
224;;
225;; Returns a locale-components object or #f, indicating a parse error.
226;;
227;;     name: language(-script)(_territory)(.codeset)(@modifier)
228;; language: ISO 639-1 or ISO 639-2
229;;   script: RFC 3066bis
230;;   region: ISO 3166-1
231;;  codeset:
232;; modifier:
233
234(define parse-posix-literal-locale
235        (let ((locale-re (regexp "([a-zA-Z]+)(-[a-zA-Z]+)?(_[a-zA-Z]+)?(\\.[^@]+)?(@.+)?")))
236                (lambda (lc str)
237                  (let ((matched-len 0))
238        (and-let* ((r (string-match locale-re str)))
239          (let ((l (cadr r))
240                (s (caddr r))
241                (t (cadddr r))
242                (c (car (cddddr r)))
243                (m (cadr (cddddr r)))
244                (inc-matched-len
245                  (lambda (v)
246                    (set! matched-len (+ matched-len (string-length v))))))
247            (when l
248              (inc-matched-len l)
249              (set-locale-component! lc 'language (string-downcase l)))
250            (when s
251              (inc-matched-len s)
252              (set-locale-component! lc 'script (string-titlecase (substring s 1))))
253            (when t
254              (inc-matched-len t)
255              (set-locale-component! lc 'region (string-upcase (substring t 1))))
256            (when c
257              (inc-matched-len c)
258              (set-locale-component! lc 'codeset (substring c 1)))
259            (when m
260              (inc-matched-len m)
261              (set-locale-component! lc 'modifier (substring m 1)))
262            (and (= matched-len (string-length str))
263                 lc ) ) ) ) ) ) )
264
265;;
266
267#| ;NOT YET
268(cond-expand
269  (macosx
270    (define *system-locale-directory* "/usr/share/locale") )
271  (else
272    (define *system-locale-directory* #f) ) )
273
274(define (parse-posix-localefile lc pn)
275  (warning "cannot understand Posix pathname locale" pn)
276  #f )
277
278(define (parse-posix-pathname-locale lc str)
279  (let ((pn (if (string-prefix? "/" str) str (make-pathname *system-locale-directory* str))))
280    (if (file-exists? pn) (parse-posix-localefile lc pn)
281        #f ) ) )
282|#
283
284;;
285
286(define (posix-locale-string->locale-components str . args)
287  (let-optionals args ((src "POSIX") (tag 'locale))
288    (let ((lc (make-locale-components str src tag)))
289      (cond ((or (not (string? str)) (string=? "" str))
290              #f )
291            ((or (string=? str "C") (string=? str "POSIX"))
292              ;FIXME - #f so BUILTIN source used but ...
293              #f )
294            (else
295              (parse-posix-literal-locale lc str) ) ) ) ) )
296
297;;; The POSIX/GNU locale categories
298
299(define *posix-locale-category-names*
300        '(("LC_COLLATE" . collate)
301                ("LC_CTYPE" . character)
302                ("LC_MESSAGES" . messages)
303                ("LC_MONETARY" . monetary)
304                ("LC_NUMERIC" . numberic)
305                ("LC_ADDRESS" . address)
306                ("LC_IDENTIFICATION" . identification)
307                ("LC_MEASUREMENT" . measurement)
308                ("LC_NAME" . name)
309                ("LC_PAPER" . paper)
310                ("LC_TELEPHONE" . telephone)
311                ("LC_TIME" . time)) )
312
313(define (set-posix-locale-categories func)
314  (for-each
315   (lambda (cell)
316     (let ((cat (cdr cell)))
317       (cond ((func (car cell) cat) => (cute set-locale-category! cat <>))) ) )
318   *posix-locale-category-names*) )
319
320;;
321
322(define (gnu-language-string->locale-components str . args)
323  (and (string? str)
324       (not (string=? "" str))
325       (let-optionals args ((src "GNU") (tag 'language))
326         (let* ((lc (make-locale-components str src tag))
327                (lang (string-upcase (locale-component-ref lc 'language))))
328           (update-locale-components! lc 'locales
329            (map
330             (lambda (str)
331               (let ((rlc (posix-locale-string->locale-components str src)))
332                 (set-locale-component! rlc 'region lang)
333                 rlc ) )
334             (string-split str ":")))
335           lc ) ) ) )
336
337;;;
338
339;; Sets the current timezone posix style
340
341(define (posix-load-timezone)
342  (and-let* ((str (nonnull-getenv "TZ")))
343    (set-locale-category! 'timezone
344     (posix-timezone-string->timezone-components str (list "POSIX" "TZ"))) ) )
345
346;; Create all local category values from the environment
347
348(define (posix-load-locale)
349        (let ((str (nonnull-getenv "LC_ALL")))
350                (if str
351        ; Then LC_ALL overrides
352        (let ((lc (posix-locale-string->locale-components str '("POSIX" "LC_ALL"))))
353          (set-posix-locale-categories (lambda (e c) lc)) )
354        ; Else set individually, w/ LANG as default
355        (let* ((str (nonnull-getenv "LANG"))
356               (lc (and str (posix-locale-string->locale-components str '("POSIX" "LANG")))))
357          (set-posix-locale-categories
358           (lambda (e c)
359             (cond ((nonnull-getenv e)
360                    => (cut posix-locale-string->locale-components <> `("POSIX" ,e)))
361                   (else lc)))) ) ) ) )
362
363;; GNU LANGUAGE (PATH-sytle list of LANG)
364
365(define (gnu-load-locale)
366  (and-let* ((str (nonnull-getenv "LANGUAGE")))
367    (let ((lc (gnu-language-string->locale-components str '("GNU" "LANGUAGE") 'language)))
368      (set-locale-category! 'language lc) ) ) )
369
370) ;module locale-posix
Note: See TracBrowser for help on using the repository browser.