1# time.tcl - Copyright (C) 2003 Pat Thoyts <patthoyts@users.sourceforge.net> 2# 3# Client for the Time protocol. See RFC 868 4# Client for Simple Network Time Protocol - RFC 2030 5# 6# ------------------------------------------------------------------------- 7# See the file "license.terms" for information on usage and redistribution 8# of this file, and for a DISCLAIMER OF ALL WARRANTIES. 9# ------------------------------------------------------------------------- 10# 11# $Id: time.tcl,v 1.19 2006/09/19 23:36:17 andreas_kupries Exp $ 12 13package require Tcl 8.0; # tcl minimum version 14package require log; # tcllib 1.3 15 16namespace eval ::time { 17 variable version 1.2.1 18 variable rcsid {$Id: time.tcl,v 1.19 2006/09/19 23:36:17 andreas_kupries Exp $} 19 20 namespace export configure gettime server cleanup 21 22 variable options 23 if {![info exists options]} { 24 array set options { 25 -timeserver {} 26 -port 37 27 -protocol tcp 28 -timeout 10000 29 -command {} 30 -loglevel warning 31 } 32 if {![catch {package require udp}]} { 33 set options(-protocol) udp 34 } else { 35 if {![catch {package require ceptcl}]} { 36 set options(-protocol) udp 37 } 38 } 39 log::lvSuppressLE emergency 0 40 log::lvSuppressLE $options(-loglevel) 1 41 log::lvSuppress $options(-loglevel) 0 42 } 43 44 # Store conversions for other epochs. Currently only unix - but maybe 45 # there are some others out there. 46 variable epoch 47 if {![info exists epoch]} { 48 array set epoch { 49 unix 2208988800 50 } 51 } 52 53 # The id for the next token. 54 variable uid 55 if {![info exists uid]} { 56 set uid 0 57 } 58} 59 60# ------------------------------------------------------------------------- 61 62# Description: 63# Retrieve configuration settings for the time package. 64# 65proc ::time::cget {optionname} { 66 return [configure $optionname] 67} 68 69# Description: 70# Configure the package. 71# With no options, returns a list of all current settings. 72# 73proc ::time::configure {args} { 74 variable options 75 set r {} 76 set cget 0 77 78 if {[llength $args] < 1} { 79 foreach opt [lsort [array names options]] { 80 lappend r $opt $options($opt) 81 } 82 return $r 83 } 84 85 if {[llength $args] == 1} { 86 set cget 1 87 } 88 89 while {[string match -* [set option [lindex $args 0]]]} { 90 switch -glob -- $option { 91 -port { set r [SetOrGet -port $cget] } 92 -timeout { set r [SetOrGet -timeout $cget] } 93 -protocol { set r [SetOrGet -protocol $cget] } 94 -command { set r [SetOrGet -command $cget] } 95 -loglevel { 96 if {$cget} { 97 return $options(-loglevel) 98 } else { 99 set options(-loglevel) [Pop args 1] 100 log::lvSuppressLE emergency 0 101 log::lvSuppressLE $options(-loglevel) 1 102 log::lvSuppress $options(-loglevel) 0 103 } 104 } 105 -- { Pop args ; break } 106 default { 107 set err [join [lsort [array names options -*]] ", "] 108 return -code error "bad option \"$option\": must be $err" 109 } 110 } 111 Pop args 112 } 113 114 return $r 115} 116 117# Set/get package options. 118proc ::time::SetOrGet {option {cget 0}} { 119 upvar options options 120 upvar args args 121 if {$cget} { 122 return $options($option) 123 } else { 124 set options($option) [Pop args 1] 125 } 126 return {} 127} 128 129# ------------------------------------------------------------------------- 130 131proc ::time::getsntp {args} { 132 set token [eval [linsert $args 0 CommonSetup -port 123]] 133 upvar #0 $token State 134 set State(rfc) 2030 135 return [QueryTime $token] 136} 137 138proc ::time::gettime {args} { 139 set token [eval [linsert $args 0 CommonSetup -port 37]] 140 upvar #0 $token State 141 set State(rfc) 868 142 return [QueryTime $token] 143} 144 145proc ::time::CommonSetup {args} { 146 variable options 147 variable uid 148 set token [namespace current]::[incr uid] 149 variable $token 150 upvar 0 $token State 151 152 array set State [array get options] 153 set State(status) unconnected 154 set State(data) {} 155 156 while {[string match -* [set option [lindex $args 0]]]} { 157 switch -glob -- $option { 158 -port { set State(-port) [Pop args 1] } 159 -timeout { set State(-timeout) [Pop args 1] } 160 -proto* { set State(-protocol) [Pop args 1] } 161 -command { set State(-command) [Pop args 1] } 162 -- { Pop args ; break } 163 default { 164 set err [join [lsort [array names State -*]] ", "] 165 return -code error "bad option \"$option\":\ 166 must be $err." 167 } 168 } 169 Pop args 170 } 171 172 set len [llength $args] 173 if {$len < 1 || $len > 2} { 174 if {[catch {info level -1} arg0]} { 175 set arg0 [info level 0] 176 } 177 return -code error "wrong # args: should be\ 178 \"[lindex $arg0 0] ?options? timeserver ?port?\"" 179 } 180 181 set State(-timeserver) [lindex $args 0] 182 if {$len == 2} { 183 set State(-port) [lindex $args 1] 184 } 185 186 return $token 187} 188 189proc ::time::QueryTime {token} { 190 variable $token 191 upvar 0 $token State 192 193 if {[string equal $State(-protocol) "udp"]} { 194 if {[llength [package provide ceptcl]] == 0 \ 195 && [llength [package provide udp]] == 0} { 196 set State(status) error 197 set State(error) "udp support is not available, \ 198 either ceptcl or tcludp required" 199 return $token 200 } 201 } 202 203 if {[catch { 204 if {[string equal $State(-protocol) "udp"]} { 205 if {[llength [package provide ceptcl]] > 0} { 206 # using ceptcl 207 set State(sock) [cep -type datagram \ 208 $State(-timeserver) $State(-port)] 209 fconfigure $State(sock) -blocking 0 210 } else { 211 # using tcludp 212 set State(sock) [udp_open] 213 udp_conf $State(sock) $State(-timeserver) $State(-port) 214 } 215 } else { 216 set State(sock) [socket $State(-timeserver) $State(-port)] 217 } 218 } sockerr]} { 219 set State(status) error 220 set State(error) $sockerr 221 return $token 222 } 223 224 # setup the timeout 225 if {$State(-timeout) > 0} { 226 set State(after) [after $State(-timeout) \ 227 [list [namespace origin reset] $token timeout]] 228 } 229 230 set State(status) connect 231 fconfigure $State(sock) -translation binary -buffering none 232 233 # SNTP wants a 48 byte request while TIME doesn't care and is happy 234 # to accept any old rubbish. If protocol is TCP then merely connecting 235 # is sufficient to elicit a response. 236 if {[string equal $State(-protocol) "udp"]} { 237 set len [expr {($State(rfc) == 2030) ? 47 : 3}] 238 puts -nonewline $State(sock) \x0b[string repeat \0 $len] 239 } 240 241 fileevent $State(sock) readable \ 242 [list [namespace origin ClientReadEvent] $token] 243 244 if {$State(-command) == {}} { 245 wait $token 246 } 247 248 return $token 249} 250 251proc ::time::unixtime {{token {}}} { 252 variable $token 253 variable epoch 254 upvar 0 $token State 255 if {$State(status) != "ok"} { 256 return -code error $State(error) 257 } 258 259 # SNTP returns 48+ bytes while TIME always returns 4. 260 if {[string length $State(data)] == 4} { 261 # RFC848 TIME 262 if {[binary scan $State(data) I r] < 1} { 263 return -code error "Unable to scan data" 264 } 265 return [expr {int($r - $epoch(unix))&0xffffffff}] 266 } elseif {[string length $State(data)] > 47} { 267 # SNTP TIME 268 if {[binary scan $State(data) c40II -> sec frac] < 1} { 269 return -code error "Failed to decode result" 270 } 271 return [expr {int($sec - $epoch(unix))&0xffffffff}] 272 } else { 273 return -code error "error: data format not recognised" 274 } 275} 276 277proc ::time::status {token} { 278 variable $token 279 upvar 0 $token State 280 return $State(status) 281} 282 283proc ::time::error {token} { 284 variable $token 285 upvar 0 $token State 286 set r {} 287 if {[info exists State(error)]} { 288 set r $State(error) 289 } 290 return $r 291} 292 293proc ::time::wait {token} { 294 variable $token 295 upvar 0 $token State 296 297 if {$State(status) == "connect"} { 298 vwait [subst $token](status) 299 } 300 301 return $State(status) 302} 303 304proc ::time::reset {token {why reset}} { 305 variable $token 306 upvar 0 $token State 307 set reason {} 308 set State(status) $why 309 catch {fileevent $State(sock) readable {}} 310 if {$why == "timeout"} { 311 set reason "timeout ocurred" 312 } 313 Finish $token $reason 314} 315 316# Description: 317# Remove any state associated with this token. 318# 319proc ::time::cleanup {token} { 320 variable $token 321 upvar 0 $token State 322 if {[info exists State]} { 323 unset State 324 } 325} 326 327# ------------------------------------------------------------------------- 328 329proc ::time::ClientReadEvent {token} { 330 variable $token 331 upvar 0 $token State 332 333 append State(data) [read $State(sock)] 334 set expected [expr {($State(rfc) == 868) ? 4 : 48}] 335 if {[string length $State(data)] < $expected} { return } 336 337 #FIX ME: acquire peer data? 338 339 set State(status) ok 340 Finish $token 341 return 342} 343 344proc ::time::Finish {token {errormsg {}}} { 345 variable $token 346 upvar 0 $token State 347 global errorInfo errorCode 348 349 if {[string length $errormsg] > 0} { 350 set State(error) $errormsg 351 set State(status) error 352 } 353 catch {close $State(sock)} 354 catch {after cancel $State(after)} 355 if {[info exists State(-command)] && $State(-command) != {}} { 356 if {[catch {eval $State(-command) {$token}} err]} { 357 if {[string length $errormsg] == 0} { 358 set State(error) [list $err $errorInfo $errorCode] 359 set State(status) error 360 } 361 } 362 if {[info exists State(-command)]} { 363 unset State(-command) 364 } 365 } 366} 367 368# ------------------------------------------------------------------------- 369# Description: 370# Pop the nth element off a list. Used in options processing. 371# 372proc ::time::Pop {varname {nth 0}} { 373 upvar $varname args 374 set r [lindex $args $nth] 375 set args [lreplace $args $nth $nth] 376 return $r 377} 378 379# ------------------------------------------------------------------------- 380 381package provide time $::time::version 382 383# ------------------------------------------------------------------------- 384# Local variables: 385# mode: tcl 386# indent-tabs-mode: nil 387# End: 388