1 # ui-ctrlmenu.tcl --
2 #
3 # FIXME: This file needs a description here.
4 #
5 # Copyright (c) 1993-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/vic/ui-ctrlmenu.tcl,v 1.95 2004/05/27 00:13:54 larry Exp $
32
33
34 import TextEntry ErrorWindow GlobalWindow KeyEditor Entry Configuration
35
36 #
37 # A control menu to control the various elements of
38 # the video capture and rendering subsystems.
39 #
40 Class ControlMenu -superclass TopLevelWindow -configuration {
41 recvOnly 0
42 framerate 8
43 maxbw -1
44 bandwidth 128000
45 useHardwareDecode false
46 stillGrabber false
47 }
48
49 #
50 ControlMenu proc fork_histtolut { } {
51 $self tkvar ditherStyle_
52 $self instvar vframe_ asm_ optionsMenu_
53
54 if { $ditherStyle_ == "gray" } {
55 new ErrorWindow "cannot optimize grayscale rendering"
56 return
57 }
58 #
59 # create a histogram object and collect stats from decoders
60 #
61 set ch [[$vframe_ set colorModel_] create-hist]
62 set active 0
63
64 foreach src [$asm_ active-sources] {
65 set d [$src handler]
66 if { ![$src mute] && $d != "" } {
67 $d histogram $ch
68 set active 1
69 }
70 }
71 if !$active {
72 new ErrorWindow "no active, unmuted sources"
73 delete $ch
74 return
75 }
76 set pid [pid]
77 set outfile /tmp/vicLUT.$pid
78 set infile /tmp/vicHIST.$pid
79
80 if { [$ch dump $infile] < 0 } {
81 new ErrorWindow "couldn't create $infile"
82 delete $ch
83 return
84 }
85 delete $ch
86 #
87 # fork off a histtolut and use tk fileevent to call back
88 # finish_histtolut when the child is done
89 #
90 #FIXME -n
91 set eflag ""
92 if { $ditherStyle_ == "ed" } {
93 set eflag "-e"
94 }
95 if [catch \
96 "open \"|histtolut $eflag -n 170 -o $outfile $infile\"" pipe] {
97 new ErrorWindow "histtolut not installed in your path"
98 return
99 }
100 fileevent $pipe readable "$self finish_histtolut $pipe $infile $outfile"
101 # disable button while histtolut is running
102 $optionsMenu_ entryconfigure "Optimize Colormap" \
103 -state disabled
104 $self instvar path_
105 $path_ configure -cursor watch
106 }
107
108 #
109 ControlMenu proc finish_histtolut { pipe infile outfile } {
110 $self instvar path_
111 $path_ configure -cursor ""
112 $self instvar optionsMenu_ vframe_ asm_
113 $optionsMenu_ entryconfigure "Optimize Colormap" -state normal
114 set cm [$vframe_ set colorModel_]
115 $cm free-colors
116 $cm lut $outfile
117 if ![$cm alloc-colors] {
118 #FIXME unset lut
119 $vframe_ revert_to_gray
120 }
121 #FIXME make this a proc
122 foreach src [$asm_ active-sources] {
123 set d [$src handler]
124 if { $d != "" } {
125 $d redraw
126 }
127 }
128 fileevent $pipe readable ""
129 close $pipe
130 }
131
132 #
133 ControlMenu instproc have_transmit_permission {} {
134 $self instvar vpipe_
135 if { [$vpipe_ input_devices] != "" } {
136 return ![$self yesno recvOnly]
137 }
138 return 0
139 }
140
141 #
142 # Creates a toplevel window at ".menu". Send it a ui (<i>mainUI</i>), a
143 # VideoAgent (<i>agent</i>), a VideoPipeline (<i>vpipe</i>), a
144 # VisualFrame (<i>vframe</i>), an ActiveSourceManager (<i>asm</i>), and
145 # a UISrcListWindow (<i>uiSrcListWin</i>). The <i>ui</i> object must
146 # implement the accessor methods, <i>use_hw_decode</i> and
147 # <i>mute_new_sources</i>.
148 #
149 ControlMenu instproc init { mainUI agent vpipe vframe asm uiSrcListWin} {
150 $self next .menu
151 $self instvar ui_ videoAgent_ qval_ lastFmt_ path_ vpipe_ \
152 ui_srclist_ vframe_ asm_ captureFile_ window_built_
153
154 set ui_ $mainUI
155 set ui_srclist_ $uiSrcListWin
156 set videoAgent_ $agent
157 set vpipe_ $vpipe
158 set vframe_ $vframe
159 set asm_ $asm
160 set lastFmt_ ""
161 set captureFile_ ""
162 set window_built_ 0
163
164 set qval_(h261) 68
165 set qval_(h263+) 68
166 set qval_(h263) 68
167 set qval_(nv) 80
168 set qval_(nvdct) 80
169 set qval_(pvh) 60
170 set qval_(jpeg) 29
171 set qval_(mpeg4) 70
172
173 $self set_default_formats
174
175 $self tkvar useHardwareDecode_ ditherStyle_ deviceDialogsState_ \
176 muteNewSources transmitButtonState_ sending_slides_ \
177 video_format_
178
179 set useHardwareDecode_ [$self yesno useHardwareDecode]
180 set ditherStyle_ [$vframe_ set dither_]
181 set deviceDialogsState_ 0
182 set muteNewSources [$self yesno muteNewSources]
183 set transmitButtonState_ 0
184 set sending_slides_ 0
185 set video_format_ [$self get_default_video_format]
186
187 $self select_device [$self selectInitialDevice]
188
189 if [$self get_option transmitOnStartup] {
190 set transmitButtonState_ 1
191 $self transmit
192 }
193 }
194
195 #
196 # Build the menu panel. Called from toggle_window,
197 # the first time the Menu button is hit.
198 #
199 ControlMenu instproc build w {
200 $self create-window $w "Video Settings"
201 $self instvar special_fx
202 wm withdraw $w
203 catch "wm resizable $w false false"
204
205 frame $w.session
206 frame $w.cb
207 $self build.xmit $w.cb
208 if { [$self yesno useScuba] && [$self get_option megaVideoSession] != ""} {
209 frame $w.scuba
210 $self build.scuba $w.scuba
211 }
212
213 if {[$self get_option specialFX] == 1} {
214 frame $w.specialfx
215 $self build.special_fx $w.specialfx
216 }
217 frame $w.encoder
218 $self build.encoder $w.encoder
219 frame $w.decoder
220 $self build.decoder $w.decoder
221
222 $self instvar videoAgent_
223 $self build.session $w.session \
224 [$videoAgent_ session-info] \
225 [$videoAgent_ get_local_srcid] \
226 [$videoAgent_ get_local_sdes name]
227
228 button $w.dismiss -text Dismiss -borderwidth 2 -width 8 \
229 -relief raised -anchor c \
230 -command "$self toggle" -font [$self get_option medfont]
231
232 pack $w.cb -padx 6 -fill x -expand 1
233 if { [$self yesno useScuba] && [$self get_option megaVideoSession] != "" } {
234 pack $w.scuba -padx 6 -fill x -expand 1
235 }
236 if {[$self get_option specialFX] == 1} {
237 pack $w.specialfx $w.encoder $w.decoder $w.session -padx 6 -fill x -expand 1
238 } else {
239 pack $w.encoder $w.decoder $w.session -padx 6 -fill x -expand 1
240 }
241 pack $w.dismiss -anchor c -pady 4
242
243 $self set window_built_ 1
244 $self update_device
245
246 wm protocol $w WM_DELETE_WINDOW "$self toggle"
247 }
248
249 #
250 ControlMenu instproc selectInitialDevice {} {
251 $self instvar vpipe_
252 set L [$vpipe_ input_devices]
253 set d [string trim [$self get_option defaultDevice] {\"}]
254
255 # now select the device - by nickname or VideoCapture device name
256 foreach v $L {
257 if { [$v attributes] == "disabled" } {
258 continue
259 }
260 if { [$v nickname] == $d } {
261 return $v
262 }
263 if [regexp {VideoCapture/(.*)} $v match dev] {
264 if {$dev == $d} {
265 return $v
266 }
267 }
268 }
269
270 foreach v $L {
271 if { "[$v attributes]" != "disabled" && \
272 "[$v nickname]" != "still" } {
273 return $v
274 }
275 }
276
277 # uh-oh, can't find any device
278 return ""
279 }
280
281 #
282 ControlMenu instproc create_global_window {} {
283 $self instvar src_ global_win_
284 if [info exists global_win_] {
285 $self delete_global_window
286 } else {
287 set global_win_ [new GlobalWindow .globalStats "Session Stats" "$self stats" "$self delete_global_window"]
288 }
289 }
290
291 #
292 ControlMenu instproc delete_global_window {} {
293 $self instvar global_win_
294 delete $global_win_
295 unset global_win_
296 }
297
298 #
299 ControlMenu instproc stats {} {
300 return [[$self set videoAgent_] stats]
301 }
302
303 #
304 ControlMenu instproc new_hostspec {} {
305 $self instvar videoAgent_ addrspec_ namespec_
306 if ![info exists addrspec_] {
307 return
308 }
309
310 set info [$videoAgent_ session-info]
311 set srcid [$videoAgent_ get_local_srcid]
312 $addrspec_ configure -text "$info ID: $srcid"
313
314 set name [$videoAgent_ get_local_sdes name]
315 $namespec_.entry delete 0 end
316 $namespec_.entry insert 0 $name
317
318 $self instvar transmitButton_
319 $transmitButton_ configure -state normal
320 }
321
322 #
323 # switches the VideoAgent object.
324 # This method should be called always from VicUI::switch-agent
325 #
326 ControlMenu instproc switch-agent {new_agent} {
327 $self instvar videoAgent_
328
329 # set the new VideoAgent
330 set videoAgent_ $new_agent
331
332 # update the UI
333 $self new_hostspec
334 }
335
336
337 #
338 ControlMenu instproc build.session { w info srcid name } {
339 set f [$self get_option smallfont]
340
341 label $w.title -text Session
342 pack $w.title -fill x
343
344 frame $w.nb -relief sunken -borderwidth 2
345 pack $w.nb -fill x
346
347 frame $w.nb.frame
348 pack append $w.nb $w.nb.frame { top fillx }
349
350 $self instvar addrspec_ sessionspec_ namespec_
351 append info " ID: $srcid"
352 label $w.nb.frame.info -font $f -anchor w -text $info
353 set addrspec_ $w.nb.frame.info
354
355 # the "Switch session: ..." line
356 frame $w.nb.frame.session
357 label $w.nb.frame.session.label -text "Switch session: " -font $f\
358 -anchor e -width 20
359 new TextEntry "$self update_session" $w.nb.frame.session.entry ""
360 pack $w.nb.frame.session.label -side left
361 pack $w.nb.frame.session.entry -side left -expand 0 -fill x -pady 2
362 set sessionspec_ $w.nb.frame.session
363
364 # the "Name: ..." line
365 frame $w.nb.frame.name
366 label $w.nb.frame.name.label -text "Name: " -font $f -anchor e -width 7
367 new TextEntry "$self update_name" $w.nb.frame.name.entry $name
368 pack $w.nb.frame.name.label -side left
369 pack $w.nb.frame.name.entry -side left -expand 1 -fill x -pady 2
370 set namespec_ $w.nb.frame.name
371
372 # the "Note: ..." line
373 frame $w.nb.frame.msg
374 label $w.nb.frame.msg.label -text "Note: " -font $f -anchor e -width 7
375 new TextEntry "$self update_note" $w.nb.frame.msg.entry ""
376 pack $w.nb.frame.msg.label -side left
377 pack $w.nb.frame.msg.entry -side left -expand 1 -fill x -pady 2
378
379 #
380 # Create the entry widget for editing the session's
381 # encryption key. The audio agent exports methods
382 # (invoked by the KeyEditor) to enable/disable encryption.
383 #
384 $self instvar videoAgent_
385 new KeyEditor $w.nb.frame $videoAgent_
386
387 frame $w.nb.frame.b
388
389 # the "Global Stats" button
390 button $w.nb.frame.b.stats -text "Global Stats" -borderwidth 2 \
391 -anchor c -font $f -command "$self create_global_window"
392
393 # the "Members" button
394 $self instvar ui_srclist_
395 button $w.nb.frame.b.members -text Members -borderwidth 2 \
396 -anchor c -font $f -command "$ui_srclist_ toggle"
397
398 # the "Switch Session" button
399 # $self instvar ui_
400 # button $w.nb.frame.b.switch -text "Switch Session" -borderwidth 2 \
401 # -anchor c -font $f -command "$ui_ switch-agent 224.1.1.1/11111"
402
403
404 # pack all the widgets
405 pack $w.nb.frame.b.stats $w.nb.frame.b.members \
406 -side left -padx 4 -pady 2 -anchor c
407
408 pack $w.nb.frame.info $w.nb.frame.session $w.nb.frame.name\
409 $w.nb.frame.msg $w.nb.frame.key -fill x -padx 2 -expand 1
410 pack $w.nb.frame.b -pady 2 -anchor c
411 }
412
413
414
415 #
416 # ControlMenu::set_effect --
417 #
418 # Modifies/Adds a special effect (FX module) between the tap and encoder
419 # objects. It's been tested only with the Titling effect.
420 #
421 ControlMenu instproc set_effect {args} {
422 $self instvar effect_
423 $self instvar effect_on_
424 $self instvar fx_titling_string_
425 $self instvar fx_titling_font_size_
426 $self instvar fx_titling_font_type_
427
428 if {([info exists effect_on_]) && ($effect_on_ == 1)} {
429 $effect_ set-title $fx_titling_string_ $fx_titling_font_size_ \
430 $fx_titling_font_type_
431 } else {
432 eval $self add_effect [list $args]
433 }
434 }
435
436
437 #
438 # ControlMenu::add_effect --
439 #
440 # Adds a special effect (FX module) between the tap and encoder
441 # objects. It's been tested only with the Titling effect, and the
442 # ControlMenu UI only fires it.
443 #
444 ControlMenu instproc add_effect {args} {
445 $self instvar videoAgent_ vpipe_
446 $self instvar effect_
447 $self instvar effect_on_
448 $self instvar fx_titling_string_
449 $self instvar fx_titling_font_size_
450 $self instvar fx_titling_font_type_
451
452 #puts "ControlMenu::add_effect ($args)"
453 #puts "videoAgent_ is $videoAgent_, vpipe_ is $vpipe_"
454
455 # get the color subsampling scheme information
456 if {[catch {$vpipe_ set encoder_} encoder]} {
457 # there is not encoder yet
458 return
459 }
460 set encoder_csss [$encoder frame-format]
461
462 # create the video effect
463 #set effect_ [new Module/VideoEffect/Addition $encoder_csss]
464 #set effect_ [new Module/VideoEffect/Copy $encoder_csss]
465 #set effect_ [new Module/VideoEffect/EdgeDetect $encoder_csss]
466 #set effect_ [new Module/VideoEffect/FadeColor $encoder_csss]
467 #set effect_ [new Module/VideoEffect/PanScan $encoder_csss]
468 #set effect_ [new Module/VideoEffect/Whirlpool $encoder_csss]
469 #set effect_ [new Module/VideoEffect/ZeroCopy $encoder_csss]
470
471 # titling effect
472 set effect_ [new Module/VideoEffect/Titling $encoder_csss]
473 if {([info exists fx_titling_string_]) && \
474 ([info exists fx_titling_font_size_]) && \
475 ([info exists fx_titling_font_type_])} {
476 $effect_ set-title $fx_titling_string_ $fx_titling_font_size_ \
477 $fx_titling_font_type_
478 }
479
480
481 # link effect -> encoder
482 $effect_ target $encoder
483
484 # link tap -> effect
485 [$vpipe_ set tap_] target $effect_ $encoder
486
487 set effect_on_ 1
488 }
489
490
491
492 #
493 # ControlMenu::delete_effect --
494 #
495 # Deletes a special effect (FX module) object between the tap and encoder
496 # objects
497 #
498 ControlMenu instproc delete_effect {args} {
499 $self instvar vpipe_
500 $self instvar effect_
501 $self instvar effect_on_
502
503 if {[catch {$vpipe_ set encoder_} encoder]} {
504 # there is not encoder yet
505 return
506 }
507 [$vpipe_ set tap_] target $encoder $encoder
508 if {[info exists effect_] && ($effect_ != "")} {
509 delete $effect_
510 set effect_ ""
511 }
512
513 set effect_on_ 0
514 }
515
516 #
517 ControlMenu instproc build.special_fx w {
518 $self instvar fx_titling_string_
519 $self instvar fx_titling_font_size_
520 $self instvar fx_titling_font_type_
521 set f [$self get_option smallfont]
522
523 label $w.title -text "Special Effects"
524 frame $w.f -relief sunken -borderwidth 2
525
526
527 frame $w.f.title
528 frame $w.f.middle
529 frame $w.f.buttons
530
531 # label $w.f.title.title -text "Titling"
532 # pack $w.f.title.title
533
534
535
536 # Set/Delete buttons
537 button $w.f.buttons.set -text "Set" -borderwidth 2 \
538 -anchor c -font $f -command "$self set_effect"
539 button $w.f.buttons.delete -text "Delete" -borderwidth 2 \
540 -anchor c -font $f -command "$self delete_effect"
541 pack $w.f.buttons.set $w.f.buttons.delete \
542 -side left -padx 4 -pady 2 -anchor c
543
544 # "String: ..." line
545 set fx_titling_string_ ""
546 frame $w.f.middle.name
547 label $w.f.middle.name.label -text "Title: " -font $f -anchor e -width 7
548 new TextEntry "$self set-fx-title title" $w.f.middle.name.entry ""
549 pack $w.f.middle.name.label -side left
550 pack $w.f.middle.name.entry -side left -expand 1 -fill x -pady 2
551 set namespec_ $w.f.middle.name
552
553 # the font selection menus
554 $self build.font $w.f.middle.font
555
556 # pack $w.f.middle.name -fill x -expand 1
557 # pack $w.f.middle.font -expand 0
558
559 pack $w.f.middle.font -side right -expand 0
560 pack $w.f.middle.name -fill x -expand 1
561
562 pack $w.f.title -side top -anchor n -fill y -padx 6 -pady 4
563 pack $w.f.middle -side top -anchor n -fill both -expand 1
564 # pack $w.f.buttons -side bottom -anchor c -fill both
565 pack $w.f.buttons -pady 2 -anchor c
566
567 pack $w.title $w.f -fill x
568 }
569
570 #
571 ControlMenu instproc set-fx-title {what argument} {
572 $self instvar fx_titling_string_
573 $self instvar fx_titling_font_size_
574 $self instvar fx_titling_font_type_
575
576 switch -- $what {
577 title {
578 set fx_titling_string_ $argument
579 }
580 size {
581 set fx_titling_font_size_ $argument
582 }
583 type {
584 set fx_titling_font_type_ $argument
585 }
586 default {
587 puts "ControlMenu::set-fx-title: Unrecognized switch"
588 }
589 }
590
591 return 0
592 }
593
594
595 #
596 ControlMenu instproc build.font w {
597 $self instvar fx_titling_font_size_
598 $self instvar fx_titling_font_type_
599 $self instvar asm_ font_menu_
600
601 set font_list {"Helvetica"\
602 "Helvetica-Bold"\
603 "Helvetica-Narrow"
604 "Times-Roman"\
605 "Times-Bold"\
606 "Times-Italic"}
607 set font_sizes {11 12 14 16 18 20 22 24 26 28 30}
608
609 set f [$self get_option smallfont]
610 set font_menu_ $w.menu
611 menubutton $w -text Font... -menu $font_menu_ -relief raised \
612 -width 10 -font $f
613 menu $font_menu_
614
615 foreach font $font_list {
616 $font_menu_ add radiobutton -label $font\
617 -command "$self set-fx-title type $font" \
618 -value $font -variable fx_titling_font_type_ -font $f
619 }
620 $font_menu_ add separator
621 foreach size $font_sizes {
622 $font_menu_ add radiobutton -label " $size"\
623 -command "$self set-fx-title size $size" \
624 -value $size -variable fx_titling_font_size_ -font $f
625 }
626
627
628 # Display the current number of columns/rows.
629 $font_menu_ invoke [$font_menu_ index Helvetica]
630 $font_menu_ invoke [$font_menu_ index " 22"]
631 return
632 }
633
634 #
635 ControlMenu instproc setFillRate {} {
636 $self instvar vpipe_
637 $self tkvar transmitButtonState_ sending_slides_
638 if $transmitButtonState_ {
639 if $sending_slides_ {
640 $vpipe_ fillrate 16
641 } else {
642 $vpipe_ fillrate 2
643 }
644 }
645 }
646
647 #
648 ControlMenu instproc update_session spec {
649 $self instvar sessionspec_
650 $self instvar ui_
651
652 if { $spec == "" } { return 0 }
653
654 # check if the new session spec is correct
655 if [catch {set ab [SessionAddress parse $spec]} err] {
656 # XXX should retrieve something useful from $err
657 # XXX maybe this should be a dialog instead of
658 # a warning to stderr...
659 Log warn "Can't parse session address $spec"
660 return 0
661 }
662
663 # the spec is valid
664 delete $ab
665
666 # delete the text entry
667 $sessionspec_.entry delete 0 end
668
669 $ui_ switch-agent $spec
670 return 0
671 }
672
673 #
674 ControlMenu instproc update_capture filename {
675 if { $filename != "" } {
676 $self instvar captureFile_
677 set captureFile_ $filename
678 return 0
679 }
680 return -1
681 }
682
683 #
684 ControlMenu instproc update_name name {
685 if { $name != ""} {
686 $self instvar videoAgent_
687 $videoAgent_ set_local_sdes name $name
688 return 0
689 }
690 return -1
691 }
692
693 #
694 ControlMenu instproc update_note note {
695 $self instvar videoAgent_
696 $videoAgent_ set_local_sdes note $note
697 return 0
698 }
699
700 #
701 ControlMenu instproc transmit { } {
702 $self instvar vpipe_
703 $self tkvar device_ video_format_ transmitButtonState_ deviceDialogsState_
704
705 $vpipe_ set userDeviceDialogs_ $deviceDialogsState_
706 if $transmitButtonState_ {
707 set err [$vpipe_ select $device_ $video_format_]
708 if { $err != "" } {
709 set transmitButtonState_ 0
710 new ErrorWindow $err
711 $self select_device $device_
712 return
713 }
714 set err [$vpipe_ start]
715 if { $err != "" } {
716 set transmitButtonState_ 0
717 new ErrorWindow $err
718 $self select_device $device_
719 return
720 }
721 } else {
722 $vpipe_ stop
723 }
724 }
725
726 #
727 ControlMenu instproc release {} {
728 $self tkvar transmitButtonState_
729 set transmitButtonState_ 0
730 [$self set vpipe_] release_device
731 }
732
733 #
734 ControlMenu instproc build.buttons w {
735 set f [$self get_option smallfont]
736 $self instvar transmitButton_
737 $self tkvar transmitButtonState_
738 set transmitButton_ $w.send
739 set transmitButtonState_ 0
740 checkbutton $w.send -text "Transmit" \
741 -relief raised -command "$self transmit" \
742 -anchor w -variable [$self tkvarname transmitButtonState_] \
743 -font $f -state disabled -highlightthickness 0
744 button $w.release -text "Release" \
745 -relief raised -command "$self release" \
746 -font $f -highlightthickness 0
747
748 pack $w.send $w.release -fill both
749 }
750
751 #
752 ControlMenu instproc invoke_transmit {} {
753 $self instvar transmitButton_
754 $transmitButton_ invoke
755 }
756
757 #
758 ControlMenu instproc set_sessionbw { w value } {
759 $self instvar videoAgent_
760 $videoAgent_ sessionbw $value
761 $w configure -text [format_bps $value]
762 update idletasks
763 }
764
765 #
766 ControlMenu instproc set_bps { w value } {
767 $self instvar vpipe_ videoAgent_
768 $vpipe_ set_bps $value
769 $videoAgent_ local_bandwidth $value
770 $w configure -text [format_bps $value]
771 update idletasks
772 }
773
774 #
775 ControlMenu instproc set_fps { w value } {
776 $self instvar vpipe_
777 $vpipe_ set_fps $value
778 $w configure -text "$value f/s"
779 update idletasks
780 }
781
782 #
783 ControlMenu instproc build.sliders w {
784 set f [$self get_option smallfont]
785
786 global btext ftext
787 $self instvar videoAgent_
788 set key [$videoAgent_ set session_]
789 set ftext($key) "0.0 f/s"
790 set btext($key) "0.0 kb/s"
791
792 if [$self yesno useScuba] {
793 set rctext "Rate Control (SCUBA)"
794 set maxbw [$self get_option maxVideoSessionBW]
795 } else {
796 set rctext "Rate Control"
797 set maxbw [$self get_option maxbw]
798 }
799
800 frame $w.info
801 label $w.info.label -text $rctext -font $f
802 label $w.info.fps -textvariable ftext($key) -width 6 \
803 -font $f -pady 0 -borderwidth 0
804 label $w.info.bps -textvariable btext($key) -width 8 \
805 -font $f -pady 0 -borderwidth 0
806 pack $w.info.label -side left
807 pack $w.info.bps $w.info.fps -side right
808
809 frame $w.bps
810 scale $w.bps.scale -orient horizontal -font $f \
811 -showvalue 0 -from 1 -to $maxbw \
812 -command "$self set_bps $w.bps.value" -width 12 \
813 -relief groove
814 label $w.bps.value -font $f -width 10 -anchor w
815
816 frame $w.fps
817 scale $w.fps.scale -font $f -orient horizontal \
818 -showvalue 0 -from 1 -to 30 \
819 -command "$self set_fps $w.fps.value" -width 12 \
820 -relief groove
821 label $w.fps.value -font $f -width 10 -anchor w
822
823 pack $w.info -fill x
824 pack $w.bps $w.fps -fill x
825 pack $w.bps.scale -side left -fill x -expand 1
826 pack $w.bps.value -side left -anchor w
827 pack $w.fps.scale -fill x -side left -expand 1
828 pack $w.fps.value -side left -anchor w
829
830 if [$self yesno useScuba] {
831 set s [$videoAgent_ set session_]
832 $w.bps.scale set [$s data-bandwidth]
833 $w.fps.scale set 30
834 } else {
835 $w.bps.scale set [$self get_option bandwidth]
836 $w.fps.scale set [$self get_option framerate]
837 $w.bps.scale configure -resolution 1000
838 $w.bps.scale configure -from 1000
839 }
840
841 global fps_slider bps_slider
842 set fps_slider $w.fps.scale
843 set bps_slider $w.bps.scale
844 }
845
846 #
847 # called when selecting a new device: insert a grabber control panel
848 # if it exists and remove the old one (if one was installed)
849 #
850 ControlMenu instproc insert_grabber_panel devname {
851 set k [string first - $devname]
852 if { $k >= 0 } {
853 incr k -1
854 set devname [string range $devname 0 $k]
855 }
856 set k [string first " " $devname]
857 if { $k >= 0 } {
858 incr k -1
859 set devname [string range $devname 0 $k]
860 }
861 set devname [string tolower $devname]
862 if {[string range $devname end end] == ":"} {
863 set devname [string range $devname 0 [expr [string length $devname] - 2]]
864 }
865
866 $self instvar path_ grabber_panel_
867 set w $path_.$devname
868 if [info exists grabber_panel_] {
869 if { "$grabber_panel_" == "$w" } {
870 return
871 }
872 pack forget $grabber_panel_
873 unset grabber_panel_
874 }
875 if { [$class info instprocs build.$devname] != "" } {
876 if ![winfo exists $w] {
877 frame $w
878 #label $w.label -text "Grabber ($devname)"
879 #frame $w.frame -relief sunken -borderwidth 0
880 #$self build.$devname $w.frame
881 #pack $w.label $w.frame -side top -fill x -expand 1
882 $self build.$devname $w
883 pack $w -side top -fill x -expand 1
884 }
885 pack $w -before $path_.encoder -padx 6 -fill x
886 set grabber_panel_ $w
887 }
888 }
889
890 ControlMenu instproc get_default_video_format { } {
891 set fmt [$self get_option videoFormat]
892 if { $fmt == "h.261" } { return "h261" }
893 if { $fmt == "h.263+" } { return "h263+" }
894 if { $fmt == "h.263" } { return "h263" }
895 return $fmt
896 }
897
898 ControlMenu instproc set_default_formats { } {
899 $self instvar vpipe_ default_format_
900
901 set default_fmt [$self get_default_video_format]
902 foreach d [$vpipe_ input_devices] {
903 if { [$d nickname] == "still" && ![$self yesno stillGrabber] } {
904 set default_format_($d) $default_fmt
905 continue
906 }
907
908 set fmts [$vpipe_ available_formats $d]
909 if [inList $default_fmt $fmts] {
910 set default_format_($d) $default_fmt
911 } else {
912 set default_format_($d) [lindex $fmts 0]
913 }
914 }
915 }
916
917 #
918 # Called when user selects a particular device (like videopix or xil)
919 # (and at startup for default device)
920 #
921 ControlMenu instproc select_device device {
922 $self instvar vpipe_ last_device_ default_format_ default_port_ \
923 window_built_
924 $self tkvar device_ video_format_ input_port_ transmitButtonState_ \
925 deviceDialogsState_
926
927 #
928 # Remember settings of various controls for previous device
929 # and close down the device if it's already open
930 #
931 set wasTransmitting $transmitButtonState_
932 if [info exists last_device_] {
933 set default_format_($last_device_) $video_format_
934 set default_port_($last_device_) $input_port_
935 }
936
937 set last_device_ $device
938 $vpipe_ release_device
939 set video_format_ $default_format_($device)
940
941 set device_ $device
942 $self update_device
943
944 $vpipe_ set device_ $device
945 $vpipe_ set userDeviceDialogs_ $deviceDialogsState_
946
947 if $wasTransmitting {
948 $vpipe_ start
949 }
950 }
951
952 ControlMenu instproc update_device { } {
953 $self instvar window_built_ videoAgent_ transmitButton_
954 $self tkvar device_ video_format_
955
956 if { $window_built_ } {
957 if [$videoAgent_ have_network] {
958 $transmitButton_ configure -state normal
959 }
960
961 $self configure_formats $device_
962 $self configure_sizes $device_
963 $self configure_port $device_
964 $self configure_norm $device_
965
966 $self insert_grabber_panel [$device_ nickname]
967
968 $self select_format $video_format_
969 }
970 }
971
972 #
973 ControlMenu instproc configure_port { device } {
974 $self instvar portButton_
975
976 if [$device supports port *] {
977 $portButton_ configure -state normal
978 $self attach_ports $device
979 } else {
980 $portButton_ configure -state disabled
981 }
982 }
983
984 #
985 ControlMenu instproc configure_norm { device } {
986 $self instvar normButton_
987
988 if [$device supports norm *] {
989 $normButton_ configure -state normal
990 $self attach_norms $device
991 } else {
992 $normButton_ configure -state disabled
993 }
994 }
995
996 #
997 ControlMenu instproc configure_sizes { device } {
998 $self instvar sizeButtons_
999
1000 if [$device supports size small] {
1001 $sizeButtons_.b0 configure -state normal
1002 } else {
1003 $sizeButtons_.b0 configure -state disabled
1004 }
1005 if [$device supports size large] {
1006 $sizeButtons_.b2 configure -state normal
1007 } else {
1008 $sizeButtons_.b2 configure -state disabled
1009 }
1010 }
1011
1012 #
1013 ControlMenu instproc configure_formats { device } {
1014 $self instvar vpipe_ format_buttons_
1015 set fmtList [$vpipe_ available_formats $device]
1016 foreach b $format_buttons_ {
1017 set fmt [lindex [$b configure -value] 4]
1018 if { [inList $fmt $fmtList] } {
1019 $b configure -state normal
1020 } else {
1021 $b configure -state disabled
1022 }
1023 }
1024 }
1025
1026 #
1027 ControlMenu instproc build.device w {
1028 set f [$self get_option smallfont]
1029
1030 set m $w.menu
1031 menubutton $w -menu $m -text Device... \
1032 -relief raised -width 10 -font $f
1033 #
1034 # Disabled the device button if we have no devices or
1035 # if we don't have transmit persmission.
1036 #
1037 if ![$self have_transmit_permission] {
1038 $w configure -state disabled
1039 return
1040 }
1041 menu $m
1042 $self build.device_menu $m
1043 }
1044
1045 #
1046 ControlMenu instproc build.device_menu m {
1047 $self instvar vpipe_
1048 set f [$self get_option smallfont]
1049 foreach d [$vpipe_ input_devices] {
1050 # this is fragile
1051 $m add radiobutton -label [$d nickname] \
1052 -command "$self select_device $d" -font $f \
1053 -variable [$self tkvarname device_] -value $d
1054 if { "[$d attributes]" == "disabled" } {
1055 $m entryconfigure [$d nickname] -state disabled