cltime.scm

;;;; "cltime.scm" Common-Lisp time conversion routines.
;;; Copyright (C) 1994, 1997 Aubrey Jaffer
;
;Permission to copy this software, to modify it, to redistribute it,
;to distribute modified versions, and to use it for any purpose is
;granted, subject to the following restrictions and understandings.
;
;1.  Any copy made of this software must include this copyright notice
;in full.
;
;2.  I have made no warranty or representation that the operation of
;this software will be error-free, and I am under no obligation to
;provide any services, by way of maintenance, update, or otherwise.
;
;3.  In conjunction with products arising from the use of this
;material, there shall be no use of my name in any advertising,
;promotional, or sales literature without prior written consent in
;each case.

(require 'values)
(require 'time-core)
(require 'time-zone)

(define time:1900 (time:invert
		   (lambda (tm) (time:split tm 0 0 "GMT")) ;time:gmtime
		   '#(0 0 0 1 0 0 #f #f 0 0 "GMT")))
;@
(define (get-decoded-time)
  (decode-universal-time (get-universal-time)))
;@
(define (get-universal-time)
  (difftime (current-time) time:1900))
;@
(define (decode-universal-time utime . tzarg)
  (let ((tv (apply time:split
		   (offset-time time:1900 utime)
		   (if (null? tzarg)
		       (tz:params utime (time-zone (getenv "TZ")))
		       (list 0 (* 3600 (car tzarg)) "???")))))
    (values
     (vector-ref tv 0)			;second	[0..59]
     (vector-ref tv 1)			;minute	[0..59]
     (vector-ref tv 2)			;hour	[0..23]
     (vector-ref tv 3)			;date	[1..31]
     (+ 1 (vector-ref tv 4))		;month	[1..12]
     (+ 1900 (vector-ref tv 5))		;year	[0....]
     (modulo (+ -1 (vector-ref tv 6)) 7) ;day-of-week	[0..6] (0 is Monday)
     (eqv? 1 (vector-ref tv 8))		;daylight-saving-time?
     (if (provided? 'inexact)
	 (inexact->exact (/ (vector-ref tv 9) 3600))
	 (/ (vector-ref tv 9) 3600))	;time-zone	[-24..24]
     )))
;@
(define (encode-universal-time second minute hour date month year . tzarg)
  (let* ((tz (time-zone
	      (if (null? tzarg)
		  (getenv "TZ")
		  (string-append "???" (number->string (car tzarg))))))
	 (tv (vector second
		     minute
		     hour
		     date
		     (+ -1 month)
		     (+ -1900 year)
		     #f			;ignored
		     #f			;ignored
		     )))
    (difftime (time:invert
	       (lambda (tm) (apply time:split tm (tz:params tm tz))) ;localtime
	       tv)
	      time:1900)))