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 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                 ;; actually this test is perfectly good, but the "internal
  36                 ;; define - missing body expression" in syntax.test somehow
  37                 ;; ends up leaving SCM_DEFER_INTS, making the test here hang
  38                 ;;
  39                 (throw 'unresolved)
  40
  41                 (alarm 5)
  42                 (false-if-exception (gmtime t))
  43                 (thread-join (begin-thread (catch 'out-of-range
  44                                                   (lambda () (gmtime t))
  45                                                   (lambda args #f))))
  46                 (alarm 0)
  47                 #t))
  48
  49             ;; time values that might provoke an error from libc
  50             ;; on 32-bit glibc all values (which fit) are fine
  51             ;; on 64-bit glibc apparently 2^63 can overflow a 32-bit tm_year
  52             (list (1- (ash 1 31)) (1- (ash 1 63))
  53                   -1 (- (ash 1 31)) (- (ash 1 63)))))
  54
  55 ;;;
  56 ;;; internal-time-units-per-second
  57 ;;;
  58
  59 (with-test-prefix "internal-time-units-per-second"
  60
  61   ;; Check that sleep 1 gives about internal-time-units-per-second worth of
  62   ;; elapsed time from times:clock.  This mainly ensures
  63   ;; internal-time-units-per-second correctly indicates CLK_TCK units.
  64   ;;
  65   (pass-if "versus times and sleep"
  66     (or (defined? 'times) (throw 'unsupported))
  67
  68     (let ((old (times)))
  69       (sleep 1)
  70       (let* ((new (times))
  71              (elapsed (- (tms:clock new) (tms:clock old))))
  72         (<= (* 0.5 internal-time-units-per-second)
  73             elapsed
  74             (* 2 internal-time-units-per-second))))))
  75
  76 ;;;
  77 ;;; strftime
  78 ;;;
  79
  80 ;; Note we must force isdst to get the ZOW zone name out of %Z on HP-UX.
  81 ;; If localtime is in daylight savings then it will decide there's no
  82 ;; daylight savings zone name for the fake ZOW, and come back empty.
  83 ;;
  84 ;; This test is disabled because on NetBSD %Z doesn't look at the tm_zone
  85 ;; field in struct tm passed by guile.  That behaviour is reasonable enough
  86 ;; since that field is not in C99 so a C99 program won't know it has to be
  87 ;; set.  For the details on that see
  88 ;;
  89 ;;     http://www.netbsd.org/cgi-bin/query-pr-single.pl?number=21722
  90 ;;
  91 ;; Not sure what to do about this in guile, it'd be nice for %Z to look at
  92 ;; tm:zone everywhere.
  93 ;;
  94 ;;
  95 ;; (pass-if "strftime %Z doesn't return garbage"
  96 ;;       (let ((t (localtime (current-time))))
  97 ;;         (set-tm:zone t "ZOW")
  98 ;;         (set-tm:isdst t 0)
  99 ;;         (string=? (strftime "%Z" t)
 100 ;;                   "ZOW")))
 101
 102 ;;;
 103 ;;; strptime
 104 ;;;
 105
 106 (with-test-prefix "strptime"
 107
 108   (pass-if "in another thread after error"
 109     (or (defined? 'strptime) (throw 'unsupported))
 110     (or (provided? 'threads) (throw 'unsupported))
 111
 112     ;; actually this test is perfectly good, but the "internal define -
 113     ;; missing body expression" in syntax.test somehow ends up leaving
 114     ;; SCM_DEFER_INTS, making the test here hang
 115     ;;
 116     (throw 'unresolved)
 117
 118     (alarm 5)
 119     (false-if-exception
 120      (strptime "%a" "nosuchday"))
 121     (thread-join (begin-thread (strptime "%d" "1")))
 122     (alarm 0)
 123     #t))