[Small-cl-src] time-utils.lisp

[Helmut Eller]

;;; time-utils.lisp --- libc style time formatting functions
;;;
;;; Written by Helmut Eller in May 2004.
;;;
;;; This file provides a two functions: one to parse time strings and
;;; an another to print time values to strings.  The interface is
;;; similar to the Emacs functions `format-time-string' and
;;; `parse-time-string'.
;;;
;;; Not the most lispy implementation but it gets the job done.  The
;;; code runs in CMUCL.  Porting it to another implementation would be
;;; a major pain.
;;; 

(defpackage :date-utils
  (:use :cl :unix :alien :c-call)
  (:export :format-time-string
	   :parse-time-string))

(in-package :date-utils)

;;;; Alien utilities
;;;
;;; I prefer to work with SAPs (system area pointers) over alien
;;; values.  Aliens are only used as convenient way to express
;;; offsets in structures.  Aliens are never passed to or returned from
;;; functions (too consy).
;;;

(def-alien-type tm (struct unix::tm))
(def-alien-type time-t unix::time-t)
(def-alien-type sap system-area-pointer)

(defmacro memcpy (to from nbytes)
  `(kernel:system-area-copy ,from 0 ,to 0 (* ,nbytes vm:byte-bits)))

(defun malloc (size)
  (let ((sap (alien-funcall (extern-alien "malloc" (function sap unsigned))
			    size)))
    (when (zerop (sys:sap-int sap))
      (unix::unix-get-errno)
      (error "malloc failed: ~S" (unix:get-unix-error-msg)))
    sap))

(defun free (sap)
  (alien-funcall (extern-alien "free" (function void sap)) sap))

(defmacro with-growing-buffer ((buffer size &key (initial-size 1024))
			       &body body)
  "Execute BODY repeatedly with BUFFER bound to a sap pointing to a
block of memory of size SIZE.  SIZE is doubled on each iteration.  An
implicit block named nil surrounds the entire form; body can be terminated
by returning to nil." 
  `(block nil
    (flet ((try (,buffer ,size) , at body))
      (let ((size ,initial-size))
	(with-alien ((buffer (array char ,initial-size)))
	  (try (alien-sap (addr buffer)) ,initial-size))
	(loop named #:noname do
	      (setf size (* 2 size))
	      (let ((buffer (malloc size)))
		(unwind-protect 
		     (try buffer size)
		  (free buffer))))))))

(defun format-time-string (format-string &key time universal unix-epoch)
  "Use FORMAT-STRING to format the time-value TIME. 

The return value is a copy of FORMAT-STRING, but with certain
constructs replaced by text that describes the specified date and time
in TIME. (See strftime(3) for details.)

TIME is an integer representing the number of seconds since 1900 (or
since 1970 if UNIX-EPOCH is true).  TIME defaults to the current time.

If UNIVERSAL is true, describe TIME as Universal Time; nil
means describe TIME in the local time zone."
  (with-alien ((utime time-t)
	       (brokentime tm)
	       (c/time (function time-t sap) :extern "time")
	       (c/gmtime_r (function sap (* time-t) (* tm)) :extern "gmtime_r")
	       (c/localtime_r (function sap (* time-t) (* tm))
			      :extern "localtime_r")
	       (c/strftime (function int sap int c-string (* tm))
			   :extern "strftime"))
    ;; Compute the Unixy time value
    (setf utime (cond ((and time unix-epoch)
		       time)
		      (time
		       (- time #.(encode-universal-time 0 0 0 1 1 1970 0)))
		      (t
		       (let ((time (alien-funcall c/time (sys:int-sap 0))))
			 (if (= time -1)
			     (error "c/time failed: ~A" (get-unix-error-msg))
			     time)))))
    ;; break it up
    (let ((result 
	   (if universal
	       (alien-funcall c/gmtime_r    (addr utime) (addr brokentime)) 
	       (alien-funcall c/localtime_r (addr utime) (addr brokentime)))))
      (unless (sys:sap= result (alien-sap (addr brokentime)))
	(error "format-time-string failed")))
    ;; print it
    (with-growing-buffer (buffer size)
      (setf (sys:sap-ref-8 buffer 0) 1)
      (let ((count (alien-funcall c/strftime buffer size 
				  format-string (addr brokentime))))
	(when (or (plusp count)
		  (and (zerop count)
		       (= (sys:sap-ref-8 buffer 0) 0)))
	  (let ((string (make-string count)))
	    (memcpy (sys:vector-sap string) buffer count)
	    (return string)))))))

(defun parse-time-string (format-string string &key junk-allowed time-zone)
  "Parse the time-string STRING into a universal time value.
The return values can be used with decode-universal-time."
  (declare (type string string format-string))
  (with-alien ((tm tm)
	       (c/strptime (function sap c-string c-string (* tm))
			   :extern "strptime"))
    (vm::system-area-fill 0 (alien-sap (addr tm)) 0 (alien-size tm :bits))
    (sys:without-gcing 
     (let ((result (alien-funcall c/strptime string format-string (addr tm))))
       (when (zerop (sys:sap-int result))
	 (error "parse-time-string failed: ~A ~A" 
		string format-string))
       (unless (or junk-allowed
		   (= (length string) 
		      (sys:sap- result (sys:vector-sap string))))
	 (error "There is junk in this string: ~A" string))))
    (encode-universal-time
     (slot tm 'unix::tm-sec)
     (slot tm 'unix::tm-min)
     (slot tm 'unix::tm-hour)
     (slot tm 'unix::tm-mday)
     (1+ (slot tm 'unix::tm-mon))
     (+ 1900 (slot tm 'unix::tm-year))
     time-zone)))

;;;; Examples:
#|

(format-time-string "%a, %d %b %Y %H:%M:%S %Z %z")

(parse-time-string "%a, %d %b %Y %H:%M:%S      " ; ? why doesn't this fail
		   (format-time-string "%a, %d %b %Y %H:%M:%S"))

;; test print/read consistency

(let* ((format "%a, %d %b %Y %H:%M:%S")
       (string1 (format-time-string format))
       (time (parse-time-string format string1))
       (string2 (format-time-string format :time time)))
  (assert (equal string2 string1))
  string2)
  
|#

;;; time-utils.lisp ends here.