[cells-cvs] CVS cells/utils-kt
ktilton
ktilton at common-lisp.net
Wed Mar 22 20:36:38 UTC 2006
Update of /project/cells/cvsroot/cells/utils-kt
In directory clnet:/tmp/cvs-serv26836/utils-kt
Added Files:
datetime.lisp
Log Message:
--- /project/cells/cvsroot/cells/utils-kt/datetime.lisp 2006/03/22 20:36:38 NONE
+++ /project/cells/cvsroot/cells/utils-kt/datetime.lisp 2006/03/22 20:36:38 1.1
;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cello; -*-
;;;
;;;
;;; Copyright © 1995,2003 by Kenneth William Tilton.
;;;
;;; Permission is hereby granted, free of charge, to any person obtaining a copy
;;; of this software and associated documentation files (the "Software"), to deal
;;; in the Software without restriction, including without limitation the rights
;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
;;; copies of the Software, and to permit persons to whom the Software is furnished
;;; to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be included in
;;; all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
;;; IN THE SOFTWARE.
(in-package :utils-kt)
(eval-when (compile load eval)
(export '(os-tickcount time-of-day now hour-min-of-day time-in-zone dd-mmm-yy mmm-dd-yyyy)))
(defun os-tickcount ()
(cl:get-internal-real-time))
(defun now ()
(/ (get-internal-real-time)
internal-time-units-per-second))
(defun time-of-day (&optional (i-time (get-universal-time)))
(multiple-value-bind
(seconds minutes hours date month year day-of-week daylight-saving-time-p time-zone)
(decode-universal-time i-time)
(declare (ignorable seconds minutes hours date
month year day-of-week
daylight-saving-time-p time-zone))
(format nil "~A:~2,,,'0 at A:~2,,,'0 at A" hours minutes seconds)))
(defun hour-min-of-day (&optional (i-time (get-universal-time)))
(multiple-value-bind
(seconds minutes hours date month year day-of-week daylight-saving-time-p time-zone)
(decode-universal-time i-time)
(declare (ignorable seconds minutes hours date
month year day-of-week
daylight-saving-time-p time-zone))
(format nil "~2,,,'0 at A:~2,,,'0 at A" hours minutes)))
(defun time-in-zone (inzone &optional (i-time (get-universal-time)))
(multiple-value-bind
(seconds minutes hours date month year day-of-week daylightsavingsp this-zone)
(decode-universal-time i-time)
(declare (ignorable this-zone day-of-week daylightsavingsp))
(encode-universal-time seconds minutes hours date month year (- inzone (if daylightsavingsp 1 0)))))
(defun dd-mmm-yy (&optional (i-time (get-universal-time)))
(multiple-value-bind
(seconds minutes hours date month year day-of-week daylight-saving-time-p time-zone)
(decode-universal-time i-time)
(declare (ignorable seconds minutes hours date
month year day-of-week
daylight-saving-time-p time-zone))
(format nil "~A-~A-~2,,,'0 at A" date (month-abbreviation month)
(mod year 100))))
(defun mmm-dd-yyyy (&optional (i-time (get-universal-time)))
(multiple-value-bind
(seconds minutes hours date month year day-of-week daylight-saving-time-p time-zone)
(decode-universal-time i-time)
(declare (ignorable seconds minutes hours date
month year day-of-week
daylight-saving-time-p time-zone))
(format nil "~A ~A, ~A" (month-abbreviation month)
date year)))
(eval-when (compile load eval)
(export '(month-abbreviation weekday-abbreviation week-time mdyy-yymd u-time u-date)))
(defun month-abbreviation (month)
(elt '("Jan" "Feb" "Mar" "Apr" "May" "June"
"July" "Aug" "Sept" "Oct" "Nov" "Dec") (1- month)))
(defun weekday-abbreviation (day)
(elt '("Mon" "Tue" "Wed" "Thur" "Fri" "Sat" "Sun") day))
(defun week-time (&optional (i-time (get-universal-time)))
(multiple-value-bind
(seconds minutes hours date month year day-of-week daylight-saving-time-p time-zone)
(decode-universal-time i-time)
(declare (ignorable seconds minutes hours date
month year day-of-week
daylight-saving-time-p time-zone))
(format nil "~A ~A ~A, ~A ~a:~2,'0d ~a"
(weekday-abbreviation day-of-week)
(month-abbreviation month)
date
year
(if (= 12 hours) hours (mod hours 12)) ; JP 010911 since (mod 12 12) = 0, treat 12 as a special case.
minutes (if (>= hours 12) "PM" "AM"))))
(defun mdyy-yymd (d)
(assert (eql 8 (length d)))
(conc$ (right$ d 4) (left$ d 4)))
(defun u-time (&optional (i-time (get-universal-time)))
(multiple-value-bind
(seconds minutes hours date month year day-of-week daylight-saving-time-p time-zone)
(decode-universal-time i-time)
(declare (ignorable seconds minutes hours date
month year day-of-week
daylight-saving-time-p time-zone))
(format nil "~2,d:~2,'0d ~a"
;; /// time-zone, really Naggum's stuff
(mod hours 12) minutes
(if (>= hours 12) "PM" "AM"))))
(defun u-date (&optional (i-time (get-universal-time)))
(multiple-value-bind
(seconds minutes hours date month year day-of-week daylight-saving-time-p time-zone)
(decode-universal-time i-time)
(declare (ignorable seconds minutes hours date
month year day-of-week
daylight-saving-time-p time-zone))
(format nil "~A-~A-~A"
date
(elt '("Jan" "Feb" "Mar" "Apr" "May" "June"
"July" "Aug" "Sept" "Oct" "Nov" "Dec") (1- month))
year
)))
(eval-when (compile load eval)
(export '(u-day multiple-value-bind m/d/y mm/dd yyyy-mm-dd)))
(defun u-day (&optional (i-time (get-universal-time)))
(multiple-value-bind
(seconds minutes hours date month year day-of-week daylight-saving-time-p time-zone)
(decode-universal-time i-time)
(declare (ignorable seconds minutes hours date
month year day-of-week
daylight-saving-time-p time-zone))
(elt '("Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday" "Sunday") day-of-week)))
(defun u-day3 (&optional (i-time (get-universal-time)))
(multiple-value-bind
(seconds minutes hours date month year day-of-week daylight-saving-time-p time-zone)
(decode-universal-time i-time)
(declare (ignorable seconds minutes hours date
month year day-of-week
daylight-saving-time-p time-zone))
(elt '("Mon" "Tue" "Wed" "Thu" "Fri" "Sat" "Sun") day-of-week)))
(defun m/d/y (&optional (i-time (get-universal-time)))
(multiple-value-bind
(seconds minutes hours date month year day-of-week daylight-saving-time-p time-zone)
(decode-universal-time i-time)
(declare (ignorable seconds minutes hours date
month year day-of-week
daylight-saving-time-p time-zone))
(format nil "~2,,,'0 at A/~2,,,'0 at A/~2,,,'0 at A" month date (mod year 100))))
(defun mm/dd (&optional (i-time (get-universal-time)))
(multiple-value-bind
(seconds minutes hours date month year day-of-week daylight-saving-time-p time-zone)
(decode-universal-time i-time)
(declare (ignorable seconds minutes hours date
month year day-of-week
daylight-saving-time-p time-zone))
(format nil "~2,,,'0 at A/~2,,,'0 at A" month date)))
(defun yyyy-mm-dd (&optional (i-time (get-universal-time)))
(multiple-value-bind
(seconds minutes hours date month year day-of-week daylight-saving-time-p time-zone)
(decode-universal-time i-time)
(declare (ignorable seconds minutes hours date
month year day-of-week
daylight-saving-time-p time-zone))
(format nil "~4,,,'0 at A~2,,,'0 at A~2,,,'0 at A"
year month date)))
(eval-when (compile load eval)
(export '(ymdhmsh)))
(defun ymdhmsh (&optional (i-time (get-universal-time)))
(multiple-value-bind
(seconds minutes hours date month year day-of-week daylight-saving-time-p time-zone)
(decode-universal-time i-time)
(declare (ignorable seconds minutes hours date
month year day-of-week
daylight-saving-time-p time-zone))
(format nil "~4,,,'0 at A:~2,,,'0 at A:~2,,,'0 at A:~2,,,'0 at A:~2,,,'0 at A:~2,,,'0 at A:~2,,,'0 at A"
year month date hours minutes seconds (floor (now) 10))))
(defun hyphenated-time-string ()
(substitute #\- #\: (ymdhmsh)))
More information about the Cells-cvs
mailing list