guile18/test-suite/tests/time.test

   1 ;;;; time.test --- test suite for Guile's time functions     -*- scheme -*-
   2 ;;;; Jim Blandy <jimb@red-bean.com> --- June 1999, 2004
   3 ;;;;
   4 ;;;;    Copyright (C) 1999, 2004, 2006, 2007, 2009 Free Software Foundation, Inc.
   5 ;;;;
   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.
  10 ;;;;
  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.
  15 ;;;;
  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
  18 ;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  19 ;;;; Boston, MA 02110-1301 USA
  20
  21 (define-module (test-suite test-time)
  22   #:use-module (test-suite lib)
  23   #:use-module (ice-9 threads))
  24
  25 ;;;
  26 ;;; gmtime
  27 ;;;
  28
  29 (with-test-prefix "gmtime"
  30
  31   (for-each (lambda (t)
  32               (pass-if (list "in another thread after error" t)
  33                 (or (provided? 'threads) (throw 'unsupported))
  34
  35                 (alarm 5)
  36                 (false-if-exception (gmtime t))
  37                 (join-thread (begin-thread (catch #t
  38                                              (lambda () (gmtime t))
  39                                              (lambda args #f))))
  40                 (alarm 0)
  41                 #t))
  42
  43             ;; time values that might provoke an error from libc
  44             ;; on 32-bit glibc all values (which fit) are fine
  45             ;; on 64-bit glibc apparently 2^63 can overflow a 32-bit tm_year
  46             (list (1- (ash 1 31)) (1- (ash 1 63))
  47                   -1 (- (ash 1 31)) (- (ash 1 63)))))
  48
  49 ;;;
  50 ;;; internal-time-units-per-second
  51 ;;;
  52
  53 (with-test-prefix "internal-time-units-per-second"
  54
  55   ;; Check that sleep 1 gives about internal-time-units-per-second worth of
  56   ;; elapsed time from times:clock.  This mainly ensures
  57   ;; internal-time-units-per-second correctly indicates CLK_TCK units.
  58   ;;
  59   (pass-if "versus times and sleep"
  60     (or (defined? 'times) (throw 'unsupported))
  61
  62     (let ((old (times)))
  63       (sleep 1)
  64       (let* ((new (times))
  65              (elapsed (- (tms:clock new) (tms:clock old))))
  66         (<= (* 0.5 internal-time-units-per-second)
  67             elapsed
  68             (* 2 internal-time-units-per-second))))))
  69
  70 ;;;
  71 ;;; localtime
  72 ;;;
  73
  74 (with-test-prefix "localtime"
  75
  76   ;; gmtoff is calculated with some explicit code, try to exercise that
  77   ;; here, looking at cases where the localtime and gmtime are within the same
  78   ;; day, or crossing midnight, or crossing new year
  79
  80   (pass-if "gmtoff of EST+5 at GMT 10:00am on 10 Jan 2000"
  81     (let ((tm (gmtime 0)))
  82       (set-tm:hour tm 10)
  83       (set-tm:mday tm 10)
  84       (set-tm:mon  tm 0)
  85       (set-tm:year tm 100)
  86       (let* ((t  (car (mktime tm "GMT")))
  87              (tm (localtime t "EST+5")))
  88         (eqv? (* 5 3600) (tm:gmtoff tm)))))
  89
  90   ;; crossing forward over day boundary
  91   (pass-if "gmtoff of EST+5 at GMT 3am on 10 Jan 2000"
  92     (let ((tm (gmtime 0)))
  93       (set-tm:hour tm 3)
  94       (set-tm:mday tm 10)
  95       (set-tm:mon  tm 0)
  96       (set-tm:year tm 100)
  97       (let* ((t  (car (mktime tm "GMT")))
  98              (tm (localtime t "EST+5")))
  99         (eqv? (* 5 3600) (tm:gmtoff tm)))))
 100
 101   ;; crossing backward over day boundary
 102   (pass-if "gmtoff of AST-10 at GMT 10pm on 10 Jan 2000"
 103     (let ((tm (gmtime 0)))
 104       (set-tm:hour tm 22)
 105       (set-tm:mday tm 10)
 106       (set-tm:mon  tm 0)
 107       (set-tm:year tm 100)
 108       (let* ((t  (car (mktime tm "GMT")))
 109              (tm (localtime t "AST-10")))
 110         (eqv? (* -10 3600) (tm:gmtoff tm)))))
 111
 112   ;; crossing forward over year boundary
 113   (pass-if "gmtoff of EST+5 at GMT 3am on 1 Jan 2000"
 114     (let ((tm (gmtime 0)))
 115       (set-tm:hour tm 3)
 116       (set-tm:mday tm 1)
 117       (set-tm:mon  tm 0)
 118       (set-tm:year tm 100)
 119       (let* ((t  (car (mktime tm "GMT")))
 120              (tm (localtime t "EST+5")))
 121         (eqv? (* 5 3600) (tm:gmtoff tm)))))
 122
 123   ;; crossing backward over day boundary
 124   (pass-if "gmtoff of AST-10 at GMT 10pm on 31 Dec 2000"
 125     (let ((tm (gmtime 0)))
 126       (set-tm:hour tm 22)
 127       (set-tm:mday tm 31)
 128       (set-tm:mon  tm 11)
 129       (set-tm:year tm 100)
 130       (let* ((t  (car (mktime tm "GMT")))
 131              (tm (localtime t "AST-10")))
 132         (eqv? (* -10 3600) (tm:gmtoff tm))))))
 133
 134 ;;;
 135 ;;; mktime
 136 ;;;
 137
 138 (with-test-prefix "mktime"
 139
 140   ;; gmtoff is calculated with some explicit code, try to exercise that
 141   ;; here, looking at cases where the mktime and gmtime are within the same
 142   ;; day, or crossing midnight, or crossing new year
 143
 144   (pass-if "gmtoff of EST+5 at 10:00am on 10 Jan 2000"
 145     (let ((tm (gmtime 0)))
 146       (set-tm:hour tm 10)
 147       (set-tm:mday tm 10)
 148       (set-tm:mon  tm 0)
 149       (set-tm:year tm 100)
 150       (let ((tm (cdr (mktime tm "EST+5"))))
 151         (eqv? (* 5 3600) (tm:gmtoff tm)))))
 152
 153   ;; crossing forward over day boundary
 154   (pass-if "gmtoff of EST+5 at 10:00pm on 10 Jan 2000"
 155     (let ((tm (gmtime 0)))
 156       (set-tm:hour tm 22)
 157       (set-tm:mday tm 10)
 158       (set-tm:mon  tm 0)
 159       (set-tm:year tm 100)
 160       (let ((tm (cdr (mktime tm "EST+5"))))
 161         (eqv? (* 5 3600) (tm:gmtoff tm)))))
 162
 163   ;; crossing backward over day boundary
 164   (pass-if "gmtoff of AST-10 at 3:00am on 10 Jan 2000"
 165     (let ((tm (gmtime 0)))
 166       (set-tm:hour tm 3)
 167       (set-tm:mday tm 10)
 168       (set-tm:mon  tm 0)
 169       (set-tm:year tm 100)
 170       (let ((tm (cdr (mktime tm "AST-10"))))
 171         (eqv? (* -10 3600) (tm:gmtoff tm)))))
 172
 173   ;; crossing forward over year boundary
 174   (pass-if "gmtoff of EST+5 at 10:00pm on 31 Dec 2000"
 175     (let ((tm (gmtime 0)))
 176       (set-tm:hour tm 22)
 177       (set-tm:mday tm 31)
 178       (set-tm:mon  tm 11)
 179       (set-tm:year tm 100)
 180       (let ((tm (cdr (mktime tm "EST+5"))))
 181         (eqv? (* 5 3600) (tm:gmtoff tm)))))
 182
 183   ;; crossing backward over day boundary
 184   (pass-if "gmtoff of AST-10 at 3:00am on 1 Jan 2000"
 185     (let ((tm (gmtime 0)))
 186       (set-tm:hour tm 3)
 187       (set-tm:mday tm 1)
 188       (set-tm:mon  tm 0)
 189       (set-tm:year tm 100)
 190       (let ((tm (cdr (mktime tm "AST-10"))))
 191         (eqv? (* -10 3600) (tm:gmtoff tm))))))
 192
 193 ;;;
 194 ;;; strftime
 195 ;;;
 196
 197 (with-test-prefix "strftime"
 198
 199   ;; Note we must force isdst to get the ZOW zone name out of %Z on HP-UX.
 200   ;; If localtime is in daylight savings then it will decide there's no
 201   ;; daylight savings zone name for the fake ZOW, and come back empty.
 202   ;;
 203   ;; This test is disabled because on NetBSD %Z doesn't look at the tm_zone
 204   ;; field in struct tm passed by guile.  That behaviour is reasonable
 205   ;; enough since that field is not in C99 so a C99 program won't know it
 206   ;; has to be set.  For the details on that see
 207   ;;
 208   ;;     http://www.netbsd.org/cgi-bin/query-pr-single.pl?number=21722
 209   ;;
 210   ;; Not sure what to do about this in guile, it'd be nice for %Z to look at
 211   ;; tm:zone everywhere.
 212   ;;
 213   ;;
 214   ;; (pass-if "strftime %Z doesn't return garbage"
 215   ;;     (let ((t (localtime (current-time))))
 216   ;;       (set-tm:zone t "ZOW")
 217   ;;       (set-tm:isdst t 0)
 218   ;;       (string=? (strftime "%Z" t)
 219   ;;                 "ZOW")))
 220
 221   (with-test-prefix "C99 %z format"
 222
 223     ;; C99 spec is empty string if no zone determinable
 224     ;;
 225     ;; On pre-C99 systems not sure what to expect if %z unsupported, probably
 226     ;; "%z" unchanged in C99 if timezone.  On AIX and Tru64 5.1b, it returns
 227     ;; a string such as "GMT" or "EST", instead of "+0000" or "-0500".  See
 228     ;; https://savannah.gnu.org/bugs/index.php?24130 for details.
 229     ;;
 230     (define have-strftime-%z
 231       (equal? (strftime "%z" (gmtime 0)) "+0000"))
 232
 233     ;; %z here is quite possibly affected by the same tm:gmtoff vs current
 234     ;; zone as %Z above is, so in the following tests we make them the same.
 235
 236     (pass-if "GMT"
 237       (or have-strftime-%z (throw 'unsupported))
 238       (putenv "TZ=GMT+0")
 239       (tzset)
 240       (let ((tm (localtime 86400)))
 241         (string=? "+0000" (strftime "%z" tm))))
 242
 243     ;; prior to guile 1.6.9 and 1.8.1 this test failed, getting "+0500",
 244     ;; because we didn't adjust for tm:gmtoff being west of Greenwich versus
 245     ;; tm_gmtoff being east of Greenwich
 246     (pass-if "EST+5"
 247       (or have-strftime-%z (throw 'unsupported))
 248       (putenv "TZ=EST+5")
 249       (tzset)
 250       (let ((tm (localtime 86400)))
 251         (string=? "-0500" (strftime "%z" tm))))))
 252
 253 ;;;
 254 ;;; strptime
 255 ;;;
 256
 257 (with-test-prefix "strptime"
 258
 259   (pass-if "in another thread after error"
 260     (or (defined? 'strptime) (throw 'unsupported))
 261     (or (provided? 'threads) (throw 'unsupported))
 262
 263     (alarm 5)
 264     (false-if-exception
 265      (strptime "%a" "nosuchday"))
 266     (join-thread (begin-thread (strptime "%d" "1")))
 267     (alarm 0)
 268     #t)
 269
 270   (with-test-prefix "GNU %s format"
 271
 272     ;; "%s" to parse a count of seconds since 1970 is a GNU extension
 273     (define have-strptime-%s
 274       (false-if-exception (strptime "%s" "0")))
 275
 276     (pass-if "gmtoff on GMT"
 277       (or have-strptime-%s (throw 'unsupported))
 278       (putenv "TZ=GMT+0")
 279       (tzset)
 280       (let ((tm (car (strptime "%s" "86400"))))
 281         (eqv? 0 (tm:gmtoff tm))))
 282
 283     ;; prior to guile 1.6.9 and 1.8.1 we didn't pass tm_gmtoff back from
 284     ;; strptime
 285     (pass-if "gmtoff on EST+5"
 286       (or have-strptime-%s (throw 'unsupported))
 287       (putenv "TZ=EST+5")
 288       (tzset)
 289       (let ((tm (car (strptime "%s" "86400"))))
 290         (eqv? (* 5 3600) (tm:gmtoff tm))))))