1 # util.tcl --
2 #
3 # FIXME: This file needs a description here.
4 #
5 # Copyright (c) 1997-2002 The Regents of the University of California.
6 # All rights reserved.
7 #
8 # Redistribution and use in source and binary forms, with or without
9 # modification, are permitted provided that the following conditions are met:
10 #
11 # A. Redistributions of source code must retain the above copyright notice,
12 # this list of conditions and the following disclaimer.
13 # B. Redistributions in binary form must reproduce the above copyright notice,
14 # this list of conditions and the following disclaimer in the documentation
15 # and/or other materials provided with the distribution.
16 # C. Neither the names of the copyright holders nor the names of its
17 # contributors may be used to endorse or promote products derived from this
18 # software without specific prior written permission.
19 #
20 # THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS IS''
21 # AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
22 # IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
23 # ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR
24 # ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
25 # DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
26 # SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
27 # CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
28 # OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
29 # OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
30 #
31 # @(#) $Header: /usr/mash/src/repository/mash/mash-1/tcl/common/util.tcl,v 1.23 2004/04/14 22:54:22 aswan Exp $
32
33
34 #provide mashutils
35
36 # Please "import mashutils" in any file that will invoke one of the generic procs defined below.
37
38 Object instproc has_method { method } {
39 if { [$self info procs $method]!="" } {
40 return 1
41 }
42
43 return [[$self info class] has_method $method]
44 }
45
46
47 Class instproc has_method { method } {
48 if { [$self info instprocs $method]!="" } {
49 return 1
50 }
51
52 foreach cl [$self info heritage] {
53 if { [$cl info instprocs $method]!="" } {
54 return 1
55 }
56 }
57 return 0
58 }
59
60 #
61 # Please "import mashutils" to use this proc. <br>
62 #
63 # Return the mash interpreter version number.
64 # (The global variable is set in tkAppInit.cc)
65 #
66 proc version {} {
67 global mash
68 return $mash(version)
69 }
70
71 #
72 # Please "import mashutils" to use this proc. <br>
73 #
74 # Return a fully qualified DNS name for any of
75 # the local host's interfaces. Return an empty
76 # string if no such name can be found.
77 #
78 proc local_fqdn {} {
79 set host ""
80 catch {set host [lookup_host_name [localaddr]]}
81 if { [string first . $host] < 0 } {
82 # not a fully qualified domain name
83 return ""
84 }
85 return $host
86 }
87
88 #
89 # Return a good guess for an email name of the user who is
90 # running the underlying mash tool. Return an empty string
91 # if our guesswork fails. This is used, for example, as the
92 # default in a type-in box for the RTP email id.
93 #
94 proc email_heuristic {} {
95 set user [user_heuristic]
96 set addr [local_fqdn]
97 if { $addr == "" } {
98 return ""
99 }
100 return $user@$addr
101 }
102
103 #
104 # Please "import mashutils" to use this proc. <br>
105 #
106 # Return a good guess for the a string identifying the user who
107 # is running the underlying mash tool. Return "UKNOWN" if our
108 # guesswork fails.
109 #
110 proc user_heuristic {} {
111 global env
112 if [info exists env(USER)] {
113 set user $env(USER)
114 } elseif [info exists env(LOGNAME)] {
115 set user $env(LOGNAME)
116 } else {
117 #
118 # try vic built-in which is present under windows
119 #
120 catch {set env(USER) [getusername]}
121 if [info exists env(USER)] {
122 return $env(USER)
123 }
124 return "UNKNOWN"
125 }
126 }
127
128 #
129 # Please "import mashutils" to use this proc.
130 #
131 proc format_fps f {
132 set fps $f
133 if { $fps < .1 } {
134 set fps "0 f/s"
135 } elseif { $fps < 10 } {
136 set fps [format "%.1f f/s" $fps]
137 } else {
138 set fps [format "%2.0f f/s" $fps]
139 }
140
141 return $fps
142 }
143
144 #
145 # Please "import mashutils" to use this proc.
146 #
147 proc format_bps b {
148 set bps $b
149
150 if { $bps < 1 } {
151 set bps "0 bps"
152 } elseif { $bps < 1000 } {
153 set bps [format "%3.0f bps" $bps]
154 } elseif { $bps < 1000000 } {
155 set bps [format "%3.1f kb/s" [expr $bps / 1000.]]
156 } else {
157 set bps [format "%.2f Mb/s" [expr $bps / 1000000.]]
158 }
159
160 return $bps
161 }
162
163 #
164 # Please "import mashutils" to use this proc.
165 #
166 proc gettime {sec} {
167 clock format $sec
168 }
169
170 #
171 # Please "import mashutils" to use this proc.
172 #
173 proc sdr_gettimeofday {} {
174 clock seconds
175 }
176
177 #
178 # Please "import mashutils" to use this proc.
179 #
180 proc gettimenow {} {
181 gettime [clock seconds]
182 }
183
184 #
185 # Please "import mashutils" to use this proc.
186 #
187 proc getreadabletime {} {
188 return [clock format [clock seconds] -format {%H:%M, %d/%m/%y}]
189 }
190
191 #
192 # Please "import mashutils" to use this proc.
193 #
194 proc unix_to_ntp {unixtime} {
195 set oddoffset 2208988800
196 if {$unixtime==0} {return 0}
197 return [format %u [expr $unixtime + $oddoffset]]
198 }
199
200 #
201 # Please "import mashutils" to use this proc.
202 #
203 proc ntp_to_unix {ntptime} {
204 set oddoffset 2208988800
205 if {($ntptime==0)||($ntptime==1)} {return $ntptime}
206 if {[catch {expr $ntptime - $oddoffset}] !=0} {
207 return 0
208 #FIXME
209 }
210 return [format %u [expr $ntptime - $oddoffset]]
211 }
212
213 #
214 # Please "import mashutils" to use this proc.
215 #
216 proc duration_readable {secs {option terse}} {
217
218 set ret ""
219 set r [expr round($secs)]
220 set h [expr $r / 3600]
221 set r [expr $r % 3600]
222 set m [expr $r / 60]
223 set s [expr $r % 60]
224
225
226 if {$option == "verbose"} then {
227 if {$h} {
228 set ret "$ret $h\h"
229 }
230 if {$m} {
231 set ret "$ret $m\m"
232 }
233 if {$s} {
234 set ret "$ret and $s\s"
235 }
236 } else {
237 set ret "$h:$m:$s"
238 }
239 return $ret
240 }
241
242
243
244 proc in_multicast addr {
245 return [expr ([lindex [split $addr .] 0] & 0xf0) == 0xe0]
246 }
247
248 proc in_ssm { addr } {
249 return [expr [lindex [split $addr .] 0] == 232]
250 }
251
252
253 proc invalid_addr a {
254 set l [split $a .]
255 if {[llength $l] != 4} { return 1 }
256 foreach i $l {
257 if {![is_number $i] || $i<0 || $i>255} { return 1 }
258 }
259 return 0
260 }
261
262 proc is_number n {
263 if [catch {expr $n}] {
264 return 0
265 }
266 return 1
267 }
268
269
270 proc parray {a {pattern *}} {
271 upvar 1 $a array
272 if ![array exists array] {
273 error "\"$a\" isn't an array"
274 }
275 set maxl 0
276 foreach name [lsort [array names array $pattern]] {
277 if {[string length $name] > $maxl} {
278 set maxl [string length $name]
279 }
280 }
281 set maxl [expr {$maxl + [string length $a] + 2}]
282 foreach name [lsort [array names array $pattern]] {
283 set nameString [format %s(%s) $a $name]
284 puts stdout [format "%-*s = %s" $maxl $nameString $array($name)]
285 }
286 }
287
This page was automatically generated by the
LXR engine.
Visit the LXR main site for more
information.