a5dbd0f5d9
Used http://wcp.sdf-eu.org/software/sclf-20150207T213551.tbz (sha256 a231aeecdb9e87c72642292a1e083fffb33e69ec1d34e667326c6c35b8bcc794). There's no upstream repository nor a release since 2015, so importing seems to make a lot of sense. Since we can't subtree making any depot-related changes in a separate CL to make them more discoverable -- this is only the source import. Change-Id: Ia51a7f4029dba3abd1eee4eeebcf99aca5c5ba4c Reviewed-on: https://cl.tvl.fyi/c/depot/+/3376 Tested-by: BuildkiteCI Reviewed-by: grfn <grfn@gws.fyi>
311 lines
12 KiB
Common Lisp
311 lines
12 KiB
Common Lisp
;;; time.lisp --- time primitives
|
|
|
|
;;; Copyright (C) 2006, 2007, 2009 by Walter C. Pelissero
|
|
|
|
;;; Author: Walter C. Pelissero <walter@pelissero.de>
|
|
;;; Project: sclf
|
|
|
|
#+cmu (ext:file-comment "$Module: time.lisp $")
|
|
|
|
;;; This library is free software; you can redistribute it and/or
|
|
;;; modify it under the terms of the GNU Lesser General Public License
|
|
;;; as published by the Free Software Foundation; either version 2.1
|
|
;;; of the License, or (at your option) any later version.
|
|
;;; This library is distributed in the hope that it will be useful,
|
|
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
|
;;; Lesser General Public License for more details.
|
|
;;; You should have received a copy of the GNU Lesser General Public
|
|
;;; License along with this library; if not, write to the Free
|
|
;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
|
|
;;; 02111-1307 USA
|
|
|
|
(in-package :sclf)
|
|
|
|
(defun year (epoch &optional time-zone)
|
|
"Return the year of EPOCH."
|
|
(sixth (multiple-value-list (decode-universal-time epoch time-zone))))
|
|
|
|
(defun month (epoch &optional time-zone)
|
|
"Return the month of EPOCH."
|
|
(fifth (multiple-value-list (decode-universal-time epoch time-zone))))
|
|
|
|
(defun day (epoch &optional time-zone)
|
|
"Return the day of EPOCH."
|
|
(fourth (multiple-value-list (decode-universal-time epoch time-zone))))
|
|
|
|
(defun week-day (epoch &optional time-zone)
|
|
"Return the day of the week of EPOCH."
|
|
(seventh (multiple-value-list (decode-universal-time epoch time-zone))))
|
|
|
|
(defun hour (epoch &optional time-zone)
|
|
"Return the hour of EPOCH."
|
|
(third (multiple-value-list (decode-universal-time epoch time-zone))))
|
|
|
|
(defun minute (epoch &optional time-zone)
|
|
"Return the minute of EPOCH."
|
|
(second (multiple-value-list (decode-universal-time epoch time-zone))))
|
|
|
|
(defun leap-year-p (year)
|
|
"Return true if YEAR is a leap year."
|
|
(and (zerop (mod year 4))
|
|
(or (not (zerop (mod year 100)))
|
|
(zerop (mod year 400)))))
|
|
|
|
(defun last-day-of-month (month year)
|
|
"Return the last day of the month as integer."
|
|
(be last (elt #(31 28 31 30 31 30 31 31 30 31 30 31) (1- month))
|
|
(if (and (= last 28)
|
|
(leap-year-p year))
|
|
(1+ last)
|
|
last)))
|
|
|
|
(defun add-months (months epoch &optional time-zone)
|
|
"Add MONTHS to EPOCH, which is a universal time. MONTHS can be
|
|
negative."
|
|
(multiple-value-bind (ss mm hh day month year) (decode-universal-time epoch time-zone)
|
|
(multiple-value-bind (y m) (floor (+ month months -1) 12)
|
|
(let ((new-month (1+ m))
|
|
(new-year (+ year y)))
|
|
(encode-universal-time ss mm hh
|
|
(min day (last-day-of-month new-month (year epoch)))
|
|
new-month
|
|
new-year
|
|
time-zone)))))
|
|
|
|
(defun add-days (days epoch)
|
|
"Add DAYS to EPOCH, which is an universal time. DAYS can be
|
|
negative."
|
|
(+ (* 60 60 24 days) epoch))
|
|
|
|
;; The following two functions are based on Thomas Russ <tar@isi.edu>
|
|
;; code which didn't carry any copyright notice, so I assume it was in
|
|
;; the public domain.
|
|
|
|
(defun iso-time-string (time &key time-zone with-timezone-p basic)
|
|
"Return an ISO 8601 string representing TIME. The time zone is
|
|
included if WITH-TIMEZONE-P is true."
|
|
(flet ((format-timezone (zone)
|
|
(if (zerop zone)
|
|
"Z"
|
|
(multiple-value-bind (h m) (truncate (abs zone) 1.0)
|
|
;; Sign of time zone is reversed in ISO 8601 relative
|
|
;; to Common Lisp convention!
|
|
(format nil "~:[+~;-~]~2,'0D:~2,'0D"
|
|
(> zone 0) h (round m))))))
|
|
(multiple-value-bind (second minute hour day month year dow dst zone)
|
|
(decode-universal-time time time-zone)
|
|
(declare (ignore dow dst))
|
|
(if basic
|
|
(format nil "~4,'0D~2,'0D~2,'0DT~2,'0D~2,'0D~2,'0D~[~*~;~A~]"
|
|
year month day hour minute second
|
|
with-timezone-p (format-timezone zone))
|
|
(format nil "~4,'0D-~2,'0D-~2,'0DT~2,'0D:~2,'0D:~2,'0D~:[~*~;~A~]"
|
|
year month day hour minute second
|
|
with-timezone-p (format-timezone zone))))))
|
|
|
|
(defun parse-iso-time-string (time-string)
|
|
"Parse an ISO 8601 formated string and return the universal time.
|
|
It can parse the basic and the extended format, but may not be able to
|
|
cover all the cases."
|
|
(labels ((parse-delimited-string (string delimiter n)
|
|
;; Parses a delimited string and returns a list of
|
|
;; n integers found in that string.
|
|
(let ((answer (make-list n :initial-element 0)))
|
|
(loop
|
|
for i upfrom 0
|
|
for start = 0 then (1+ end)
|
|
for end = (position delimiter string :start (1+ start))
|
|
do (setf (nth i answer)
|
|
(parse-integer (subseq string start end)))
|
|
when (null end) return t)
|
|
(values-list answer)))
|
|
(parse-fixed-field-string (string field-sizes)
|
|
;; Parses a string with fixed length fields and returns
|
|
;; a list of integers found in that string.
|
|
(let ((answer (make-list (length field-sizes) :initial-element 0)))
|
|
(loop
|
|
with len = (length string)
|
|
for start = 0 then (+ start field-size)
|
|
for field-size in field-sizes
|
|
for i upfrom 0
|
|
while (< start len)
|
|
do (setf (nth i answer)
|
|
(parse-integer (subseq string start (+ start field-size)))))
|
|
(values-list answer)))
|
|
(parse-iso8601-date (date-string)
|
|
(let ((hyphen-pos (position #\- date-string)))
|
|
(if hyphen-pos
|
|
(parse-delimited-string date-string #\- 3)
|
|
(parse-fixed-field-string date-string '(4 2 2)))))
|
|
(parse-iso8601-timeonly (time-string)
|
|
(let* ((colon-pos (position #\: time-string))
|
|
(zone-pos (or (position #\- time-string)
|
|
(position #\+ time-string)))
|
|
(timeonly-string (subseq time-string 0 zone-pos))
|
|
(zone-string (when zone-pos (subseq time-string (1+ zone-pos))))
|
|
(time-zone nil))
|
|
(when zone-pos
|
|
(multiple-value-bind (zone-h zone-m)
|
|
(parse-delimited-string zone-string #\: 2)
|
|
(setq time-zone (+ zone-h (/ zone-m 60)))
|
|
(when (char= (char time-string zone-pos) #\-)
|
|
(setq time-zone (- time-zone)))))
|
|
(multiple-value-bind (hh mm ss)
|
|
(if colon-pos
|
|
(parse-delimited-string timeonly-string #\: 3)
|
|
(parse-fixed-field-string timeonly-string '(2 2 2)))
|
|
(values hh mm ss time-zone)))))
|
|
(let ((time-separator (position #\T time-string)))
|
|
(multiple-value-bind (year month date)
|
|
(parse-iso8601-date
|
|
(subseq time-string 0 time-separator))
|
|
(if time-separator
|
|
(multiple-value-bind (hh mm ss zone)
|
|
(parse-iso8601-timeonly
|
|
(subseq time-string (1+ time-separator)))
|
|
(if zone
|
|
;; Sign of time zone is reversed in ISO 8601
|
|
;; relative to Common Lisp convention!
|
|
(encode-universal-time ss mm hh date month year (- zone))
|
|
(encode-universal-time ss mm hh date month year)))
|
|
(encode-universal-time 0 0 0 date month year))))))
|
|
|
|
(defun time-string (time &optional time-zone)
|
|
"Return a string representing TIME in the form:
|
|
Tue Jan 25 12:55:40 2005"
|
|
(multiple-value-bind (ss mm hh day month year week-day)
|
|
(decode-universal-time time time-zone)
|
|
(format nil "~A ~A ~A ~D:~2,'0D:~2,'0D ~A"
|
|
(subseq (week-day->string week-day) 0 3)
|
|
(subseq (month->string month) 0 3)
|
|
day
|
|
hh mm ss
|
|
year)))
|
|
|
|
(defun beginning-of-month (month year &optional time-zone)
|
|
(encode-universal-time 0 0 0 1 month year time-zone))
|
|
|
|
(defun end-of-month (month year &optional time-zone)
|
|
(1- (add-months 1 (encode-universal-time 0 0 0 1 month year time-zone))))
|
|
|
|
(defun beginning-of-first-week (year &optional time-zone)
|
|
"Return the epoch of the first week of YEAR. As the first week
|
|
of the year needs to have Thursday in this YEAR, the returned
|
|
time can actually fall in the previous year."
|
|
(let* ((Jan-1st (encode-universal-time 0 0 0 1 1 year time-zone))
|
|
(start (- 4 (week-day (add-days 4 Jan-1st)))))
|
|
(add-days start Jan-1st)))
|
|
|
|
(defun beginning-of-week (week year &optional time-zone)
|
|
"Return the epoch of the beginning of WEEK of YEAR."
|
|
(add-days (* (1- week) 7) (beginning-of-first-week year time-zone)))
|
|
|
|
(defun end-of-week (week year &optional time-zone)
|
|
"Return the epoch of the beginning of WEEK of YEAR."
|
|
(1- (beginning-of-week (1+ week) year time-zone)))
|
|
|
|
(defun end-of-last-week (year &optional time-zone)
|
|
"Return the epoch of the last week of YEAR. As the last week
|
|
of the year needs to have Thursday in this YEAR, the returned
|
|
time can fall in the next year."
|
|
(1- (beginning-of-first-week (1+ year) time-zone)))
|
|
|
|
(defun seconds-from-beginning-of-the-year (time &optional time-zone)
|
|
(- time (encode-universal-time 0 0 0 1 1 (year time) time-zone)))
|
|
|
|
(defun day-of-the-year (time &optional time-zone)
|
|
"Return the day within the year of TIME starting from 1 up to
|
|
365 (or 366)."
|
|
(1+ (truncate (seconds-from-beginning-of-the-year time time-zone)
|
|
(* 60 60 24))))
|
|
|
|
(defun week (time &optional time-zone)
|
|
"Return the number of the week and the year TIME referes to.
|
|
Week is an integer from 1 to 52. Due to the way the first week
|
|
of the year is calculated a day in one year could actually be in
|
|
the last week of the previous or next year."
|
|
(let* ((year (year time))
|
|
(start (beginning-of-first-week year time-zone))
|
|
(days-from-start (truncate (- time start) (* 60 60 24)))
|
|
(weeks (truncate days-from-start 7))
|
|
(week-number (mod weeks 52)))
|
|
(values (1+ week-number)
|
|
(cond ((< weeks 0)
|
|
(1- year))
|
|
((> weeks 51)
|
|
(1+ year))
|
|
(t year)))))
|
|
|
|
(defun week-day->string (day &optional sunday-first)
|
|
"Return the weekday string corresponding to DAY number."
|
|
(elt (if sunday-first
|
|
#("Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday")
|
|
#("Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday" "Sunday"))
|
|
day))
|
|
|
|
(defconst +month-names+ #("January" "February" "March" "April" "May" "June" "July"
|
|
"August" "September" "October" "November" "December"))
|
|
|
|
(defun month->string (month)
|
|
"Return the month string corresponding to MONTH number."
|
|
(elt +month-names+ (1- month)))
|
|
|
|
(defun month-string->number (month)
|
|
(1+ (position month +month-names+ :test #'string-equal)))
|
|
|
|
(defun print-time-span (span &optional stream)
|
|
"Print in English the time SPAN expressed in seconds."
|
|
(let* ((minute 60)
|
|
(hour (* minute 60))
|
|
(day (* hour 24))
|
|
(seconds span))
|
|
(macrolet ((split (divisor)
|
|
`(when (>= seconds ,divisor)
|
|
(prog1 (truncate seconds ,divisor)
|
|
(setf seconds (mod seconds ,divisor))))))
|
|
(let* ((days (split day))
|
|
(hours (split hour))
|
|
(minutes (split minute)))
|
|
(format stream "~{~A~^ ~}" (remove nil
|
|
(list
|
|
(when days
|
|
(format nil "~D day~:P" days))
|
|
(when hours
|
|
(format nil "~D hour~:P" hours))
|
|
(when minutes
|
|
(format nil "~D minute~:P" minutes))
|
|
(when (or (> seconds 0)
|
|
(= span 0))
|
|
(format nil "~D second~:P" seconds)))))))))
|
|
|
|
(defun next-week-day (epoch week-day &optional time-zone)
|
|
"Return the universal time of the next WEEK-DAY starting from epoch."
|
|
(add-days (mod (- week-day (week-day epoch time-zone)) 7)
|
|
epoch))
|
|
|
|
(defun next-monday (epoch &optional time-zone)
|
|
"Return the universal time of the next Monday starting from
|
|
EPOCH."
|
|
(next-week-day epoch 0 time-zone))
|
|
|
|
(defun full-weeks-in-span (start end &optional time-zone)
|
|
"Return the number of full weeks in time span START to END. A
|
|
full week starts on Monday and ends on Sunday."
|
|
(be first-monday (next-monday start time-zone)
|
|
(truncate (- end first-monday) (* 7 24 60 60))))
|
|
|
|
(defconst +unix-lisp-time-difference+
|
|
(encode-universal-time 0 0 0 1 1 1970 0)
|
|
"Time difference between Unix epoch and Common Lisp epoch. The
|
|
former is 1st January 1970, while the latter is the beginning of the
|
|
XX century.")
|
|
|
|
(defun universal->unix-time (time)
|
|
(- time +unix-lisp-time-difference+))
|
|
|
|
(defun unix->universal-time (time)
|
|
(+ time +unix-lisp-time-difference+))
|
|
|
|
(defun get-unix-time ()
|
|
(universal->unix-time (get-universal-time)))
|