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

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

Save. Bug in posix parse. Rmvd string const globals. Made 'locale' a "full export" module.

File size: 13.3 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]+)" #;"^([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 "^[;,](M|J)?([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(print "@ " (substring str strpos))
87                (and-let* ((ml (string-search re str strpos)))
88(print "! " ml)
89                  (set! strpos (+ strpos (string-length (car ml))))
90                  ml ) ) )
91            (all-parsed
92              (lambda ()
93                (or (<= strend strpos)
94                    (failwarn "bad Posix timezone format") ) ) )
95            (parse-number
96              (lambda (numstr)
97                (cond ((not numstr) 0 )
98                      ((char-numeric? (string-ref numstr 0)) (string->number numstr) )
99                      (else (failwarn "bad Posix timezone number") ) ) ) )
100            (parse-delmcomp
101              (lambda (numstr delm)
102                (parse-number
103                  (cond ((string-prefix? delm numstr) (string-trim numstr (string-ref delm 0)) )
104                        (else                         numstr ) ) ) ) )
105            (parse-timecomp
106              (lambda (numstr) (parse-delmcomp numstr ":")) )
107            (parse-optional-timecomp  ; an offset component is optional
108              (lambda (numstr) (if numstr (parse-timecomp numstr) 0)) )
109            (parse-daterulecomp
110              (lambda (numstr) (parse-delmcomp numstr ".")) )
111            (hms->offset
112              (lambda (sgnstr hms-lst)
113                (and-let* ((hr (parse-number (car hms-lst)))
114                           (mn (parse-optional-timecomp (cadr hms-lst)))
115                           (sc (parse-optional-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                  (if (not rulstr)
123                      ; then assume Julian style rule
124                      (make-timezone-dst-rule-julian-leap n1 off)
125                      ; else select rule kind & interpret rest of match
126                      (let ((rch (string-ref rulstr 0)))
127                        (case rch
128                          ((#\J)  ; Julian
129                            (make-timezone-dst-rule-julian-noleap n1 off) )
130                          ((#\M)  ; Date
131                            (and-let* ((n (parse-daterulecomp (cadr dat-lst)))
132                                       (d (parse-daterulecomp (caddr dat-lst))) )
133                              (make-timezone-dst-rule-mwd n1 n d off) ) )
134                          (else
135                            (failwarn "unknown Posix timezone DST rule type") ) ) ) ) ) ) )
136            (parse-dst-rule
137              (lambda (key)
138                (and-let* ((d-m (next-match date-re)))
139                  ; Time component is optional & defaults to 02:00:00
140                  (let* ((t-m (next-match time-re))
141                         (off (if t-m (hms->offset "" (cdr t-m)) +0200hrs+)) )
142                    (set-timezone-component! tz key (decode-dst-rule (cadr d-m) (cddr d-m) off))
143                    #t ) ) ) )
144            (dst-parse
145              (lambda ()
146                ; DST section is optional
147                (let ((n-m (next-match name-re)))
148                  (or (not n-m)
149                      ; Offset is optional & defaults to 1hr
150                      (let* ((o-m (next-match offset-re))
151                             (off (if o-m (hms->offset (cadr o-m) (cddr o-m))
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) (failwarn "bad Posix timezone STD name") )
164                        (else
165                          (let ((o-m (next-match offset-re)))
166                            (cond ((not o-m) (failwarn "bad Posix 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) (failwarn "empty Posix 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 ((string-prefix? ":" str)
213            (parse-posix-implementation-defined-timezone tz str) )
214          (else
215            (parse-posix-literal-timezone tz str) ) ) ) )
216
217;;; Locale
218
219;; Splits an IEEEÊStdÊ1003.1-2001 locale specifier string into
220;; string components. The standard is extended to support a RFC 3066bis
221;; Script specifier.
222;;
223;; Returns a locale-components object or #f, indicating a parse error.
224;;
225;;     name: language(-script)(_territory)(.codeset)(@modifier)
226;; language: ISO 639-1 or ISO 639-2
227;;   script: RFC 3066bis
228;;   region: ISO 3166-1
229;;  codeset:
230;; modifier:
231
232(define parse-posix-literal-locale
233        (let ((locale-re (regexp "([a-zA-Z]+)(-[a-zA-Z]+)?(_[a-zA-Z]+)?(\\.[^@]+)?(@.+)?")))
234                (lambda (lc str)
235                  (let ((matched-len 0))
236        (and-let* ((r (string-match locale-re str)))
237          (let ((l (cadr r))
238                (s (caddr r))
239                (t (cadddr r))
240                (c (car (cddddr r)))
241                (m (cadr (cddddr r)))
242                (inc-matched-len
243                  (lambda (v)
244                    (set! matched-len (+ matched-len (string-length v))))))
245            (when l
246              (inc-matched-len l)
247              (set-locale-component! lc 'language (string-downcase l)))
248            (when s
249              (inc-matched-len s)
250              (set-locale-component! lc 'script (string-titlecase (substring s 1))))
251            (when t
252              (inc-matched-len t)
253              (set-locale-component! lc 'region (string-upcase (substring t 1))))
254            (when c
255              (inc-matched-len c)
256              (set-locale-component! lc 'codeset (substring c 1)))
257            (when m
258              (inc-matched-len m)
259              (set-locale-component! lc 'modifier (substring m 1)))
260            (and (= matched-len (string-length str))
261                 lc ) ) ) ) ) ) )
262
263;;
264
265#| ;NOT YET
266(cond-expand
267  (macosx
268    (define *system-locale-directory* "/usr/share/locale") )
269  (else
270    (define *system-locale-directory* #f) ) )
271
272(define (parse-posix-localefile lc pn)
273  (warning "cannot understand Posix pathname locale" pn)
274  #f )
275
276(define (parse-posix-pathname-locale lc str)
277  (let ((pn (if (string-prefix? "/" str) str (make-pathname *system-locale-directory* str))))
278    (if (file-exists? pn) (parse-posix-localefile lc pn)
279        #f ) ) )
280|#
281
282;;
283
284(define (posix-locale-string->locale-components str . args)
285  (let-optionals args ((src "POSIX") (tag 'locale))
286    (let ((lc (make-locale-components str src tag)))
287      (cond ((or (string=? str "C") (string=? str "POSIX"))
288             ;FIXME - #f so BUILTIN source used but ...
289             #f )
290            (else
291             (parse-posix-literal-locale lc str) ) ) ) ) )
292
293;;; The POSIX/GNU locale categories
294
295(define *posix-locale-category-names*
296        '(("LC_COLLATE" . collate)
297                ("LC_CTYPE" . character)
298                ("LC_MESSAGES" . messages)
299                ("LC_MONETARY" . monetary)
300                ("LC_NUMERIC" . numberic)
301                ("LC_ADDRESS" . address)
302                ("LC_IDENTIFICATION" . identification)
303                ("LC_MEASUREMENT" . measurement)
304                ("LC_NAME" . name)
305                ("LC_PAPER" . paper)
306                ("LC_TELEPHONE" . telephone)
307                ("LC_TIME" . time)) )
308
309(define (set-posix-locale-categories func)
310  (for-each
311   (lambda (cell)
312     (let ((cat (cdr cell)))
313       (cond ((func (car cell) cat) => (cute set-locale-category! cat <>))) ) )
314   *posix-locale-category-names*) )
315
316;;
317
318(define (gnu-language-string->locale-components str . args)
319  (let-optionals args ((src "GNU") (tag 'language))
320    (let* ((lc (make-locale-components str src tag))
321           (lang (string-upcase (locale-component-ref lc 'language))))
322      (update-locale-components! lc 'locales
323       (map
324        (lambda (str)
325          (let ((rlc (posix-locale-string->locale-components str src)))
326            (set-locale-component! rlc 'region lang)
327            rlc ) )
328        (string-split str ":")))
329      lc ) ) )
330
331;;;
332
333;; Sets the current timezone posix style
334
335(define (posix-load-timezone)
336  (and-let* ((str (nonnull-getenv "TZ")))
337    (set-locale-category! 'timezone
338     (posix-timezone-string->timezone-components str (list "POSIX" "TZ"))) ) )
339
340;; Create all local category values from the environment
341
342(define (posix-load-locale)
343        (let ((str (nonnull-getenv "LC_ALL")))
344                (if str
345        ; Then LC_ALL overrides
346        (let ((lc (posix-locale-string->locale-components str '("POSIX" "LC_ALL"))))
347          (set-posix-locale-categories (lambda (e c) lc)) )
348        ; Else set individually, w/ LANG as default
349        (let* ((str (nonnull-getenv "LANG"))
350               (lc (and str (posix-locale-string->locale-components str '("POSIX" "LANG")))))
351          (set-posix-locale-categories
352           (lambda (e c)
353             (cond ((nonnull-getenv e)
354                    => (cut posix-locale-string->locale-components <> `("POSIX" ,e)))
355                   (else lc)))) ) ) ) )
356
357;; GNU LANGUAGE (PATH-sytle list of LANG)
358
359(define (gnu-load-locale)
360  (and-let* ((str (nonnull-getenv "LANGUAGE")))
361    (let ((lc (gnu-language-string->locale-components str '("GNU" "LANGUAGE") 'language)))
362      (set-locale-category! 'language lc) ) ) )
363
364) ;module locale-posix
Note: See TracBrowser for help on using the repository browser.