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

Last change on this file since 35426 was 35426, checked in by kon, 7 months ago

add ±[0-9]+ as std-time name (but not dst-name), any name pattern match is name, add test, reflow

File size: 15.6 KB
Line 
1;;;; locale-posix.scm
2;;; Kon Lovett, Dec '05
3
4;; Issues
5;;
6;; - #f is generated for any parse problems.
7;;
8;; - Does not interact w/ setlocale or tzset
9;;
10;; - If LC_ALL or LANG is not set but any LC_* is set then (current-locale)
11;; will still be #f, while some locale-categories will be valued
12
13(module locale-posix
14
15(;export
16  ;
17  seconds->h:m:s-string
18  ;
19  make-posix-timezone
20  ;
21  posix-timezone-string->timezone-components
22  posix-locale-string->locale-components
23  gnu-language-string->locale-components
24  ;
25  posix-load-timezone
26  posix-load-locale
27  gnu-load-locale)
28
29(import chicken scheme)
30(use
31  srfi-1 srfi-13 regex data-structures files
32  locale-categories locale-components)
33
34;;;
35
36;;fx-utils
37
38(: fxnegative? (fixnum --> boolean))
39;
40(define (fxnegative? n)
41  (fx> 0 n) )
42
43(: fxabs (fixnum --> fixnum))
44;
45(define (fxabs n)
46  (if (fxnegative? n) (fxneg n) n) )
47
48;;
49
50(define-type locale-components list)
51
52;;
53
54(define-constant SEC/HR   3600)
55(define-constant SEC/MIN  60)
56
57;;
58
59(define (nonnull-getenv varnam)
60  (let (
61    (str (get-environment-variable varnam)) )
62    (and
63      (string? str) (not (string-null? str))
64      str ) ) )
65
66;;; Utility
67
68(define (seconds->h:m:s-string secs)
69  (let* (
70    (asecs (fxabs secs))
71    (rsecs (fxmod asecs SEC/HR)) )
72    (conc
73      (if (fxnegative? secs) #\- #\+) (fx/ asecs SEC/HR)
74      #\: (fx/ rsecs SEC/MIN)
75      #\: (fxmod rsecs SEC/MIN)) ) )
76
77(define (make-posix-timezone dst-tzn dst-off std-tzn std-off)
78  (string-append
79    dst-tzn (seconds->h:m:s-string dst-off)
80    std-tzn (seconds->h:m:s-string std-off)) )
81
82;;; Timezone
83
84;; Splits an IEEEÊStdÊ1003.1-2001 TZ specifier string into components.
85;;
86;; Returns a timezone components object or #f, indicating a parse error.
87;;
88;; - doesn't handle implementation defined entries
89;;
90;; - cannot differentiate a relative timezone filename that is a valid
91;; timezone specifier
92
93(define parse-posix-literal-timezone
94  (let (
95    (ext-name-re (regexp "(^[+-][0-9]+)|(^[^<:0-9,+-][^0-9,+-]*)|^<([^>]+)>"))
96    (int-name-re (regexp "(^[^<:0-9,+-][^0-9,+-]*)|^<([^>]+)>"))
97    (offset-re (regexp "^(\\+|-)?([0-9]+)(:[0-9]+)?(:[0-9]+)?"))
98    ;For compatibility with System V Release 3.1, a semicolon (`;') may be
99    ;used to separate the rule from the rest of the specification.
100    ;Allow it to separate the "to DST" & "from DST" segments since no harm, no foul.
101    (date-re (regexp "^[;,]([JM])?([0-9]+)(\\.[0-9]+)?(\\.[0-9]+)?"))
102    (time-re (regexp "^/([0-9]+)(:[0-9]+)?(:[0-9]+)?"))
103    (+0200hrs+ (fx* 2 SEC/HR)) )
104    ;
105    (lambda (tz str)
106      (let (
107        (strpos 0)
108        (strend (string-length str)) )
109        ;
110        (letrec (
111          ;
112          (fail
113            (lambda (msg)
114              (error 'parse-posix-literal-timezone msg str) ) )
115          ;
116          (next-match
117            (lambda (re)
118              (and-let* (
119                (ml (string-search re str strpos)) )
120                (set! strpos (fx+ strpos (string-length (car ml))))
121                ml ) ) )
122          ;
123          (all-parsed
124            (lambda ()
125              (or
126                (<= strend strpos)
127                (fail "bad timezone format") ) ) )
128          ;
129          (parse-number
130            (lambda (numstr)
131              (cond
132                ((not numstr)
133                  0 )
134                ((char-numeric? (string-ref numstr 0))
135                  (string->number numstr) )
136                (else
137                  (fail "bad timezone number") ) ) ) )
138          ;
139          (parse-delmcomp
140            (lambda (numstr delm)
141              (parse-number
142                (if (not (and numstr (string-prefix? delm numstr)))
143                  numstr
144                  (string-trim numstr (string-ref delm 0)) ) ) ) )
145          ;
146          (parse-timecomp
147            (lambda (numstr)
148              (parse-delmcomp numstr ":")) )
149          ;
150          (parse-daterulecomp
151            (lambda (numstr)
152              (parse-delmcomp numstr ".")) )
153          ;
154          (hms->offset
155            (lambda (sgnstr hms-lst)
156              (and-let* (
157                (hr (parse-number (car hms-lst)))
158                (mn (parse-timecomp (cadr hms-lst)))
159                (sc (parse-timecomp (caddr hms-lst))) )
160                (let (
161                  (secs (fx+ (fx* hr SEC/HR) (fx+ (fx* mn SEC/MIN) sc))) )
162                  (if (and sgnstr (string=? sgnstr "-"))
163                    (fxneg secs)
164                    secs)) ) ) )
165          ;
166          (decode-dst-rule
167            (lambda (rulstr dat-lst off)
168              ;Must begin w/ a valid integer. Interpreted later.
169              (and-let* (
170                (n1 (parse-number (car dat-lst))) )
171                (cond
172                  ((not rulstr) ;Julian Leap rule
173                    (make-timezone-dst-rule-julian-leap n1 off) )
174                  ;select rule kind & interpret rest of match
175                  (else
176                    (case (string-ref rulstr 0)
177                      ((#\J)  ;Julian No-Leap rule
178                        (make-timezone-dst-rule-julian-noleap n1 off) )
179                      ((#\M)  ;Date
180                        (and-let* (
181                          (n (parse-daterulecomp (cadr dat-lst)))
182                          (d (parse-daterulecomp (caddr dat-lst))) )
183                          (make-timezone-dst-rule-mwd n1 n d off) ) )
184                      (else
185                        (fail "unknown timezone DST rule type") ) ) ) ) ) ) )
186          ;
187          (parse-dst-rule
188            (lambda (key)
189              (and-let* (
190                (d-m (next-match date-re)) )
191                ;Time component is optional & defaults to 02:00:00
192                (let* (
193                  (t-m
194                    (next-match time-re))
195                  (off
196                    (if t-m
197                      (hms->offset #f (cdr t-m))
198                      +0200hrs+)) )
199                  (set-timezone-component!
200                    tz
201                    key (decode-dst-rule (cadr d-m) (cddr d-m) off))
202                  #t ) ) ) )
203          ;
204          (dst-parse
205            (lambda ()
206              ;DST section is optional
207              (let (
208                (n-m (next-match int-name-re)) )
209                (or
210                  (not n-m)
211                  ;Offset is optional & defaults to 1hr
212                  (let* (
213                    (o-m (next-match offset-re))
214                    (off
215                      (if o-m
216                        (hms->offset (cadr o-m) (cddr o-m))
217                        (fx- (timezone-component-ref tz 'std-offset) SEC/HR)
218                        #; ;XXX What does "ahead" mean?
219                        (fx+ (timezone-component-ref tz 'std-offset) SEC/HR))) )
220                    (set-timezone-component! tz 'dst-name (car n-m))
221                    (set-timezone-component! tz 'dst-offset off)
222                    ;Rule, if present, must be complete
223                    (if (parse-dst-rule 'dst-start)
224                      (parse-dst-rule 'dst-end)
225                      #t ) ) ) ) ) )
226          ;
227          (std-parse
228            (lambda ()
229              ;Must have name & offset components
230              (let (
231                (n-m (next-match ext-name-re)) )
232                (cond
233                  ((not n-m)
234                    (fail "bad timezone STD name") )
235                  (else
236                    (let (
237                      (o-m (next-match offset-re)) )
238                      (cond
239                        ((not o-m)
240                          (fail "bad timezone STD offset") )
241                        (else
242                          (set-timezone-component! tz 'std-name (car n-m))
243                          (set-timezone-component! tz 'std-offset (hms->offset (cadr o-m) (cddr o-m)))
244                          #t ) ) ) ) ) ) ) ) )
245          ;
246          ;walk the match set
247          (cond
248            ((string-null? str)
249              (fail "empty timezone") )
250            (else
251              (and
252                (std-parse)   ;required
253                (dst-parse)   ;optional
254                (all-parsed)  ;must have successfully scanned entire string
255                ;then valid timezone info
256                tz ) ) ) ) ) ) ) )
257
258;;
259
260#| ;NOT YET
261(cond-expand
262  (macosx
263    (define *system-timezone-directory* "/usr/share/zoneinfo") )
264  (else
265    (define *system-timezone-directory* #f) ) )
266
267(define (parse-posix-tzfile tz pn)
268  (warning "cannot understand Posix pathname timezone" pn)
269  #f )
270
271(define (parse-posix-pathname-timezone tz str)
272  (let ((pn (if (string-prefix? "/" str) str (make-pathname *system-timezone-directory* str))))
273    (if (file-exists? pn)
274      (parse-posix-tzfile tz pn)
275      #f ) ) )
276|#
277
278(define (parse-posix-implementation-defined-timezone tz str)
279  (warning "cannot understand Posix implementation-defined timezone" str)
280  #f
281  #; ;NOT YET
282  (or
283    (parse-posix-pathname-timezone tz (substring str 1))
284    (begin
285      (warning "cannot understand Posix implementation-defined timezone" str)
286      #f ) ) )
287
288;;
289
290(define (posix-timezone-string->timezone-components str . src)
291  (let (
292    (tz (make-timezone-components str (optional src "POSIX"))) )
293    (cond
294      ((and (string? str) (string-prefix? ":" str))
295        (parse-posix-implementation-defined-timezone tz str) )
296      ((or (not (string? str)) (string-null? str))
297        #f )
298      (else
299        (parse-posix-literal-timezone tz str) ) ) ) )
300
301;;; Locale
302
303;; Splits an IEEEÊStdÊ1003.1-2001 locale specifier string into
304;; string components. The standard is extended to support a RFC 3066bis
305;; Script specifier.
306;;
307;; Returns a locale-components object or #f, indicating a parse error.
308;;
309;;     name: language(-script)(_country)(-subdivision)(.codeset)(@modifier)
310;; language: ISO 639-1 or ISO 639-2
311;;   script: RFC 3066bis
312;;   region: ISO 3166-1 or ISO 3166-2 (territory in IEEE Std 1003.1-2001)
313;;           country & subdivision
314;;  codeset:
315;; modifier:
316
317(define-constant POSIX-LOCALE-REGEX
318  "([a-zA-Z]+)(-[a-zA-Z]+)?(_[a-zA-Z]+)?(-[a-zA-Z0-9]+)?(\\.[^@]+)?(@.+)?")
319
320(: parse-posix-literal-locale (locale-components string -> (or boolean locale-components)))
321;
322(define parse-posix-literal-locale
323  (let (
324    (locale-re (regexp POSIX-LOCALE-REGEX)) )
325    (lambda (lc str)
326      (let (
327        (matched-len 0) )
328        (and-let* (
329          (r (string-match locale-re str)) )
330          (let (
331            (language (cadr r))
332            (script (caddr r))
333            (country (cadddr r))
334            (subdivision (car (cddddr r)))
335            (codeset (cadr (cddddr r)))
336            (modifier (caddr (cddddr r)))
337            (inc-matched-len
338              (lambda (v)
339                (set! matched-len (fx+ matched-len (string-length v))) ) ) )
340            (when language
341              (inc-matched-len language)
342              (set-locale-component! lc 'language (string-downcase language)) )
343            (when script
344              (inc-matched-len script)
345              (set-locale-component! lc 'script (string-titlecase (substring script 1))) )
346            (when country
347              (inc-matched-len country)
348              (set-locale-component! lc 'country (string-upcase (substring country 1))) )
349            (when subdivision
350              (inc-matched-len subdivision)
351              (set-locale-component! lc 'subdivision (string-upcase (substring subdivision 1))) )
352            (when codeset
353              (inc-matched-len codeset)
354              (set-locale-component! lc 'codeset (substring codeset 1)) )
355            (when modifier
356              (inc-matched-len modifier)
357              (set-locale-component! lc 'modifier (substring modifier 1)) )
358            ;Synthetic component
359            (when country
360              (set-locale-component! lc 'region
361                (string-append
362                  (or (locale-component-ref lc 'country) "")
363                  (let (
364                    (str (locale-component-ref lc 'subdivision)) )
365                    (if str (string-append "-" str) "")))) )
366            ;Must be at the end of string
367            (and
368              (fx= matched-len (string-length str))
369              lc ) ) ) ) ) ) )
370
371;;
372
373#| ;NOT YET
374(cond-expand
375  (macosx
376    (define *system-locale-directory* "/usr/share/locale") )
377  (else
378    (define *system-locale-directory* #f) ) )
379
380(define (parse-posix-localefile lc pn)
381  (warning "cannot understand Posix pathname locale" pn)
382  #f )
383
384(define (parse-posix-pathname-locale lc str)
385  (let (
386    (pn
387      (if (string-prefix? "/" str)
388        str
389        (make-pathname *system-locale-directory* str))) )
390    (if (file-exists? pn)
391      (parse-posix-localefile lc pn)
392      #f ) ) )
393|#
394
395;;
396
397(define (posix-locale-string->locale-components str . args)
398  (let-optionals args (
399    (src "POSIX")
400    (tag 'locale) )
401    (let (
402      (lc (make-locale-components str src tag)) )
403      (cond
404        ((or (not (string? str)) (string-null? str))
405          #f )
406        ((or (string=? str "C") (string=? str "POSIX"))
407          ;FIXME - #f so BUILTIN source used but ...
408          #f )
409        (else
410          (parse-posix-literal-locale lc str) ) ) ) ) )
411
412;;; The POSIX/GNU locale categories
413
414(define *posix-locale-category-names*
415  '(("LC_COLLATE" . collate)
416    ("LC_CTYPE" . character)
417    ("LC_MESSAGES" . messages)
418    ("LC_MONETARY" . monetary)
419    ("LC_NUMERIC" . numberic)
420    ("LC_ADDRESS" . address)
421    ("LC_IDENTIFICATION" . identification)
422    ("LC_MEASUREMENT" . measurement)
423    ("LC_NAME" . name)
424    ("LC_PAPER" . paper)
425    ("LC_TELEPHONE" . telephone)
426    ("LC_TIME" . time)) )
427
428(define (set-posix-locale-categories func)
429  (for-each
430    (lambda (cell)
431      (let (
432        (cat (cdr cell)) )
433        (cond
434          ((func (car cell) cat)
435            => (cut set-locale-category! cat <>))) ) )
436   *posix-locale-category-names*) )
437
438;;
439
440(define (gnu-language-string->locale-components str . args)
441  (and
442    (string? str)
443    (not (string-null? str))
444    (let-optionals args (
445      (src "GNU")
446      (tag 'language) )
447      (let (
448        (lc (make-locale-components str src tag)) )
449        (update-locale-components! lc 'locales
450          ;Keep in priority order
451          (reverse!
452            (fold
453              ;May not have a 'country or 'region. Should use locale's?
454              (lambda (str ls)
455              ;Ignore when no parse
456              (let ((lc (posix-locale-string->locale-components str src)))
457              (if lc (cons lc ls) ls) ) )
458              '()
459              (string-split str ":")))) ) ) ) )
460
461;;;
462
463;; Sets the current timezone posix style
464
465(define (posix-load-timezone)
466  (and-let* (
467    (str (nonnull-getenv "TZ")) )
468    (set-locale-category!
469      'timezone
470      (posix-timezone-string->timezone-components
471        str
472        (list "POSIX" "TZ"))) ) )
473
474;; Create all local category values from the environment
475
476(define (posix-load-locale)
477  (let (
478    (str (nonnull-getenv "LC_ALL")) )
479    (if str
480      ;then LC_ALL overrides
481      (let (
482        (lc (posix-locale-string->locale-components str '("POSIX" "LC_ALL"))) )
483        (set-locale-category! 'current lc)
484        (set-posix-locale-categories (lambda (e c) lc)) )
485      ;else set individually, w/ LANG as default
486      (let (
487        (str (nonnull-getenv "LANG")) )
488        (when str
489          (let (
490            (lc (posix-locale-string->locale-components str '("POSIX" "LANG"))) )
491            (set-locale-category! 'current lc)
492            (set-posix-locale-categories
493              (lambda (e c)
494                (cond
495                  ((nonnull-getenv e)
496                    => (cut posix-locale-string->locale-components <> `("POSIX" ,e)))
497                  (else
498                    lc)))) ) ) ) ) ) )
499
500;; GNU LANGUAGE (PATH-sytle list of LANG)
501
502(define (gnu-load-locale)
503  (and-let* (
504    (str (nonnull-getenv "LANGUAGE")) )
505    (let (
506      (lc (gnu-language-string->locale-components str '("GNU" "LANGUAGE") 'language)) )
507      (set-locale-category! 'language lc) ) ) )
508
509) ;module locale-posix
Note: See TracBrowser for help on using the repository browser.