test-suite/tests/srfi-19.test

   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, 2014 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 (when (defined? 'setlocale)
  32   (setlocale LC_ALL "C"))
  33
  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"))
  41           (putenv (format #f "TZ=~A" tz)))
  42         thunk
  43         (lambda ()
  44           (if old-tz
  45               (putenv (format #f "TZ=~A" old-tz))
  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.)"
  57   (pass-if (format #f "~A makes integer seconds"
  58                    date->time)
  59            (exact? (time-second
  60                     (date->time (make-date 0 0 0 12 1 6 2001 0))))))
  61
  62 (define (test-time->date time->date date->time)
  63   (pass-if (format #f "~A works"
  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)
  70   (pass-if (format #f "~A respects local DST if no TZ-OFFSET given"
  71                    time->date)
  72            (let ((time (date->time (make-date 0 0 0 12 1 6 2001 0))))
  73              ;; on 2001-06-01, there should be 4 hours zone offset
  74              ;; between EST (EDT) and GMT
  75              (= (date-zone-offset
  76                  (with-tz "EST5EDT"
  77                    (time->date time)))
  78                 -14400))))
  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)))
  83     `(pass-if (format #f "~A and ~A work and are inverses of each other"
  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
  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
  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
 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
 107                 #t))
 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"
 113            (time? (current-time time-tai)))
 114   (pass-if "(current-time time-process) works"
 115            (time? (current-time time-process)))
 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)
 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
 151   (pass-if "string->date respects local DST if no time zone is read"
 152            (time=? (date->time-utc
 153                     (with-tz "EST5EDT"
 154                       (string->date "2001-06-01@08:00" "~Y-~m-~d@~H:~M")))
 155                    (date->time-utc
 156                     (make-date 0 0 0 12 1 6 2001 0))))
 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))))
 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
 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)
 193     (test-time-arithmetic subtract-duration time2 diff time1))
 194
 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
 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
 219
 220 ;; Local Variables:
 221 ;; eval: (put 'with-tz 'scheme-indent-function 1)
 222 ;; End: