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

Last change on this file since 15915 was 15915, checked in by Kon Lovett, 11 years ago

Use of scheme only in locale-timezone. Note about posix 'local-timezone-abbreviation' bug.

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