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

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

reflow

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