OSNCL/lib/time-utilities.lisp

;;;; PMSF-Lib --- PMSF Common Lisp Utility Library
;;;; This is copyrighted software.  See documentation for terms.
;;;; 
;;;; time-utilities.lisp --- Utilities concerned with time processing
;;;; 
;;;; $Id$

(cl:in-package #:pmsf-lib)

(pmsf-lib:file-version :pmsf-lib "$Id$")

;;;; %File Description:
;;;; 
;;;; This file contains utilities for time processing, especially time
;;;; formatting.
;;;; 

(defvar *defined-iso8601-time-formats* (make-hash-table :test #'eq))

(defun format-iso8601-time (&key
                            (time (get-universal-time)) 
                            (format :human))
  "Format time, which defaults to the current time as returned by 
`get-universal-time' in a string that is more or less formatted according
to ISO8601.  The exact format can be specified by the `format' parameter,
which must be a format defined by `define-iso8601-time-format'.  The list
of currently defined formats can be displayed with the function
`list-iso8601-time-formats'.  The following set of formats are currently
pre-defined:

:human          YYYY-MM-DD HH:mm:ss [+|-]HH:mm
:human-short    YYYY-MM-DD HH:mm:ss
:strict         YYYY-MM-DD'T'HH:mm:ss[+|-]HH:mm
:strict-short   YYYY-MM-DD'T'HH:mm:ss
:date           YYYY-MM-DD
:time           HH:mm:ss
:timezone       [+|-]HH:mm"
  (multiple-value-bind (second minute hour date month year day daylight-p zone)
      (decode-universal-time time)
    (declare (ignore day))
    (multiple-value-bind (tz-hours tz-minutes) (truncate (- zone))
      (let ((formatter (gethash format *defined-iso8601-time-formats* nil)))
        (unless formatter
          (error "Undefined time format ~S in call to format-iso8601-time."
                 format))
        (funcall formatter year month date hour minute second 
                 (if (minusp tz-hours) #\- #\+)
                 (abs (+ tz-hours (if daylight-p 1 0)))
                 (abs (* tz-minutes 60)))))))

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defmacro define-iso8601-time-format (name (&rest vars) &body body)
    "Define a new time format named `name' with the given formatter.  The 
formatter must take the following 9 parameters in the given order via 
`vars' and must return a string with the formatted time according to
the format.  It should not have any side-effects.

Parameters:
  - year
  - month
  - day-of-month
  - hour
  - minute
  - second
  - sign of timezone as a character + or - indicating east and west of UTC
  - hours of the timezone
  - minutes of the timezone"
    `(ensure-iso8601-time-format ',name (lambda (,@vars) ,@body))))

(defun list-iso8601-time-formats (&optional (time (get-universal-time)))
  "Print a list of currently defined formats and their effect on formatting
the time given in `time', which defaults to the current time as returned by
`get-universal-time'."
  (let ((formats (loop for key being the hash-keys of
                      *defined-iso8601-time-formats*
                      collect key)))
    (loop for format in (sort formats #'string< :key #'symbol-name)
       for result = (format-iso8601-time :time time :format format)
       initially
         (format t "~&~25A ~A~2%" "Format" "Formatted Time")
       do
         (format t "~25S ~A~%" format result))))

(defun ensure-iso8601-time-format (name formatter)
  (setf (gethash name *defined-iso8601-time-formats*) formatter))

(define-iso8601-time-format :human
    (year month date hour minute second tz-sign tz-hours tz-minutes)
  (format nil "~4,'0D-~2,'0D-~2,'0D ~2,'0D:~2,'0D:~2,'0D ~C~2,'0D:~2,'0D"
          year month date hour minute second tz-sign tz-hours tz-minutes))

(define-iso8601-time-format :strict
    (year month date hour minute second tz-sign tz-hours tz-minutes)
  (format nil "~4,'0D-~2,'0D-~2,'0DT~2,'0D:~2,'0D:~2,'0D~C~2,'0D:~2,'0D"
          year month date hour minute second tz-sign tz-hours tz-minutes))

(define-iso8601-time-format :human-short
    (year month date hour minute second tz-sign tz-hours tz-minutes)
  (declare (ignore tz-sign tz-hours tz-minutes))
  (format nil "~4,'0D-~2,'0D-~2,'0D ~2,'0D:~2,'0D:~2,'0D"
          year month date hour minute second))

(define-iso8601-time-format :strict-short
    (year month date hour minute second tz-sign tz-hours tz-minutes)
  (declare (ignore tz-sign tz-hours tz-minutes))
  (format nil "~4,'0D-~2,'0D-~2,'0DT~2,'0D:~2,'0D:~2,'0D"
          year month date hour minute second))

(define-iso8601-time-format :date
    (year month date hour minute second tz-sign tz-hours tz-minutes)
  (declare (ignore hour minute second tz-sign tz-hours tz-minutes))
  (format nil "~4,'0D-~2,'0D-~2,'0D" year month date))

(define-iso8601-time-format :time
    (year month date hour minute second tz-sign tz-hours tz-minutes)
  (declare (ignore year month date tz-sign tz-hours tz-minutes))
  (format nil "~2,'0D:~2,'0D:~2,'0D" hour minute second))

(define-iso8601-time-format :timezone
    (year month date hour minute second tz-sign tz-hours tz-minutes)
  (declare (ignore year month date hour minute second))
  (format nil "~C~2,'0D:~2,'0D" tz-sign tz-hours tz-minutes))

;;;
;;; Access To High Precision Timers
;;;

#+(and lispworks win32)
(fli:define-foreign-function (%query-performance-counter "QueryPerformanceCounter")
    (&optional (counter (:reference-return :int64)))
  :result-type :int
  :calling-convention :stdcall)

#+(and lispworks win32)
(fli:define-foreign-function (%query-performance-frequency "QueryPerformanceFrequency")
    (&optional (freq (:reference-return :int64)))
  :result-type :int
  :calling-convention :stdcall)

(defun query-performance-counter ()
  #+(and lispworks win32)
  (multiple-value-bind (good counter)
      (%query-performance-counter)
    (unless (zerop good)
      counter))
  #-(and lispworks win32)
  (get-internal-real-time))

(defun query-performance-frequency ()
  #+(and lispworks win32)
  (multiple-value-bind (good freq)
      (%query-performance-frequency)
    (unless (zerop good)
      freq))
  #-(and lispworks win32)
  internal-time-units-per-second)