LCOV - code coverage report
Current view: top level - lisp/calendar - time-date.el (source / functions) Hit Total Coverage
Test: tramp-tests-after.info Lines: 1 146 0.7 %
Date: 2017-08-30 10:12:24 Functions: 1 16 6.2 %

          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

Generated by: LCOV version 1.12