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

Last change on this file since 35363 was 35363, checked in by kon, 6 months ago

use csi+csc test runner

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 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
Note: See TracBrowser for help on using the repository browser.