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

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

Parse errors are now failures. Added type checking for components. Made posix tz name be almost anything.

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 "(^[^<:][^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                                      ;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) (fail "bad timezone STD name") )
163                        (else
164                          (let ((o-m (next-match offset-re)))
165                            (cond ((not o-m) (fail "bad 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) (fail "empty 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 ((and (string? str) (string-prefix? ":" str))
212            (parse-posix-implementation-defined-timezone tz str) )
213          ((or (not (string? str)) (string=? "" str))
214            #f )
215          (else
216            (parse-posix-literal-timezone tz str) ) ) ) )
217
218;;; Locale
219
220;; Splits an IEEEÊStdÊ1003.1-2001 locale specifier string into
221;; string components. The standard is extended to support a RFC 3066bis
222;; Script specifier.
223;;
224;; Returns a locale-components object or #f, indicating a parse error.
225;;
226;;     name: language(-script)(_territory)(.codeset)(@modifier)
227;; language: ISO 639-1 or ISO 639-2
228;;   script: RFC 3066bis
229;;   region: ISO 3166-1
230;;  codeset:
231;; modifier:
232
233(define parse-posix-literal-locale
234        (let ((locale-re (regexp "([a-zA-Z]+)(-[a-zA-Z]+)?(_[a-zA-Z]+)?(\\.[^@]+)?(@.+)?")))
235                (lambda (lc str)
236                  (let ((matched-len 0))
237        (and-let* ((r (string-match locale-re str)))
238          (let ((l (cadr r))
239                (s (caddr r))
240                (t (cadddr r))
241                (c (car (cddddr r)))
242                (m (cadr (cddddr r)))
243                (inc-matched-len
244                  (lambda (v)
245                    (set! matched-len (+ matched-len (string-length v))))))
246            (when l
247              (inc-matched-len l)
248              (set-locale-component! lc 'language (string-downcase l)))
249            (when s
250              (inc-matched-len s)
251              (set-locale-component! lc 'script (string-titlecase (substring s 1))))
252            (when t
253              (inc-matched-len t)
254              (set-locale-component! lc 'region (string-upcase (substring t 1))))
255            (when c
256              (inc-matched-len c)
257              (set-locale-component! lc 'codeset (substring c 1)))
258            (when m
259              (inc-matched-len m)
260              (set-locale-component! lc 'modifier (substring m 1)))
261            (and (= matched-len (string-length str))
262                 lc ) ) ) ) ) ) )
263
264;;
265
266#| ;NOT YET
267(cond-expand
268  (macosx
269    (define *system-locale-directory* "/usr/share/locale") )
270  (else
271    (define *system-locale-directory* #f) ) )
272
273(define (parse-posix-localefile lc pn)
274  (warning "cannot understand Posix pathname locale" pn)
275  #f )
276
277(define (parse-posix-pathname-locale lc str)
278  (let ((pn (if (string-prefix? "/" str) str (make-pathname *system-locale-directory* str))))
279    (if (file-exists? pn) (parse-posix-localefile lc pn)
280        #f ) ) )
281|#
282
283;;
284
285(define (posix-locale-string->locale-components str . args)
286  (let-optionals args ((src "POSIX") (tag 'locale))
287    (let ((lc (make-locale-components str src tag)))
288      (cond ((or (not (string? str)) (string=? "" str))
289              #f )
290            ((or (string=? str "C") (string=? str "POSIX"))
291              ;FIXME - #f so BUILTIN source used but ...
292              #f )
293            (else
294              (parse-posix-literal-locale lc str) ) ) ) ) )
295
296;;; The POSIX/GNU locale categories
297
298(define *posix-locale-category-names*
299        '(("LC_COLLATE" . collate)
300                ("LC_CTYPE" . character)
301                ("LC_MESSAGES" . messages)
302                ("LC_MONETARY" . monetary)
303                ("LC_NUMERIC" . numberic)
304                ("LC_ADDRESS" . address)
305                ("LC_IDENTIFICATION" . identification)
306                ("LC_MEASUREMENT" . measurement)
307                ("LC_NAME" . name)
308                ("LC_PAPER" . paper)
309                ("LC_TELEPHONE" . telephone)
310                ("LC_TIME" . time)) )
311
312(define (set-posix-locale-categories func)
313  (for-each
314   (lambda (cell)
315     (let ((cat (cdr cell)))
316       (cond ((func (car cell) cat) => (cute set-locale-category! cat <>))) ) )
317   *posix-locale-category-names*) )
318
319;;
320
321(define (gnu-language-string->locale-components str . args)
322  (and (string? str)
323       (not (string=? "" str))
324       (let-optionals args ((src "GNU") (tag 'language))
325         (let* ((lc (make-locale-components str src tag))
326                (lang (string-upcase (locale-component-ref lc 'language))))
327           (update-locale-components! lc 'locales
328            (map
329             (lambda (str)
330               (let ((rlc (posix-locale-string->locale-components str src)))
331                 (set-locale-component! rlc 'region lang)
332                 rlc ) )
333             (string-split str ":")))
334           lc ) ) ) )
335
336;;;
337
338;; Sets the current timezone posix style
339
340(define (posix-load-timezone)
341  (and-let* ((str (nonnull-getenv "TZ")))
342    (set-locale-category! 'timezone
343     (posix-timezone-string->timezone-components str (list "POSIX" "TZ"))) ) )
344
345;; Create all local category values from the environment
346
347(define (posix-load-locale)
348        (let ((str (nonnull-getenv "LC_ALL")))
349                (if str
350        ; Then LC_ALL overrides
351        (let ((lc (posix-locale-string->locale-components str '("POSIX" "LC_ALL"))))
352          (set-posix-locale-categories (lambda (e c) lc)) )
353        ; Else set individually, w/ LANG as default
354        (let* ((str (nonnull-getenv "LANG"))
355               (lc (and str (posix-locale-string->locale-components str '("POSIX" "LANG")))))
356          (set-posix-locale-categories
357           (lambda (e c)
358             (cond ((nonnull-getenv e)
359                    => (cut posix-locale-string->locale-components <> `("POSIX" ,e)))
360                   (else lc)))) ) ) ) )
361
362;; GNU LANGUAGE (PATH-sytle list of LANG)
363
364(define (gnu-load-locale)
365  (and-let* ((str (nonnull-getenv "LANGUAGE")))
366    (let ((lc (gnu-language-string->locale-components str '("GNU" "LANGUAGE") 'language)))
367      (set-locale-category! 'language lc) ) ) )
368
369) ;module locale-posix
Note: See TracBrowser for help on using the repository browser.