1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
|
;;;; "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)))
|
