| 1 | ;;;; srfi-19.test --- test suite for SRFI-19 -*- scheme -*- |
| 2 | ;;;; Matthias Koeppe <mkoeppe@mail.math.uni-magdeburg.de> --- June 2001 |
| 3 | ;;;; |
| 4 | ;;;; Copyright (C) 2001, 2003, 2004, 2005, 2006, 2007, 2008, |
| 5 | ;;;; 2011 Free Software Foundation, Inc. |
| 6 | ;;;; |
| 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. |
| 11 | ;;;; |
| 12 | ;;;; This library is distributed in the hope that it will be useful, |
| 13 | ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
| 14 | ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
| 15 | ;;;; Lesser General Public License for more details. |
| 16 | ;;;; |
| 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 |
| 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) |
| 25 | :duplicates (last) ;; avoid warning about srfi-19 replacing `current-time' |
| 26 | :use-module (test-suite lib) |
| 27 | :use-module (srfi srfi-19) |
| 28 | :use-module (ice-9 format)) |
| 29 | |
| 30 | ;; Make sure we use the default locale. |
| 31 | (setlocale LC_ALL "C") |
| 32 | |
| 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")) |
| 40 | (putenv (format #f "TZ=~A" tz))) |
| 41 | thunk |
| 42 | (lambda () |
| 43 | (if old-tz |
| 44 | (putenv (format #f "TZ=~A" old-tz)) |
| 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.)" |
| 56 | (pass-if (format #f "~A makes integer seconds" |
| 57 | date->time) |
| 58 | (exact? (time-second |
| 59 | (date->time (make-date 0 0 0 12 1 6 2001 0)))))) |
| 60 | |
| 61 | (define (test-time->date time->date date->time) |
| 62 | (pass-if (format #f "~A works" |
| 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) |
| 69 | (pass-if (format #f "~A respects local DST if no TZ-OFFSET given" |
| 70 | time->date) |
| 71 | (let ((time (date->time (make-date 0 0 0 12 1 6 2001 0)))) |
| 72 | ;; on 2001-06-01, there should be 4 hours zone offset |
| 73 | ;; between EST (EDT) and GMT |
| 74 | (= (date-zone-offset |
| 75 | (with-tz "EST5EDT" |
| 76 | (time->date time))) |
| 77 | -14400)))) |
| 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))) |
| 82 | `(pass-if (format #f "~A and ~A work and are inverses of each other" |
| 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 | |
| 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 | |
| 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 | |
| 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 |
| 106 | #t)) |
| 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" |
| 112 | (time? (current-time time-tai))) |
| 113 | (pass-if "(current-time time-process) works" |
| 114 | (time? (current-time time-process))) |
| 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) |
| 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 | |
| 150 | (pass-if "string->date respects local DST if no time zone is read" |
| 151 | (time=? (date->time-utc |
| 152 | (with-tz "EST5EDT" |
| 153 | (string->date "2001-06-01@08:00" "~Y-~m-~d@~H:~M"))) |
| 154 | (date->time-utc |
| 155 | (make-date 0 0 0 12 1 6 2001 0)))) |
| 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)))) |
| 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 | |
| 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) |
| 192 | (test-time-arithmetic subtract-duration time2 diff time1)) |
| 193 | |
| 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 | |
| 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 | |
| 218 | |
| 219 | ;; Local Variables: |
| 220 | ;; eval: (put 'with-tz 'scheme-indent-function 1) |
| 221 | ;; End: |