source: project/release/4/locale/trunk/locale-timezone.scm @ 23540

Last change on this file since 23540 was 23540, checked in by kon, 8 years ago

Use 'current locale category for primary locale, rather than 'messages. locale-timezone has proc for offset & name.

File size: 5.0 KB
Line 
1;;;; locale-timezone.scm
2;;;; From "dateutils.scm" by Graham Fawcett
3
4(module locale-timezone
5
6  (;export
7    local-timezone-name
8    local-timezone-offset
9    local-timezone-name+offset
10    with-tzset
11    ;Deprecated
12    local-timezone)
13
14  (import
15    scheme chicken foreign
16    (only posix
17      time->string seconds->local-time local-time->seconds
18      setenv unsetenv)
19    (only type-checks
20      check-minimum-argument-count check-argument-count
21      check-fixnum)
22    (only type-errors
23      error-argument-count
24      error-keyword error-argument-type))
25
26  (require-library posix type-checks type-errors)
27
28;;;
29
30(define-syntax check-fixnums
31  (syntax-rules ()
32    ((_ ?loc ?nam0 ...)
33      (for-each
34        (lambda (x) (check-fixnum ?loc (car x) (cadr x)))
35        (list (list ?nam0 '?nam0) ...)) ) ) )
36
37(define-syntax check-closed-intervals
38  (syntax-rules (<=)
39    ((_ ?loc (<= ?low0 ?nam0 ?hgh0) ...)
40      (for-each
41        (lambda (x)
42          (unless (<= (caddr x) (car x) (cadddr x))
43            (error ?loc
44              (string-append "bad argument " (symbol->string (cadr x)) " type - out of range")
45              (car x) (caddr x) (cadddr x)) ) )
46        (list (list ?nam0 '?nam0 ?low0 ?hgh0) ...)) ) ) )
47
48;;;
49
50(define (get-tz tv)
51  ;Note that the tz-off should be in the tv!
52  (let* ((tz (time->string (seconds->local-time (local-time->seconds tv)) "%z %Z"))
53         (1stch (string-ref tz 0))
54         (neg? (char=? #\- 1stch))
55         (start (if (or neg? (char=? #\+ 1stch)) 1 0))
56         (end (+ start 2))
57         (secs (+ (* (string->number (substring tz start end)) 3600)
58                  (* (string->number (substring tz end (+ end 2))) 60))) )
59    (values (if neg? (- secs) secs) (substring tz (+ start 5))) ) )
60
61;#!required tv | yr mo dy #!optional (hr 12) (mn 0) (sc 0) #!key dst?
62(define (*local-tz-info loc . args)
63
64  (let ((argcnt (length args))
65        (yr #f) (mo #f) (dy #f) (hr #f) (mn #f) (sc #f) (dst? #f))
66
67    (define (kwdarg kwd rest)
68      (cond
69        ((eq? #:dst? kwd) (set! dst? (cadr rest)) )
70        (else (error-argument-type loc "keyword #:dst?" kwd) ) ) )
71
72    ; DSSSL lambda list parsing behavior as I wish it was
73    (check-minimum-argument-count loc argcnt 1)
74    (if (vector? (car args))
75        ;then time-vector is argument
76        ;kwd dst? overrides vector elm
77        (let ((tv (car args)))
78          (when (< (vector-length tv) 10) 
79            (error-argument-type loc tv "ten element time vector") )
80          (set! dst? (vector-ref tv 8))
81          (set! yr (+ (vector-ref tv 5) 1900))
82          (set! mo (vector-ref tv 4))
83          (set! dy (vector-ref tv 3))
84          (set! hr (vector-ref tv 2))
85          (set! mn (vector-ref tv 1))
86          (set! sc (vector-ref tv 0))
87          (let loop ((args (cdr args)))
88            (unless (null? args)
89              (let ((arg (car args)))
90                (cond
91                  ((keyword? arg)
92                    (kwdarg arg args)
93                    (loop (cddr args)) )
94                  (else
95                    (error-keyword loc arg) ) ) ) ) ) )
96        ;else atomic time elements
97        (begin
98          (check-minimum-argument-count loc argcnt 3)
99          (set! yr (car args))
100          (set! mo (cadr args))
101          (set! dy (caddr args))
102          (let loop ((args (cdddr args)))
103            (if (null? args)
104                (begin
105                  (unless hr (set! hr 12))
106                  (unless mn (set! mn 0))
107                  (unless sc (set! sc 0)))
108                (let ((arg (car args)))
109                  (cond
110                    ((keyword? arg)
111                      (kwdarg arg args)
112                      (loop (cddr args)) )
113                    ((and hr mn sc)
114                      (error-argument-count loc argcnt 8) )
115                    (else
116                      (if hr (if mn (set! sc arg) (set! mn arg)) (set! hr arg))
117                      (loop (cdr args)) ) ) ) ) ) ) )
118
119    (check-fixnums loc yr mo dy hr mn sc)
120    (check-closed-intervals loc
121      (<= 0 sc 60)
122      (<= 0 mn 59)
123      (<= 0 hr 23)
124      (<= 1 dy 31)
125      (<= 0 mo 11))
126
127    (get-tz (vector sc mn hr dy mo (- yr 1900) 0 0 dst? 0)) ) )
128
129;;;
130
131;; Return the timezone for the given date as a string, (e.g. "EST").
132
133(define (local-timezone-name . args)
134  (let-values (((tzo tzn) (apply *local-tz-info 'local-timezone-name args)))
135    tzn ) )
136
137(define local-timezone local-timezone-name)
138
139;; Return the timezone offset as seconds where positive is east of UTC &
140;; negative is west of UTC. RFC-822 format (e.g. "-0500").
141
142(define (local-timezone-offset . args)
143  (let-values (((tzo tzn) (apply *local-tz-info 'local-timezone-offset args)))
144    tzo ) )
145
146;; Return the timezone for the given date.
147
148(define (local-timezone-name+offset . args)
149  (apply *local-tz-info 'local-timezone-name+offset args) )
150
151;;
152
153(define (with-tzset tz thunk)
154  (let ((orgtz (get-environment-variable "TZ")))
155    (dynamic-wind
156      (lambda () (setenv "TZ" tz) ((foreign-lambda void "tzset")))
157      thunk
158      (lambda ()
159        (if orgtz (setenv "TZ" orgtz) (unsetenv "TZ"))
160        ((foreign-lambda void "tzset")) ) ) ) )
161
162) ;module locale-timezone
Note: See TracBrowser for help on using the repository browser.