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
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
|
;;;; srfi-19.test --- test suite for SRFI-19 -*- scheme -*-
;;;; Matthias Koeppe <mkoeppe@mail.math.uni-magdeburg.de> --- June 2001
;;;;
;;;; Copyright (C) 2001, 2003, 2004, 2005, 2006, 2007, 2008,
;;;; 2011, 2014 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;; SRFI-19 overrides current-date, so we have to do the test in a
;; separate module, or later tests will fail.
(define-module (test-suite test-srfi-19)
:duplicates (last) ;; avoid warning about srfi-19 replacing `current-time'
:use-module (test-suite lib)
:use-module (srfi srfi-19)
:use-module (ice-9 format))
;; Make sure we use the default locale.
(when (defined? 'setlocale)
(setlocale LC_ALL "C"))
(define (with-tz* tz thunk)
"Temporarily set the TZ environment variable to the passed string
value and call THUNK."
(let ((old-tz #f))
(dynamic-wind
(lambda ()
(set! old-tz (getenv "TZ"))
(putenv (format #f "TZ=~A" tz)))
thunk
(lambda ()
(if old-tz
(putenv (format #f "TZ=~A" old-tz))
(putenv "TZ"))))))
(defmacro with-tz (tz . body)
`(with-tz* ,tz (lambda () ,@body)))
(define (test-integral-time-structure date->time)
"Test whether the given DATE->TIME procedure creates a time
structure with integral seconds. (The seconds shall be maintained as
integers, or precision may go away silently. The SRFI-19 reference
implementation was not OK for Guile in this respect because of Guile's
incomplete numerical tower implementation.)"
(pass-if (format #f "~A makes integer seconds"
date->time)
(exact? (time-second
(date->time (make-date 0 0 0 12 1 6 2001 0))))))
(define (test-time->date time->date date->time)
(pass-if (format #f "~A works"
time->date)
(begin
(time->date (date->time (make-date 0 0 0 12 1 6 2001 0)))
#t)))
(define (test-dst time->date date->time)
(pass-if (format #f "~A respects local DST if no TZ-OFFSET given"
time->date)
(let ((time (date->time (make-date 0 0 0 12 1 6 2001 0))))
;; on 2001-06-01, there should be 4 hours zone offset
;; between EST (EDT) and GMT
(= (date-zone-offset
(with-tz "EST5EDT"
(time->date time)))
-14400))))
(define-macro (test-time-conversion a b)
(let* ((a->b-sym (symbol-append a '-> b))
(b->a-sym (symbol-append b '-> a)))
`(pass-if (format #f "~A and ~A work and are inverses of each other"
',a->b-sym ',b->a-sym)
(let ((time (make-time ,a 12345 67890123)))
(time=? time (,b->a-sym (,a->b-sym time)))))))
(define (test-time-comparison cmp a b)
(pass-if (format #f "~A works" cmp)
(cmp a b)))
(define (test-time-arithmetic op a b res)
(pass-if (format #f "~A works" op)
(time=? (op a b) res)))
;; return true if time objects X and Y are equal
(define (time-equal? x y)
(and (eq? (time-type x) (time-type y))
(eqv? (time-second x) (time-second y))
(eqv? (time-nanosecond x) (time-nanosecond y))))
(with-test-prefix "SRFI date/time library"
;; check for typos and silly errors
(pass-if "date-zone-offset is defined"
(and (defined? 'date-zone-offset)
date-zone-offset
#t))
(pass-if "add-duration is defined"
(and (defined? 'add-duration)
add-duration
#t))
(pass-if "(current-time time-tai) works"
(time? (current-time time-tai)))
(pass-if "(current-time time-process) works"
(time? (current-time time-process)))
(test-time-conversion time-utc time-tai)
(test-time-conversion time-utc time-monotonic)
(test-time-conversion time-tai time-monotonic)
(pass-if "string->date works"
(begin (string->date "2001-06-01@14:00" "~Y-~m-~d@~H:~M")
#t))
;; check for code paths where reals were passed to quotient, which
;; doesn't work in Guile (and is unspecified in R5RS)
(test-time->date time-utc->date date->time-utc)
(test-time->date time-tai->date date->time-tai)
(test-time->date time-monotonic->date date->time-monotonic)
(pass-if "Fractional nanoseconds are handled"
(begin (make-time time-duration 1000000000.5 0) #t))
;; the seconds in a time shall be maintained as integers, or
;; precision may silently go away
(test-integral-time-structure date->time-utc)
(test-integral-time-structure date->time-tai)
(test-integral-time-structure date->time-monotonic)
;; check for DST and zone related problems
(pass-if "date->time-utc is the inverse of time-utc->date"
(let ((time (date->time-utc
(make-date 0 0 0 14 1 6 2001 7200))))
(time=? time
(date->time-utc (time-utc->date time 7200)))))
(test-dst time-utc->date date->time-utc)
(test-dst time-tai->date date->time-tai)
(test-dst time-monotonic->date date->time-monotonic)
(test-dst julian-day->date date->julian-day)
(test-dst modified-julian-day->date date->modified-julian-day)
(pass-if "`date->julian-day' honors timezone"
(let ((now (current-date -14400)))
(time=? (date->time-utc (julian-day->date (date->julian-day now)))
(date->time-utc now))))
(pass-if "string->date respects local DST if no time zone is read"
(time=? (date->time-utc
(with-tz "EST5EDT"
(string->date "2001-06-01@08:00" "~Y-~m-~d@~H:~M")))
(date->time-utc
(make-date 0 0 0 12 1 6 2001 0))))
(pass-if "string->date understands days and months"
(time=? (let ((d (string->date "Saturday, December 9, 2006"
"~A, ~B ~d, ~Y")))
(date->time-utc (make-date (date-nanosecond d)
(date-second d)
(date-minute d)
(date-hour d)
(date-day d)
(date-month d)
(date-year d)
0)))
(date->time-utc
(make-date 0 0 0 0 9 12 2006 0))))
(pass-if "string->date works on Sunday"
;; `string->date' never rests!
(let* ((str "Sun, 05 Jun 2005 18:33:00 +0200")
(date (string->date str "~a, ~d ~b ~Y ~H:~M:~S ~z")))
(equal? "Sun Jun 05 18:33:00+0200 2005"
(date->string date))))
;; check time comparison procedures
(let* ((time1 (make-time time-monotonic 0 0))
(time2 (make-time time-monotonic 0 0))
(time3 (make-time time-monotonic 385907 998360432))
(time4 (make-time time-monotonic 385907 998360432)))
(test-time-comparison time<=? time1 time3)
(test-time-comparison time<? time1 time3)
(test-time-comparison time=? time1 time2)
(test-time-comparison time>=? time3 time3)
(test-time-comparison time>? time3 time2))
;; check time arithmetic procedures
(let* ((time1 (make-time time-monotonic 0 0))
(time2 (make-time time-monotonic 385907 998360432))
(diff (time-difference time2 time1)))
(test-time-arithmetic add-duration time1 diff time2)
(test-time-arithmetic subtract-duration time2 diff time1))
(with-test-prefix "date->time-tai"
;; leap second 1 Jan 1999, 1 second of UTC in make-date is out as 2
;; seconds of TAI in date->time-tai
(pass-if "31dec98 23:59:59"
(time-equal? (make-time time-tai 0 915148830)
(date->time-tai (make-date 0 59 59 23 31 12 1998 0))))
(pass-if "1jan99 0:00:00"
(time-equal? (make-time time-tai 0 915148832)
(date->time-tai (make-date 0 0 0 0 1 1 1999 0))))
;; leap second 1 Jan 2006, 1 second of UTC in make-date is out as 2
;; seconds of TAI in date->time-tai
(pass-if "31dec05 23:59:59"
(time-equal? (make-time time-tai 0 1136073631)
(date->time-tai (make-date 0 59 59 23 31 12 2005 0))))
(pass-if "1jan06 0:00:00"
(time-equal? (make-time time-tai 0 1136073633)
(date->time-tai (make-date 0 0 0 0 1 1 2006 0)))))
(with-test-prefix "date-week-number"
(pass-if (= 0 (date-week-number (make-date 0 0 0 0 1 1 1984 0) 0)))
(pass-if (= 0 (date-week-number (make-date 0 0 0 0 7 1 1984 0) 0)))
(pass-if (= 1 (date-week-number (make-date 0 0 0 0 8 1 1984 0) 0)))))
;; Local Variables:
;; eval: (put 'with-tz 'scheme-indent-function 1)
;; End:
|
