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

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

Save

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