Mercurial > emacs
comparison lisp/calendar/time-date.el @ 88155:d7ddb3e565de
sync with trunk
author | Henrik Enberg <henrik.enberg@telia.com> |
---|---|
date | Mon, 16 Jan 2006 00:03:54 +0000 |
parents | d94124a8eddf |
children |
comparison
equal
deleted
inserted
replaced
88154:8ce476d3ba36 | 88155:d7ddb3e565de |
---|---|
1 ;;; time-date.el --- date and time handling functions | 1 ;;; time-date.el --- Date and time handling functions |
2 ;; Copyright (C) 1998, 1999, 2000 Free Software Foundation, Inc. | 2 |
3 ;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005 | |
4 ;; Free Software Foundation, Inc. | |
3 | 5 |
4 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> | 6 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> |
5 ;; Masanobu Umeda <umerin@mse.kyutech.ac.jp> | 7 ;; Masanobu Umeda <umerin@mse.kyutech.ac.jp> |
6 ;; Keywords: mail news util | 8 ;; Keywords: mail news util |
7 | 9 |
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | 19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
18 ;; GNU General Public License for more details. | 20 ;; GNU General Public License for more details. |
19 | 21 |
20 ;; You should have received a copy of the GNU General Public License | 22 ;; You should have received a copy of the GNU General Public License |
21 ;; along with GNU Emacs; see the file COPYING. If not, write to the | 23 ;; along with GNU Emacs; see the file COPYING. If not, write to the |
22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, | 24 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, |
23 ;; Boston, MA 02111-1307, USA. | 25 ;; Boston, MA 02110-1301, USA. |
24 | 26 |
25 ;;; Commentary: | 27 ;;; Commentary: |
26 | 28 |
29 ;; Time values come in three formats. The oldest format is a cons | |
30 ;; cell of the form (HIGH . LOW). This format is obsolete, but still | |
31 ;; supported. The two other formats are the lists (HIGH LOW) and | |
32 ;; (HIGH LOW MICRO). The first two formats specify HIGH * 2^16 + LOW | |
33 ;; seconds; the third format specifies HIGH * 2^16 + LOW + MICRO / | |
34 ;; 1000000 seconds. We should have 0 <= MICRO < 1000000 and 0 <= LOW | |
35 ;; < 2^16. If the time value represents a point in time, then HIGH is | |
36 ;; nonnegative. If the time value is a time difference, then HIGH can | |
37 ;; be negative as well. The macro `with-decoded-time-value' and the | |
38 ;; function `encode-time-value' make it easier to deal with these | |
39 ;; three formats. See `time-subtract' for an example of how to use | |
40 ;; them. | |
41 | |
27 ;;; Code: | 42 ;;; Code: |
28 | 43 |
29 (require 'parse-time) | 44 (defmacro with-decoded-time-value (varlist &rest body) |
30 | 45 "Decode a time value and bind it according to VARLIST, then eval BODY. |
46 | |
47 The value of the last form in BODY is returned. | |
48 | |
49 Each element of the list VARLIST is a list of the form | |
50 \(HIGH-SYMBOL LOW-SYMBOL MICRO-SYMBOL [TYPE-SYMBOL] TIME-VALUE). | |
51 The time value TIME-VALUE is decoded and the result it bound to | |
52 the symbols HIGH-SYMBOL, LOW-SYMBOL and MICRO-SYMBOL. | |
53 | |
54 The optional TYPE-SYMBOL is bound to the type of the time value. | |
55 Type 0 is the cons cell (HIGH . LOW), type 1 is the list (HIGH | |
56 LOW), and type 3 is the list (HIGH LOW MICRO)." | |
57 (declare (indent 1) | |
58 (debug ((&rest (symbolp symbolp symbolp &or [symbolp form] form)) | |
59 body))) | |
60 (if varlist | |
61 (let* ((elt (pop varlist)) | |
62 (high (pop elt)) | |
63 (low (pop elt)) | |
64 (micro (pop elt)) | |
65 (type (unless (eq (length elt) 1) | |
66 (pop elt))) | |
67 (time-value (car elt)) | |
68 (gensym (make-symbol "time"))) | |
69 `(let* ,(append `((,gensym ,time-value) | |
70 (,high (pop ,gensym)) | |
71 ,low ,micro) | |
72 (when type `(,type))) | |
73 (if (consp ,gensym) | |
74 (progn | |
75 (setq ,low (pop ,gensym)) | |
76 (if ,gensym | |
77 ,(append `(setq ,micro (car ,gensym)) | |
78 (when type `(,type 2))) | |
79 ,(append `(setq ,micro 0) | |
80 (when type `(,type 1))))) | |
81 ,(append `(setq ,low ,gensym ,micro 0) | |
82 (when type `(,type 0)))) | |
83 (with-decoded-time-value ,varlist ,@body))) | |
84 `(progn ,@body))) | |
85 | |
86 (defun encode-time-value (high low micro type) | |
87 "Encode HIGH, LOW, and MICRO into a time value of type TYPE. | |
88 Type 0 is the cons cell (HIGH . LOW), type 1 is the list (HIGH LOW), | |
89 and type 3 is the list (HIGH LOW MICRO)." | |
90 (cond | |
91 ((eq type 0) (cons high low)) | |
92 ((eq type 1) (list high low)) | |
93 ((eq type 2) (list high low micro)))) | |
94 | |
95 (autoload 'parse-time-string "parse-time") | |
31 (autoload 'timezone-make-date-arpa-standard "timezone") | 96 (autoload 'timezone-make-date-arpa-standard "timezone") |
32 | 97 |
33 ;;;###autoload | 98 ;;;###autoload |
34 (defun date-to-time (date) | 99 (defun date-to-time (date) |
35 "Parse a string that represents a date-time and return a time value." | 100 "Parse a string that represents a date-time and return a time value." |
36 (condition-case () | 101 (condition-case () |
37 (apply 'encode-time | 102 (apply 'encode-time |
38 (parse-time-string | 103 (parse-time-string |
39 ;; `parse-time-string' isn't sufficiently general or | 104 ;; `parse-time-string' isn't sufficiently general or |
40 ;; robust. It fails to grok some of the formats that | 105 ;; robust. It fails to grok some of the formats that |
41 ;; timzeone does (e.g. dodgy post-2000 stuff from some | 106 ;; timezone does (e.g. dodgy post-2000 stuff from some |
42 ;; Elms) and either fails or returns bogus values. Lars | 107 ;; Elms) and either fails or returns bogus values. Lars |
43 ;; reverted this change, but that loses non-trivially | 108 ;; reverted this change, but that loses non-trivially |
44 ;; often for me. -- fx | 109 ;; often for me. -- fx |
45 (timezone-make-date-arpa-standard date))) | 110 (timezone-make-date-arpa-standard date))) |
46 (error (error "Invalid date: %s" date)))) | 111 (error (error "Invalid date: %s" date)))) |
47 | 112 |
113 ;;;###autoload | |
48 (defun time-to-seconds (time) | 114 (defun time-to-seconds (time) |
49 "Convert time value TIME to a floating point number. | 115 "Convert time value TIME to a floating point number. |
50 You can use `float-time' instead." | 116 You can use `float-time' instead." |
51 (+ (* (car time) 65536.0) | 117 (with-decoded-time-value ((high low micro time)) |
52 (cadr time) | 118 (+ (* 1.0 high 65536) |
53 (/ (or (nth 2 time) 0) 1000000.0))) | 119 low |
120 (/ micro 1000000.0)))) | |
54 | 121 |
55 ;;;###autoload | 122 ;;;###autoload |
56 (defun seconds-to-time (seconds) | 123 (defun seconds-to-time (seconds) |
57 "Convert SECONDS (a floating point number) to a time value." | 124 "Convert SECONDS (a floating point number) to a time value." |
58 (list (floor seconds 65536) | 125 (list (floor seconds 65536) |
60 (floor (* (- seconds (ffloor seconds)) 1000000)))) | 127 (floor (* (- seconds (ffloor seconds)) 1000000)))) |
61 | 128 |
62 ;;;###autoload | 129 ;;;###autoload |
63 (defun time-less-p (t1 t2) | 130 (defun time-less-p (t1 t2) |
64 "Say whether time value T1 is less than time value T2." | 131 "Say whether time value T1 is less than time value T2." |
65 (or (< (car t1) (car t2)) | 132 (with-decoded-time-value ((high1 low1 micro1 t1) |
66 (and (= (car t1) (car t2)) | 133 (high2 low2 micro2 t2)) |
67 (< (nth 1 t1) (nth 1 t2))))) | 134 (or (< high1 high2) |
135 (and (= high1 high2) | |
136 (or (< low1 low2) | |
137 (and (= low1 low2) | |
138 (< micro1 micro2))))))) | |
68 | 139 |
69 ;;;###autoload | 140 ;;;###autoload |
70 (defun days-to-time (days) | 141 (defun days-to-time (days) |
71 "Convert DAYS into a time value." | 142 "Convert DAYS into a time value." |
72 (let* ((seconds (* 1.0 days 60 60 24)) | 143 (let* ((seconds (* 1.0 days 60 60 24)) |
73 (rest (expt 2 16)) | 144 (high (condition-case nil (floor (/ seconds 65536)) |
74 (ms (condition-case nil (floor (/ seconds rest)) | 145 (range-error most-positive-fixnum)))) |
75 (range-error (expt 2 16))))) | 146 (list high (condition-case nil (floor (- seconds (* 1.0 high 65536))) |
76 (list ms (condition-case nil (round (- seconds (* ms rest))) | 147 (range-error 65535))))) |
77 (range-error (expt 2 16)))))) | |
78 | 148 |
79 ;;;###autoload | 149 ;;;###autoload |
80 (defun time-since (time) | 150 (defun time-since (time) |
81 "Return the time elapsed since TIME. | 151 "Return the time elapsed since TIME. |
82 TIME should be either a time value or a date-time string." | 152 TIME should be either a time value or a date-time string." |
83 (when (stringp time) | 153 (when (stringp time) |
84 ;; Convert date strings to internal time. | 154 ;; Convert date strings to internal time. |
85 (setq time (date-to-time time))) | 155 (setq time (date-to-time time))) |
86 (let* ((current (current-time)) | 156 (time-subtract (current-time) time)) |
87 (rest (when (< (nth 1 current) (nth 1 time)) | |
88 (expt 2 16)))) | |
89 (list (- (+ (car current) (if rest -1 0)) (car time)) | |
90 (- (+ (or rest 0) (nth 1 current)) (nth 1 time))))) | |
91 | 157 |
92 ;;;###autoload | 158 ;;;###autoload |
93 (defalias 'subtract-time 'time-subtract) | 159 (defalias 'subtract-time 'time-subtract) |
94 | 160 |
95 ;;;###autoload | 161 ;;;###autoload |
96 (defun time-subtract (t1 t2) | 162 (defun time-subtract (t1 t2) |
97 "Subtract two time values. | 163 "Subtract two time values. |
98 Return the difference in the format of a time value." | 164 Return the difference in the format of a time value." |
99 (let ((borrow (< (cadr t1) (cadr t2)))) | 165 (with-decoded-time-value ((high low micro type t1) |
100 (list (- (car t1) (car t2) (if borrow 1 0)) | 166 (high2 low2 micro2 type2 t2)) |
101 (- (+ (if borrow 65536 0) (cadr t1)) (cadr t2))))) | 167 (setq high (- high high2) |
168 low (- low low2) | |
169 micro (- micro micro2) | |
170 type (max type type2)) | |
171 (when (< micro 0) | |
172 (setq low (1- low) | |
173 micro (+ micro 1000000))) | |
174 (when (< low 0) | |
175 (setq high (1- high) | |
176 low (+ low 65536))) | |
177 (encode-time-value high low micro type))) | |
102 | 178 |
103 ;;;###autoload | 179 ;;;###autoload |
104 (defun time-add (t1 t2) | 180 (defun time-add (t1 t2) |
105 "Add two time values. One should represent a time difference." | 181 "Add two time values. One should represent a time difference." |
106 (let ((high (car t1)) | 182 (with-decoded-time-value ((high low micro type t1) |
107 (low (if (consp (cdr t1)) (nth 1 t1) (cdr t1))) | 183 (high2 low2 micro2 type2 t2)) |
108 (micro (if (numberp (car-safe (cdr-safe (cdr t1)))) | 184 (setq high (+ high high2) |
109 (nth 2 t1) | 185 low (+ low low2) |
110 0)) | 186 micro (+ micro micro2) |
111 (high2 (car t2)) | 187 type (max type type2)) |
112 (low2 (if (consp (cdr t2)) (nth 1 t2) (cdr t2))) | 188 (when (>= micro 1000000) |
113 (micro2 (if (numberp (car-safe (cdr-safe (cdr t2)))) | 189 (setq low (1+ low) |
114 (nth 2 t2) | 190 micro (- micro 1000000))) |
115 0))) | 191 (when (>= low 65536) |
116 ;; Add | 192 (setq high (1+ high) |
117 (setq micro (+ micro micro2)) | 193 low (- low 65536))) |
118 (setq low (+ low low2)) | 194 (encode-time-value high low micro type))) |
119 (setq high (+ high high2)) | |
120 | |
121 ;; Normalize | |
122 ;; `/' rounds towards zero while `mod' returns a positive number, | |
123 ;; so we can't rely on (= a (+ (* 100 (/ a 100)) (mod a 100))). | |
124 (setq low (+ low (/ micro 1000000) (if (< micro 0) -1 0))) | |
125 (setq micro (mod micro 1000000)) | |
126 (setq high (+ high (/ low 65536) (if (< low 0) -1 0))) | |
127 (setq low (logand low 65535)) | |
128 | |
129 (list high low micro))) | |
130 | 195 |
131 ;;;###autoload | 196 ;;;###autoload |
132 (defun date-to-day (date) | 197 (defun date-to-day (date) |
133 "Return the number of days between year 1 and DATE. | 198 "Return the number of days between year 1 and DATE. |
134 DATE should be a date-time string." | 199 DATE should be a date-time string." |
147 (not (zerop (% year 100)))) | 212 (not (zerop (% year 100)))) |
148 (zerop (% year 400)))) | 213 (zerop (% year 400)))) |
149 | 214 |
150 ;;;###autoload | 215 ;;;###autoload |
151 (defun time-to-day-in-year (time) | 216 (defun time-to-day-in-year (time) |
152 "Return the day number within the year of the date month/day/year." | 217 "Return the day number within the year corresponding to TIME." |
153 (let* ((tim (decode-time time)) | 218 (let* ((tim (decode-time time)) |
154 (month (nth 4 tim)) | 219 (month (nth 4 tim)) |
155 (day (nth 3 tim)) | 220 (day (nth 3 tim)) |
156 (year (nth 5 tim)) | 221 (year (nth 5 tim)) |
157 (day-of-year (+ day (* 31 (1- month))))) | 222 (day-of-year (+ day (* 31 (1- month))))) |
174 (* 365 (1- year)) ; + Days in prior years | 239 (* 365 (1- year)) ; + Days in prior years |
175 (/ (1- year) 4) ; + Julian leap years | 240 (/ (1- year) 4) ; + Julian leap years |
176 (- (/ (1- year) 100)) ; - century years | 241 (- (/ (1- year) 100)) ; - century years |
177 (/ (1- year) 400)))) ; + Gregorian leap years | 242 (/ (1- year) 400)))) ; + Gregorian leap years |
178 | 243 |
244 (defun time-to-number-of-days (time) | |
245 "Return the number of days represented by TIME. | |
246 The number of days will be returned as a floating point number." | |
247 (/ (time-to-seconds time) (* 60 60 24))) | |
248 | |
179 ;;;###autoload | 249 ;;;###autoload |
180 (defun safe-date-to-time (date) | 250 (defun safe-date-to-time (date) |
181 "Parse a string that represents a date-time and return a time value. | 251 "Parse a string that represents a date-time and return a time value. |
182 If DATE is malformed, return a time value of zeros." | 252 If DATE is malformed, return a time value of zeros." |
183 (condition-case () | 253 (condition-case () |
184 (date-to-time date) | 254 (date-to-time date) |
185 (error '(0 0)))) | 255 (error '(0 0)))) |
186 | 256 |
187 (provide 'time-date) | 257 (provide 'time-date) |
188 | 258 |
259 ;;; arch-tag: addcf07b-b20a-465b-af72-550b8ac5190f | |
189 ;;; time-date.el ends here | 260 ;;; time-date.el ends here |