1 # ui-univ.tcl --
2 #
3 # FIXME: This file needs a description here.
4 #
5 # Copyright (c) 1996-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/applications/uc/ui-univ.tcl,v 1.13 2002/02/03 04:22:33 lim Exp $
32
33
34 import mashutils Trace Observer RendezvousManager UIGenerator SrvAllocUI
35
36 # import some default client UIs
37 import AVSwitchUI CameraUI PowerSwitchUI RvicClientUI
38
39 # load http namespace
40 ::http::formatQuery
41
42
43 #Trace on
44 #Trace add UniversalUI
45 #Trace add checkButtonInvoke
46
47
48 # --- Notes / Bugs ---------------
49 # Checkbuttons:
50 # - clicking too rapidly will crash it due to a race(?) condition:
51 # somehow a second invoke get called before a first one finishes.
52 # ----------------------------------
53
54
55 #
56 # a UI that wraps client UI agents.
57 #
58 Class UniversalUI -superclass Observer
59
60
61 # init method takes
62 # args are a tk window to parent the UniversalUI
63 # and a list of pairs of the form
64 # <br> 'Client-UI-agent-class' 'Server-address-spec'
65 # <br>i.e.,<br> AVSwitchUI spade/1211 CameraUI spade/1212
66 #
67 UniversalUI public init {w args} {
68 Trc $class "--> ${class}::$proc"
69 $self next
70
71 $self parse_components $args
72 $self read_mysrvs_files
73 $self init_gui $w
74 $self read_omappings_file
75 $self init_rendez
76 $self update_gui
77 }
78
79 #
80 UniversalUI public destroy {} {
81 $self instvar rv_
82 $rv_ detach_observer $self
83 $self next
84 }
85
86 # build list of components: each client UI agent can have one or
87 # more servers (addresses) it can connect to.
88 UniversalUI private parse_components {args} {
89 Trc $class "--> ${class}::$proc $args"
90 $self instvar components_ active_
91 set args [lindex $args 0]
92
93 foreach {agent addrspec} $args {
94 # import native agents
95 if {[string first "WPI:" $agent]!=0 && [string first "-" $agent]!=0} {
96 import $agent
97 if {[info commands $agent] == ""} {
98 puts "Cannot find class $agent .. ignoring it"
99 continue
100 }
101 # if addrspec includes a name, turn it into IP addr
102 set n [lindex [split $addrspec "/"] 0]
103 set p [lindex [split $addrspec "/"] 1]
104 set s [gethostbyname $n]
105 if { $s == "" } {
106 puts "cannot find address for '$n'... ignoring it."
107 continue
108 }
109 set addrspec $s/$p
110 }
111
112 # only add components once
113 if {[array names components_ $agent] == "" || \
114 [lsearch -exact $components_($agent) $addrspec] == -1} {
115 lappend components_($agent) $addrspec
116 }
117 }
118 foreach i "[array names components_]" {
119 if {[array names active_ $i] == ""} {
120 # checkbuttons default off
121 set active_($i) 0
122 }
123 }
124 #parray components_
125 }
126
127 # read in saved/"custom-designed" services <p> (i.e., things the
128 # user has saved in their `mysrvs' directory, either for use outside
129 # the location where it normally dynamically discovered or as
130 # a totally new service built upon other services.
131 #<p>
132 # These are XML files for use with automatic UI generation,
133 # but since the XML can embed whole UIs with the <UI> tag,
134 # this covers all cases (mixed use).
135 #
136 UniversalUI private read_mysrvs_files {} {
137 set d [$self get_option mySrvsDir]
138 Trc $class "${class}::${proc} : mySrvsDir = `$d'"
139 if {![file isdirectory $d] || [catch {glob $d/*} catchRes]} {
140 puts "Personal services directory not specified/accessable/empty:"
141 puts " No personal services will be loaded."
142 } else {
143 foreach f [glob $d/*] {
144 $self parse_components "-[file tail $f] local-file"
145 }
146 }
147
148 }
149
150
151 # --------------------------------------------------
152 # Methods for dealing with GUI stuff
153 # --------------------------------------------------
154
155
156 #
157 UniversalUI private init_gui {w} {
158 Trc $class "--> ${class}::$proc"
159 $self instvar components_ curAddr_ w_ uigen_
160 set w_ $w
161 set uigen_ [new UIGenerator]
162
163 # list of clients
164 frame $w.listFrame -relief sunken
165 pack $w.listFrame -side left -expand 1
166
167 # footer
168 frame $w.listFrame.foot -relief groove
169 label $w.listFrame.foot.l -text " UC v[version]"
170 pack $w.listFrame.foot.l -fill x
171 pack $w.listFrame.foot -side bottom -fill x -expand 1
172
173 # application UI side frame
174 frame $w.appFrame
175 pack $w.appFrame -side right -fill y -expand 1
176
177 bind . <q> exit
178 }
179
180 # updates list of components based on contents of compnents_ array
181 UniversalUI private update_gui {} {
182 Trc $class "--> ${class}::$proc"
183 $self instvar components_ curAddr_ w_
184 set w $w_
185 set need_repack 0
186
187 foreach uiType "[array names components_]" {
188 if {[info commands $w.listFrame.cb$uiType] == ""} {
189 set need_repack 1
190 # for each type we have a checkbox
191 checkbutton $w.listFrame.cb$uiType -text "$uiType" \
192 -command "$self checkButtonInvoke $uiType"
193 }
194 set count 0
195 foreach addr [lsort $components_($uiType)] {
196
197 set addrlabel [lindex [split $addr /] 0]
198 set addrlabel [lookup_host_name $addrlabel]
199 if ![invalid_addr $addrlabel] {
200 set addrlabel $addr
201 } else {
202 set addrlabel [lindex [split $addrlabel .] 0]
203 }
204
205 if {[info commands $w.listFrame.rb$uiType$count] == ""} {
206 set need_repack 1
207
208 # under each type we have a radiobutton for each addr
209 radiobutton $w.listFrame.rb$uiType$count -padx 10 \
210 -text "$addrlabel" \
211 -command "$self radioButtonInvoke $uiType $addr" \
212 -variable dummyVar$uiType -value $count
213 if {$count == 0} {
214 set curAddr_($uiType) $addr
215 $w.listFrame.rb$uiType$count invoke
216 }
217 } else {
218 $w.listFrame.rb$uiType$count configure \
219 -text "$addrlabel" \
220 -command "$self radioButtonInvoke $uiType $addr" \
221 -value $count
222 }
223 incr count
224 }
225 }
226 if $need_repack {
227 foreach i [info commands $w.listFrame.cb*] {pack forget $i}
228 foreach i [info commands $w.listFrame.rb*] {pack forget $i}
229 foreach uiType "[lsort [array names components_]]" {
230 pack $w.listFrame.cb$uiType -side top -anchor w
231 set count 0
232 foreach addr $components_($uiType) {
233 pack $w.listFrame.rb$uiType$count -side top -anchor w
234 incr count
235 }
236 }
237 }
238 }
239
240 #
241 # toggles active_($agent), which indicates whether the UI for
242 # the agent is being shown
243 #
244 UniversalUI private checkButtonInvoke {agent} {
245 Trc $class "--> ${class}::$proc"
246 Trc $proc "--> ${class}::$proc"
247 #puts $agent
248
249 $self instvar active_ agents_ w_ curAddr_ uigen_
250
251 if {$active_($agent) == 0} {
252 # was off: build and pack it
253
254 frame $w_.appFrame.ag$agent
255 pack $w_.appFrame.ag$agent -side right
256
257 if {[string first "WPI:" $agent]==0} {
258 global env
259 set filename [string range $agent 4 end]
260 set filename [file join $env(HOME) .mash WPI $filename]
261 set o [$uigen_ GenerateUIfromFile $filename $w_.appFrame.ag$agent]
262 # set this to list of sub-agents allocated internally to gen'd UI
263 set agents_($agent) $o
264 } elseif {[string first "-" $agent]==0} {
265 set filename [string range $agent 1 end]
266 set dir [$self get_option mySrvsDir]
267 set filename [file join [glob $dir] $filename]
268 set o [$uigen_ GenerateUIfromFile $filename $w_.appFrame.ag$agent]
269 set agents_($agent) $o
270 } else {
271 set agents_($agent) \
272 [new $agent $w_.appFrame.ag$agent $curAddr_($agent)]
273 }
274 set active_($agent) 1
275 } else {
276 # was on, destroy the agent
277
278 # can be a list due to multiple <UI> tags in a gen'd UI
279 foreach a $agents_($agent) {
280 Trc $class "deleting `$a'"
281 delete $a
282 }
283 pack forget $w_.appFrame.ag$agent
284 destroy $w_.appFrame.ag$agent
285 Trc $class "destroyed $w_.appFrame.ag$agent"
286 set active_($agent) 0
287 }
288 Trc $proc "<-- ${class}::$proc"
289 }
290
291 #
292 UniversalUI private radioButtonInvoke {agent addr} {
293 Trc $class "--> ${class}::$proc"
294 #puts "$agent $addr"
295 $self instvar curAddr_ active_
296
297 if {$curAddr_($agent) == $addr} {
298 return
299 }
300 set curAddr_($agent) $addr
301 if {$active_($agent)} {
302 update
303 $self checkButtonInvoke $agent
304 update
305 $self checkButtonInvoke $agent
306 update
307 }
308 }
309
310
311
312
313 # --------------------------------------------------
314 # Methods for dealing with a RendezvousManager and
315 # its upcalls
316 # --------------------------------------------------
317
318
319 #
320 UniversalUI private init_rendez {} {
321 Trc $class "--> ${class}::$proc"
322 $self instvar rv_
323
324 set rspeclist [$self get_option rendez]
325 if {$rspeclist==""} {return}
326
327 set rv [RendezvousManager info instances]
328 if {[llength $rv] > 1} {
329 puts "Warning: Multiple RendezvousManagers"
330 set rv [lindex $rv 0]
331 }
332 if {$rv == ""} {
333 set rv_ [new RendezvousManager $rspeclist]
334 } else {
335 set rv_ $rv
336 foreach s [split $rspeclist ,] {
337 $rv_ add_spec $s
338 }
339 }
340
341 $rv_ attach_observer $self
342 }
343
344 # some example msgs -- (This is never called! -- it is an e.g.!)
345 UniversalUI private test_msgs {} {
346 Trc $class "--> ${class}::$proc"
347 $self instvar rv_
348 after 2000 "$rv_ recv_msg w x y \
349 {obj-mapping: server=mash-object:ServObjName\
350 client=mash-object:ClientObjName} z"
351 after 4000 "$rv_ recv_msg w x y \
352 {will-provide: mash-object=ServObjName ctrlspec=AddrSpec} z"
353 after 6000 "$rv_ recv_msg w x y \
354 {will-provide: name=326 mash-object=Serv2ObjName \
355 ctrlspec=mercenary/9988 \
356 WPI=http://www.cs.berkeley.edu/~hodes/WPI/326power.xml} z"
357 after 8000 "$rv_ recv_msg w x y \
358 {will-provide: name=326-w-ui mash-object=Serv2ObjName \
359 ctrlspec=mercenary/9988 \
360 WPI=http://www.cs.berkeley.edu/~hodes/WPI/326power-w-ui.xml} z"
361 after 9000 "$rv_ recv_msg w x y \
362 {will-provide: name=405lights ctrlspec=htsr/6902 \
363 WPI=http://www.cs.berkeley.edu/~hodes/WPI/405lights.xml} z"
364 }
365
366 # a new server is available, so allocate the client
367 UniversalUI private new_service_avail {rspec agent ctrladdr} {
368 Trc $class "--> ${class}::$proc"
369 $self parse_components "$agent $ctrladdr"
370 $self update_gui
371 }
372
373
374
375 # Accepts an upcall from an (Observable) RendezvousManager when a msg of
376 # type ``will-provide'' is received.
377 #<p>
378 # Checks for msgs of the form:
379 # <br>
380 # "will-provide: mash-object=`ObjName' ctrlspec=`AddrSpec' [`Attr'=`Val'] ..."
381 # <br>or<br>
382 # "will-provide: WPI=http://... [`Attr'=`Val'] ..."
383 # <br>
384 # which are announcements of available services
385 #
386 UniversalUI private rendez_recv_will-provide {rvmsg} {
387 Trc $class "--> ${class}::$proc"
388 set ob [$rvmsg get_field mash-object]
389 if {$ob != ""} {
390 # is a mash object: check for matching client mash object
391 set clForObj [$self get_omapping $ob]
392 if {$clForObj != ""} {
393 set ad [$rvmsg get_field ctrlspec]
394 if {$ad != ""} {
395 $self new_service_avail [$rvmsg rspec] $clForObj $ad
396 return
397 }
398 } else {
399 Trc $class "unknown client object for server `$ob'"
400 }
401 }
402 # if we got here, either its not a mash object, or we have no
403 # client for it, or no ctrladdr -- attempt to generate a UI
404 $self use_WPI $rvmsg
405 }
406
407 # recv a `can-allocate' method -- allocate a SrvAllocUI agent for it.
408 #
409 UniversalUI private rendez_recv_can-allocate {rvmsg} {
410 Trc $class "--> ${class}::$proc"
411 $self instvar rv_
412 set rspec [$rvmsg rspec]
413 $self new_service_avail $rspec SrvAllocUI $rspec
414 }
415
416
417 #
418 UniversalUI private use_WPI {rvmsg} {
419 Trc $class "--> ${class}::$proc"
420 $self instvar rv_
421
422 set url [$rvmsg get_field WPI]
423 if {$url != ""} {
424 set name [$rvmsg get_field name]
425 if {$name == ""} {
426 puts "Using a `will-provide' WPI with no name field"
427 }
428 if {[$self get_WPI $url $name] == 0} {return}
429 # let the application know that this new service is
430 # available but needs to have its UI dynamically generated
431 # by prepending "WPI:" to its component name
432 set spec [$rvmsg rspec]
433 $self new_service_avail $spec WPI:$name [$rv_ get_spec_name $spec]
434 } else {
435 puts "no WPI for dynamically generating a UI: ignoring new service."
436 }
437 }
438
439 # Checks for msgs of the form:
440 # <br>
441 # "object-mapping: server=mash-object=`ObjName' client=mash-object=`ObjName'"
442 # <p>
443 # which are mappings from a server type to a client type.
444 #
445 UniversalUI private rendez_recv_obj-mapping {rvmsg} {
446 Trc $class "--> ${class}::$proc"
447 set cli "" ; set ser ""
448 set data [$rvmsg get_msg]
449 foreach i [lrange $data 1 end] {
450 if {[string first "server=" $i]==0} {
451 set idx [string first = $i]
452 set ser [string range $i [expr $idx+1] end]
453 }
454 if {[string first "client=" $i]==0} {
455 set idx [string first = $i]
456 set cli [string range $i [expr $idx+1] end]
457 }
458 }
459 if {$cli == "" || $ser == ""} {
460 puts "bad `obj-mapping:' message: $data"
461 return
462 }
463 foreach i "$cli $ser" {
464 set obType [lindex [split $i :] 0]
465 if {$obType != "mash-object"} {
466 puts "ignoring unknown obj type: $obType"
467 return
468 }
469 }
470 set idx [string first : $cli]
471 set cli [string range $cli [expr $idx+1] end]
472 set idx [string first : $ser]
473 set ser [string range $ser [expr $idx+1] end]
474 if {[$self set_omapping $ser $cli]} {
475 puts "adding mapping from $ser to $cli"
476 } else {
477 # we've already mapped it, no msg to user
478 }
479 }
480
481
482
483 # load mappings:
484 # "server object to client object"
485 # "client object to WRI"
486 #
487 UniversalUI private read_omappings_file {{filename ""}} {
488 Trc $class "--> ${class}::$proc"
489
490 set mf $filename
491 if {$filename == ""} {
492 global env
493 set mf [file join $env(HOME) .mash obj-mappings]
494 }
495 if [file readable $mf] {
496 set fp [open $mf r]
497 set filedata [read $fp]
498 set linedata [split $filedata "\n"]
499 foreach i $linedata {
500 set j [string trim $i]
501 if {$j == ""} {continue}
502 if {[string index $j 0] == "#"} {continue}
503 if {[llength $j] != 2} {
504 puts "error in mapping file `$mf' format:"
505 puts " `$j'"
506 continue
507 }
508 $self set_omapping [lindex $j 0] [lindex $j 1]
509 }
510 close $fp
511 } else {
512 puts "Mapping file `$mf' not found/readable..."
513 }
514 }
515
516 # get client object name for a given server object name
517 # or return {} if no mapping available
518 UniversalUI public get_omapping {serverObj} {
519 Trc $class "--> ${class}::$proc"
520 $self instvar obj_mappings_
521 if {[array names obj_mappings_ $serverObj] != ""} {
522 return $obj_mappings_($serverObj)
523 } else {
524 return ""
525 }
526 }
527
528 # set serverObj mapping to clientObj ; returns 1 if it
529 # is a new mapping or 0 if not
530 UniversalUI public set_omapping {serverObj clientObj} {
531 Trc $class "--> ${class}::$proc"
532 $self instvar obj_mappings_
533 #puts "UniversalUI:set_omapping : $serverObj $clientObj"
534
535 set old ".Invalid."
536 if {[array names obj_mappings_ $serverObj] != ""} {
537 set old $obj_mappings_($serverObj)
538 }
539 set obj_mappings_($serverObj) $clientObj
540 if {$old == $clientObj} {
541 return 0
542 } else {
543 return 1
544 }
545 }
546
547
548 #
549 # Get the WPI at `url', save it to a file under ~/.mash/WPI/
550 #
551 UniversalUI private get_WPI {url obj_name} {
552 Trc $class "--> ${class}::$proc"
553
554 if {$obj_name == ""} {
555 set obj_name [$self URLToFilename $url]
556 }
557 global env
558 set path [file join $env(HOME) .mash WPI]
559 if ![file isdirectory $path] {
560 puts "Creating directory `$path' to hold WPIs."
561 file mkdir $path
562 }
563 set fullname [file join $path $obj_name]
564 if ![file readable $fullname] {
565 #puts "getting `$url', putting in $fullname ..."
566 return [$self copyURLtoFile $url $fullname]
567 }
568 return 1
569 }
570
571 # url-to-file copy
572 # <br> returns ::http state token on success, 0 on error
573 #
574 UniversalUI private copyURLtoFile { url file {chunk 4096} } {
575 Trc $class "--> ${class}::$proc"
576 puts "Requesting URL $url ..."
577 set out [open $file w]
578 set token [::http::geturl $url -channel $out -blocksize $chunk]
579 close $out
580 set retVal [::http::code $token]
581 if {[lindex $retVal 1] != 200} {
582 puts "Error: HTTP request failed: $retVal"
583 return 0
584 }
585 ::http::reset $token
586 return $token
587 }
588
589 #
590 UniversalUI private URLToFilename {url} {
591 Trc $class "--> ${class}::$proc"
592 set name [split $url /]
593 set name [join $name ,]
594 #puts "url `$url' maps to filename `$name'"
595 return $name
596 }
597
598 #
599 UniversalUI private FilenameToURL {filename} {
600 Trc $class "--> ${class}::$proc"
601 set url [split $filename ,]
602 set url [join $name /]
603 return $url
604 }
605
606
This page was automatically generated by the
LXR engine.
Visit the LXR main site for more
information.