# time.test = Copyright (C) 2003 Pat Thoyts <[email protected]>
#
# Exercise the tcllib time package.
#
# -------------------------------------------------------------------------
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# -------------------------------------------------------------------------
# RCS: @(#) $Id: time.test,v 1.12 2006/10/09 21:41:41 andreas_kupries Exp $
# -------------------------------------------------------------------------
source [file join \
[file dirname [file dirname [file join [pwd] [info script]]]] \
devtools testutilities.tcl]
testsNeedTcl 8.5
testsNeedTcltest 1.0
testing {
useLocal time.tcl time
}
# -------------------------------------------------------------------------
# Constraints
#
tcltest::testConstraint remote 0; # set true to use the remote tests.
tcltest::testConstraint udp \
[llength [concat \
[package provide udp] \
[package provide ceptcl]]]
# -------------------------------------------------------------------------
set testScript tstsrv.tmp
proc createServerProcess {} {
file delete -force $::testScript
set f [open $::testScript w+]
puts $f {
# This proc is called to handle client connections. We only need to
# return the time in TIME epoch and then close the channel.
proc ::srv {chan args} {
fconfigure $chan -translation binary -buffering none -eofchar {}
if {[catch {
set r [binary format I [expr {int([clock seconds] + 2208988800)}]]
puts "connect on $chan from [fconfigure $chan -peername]"
puts -nonewline $chan $r
close $chan
} msg]} {
puts stderr "error: $msg"
}
set ::done 1
}
set s [socket -server ::srv 0]
fconfigure $s -translation binary -buffering none -eofchar {}
set port [lindex [fconfigure $s -sockname] 2]
puts $port
flush stdout
vwait ::done
update
exit
}
close $f
# Now run the server script as a child process - return child's
# stdout to the caller so they can read the port to use.
if {[catch {
set f [open |[list [::tcltest::interpreter] $::testScript] r]
}]} {
set f [open |[list [info nameofexecutable] $::testScript] r]
}
fconfigure $f -buffering line -blocking 1
#after 500 {set _init 1} ; vwait _init
return $f
}
# -------------------------------------------------------------------------
set token {}
test time-1.1 {time::gettime} {
global token
list [catch {
set f [createServerProcess]
gets $f port
set token [::time::gettime -protocol tcp localhost $port]
set r {}
} msg] $msg
} {0 {}}
test time-1.2 {time::status} {
global token
list [catch {time::status $token} m] $m
} {0 ok}
test time-1.3 {time::unixtime} {
global token
list [catch {
set t [time::unixtime $token]
expr {(0 <= $t) && ($t <= 2147483647)}
} m] $m
} {0 1}
test time-1.4 {time::cget} {
global token
list [catch {
time::cget -port
} m] $m
} {0 37}
test time-1.5 {time::cleanup} {
global token
list [catch {
time::cleanup $token
} m] $m
} {0 {}}
# -------------------------------------------------------------------------
test time-2.0 {check for real: RFC 868} {remote} {
set ::time::TestReady 0
list [catch {
set tok [time::gettime -protocol tcp -timeout 5000 ntp2a.mcc.ac.uk]
time::wait $tok
list [time::status $tok] [time::cleanup $tok]
} err] $err
} {0 {ok {}}}
test time-2.1 {check for real: RFC 868} {remote udp} {
set ::time::TestReady 0
list [catch {
set tok [time::gettime -protocol udp -timeout 5000 ntp2a.mcc.ac.uk]
time::wait $tok
list [time::status $tok] [time::cleanup $tok]
} err] $err
} {0 {ok {}}}
test time-2.2 {check for real: RFC 2030} {remote udp} {
set ::time::TestReady 0
list [catch {
set tok [time::getsntp -timeout 5000 ntp2a.mcc.ac.uk]
time::wait $tok
list [time::status $tok] [time::cleanup $tok]
} err] $err
} {0 {ok {}}}
# -------------------------------------------------------------------------
file delete -force $::testScript
testsuiteCleanup
return
#
# Local variables:
# mode: tcl
# indent-tabs-mode: nil
# End:
