source: project/release/4/locale/trunk/locale-posix.scm @ 15661

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

Save.

File size: 13.2 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 "(^[A-Za-z]+)|^<([^>]+)>"))
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            (failwarn
83              (lambda (msg) (warning msg str) #f) )
84            (next-match
85              (lambda (re)
86                (and-let* ((ml (string-search re str strpos)))
87                  (set! strpos (+ strpos (string-length (car ml))))
88                  ml ) ) )
89            (all-parsed
90              (lambda ()
91                (or (<= strend strpos)
92                    (failwarn "bad Posix timezone format") ) ) )
93            (parse-number
94              (lambda (numstr)
95                (cond ((not numstr) 0 )
96                      ((char-numeric? (string-ref numstr 0)) (string->number numstr) )
97                      (else
98                        (failwarn "bad Posix timezone number") ) ) ) )
99            (parse-delmcomp
100              (lambda (numstr delm)
101                (parse-number
102                  (cond ((string-prefix? delm numstr) (string-trim numstr (string-ref delm 0)) )
103                        (else                         numstr ) ) ) ) )
104            (parse-timecomp
105              (lambda (numstr) (parse-delmcomp numstr ":")) )
106            (parse-optional-timecomp  ; an offset component is optional
107              (lambda (numstr) (if numstr (parse-timecomp numstr) 0)) )
108            (parse-daterulecomp
109              (lambda (numstr) (parse-delmcomp numstr ".")) )
110            (hms->offset
111              (lambda (sgnstr hms-lst)
112                (and-let* ((hr (parse-number (car hms-lst)))
113                           (mn (parse-optional-timecomp (cadr hms-lst)))
114                           (sc (parse-optional-timecomp (caddr hms-lst))) )
115                  (let ((secs (+ (* hr SEC/HR) (* mn SEC/MIN) sc)))
116                    (if (and sgnstr (string=? sgnstr "-")) (- secs) secs)) ) ) )
117            (decode-dst-rule
118              (lambda (rulstr dat-lst off)
119                ; Must begin w/ a valid integer. Interpreted later.
120                (and-let* ((n1 (parse-number (car dat-lst))))
121                  (if (not rulstr)
122                      ; then assume Julian style rule
123                      (make-timezone-dst-rule-julian-leap n1 off)
124                      ; else select rule kind & interpret rest of match
125                      (let ((rch (string-ref rulstr 0)))
126                        (case rch
127                          ((#\J)  ; Julian
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                            (failwarn "unknown Posix 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                                      ;XXX What does "ahead" mean?
152                                      (+ (timezone-component-ref tz 'std-offset) SEC/HR) ) ) )
153                        (set-timezone-component! tz 'dst-name (cadr n-m))
154                        (set-timezone-component! tz 'dst-offset off)
155                        ; Rule, if present, must be complete
156                        (if (parse-dst-rule 'dst-start) (parse-dst-rule 'dst-end)
157                            #t ) ) ) ) ) )
158            (std-parse
159              (lambda ()
160                ; Must have name & offset components
161                (let ((n-m (next-match name-re)))
162                  (cond ((not n-m) (failwarn "bad Posix timezone STD name") )
163                        (else
164                          (let ((o-m (next-match offset-re)))
165                            (cond ((not o-m) (failwarn "bad Posix timezone STD offset") )
166                                  (else
167                                    (set-timezone-component! tz 'std-name (cadr n-m))
168                                    (set-timezone-component! tz 'std-offset (hms->offset (cadr o-m) (cddr o-m)))
169                                    #t ) ) ) ) ) ) ) ) )
170          ; Walk the match set
171          (cond ((string-null? str) (failwarn "empty Posix timezone") )
172                (else
173                 (and (std-parse)   ; Required
174                      (dst-parse)   ; Optional
175                      (all-parsed)  ; Must have successfully scanned entire string
176                      ; Then valid timezone info
177                      tz ) ) ) ) ) ) ) )
178
179;;
180
181#| ;NOT YET
182(cond-expand
183  (macosx
184    (define *system-timezone-directory* "/usr/share/zoneinfo") )
185  (else
186    (define *system-timezone-directory* #f) ) )
187
188(define (parse-posix-tzfile tz pn)
189  (warning "cannot understand Posix pathname timezone" pn)
190  #f )
191
192(define (parse-posix-pathname-timezone tz str)
193  (let ((pn (if (string-prefix? "/" str) str (make-pathname *system-timezone-directory* str))))
194    (if (file-exists? pn) (parse-posix-tzfile tz pn)
195        #f ) ) )
196|#
197
198(define (parse-posix-implementation-defined-timezone tz str)
199  (warning "cannot understand Posix implementation-defined timezone" str)
200  #f
201  #; ;NOT YET
202  (or (parse-posix-pathname-timezone tz (substring str 1))
203      (begin
204        (warning "cannot understand Posix implementation-defined timezone" str)
205        #f ) ) )
206
207;;
208
209(define (posix-timezone-string->timezone-components str . src)
210  (let ((tz (make-timezone-components str (optional src "POSIX"))))
211    (cond ((string-prefix? ":" str)
212            (parse-posix-implementation-defined-timezone tz str) )
213          (else
214            (parse-posix-literal-timezone tz str) ) ) ) )
215
216;;; Locale
217
218;; Splits an IEEEÊStdÊ1003.1-2001 locale specifier string into
219;; string components. The standard is extended to support a RFC 3066bis
220;; Script specifier.
221;;
222;; Returns a locale-components object or #f, indicating a parse error.
223;;
224;;     name: language(-script)(_territory)(.codeset)(@modifier)
225;; language: ISO 639-1 or ISO 639-2
226;;   script: RFC 3066bis
227;;   region: ISO 3166-1
228;;  codeset:
229;; modifier:
230
231(define parse-posix-literal-locale
232        (let ((locale-re (regexp "([a-zA-Z]+)(-[a-zA-Z]+)?(_[a-zA-Z]+)?(\\.[^@]+)?(@.+)?")))
233                (lambda (lc str)
234                  (let ((matched-len 0))
235        (and-let* ((r (string-match locale-re str)))
236          (let ((l (cadr r))
237                (s (caddr r))
238                (t (cadddr r))
239                (c (car (cddddr r)))
240                (m (cadr (cddddr r)))
241                (inc-matched-len
242                  (lambda (v)
243                    (set! matched-len (+ matched-len (string-length v))))))
244            (when l
245              (inc-matched-len l)
246              (set-locale-component! lc 'language (string-downcase l)))
247            (when s
248              (inc-matched-len s)
249              (set-locale-component! lc 'script (string-titlecase (substring s 1))))
250            (when t
251              (inc-matched-len t)
252              (set-locale-component! lc 'region (string-upcase (substring t 1))))
253            (when c
254              (inc-matched-len c)
255              (set-locale-component! lc 'codeset (substring c 1)))
256            (when m
257              (inc-matched-len m)
258              (set-locale-component! lc 'modifier (substring m 1)))
259            (and (= matched-len (string-length str))
260                 lc ) ) ) ) ) ) )
261
262;;
263
264#| ;NOT YET
265(cond-expand
266  (macosx
267    (define *system-locale-directory* "/usr/share/locale") )
268  (else
269    (define *system-locale-directory* #f) ) )
270
271(define (parse-posix-localefile lc pn)
272  (warning "cannot understand Posix pathname locale" pn)
273  #f )
274
275(define (parse-posix-pathname-locale lc str)
276  (let ((pn (if (string-prefix? "/" str) str (make-pathname *system-locale-directory* str))))
277    (if (file-exists? pn) (parse-posix-localefile lc pn)
278        #f ) ) )
279|#
280
281;;
282
283(define (posix-locale-string->locale-components str . args)
284  (let-optionals args ((src "POSIX") (tag 'locale))
285    (let ((lc (make-locale-components str src tag)))
286      (cond ((or (string=? str "C") (string=? str "POSIX"))
287             ;FIXME - #f so BUILTIN source used but ...
288             #f )
289            (else
290             (parse-posix-literal-locale lc str) ) ) ) ) )
291
292;;; The POSIX/GNU locale categories
293
294(define *posix-locale-category-names*
295        '(("LC_COLLATE" . collate)
296                ("LC_CTYPE" . character)
297                ("LC_MESSAGES" . messages)
298                ("LC_MONETARY" . monetary)
299                ("LC_NUMERIC" . numberic)
300                ("LC_ADDRESS" . address)
301                ("LC_IDENTIFICATION" . identification)
302                ("LC_MEASUREMENT" . measurement)
303                ("LC_NAME" . name)
304                ("LC_PAPER" . paper)
305                ("LC_TELEPHONE" . telephone)
306                ("LC_TIME" . time)) )
307
308(define (set-posix-locale-categories func)
309  (for-each
310   (lambda (cell)
311     (let ((cat (cdr cell)))
312       (cond ((func (car cell) cat) => (cute set-locale-category! cat <>))) ) )
313   *posix-locale-category-names*) )
314
315;;
316
317(define (gnu-language-string->locale-components str . args)
318  (let-optionals args ((src "GNU") (tag 'language))
319    (let* ((lc (make-locale-components str src tag))
320           (lang (string-upcase (locale-component-ref lc 'language))))
321      (update-locale-components! lc 'locales
322       (map
323        (lambda (str)
324          (let ((rlc (posix-locale-string->locale-components str src)))
325            (set-locale-component! rlc 'region lang)
326            rlc ) )
327        (string-split str ":")))
328      lc ) ) )
329
330;;;
331
332;; Sets the current timezone posix style
333
334(define (posix-load-timezone)
335  (and-let* ((str (nonnull-getenv "TZ")))
336    (set-locale-category! 'timezone
337     (posix-timezone-string->timezone-components str (list "POSIX" "TZ"))) ) )
338
339;; Create all local category values from the environment
340
341(define (posix-load-locale)
342        (let ((str (nonnull-getenv "LC_ALL")))
343                (if str
344        ; Then LC_ALL overrides
345        (let ((lc (posix-locale-string->locale-components str '("POSIX" "LC_ALL"))))
346          (set-posix-locale-categories (lambda (e c) lc)) )
347        ; Else set individually, w/ LANG as default
348        (let* ((str (nonnull-getenv "LANG"))
349               (lc (and str (posix-locale-string->locale-components str '("POSIX" "LANG")))))
350          (set-posix-locale-categories
351           (lambda (e c)
352             (cond ((nonnull-getenv e)
353                    => (cut posix-locale-string->locale-components <> `("POSIX" ,e)))
354                   (else lc)))) ) ) ) )
355
356;; GNU LANGUAGE (PATH-sytle list of LANG)
357
358(define (gnu-load-locale)
359  (and-let* ((str (nonnull-getenv "LANGUAGE")))
360    (let ((lc (gnu-language-string->locale-components str '("GNU" "LANGUAGE") 'language)))
361      (set-locale-category! 'language lc) ) ) )
362
363) ;module locale-posix
Note: See TracBrowser for help on using the repository browser.