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