Line data Source code
1 : ;;; time-date.el --- Date and time handling functions
2 :
3 : ;; Copyright (C) 1998-2017 Free Software Foundation, Inc.
4 :
5 : ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
6 : ;; Masanobu Umeda <umerin@mse.kyutech.ac.jp>
7 : ;; Keywords: mail news util
8 :
9 : ;; This file is part of GNU Emacs.
10 :
11 : ;; GNU Emacs is free software: you can redistribute it and/or modify
12 : ;; it under the terms of the GNU General Public License as published by
13 : ;; the Free Software Foundation, either version 3 of the License, or
14 : ;; (at your option) any later version.
15 :
16 : ;; GNU Emacs is distributed in the hope that it will be useful,
17 : ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18 : ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19 : ;; GNU General Public License for more details.
20 :
21 : ;; You should have received a copy of the GNU General Public License
22 : ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
23 :
24 : ;;; Commentary:
25 :
26 : ;; Time values come in several formats. The oldest format is a cons
27 : ;; cell of the form (HIGH . LOW). This format is obsolete, but still
28 : ;; supported. The other formats are the lists (HIGH LOW), (HIGH LOW
29 : ;; USEC), and (HIGH LOW USEC PSEC). These formats specify the time
30 : ;; value equal to HIGH * 2^16 + LOW + USEC * 10^-6 + PSEC * 10^-12
31 : ;; seconds, where missing components are treated as zero. HIGH can be
32 : ;; negative, either because the value is a time difference, or because
33 : ;; it represents a time stamp before the epoch. Typically, there are
34 : ;; more time values than the underlying system time type supports,
35 : ;; but the reverse can also be true.
36 :
37 : ;;; Code:
38 :
39 : (defmacro with-decoded-time-value (varlist &rest body)
40 : "Decode a time value and bind it according to VARLIST, then eval BODY.
41 :
42 : The value of the last form in BODY is returned.
43 :
44 : Each element of the list VARLIST is a list of the form
45 : \(HIGH-SYMBOL LOW-SYMBOL MICRO-SYMBOL [PICO-SYMBOL [TYPE-SYMBOL]] TIME-VALUE).
46 : The time value TIME-VALUE is decoded and the result is bound to
47 : the symbols HIGH-SYMBOL, LOW-SYMBOL and MICRO-SYMBOL.
48 : The optional PICO-SYMBOL is bound to the picoseconds part.
49 :
50 : The optional TYPE-SYMBOL is bound to the type of the time value.
51 : Type 0 is the cons cell (HIGH . LOW), type 1 is the list (HIGH
52 : LOW), type 2 is the list (HIGH LOW MICRO), and type 3 is the
53 : list (HIGH LOW MICRO PICO)."
54 : (declare (indent 1)
55 : (debug ((&rest (symbolp symbolp symbolp
56 : &or [symbolp symbolp form] [symbolp form] form))
57 : body)))
58 0 : (if varlist
59 0 : (let* ((elt (pop varlist))
60 0 : (high (pop elt))
61 0 : (low (pop elt))
62 0 : (micro (pop elt))
63 0 : (pico (unless (<= (length elt) 2)
64 0 : (pop elt)))
65 0 : (type (unless (eq (length elt) 1)
66 0 : (pop elt)))
67 0 : (time-value (car elt))
68 0 : (gensym (make-symbol "time")))
69 0 : `(let* ,(append `((,gensym (or ,time-value (current-time)))
70 0 : (,gensym
71 : (cond
72 0 : ((integerp ,gensym)
73 0 : (list (ash ,gensym -16)
74 0 : (logand ,gensym 65535)))
75 0 : ((floatp ,gensym)
76 0 : (let* ((usec (* 1000000 (mod ,gensym 1)))
77 : (ps (round (* 1000000 (mod usec 1))))
78 : (us (floor usec))
79 0 : (lo (floor (mod ,gensym 65536)))
80 0 : (hi (floor ,gensym 65536)))
81 : (if (eq ps 1000000)
82 : (progn
83 : (setq ps 0)
84 : (setq us (1+ us))
85 : (if (eq us 1000000)
86 : (progn
87 : (setq us 0)
88 : (setq lo (1+ lo))
89 : (if (eq lo 65536)
90 : (progn
91 : (setq lo 0)
92 : (setq hi (1+ hi))))))))
93 : (list hi lo us ps)))
94 0 : (t ,gensym)))
95 0 : (,high (pop ,gensym))
96 0 : ,low ,micro)
97 0 : (when pico `(,pico))
98 0 : (when type `(,type)))
99 0 : (if (consp ,gensym)
100 : (progn
101 0 : (setq ,low (pop ,gensym))
102 0 : (if ,gensym
103 : (progn
104 0 : (setq ,micro (car ,gensym))
105 0 : ,(cond (pico
106 0 : `(if (cdr ,gensym)
107 0 : ,(append `(setq ,pico (cadr ,gensym))
108 0 : (when type `(,type 3)))
109 0 : ,(append `(setq ,pico 0)
110 0 : (when type `(,type 2)))))
111 0 : (type
112 0 : `(setq type 2))))
113 0 : ,(append `(setq ,micro 0)
114 0 : (when pico `(,pico 0))
115 0 : (when type `(,type 1)))))
116 0 : ,(append `(setq ,low ,gensym ,micro 0)
117 0 : (when pico `(,pico 0))
118 0 : (when type `(,type 0))))
119 0 : (with-decoded-time-value ,varlist ,@body)))
120 0 : `(progn ,@body)))
121 :
122 : (defun encode-time-value (high low micro pico &optional type)
123 : "Encode HIGH, LOW, MICRO, and PICO into a time value of type TYPE.
124 : Type 0 is the cons cell (HIGH . LOW), type 1 is the list (HIGH LOW),
125 : type 2 is (HIGH LOW MICRO), and type 3 is (HIGH LOW MICRO PICO).
126 :
127 : For backward compatibility, if only four arguments are given,
128 : it is assumed that PICO was omitted and should be treated as zero."
129 0 : (when (null type)
130 0 : (setq type pico)
131 0 : (setq pico 0))
132 0 : (cond
133 0 : ((eq type 0) (cons high low))
134 0 : ((eq type 1) (list high low))
135 0 : ((eq type 2) (list high low micro))
136 0 : ((eq type 3) (list high low micro pico))))
137 :
138 : (make-obsolete 'encode-time-value nil "25.1")
139 : (make-obsolete 'with-decoded-time-value nil "25.1")
140 :
141 : (autoload 'parse-time-string "parse-time")
142 : (autoload 'timezone-make-date-arpa-standard "timezone")
143 :
144 : ;;;###autoload
145 : ;; `parse-time-string' isn't sufficiently general or robust. It fails
146 : ;; to grok some of the formats that timezone does (e.g. dodgy
147 : ;; post-2000 stuff from some Elms) and either fails or returns bogus
148 : ;; values. timezone-make-date-arpa-standard should help.
149 : (defun date-to-time (date)
150 : "Parse a string DATE that represents a date-time and return a time value.
151 : If DATE lacks timezone information, GMT is assumed."
152 0 : (condition-case err
153 0 : (apply 'encode-time (parse-time-string date))
154 : (error
155 0 : (let ((overflow-error '(error "Specified time is not representable")))
156 0 : (if (equal err overflow-error)
157 0 : (apply 'signal err)
158 0 : (condition-case err
159 0 : (apply 'encode-time
160 0 : (parse-time-string
161 0 : (timezone-make-date-arpa-standard date)))
162 : (error
163 0 : (if (equal err overflow-error)
164 0 : (apply 'signal err)
165 0 : (error "Invalid date: %s" date)))))))))
166 :
167 : ;;;###autoload
168 : (defalias 'time-to-seconds 'float-time)
169 :
170 : ;;;###autoload
171 : (defun seconds-to-time (seconds)
172 : "Convert SECONDS to a time value."
173 196 : (time-add 0 seconds))
174 :
175 : ;;;###autoload
176 : (defun days-to-time (days)
177 : "Convert DAYS into a time value."
178 0 : (let ((time (condition-case nil (seconds-to-time (* 86400.0 days))
179 0 : (range-error (list most-positive-fixnum 65535)))))
180 0 : (if (integerp days)
181 0 : (setcdr (cdr time) nil))
182 0 : time))
183 :
184 : ;;;###autoload
185 : (defun time-since (time)
186 : "Return the time elapsed since TIME.
187 : TIME should be either a time value or a date-time string."
188 0 : (when (stringp time)
189 : ;; Convert date strings to internal time.
190 0 : (setq time (date-to-time time)))
191 0 : (time-subtract nil time))
192 :
193 : ;;;###autoload
194 : (define-obsolete-function-alias 'subtract-time 'time-subtract "26.1")
195 :
196 : ;;;###autoload
197 : (defun date-to-day (date)
198 : "Return the number of days between year 1 and DATE.
199 : DATE should be a date-time string."
200 0 : (time-to-days (date-to-time date)))
201 :
202 : ;;;###autoload
203 : (defun days-between (date1 date2)
204 : "Return the number of days between DATE1 and DATE2.
205 : DATE1 and DATE2 should be date-time strings."
206 0 : (- (date-to-day date1) (date-to-day date2)))
207 :
208 : ;;;###autoload
209 : (defun date-leap-year-p (year)
210 : "Return t if YEAR is a leap year."
211 0 : (or (and (zerop (% year 4))
212 0 : (not (zerop (% year 100))))
213 0 : (zerop (% year 400))))
214 :
215 : (defun time-date--day-in-year (tim)
216 : "Return the day number within the year corresponding to the decoded time TIM."
217 0 : (let* ((month (nth 4 tim))
218 0 : (day (nth 3 tim))
219 0 : (year (nth 5 tim))
220 0 : (day-of-year (+ day (* 31 (1- month)))))
221 0 : (when (> month 2)
222 0 : (setq day-of-year (- day-of-year (/ (+ 23 (* 4 month)) 10)))
223 0 : (when (date-leap-year-p year)
224 0 : (setq day-of-year (1+ day-of-year))))
225 0 : day-of-year))
226 :
227 : ;;;###autoload
228 : (defun time-to-day-in-year (time)
229 : "Return the day number within the year corresponding to TIME."
230 0 : (time-date--day-in-year (decode-time time)))
231 :
232 : ;;;###autoload
233 : (defun time-to-days (time)
234 : "The number of days between the Gregorian date 0001-12-31bce and TIME.
235 : TIME should be a time value.
236 : The Gregorian date Sunday, December 31, 1bce is imaginary."
237 0 : (let* ((tim (decode-time time))
238 0 : (year (nth 5 tim)))
239 0 : (+ (time-date--day-in-year tim) ; Days this year
240 0 : (* 365 (1- year)) ; + Days in prior years
241 0 : (/ (1- year) 4) ; + Julian leap years
242 0 : (- (/ (1- year) 100)) ; - century years
243 0 : (/ (1- year) 400)))) ; + Gregorian leap years
244 :
245 : (defun time-to-number-of-days (time)
246 : "Return the number of days represented by TIME.
247 : Returns a floating point number."
248 0 : (/ (float-time time) (* 60 60 24)))
249 :
250 : ;;;###autoload
251 : (defun safe-date-to-time (date)
252 : "Parse a string DATE that represents a date-time and return a time value.
253 : If DATE is malformed, return a time value of zeros."
254 0 : (condition-case ()
255 0 : (date-to-time date)
256 0 : (error '(0 0))))
257 :
258 :
259 : ;;;###autoload
260 : (defun format-seconds (string seconds)
261 : "Use format control STRING to format the number SECONDS.
262 : The valid format specifiers are:
263 : %y is the number of (365-day) years.
264 : %d is the number of days.
265 : %h is the number of hours.
266 : %m is the number of minutes.
267 : %s is the number of seconds.
268 : %z is a non-printing control flag (see below).
269 : %% is a literal \"%\".
270 :
271 : Upper-case specifiers are followed by the unit-name (e.g. \"years\").
272 : Lower-case specifiers return only the unit.
273 :
274 : \"%\" may be followed by a number specifying a width, with an
275 : optional leading \".\" for zero-padding. For example, \"%.3Y\" will
276 : return something of the form \"001 year\".
277 :
278 : The \"%z\" specifier does not print anything. When it is used, specifiers
279 : must be given in order of decreasing size. To the left of \"%z\", nothing
280 : is output until the first non-zero unit is encountered.
281 :
282 : This function does not work for SECONDS greater than `most-positive-fixnum'."
283 0 : (let ((start 0)
284 : (units '(("y" "year" 31536000)
285 : ("d" "day" 86400)
286 : ("h" "hour" 3600)
287 : ("m" "minute" 60)
288 : ("s" "second" 1)
289 : ("z")))
290 : (case-fold-search t)
291 : spec match usedunits zeroflag larger prev name unit num zeropos)
292 0 : (while (string-match "%\\.?[0-9]*\\(.\\)" string start)
293 0 : (setq start (match-end 0)
294 0 : spec (match-string 1 string))
295 0 : (unless (string-equal spec "%")
296 0 : (or (setq match (assoc (downcase spec) units))
297 0 : (error "Bad format specifier: `%s'" spec))
298 0 : (if (assoc (downcase spec) usedunits)
299 0 : (error "Multiple instances of specifier: `%s'" spec))
300 0 : (if (string-equal (car match) "z")
301 0 : (setq zeroflag t)
302 0 : (unless larger
303 0 : (setq unit (nth 2 match)
304 0 : larger (and prev (> unit prev))
305 0 : prev unit)))
306 0 : (push match usedunits)))
307 0 : (and zeroflag larger
308 0 : (error "Units are not in decreasing order of size"))
309 0 : (dolist (u units)
310 0 : (setq spec (car u)
311 0 : name (cadr u)
312 0 : unit (nth 2 u))
313 0 : (when (string-match (format "%%\\(\\.?[0-9]+\\)?\\(%s\\)" spec) string)
314 0 : (if (string-equal spec "z") ; must be last in units
315 0 : (setq string
316 0 : (replace-regexp-in-string
317 : "%z" ""
318 0 : (substring string (min (or zeropos (match-end 0))
319 0 : (match-beginning 0)))))
320 : ;; Cf article-make-date-line in gnus-art.
321 0 : (setq num (floor seconds unit)
322 0 : seconds (- seconds (* num unit)))
323 : ;; Start position of the first non-zero unit.
324 0 : (or zeropos
325 0 : (setq zeropos (unless (zerop num) (match-beginning 0))))
326 0 : (setq string
327 0 : (replace-match
328 0 : (format (concat "%" (match-string 1 string) "d%s") num
329 0 : (if (string-equal (match-string 2 string) spec)
330 : "" ; lower-case, no unit-name
331 0 : (format " %s%s" name
332 0 : (if (= num 1) "" "s"))))
333 0 : t t string))))))
334 0 : (replace-regexp-in-string "%%" "%" string))
335 :
336 : (defvar seconds-to-string
337 : (list (list 1 "ms" 0.001)
338 : (list 100 "s" 1)
339 : (list (* 60 100) "m" 60.0)
340 : (list (* 3600 30) "h" 3600.0)
341 : (list (* 3600 24 400) "d" (* 3600.0 24.0))
342 : (list nil "y" (* 365.25 24 3600)))
343 : "Formatting used by the function `seconds-to-string'.")
344 : ;;;###autoload
345 : (defun seconds-to-string (delay)
346 : "Convert the time interval in seconds to a short string."
347 0 : (cond ((> 0 delay) (concat "-" (seconds-to-string (- delay))))
348 0 : ((= 0 delay) "0s")
349 0 : (t (let ((sts seconds-to-string) here)
350 0 : (while (and (car (setq here (pop sts)))
351 0 : (<= (car here) delay)))
352 0 : (concat (format "%.2f" (/ delay (car (cddr here)))) (cadr here))))))
353 :
354 : (provide 'time-date)
355 :
356 : ;;; time-date.el ends here
|