Mercurial > emacs
comparison lisp/calendar/cal-dst.el @ 3872:923a207e7967
* cal-dst.el: New file.
(calendar-/, calendar-%, calendar-absolute-from-time,
calendar-time-from-absolute, calendar-next-time-zone-transition,
calendar-time-zone-daylight-rules): New functions.
(calendar-current-time-zone): Moved from calendar.el and rewritten.
(calendar-current-time-zone-cache): New variable.
(calendar-current-time-zone, calendar-time-zone,
calendar-daylight-time-offset, calendar-standard-time-zone-name,
calendar-daylight-time-zone-name,
calendar-daylight-savings-starts, calendar-daylight-savings-ends,
calendar-daylight-savings-switchover-time): Moved from calendar.el.
author | Jim Blandy <jimb@redhat.com> |
---|---|
date | Tue, 22 Jun 1993 03:25:13 +0000 |
parents | |
children | 2308b366bfc8 |
comparison
equal
deleted
inserted
replaced
3871:a9f9a058567f | 3872:923a207e7967 |
---|---|
1 ;;; cal-dst.el --- calendar functions for daylight savings rules. | |
2 | |
3 ;; Copyright (C) 1993 Free Software Foundation, Inc. | |
4 | |
5 ;; Author: Paul Eggert <eggert@twinsun.com> | |
6 ;; Edward M. Reingold <reingold@cs.uiuc.edu> | |
7 ;; Keywords: calendar | |
8 ;; Human-Keywords: daylight savings time, calendar, diary, holidays | |
9 | |
10 ;; This file is part of GNU Emacs. | |
11 | |
12 ;; GNU Emacs is distributed in the hope that it will be useful, | |
13 ;; but WITHOUT ANY WARRANTY. No author or distributor | |
14 ;; accepts responsibility to anyone for the consequences of using it | |
15 ;; or for whether it serves any particular purpose or works at all, | |
16 ;; unless he says so in writing. Refer to the GNU Emacs General Public | |
17 ;; License for full details. | |
18 | |
19 ;; Everyone is granted permission to copy, modify and redistribute | |
20 ;; GNU Emacs, but only under the conditions described in the | |
21 ;; GNU Emacs General Public License. A copy of this license is | |
22 ;; supposed to have been given to you along with GNU Emacs so you | |
23 ;; can know your rights and responsibilities. It should be in a | |
24 ;; file named COPYING. Among other things, the copyright notice | |
25 ;; and this notice must be preserved on all copies. | |
26 | |
27 ;;; Commentary: | |
28 | |
29 ;; This collection of functions implements the features of calendar.el and | |
30 ;; holiday.el that deal with daylight savings time. | |
31 | |
32 ;; Comments, corrections, and improvements should be sent to | |
33 ;; Edward M. Reingold Department of Computer Science | |
34 ;; (217) 333-6733 University of Illinois at Urbana-Champaign | |
35 ;; reingold@cs.uiuc.edu 1304 West Springfield Avenue | |
36 ;; Urbana, Illinois 61801 | |
37 | |
38 ;;; Code: | |
39 | |
40 (require 'calendar) | |
41 | |
42 (defvar calendar-current-time-zone-cache nil | |
43 "Cache for result of calendar-current-time-zone.") | |
44 | |
45 (defvar calendar-system-time-basis | |
46 (calendar-absolute-from-gregorian '(1 1 1970)) | |
47 "Absolute date of starting date of system clock.") | |
48 | |
49 (defun calendar-/ (a b) | |
50 "Floor(A/B) = the greatest integer not greater than A divided by B. | |
51 A and B be must both be integers, and B must be positive." | |
52 (if (< a 0) | |
53 (- (/ (- b 1 a) b)) | |
54 (/ a b))) | |
55 | |
56 (defun calendar-% (a b) | |
57 "A modulo B; always nonnegative. | |
58 A and B be must both be integers, and B must be positive." | |
59 (let ((m (% a b))) | |
60 (if (< m 0) | |
61 (+ m b) | |
62 m))) | |
63 | |
64 (defun calendar-absolute-from-time (x utc-diff) | |
65 "Absolute local date of time X; local time is UTC-DIFF seconds from UTC. | |
66 | |
67 X is (HIGH . LOW) or (HIGH LOW . IGNORED) where HIGH and LOW are the | |
68 high and low 16 bits, respectively, of the number of seconds since | |
69 1970-01-01 00:00:00 UTC, ignoring leap seconds. | |
70 | |
71 Returns the pair (ABS-DATE . SECONDS) where SECONDS after local midnight on | |
72 absolute date ABS-DATE is the equivalent moment to X." | |
73 (let* ((h (car x)) | |
74 (xtail (cdr x)) | |
75 (l (+ utc-diff (if (numberp xtail) xtail (car xtail)))) | |
76 (u (+ (* 512 (calendar-% h 675)) (calendar-/ l 128)))) | |
77 ;; Overflow is a terrible thing! | |
78 (cons (+ calendar-system-time-basis | |
79 ;; floor((2^16 h +l) / (60*60*24)) | |
80 (* 512 (calendar-/ h 675)) (calendar-/ u 675)) | |
81 ;; (2^16 h +l) % (60*60*24) | |
82 (+ (* (calendar-% u 675) 128) (calendar-% l 128))))) | |
83 | |
84 (defun calendar-time-from-absolute (abs-date s) | |
85 "Time of absolute date ABS-DATE, S seconds after midnight. | |
86 | |
87 Returns the pair (HIGH . LOW) where HIGH and LOW are the high and low | |
88 16 bits, respectively, of the number of seconds 1970-01-01 00:00:00 UTC, | |
89 ignoring leap seconds, that is the equivalent moment to S seconds after | |
90 midnight UTC on absolute date ABS-DATE." | |
91 (let* ((a (- abs-date calendar-system-time-basis)) | |
92 (u (+ (* 163 (calendar-% a 512)) (calendar-/ s 128)))) | |
93 ;; Overflow is a terrible thing! | |
94 (cons | |
95 ;; (60*60*24*a + s) / 2^16 | |
96 (+ a (* 163 (calendar-/ a 512)) (calendar-/ u 512)) | |
97 ;; (60*60*24*a + s) % 2^16 | |
98 (+ (* 128 (calendar-% u 512)) (calendar-% s 128))))) | |
99 | |
100 (defun calendar-next-time-zone-transition (time) | |
101 "Return the time of the next time zone transition after TIME. | |
102 Both TIME and the result are acceptable arguments to current-time-zone. | |
103 Return nil if no such transition can be found." | |
104 (let* ((base 65536);; 2^16 = base of current-time output | |
105 (quarter-multiple 120);; approx = (seconds per quarter year) / base | |
106 (time-zone (current-time-zone time)) | |
107 (time-utc-diff (car time-zone)) | |
108 hi | |
109 hi-zone | |
110 (hi-utc-diff time-utc-diff) | |
111 (quarters '(2 1 3))) | |
112 ;; Heuristic: probe the time zone offset in the next three calendar | |
113 ;; quarters, looking for a time zone offset different from TIME. | |
114 (while (and quarters (eq time-utc-diff hi-utc-diff)) | |
115 (setq hi (cons (+ (car time) (* (car quarters) quarter-multiple)) 0)) | |
116 (setq hi-zone (current-time-zone hi)) | |
117 (setq hi-utc-diff (car hi-zone)) | |
118 (setq quarters (cdr quarters))) | |
119 (and | |
120 time-utc-diff | |
121 hi-utc-diff | |
122 (not (eq time-utc-diff hi-utc-diff)) | |
123 ;; Now HI is after the next time zone transition. | |
124 ;; Set LO to TIME, and then binary search to increase LO and decrease HI | |
125 ;; until LO is just before and HI is just after the time zone transition. | |
126 (let* ((tail (cdr time)) | |
127 (lo (cons (car time) (if (numberp tail) tail (car tail)))) | |
128 probe) | |
129 (while | |
130 ;; Set PROBE to halfway between LO and HI, rounding down. | |
131 ;; If PROBE equals LO, we are done. | |
132 (let* ((lsum (+ (cdr lo) (cdr hi))) | |
133 (hsum (+ (car lo) (car hi) (/ lsum base))) | |
134 (hsumodd (logand 1 hsum))) | |
135 (setq probe (cons (/ (- hsum hsumodd) 2) | |
136 (/ (+ (* hsumodd base) (% lsum base)) 2))) | |
137 (not (equal lo probe))) | |
138 ;; Set either LO or HI to PROBE, depending on probe results. | |
139 (if (eq (car (current-time-zone probe)) hi-utc-diff) | |
140 (setq hi probe) | |
141 (setq lo probe))) | |
142 hi)))) | |
143 | |
144 (defun calendar-time-zone-daylight-rules (abs-date utc-diff) | |
145 "Return daylight transition rule for ABS-DATE, UTC-DIFF sec offset from UTC. | |
146 ABS-DIFF must specify a day that contains a daylight savings transition. | |
147 The result has the proper form for calendar-daylight-savings-starts'." | |
148 (let* ((date (calendar-gregorian-from-absolute abs-date)) | |
149 (weekday (% abs-date 7)) | |
150 (m (extract-calendar-month date)) | |
151 (d (extract-calendar-day date)) | |
152 (y (extract-calendar-year date)) | |
153 (last (calendar-last-day-of-month m y)) | |
154 (candidate-rules | |
155 (append | |
156 ;; Day D of month M. | |
157 (list (list 'list m d 'year)) | |
158 ;; The first WEEKDAY of month M. | |
159 (if (< d 8) | |
160 (list (list 'calendar-nth-named-day 1 weekday m 'year))) | |
161 ;; The last WEEKDAY of month M. | |
162 (if (> d (- last 7)) | |
163 (list (list 'calendar-nth-named-day -1 weekday m 'year))) | |
164 ;; The first WEEKDAY after day J of month M, for D-6 < J <= D. | |
165 (let (l) | |
166 (calendar-for-loop j from (max 2 (- d 6)) to (min d (- last 8)) do | |
167 (setq l | |
168 (cons | |
169 (list 'calendar-nth-named-day 1 weekday m 'year j) | |
170 l))) | |
171 l) | |
172 ;; Israel is special. | |
173 (if (zerop weekday) | |
174 (if (< m 7) | |
175 (list | |
176 '(calendar-gregorian-from-absolute | |
177 (calendar-dayname-on-or-before | |
178 0 | |
179 (calendar-absolute-from-hebrew | |
180 (list 1 28 (+ year 3760)))))) | |
181 (list '(calendar-gregorian-from-absolute | |
182 (calendar-dayname-on-or-before | |
183 0 | |
184 (- (calendar-absolute-from-hebrew | |
185 (list 7 1 (+ year 3761))) 3)))))))) | |
186 (prevday-sec (- -1 utc-diff)) ;; last sec of previous local day | |
187 last-surviving-rule | |
188 (i 1)) | |
189 ;; Scan through the next few years; take the rule that explains them best. | |
190 (while (and candidate-rules (cdr candidate-rules) (<= i 28)) | |
191 (let ((year (+ y i)) | |
192 new-rules) | |
193 (while candidate-rules | |
194 (let* ((rule (car candidate-rules)) | |
195 (date (calendar-absolute-from-gregorian (eval rule)))) | |
196 (or (equal (current-time-zone | |
197 (calendar-time-from-absolute date prevday-sec)) | |
198 (current-time-zone | |
199 (calendar-time-from-absolute (1+ date) prevday-sec))) | |
200 (progn | |
201 (setq new-rules (cons rule new-rules)) | |
202 (setq last-surviving-rule rule)))) | |
203 (setq candidate-rules (cdr candidate-rules))) | |
204 (setq candidate-rules (nreverse new-rules))) | |
205 (setq i (1+ i))) | |
206 last-surviving-rule)) | |
207 | |
208 (defun calendar-current-time-zone () | |
209 "Return UTC difference, dst offset, names and rules for current time zone. | |
210 | |
211 Returns (UTC-DIFF DST-OFFSET STD-ZONE DST-ZONE DST-STARTS DST-ENDS DST-SWITCH), | |
212 based on a heuristic probing of what the system knows: | |
213 | |
214 UTC-DIFF is an integer specifying the number of minutes difference between | |
215 standard time in the current time zone and Coordinated Universal Time | |
216 (Greenwich Mean Time). A negative value means west of Greenwich. | |
217 DST-OFFSET is an integer giving the daylight savings time offset in minutes. | |
218 STD-ZONE is a string giving the name of the time zone when no seasonal time | |
219 adjustment is in effect. | |
220 DST-ZONE is a string giving the name of the time zone when there is a seasonal | |
221 time adjustment in effect. | |
222 DST-STARTS and DST-ENDS are sexps in the variable `year' giving the daylight | |
223 savings time start rules, in the form expected by | |
224 `calendar-daylight-savings-starts'. | |
225 DST-SWITCH is an integer giving the number of minutes after midnight that | |
226 daylight savings time starts or ends. | |
227 | |
228 If the local area does not use a seasonal time adjustment, DST-OFFSET and | |
229 DST-SWITCH are 0, STD-ZONE and DST-ZONE are equal, and DST-STARTS and DST-ENDS | |
230 are nil. | |
231 | |
232 Some operating systems cannot provide all this information to Emacs; in this | |
233 case, `calendar-current-time-zone' returns a list containing nil for the data | |
234 it can't find." | |
235 (or | |
236 calendar-current-time-zone-cache | |
237 (progn | |
238 (message "Checking time zone data...") | |
239 (setq | |
240 calendar-current-time-zone-cache | |
241 (let* ((now (current-time)) | |
242 (now-zone (current-time-zone now)) | |
243 (now-utc-diff (car now-zone)) | |
244 (now-name (car (cdr now-zone))) | |
245 (next (calendar-next-time-zone-transition now))) | |
246 (if (null next) | |
247 (list (and now-utc-diff (/ now-utc-diff 60)) | |
248 0 now-name now-name nil nil 0) | |
249 (let* ((next-zone (current-time-zone next)) | |
250 (next-utc-diff (car next-zone)) | |
251 (next-name (car (cdr next-zone))) | |
252 (next-absdate-seconds | |
253 (calendar-absolute-from-time next now-utc-diff)) | |
254 (next-transitions | |
255 (calendar-time-zone-daylight-rules | |
256 (car next-absdate-seconds) now-utc-diff)) | |
257 (nextnext (calendar-next-time-zone-transition next)) | |
258 (now-transitions | |
259 (calendar-time-zone-daylight-rules | |
260 (car (calendar-absolute-from-time nextnext next-utc-diff)) | |
261 next-utc-diff)) | |
262 (now-is-std (< now-utc-diff next-utc-diff))) | |
263 (list (/ (min now-utc-diff next-utc-diff) 60) | |
264 (/ (abs (- now-utc-diff next-utc-diff)) 60) | |
265 (if now-is-std now-name next-name) | |
266 (if now-is-std next-name now-name) | |
267 (if now-is-std next-transitions now-transitions) | |
268 (if now-is-std now-transitions next-transitions) | |
269 (/ (cdr next-absdate-seconds) 60)))))) | |
270 (message "Checking time zone data...done"))) | |
271 calendar-current-time-zone-cache) | |
272 | |
273 ;;; The following six defvars relating to daylight savings time should NOT be | |
274 ;;; marked to go into loaddefs.el where they would be evaluated when Emacs is | |
275 ;;; dumped. These variables' appropriate values depend on the conditions under | |
276 ;;; which the code is INVOKED; so it's inappropriate to initialize them when | |
277 ;;; Emacs is dumped---they should be initialized when calendar.el is loaded. | |
278 | |
279 (calendar-current-time-zone) | |
280 | |
281 (defvar calendar-time-zone (car calendar-current-time-zone-cache) | |
282 "*Number of minutes difference between local standard time at | |
283 `calendar-location-name' and Coordinated Universal (Greenwich) Time. For | |
284 example, -300 for New York City, -480 for Los Angeles.") | |
285 | |
286 (defvar calendar-daylight-time-offset | |
287 (car (cdr calendar-current-time-zone-cache)) | |
288 "*Number of minutes difference between daylight savings and standard time. | |
289 | |
290 If the locale never uses daylight savings time, set this to 0.") | |
291 | |
292 (defvar calendar-standard-time-zone-name | |
293 (car (nthcdr 2 calendar-current-time-zone-cache)) | |
294 "*Abbreviated name of standard time zone at `calendar-location-name'. | |
295 For example, \"EST\" in New York City, \"PST\" for Los Angeles.") | |
296 | |
297 (defvar calendar-daylight-time-zone-name | |
298 (car (nthcdr 3 calendar-current-time-zone-cache)) | |
299 "*Abbreviated name of daylight-savings time zone at `calendar-location-name'. | |
300 For example, \"EDT\" in New York City, \"PDT\" for Los Angeles.") | |
301 | |
302 (defvar calendar-daylight-savings-starts | |
303 (car (nthcdr 4 calendar-current-time-zone-cache)) | |
304 "*Sexp giving the date on which daylight savings time starts. | |
305 This is an expression in the variable `year' whose value gives the Gregorian | |
306 date in the form (month day year) on which daylight savings time starts. It is | |
307 used to determine the starting date of daylight savings time for the holiday | |
308 list and for correcting times of day in the solar and lunar calculations. | |
309 | |
310 For example, if daylight savings time is mandated to start on October 1, | |
311 you would set `calendar-daylight-savings-starts' to | |
312 | |
313 '(10 1 year) | |
314 | |
315 For a more complex example, daylight savings time begins in Israel on the | |
316 first Sunday after Passover ends on Nisan 21: | |
317 | |
318 '(calendar-gregorian-from-absolute | |
319 (calendar-dayname-on-or-before | |
320 0 | |
321 (calendar-absolute-from-hebrew (list 1 28 (+ year 3760))))) | |
322 | |
323 because Nisan is the first month in the Hebrew calendar. | |
324 | |
325 If the locale never uses daylight savings time, set this to nil.") | |
326 | |
327 (defvar calendar-daylight-savings-ends | |
328 (car (nthcdr 5 calendar-current-time-zone-cache)) | |
329 "*Sexp giving the date on which daylight savings time ends. | |
330 This is an expression in the variable `year' whose value gives the Gregorian | |
331 date in the form (month day year) on which daylight savings time ends. It is | |
332 used to determine the starting date of daylight savings time for the holiday | |
333 list and for correcting times of day in the solar and lunar calculations. | |
334 | |
335 For example, daylight savings time ends in Israel on the Sunday Selichot | |
336 begins: | |
337 | |
338 '(calendar-gregorian-from-absolute | |
339 (calendar-dayname-on-or-before | |
340 0 | |
341 (- (calendar-absolute-from-hebrew (list 7 1 (+ year 3761))) 3))) | |
342 | |
343 If the locale never uses daylight savings time, set this to nil.") | |
344 | |
345 (defvar calendar-daylight-savings-switchover-time | |
346 (car (nthcdr 6 calendar-current-time-zone-cache)) | |
347 "*Number of minutes after midnight that daylight savings time begins/ends. | |
348 If the locale never uses daylight savings time, set this to 0.") | |
349 | |
350 (provide 'cal-dst) | |
351 | |
352 ;;; cal-dst.el ends here |