/usr/share/common-lisp/source/kmrcl/datetime.lisp is in cl-kmrcl 1.106-1.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 | ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
;;;; *************************************************************************
;;;; FILE IDENTIFICATION
;;;;
;;;; Name: datetime.lisp
;;;; Purpose: Date & Time functions for KMRCL package
;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Apr 2000
;;;;
;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
;;;;
;;;; KMRCL users are granted the rights to distribute and use this software
;;;; as governed by the terms of the Lisp Lesser GNU Public License
;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
;;;; *************************************************************************
(in-package #:kmrcl)
;;; Formatting functions
(defun pretty-date (year month day &optional (hour 12) (m 0) (s 0))
(multiple-value-bind (sec min hr dy mn yr wkday)
(decode-universal-time
(encode-universal-time s m hour day month year))
(values (elt '("Monday" "Tuesday" "Wednesday" "Thursday"
"Friday" "Saturday" "Sunday")
wkday)
(elt '("January" "February" "March" "April" "May" "June"
"July" "August" "September" "October" "November"
"December")
(1- mn))
(format nil "~A" dy)
(format nil "~A" yr)
(format nil "~2,'0D:~2,'0D:~2,'0D" hr min sec))))
(defun pretty-date-ut (&optional (tm (get-universal-time)))
(multiple-value-bind (sec min hr dy mn yr) (decode-universal-time tm)
(pretty-date yr mn dy hr min sec)))
(defun date-string (&optional (ut (get-universal-time)))
(if (typep ut 'integer)
(multiple-value-bind (sec min hr day mon year dow daylight-p zone)
(decode-universal-time ut)
(declare (ignore daylight-p zone))
(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"
dow
day
(1- mon)
year
hr min sec))))
(eval-when (:compile-toplevel :load-toplevel :execute)
(defconstant +minute-seconds+ 60)
(defconstant +hour-seconds+ (* 60 +minute-seconds+))
(defconstant +day-seconds+ (* 24 +hour-seconds+))
(defconstant +week-seconds+ (* +day-seconds+ 7))
(defconstant +month-seconds+ (* +day-seconds+ (/ 365.25 12)))
(defconstant +year-seconds+ (* +day-seconds+ 365.25)))
(defun seconds-to-condensed-time-string (sec &key (dp-digits 0))
"Prints a quantity of seconds as a condensed string. DP-DIGITS controls
how many digits after decimal point."
(multiple-value-bind (year yrem) (floor (coerce sec 'double-float) +year-seconds+)
(multiple-value-bind (month mrem) (floor yrem +month-seconds+)
(multiple-value-bind (week wrem) (floor mrem +week-seconds+)
(multiple-value-bind (day drem) (floor wrem +day-seconds+)
(multiple-value-bind (hour hrem) (floor drem +hour-seconds+)
(multiple-value-bind (minute minrem) (floor hrem +minute-seconds+)
(let ((secstr (if (zerop dp-digits)
(format nil "~Ds" (round minrem))
(format nil (format nil "~~,~DFs" dp-digits) minrem))))
(cond
((plusp year)
(format nil "~Dy~DM~Dw~Dd~Dh~Dm~A" year month week day hour minute secstr))
((plusp month)
(format nil "~DM~Dw~Dd~Dh~Dm~A" month week day hour minute secstr))
((plusp week)
(format nil "~Dw~Dd~Dh~Dm~A" week day hour minute secstr))
((plusp day)
(format nil "~Dd~Dh~Dm~A" day hour minute secstr))
((plusp hour)
(format nil "~Dh~Dm~A" hour minute secstr))
((plusp minute)
(format nil "~Dm~A" minute secstr))
(t
secstr))))))))))
(defun print-seconds (secs)
(print-float-units secs "sec"))
(defun print-float-units (val unit)
(cond
((< val 1d-6)
(format t "~,2,9F nano~A" val unit))
((< val 1d-3)
(format t "~,2,6F micro~A" val unit))
((< val 1)
(format t "~,2,3F milli~A" val unit))
((> val 1d9)
(format t "~,2,-9F giga~A" val unit))
((> val 1d6)
(format t "~,2,-6F mega~A" val unit))
((> val 1d3)
(format t "~,2,-3F kilo~A" val unit))
(t
(format t "~,2F ~A" val unit))))
(defconstant +posix-epoch+
(encode-universal-time 0 0 0 1 1 1970 0))
(defun posix-time-to-utime (time)
(+ time +posix-epoch+))
(defun utime-to-posix-time (utime)
(- utime +posix-epoch+))
;; Monthnames taken from net-telent-date to support lml2
(defvar *monthnames*
'((1 . "January")
(2 . "February")
(3 . "March")
(4 . "April")
(5 . "May")
(6 . "June")
(7 . "July")
(8 . "August")
(9 . "September")
(10 . "October")
(11 . "November")
(12 . "December")))
(defun monthname (stream arg colon-p at-p &optional width (mincol 0) (colinc 1) (minpad 0) (padchar #\Space))
"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"
(declare (ignore colon-p))
(let ((monthstring (cdr (assoc arg *monthnames*))))
(if (not monthstring) (return-from monthname nil))
(let ((truncate (if width (min width (length monthstring)) nil)))
(format stream
(if at-p "~V,V,V,V@A" "~V,V,V,VA")
mincol colinc minpad padchar
(subseq monthstring 0 truncate)))))
(defconstant* +zellers-adj+ #(0 3 2 5 0 3 5 1 4 6 2 4))
(defun day-of-week (year month day)
"Day of week calculation using Zeller's Congruence.
Input: The year y, month m (1 <= m <= 12) and day d (1 <= d <= 31).
Output: n - the day of the week (Sunday = 0, Saturday = 6)."
(when (< month 3)
(decf year))
(mod
(+ year (floor year 4) (- (floor year 100)) (floor year 400)
(aref +zellers-adj+ (1- month)) day)
7))
;;;; Daylight Saving Time calculations
;; Daylight Saving Time begins for most of the United States at 2
;; a.m. on the first Sunday of April. Time reverts to standard time at
;; 2 a.m. on the last Sunday of October. In the U.S., each time zone
;; switches at a different time.
;; In the European Union, Summer Time begins and ends at 1 am
;; Universal Time (Greenwich Mean Time). It starts the last Sunday in
;; March, and ends the last Sunday in October. In the EU, all time
;; zones change at the same moment.
;; Spring forward, Fall back
;; During DST, clocks are turned forward an hour, effectively moving
;; an hour of daylight from the morning to the evening.
;; United States European Union
;; Year DST Begins DST Ends Summertime Summertime
;; at 2 a.m. at 2 a.m. period begins period ends
;; at 1 a.m. UT at 1 a.m. UT
;; ----------------------------------------------------------
;; 2000 April 2 October 29 March 26 October 29
;; 2001 April 1 October 28 March 25 October 28
;; 2002 April 7 October 27 March 31 October 27
;; 2003 April 6 October 26 March 30 October 26
;; 2004 April 4 October 31 March 28 October 31
;; 2005 April 3 October 30 March 27 October 30
;; 2006 April 2 October 29 March 26 October 29
;; 2007 April 1 October 28 March 25 October 28
;; 2008 April 6 October 26 March 30 October 26
|