tcl/tests/winTime.test

   1 # This file tests the tclWinTime.c file.
   2 #
   3 # This file contains a collection of tests for one or more of the Tcl
   4 # built-in commands.  Sourcing this file into Tcl runs the tests and
   5 # generates output for errors.  No output means no errors were found.
   6 #
   7 # Copyright (c) 1997 Sun Microsystems, Inc.
   8 # Copyright (c) 1998-1999 by Scriptics Corporation.
   9 #
  10 # See the file "license.terms" for information on usage and redistribution
  11 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  12 #
  13 # RCS: @(#) $Id$
  14
  15 if {[lsearch [namespace children] ::tcltest] == -1} {
  16     package require tcltest
  17     namespace import -force ::tcltest::*
  18 }
  19
  20 # The next two tests will crash on Windows if the check for negative
  21 # clock values is not done properly.
  22
  23 test winTime-1.1 {TclpGetDate} {pcOnly} {
  24     set ::env(TZ) JST-9
  25     set result [clock format -1 -format %Y]
  26     unset ::env(TZ)
  27     set result
  28 } {1970}
  29 test winTime-1.2 {TclpGetDate} {pcOnly} {
  30     set ::env(TZ) PST8
  31     set result [clock format 1 -format %Y]
  32     unset ::env(TZ)
  33     set result
  34 } {1969}
  35
  36 # Next test tries to make sure that the Tcl clock stays in step
  37 # with the Windows clock.  3000 iterations really isn't enough,
  38 # but how many does a tester have patience for?
  39
  40 test winTime-2.1 {Synchronization of Tcl and Windows clocks} {pcOnly} {
  41     set failed 0
  42     foreach { sys_sec sys_usec tcl_sec tcl_usec } [testwinclock] {}
  43     set olddiff [expr { abs ( $tcl_sec - $sys_sec
  44                            + 1.0e-6 * ( $tcl_usec - $sys_usec ) ) }]
  45     set ok 1
  46     for { set i 0 } { $i < 3000 } { incr i } {
  47         foreach { sys_sec sys_usec tcl_sec tcl_usec } [testwinclock] {}
  48         set diff [expr { abs ( $tcl_sec - $sys_sec
  49                                + 1.0e-6 * ( $tcl_usec - $sys_usec ) ) }]
  50         if { ( $diff > $olddiff + 1000 )
  51              || ( $diff > 11000 ) } {
  52             set failed 1
  53             break
  54         } else {
  55             set olddiff $diff
  56             after 1
  57         }
  58     }
  59     set failed
  60 } {0}
  61
  62 # cleanup
  63 ::tcltest::cleanupTests
  64 return
  65
  66
  67
  68
  69
  70
  71
  72
  73
  74
  75
  76