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