1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
|
;;;; "timezone.scm" Compute timezones and DST from TZ environment variable.
;;; Copyright (C) 1994, 1996, 1997 Aubrey Jaffer.
;
;Permission to copy this software, to redistribute it, and to use it
;for any purpose is granted, subject to the following restrictions and
;understandings.
;
;1. Any copy made of this software must include this copyright notice
;in full.
;
;2. I have made no warrantee or representation that the operation of
;this software will be error-free, and I am under no obligation to
;provide any services, by way of maintenance, update, or otherwise.
;
;3. In conjunction with products arising from the use of this
;material, there shall be no use of my name in any advertising,
;promotional, or sales literature without prior written consent in
;each case.
;; The C-library support for time in general and time-zones in particular
;; stands as a fine example of how *not* to create interfaces.
;;
;; Functions are not consistently named. Support for GMT is offered in one
;; direction only; The localtime function returns some timezone data in the
;; structure which it returns, and some data in shared global variables.
;; The structure which localtime returns is overwritten with each
;; invocation. There is no way to find local time in zones other than GMT
;; and the local timezone.
;;
;; The tzfile(5) format encodes only a single timezone per file. There is
;; no dispatch on zone names, so multiple copies of a timezone file exist
;; under different names. The TZ `:' specification is unix filesystem
;; specific. The tzfile(5) format makes no provision for byte-order
;; differences; It mixes 32-bit integer data with characters; specifying
;; ASCII bytes, it is incompatible with different character sizes. The
;; binary format makes it impossible to easily inspect a file for
;; corruption.
;;
;; I have corrected most of the failings of the C-library time interface in
;; SLIB while maintaining compatablility. I wrote support for Linux
;; timezone files because on a system where TZ is not set, there is no
;; other way to reveal this information. HP-UX appears to have a more
;; sensible arrangement; I invite you to add support for it and other
;; platforms.
;;
;; Writing this was a long, tedious, and unenlightening process. I hope it
;; is useful.
;;
;; Sat Nov 15 00:15:33 1997 Aubrey Jaffer <jaffer@martigny.ai.mit.edu>
(provide 'time-zone)
(require 'scanf)
(define daylight? #f)
(define *timezone* 0)
(define tzname '#("UTC" "???"))
(define tz:default #f)
;;; Parse Posix TZ string.
(define (string->transition-day-time str)
(let ((month 0) (week 0) (day #f) (junk #f))
(or (case (sscanf str "J%u%s" day junk)
((1) (and (<= 1 day 365)
(list #f #f day)))
(else #f))
(case (sscanf str "%u%s" day junk)
((1) (and (<= 0 day 365)
(list #f #t day)))
(else #f))
(case (sscanf str "M%u.%u.%u%s" month week day junk)
((3) (and (<= 1 month 12)
(<= 1 week 5)
(<= 0 day 6)
(list month week day)))
(else #f)))))
(define (string->transition-time str)
(let ((date #f) (time "2") (junk #f))
(and (or (eqv? 2 (sscanf str "%[JM.0-9]/%[:0-9]%s" date time junk))
(eqv? 1 (sscanf str "%[JM.0-9]" date junk)))
(let ((day (string->transition-day-time date))
(tim (string->time-offset time)))
(and day tim (append day (list tim)))))))
(define (string->time-offset str)
(and str (string? str) (positive? (string-length str))
(let ((hh #f) (mm 0) (ss 0) (junk #f))
(and (<= 1 (sscanf (if (memv (string-ref str 0) '(#\+ #\-))
(substring str 1 (string-length str))
str)
"%u:%u:%u%s" hh mm ss junk)
3)
hh (<= 0 hh 23) (<= 0 mm 59) (<= 0 ss 59)
(* (if (char=? #\- (string-ref str 0)) -1 1)
(+ ss (* 60 (+ mm (* hh 60)))))))))
(define (string->time-zone tz)
(let ((tzname #f) (offset #f) (dtzname #f) (doffset #f)
(start-str #f) (end-str #f) (junk #f))
(define found
(sscanf
tz "%[^0-9,+-]%[-:+0-9]%[^0-9,+-]%[-:+0-9],%[JM.0-9/:],%[JM.0-9/:]%s"
tzname offset dtzname doffset start-str end-str junk))
(set! offset (string->time-offset offset))
(set! doffset (string->time-offset doffset))
(cond
((and offset (eqv? 3 found))
(set! doffset (+ -3600 offset))
(set! found
(+ 1
(sscanf
tz "%[^0-9,+-]%[-:+0-9]%[^0-9,+-],%[JM.0-9/:],%[JM.0-9/:]%s"
tzname offset dtzname start-str end-str junk)))
(set! offset (string->time-offset offset))))
(case found
((2) (vector 'tz:fixed tz tzname offset))
((4) (vector 'tz:rule tz tzname dtzname offset doffset
(list 4 1 0 7200) (list 10 5 0 7200)))
((6) (let ((start (string->transition-time start-str))
(end (string->transition-time end-str)))
(and
start end
(vector 'tz:rule tz tzname dtzname offset doffset start end))))
(else #f))))
(define (read-tzfile path)
(require 'tzfile)
(let ((realpath
(cond ((not path) (in-vicinity tzfile:vicinity "localtime"))
((or (char-alphabetic? (string-ref path 0))
(char-numeric? (string-ref path 0)))
(in-vicinity tzfile:vicinity path))
(else path))))
(if (file-exists? realpath)
(let ((zone (tzfile:read realpath)))
(if zone (list->vector (cons 'tz:file zone))
(slib:error 'read-tzfile realpath)))
(slib:error 'read-tzfile "file not found:" realpath)
)))
(define (time-zone tz)
(cond ((not tz) (read-tzfile #f))
((vector? tz) tz)
((eqv? #\: (string-ref tz 0))
(read-tzfile (substring tz 1 (string-length tz))))
(else (string->time-zone tz))))
;;; Use the timezone
(define (tzrule->caltime year previous-gmt-offset
tr-month tr-week tr-day tr-time)
(define leap? (leap-year? year))
(define gmmt
(time:invert time:gmtime
(vector 0 0 0 1 (if tr-month (+ -1 tr-month) 0) year #f #f 0)))
(offset-time
gmmt
(+ tr-time previous-gmt-offset
(* 3600 24
(if tr-month
(let* ((fdow (vector-ref (time:gmtime gmmt) 6)))
(case tr-week
((1 2 3 4) (+ (modulo (- tr-day fdow) 7)
(* 7 (+ -1 tr-week))))
((5)
(do ((mmax (vector-ref
(vector-ref time:days/month (if leap? 1 0))
(+ -1 tr-month)))
(d (modulo (- tr-day fdow) 7) (+ 7 d)))
((>= d mmax) (+ -7 d))))
(else (slib:error 'tzrule->caltime
"week out of range" tr-week))))
(+ tr-day
(if (and (not tr-week) (>= tr-day 60) (leap-year? year))
1 0)))))))
(define (tz:params caltime tz)
(case (vector-ref tz 0)
((tz:fixed) (list 0 (vector-ref tz 3) (vector-ref tz 2)))
((tz:rule)
(let* ((year (vector-ref (time:gmtime caltime) 5))
(ttime0 (apply tzrule->caltime
year (vector-ref tz 4) (vector-ref tz 6)))
(ttime1 (apply tzrule->caltime
year (vector-ref tz 5) (vector-ref tz 7)))
(dst (if (and (not (negative? (difftime caltime ttime0)))
(negative? (difftime caltime ttime1)))
1 0)))
(list dst (vector-ref tz (+ 4 dst)) (vector-ref tz (+ 2 dst)))
;;(for-each display (list (gtime ttime0) (gtime caltime) (gtime ttime1)))
))
((tz:file) (let ((zone-spec (tzfile:get-zone-spec caltime tz)))
(list (if (vector-ref zone-spec 2) 1 0)
(- (vector-ref zone-spec 1))
(vector-ref zone-spec 0))))
(else (slib:error 'tz:params "unknown timezone type" tz))))
(define (tz:std-offset zone)
(case (vector-ref zone 0)
((tz:fixed) (vector-ref zone 3))
((tz:rule) (vector-ref zone 4))
((tz:file)
(let ((mode-table (vector-ref zone 2)))
(do ((type-idx 0 (+ 1 type-idx)))
((or (>= type-idx (vector-length mode-table))
(not (vector-ref (vector-ref mode-table type-idx) 2)))
(if (>= type-idx (vector-length mode-table))
(vector-ref (vector-ref mode-table 0) 1)
(- (vector-ref (vector-ref mode-table type-idx) 1)))))))
(else (slib:error 'tz:std-offset "unknown timezone type" tz))))
;;; Interpret the TZ envariable.
(define (tzset . opt-tz)
(define tz (if (null? opt-tz)
(getenv "TZ")
(car opt-tz)))
(if (or (not tz:default)
(and (string? tz) (not (string-ci=? tz (vector-ref tz:default 1)))))
(set! tz:default (or (time-zone tz) '#(tz:fixed "UTC" "GMT" 0))))
(case (vector-ref tz:default 0)
((tz:fixed)
(set! tzname (vector (vector-ref tz:default 2) "???"))
(set! daylight? #f)
(set! *timezone* (vector-ref tz:default 3)))
((tz:rule)
(set! tzname (vector (vector-ref tz:default 2)
(vector-ref tz:default 3)))
(set! daylight? #t)
(set! *timezone* (vector-ref tz:default 4)))
((tz:file)
(let ((mode-table (vector-ref tz:default 2))
(transition-types (vector-ref tz:default 5)))
(set! daylight? #f)
(set! *timezone* (vector-ref (vector-ref mode-table 0) 1))
(set! tzname (make-vector 2 #f))
(do ((type-idx 0 (+ 1 type-idx)))
((>= type-idx (vector-length mode-table)))
(let ((rec (vector-ref mode-table type-idx)))
(if (vector-ref rec 2)
(set! daylight? #t)
(set! *timezone* (- (vector-ref rec 1))))))
(do ((transition-idx (+ -1 (vector-length transition-types))
(+ -1 transition-idx)))
((or (negative? transition-idx)
(and (vector-ref tzname 0) (vector-ref tzname 1))))
(let ((rec (vector-ref mode-table
(vector-ref transition-types transition-idx))))
(if (vector-ref rec 2)
(if (not (vector-ref tzname 1))
(vector-set! tzname 1 (vector-ref rec 0)))
(if (not (vector-ref tzname 0))
(vector-set! tzname 0 (vector-ref rec 0))))))))
(else (slib:error 'tzset "unknown timezone type" tz)))
tz:default)
|
