1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
2 ;;;; *************************************************************************
3 ;;;; FILE IDENTIFICATION
5 ;;;; Name: datetime.lisp
6 ;;;; Purpose: Date & Time functions for KMRCL package
7 ;;;; Programmer: Kevin M. Rosenberg
8 ;;;; Date Started: Apr 2000
10 ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
12 ;;;; KMRCL users are granted the rights to distribute and use this software
13 ;;;; as governed by the terms of the Lisp Lesser GNU Public License
14 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
15 ;;;; *************************************************************************
20 ;;; Formatting functions
22 (defun pretty-date (year month day &optional (hour 12) (m 0) (s 0))
23 (multiple-value-bind (sec min hr dy mn yr wkday)
24 (decode-universal-time
25 (encode-universal-time s m hour day month year))
26 (values (elt '("Monday" "Tuesday" "Wednesday" "Thursday"
27 "Friday" "Saturday" "Sunday")
29 (elt '("January" "February" "March" "April" "May" "June"
30 "July" "August" "September" "October" "November"
35 (format nil "~2,'0D:~2,'0D:~2,'0D" hr min sec))))
37 (defun pretty-date-ut (&optional (tm (get-universal-time)))
38 (multiple-value-bind (sec min hr dy mn yr) (decode-universal-time tm)
39 (pretty-date yr mn dy hr min sec)))
41 (defun date-string (&optional (ut (get-universal-time)))
42 (if (typep ut 'integer)
43 (multiple-value-bind (sec min hr day mon year dow daylight-p zone)
44 (decode-universal-time ut)
45 (declare (ignore daylight-p zone))
46 (format nil "~[Mon~;Tue~;Wed~;Thu~;Fri~;Sat~;Sun~] ~d ~[Jan~;Feb~;Mar~;Apr~;May~;Jun~;Jul~;Aug~;Sep~;Oct~;Nov~;Dec~] ~d ~2,'0d:~2,'0d:~2,'0d"
53 (eval-when (:compile-toplevel :load-toplevel :execute)
54 (defconstant +minute-seconds+ 60)
55 (defconstant +hour-seconds+ (* 60 +minute-seconds+))
56 (defconstant +day-seconds+ (* 24 +hour-seconds+))
57 (defconstant +week-seconds+ (* +day-seconds+ 7))
58 (defconstant +month-seconds+ (* +day-seconds+ (/ 365.25 12)))
59 (defconstant +year-seconds+ (* +day-seconds+ 365.25)))
61 (defun seconds-to-condensed-time-string (sec &key (dp-digits 0))
62 "Prints a quantity of seconds as a condensed string. DP-DIGITS controls
63 how many digits after decimal point."
64 (multiple-value-bind (year yrem) (floor (coerce sec 'double-float) +year-seconds+)
65 (multiple-value-bind (month mrem) (floor yrem +month-seconds+)
66 (multiple-value-bind (week wrem) (floor mrem +week-seconds+)
67 (multiple-value-bind (day drem) (floor wrem +day-seconds+)
68 (multiple-value-bind (hour hrem) (floor drem +hour-seconds+)
69 (multiple-value-bind (minute minrem) (floor hrem +minute-seconds+)
70 (let ((secstr (if (zerop dp-digits)
71 (format nil "~Ds" (round minrem))
72 (format nil (format nil "~~,~DFs" dp-digits) minrem))))
75 (format nil "~Dy~DM~Dw~Dd~Dh~Dm~A" year month week day hour minute secstr))
77 (format nil "~DM~Dw~Dd~Dh~Dm~A" month week day hour minute secstr))
79 (format nil "~Dw~Dd~Dh~Dm~A" week day hour minute secstr))
81 (format nil "~Dd~Dh~Dm~A" day hour minute secstr))
83 (format nil "~Dh~Dm~A" hour minute secstr))
85 (format nil "~Dm~A" minute secstr))
89 (defun print-seconds (secs)
90 (print-float-units secs "sec"))
92 (defun print-float-units (val unit)
95 (format t "~,2,9F nano~A" val unit))
97 (format t "~,2,6F micro~A" val unit))
99 (format t "~,2,3F milli~A" val unit))
101 (format t "~,2,-9F giga~A" val unit))
103 (format t "~,2,-6F mega~A" val unit))
105 (format t "~,2,-3F kilo~A" val unit))
107 (format t "~,2F ~A" val unit))))
109 (defconstant +posix-epoch+
110 (encode-universal-time 0 0 0 1 1 1970 0))
112 (defun posix-time-to-utime (time)
113 (+ time +posix-epoch+))
115 (defun utime-to-posix-time (utime)
116 (- utime +posix-epoch+))
118 ;; Monthnames taken from net-telent-date to support lml2
134 (defun monthname (stream arg colon-p at-p &optional width (mincol 0) (colinc 1) (minpad 0) (padchar #\Space))
135 "Print the name of the month (1=January) corresponding to ARG on STREAM. This is intended for embedding in a FORMAT directive: WIDTH governs the number of characters of text printed, MINCOL, COLINC, MINPAD, PADCHAR work as for ~A"
136 (declare (ignore colon-p))
137 (let ((monthstring (cdr (assoc arg *monthnames*))))
138 (if (not monthstring) (return-from monthname nil))
139 (let ((truncate (if width (min width (length monthstring)) nil)))
141 (if at-p "~V,V,V,V@A" "~V,V,V,VA")
142 mincol colinc minpad padchar
143 (subseq monthstring 0 truncate)))))
145 (defconstant* +zellers-adj+ #(0 3 2 5 0 3 5 1 4 6 2 4))
147 (defun day-of-week (year month day)
148 "Day of week calculation using Zeller's Congruence.
149 Input: The year y, month m (1 <= m <= 12) and day d (1 <= d <= 31).
150 Output: n - the day of the week (Sunday = 0, Saturday = 6)."
155 (+ year (floor year 4) (- (floor year 100)) (floor year 400)
156 (aref +zellers-adj+ (1- month)) day)
159 ;;;; Daylight Saving Time calculations
161 ;; Daylight Saving Time begins for most of the United States at 2
162 ;; a.m. on the first Sunday of April. Time reverts to standard time at
163 ;; 2 a.m. on the last Sunday of October. In the U.S., each time zone
164 ;; switches at a different time.
166 ;; In the European Union, Summer Time begins and ends at 1 am
167 ;; Universal Time (Greenwich Mean Time). It starts the last Sunday in
168 ;; March, and ends the last Sunday in October. In the EU, all time
169 ;; zones change at the same moment.
171 ;; Spring forward, Fall back
172 ;; During DST, clocks are turned forward an hour, effectively moving
173 ;; an hour of daylight from the morning to the evening.
175 ;; United States European Union
177 ;; Year DST Begins DST Ends Summertime Summertime
178 ;; at 2 a.m. at 2 a.m. period begins period ends
179 ;; at 1 a.m. UT at 1 a.m. UT
180 ;; ----------------------------------------------------------
181 ;; 2000 April 2 October 29 March 26 October 29
182 ;; 2001 April 1 October 28 March 25 October 28
183 ;; 2002 April 7 October 27 March 31 October 27
184 ;; 2003 April 6 October 26 March 30 October 26
185 ;; 2004 April 4 October 31 March 28 October 31
186 ;; 2005 April 3 October 30 March 27 October 30
187 ;; 2006 April 2 October 29 March 26 October 29
188 ;; 2007 April 1 October 28 March 25 October 28
189 ;; 2008 April 6 October 26 March 30 October 26