1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
|
# time.test = Copyright (C) 2003 Pat Thoyts <patthoyts@users.sourceforge.net>
#
# 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.9 2005/08/26 17:43:09 andreas_kupries Exp $
# -------------------------------------------------------------------------
# Initialise the test package
#
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
# -------------------------------------------------------------------------
# Ensure we test _this_ local copy and one installed somewhere else.
#
package forget time
catch {namespace delete ::time}
if {[catch {source [file join [file dirname [info script]] time.tcl]} msg]} {
puts "skipped [file tail [info script]]: $msg"
return
}
# -------------------------------------------------------------------------
# Constraints
#
testConstraint remote 0; # set true to use the remote tests.
testConstraint udp [llength [concat [package provide udp]\
[package provide ceptcl]]]
puts "- time [package present time]"
# -------------------------------------------------------------------------
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
::tcltest::cleanupTests
return
#
# Local variables:
# mode: tcl
# indent-tabs-mode: nil
# End:
|
