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