source: project/release/3/locale/trunk/locale.scm @ 13860

Last change on this file since 13860 was 13860, checked in by Kon Lovett, 12 years ago

Save. Mvd params into locale.scm

File size: 3.8 KB
Line 
1;;;; locale.scm
2;;;; Kon Lovett, May '06
3
4;; Issues
5;;
6;; - Only Posix for now.
7
8(declare
9  (usual-integrations)
10  (fixnum)
11  (inline)
12  (no-procedure-checks)
13  (export
14    UNKNOWN-LOCAL-TZ-NAME
15    BUILTIN-SOURCE
16    current-timezone
17    current-locale
18    current-timezone-components
19    current-locale-components) )
20
21(require-extension posix miscmacros locale-posix locale-components locale-categories locale-errors)
22
23;;;
24
25(define (check-string-or-false loc obj)
26  (unless (or (not obj) (string? obj))
27    (type-error loc "string or #f" obj) ) )
28
29;;
30
31(define (current-timezone . args)
32  (cond ((null? args)
33          (and-let* ((lc (locale-category-ref 'timezone)))
34            (locale-component-ref lc 'name) ) )
35        (else
36          (let-optionals args ((str #f) (src "USER"))
37            (check-string-or-false 'current-timezone str)
38            (let ((lc (and str (posix-timezone-string->locale-components str src))))
39              (set-locale-category! 'timezone lc) ) ) ) ) )
40
41;; A'la MzScheme
42;; Treat locale as messages category
43
44(define (current-locale . args)
45  (cond ((null? args)
46          (and-let* ((lc (locale-category-ref 'messages)))
47            (locale-component-ref lc 'name) ) )
48        (else
49          (let-optionals args ((str #f) (src "USER"))
50            (check-string-or-false 'current-locale str)
51            (let ((lc (and str (posix-locale-string->locale-components str src))))
52              (set-locale-category! 'messages lc) ) ) ) ) )
53
54;;
55
56(define (current-timezone-components) (locale-category-ref 'timezone))
57
58(define (current-locale-components) (locale-category-ref 'messages))
59
60;;; When no environment info use Plan B
61
62(define BUILTIN-SOURCE "BUILTIN")
63(define UNKNOWN-LOCAL-TZ-NAME "XXXX")
64
65;; Builtin Timezone
66
67;; Daylight saving time offset from standard offset.
68;; ("spring forward" add it, "fall back" subtract it)
69
70(define-constant DEFAULT-DST-OFFSET 3600)
71
72(define (local-timezone-name) (or (local-timezone-abbreviation) UNKNOWN-LOCAL-TZ-NAME))
73
74(define (make-builtin-timezone)
75  ; Need local timezone info
76  (let* ((tv (seconds->local-time (current-seconds)))
77         (dstf (vector-ref tv 8))
78         (tzn (local-timezone-name)) )
79    (cond-expand
80      (macosx
81        ; Since the tzo reflects the dst status need to fake the one not in effect.
82        (let ((tzo (vector-ref tv 9)))
83          (if dstf
84              (make-posix-timezone UNKNOWN-LOCAL-TZ-NAME (+ tzo DEFAULT-DST-OFFSET) tzn tzo)
85              (make-posix-timezone tzn tzo UNKNOWN-LOCAL-TZ-NAME (- tzo DEFAULT-DST-OFFSET)) ) ) )
86      (else
87        ; Since only the standard tzn & tzo are available need to
88        ; fake summer time.
89        (let ((tzo (vector-ref tv 9)))
90          (make-posix-timezone tzn tzo UNKNOWN-LOCAL-TZ-NAME (- tzo DEFAULT-DST-OFFSET)) ) ) ) ) )
91
92(define (use-builtin-timezone)
93  (current-timezone (make-builtin-timezone) BUILTIN-SOURCE) )
94
95;; Builtin Locale
96
97(define-constant DEFAULT-LANGUAGE "en")
98(define-constant DEFAULT-REGION "US")
99
100(define (make-builtin-locale-string)
101  (string-append DEFAULT-LANGUAGE "_" DEFAULT-REGION) )
102
103(define (use-builtin-locale)
104  (current-locale (make-builtin-locale-string) BUILTIN-SOURCE) )
105
106;; Builtin Language List
107
108(define (use-builtin-language)
109  (and-let* ((msglc (locale-category-ref 'messages)))
110    (let ((lc (make-locale-components (locale-component-ref msglc 'name) BUILTIN-SOURCE 'language)))
111      (update-locale-components! lc 'locales (list msglc))
112      (set-locale-category! 'language lc) ) ) )
113
114;;;
115;;; Module Init
116;;;
117
118;; Use posix locale system, for now
119
120(posix-load-timezone)
121(posix-load-locale)
122(gnu-load-locale)
123
124;; Need the current-timezone-components, and unless we
125;; have a current-timezone need to fake one from system
126;; time info.
127
128(unless (current-timezone) (use-builtin-timezone))
129
130(unless (current-locale) (use-builtin-locale))
131
132(unless (locale-category-ref 'language) (use-builtin-language))
Note: See TracBrowser for help on using the repository browser.