datetime.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; Name:          datetime.lisp
   6 ;;;; Purpose:       Date & Time functions for KMRCL package
   7 ;;;; Programmer:    Kevin M. Rosenberg
   8 ;;;; Date Started:  Apr 2000
   9 ;;;;
  10 ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
  11 ;;;;
  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 ;;;; *************************************************************************
  16
  17 (in-package #:kmrcl)
  18
  19
  20 ;;; Formatting functions
  21
  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")
  28                  wkday)
  29             (elt '("January" "February" "March" "April" "May" "June"
  30                    "July" "August" "September" "October" "November"
  31                    "December")
  32                  (1- mn))
  33             (format nil "~A" dy)
  34             (format nil "~A" yr)
  35             (format nil "~2,'0D:~2,'0D:~2,'0D" hr min sec))))
  36
  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)))
  40
  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"
  47                 dow
  48                 day
  49                 (1- mon)
  50                 year
  51                 hr min sec))))
  52
  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)))
  60
  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))))
  73                 (cond
  74                   ((plusp year)
  75                    (format nil "~Dy~DM~Dw~Dd~Dh~Dm~A" year month week day hour minute secstr))
  76                   ((plusp month)
  77                    (format nil "~DM~Dw~Dd~Dh~Dm~A" month week day hour minute secstr))
  78                   ((plusp week)
  79                    (format nil "~Dw~Dd~Dh~Dm~A" week day hour minute secstr))
  80                   ((plusp day)
  81                    (format nil "~Dd~Dh~Dm~A" day hour minute secstr))
  82                   ((plusp hour)
  83                    (format nil "~Dh~Dm~A" hour minute secstr))
  84                   ((plusp minute)
  85                    (format nil "~Dm~A" minute secstr))
  86                   (t
  87                    secstr))))))))))
  88
  89 (defun print-seconds (secs)
  90   (print-float-units secs "sec"))
  91
  92 (defun print-float-units (val unit)
  93   (cond
  94     ((< val 1d-6)
  95      (format t "~,2,9F nano~A" val unit))
  96     ((< val 1d-3)
  97      (format t "~,2,6F micro~A" val unit))
  98     ((< val 1)
  99      (format t "~,2,3F milli~A" val unit))
 100     ((> val 1d9)
 101      (format t "~,2,-9F giga~A" val unit))
 102     ((> val 1d6)
 103      (format t "~,2,-6F mega~A" val unit))
 104     ((> val 1d3)
 105      (format t "~,2,-3F kilo~A" val unit))
 106     (t
 107      (format t "~,2F ~A" val unit))))
 108
 109 (defconstant +posix-epoch+
 110   (encode-universal-time 0 0 0 1 1 1970 0))
 111
 112 (defun posix-time-to-utime (time)
 113   (+ time +posix-epoch+))
 114
 115 (defun utime-to-posix-time (utime)
 116   (- utime +posix-epoch+))
 117
 118 ;; Monthnames taken from net-telent-date to support lml2
 119
 120 (defvar *monthnames*
 121   '((1 . "January")
 122     (2 . "February")
 123     (3 . "March")
 124     (4 . "April")
 125     (5 . "May")
 126     (6 . "June")
 127     (7 . "July")
 128     (8 . "August")
 129     (9 . "September")
 130     (10 . "October")
 131     (11 . "November")
 132     (12 . "December")))
 133
 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)))
 140       (format stream
 141               (if at-p "~V,V,V,V@A" "~V,V,V,VA")
 142               mincol colinc minpad padchar
 143               (subseq monthstring 0 truncate)))))
 144
 145 (defconstant* +zellers-adj+ #(0 3 2 5 0 3 5 1 4 6 2 4))
 146
 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)."
 151
 152   (when (< month 3)
 153     (decf year))
 154   (mod
 155    (+ year (floor year 4) (- (floor year 100)) (floor year 400)
 156       (aref +zellers-adj+ (1- month)) day)
 157    7))
 158
 159 ;;;; Daylight Saving Time calculations
 160
 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.
 165
 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.
 170
 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.
 174
 175 ;; United States                  European Union
 176
 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
 190
 191