summaryrefslogtreecommitdiffstats
path: root/cltime.scm
diff options
context:
space:
mode:
Diffstat (limited to 'cltime.scm')
-rw-r--r--cltime.scm74
1 files changed, 74 insertions, 0 deletions
diff --git a/cltime.scm b/cltime.scm
new file mode 100644
index 0000000..248f638
--- /dev/null
+++ b/cltime.scm
@@ -0,0 +1,74 @@
+;;;; "cltime.scm" Common-Lisp time conversion routines.
+;;; Copyright (C) 1994 Aubrey Jaffer.
+;
+;Permission to copy this software, to redistribute it, 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 warrantee 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 'posix-time)
+
+(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* ((tz (if (null? tzarg) *timezone* (* 3600 (car tzarg))))
+ (tv (time:split
+ (offset-time time:1900 utime)
+ (if (null? tzarg) time:daylight 0)
+ tz
+ (if (= tz *timezone*) (vector-ref time:tzname time:daylight)
+ ""))))
+ (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 time:1900 (time:invert time:gmtime #(0 0 0 1 0 0 #f #f 0 0 "GMT")))
+
+(define (encode-universal-time second minute hour date month year . tzarg)
+ (let* ((tz (if (null? tzarg) *timezone*
+ (* 3600 (car tzarg))))
+ (tv (vector second
+ minute
+ hour
+ date
+ (+ -1 month)
+ (+ -1900 year)
+ #f ;ignored
+ #f ;ignored
+ (if (= tz *timezone*) time:daylight 0)
+ tz
+ (cond ((= tz *timezone*)
+ (vector-ref time:tzname time:daylight))
+ ((zero? tz) "GMT")
+ (else ""))
+ )))
+ (if (= tz *timezone*) (difftime (time:invert localtime tv) time:1900)
+ (difftime (offset-time (time:invert gmtime tv) tz) time:1900))))
+
+(tzset)