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

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

Save

File size: 4.5 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 chicken scheme)
10  (require-extension posix)
11
12  (declare
13    (inline)
14    (fixnum)
15    (no-procedure-checks)
16    (run-time-macros)
17    (bound-to-procedure
18      ##sys#error-hook) )
19
20#>
21#include <stdlib.h>
22#include <string.h>
23#include <stdio.h>
24#include <time.h>
25
26#ifdef _WIN32
27static struct tm *
28localtime_r( const time_t *clock, struct tm *result )
29{
30  if (!clock || !result) return NULL;
31  memcpy( result, localtime( clock ), sizeof( *result ) );
32  return result;
33}
34#endif
35
36static char *
37get_tz( int yr, int mo, int dy, int hr, int mn, int sc, int as_offset )
38{
39  struct tm tm;
40  time_t t;
41
42  const int size = 31 + 1;
43  char *buf = malloc( size * sizeof( char ) );
44
45  memset( &tm, 0, sizeof tm );
46  tm.tm_hour = hr;
47  tm.tm_min = mn;
48  tm.tm_sec = sc;
49  tm.tm_year = yr - 1900;
50  tm.tm_mon = mo;
51  tm.tm_mday = dy;
52
53  t = mktime( &tm );
54  strftime( buf, size, (as_offset ? "%z" : "%Z"), localtime_r( &t, &tm ) );
55
56  return buf;
57}
58<#
59
60;;;
61
62(define get-tz (foreign-lambda c-string* "get_tz" int int int int int int bool))
63
64; #!required tm | hr mo dy #!optional (hr 12) (mn 0) (sc 0) #!key offset?
65(define (*local-timezone loc . args)
66
67  (let ((arglen (length args))
68        (yr #f) (mo #f) (dy #f) (hr #f) (mn #f) (sc #f) (offset? #f))
69
70    ; DSSSL lambda list parsing behavior as I wish it was
71    (unless (<= 1 arglen) (##sys#error-hook 2 loc arglen 1))
72    (if (vector? (car args))
73        (let ((tm (car args)))
74          (when (< (vector-length tm) 10) (error loc "time vector too short" tm))
75          (set! yr (+ (vector-ref tm 5) 1900))
76          (set! mo (vector-ref tm 4))
77          (set! dy (vector-ref tm 3))
78          (set! hr (vector-ref tm 2))
79          (set! mn (vector-ref tm 1))
80          (set! sc (vector-ref tm 0))
81          (let ((args (cdr args)))
82            (if (= 3 arglen)
83                (let ((arg (car args)))
84                  (if (eq? #:offset? arg) (set! offset? (cadr args))
85                      (if (keyword? arg) (error loc "unknown keyword argument" arg)
86                          (##sys#error-hook 1 loc arglen 3) ) ) )
87                (unless (= 1 arglen) (##sys#error-hook 1 loc arglen 3)) ) ) )
88        (begin
89          (unless (<= 3 arglen) (##sys#error-hook 2 loc arglen 3))
90          (set! yr (car args))
91          (set! mo (cadr args))
92          (set! dy (caddr args))
93          (let loop ((args (cdddr args)))
94            (if (null? args)
95                (begin (unless hr (set! hr 12)) (unless mn (set! mn 0)) (unless sc (set! sc 0)))
96                (let ((arg (car args)))
97                  (cond ((keyword? arg)
98                         (if (eq? #:offset? arg) (set! offset? (cadr args))
99                             (error loc "unknown keyword argument" arg) )
100                         (loop (cddr args)) )
101                        ((and hr mn sc)
102                         (##sys#error-hook 1 loc arglen 8) )
103                        (else
104                         (if hr (if mn (set! sc arg) (set! mn arg)) (set! hr arg))
105                         (loop (cdr args)) ) ) ) ) ) ) )
106
107    (unless (and (fixnum? yr) (fixnum? mo) (fixnum? dy) (fixnum? hr) (fixnum? mn) (fixnum? sc))
108      (apply error loc "bad argument type - expected fixnum" args) )
109    (unless (and (<= 0 sc 60) (<= 0 mn 59) (<= 0 hr 23) (<= 1 dy 31) (<= 0 mn 11))
110      (apply error loc "bad argument type - out of range" args) )
111
112    (get-tz yr mo dy hr mn sc offset?) ) )
113
114;;;
115
116;; Return the timezone for the given date as a string,
117;; (e.g. "EST"). If offset?: #t, then return it in RFC-822
118;; format (e.g. "-0500").
119
120(define (local-timezone . args) (apply *local-timezone 'local-timezone args))
121
122;; Return the timezone offset as seconds where positive is east of UTC &
123;; negative is west of UTC.
124
125(define (local-timezone-offset . args)
126  (let* ((tzo (apply 'local-timezone-offset *local-timezone args))
127         (1stch (string-ref tzo 0))
128         (neg? (char=? #\- 1stch))
129         (start (if (or neg? (char=? #\+ 1stch)) 1 0))
130         (end (+ start 2))
131         (secs (+ (* (string->number (substring tzo start end)) 3600)
132                  (* (string->number (substring tzo end (+ end 2))) 60))) )
133    (if neg? (- secs) secs) ) )
134
135;;
136
137(define (with-tzset tz thunk)
138  (let ((orgtz (getenv "TZ")))
139     (dynamic-wind
140       (lambda () (setenv "TZ" tz) ((foreign-lambda void "tzset")))
141       thunk
142       (lambda () (setenv "TZ" orgtz) ((foreign-lambda void "tzset"))) ) ) )
143
144) ;module locale-timezone
Note: See TracBrowser for help on using the repository browser.