lisp/calendar/time-date.el

   1 ;;; time-date.el --- Date and time handling functions
   2
   3 ;; Copyright (C) 1998-2020 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 <https://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 (require 'cl-lib)
  40 (require 'subr-x)
  41
  42 (defmacro with-decoded-time-value (varlist &rest body)
  43   "Decode a time value and bind it according to VARLIST, then eval BODY.
  44
  45 The value of the last form in BODY is returned.
  46
  47 Each element of the list VARLIST is a list of the form
  48 \(HIGH-SYMBOL LOW-SYMBOL MICRO-SYMBOL [PICO-SYMBOL [TYPE-SYMBOL]] TIME-VALUE).
  49 The time value TIME-VALUE is decoded and the result is bound to
  50 the symbols HIGH-SYMBOL, LOW-SYMBOL and MICRO-SYMBOL.
  51 The optional PICO-SYMBOL is bound to the picoseconds part.
  52
  53 The optional TYPE-SYMBOL is bound to the type of the time value.
  54 Type 0 is the cons cell (HIGH . LOW), type 1 is the list (HIGH
  55 LOW), type 2 is the list (HIGH LOW MICRO), and type 3 is the
  56 list (HIGH LOW MICRO PICO)."
  57   (declare (indent 1)
  58            (debug ((&rest (symbolp symbolp symbolp
  59                            &or [symbolp symbolp form] [symbolp form] form))
  60                    body)))
  61   (if varlist
  62       (let* ((elt (pop varlist))
  63              (high (pop elt))
  64              (low (pop elt))
  65              (micro (pop elt))
  66              (pico (unless (<= (length elt) 2)
  67                      (pop elt)))
  68              (type (unless (eq (length elt) 1)
  69                      (pop elt)))
  70              (time-value (car elt))
  71              (gensym (make-symbol "time")))
  72         `(let* ,(append `((,gensym (or ,time-value (current-time)))
  73                           (,gensym
  74                            (cond
  75                             ((integerp ,gensym)
  76                              (list (ash ,gensym -16)
  77                                    (logand ,gensym 65535)))
  78                             ((floatp ,gensym)
  79                              (let* ((usec (* 1000000 (mod ,gensym 1)))
  80                                     (ps (round (* 1000000 (mod usec 1))))
  81                                     (us (floor usec))
  82                                     (lo (floor (mod ,gensym 65536)))
  83                                     (hi (floor ,gensym 65536)))
  84                                (if (eq ps 1000000)
  85                                    (progn
  86                                      (setq ps 0)
  87                                      (setq us (1+ us))
  88                                      (if (eq us 1000000)
  89                                          (progn
  90                                            (setq us 0)
  91                                            (setq lo (1+ lo))
  92                                            (if (eq lo 65536)
  93                                                (progn
  94                                                  (setq lo 0)
  95                                                  (setq hi (1+ hi))))))))
  96                                (list hi lo us ps)))
  97                             (t ,gensym)))
  98                           (,high (pop ,gensym))
  99                           ,low ,micro)
 100                         (when pico `(,pico))
 101                         (when type `(,type)))
 102            (if (consp ,gensym)
 103                (progn
 104                  (setq ,low (pop ,gensym))
 105                  (if ,gensym
 106                      (progn
 107                        (setq ,micro (car ,gensym))
 108                        ,(cond (pico
 109                                `(if (cdr ,gensym)
 110                                     ,(append `(setq ,pico (cadr ,gensym))
 111                                              (when type `(,type 3)))
 112                                   ,(append `(setq ,pico 0)
 113                                            (when type `(,type 2)))))
 114                               (type
 115                                `(setq type 2))))
 116                    ,(append `(setq ,micro 0)
 117                             (when pico `(,pico 0))
 118                             (when type `(,type 1)))))
 119              ,(append `(setq ,low ,gensym ,micro 0)
 120                       (when pico `(,pico 0))
 121                       (when type `(,type 0))))
 122            (with-decoded-time-value ,varlist ,@body)))
 123     `(progn ,@body)))
 124
 125 (defun encode-time-value (high low micro pico &optional type)
 126   "Encode HIGH, LOW, MICRO, and PICO into a time value of type TYPE.
 127 Type 0 is the cons cell (HIGH . LOW), type 1 is the list (HIGH LOW),
 128 type 2 is (HIGH LOW MICRO), and type 3 is (HIGH LOW MICRO PICO).
 129
 130 For backward compatibility, if only four arguments are given,
 131 it is assumed that PICO was omitted and should be treated as zero."
 132   (when (null type)
 133     (setq type pico)
 134     (setq pico 0))
 135   (cond
 136    ((eq type 0) (cons high low))
 137    ((eq type 1) (list high low))
 138    ((eq type 2) (list high low micro))
 139    ((eq type 3) (list high low micro pico))))
 140
 141 (make-obsolete 'encode-time-value nil "25.1")
 142 (make-obsolete 'with-decoded-time-value nil "25.1")
 143
 144 (autoload 'parse-time-string "parse-time")
 145 (autoload 'timezone-make-date-arpa-standard "timezone")
 146
 147 ;;;###autoload
 148 ;; `parse-time-string' isn't sufficiently general or robust.  It fails
 149 ;; to grok some of the formats that timezone does (e.g. dodgy
 150 ;; post-2000 stuff from some Elms) and either fails or returns bogus
 151 ;; values.  timezone-make-date-arpa-standard should help.
 152 (defun date-to-time (date)
 153   "Parse a string DATE that represents a date-time and return a time value.
 154 DATE should be in one of the forms recognized by `parse-time-string'.
 155 If DATE lacks timezone information, GMT is assumed."
 156   (condition-case err
 157       (encode-time (parse-time-string date))
 158     (error
 159      (let ((overflow-error '(error "Specified time is not representable")))
 160        (if (equal err overflow-error)
 161            (signal (car err) (cdr err))
 162          (condition-case err
 163              (encode-time (parse-time-string
 164                            (timezone-make-date-arpa-standard date)))
 165            (error
 166             (if (equal err overflow-error)
 167                 (signal (car err) (cdr err))
 168               (error "Invalid date: %s" date)))))))))
 169
 170 ;;;###autoload
 171 (defalias 'time-to-seconds 'float-time)
 172
 173 ;;;###autoload
 174 (defalias 'seconds-to-time 'time-convert)
 175
 176 ;;;###autoload
 177 (defun days-to-time (days)
 178   "Convert DAYS into a time value."
 179   (let ((time (time-convert (* 86400 days))))
 180     ;; Traditionally, this returned a two-element list if DAYS was an integer.
 181     ;; Keep that tradition if time-convert outputs timestamps in list form.
 182     (if (and (integerp days) (consp (cdr time)))
 183         (setcdr (cdr time) nil))
 184     time))
 185
 186 ;;;###autoload
 187 (defun time-since (time)
 188   "Return the time elapsed since TIME.
 189 TIME should be either a time value or a date-time string."
 190   (when (stringp time)
 191     ;; Convert date strings to internal time.
 192     (setq time (date-to-time time)))
 193   (time-subtract nil time))
 194
 195 ;;;###autoload
 196 (define-obsolete-function-alias 'subtract-time 'time-subtract "26.1")
 197
 198 ;;;###autoload
 199 (defun date-to-day (date)
 200   "Return the absolute date of DATE, a date-time string.
 201 The absolute date is the number of days elapsed since the imaginary
 202 Gregorian date Sunday, December 31, 1 BC."
 203   (time-to-days (date-to-time date)))
 204
 205 ;;;###autoload
 206 (defun days-between (date1 date2)
 207   "Return the number of days between DATE1 and DATE2.
 208 DATE1 and DATE2 should be date-time strings."
 209   (- (date-to-day date1) (date-to-day date2)))
 210
 211 ;;;###autoload
 212 (defun date-leap-year-p (year)
 213   "Return t if YEAR is a leap year."
 214   (or (and (zerop (% year 4))
 215            (not (zerop (% year 100))))
 216       (zerop (% year 400))))
 217
 218 (defun time-date--day-in-year (tim)
 219   "Return the day number within the year corresponding to the decoded time TIM."
 220   (let* ((month (decoded-time-month tim))
 221          (day (decoded-time-day tim))
 222          (year (decoded-time-year tim))
 223          (day-of-year (+ day (* 31 (1- month)))))
 224     (when (> month 2)
 225       (setq day-of-year (- day-of-year (/ (+ 23 (* 4 month)) 10)))
 226       (when (date-leap-year-p year)
 227         (setq day-of-year (1+ day-of-year))))
 228     day-of-year))
 229
 230 ;;;###autoload
 231 (defun time-to-day-in-year (time)
 232   "Return the day number within the year corresponding to TIME."
 233   (time-date--day-in-year (decode-time time)))
 234
 235 ;;;###autoload
 236 (defun time-to-days (time)
 237   "The absolute date corresponding to TIME, a time value.
 238 The absolute date is the number of days elapsed since the imaginary
 239 Gregorian date Sunday, December 31, 1 BC."
 240   (let* ((tim (decode-time time))
 241          (year (decoded-time-year tim)))
 242     (+ (time-date--day-in-year tim)     ;       Days this year
 243        (* 365 (1- year))                ;       + Days in prior years
 244        (/ (1- year) 4)                  ;       + Julian leap years
 245        (- (/ (1- year) 100))            ;       - century years
 246        (/ (1- year) 400))))             ;       + Gregorian leap years
 247
 248 (defun time-to-number-of-days (time)
 249   "Return the number of days represented by TIME.
 250 Returns a floating point number."
 251   (/ (float-time time) (* 60 60 24)))
 252
 253 ;;;###autoload
 254 (defun safe-date-to-time (date)
 255   "Parse a string DATE that represents a date-time and return a time value.
 256 If DATE is malformed, return a time value of zeros."
 257   (condition-case ()
 258       (date-to-time date)
 259     (error '(0 0))))
 260
 261 \f
 262 ;;;###autoload
 263 (defun format-seconds (string seconds)
 264   "Use format control STRING to format the number SECONDS.
 265 The valid format specifiers are:
 266 %y is the number of (365-day) years.
 267 %d is the number of days.
 268 %h is the number of hours.
 269 %m is the number of minutes.
 270 %s is the number of seconds.
 271 %z is a non-printing control flag (see below).
 272 %% is a literal \"%\".
 273
 274 Upper-case specifiers are followed by the unit-name (e.g. \"years\").
 275 Lower-case specifiers return only the unit.
 276
 277 \"%\" may be followed by a number specifying a width, with an
 278 optional leading \".\" for zero-padding.  For example, \"%.3Y\" will
 279 return something of the form \"001 year\".
 280
 281 The \"%z\" specifier does not print anything.  When it is used, specifiers
 282 must be given in order of decreasing size.  To the left of \"%z\", nothing
 283 is output until the first non-zero unit is encountered."
 284   (let ((start 0)
 285         (units '(("y" "year"   31536000)
 286                  ("d" "day"       86400)
 287                  ("h" "hour"       3600)
 288                  ("m" "minute"       60)
 289                  ("s" "second"        1)
 290                  ("z")))
 291         (case-fold-search t)
 292         spec match usedunits zeroflag larger prev name unit num zeropos)
 293     (while (string-match "%\\.?[0-9]*\\(.\\)" string start)
 294       (setq start (match-end 0)
 295             spec (match-string 1 string))
 296       (unless (string-equal spec "%")
 297         (or (setq match (assoc (downcase spec) units))
 298             (error "Bad format specifier: `%s'" spec))
 299         (if (assoc (downcase spec) usedunits)
 300             (error "Multiple instances of specifier: `%s'" spec))
 301         (if (string-equal (car match) "z")
 302             (setq zeroflag t)
 303           (unless larger
 304             (setq unit (nth 2 match)
 305                   larger (and prev (> unit prev))
 306                   prev unit)))
 307         (push match usedunits)))
 308     (and zeroflag larger
 309          (error "Units are not in decreasing order of size"))
 310     (setq seconds (time-convert seconds 'integer))
 311     (dolist (u units)
 312       (setq spec (car u)
 313             name (cadr u)
 314             unit (nth 2 u))
 315       (when (string-match (format "%%\\(\\.?[0-9]+\\)?\\(%s\\)" spec) string)
 316         (if (string-equal spec "z")     ; must be last in units
 317             (setq string
 318                   (replace-regexp-in-string
 319                    "%z" ""
 320                    (substring string (min (or zeropos (match-end 0))
 321                                           (match-beginning 0)))))
 322           ;; Cf article-make-date-line in gnus-art.
 323           (setq num (floor seconds unit)
 324                 seconds (- seconds (* num unit)))
 325           ;; Start position of the first non-zero unit.
 326           (or zeropos
 327               (setq zeropos (unless (zerop num) (match-beginning 0))))
 328           (setq string
 329                 (replace-match
 330                  (format (concat "%" (match-string 1 string) "d%s") num
 331                          (if (string-equal (match-string 2 string) spec)
 332                              ""       ; lower-case, no unit-name
 333                            (format " %s%s" name
 334                                    (if (= num 1) "" "s"))))
 335                  t t string))))))
 336   (replace-regexp-in-string "%%" "%" string))
 337
 338 (defvar seconds-to-string
 339   (list (list 1 "ms" 0.001)
 340         (list 100 "s" 1)
 341         (list (* 60 100) "m" 60.0)
 342         (list (* 3600 30) "h" 3600.0)
 343         (list (* 3600 24 400) "d" (* 3600.0 24.0))
 344         (list nil "y" (* 365.25 24 3600)))
 345   "Formatting used by the function `seconds-to-string'.")
 346 ;;;###autoload
 347 (defun seconds-to-string (delay)
 348   "Convert the time interval in seconds to a short string."
 349   (cond ((> 0 delay) (concat "-" (seconds-to-string (- delay))))
 350         ((= 0 delay) "0s")
 351         (t (let ((sts seconds-to-string) here)
 352              (while (and (car (setq here (pop sts)))
 353                          (<= (car here) delay)))
 354              (concat (format "%.2f" (/ delay (car (cddr here)))) (cadr here))))))
 355
 356 (defun date-days-in-month (year month)
 357   "The number of days in MONTH in YEAR."
 358   (if (= month 2)
 359       (if (date-leap-year-p year)
 360           29
 361         28)
 362     (if (memq month '(1 3 5 7 8 10 12))
 363         31
 364       30)))
 365
 366 (defun date-ordinal-to-time (year ordinal)
 367   "Convert a YEAR/ORDINAL to the equivalent `decoded-time' structure.
 368 ORDINAL is the number of days since the start of the year, with
 369 January 1st being 1."
 370   (let ((month 1))
 371     (while (> ordinal (date-days-in-month year month))
 372       (setq ordinal (- ordinal (date-days-in-month year month))
 373             month (1+ month)))
 374     (list nil nil nil ordinal month year nil nil nil)))
 375
 376 (defun decoded-time-add (time delta)
 377   "Add DELTA to TIME, both of which are `decoded-time' structures.
 378 TIME should represent a time, while DELTA should have non-nil
 379 entries only for the values that should be altered.
 380
 381 For instance, if you want to \"add two months\" to TIME, then
 382 leave all other fields but the month field in DELTA nil, and make
 383 the month field 2.  The values in DELTA can be negative.
 384
 385 If applying a month/year delta leaves the time spec invalid, it
 386 is decreased to be valid (\"add one month\" to January 31st 2019
 387 will yield a result of February 28th 2019 and \"add one year\" to
 388 February 29th 2020 will result in February 28th 2021).
 389
 390 Fields are added in a most to least significant order, so if the
 391 adjustment described above happens, it happens before adding
 392 days, hours, minutes or seconds.
 393
 394 When changing the time bits in TIME (i.e., second/minute/hour),
 395 changes in daylight saving time are not taken into account."
 396   (let ((time (copy-sequence time))
 397         seconds)
 398     ;; Years are simple.
 399     (when (decoded-time-year delta)
 400       (cl-incf (decoded-time-year time) (decoded-time-year delta)))
 401
 402     ;; Months are pretty simple.
 403     (when (decoded-time-month delta)
 404       (let ((new (+ (decoded-time-month time) (decoded-time-month delta))))
 405         (setf (decoded-time-month time) (mod new 12))
 406         (cl-incf (decoded-time-year time) (/ new 12))))
 407
 408     ;; Adjust for month length (as described in the doc string).
 409     (setf (decoded-time-day time)
 410           (min (date-days-in-month (decoded-time-year time)
 411                                    (decoded-time-month time))
 412                (decoded-time-day time)))
 413
 414     ;; Days are iterative.
 415     (when-let* ((days (decoded-time-day delta)))
 416       (let ((increase (> days 0))
 417             (days (abs days)))
 418         (while (> days 0)
 419           (decoded-time--alter-day time increase)
 420           (cl-decf days))))
 421
 422     ;; Do the time part, which is pretty simple (except for leap
 423     ;; seconds, I guess).
 424     ;; Time zone adjustments are basically the same as time adjustments.
 425     (setq seconds (time-convert (or (decoded-time-second delta) 0) t))
 426     (setq seconds
 427           (time-add seconds
 428                     (time-convert (+ (* (or (decoded-time-hour delta) 0) 3600)
 429                                      (* (or (decoded-time-minute delta) 0) 60)
 430                                      (or (decoded-time-zone delta) 0))
 431                                   (cdr seconds))))
 432
 433     (decoded-time--alter-second time seconds)
 434     time))
 435
 436 (defun decoded-time--alter-month (time increase)
 437   "Increase or decrease the month in TIME by 1."
 438   (if increase
 439       (progn
 440         (cl-incf (decoded-time-month time))
 441         (when (> (decoded-time-month time) 12)
 442           (setf (decoded-time-month time) 1)
 443           (cl-incf (decoded-time-year time))))
 444     (cl-decf (decoded-time-month time))
 445     (when (zerop (decoded-time-month time))
 446       (setf (decoded-time-month time) 12)
 447       (cl-decf (decoded-time-year time)))))
 448
 449 (defun decoded-time--alter-day (time increase)
 450   "Increase or decrease the day in TIME by 1."
 451   (if increase
 452       (progn
 453         (cl-incf (decoded-time-day time))
 454         (when (> (decoded-time-day time)
 455                  (date-days-in-month (decoded-time-year time)
 456                                      (decoded-time-month time)))
 457           (setf (decoded-time-day time) 1)
 458           (decoded-time--alter-month time t)))
 459     (cl-decf (decoded-time-day time))
 460     (when (zerop (decoded-time-day time))
 461       (decoded-time--alter-month time nil)
 462       (setf (decoded-time-day time)
 463             (date-days-in-month (decoded-time-year time)
 464                                 (decoded-time-month time))))))
 465
 466 (defun decoded-time--alter-second (time seconds)
 467   "Increase the time in TIME by SECONDS."
 468   (let* ((time-sec (time-convert (or (decoded-time-second time) 0) t))
 469          (time-hz (cdr time-sec))
 470          (old (time-add time-sec
 471                         (time-convert
 472                          (+ (* 3600 (or (decoded-time-hour time) 0))
 473                             (* 60 (or (decoded-time-minute time) 0)))
 474                          time-hz)))
 475          (new (time-convert (time-add old seconds) t))
 476          (new-hz (cdr new))
 477          (secsperday (time-convert 86400 new-hz)))
 478     ;; Hm...  DST...
 479     (while (time-less-p new 0)
 480       (decoded-time--alter-day time nil)
 481       (setq new (time-add new secsperday)))
 482     (while (not (time-less-p new secsperday))
 483       (decoded-time--alter-day time t)
 484       (setq new (time-subtract new secsperday)))
 485     (let ((sec (time-convert new 'integer)))
 486       (setf (decoded-time-second time) (time-add
 487                                         (time-convert (% sec 60) new-hz)
 488                                         (time-subtract
 489                                          new (time-convert sec new-hz)))
 490             (decoded-time-minute time) (% (/ sec 60) 60)
 491             (decoded-time-hour time) (/ sec 3600)))))
 492
 493 (cl-defun make-decoded-time (&key second minute hour
 494                                   day month year
 495                                   dst zone)
 496   "Return a `decoded-time' structure with only the keywords given filled out."
 497   (list second minute hour day month year nil dst zone))
 498
 499 (defun decoded-time-set-defaults (time &optional default-zone)
 500   "Set any nil values in `decoded-time' TIME to default values.
 501 The default value is based on January 1st, 1970 at midnight.
 502
 503 TIME is modified and returned."
 504   (unless (decoded-time-second time)
 505     (setf (decoded-time-second time) 0))
 506   (unless (decoded-time-minute time)
 507     (setf (decoded-time-minute time) 0))
 508   (unless (decoded-time-hour time)
 509     (setf (decoded-time-hour time) 0))
 510
 511   (unless (decoded-time-day time)
 512     (setf (decoded-time-day time) 1))
 513   (unless (decoded-time-month time)
 514     (setf (decoded-time-month time) 1))
 515   (unless (decoded-time-year time)
 516     (setf (decoded-time-year time) 0))
 517
 518   ;; When we don't have a time zone, default to DEFAULT-ZONE without
 519   ;; DST if DEFAULT-ZONE if given, and to unknown DST otherwise.
 520   (unless (decoded-time-zone time)
 521     (if default-zone
 522         (progn (setf (decoded-time-zone time) default-zone)
 523                (setf (decoded-time-dst time) nil))
 524       (setf (decoded-time-dst time) -1)))
 525
 526   time)
 527
 528 (provide 'time-date)
 529
 530 ;;; time-date.el ends here