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 | ;;;; | |
957f3c2b | 4 | ;;;; Copyright (C) 2001, 2003, 2004 Free Software Foundation, Inc. |
176d0e0b | 5 | ;;;; |
025f75b4 MV |
6 | ;;;; This program is free software; you can redistribute it and/or modify |
7 | ;;;; it under the terms of the GNU General Public License as published by | |
8 | ;;;; the Free Software Foundation; either version 2, or (at your option) | |
9 | ;;;; any later version. | |
176d0e0b | 10 | ;;;; |
025f75b4 MV |
11 | ;;;; This program is distributed in the hope that it will be useful, |
12 | ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
13 | ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
14 | ;;;; GNU General Public License for more details. | |
176d0e0b | 15 | ;;;; |
025f75b4 MV |
16 | ;;;; You should have received a copy of the GNU General Public License |
17 | ;;;; along with this software; see the file COPYING. If not, write to | |
92205699 MV |
18 | ;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, |
19 | ;;;; 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 | ||
30 | (define (with-tz* tz thunk) | |
31 | "Temporarily set the TZ environment variable to the passed string | |
32 | value and call THUNK." | |
33 | (let ((old-tz #f)) | |
34 | (dynamic-wind | |
35 | (lambda () | |
36 | (set! old-tz (getenv "TZ")) | |
37 | (putenv (format "TZ=~A" tz))) | |
38 | thunk | |
39 | (lambda () | |
40 | (if old-tz | |
41 | (putenv (format "TZ=~A" old-tz)) | |
42 | (putenv "TZ")))))) | |
43 | ||
44 | (defmacro with-tz (tz . body) | |
45 | `(with-tz* ,tz (lambda () ,@body))) | |
46 | ||
47 | (define (test-integral-time-structure date->time) | |
48 | "Test whether the given DATE->TIME procedure creates a time | |
49 | structure with integral seconds. (The seconds shall be maintained as | |
50 | integers, or precision may go away silently. The SRFI-19 reference | |
51 | implementation was not OK for Guile in this respect because of Guile's | |
52 | incomplete numerical tower implementation.)" | |
53 | (pass-if (format "~A makes integer seconds" | |
54 | date->time) | |
55 | (exact? (time-second | |
176d0e0b | 56 | (date->time (make-date 0 0 0 12 1 6 2001 0)))))) |
025f75b4 MV |
57 | |
58 | (define (test-time->date time->date date->time) | |
59 | (pass-if (format "~A works" | |
60 | time->date) | |
61 | (begin | |
62 | (time->date (date->time (make-date 0 0 0 12 1 6 2001 0))) | |
63 | #t))) | |
64 | ||
65 | (define (test-dst time->date date->time) | |
66 | (pass-if (format "~A respects local DST if no TZ-OFFSET given" | |
67 | time->date) | |
68 | (let ((time (date->time (make-date 0 0 0 12 1 6 2001 0)))) | |
957f3c2b KR |
69 | ;; on 2001-06-01, there should be 4 hours zone offset |
70 | ;; between EST (EDT) and GMT | |
025f75b4 | 71 | (= (date-zone-offset |
957f3c2b | 72 | (with-tz "EST5EDT" |
025f75b4 | 73 | (time->date time))) |
957f3c2b | 74 | -14400)))) |
025f75b4 MV |
75 | |
76 | (define-macro (test-time-conversion a b) | |
77 | (let* ((a->b-sym (symbol-append a '-> b)) | |
78 | (b->a-sym (symbol-append b '-> a))) | |
79 | `(pass-if (format "~A and ~A work and are inverses of each other" | |
80 | ',a->b-sym ',b->a-sym) | |
81 | (let ((time (make-time ,a 12345 67890123))) | |
82 | (time=? time (,b->a-sym (,a->b-sym time))))))) | |
83 | ||
176d0e0b TTN |
84 | (define (test-time-comparison cmp a b) |
85 | (pass-if (format #f "~A works" cmp) | |
86 | (cmp a b))) | |
87 | ||
88 | (define (test-time-arithmetic op a b res) | |
89 | (pass-if (format #f "~A works" op) | |
90 | (time=? (op a b) res))) | |
91 | ||
025f75b4 MV |
92 | (with-test-prefix "SRFI date/time library" |
93 | ;; check for typos and silly errors | |
94 | (pass-if "date-zone-offset is defined" | |
95 | (and (defined? 'date-zone-offset) | |
96 | date-zone-offset | |
176d0e0b | 97 | #t)) |
025f75b4 MV |
98 | (pass-if "add-duration is defined" |
99 | (and (defined? 'add-duration) | |
100 | add-duration | |
101 | #t)) | |
102 | (pass-if "(current-time time-tai) works" | |
103 | (begin (current-time time-tai) #t)) | |
104 | (test-time-conversion time-utc time-tai) | |
105 | (test-time-conversion time-utc time-monotonic) | |
106 | (test-time-conversion time-tai time-monotonic) | |
107 | (pass-if "string->date works" | |
108 | (begin (string->date "2001-06-01@14:00" "~Y-~m-~d@~H:~M") | |
109 | #t)) | |
110 | ;; check for code paths where reals were passed to quotient, which | |
111 | ;; doesn't work in Guile (and is unspecified in R5RS) | |
112 | (test-time->date time-utc->date date->time-utc) | |
113 | (test-time->date time-tai->date date->time-tai) | |
114 | (test-time->date time-monotonic->date date->time-monotonic) | |
115 | (pass-if "Fractional nanoseconds are handled" | |
116 | (begin (make-time time-duration 1000000000.5 0) #t)) | |
117 | ;; the seconds in a time shall be maintained as integers, or | |
118 | ;; precision may silently go away | |
119 | (test-integral-time-structure date->time-utc) | |
120 | (test-integral-time-structure date->time-tai) | |
121 | (test-integral-time-structure date->time-monotonic) | |
122 | ;; check for DST and zone related problems | |
123 | (pass-if "date->time-utc is the inverse of time-utc->date" | |
124 | (let ((time (date->time-utc | |
125 | (make-date 0 0 0 14 1 6 2001 7200)))) | |
126 | (time=? time | |
127 | (date->time-utc (time-utc->date time 7200))))) | |
128 | (test-dst time-utc->date date->time-utc) | |
129 | (test-dst time-tai->date date->time-tai) | |
130 | (test-dst time-monotonic->date date->time-monotonic) | |
131 | (test-dst julian-day->date date->julian-day) | |
132 | (test-dst modified-julian-day->date date->modified-julian-day) | |
133 | (pass-if "string->date respects local DST if no time zone is read" | |
134 | (time=? (date->time-utc | |
957f3c2b KR |
135 | (with-tz "EST5EDT" |
136 | (string->date "2001-06-01@08:00" "~Y-~m-~d@~H:~M"))) | |
025f75b4 | 137 | (date->time-utc |
176d0e0b TTN |
138 | (make-date 0 0 0 12 1 6 2001 0)))) |
139 | ;; check time comparison procedures | |
140 | (let* ((time1 (make-time time-monotonic 0 0)) | |
141 | (time2 (make-time time-monotonic 0 0)) | |
142 | (time3 (make-time time-monotonic 385907 998360432)) | |
143 | (time4 (make-time time-monotonic 385907 998360432))) | |
144 | (test-time-comparison time<=? time1 time3) | |
145 | (test-time-comparison time<? time1 time3) | |
146 | (test-time-comparison time=? time1 time2) | |
147 | (test-time-comparison time>=? time3 time3) | |
148 | (test-time-comparison time>? time3 time2)) | |
149 | ;; check time arithmetic procedures | |
150 | (let* ((time1 (make-time time-monotonic 0 0)) | |
151 | (time2 (make-time time-monotonic 385907 998360432)) | |
152 | (diff (time-difference time2 time1))) | |
153 | (test-time-arithmetic add-duration time1 diff time2) | |
01dbf76f KR |
154 | (test-time-arithmetic subtract-duration time2 diff time1)) |
155 | ||
156 | (with-test-prefix "date-week-number" | |
157 | (pass-if (= 0 (date-week-number (make-date 0 0 0 0 1 1 1984 0) 0))) | |
158 | (pass-if (= 0 (date-week-number (make-date 0 0 0 0 7 1 1984 0) 0))) | |
159 | (pass-if (= 1 (date-week-number (make-date 0 0 0 0 8 1 1984 0) 0))))) | |
160 | ||
025f75b4 MV |
161 | |
162 | ;; Local Variables: | |
163 | ;; eval: (put 'with-tz 'scheme-indent-function 1) | |
164 | ;; End: |