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