summaryrefslogtreecommitdiffstats
path: root/tcllib/modules/ntp
diff options
context:
space:
mode:
Diffstat (limited to 'tcllib/modules/ntp')
-rw-r--r--tcllib/modules/ntp/ChangeLog201
-rw-r--r--tcllib/modules/ntp/ntp_time.man131
-rw-r--r--tcllib/modules/ntp/pkgIndex.tcl2
-rw-r--r--tcllib/modules/ntp/time.tcl382
-rw-r--r--tcllib/modules/ntp/time.test162
5 files changed, 878 insertions, 0 deletions
diff --git a/tcllib/modules/ntp/ChangeLog b/tcllib/modules/ntp/ChangeLog
new file mode 100644
index 0000000..82bd1fa
--- /dev/null
+++ b/tcllib/modules/ntp/ChangeLog
@@ -0,0 +1,201 @@
+2013-02-01 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.15 ========================
+ *
+
+2011-12-13 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.14 ========================
+ *
+
+2011-01-24 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.13 ========================
+ *
+
+2009-12-07 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.12 ========================
+ *
+
+2008-12-12 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.11.1 ========================
+ *
+
+2008-10-16 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.11 ========================
+ *
+
+2007-09-12 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.10 ========================
+ *
+
+2007-03-21 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * ntp.man: Fixed all warnings due to use of now deprecated
+ commands. Added a section about how to give feedback.
+
+2006-10-03 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.9 ========================
+ *
+
+2006-09-19 Andreas Kupries <andreask@activestate.com>
+
+ * ntp_time.man: Bumped version to 1.2.1
+ * time.tcl:
+ * pkgIndex.tcl:
+
+2006-04-20 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * time.tcl: bug #1409219: added missing hyphen.
+
+2006-01-23 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * time.test: More boilerplate simplified via use of test support.
+
+2006-01-19 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * time.test: Hooked into the new common test support code.
+
+2005-10-06 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.8 ========================
+ *
+
+2005-08-26 Andreas Kupries <andreask@activestate.com>
+
+ * time.tcl (::time::unixtime): Fixed the 64bit problems reported
+ in [Tcllib SF Bug 899211] by forcefully restricting results to
+ 32bit (Masking with 0xffffffff).
+
+2005-08-26 Andreas Kupries <andreask@activestate.com>
+
+ * time.test (createServerProcess): Ensure that the actual socket
+ is set to binary transport, not the listening socket. On 64bit
+ machines this can cause the fake server to send more than 4
+ bytes, causing data format errors in the client.
+
+2005-08-26 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * time.tcl: Deal with Andreas Kupries comment in bug #899211.
+ Keep trying to read data until the amount expected for the protocol
+ in use is received.
+ * time.test: Added some real remote using tests (with constraint).
+
+2005-08-11 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * time.tcl: SNTP wasn't working (raised by Donal Fellows).
+ Added support for ceptcl in addition to tcludp. Incremented
+ version.
+
+2004-10-05 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.7 ========================
+ *
+
+2004-08-19 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * time.tcl: Tidied up error messages.
+
+2004-05-23 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * time.tcl: Updated version number to distinguish
+ * ntp_time.man: from the 1.6.1 release.
+ * pkgIndex.tcl:
+
+2004-05-23 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.6.1 ========================
+ *
+
+2004-05-23 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * time.tcl: Rel. engineering. Updated version number
+ * time.man: of time to reflect its changes, to 1.0.3.
+ * pkgIndex.tcl:
+
+2004-04-30 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * time.tcl: Added support for SNTP (RFC 2030).
+ * ntp_time.man:
+
+2004-02-28 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * time.tcl: Fix the version as 1.0.2
+
+2004-02-26 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * time.tcl: Applied patch #905132 to better handle socket errors.
+
+2004-02-15 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.6 ========================
+ *
+
+2003-05-29 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * time.tcl: Conform more closely to the RFC in response to
+ bug #744391.
+
+2003-05-05 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.4 ========================
+ *
+
+2003-05-05 Andreas Kupries <andreask@activestate.com>
+
+ * pkgIndex.tcl: Resynced package version numbers for this module.
+
+2003-05-02 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * time.tcl (unixtime): Applied patch from Andreas Kupries to
+ ensure the result is always an integer.
+ * time.test: Make sure the server returns integer values and check
+ the range is valid (rather than just checking for integer).
+
+2003-04-24 Andreas Kupries <andreask@activestate.com>
+
+ * ntp_time.man: Cleanup of RFC referencing.
+
+ * time.tcl (unixtime): [SF Bug #723426] Added code to handle
+ possibility of failure in "binary scan". (ClientReadEvent):
+ Changed to append partial results, allow for empty reads.
+
+ * time.test: [SF Bug #723426]. Corrected non-unique test
+ names. Handle a missing tcltest::interpreter and fall back to
+ [info nameofexecutable].
+
+2003-04-16 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * time.man: Renamed the man page to avoid clashing with
+ * ntp_time.man: the tcl time.n manual page.
+
+2003-03-20 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * time.test: Added a test package.
+ * pkgIndex.tcl: Added a package index file.
+
+2003-03-17 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * time.tcl:
+ * time.man: Initial checkin of an RFC 868 client.
+ * examples/ntp/rdate.tcl: A demo using the time package to request
+ the current time from a remote host via tcp or udp.
+
diff --git a/tcllib/modules/ntp/ntp_time.man b/tcllib/modules/ntp/ntp_time.man
new file mode 100644
index 0000000..92a7010
--- /dev/null
+++ b/tcllib/modules/ntp/ntp_time.man
@@ -0,0 +1,131 @@
+[manpage_begin ntp_time n 1.2.1]
+[see_also ntp]
+[keywords NTP]
+[keywords {rfc 868}]
+[keywords {rfc 2030}]
+[keywords SNTP]
+[keywords time]
+[copyright {2002, Pat Thoyts <patthoyts@users.sourceforge.net>}]
+[moddesc {Network Time Facilities}]
+[titledesc {Tcl Time Service Client}]
+[category Networking]
+[require Tcl 8.0]
+[require time [opt 1.2.1]]
+[description]
+[para]
+
+This package implements a client for the RFC 868 TIME protocol
+([uri http://www.rfc-editor.org/rfc/rfc868.txt]) and also a minimal
+client for the RFC 2030 Simple Network Time Protocol
+([uri http://www.rfc-editor.org/rfc/rfc2030.txt]).
+
+RFC 868 returns the time in seconds since 1 January 1900
+to either tcp or udp clients. RFC 2030 also gives this time but also
+provides a fractional part which is not used in this client.
+
+[section COMMANDS]
+
+[list_begin definitions]
+
+[call [cmd ::time::gettime] [opt [arg "options"]] [arg timeserver] [opt [arg "port"]]]
+
+Get the time from [arg timeserver]. You may specify any of the options
+listed for the [cmd configure] command here. This command returns a
+token which must then be used with the remaining commands in this
+package. Once you have finished, you should use [cmd cleanup] to
+release all resources. The default port is [const 37].
+
+[call [cmd ::time::getsntp] [opt [arg "options"]] [arg timeserver] [opt [arg "port"]]]
+
+Get the time from an SNTP server. This accepts exactly the same
+arguments as [cmd ::time::gettime] except that the default port is
+[const 123]. The result is a token as per [cmd ::time::gettime] and
+should be handled in the same way.
+[para]
+Note that it is unlikely that any SNTP server will reply using tcp so
+you will require the [package tcludp] or the [package ceptcl]
+package. If a suitable package can be loaded then the udp protocol
+will be used by default.
+
+[call [cmd ::time::configure] [opt [arg "options"]]]
+
+Called with no arguments this command returns all the current
+configuration options and values. Otherwise it should be called with
+pairs of option name and value.
+
+[list_begin definitions]
+[def "[cmd -protocol] [arg number]"]
+ Set the default network protocol. This defaults to udp if the tcludp
+ package is available. Otherwise it will use tcp.
+[def "[cmd -port] [arg number]"]
+ Set the default port to use. RFC 868 uses port [const 37], RFC 2030 uses
+port [const 123].
+[def "[cmd -timeout] [arg number]"]
+ Set the default timeout value in milliseconds. The default is 10 seconds.
+[def "[cmd -command] [arg number]"]
+ Set a command procedure to be run when a reply is received. The
+ procedure is called with the time token appended to the argument list.
+[def "[cmd -loglevel] [arg number]"]
+ Set the logging level. The default is 'warning'.
+[list_end]
+
+[call [cmd ::time::cget] [arg name]]
+
+Get the current value for the named configuration option.
+
+[call [cmd ::time::unixtime] [arg token]]
+ Format the returned time for the unix epoch. RFC 868 time defines
+ time 0 as 1 Jan 1900, while unix time defines time 0 as 1 Jan
+ 1970. This command converts the reply to unix time.
+
+[call [cmd ::time::status] [arg token]]
+ Returns the status flag. For a successfully completed query this will be
+ [emph ok]. May be [emph error] or [emph timeout] or [emph eof].
+ See also [cmd ::time::error]
+
+[call [cmd ::time::error] [arg token]]
+ Returns the error message provided for requests whose status is [emph error].
+ If there is no error message then an empty string is returned.
+
+[call [cmd ::time::reset] [arg token] [arg [opt reason]]]
+ Reset or cancel the query optionally specfying the reason to record
+ for the [cmd error] command.
+
+[call [cmd ::time::wait] [arg token]]
+ Wait for a query to complete and return the status upon completion.
+
+[call [cmd ::time::cleanup] [arg token]]
+ Remove all state variables associated with the request.
+
+[list_end]
+
+[example {
+% set tok [::time::gettime ntp2a.mcc.ac.uk]
+% set t [::time::unixtime $tok]
+% ::time::cleanup $tok
+}]
+
+[example {
+% set tok [::time::getsntp pool.ntp.org]
+% set t [::time::unixtime $tok]
+% ::time::cleanup $tok
+}]
+
+[example {
+proc on_time {token} {
+ if {[time::status $token] eq "ok"} {
+ puts [clock format [time::unixtime $token]]
+ } else {
+ puts [time::error $token]
+ }
+ time::cleanup $token
+}
+time::getsntp -command on_time pool.ntp.org
+}]
+
+[section AUTHORS]
+Pat Thoyts
+
+[vset CATEGORY ntp]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/ntp/pkgIndex.tcl b/tcllib/modules/ntp/pkgIndex.tcl
new file mode 100644
index 0000000..21a47f4
--- /dev/null
+++ b/tcllib/modules/ntp/pkgIndex.tcl
@@ -0,0 +1,2 @@
+if {![package vsatisfies [package provide Tcl] 8.2]} {return}
+package ifneeded time 1.2.1 [list source [file join $dir time.tcl]]
diff --git a/tcllib/modules/ntp/time.tcl b/tcllib/modules/ntp/time.tcl
new file mode 100644
index 0000000..3e6d0f2
--- /dev/null
+++ b/tcllib/modules/ntp/time.tcl
@@ -0,0 +1,382 @@
+# time.tcl - Copyright (C) 2003 Pat Thoyts <patthoyts@users.sourceforge.net>
+#
+# Client for the Time protocol. See RFC 868
+# Client for Simple Network Time Protocol - RFC 2030
+#
+# -------------------------------------------------------------------------
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+# -------------------------------------------------------------------------
+
+package require Tcl 8.0; # tcl minimum version
+package require log; # tcllib 1.3
+
+namespace eval ::time {
+ namespace export configure gettime server cleanup
+
+ variable options
+ if {![info exists options]} {
+ array set options {
+ -timeserver {}
+ -port 37
+ -protocol tcp
+ -timeout 10000
+ -command {}
+ -loglevel warning
+ }
+ if {![catch {package require udp}]} {
+ set options(-protocol) udp
+ } else {
+ if {![catch {package require ceptcl}]} {
+ set options(-protocol) udp
+ }
+ }
+ log::lvSuppressLE emergency 0
+ log::lvSuppressLE $options(-loglevel) 1
+ log::lvSuppress $options(-loglevel) 0
+ }
+
+ # Store conversions for other epochs. Currently only unix - but maybe
+ # there are some others out there.
+ variable epoch
+ if {![info exists epoch]} {
+ array set epoch {
+ unix 2208988800
+ }
+ }
+
+ # The id for the next token.
+ variable uid
+ if {![info exists uid]} {
+ set uid 0
+ }
+}
+
+# -------------------------------------------------------------------------
+
+# Description:
+# Retrieve configuration settings for the time package.
+#
+proc ::time::cget {optionname} {
+ return [configure $optionname]
+}
+
+# Description:
+# Configure the package.
+# With no options, returns a list of all current settings.
+#
+proc ::time::configure {args} {
+ variable options
+ set r {}
+ set cget 0
+
+ if {[llength $args] < 1} {
+ foreach opt [lsort [array names options]] {
+ lappend r $opt $options($opt)
+ }
+ return $r
+ }
+
+ if {[llength $args] == 1} {
+ set cget 1
+ }
+
+ while {[string match -* [set option [lindex $args 0]]]} {
+ switch -glob -- $option {
+ -port { set r [SetOrGet -port $cget] }
+ -timeout { set r [SetOrGet -timeout $cget] }
+ -protocol { set r [SetOrGet -protocol $cget] }
+ -command { set r [SetOrGet -command $cget] }
+ -loglevel {
+ if {$cget} {
+ return $options(-loglevel)
+ } else {
+ set options(-loglevel) [Pop args 1]
+ log::lvSuppressLE emergency 0
+ log::lvSuppressLE $options(-loglevel) 1
+ log::lvSuppress $options(-loglevel) 0
+ }
+ }
+ -- { Pop args ; break }
+ default {
+ set err [join [lsort [array names options -*]] ", "]
+ return -code error "bad option \"$option\": must be $err"
+ }
+ }
+ Pop args
+ }
+
+ return $r
+}
+
+# Set/get package options.
+proc ::time::SetOrGet {option {cget 0}} {
+ upvar options options
+ upvar args args
+ if {$cget} {
+ return $options($option)
+ } else {
+ set options($option) [Pop args 1]
+ }
+ return {}
+}
+
+# -------------------------------------------------------------------------
+
+proc ::time::getsntp {args} {
+ set token [eval [linsert $args 0 CommonSetup -port 123]]
+ upvar #0 $token State
+ set State(rfc) 2030
+ return [QueryTime $token]
+}
+
+proc ::time::gettime {args} {
+ set token [eval [linsert $args 0 CommonSetup -port 37]]
+ upvar #0 $token State
+ set State(rfc) 868
+ return [QueryTime $token]
+}
+
+proc ::time::CommonSetup {args} {
+ variable options
+ variable uid
+ set token [namespace current]::[incr uid]
+ variable $token
+ upvar 0 $token State
+
+ array set State [array get options]
+ set State(status) unconnected
+ set State(data) {}
+
+ while {[string match -* [set option [lindex $args 0]]]} {
+ switch -glob -- $option {
+ -port { set State(-port) [Pop args 1] }
+ -timeout { set State(-timeout) [Pop args 1] }
+ -proto* { set State(-protocol) [Pop args 1] }
+ -command { set State(-command) [Pop args 1] }
+ -- { Pop args ; break }
+ default {
+ set err [join [lsort [array names State -*]] ", "]
+ return -code error "bad option \"$option\":\
+ must be $err."
+ }
+ }
+ Pop args
+ }
+
+ set len [llength $args]
+ if {$len < 1 || $len > 2} {
+ if {[catch {info level -1} arg0]} {
+ set arg0 [info level 0]
+ }
+ return -code error "wrong # args: should be\
+ \"[lindex $arg0 0] ?options? timeserver ?port?\""
+ }
+
+ set State(-timeserver) [lindex $args 0]
+ if {$len == 2} {
+ set State(-port) [lindex $args 1]
+ }
+
+ return $token
+}
+
+proc ::time::QueryTime {token} {
+ variable $token
+ upvar 0 $token State
+
+ if {[string equal $State(-protocol) "udp"]} {
+ if {[llength [package provide ceptcl]] == 0 \
+ && [llength [package provide udp]] == 0} {
+ set State(status) error
+ set State(error) "udp support is not available, \
+ either ceptcl or tcludp required"
+ return $token
+ }
+ }
+
+ if {[catch {
+ if {[string equal $State(-protocol) "udp"]} {
+ if {[llength [package provide ceptcl]] > 0} {
+ # using ceptcl
+ set State(sock) [cep -type datagram \
+ $State(-timeserver) $State(-port)]
+ fconfigure $State(sock) -blocking 0
+ } else {
+ # using tcludp
+ set State(sock) [udp_open]
+ udp_conf $State(sock) $State(-timeserver) $State(-port)
+ }
+ } else {
+ set State(sock) [socket $State(-timeserver) $State(-port)]
+ }
+ } sockerr]} {
+ set State(status) error
+ set State(error) $sockerr
+ return $token
+ }
+
+ # setup the timeout
+ if {$State(-timeout) > 0} {
+ set State(after) [after $State(-timeout) \
+ [list [namespace origin reset] $token timeout]]
+ }
+
+ set State(status) connect
+ fconfigure $State(sock) -translation binary -buffering none
+
+ # SNTP wants a 48 byte request while TIME doesn't care and is happy
+ # to accept any old rubbish. If protocol is TCP then merely connecting
+ # is sufficient to elicit a response.
+ if {[string equal $State(-protocol) "udp"]} {
+ set len [expr {($State(rfc) == 2030) ? 47 : 3}]
+ puts -nonewline $State(sock) \x0b[string repeat \0 $len]
+ }
+
+ fileevent $State(sock) readable \
+ [list [namespace origin ClientReadEvent] $token]
+
+ if {$State(-command) == {}} {
+ wait $token
+ }
+
+ return $token
+}
+
+proc ::time::unixtime {{token {}}} {
+ variable $token
+ variable epoch
+ upvar 0 $token State
+ if {$State(status) != "ok"} {
+ return -code error $State(error)
+ }
+
+ # SNTP returns 48+ bytes while TIME always returns 4.
+ if {[string length $State(data)] == 4} {
+ # RFC848 TIME
+ if {[binary scan $State(data) I r] < 1} {
+ return -code error "Unable to scan data"
+ }
+ return [expr {int($r - $epoch(unix))&0xffffffff}]
+ } elseif {[string length $State(data)] > 47} {
+ # SNTP TIME
+ if {[binary scan $State(data) c40II -> sec frac] < 1} {
+ return -code error "Failed to decode result"
+ }
+ return [expr {int($sec - $epoch(unix))&0xffffffff}]
+ } else {
+ return -code error "error: data format not recognised"
+ }
+}
+
+proc ::time::status {token} {
+ variable $token
+ upvar 0 $token State
+ return $State(status)
+}
+
+proc ::time::error {token} {
+ variable $token
+ upvar 0 $token State
+ set r {}
+ if {[info exists State(error)]} {
+ set r $State(error)
+ }
+ return $r
+}
+
+proc ::time::wait {token} {
+ variable $token
+ upvar 0 $token State
+
+ if {$State(status) == "connect"} {
+ vwait [subst $token](status)
+ }
+
+ return $State(status)
+}
+
+proc ::time::reset {token {why reset}} {
+ variable $token
+ upvar 0 $token State
+ set reason {}
+ set State(status) $why
+ catch {fileevent $State(sock) readable {}}
+ if {$why == "timeout"} {
+ set reason "timeout ocurred"
+ }
+ Finish $token $reason
+}
+
+# Description:
+# Remove any state associated with this token.
+#
+proc ::time::cleanup {token} {
+ variable $token
+ upvar 0 $token State
+ if {[info exists State]} {
+ unset State
+ }
+}
+
+# -------------------------------------------------------------------------
+
+proc ::time::ClientReadEvent {token} {
+ variable $token
+ upvar 0 $token State
+
+ append State(data) [read $State(sock)]
+ set expected [expr {($State(rfc) == 868) ? 4 : 48}]
+ if {[string length $State(data)] < $expected} { return }
+
+ #FIX ME: acquire peer data?
+
+ set State(status) ok
+ Finish $token
+ return
+}
+
+proc ::time::Finish {token {errormsg {}}} {
+ variable $token
+ upvar 0 $token State
+ global errorInfo errorCode
+
+ if {[string length $errormsg] > 0} {
+ set State(error) $errormsg
+ set State(status) error
+ }
+ catch {close $State(sock)}
+ catch {after cancel $State(after)}
+ if {[info exists State(-command)] && $State(-command) != {}} {
+ if {[catch {eval $State(-command) {$token}} err]} {
+ if {[string length $errormsg] == 0} {
+ set State(error) [list $err $errorInfo $errorCode]
+ set State(status) error
+ }
+ }
+ if {[info exists State(-command)]} {
+ unset State(-command)
+ }
+ }
+}
+
+# -------------------------------------------------------------------------
+# Description:
+# Pop the nth element off a list. Used in options processing.
+#
+proc ::time::Pop {varname {nth 0}} {
+ upvar $varname args
+ set r [lindex $args $nth]
+ set args [lreplace $args $nth $nth]
+ return $r
+}
+
+# -------------------------------------------------------------------------
+
+package provide time 1.2.1
+
+# -------------------------------------------------------------------------
+# Local variables:
+# mode: tcl
+# indent-tabs-mode: nil
+# End:
diff --git a/tcllib/modules/ntp/time.test b/tcllib/modules/ntp/time.test
new file mode 100644
index 0000000..9a4caf6
--- /dev/null
+++ b/tcllib/modules/ntp/time.test
@@ -0,0 +1,162 @@
+# 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.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.2
+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:
generated by cgit v0.12 at 2025-08-29 23:51:48 (GMT)