diff options
author | Bryan Newbold <bnewbold@robocracy.org> | 2017-02-20 00:05:25 -0800 |
---|---|---|
committer | Bryan Newbold <bnewbold@robocracy.org> | 2017-02-20 00:05:25 -0800 |
commit | 8ffbc2df0fde83082610149d24e594c1cd879f4a (patch) | |
tree | a2be9aad5101c5e450ad141d15c514bc9c2a2963 /cltime.scm | |
download | slib-8ffbc2df0fde83082610149d24e594c1cd879f4a.tar.gz slib-8ffbc2df0fde83082610149d24e594c1cd879f4a.zip |
Import Upstream version 2a6upstream/2a6
Diffstat (limited to 'cltime.scm')
-rw-r--r-- | cltime.scm | 74 |
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) |