bwidget-1.9.14/0000755000076500001440000000000013571542425012435 5ustar oehharusersbwidget-1.9.14/progressbar.tcl0000644000076500001440000001616013571542357015502 0ustar oehharusers# ---------------------------------------------------------------------------- # progressbar.tcl # This file is part of Unifix BWidget Toolkit # ---------------------------------------------------------------------------- # Index of commands: # - ProgressBar::create # - ProgressBar::configure # - ProgressBar::cget # - ProgressBar::_destroy # - ProgressBar::_modify # ---------------------------------------------------------------------------- namespace eval ProgressBar { Widget::define ProgressBar progressbar Widget::declare ProgressBar { {-type Enum normal 0 {normal incremental infinite nonincremental_infinite}} {-maximum Int 100 0 "%d > 0"} {-background TkResource "" 0 frame} {-foreground TkResource "blue" 0 label} {-borderwidth TkResource 2 0 frame} {-troughcolor TkResource "" 0 scrollbar} {-relief TkResource sunken 0 label} {-orient Enum horizontal 1 {horizontal vertical}} {-variable String "" 0} {-idle Boolean 0 0} {-width TkResource 100 0 frame} {-height TkResource 4m 0 frame} {-bg Synonym -background} {-fg Synonym -foreground} {-bd Synonym -borderwidth} } Widget::addmap ProgressBar "" :cmd {-background {} -width {} -height {}} Widget::addmap ProgressBar "" .bar { -troughcolor -background -borderwidth {} -relief {} } variable _widget } # ---------------------------------------------------------------------------- # Command ProgressBar::create # ---------------------------------------------------------------------------- proc ProgressBar::create { path args } { variable _widget array set maps [list ProgressBar {} :cmd {} .bar {}] array set maps [Widget::parseArgs ProgressBar $args] eval frame $path $maps(:cmd) -class ProgressBar -bd 0 \ -highlightthickness 0 -relief flat Widget::initFromODB ProgressBar $path $maps(ProgressBar) set c [eval [list canvas $path.bar] $maps(.bar) -highlightthickness 0] set fg [Widget::cget $path -foreground] if { [string equal [Widget::cget $path -orient] "horizontal"] } { $path.bar create rectangle -1 0 0 0 -fill $fg -outline $fg -tags rect } else { $path.bar create rectangle 0 1 0 0 -fill $fg -outline $fg -tags rect } set _widget($path,val) 0 set _widget($path,dir) 1 set _widget($path,var) [Widget::cget $path -variable] if {$_widget($path,var) != ""} { GlobalVar::tracevar variable $_widget($path,var) w \ [list ProgressBar::_modify $path] set _widget($path,afterid) \ [after idle [list ProgressBar::_modify $path]] } bind $path.bar [list ProgressBar::_destroy $path] bind $path.bar [list ProgressBar::_modify $path] return [Widget::create ProgressBar $path] } # ---------------------------------------------------------------------------- # Command ProgressBar::configure # ---------------------------------------------------------------------------- proc ProgressBar::configure { path args } { variable _widget set res [Widget::configure $path $args] if { [Widget::hasChangedX $path -variable] } { set newv [Widget::cget $path -variable] if { $_widget($path,var) != "" } { GlobalVar::tracevar vdelete $_widget($path,var) w \ [list ProgressBar::_modify $path] } if { $newv != "" } { set _widget($path,var) $newv GlobalVar::tracevar variable $newv w \ [list ProgressBar::_modify $path] if {![info exists _widget($path,afterid)]} { set _widget($path,afterid) \ [after idle [list ProgressBar::_modify $path]] } } else { set _widget($path,var) "" } } foreach {cbd cor cma} [Widget::hasChangedX $path -borderwidth \ -orient -maximum] break if { $cbd || $cor || $cma } { if {![info exists _widget($path,afterid)]} { set _widget($path,afterid) \ [after idle [list ProgressBar::_modify $path]] } } if { [Widget::hasChangedX $path -foreground] } { set fg [Widget::cget $path -foreground] $path.bar itemconfigure rect -fill $fg -outline $fg } return $res } # ---------------------------------------------------------------------------- # Command ProgressBar::cget # ---------------------------------------------------------------------------- proc ProgressBar::cget { path option } { return [Widget::cget $path $option] } # ---------------------------------------------------------------------------- # Command ProgressBar::_modify # ---------------------------------------------------------------------------- proc ProgressBar::_modify { path args } { variable _widget catch {unset _widget($path,afterid)} if { ![GlobalVar::exists $_widget($path,var)] || [set val [GlobalVar::getvar $_widget($path,var)]] < 0 } { catch {place forget $path.bar} } else { place $path.bar -relx 0 -rely 0 -relwidth 1 -relheight 1 set type [Widget::getoption $path -type] if { $val != 0 && $type != "normal" && \ $type != "nonincremental_infinite"} { set val [expr {$val+$_widget($path,val)}] } set _widget($path,val) $val set max [Widget::getoption $path -maximum] set bd [expr {2*[$path.bar cget -bd]}] set w [winfo width $path.bar] set h [winfo height $path.bar] if {$type == "infinite" || $type == "nonincremental_infinite"} { # JDC: New infinite behaviour set tval [expr {$val % $max}] if { $tval < ($max / 2.0) } { set x0 [expr {double($tval) / double($max) * 1.5}] } else { set x0 [expr {(1.0-(double($tval) / double($max))) * 1.5}] } set x1 [expr {$x0 + 0.25}] # convert coords to ints to prevent triggering canvas refresh # bug related to fractional coords if {[Widget::getoption $path -orient] == "horizontal"} { $path.bar coords rect [expr {int($x0*$w)}] 0 \ [expr {int($x1*$w)}] $h } else { $path.bar coords rect 0 [expr {int($h-$x0*$h)}] $w \ [expr {int($x1*$h)}] } } else { if { $val > $max } {set val $max} if {[Widget::getoption $path -orient] == "horizontal"} { $path.bar coords rect -1 0 [expr {int(double($val)*$w/$max)}] $h } else { $path.bar coords rect 0 [expr {$h+1}] $w \ [expr {int($h*(1.0 - double($val)/$max))}] } } } if {![Widget::cget $path -idle]} { update idletasks } } # ---------------------------------------------------------------------------- # Command ProgressBar::_destroy # ---------------------------------------------------------------------------- proc ProgressBar::_destroy { path } { variable _widget if {[info exists _widget($path,afterid)]} { after cancel $_widget($path,afterid) unset _widget($path,afterid) } if {[info exists _widget($path,var)]} { if {$_widget($path,var) != ""} { GlobalVar::tracevar vdelete $_widget($path,var) w \ [list ProgressBar::_modify $path] } unset _widget($path,var) } unset _widget($path,dir) Widget::destroy $path } bwidget-1.9.14/color.tcl0000644000076500001440000007406413571542357014276 0ustar oehharusersnamespace eval SelectColor { Widget::define SelectColor color Dialog Widget::declare SelectColor { {-title String "Select a color" 0} {-parent String "" 0} {-command String "" 0} {-help Boolean 0 1} {-color TkResource "" 0 {label -background}} {-type Enum "dialog" 1 {dialog popup}} {-placement String "center" 1} {-background TkResource "" 0 {label -background}} } variable _baseColors { \#0000ff \#00ff00 \#00ffff \#ff0000 \#ff00ff \#ffff00 \#000099 \#009900 \#009999 \#990000 \#990099 \#999900 \#000000 \#333333 \#666666 \#999999 \#cccccc \#ffffff } variable _userColors { \#ffffff \#ffffff \#ffffff \#ffffff \#ffffff \#ffffff \#ffffff \#ffffff \#ffffff \#ffffff \#ffffff } if {[string equal $::tcl_platform(platform) "unix"]} { set useTkDialogue 0 } else { set useTkDialogue 1 } variable _selectype variable _selection variable _wcolor variable _image variable _hsv variable _command variable _unsavedSelection variable _oldColor variable _entryColor variable _bgColor variable _fgColor variable _rounds } proc SelectColor::create { path args } { Widget::init SelectColor $path $args set type [Widget::cget $path -type] switch -- [Widget::cget $path -type] { "dialog" { return [eval [list SelectColor::dialog $path] $args] } "popup" { set list [list at center left right above below] set placement [Widget::cget $path -placement] set where [lindex $placement 0] if {[lsearch $list $where] < 0} { return -code error \ [BWidget::badOptionString placement $placement $list] } ## If they specified a parent and didn't pass a second argument ## in the placement, set the placement relative to the parent. set parent [Widget::cget $path -parent] if {[string length $parent]} { if {[llength $placement] == 1} { lappend placement $parent } } return [eval [list SelectColor::menu $path $placement] $args] } } } proc SelectColor::menu {path placement args} { variable _baseColors variable _userColors variable _wcolor variable _selectype variable _selection variable _command variable _bgColor variable _rounds Widget::init SelectColor $path $args set top [toplevel $path] set parent [winfo toplevel [winfo parent $top]] wm withdraw $top wm transient $top $parent wm overrideredirect $top 1 catch { wm attributes $top -topmost 1 } set _command [Widget::cget $path -command] set _bgColor [Widget::cget $path -background] set _rounds {} set frame [frame $top.frame \ -highlightthickness 0 \ -relief raised -borderwidth 2] set col 0 set row 0 set count 0 set colors [concat $_baseColors $_userColors] foreach color $colors { set f [frame $frame.c$count \ -highlightthickness 2 \ -highlightcolor white \ -relief solid -borderwidth 1 \ -width 16 -height 16 -background $color] bind $f <1> "set SelectColor::_selection $count; break" bind $f {focus %W} grid $f -column $col -row $row incr count if {[incr col] == 6 } { set col 0 incr row } } set f [label $frame.c$count \ -highlightthickness 2 \ -highlightcolor white \ -relief flat -borderwidth 0 \ -width 16 -height 16 -image [Bitmap::get palette]] grid $f -column $col -row $row bind $f <1> "set SelectColor::_selection $count; break" bind $f {focus %W} pack $frame bind $top <1> {set SelectColor::_selection -1} bind $top {set SelectColor::_selection -2} bind $top [subst {if {"%W" == "$top"} \ {set SelectColor::_selection -2}}] # set background color for menu $f configure -bg $_bgColor $frame configure -bg $_bgColor foreach w [winfo children $frame] { $w configure -highlightcolor $_bgColor -highlightbackground $_bgColor } eval [list BWidget::place $top 0 0] $placement wm deiconify $top raise $top if {$::tcl_platform(platform) == "unix"} { tkwait visibility $top update } BWidget::SetFocusGrab $top $frame.c0 vwait SelectColor::_selection BWidget::RestoreFocusGrab $top $frame.c0 destroy Widget::destroy $top if {$_selection == $count} { array set opts { -parent -parent -title -title -color -initialcolor } if {[Widget::theme]} { set native 1 set nativecmd [list tk_chooseColor -parent $parent] foreach {key val} $args { if {![info exists opts($key)]} { set native 0 break } lappend nativecmd $opts($key) $val } if {$native} { # Call native dialog return [eval $nativecmd] } } # Call BWidget dialog return [eval [list dialog $path] $args] } else { # The user has either selected one of the palette colors, or has # cancelled. The full BWidget/native dialog was not called. # Unless the user has cancelled, pass the selected # color to _userCommand. set tmpCol [lindex $colors $_selection] if {[string equal $tmpCol ""]} { # User has cancelled - no need to call _userCommand. } else { _userCommand $tmpCol } return $tmpCol } } proc SelectColor::_userCommand {color} { variable _command if {[string equal $_command {}]} { return } uplevel #0 $_command [list $color] return } proc SelectColor::dialog {path args} { variable _baseColors variable _userColors variable _widget variable _selection variable _image variable _hsv variable _command variable _unsavedSelection variable _oldColor variable _entryColor variable _bgColor variable _fgColor variable _rounds Widget::init SelectColor $path:SelectColor $args set top [Dialog::create $path \ -title [Widget::cget $path:SelectColor -title] \ -parent [Widget::cget $path:SelectColor -parent] \ -separator 0 -default 0 -cancel 1 -anchor e] wm resizable $top 0 0 set dlgf [$top getframe] set fg [frame $dlgf.fg] set desc [list \ base _baseColors "Base colors" \ user _userColors "User colors"] set help [Widget::cget $path:SelectColor -help] set _command [Widget::cget $path:SelectColor -command] set _bgColor [Widget::cget $path:SelectColor -background] set _rounds {} set mouseHelpText "" if {$help} { append mouseHelpText [subst -nocommands -novariables\ [lindex [BWidget::getname mouseHelpText] 0]] } set count 0 foreach {type varcol defTitle} $desc { set col 0 set lin 0 set title [lindex [BWidget::getname "${type}Colors"] 0] if {![string length $title]} { set title $defTitle } set titf [TitleFrame $fg.$type -text $title] set subf [$titf getframe] foreach color [set $varcol] { set fround [frame $fg.round$count \ -highlightthickness 1 \ -relief sunken -borderwidth 2] set fcolor [frame $fg.color$count -width 16 -height 12 \ -highlightthickness 0 \ -relief flat -borderwidth 0 \ -background $color] pack $fcolor -in $fround grid $fround -in $subf -row $lin -column $col -padx 1 -pady 1 bind $fround [list SelectColor::_select_rgb $count] bind $fcolor [list SelectColor::_select_rgb $count] DynamicHelp::add $fround -text $mouseHelpText DynamicHelp::add $fcolor -text $mouseHelpText bind $fround \ "SelectColor::_select_rgb [list $count]; [list $top] invoke 0" bind $fcolor \ "SelectColor::_select_rgb [list $count]; [list $top] invoke 0" # Record list of $fround values in _rounds lappend _rounds $fround incr count if {[incr col] == 6} { incr lin set col 0 } } pack $titf -anchor w -pady 2 } # Record these colors for later use set _fgColor [$fg.round0 cget -highlightcolor] # Add a TitleFrame $titf to wrap $fg.round and $fg.value set name [lindex [BWidget::getname yourSelection] 0] set titf [TitleFrame $fg.choice -text $name] set subf [$titf getframe] pack $titf -anchor w -pady 2 -expand yes -fill both # Add an entry widget $fg.value for the #RRGGBB value if {$::tk_version > 8.4} { set fixedFont TkFixedFont } else { set fixedFont Courier } set subf2 $fg.vround frame $subf2 -highlightthickness 0 -relief sunken -borderwidth 2 entry $fg.value -width 8 -relief sunken -bd 0 -highlightthickness 0 \ -bg white -textvariable ::SelectColor::_entryColor -font $fixedFont pack $subf2 -in $subf -anchor w -side left pack $fg.value -in $subf2 -anchor w -side left if {$help} { DynamicHelp::add $fg.value -text [subst -nocommands -novariables\ [lindex [BWidget::getname keyboardHelpText] 0]] } # Remove focus from the entry widget by clicking anywhere... bind $top <1> [list ::SelectColor::_CheckFocus %W] # ... or by pressing Return/Escape. bind $fg.value [list ::SelectColor::_CheckFocus .] bind $fg.value [list ::SelectColor::_CheckFocus .] bind $fg.value {+break} bind $fg.value {+break} # Break so that the bindings to these events on the toplevel are not # executed. # MODS - record the Tk window path for the entry widget. set _widget(en) $fg.value set fround [frame $fg.round \ -highlightthickness 0 \ -relief sunken -borderwidth 2] set fcolor [frame $fg.color \ -width 50 \ -highlightthickness 0 \ -relief flat -borderwidth 0] pack $fcolor -in $fround -fill y -expand yes pack $fround -in $subf -side right -anchor e -pady 2 -fill y -expand yes # Add a TitleFrame $dlgf.fd to wrap the canvas selectors. The # labels are referenced by the DynamicHelp tooltip. set name [lindex [BWidget::getname colorSelectors] 0] set fd0 [TitleFrame $dlgf.fd -text $name] set fd [$fd0 getframe] set f1 [frame $fd.f1 -relief sunken -borderwidth 2] set f2 [frame $fd.f2 -relief sunken -borderwidth 2] set c1 [canvas $f1.c -width 200 -height 200 -bd 0 -highlightthickness 0] set c2 [canvas $f2.c -width 15 -height 200 -bd 0 -highlightthickness 0] for {set val 0} {$val < 40} {incr val} { $c2 create rectangle 0 [expr {5*$val}] 15 [expr {5*$val+5}] -tags val[expr {39-$val}] } $c2 create polygon 0 0 10 5 0 10 -fill black -outline white -tags target pack $c1 $c2 pack $f1 $f2 -side left -padx 10 -anchor n pack $fg $fd0 -side left -anchor n -fill y pack configure $fd0 -pady 2 -padx {4 0} bind $c1 [list SelectColor::_select_hue_sat %x %y] bind $c1 [list SelectColor::_select_hue_sat %x %y] bind $c2 [list SelectColor::_select_value %x %y] bind $c2 [list SelectColor::_select_value %x %y] if {![info exists _image] || [catch {image type $_image}]} { set _image [image create photo -width 200 -height 200] for {set x 0} {$x < 200} {incr x 4} { for {set y 0} {$y < 200} {incr y 4} { $_image put \ [eval [list format "\#%04x%04x%04x"] \ [hsvToRgb [expr {$x/196.0}] [expr {(196-$y)/196.0}] 0.85]] \ -to $x $y [expr {$x+4}] [expr {$y+4}] } } } $c1 create image 0 0 -anchor nw -image $_image $c1 create bitmap 0 0 \ -bitmap @[file join $::BWIDGET::LIBRARY "images" "target.xbm"] \ -anchor nw -tags target set _selection -1 set _widget(fcolor) $fg set _widget(chs) $c1 set _widget(cv) $c2 set rgb [winfo rgb $path [Widget::cget $path:SelectColor -color]] set _hsv [eval rgbToHsv $rgb] _set_rgb [eval [list format "\#%04x%04x%04x"] $rgb] _set_hue_sat [lindex $_hsv 0] [lindex $_hsv 1] _set_value [lindex $_hsv 2] # Initialize _oldColor which is used to reset the color supplied to # _userCommand if the user cancels. set _oldColor [set _unsavedSelection] set tmp24 [::SelectColor::_24BitRgb $_oldColor] if {[_ValidateColorEntry forced $tmp24]} { set ::SelectColor::_entryColor $tmp24 } else { # Value $tmp24 does not pass entry widget validation and if used # would disable validation. Use this default instead. set _entryColor # } # Validate input to the entry field. # To avoid conflict with the entry -variable (_entryColor), do not set the # latter directly (because a failed validation will switch off subsequent # validations). Either call _SetEntryValue, or set _unsavedSelection which # triggers the trace. $fg.value configure -validate all -validatecommand \ [list SelectColor::_ValidateColorEntry %V %P] # Trace _unsavedSelection # Subsequent modifications to _unsavedSelection will update the entry # widget, if the value is valid. # From now on, this is the only way that: # (1) ::SelectColor::_SetEntryValue is called # (2) ::SelectColor::_entryColor is modified (except by the user typing in # the entry widget) trace add variable ::SelectColor::_unsavedSelection write ::SelectColor::_SetEntryValue $top add -text [lindex [BWidget::getname ok] 0] $top add -text [lindex [BWidget::getname cancel] 0] # Override background color ReColor $path $_bgColor set res [$top draw] if {$res == 0} { set color [$fg.color cget -background] } else { # User has cancelled - call _userCommand to undo any changes made # in the caller. _userCommand $_oldColor set color "" } trace remove variable ::SelectColor::_unsavedSelection write ::SelectColor::_SetEntryValue destroy $top return $color } # ---------------------------------------------------------------------------- # Command SelectColor::setbasecolor # ---------------------------------------------------------------------------- # Exported command, to allow the caller to set the base colors of the palette. proc SelectColor::setbasecolor { idx color } { variable _baseColors set _baseColors [lreplace $_baseColors $idx $idx $color] } # ---------------------------------------------------------------------------- # Command SelectColor::setcolor # ---------------------------------------------------------------------------- proc SelectColor::setcolor { idx color } { variable _userColors set _userColors [lreplace $_userColors $idx $idx $color] } proc SelectColor::_select_rgb {count} { variable _baseColors variable _userColors variable _selection variable _widget variable _hsv variable _unsavedSelection variable _bgColor variable _fgColor set frame $_widget(fcolor) # Use highlight color instead of focus to identify the selected # palette color. Tab traversal of focus now works correctly. if {$_selection >= 0} { $frame.round$_selection configure \ -relief sunken -highlightthickness 1 -borderwidth 2 \ -highlightbackground $_bgColor } $frame.round$count configure \ -relief flat -highlightthickness 2 -borderwidth 1 \ -highlightbackground $_fgColor set _selection $count set bg [$frame.color$count cget -background] set user [expr {$_selection-[llength $_baseColors]}] if {$user >= 0 && [string equal \ [winfo rgb $frame.color$_selection $bg] \ [winfo rgb $frame.color$_selection white]]} { set bg [$frame.color cget -bg] $frame.color$_selection configure -background $bg set _userColors [lreplace $_userColors $user $user $bg] } else { set _hsv [eval rgbToHsv [winfo rgb $frame.color$count $bg]] _set_hue_sat [lindex $_hsv 0] [lindex $_hsv 1] _set_value [lindex $_hsv 2] $frame.color configure -background $bg # Display selected color in entry widget (via trace on # ::SelectColor::_unsavedSelection), and notify caller. set ::SelectColor::_unsavedSelection $bg _userCommand $bg } } proc SelectColor::_set_rgb {rgb} { variable _selection variable _baseColors variable _userColors variable _widget variable _unsavedSelection set frame $_widget(fcolor) $frame.color configure -background $rgb # Display selected color in entry widget (via trace on # ::SelectColor::_unsavedSelection), and notify caller. set ::SelectColor::_unsavedSelection $rgb _userCommand $rgb set user [expr {$_selection-[llength $_baseColors]}] if {$user >= 0} { $frame.color$_selection configure -background $rgb set _userColors [lreplace $_userColors $user $user $rgb] } } proc SelectColor::_select_hue_sat {x y} { variable _widget variable _hsv if {$x < 0} { set x 0 } elseif {$x > 200} { set x 200 } if {$y < 0 } { set y 0 } elseif {$y > 200} { set y 200 } set hue [expr {$x/200.0}] set sat [expr {(200-$y)/200.0}] set _hsv [lreplace $_hsv 0 1 $hue $sat] $_widget(chs) coords target [expr {$x-9}] [expr {$y-9}] _draw_values $hue $sat _set_rgb [eval [list format "\#%04x%04x%04x"] [eval [list hsvToRgb] $_hsv]] } proc SelectColor::_set_hue_sat {hue sat} { variable _widget set x [expr {$hue*200-9}] set y [expr {(1-$sat)*200-9}] $_widget(chs) coords target $x $y _draw_values $hue $sat } proc SelectColor::_select_value {x y} { variable _widget variable _hsv if {$y < 0} { set y 0 } elseif {$y > 200} { set y 200 } $_widget(cv) coords target 0 [expr {$y-5}] 10 $y 0 [expr {$y+5}] set _hsv [lreplace $_hsv 2 2 [expr {(200-$y)/200.0}]] _set_rgb [eval [list format "\#%04x%04x%04x"] [eval [list hsvToRgb] $_hsv]] } proc SelectColor::_draw_values {hue sat} { variable _widget for {set val 0} {$val < 40} {incr val} { set l [hsvToRgb $hue $sat [expr {$val/39.0}]] set col [eval [list format "\#%04x%04x%04x"] $l] $_widget(cv) itemconfigure val$val -fill $col -outline $col } } proc SelectColor::_set_value {value} { variable _widget set y [expr {int((1-$value)*200)}] $_widget(cv) coords target 0 [expr {$y-5}] 10 $y 0 [expr {$y+5}] } # -- # Taken from tk8.0/demos/tcolor.tcl # -- # The procedure below converts an HSB value to RGB. It takes hue, saturation, # and value components (floating-point, 0-1.0) as arguments, and returns a # list containing RGB components (integers, 0-65535) as result. The code # here is a copy of the code on page 616 of "Fundamentals of Interactive # Computer Graphics" by Foley and Van Dam. proc SelectColor::hsvToRgb {hue sat val} { set v [expr {round(65535.0*$val)}] if {$sat == 0} { return [list $v $v $v] } else { set hue [expr {$hue*6.0}] if {$hue >= 6.0} { set hue 0.0 } set i [expr {int($hue)}] set f [expr {$hue-$i}] set p [expr {round(65535.0*$val*(1 - $sat))}] set q [expr {round(65535.0*$val*(1 - ($sat*$f)))}] set t [expr {round(65535.0*$val*(1 - ($sat*(1 - $f))))}] switch $i { 0 {return [list $v $t $p]} 1 {return [list $q $v $p]} 2 {return [list $p $v $t]} 3 {return [list $p $q $v]} 4 {return [list $t $p $v]} 5 {return [list $v $p $q]} } } } # -- # Taken from tk8.0/demos/tcolor.tcl # -- # The procedure below converts an RGB value to HSB. It takes red, green, # and blue components (0-65535) as arguments, and returns a list containing # HSB components (floating-point, 0-1) as result. The code here is a copy # of the code on page 615 of "Fundamentals of Interactive Computer Graphics" # by Foley and Van Dam. proc SelectColor::rgbToHsv {red green blue} { if {$red > $green} { set max $red.0 set min $green.0 } else { set max $green.0 set min $red.0 } if {$blue > $max} { set max $blue.0 } else { if {$blue < $min} { set min $blue.0 } } set range [expr {$max-$min}] if {$max == 0} { set sat 0 } else { set sat [expr {($max-$min)/$max}] } if {$sat == 0} { set hue 0 } else { set rc [expr {($max - $red)/$range}] set gc [expr {($max - $green)/$range}] set bc [expr {($max - $blue)/$range}] if {$red == $max} { set hue [expr {.166667*($bc - $gc)}] } else { if {$green == $max} { set hue [expr {.166667*(2 + $rc - $bc)}] } else { set hue [expr {.166667*(4 + $gc - $rc)}] } } if {$hue < 0.0} { set hue [expr {$hue + 1.0}] } } return [list $hue $sat [expr {$max/65535}]] } # ------------------------------------------------------------------------------ # Command SelectColor::ReColor # ------------------------------------------------------------------------------ # Command to change the background color for the dialog. # # FIXME Ideally this would be called by "$w configure -background $value". # Currently a "configure -background" command is passed to Dialog and Widget # but does not change SelectColor. # HaO: it might also be possible that this is controled by the option data base. # ------------------------------------------------------------------------------ proc SelectColor::ReColor {path newColor} { variable _bgColor variable _rounds set _bgColor $newColor $path configure -bg $_bgColor # Use the internal names of the dialog widget - it would be nicer to # use a colored dialog widget. foreach child { fd fd.f.f1 fd.f.f2 fg fg.base fg.choice fg.user fg.round fg.vround } { $path.frame.$child configure -background $_bgColor } # Special treatment for Aqua native buttons. # FIXME implement a general fix for BWidget Button/ButtonBox/Dialog if {[string equal [tk windowingsystem] "aqua"]} { $path.bbox.b0 configure -highlightbackground $_bgColor \ -highlightthickness 0 $path.bbox.b1 configure -highlightbackground $_bgColor \ -highlightthickness 0 } else { $path.bbox.b0 configure -bg $_bgColor -activebackground $_bgColor \ -highlightbackground $_bgColor $path.bbox.b1 configure -bg $_bgColor -activebackground $_bgColor \ -highlightbackground $_bgColor } foreach fround $_rounds { $fround configure -highlightbackground $_bgColor -bg $_bgColor } return } # ------------------------------------------------------------------------------ # Command SelectColor::_24BitRgb # ------------------------------------------------------------------------------ # Command to convert a hex 12n-bit RGB color to 24-bit, n > 0. # Convert anything else to {}. # Used to process the display in the entry widget. # ------------------------------------------------------------------------------ proc SelectColor::_24BitRgb {col} { set lenny [string length $col] incr lenny -1 if { ($lenny % 3) || ($lenny == 0) || (![regexp {^#[a-fA-F0-9]*$} $col]) } { # Not a multiple of 3, or not leading #, or nothing after #, # or non-HEX digits. return {} } elseif {$lenny == 3} { # 12-bit, pad to 24-bit set val $col set val [string replace $val 3 3 "[string index $val 3]0"] set val [string replace $val 2 2 "[string index $val 2]0"] set val [string replace $val 1 1 "[string index $val 1]0"] return $val } elseif {$lenny == 6} { # 24-bit, return unchanged return $col } else { # Truncate to 24-bit set delta [expr {$lenny / 3}] set delta2 [expr {$delta * 2}] set deltaP1 [incr delta] set deltaP2 [incr delta] set delta2P1 [incr delta2] set delta2P2 [incr delta2] set result # append result [string range $col 1 2] append result [string range $col $deltaP1 $deltaP2] append result [string range $col $delta2P1 $delta2P2] return $result } } # ------------------------------------------------------------------------------ # Command SelectColor::_SetEntryValue # ------------------------------------------------------------------------------ # Command to update the (hexadecimal color displayed in the) entry widget # when there is a change in the color currently selected in the GUI, which is # stored in _unsavedSelection. # # This command is called by a write trace on _unsavedSelection; if the # value of this variable is a valid color (i.e. "#" followed by 3N hex digits), # this command converts the value to 24 bits and sets ::SelectColor::_entryColor # to the result, thereby displaying it in the entry widget. Therefore, # when the user chooses a color by means other than the entry widget, this # command updates the entry widget. # # This command does not update the GUI when the user changes the value in the # entry widget: that is done instead by the -vcmd of the entry widget, which # is SelectColor::_ValidateColorEntry. When the user chooses a color by typing # in the entry widget, the command _ValidateColorEntry copies the value to # _unsavedSelection if a keystroke in the widget makes its contents 3N hex # digits long. # ------------------------------------------------------------------------------ proc SelectColor::_SetEntryValue {argVarName var2 op} { variable _entryColor variable _unsavedSelection if {[string equal $argVarName ::SelectColor::_unsavedSelection] && [string equal $var2 {}] && [string equal $op "write"]} { # OK } else { # Unexpected call return -code error "Unexpected trace of variable\ \"$argVarName\", \"$var2\", \"$op\"" } set col24bit [::SelectColor::_24BitRgb [set $argVarName]] if {[_ValidateColorEntry forced $col24bit]} { set ::SelectColor::_entryColor $col24bit } else { # Value is invalid, and if written to _entryColor this would disable # validation. } return } # ------------------------------------------------------------------------------ # Command SelectColor::_CheckFocus # ------------------------------------------------------------------------------ # This command is called with argument %W as a binding to <1> on the toplevel. # It is also called with argument {.}, by bindings on the entry widget to # , . # # The command does something only if the entry widget has focus, and the # argument (the clicked window) is the Tk window path of somewhere else. Then, # the command removes focus from the entry widget to the default button. # ------------------------------------------------------------------------------ proc SelectColor::_CheckFocus {w} { variable _widget if { (! [string equal $w $_widget(en)]) && ([string equal [focus] $_widget(en)])} { set top [winfo toplevel $_widget(en)] $top setfocus default } return } # ------------------------------------------------------------------------------ # Command SelectColor::_ValidateColorEntry # ------------------------------------------------------------------------------ # This command is the "-validate all -vcmd" of the entry widget. # It is also called by SelectColor::dialog and SelectColor::_SetEntryValue to # check values assigned to _entryColor. # # When the user chooses a color by typing in the entry widget, this command # copies the value to _unsavedSelection if a keystroke in the widget makes its # contents 3N hex digits long. # ------------------------------------------------------------------------------ proc SelectColor::_ValidateColorEntry {percentV percentP} { variable _unsavedSelection set result [regexp -- {^#[0-9a-fA-F]*$} $percentP] set lenny [string length $percentP] if {$result} { if {[string equal $percentV "forced"]} { # Validation only. Don't want a loop. } elseif {[string equal $percentV "key"]} { # Copy to GUI if a valid color. if {($lenny - 1) % 3 || $lenny == 1} { # Not a valid color, which needs 3n+1 characters, n > 0 } else { after idle [list SelectColor::_SetWithoutTrace $percentP] } } elseif {[string equal $percentV "focusout"]} { # If the color is valid it will already have been copied to the GUI # and to _userCommand by the "key" validation above. # # The code below only needs to reset the value in the entry widget. # Remove an invalid value, convert a valid one to 24-bit. # Ignore $percentP, just fire the trace on _unsavedSelection. set color $_unsavedSelection after idle [list set ::SelectColor::_unsavedSelection $color] } } return $result } # ------------------------------------------------------------------------------ # Command SelectColor::_SetWithoutTrace # ------------------------------------------------------------------------------ # This command sets _unsavedSelection (using _set_rgb) without firing the trace # that copies the value to _entryColor. # The command is called by SelectColor::_ValidateColorEntry to avoid a loop. # ------------------------------------------------------------------------------ proc SelectColor::_SetWithoutTrace {value} { trace remove variable ::SelectColor::_unsavedSelection write ::SelectColor::_SetEntryValue _set_rgb $value set _hsv [eval rgbToHsv [winfo rgb . $value]] _set_hue_sat [lindex $_hsv 0] [lindex $_hsv 1] _set_value [lindex $_hsv 2] trace add variable ::SelectColor::_unsavedSelection write ::SelectColor::_SetEntryValue return } bwidget-1.9.14/mainframe.tcl0000740000076500001440000006605413571542357015114 0ustar oehharusers# ---------------------------------------------------------------------------- # mainframe.tcl # This file is part of Unifix BWidget Toolkit # $Id: mainframe.tcl,v 1.24.2.3 2011/05/25 15:10:07 oehhar Exp $ # ------------------------------------------------------------------------------ # Index of commands: # - MainFrame::create # - MainFrame::configure # - MainFrame::cget # - MainFrame::getframe # - MainFrame::addtoolbar # - MainFrame::gettoolbar # - MainFrame::addindicator # - MainFrame::getindicator # - MainFrame::getmenu # - MainFrame::menuonly # - MainFrame::showtoolbar # - MainFrame::showstatusbar # - MainFrame::_create_menubar # - MainFrame::_create_entries # - MainFrame::_parse_name # - MainFrame::_parse_accelerator # ---------------------------------------------------------------------------- namespace eval MainFrame { Widget::define MainFrame mainframe ProgressBar Widget::bwinclude MainFrame ProgressBar .status.prg \ remove { -fg -bg -bd -troughcolor -background -borderwidth -relief -orient -width -height } \ rename { -maximum -progressmax -variable -progressvar -type -progresstype -foreground -progressfg } if {[Widget::theme]} { # No option -background for themed MainFrame Widget::declare MainFrame { {-width TkResource 0 0 frame} {-height TkResource 0 0 frame} {-textvariable String "" 0} {-menu String {} 1} {-separator Enum both 1 {none top bottom both}} {-menubarfont String "" 0} {-menuentryfont String "" 0} {-statusbarfont String "" 0} {-sizegrip Boolean 0 1} } Widget::addmap MainFrame "" .frame {-width {} -height {}} } else { Widget::declare MainFrame { {-width TkResource 0 0 frame} {-height TkResource 0 0 frame} {-background TkResource "" 0 frame} {-textvariable String "" 0} {-menu String {} 1} {-separator Enum both 1 {none top bottom both}} {-bg Synonym -background} {-menubarfont String "" 0} {-menuentryfont String "" 0} {-statusbarfont String "" 0} {-sizegrip Boolean 0 1} } Widget::addmap MainFrame "" .frame {-width {} -height {} -background {}} Widget::addmap MainFrame "" .topf {-background {}} Widget::addmap MainFrame "" .botf {-background {}} Widget::addmap MainFrame "" .status {-background {}} Widget::addmap MainFrame "" .status.label {-background {}} Widget::addmap MainFrame "" .status.indf {-background {}} Widget::addmap MainFrame "" .status.prgf {-background {}} Widget::addmap MainFrame ProgressBar .status.prg {-background {} -background -troughcolor} } variable _widget } # ---------------------------------------------------------------------------- # Command MainFrame::create # ---------------------------------------------------------------------------- proc MainFrame::create { path args } { global tcl_platform variable _widget if {[Widget::theme]} { set path [ttk::frame $path] } else { set path [frame $path -takefocus 0 -highlightthickness 0] } set top [winfo parent $path] if { ![string equal [winfo toplevel $path] $top] } { destroy $path return -code error "parent must be a toplevel" } Widget::init MainFrame $path $args if { $tcl_platform(platform) == "unix" } { set relief raised set bd 1 } else { set relief flat set bd 0 } if {[Widget::theme]} { set userframe [eval [list ttk::frame $path.frame] \ [Widget::subcget $path .frame]] set topframe [ttk::frame $path.topf] set botframe [ttk::frame $path.botf] } else { set userframe [eval [list frame $path.frame] \ [Widget::subcget $path .frame] \ -relief $relief -borderwidth $bd] set topframe [eval [list frame $path.topf] \ [Widget::subcget $path .topf]] set botframe [eval [list frame $path.botf] \ -relief $relief -borderwidth $bd \ [Widget::subcget $path .botf]] } pack $topframe -fill x grid columnconfigure $topframe 0 -weight 1 if {![Widget::theme]} { set bg [Widget::cget $path -background] $path configure -background $bg } if { $tcl_platform(platform) != "unix" } { set sepopt [Widget::getoption $path -separator] if { $sepopt == "both" || $sepopt == "top" } { if {[Widget::theme]} { set sep [ttk::separator $path.sep -orient horizontal] } else { set sep [Separator::create $path.sep -orient horizontal -background $bg] } pack $sep -fill x } if { $sepopt == "both" || $sepopt == "bottom" } { if {[Widget::theme]} { set sep [ttk::separator $botframe.sep -orient horizontal] } else { set sep [Separator::create $botframe.sep -orient horizontal -background $bg] } pack $sep -fill x } } # --- status bar --------------------------------------------------------- if {[string length [Widget::getoption $path -statusbarfont]]} { set sbfnt [list -font [Widget::getoption $path -statusbarfont]] } else { set sbfnt "" } if {[Widget::theme]} { set status [ttk::frame $path.status] set label [eval [list ttk::label $status.label \ -textvariable [Widget::getoption $path -textvariable]] $sbfnt] set indframe [ttk::frame $status.indf] set prgframe [ttk::frame $status.prgf] } else { set status [frame $path.status -background $bg] set label [eval [list label $status.label \ -textvariable [Widget::getoption $path -textvariable] \ -background $bg] $sbfnt] set indframe [frame $status.indf -background $bg] set prgframe [frame $status.prgf -background $bg] } place $label -anchor w -x 0 -rely 0.5 place $indframe -anchor ne -relx 1 -y 0 -relheight 1 pack $prgframe -in $indframe -side left -padx 2 $status configure -height [winfo reqheight $label] set progress [eval [list ProgressBar::create $status.prg] \ [Widget::subcget $path .status.prg] \ -width 50 \ -height [expr {[winfo reqheight $label]-2}] \ -borderwidth 1 \ -relief sunken] if {[Widget::theme] && [Widget::getoption $path -sizegrip]} { pack [ttk::sizegrip $botframe.sg] -side right -anchor se } pack $status -in $botframe -fill x -pady 2 pack $botframe -side bottom -fill x pack $userframe -fill both -expand yes set _widget($path,top) $top set _widget($path,ntoolbar) 0 set _widget($path,nindic) 0 set menu [Widget::getoption $path -menu] if { [llength $menu] } { _create_menubar $path $menu } bind $path [list MainFrame::_destroy %W] return [Widget::create MainFrame $path] } # ---------------------------------------------------------------------------- # Command MainFrame::configure # ---------------------------------------------------------------------------- proc MainFrame::configure { path args } { variable _widget set res [Widget::configure $path $args] if { [Widget::hasChanged $path -textvariable newv] } { uplevel \#0 $path.status.label configure -textvariable [list $newv] } # The ttk frame has no -background if {![Widget::theme] && [Widget::hasChanged $path -background bg] } { if {($::tcl_platform(platform) == "unix") && (0 != [string compare [tk windowingsystem] "aqua"])} { set listmenu [$_widget($path,top) cget -menu] while { [llength $listmenu] } { set newlist {} foreach menu $listmenu { $menu configure -background $bg set newlist [concat $newlist [winfo children $menu]] } set listmenu $newlist } } foreach sep {.sep .botf.sep} { if {[winfo exists $path.$sep]} { Separator::configure $path.$sep -background $bg } } foreach w [winfo children $path.topf] { $w configure -background $bg } } if { [Widget::hasChanged $path -menubarfont newmbfnt] } { if {[string length $newmbfnt]} { set mbfnt [list -font $newmbfnt] } else { set mbfnt "" } set top $_widget($path,top) if {[string equal $top .]} { eval [list .menubar configure] $mbfnt } else { eval [list $top.menubar configure] $mbfnt } } if { [Widget::hasChanged $path -menuentryfont newmefnt] } { if {[string length $newmefnt]} { set mefnt [list -font $newmefnt] } else { set mefnt "" } set top $_widget($path,top) if {[string equal $top .]} { set mb .menubar } else { set mb $top.menubar } set l [winfo children $mb] while {[llength $l]} { set e [lindex $l 0] set l [lrange $l 1 end] if {[string length $e] == 0} {continue} lappend l [winfo children $e] eval [list $e configure] $mefnt } } if { [Widget::hasChanged $path -statusbarfont newsbfnt] } { if {[string length $newsbfnt]} { set sbfnt [list -font $newsbfnt] } else { set sbfnt "" } for {set index 0} {$index<$_widget($path,nindic)} {incr index} { set indic $path.status.indf.f$index eval [list $indic configure] $sbfnt } eval [list $path.status.label configure] $sbfnt $path.status configure -height [winfo reqheight $path.status.label] $path.status.prg configure \ -height [expr {[winfo reqheight $path.status.label]-2}] } return $res } # ---------------------------------------------------------------------------- # Command MainFrame::cget # ---------------------------------------------------------------------------- proc MainFrame::cget { path option } { return [Widget::cget $path $option] } # ---------------------------------------------------------------------------- # Command MainFrame::getframe # ---------------------------------------------------------------------------- proc MainFrame::getframe { path } { return $path.frame } # ---------------------------------------------------------------------------- # Command MainFrame::addtoolbar # ---------------------------------------------------------------------------- proc MainFrame::addtoolbar { path } { global tcl_platform variable _widget set index $_widget($path,ntoolbar) set toolframe $path.topf.f$index set toolbar $path.topf.tb$index if { $tcl_platform(platform) == "unix" } { if {[Widget::theme]} { ttk::frame $toolframe -padding 1 } else { set bg [Widget::getoption $path -background] frame $toolframe -relief raised -borderwidth 1 \ -takefocus 0 -highlightthickness 0 -background $bg } } else { if {[Widget::theme]} { ttk::frame $toolframe set sep [ttk::separator $toolframe.sep -orient horizontal] } else { set bg [Widget::getoption $path -background] frame $toolframe -relief flat -borderwidth 0 -takefocus 0 \ -highlightthickness 0 -background $bg set sep [Separator::create $toolframe.sep -orient horizontal -background $bg] } pack $sep -fill x } if {[Widget::theme]} { set toolbar [ttk::frame $toolbar -padding 2] } else { set toolbar [frame $toolbar -relief flat -borderwidth 2 \ -takefocus 0 -highlightthickness 0 -background $bg] } pack $toolbar -in $toolframe -anchor w -expand yes -fill x incr _widget($path,ntoolbar) grid $toolframe -column 0 -row $index -sticky ew return $toolbar } # ---------------------------------------------------------------------------- # Command MainFrame::gettoolbar # ---------------------------------------------------------------------------- proc MainFrame::gettoolbar { path index } { return $path.topf.tb$index } # ---------------------------------------------------------------------------- # Command MainFrame::addindicator # ---------------------------------------------------------------------------- proc MainFrame::addindicator { path args } { variable _widget if {[string length [Widget::getoption $path -statusbarfont]]} { set sbfnt [list -font [Widget::getoption $path -statusbarfont]] } else { set sbfnt "" } set index $_widget($path,nindic) set indic $path.status.indf.f$index eval [list label $indic] $args -relief sunken -borderwidth 1 \ -takefocus 0 -highlightthickness 0 $sbfnt pack $indic -side left -anchor w -padx 2 -fill y -expand 1 incr _widget($path,nindic) return $indic } # ---------------------------------------------------------------------------- # Command MainFrame::getindicator # ---------------------------------------------------------------------------- proc MainFrame::getindicator { path index } { return $path.status.indf.f$index } # ---------------------------------------------------------------------------- # Command MainFrame::getmenu # ---------------------------------------------------------------------------- proc MainFrame::getmenu { path menuid } { variable _widget if { [info exists _widget($path,menuid,$menuid)] } { return $_widget($path,menuid,$menuid) } return "" } # ----------------------------------------------------------------------------- # Command MainFrame::setmenustate # ----------------------------------------------------------------------------- proc MainFrame::setmenustate { path tag state } { variable _widget # Set menustate to enabled when ALL of its tags are enabled. # First see if this is a real tag if { [info exists _widget($path,tagstate,$tag)] } { if { ![string equal $state "disabled"] } { set _widget($path,tagstate,$tag) 1 } else { set _widget($path,tagstate,$tag) 0 } foreach {menu entry} $_widget($path,tags,$tag) { set expression "1" foreach menutag $_widget($path,menutags,[list $menu $entry]) { append expression " && $_widget($path,tagstate,$menutag)" } if { [expr $expression] } { set state normal } else { set state disabled } $menu entryconfigure $entry -state $state } } return } # ----------------------------------------------------------------------------- # Command MainFrame::getmenustate # ----------------------------------------------------------------------------- proc MainFrame::getmenustate { path tag } { variable _widget if {$_widget($path,tagstate,$tag)} { return normal } else { return disabled } } # ----------------------------------------------------------------------------- # Command MainFrame::menuonly # ----------------------d------------------------------------------------------ proc MainFrame::menuonly { path } { variable _widget catch {pack forget $path.sep} catch {pack forget $path.botf.sep} catch {pack forget $path.frame} } # ---------------------------------------------------------------------------- # Command MainFrame::showtoolbar # ---------------------------------------------------------------------------- proc MainFrame::showtoolbar { path index bool } { variable _widget set toolframe $path.topf.f$index if { [winfo exists $toolframe] } { if { !$bool && [llength [grid info $toolframe]] } { grid forget $toolframe $path.topf configure -height 1 } elseif { $bool && ![llength [grid info $toolframe]] } { grid $toolframe -column 0 -row $index -sticky ew } } } # ---------------------------------------------------------------------------- # Command MainFrame::showstatusbar # ---------------------------------------------------------------------------- proc MainFrame::showstatusbar { path name } { set status $path.status set botframe $path.botf if { [string equal $name "none"] } { pack forget $status } else { pack $status -fill x -in $botframe -fill x -pady 2 switch -- $name { status { catch {pack forget $status.prg} } progression { pack $status.prg -in $status.prgf } } } } # ---------------------------------------------------------------------------- # Command MainFrame::_destroy # ---------------------------------------------------------------------------- proc MainFrame::_destroy { path } { variable _widget Widget::destroy $path catch {destroy [$_widget($path,top) cget -menu]} $_widget($path,top) configure -menu {} # Unset all of the state vars associated with this main frame. foreach index [array names _widget $path,*] { unset _widget($index) } } # ---------------------------------------------------------------------------- # Command MainFrame::_create_menubar # ---------------------------------------------------------------------------- # For Android, a menubutton is more appropriate. # To support this, the menubutton widget may be passed as 3rd # parameter. proc MainFrame::_create_menubar { path descmenu {top ""} } { variable _widget global tcl_platform if {![string length $top]} { set top $_widget($path,top) } foreach {v x} {mbfnt -menubarfont mefnt -menuentryfont} { if {[string length [Widget::getoption $path $x]]} { set $v [list -font [Widget::getoption $path $x]] } else { set $v "" } } if { ![Widget::theme] && $tcl_platform(platform) == "unix" && [tk windowingsystem] !="aqua" } { set menuopts [list -background [Widget::getoption $path -background] \ -borderwidth 1] } else { set menuopts [list] } set menubar [eval [list menu $top.menubar -tearoff 0] $menuopts $mbfnt] $top configure -menu $menubar set count 0 foreach {name tags menuid tearoff entries} $descmenu { # Check if only one menu with an empty name is given # In this case, remove the top level menu item # This allows to also have checkboxes and commands at the top level. if {![string length $name] && 5 == [llength $descmenu]} { # A single namesless menu - skip the first level to allow other # than cascade as first level. set menu $menubar } else { set opt [_parse_name $name] if {[string length $menuid] && ![info exists _widget($path,menuid,$menuid)] } { # menu has identifier # we use it for its pathname, to enable special menu entries # (help, system, ...) set menu $menubar.$menuid } else { set menu $menubar.menu$count } eval [list $menubar add cascade] $opt [list -menu $menu] eval [list menu $menu -tearoff $tearoff] $menuopts $mefnt foreach tag $tags { lappend _widget($path,tags,$tag) $menubar $count # ericm@scriptics: Add a tagstate tracker if { ![info exists _widget($path,tagstate,$tag)] } { set _widget($path,tagstate,$tag) 1 } } # ericm@scriptics: Add mapping from menu items to tags set _widget($path,menutags,[list $menubar $count]) $tags if { [string length $menuid] } { # menu has identifier set _widget($path,menuid,$menuid) $menu } } _create_entries $path $menu $menuopts $entries incr count } } # ---------------------------------------------------------------------------- # Command MainFrame::_create_entries # ---------------------------------------------------------------------------- proc MainFrame::_create_entries { path menu menuopts entries } { variable _widget set count [$menu cget -tearoff] set registered 0 foreach entry $entries { set len [llength $entry] set type [lindex $entry 0] if { [string equal $type "separator"] } { $menu add separator incr count continue } # entry name and tags set opt [_parse_name [lindex $entry 1]] set tags [lindex $entry 2] foreach tag $tags { lappend _widget($path,tags,$tag) $menu $count # ericm@scriptics: Add a tagstate tracker if { ![info exists _widget($path,tagstate,$tag)] } { set _widget($path,tagstate,$tag) 1 } } # ericm@scriptics: Add mapping from menu items to tags set _widget($path,menutags,[list $menu $count]) $tags if {[string equal $type "cascade"] || [string equal $type "cascad"]} { set menuid [lindex $entry 3] set tearoff [lindex $entry 4] set submenu $menu.menu$count eval [list $menu add cascade] $opt [list -menu $submenu] eval [list menu $submenu -tearoff $tearoff] $menuopts if { [string length $menuid] } { # menu has identifier set _widget($path,menuid,$menuid) $submenu } _create_entries $path $submenu $menuopts [lindex $entry 5] incr count continue } # entry help description set desc [lindex $entry 3] if { [string length $desc] } { if { !$registered } { DynamicHelp::register $menu menu [Widget::getoption $path -textvariable] set registered 1 } DynamicHelp::register $menu menuentry $count $desc } # entry accelerator set accel [_parse_accelerator [lindex $entry 4]] if { [llength $accel] } { lappend opt -accelerator [lindex $accel 0] foreach event [lindex $accel 1] { bind $_widget($path,top) $event [list $menu invoke $count] } foreach event [lindex $accel 2] { if {[bind $_widget($path,top) $event] == {}} { bind $_widget($path,top) $event { # do nothing } } else { # The existing binding will intercept these events. } } } # user options set useropt [lrange $entry 5 end] if { [string equal $type "command"] || [string equal $type "radiobutton"] || [string equal $type "checkbutton"] } { eval [list $menu add $type] $opt $useropt } else { return -code error "invalid menu type \"$type\"" } incr count } } # ---------------------------------------------------------------------------- # Command MainFrame::_parse_name # ---------------------------------------------------------------------------- proc MainFrame::_parse_name { menuname } { set idx [string first "&" $menuname] if { $idx == -1 } { return [list -label $menuname] } else { set beg [string range $menuname 0 [expr {$idx-1}]] set end [string range $menuname [expr {$idx+1}] end] append beg $end return [list -label $beg -underline $idx] } } # MainFrame::_parse_accelerator -- # # Given a key combo description, construct an appropriate human readable # string (for display on as a menu accelerator), a list of the # corresponding bind events, and a separate list of bind events that need # to be blocked. # # When argument $desc does not include "Shift", the bindings to $events # will in some cases also intercept events that have the modifier "Shift", # unless more specific bindings $blockEvents exist to the latter. This # situation occurs, for example, when a Cmd binding exists without a # corresponding ShiftCmd binding. The list of events that need to be # blocked is returned as the third element of the result. # # Arguments: # desc a list with the following format: # ?sequence? key # sequence may be None, Ctrl, Alt, CtrlAlt, Shift, Cmd or # ShiftCmd # key may be any key # # Results: # {accel events blockEvents} a list containing the accelerator string and # two lists of events proc MainFrame::_parse_accelerator { desc } { variable _widget set fKey 0 if { [llength $desc] == 1 } { set seq None set key [string tolower [lindex $desc 0]] # If the key is an F key (ie, F1, F2, etc), it has to be capitalized if {[regexp {^f([1-9]|([12][0-9]|3[0-5]))$} $key]} { set key [string toupper $key] set fKey 1 } } elseif { [llength $desc] == 2 } { set seq [lindex $desc 0] set key [string tolower [lindex $desc 1]] # If the key is an F key (ie, F1, F2, etc), it has to be capitalized if {[regexp {^f([1-9]|([12][0-9]|3[0-5]))$} $key]} { set key [string toupper $key] set fKey 1 } } else { return {} } # Plain "Shift" can be used only with F keys, but "ShiftCmd" is allowed. if {[string equal $seq "Shift"] && (!$fKey)} { return -code error {Shift accelerator can be used only with F keys} } set blockEvents {} set upc [string toupper $key] switch -- $seq { None { set accel "$upc" set events [list ""] if {$fKey} { set blockEvents [list ""] } } Shift { # Used only with Function keys. set accel "Shift+$upc" set events [list ""] } Cmd { set accel "Cmd+$upc" if { [string equal [tk windowingsystem] "aqua"] && ([string first AppKit [winfo server .]] == -1) } { # Carbon set events [list "" \ "" ] set blockEvents [list ""] # Both bindings must be included in $events - the first binding # does not fire if "Lock" is set, and this is as bind(n) states # because the second binding is NOT a more specialized form of # the first. } else { # Cocoa and anything else that uses Cmd set events [list ""] # A binding to "" must not be included # here - both events fire if "Lock" is set. set blockEvents [list ""] } } ShiftCmd { if { [string equal [tk windowingsystem] "aqua"] && ([string first AppKit [winfo server .]] == -1) } { # Carbon set accel "Shift+Cmd+$upc" set events [list "" \ ""] # Both bindings must be included here - the first binding does # not fire if "Lock" is set, even though the second binding # should be recognized as a more specialized form of the first. } else { # Cocoa and anything else that uses Cmd set accel "Shift+Cmd+$upc" set events [list ""] # A binding to "" must not be # included here - both events fire if "Lock" is set. # Tk/Cocoa fails to recognize # as a "more specialized" binding # than . # Perversely, Tk/Carbon (above) makes the opposite error. } } Ctrl { set accel "Ctrl+$upc" set events [list ""] } Alt { set accel "Alt+$upc" set events [list ""] } CtrlAlt { set accel "Ctrl+Alt+$upc" set events [list ""] } default { return -code error "invalid accelerator code $seq" } } return [list $accel $events $blockEvents] } bwidget-1.9.14/dynhelp.tcl0000644000076500001440000005675013571542357014625 0ustar oehharusers# ---------------------------------------------------------------------------- # dynhelp.tcl # This file is part of Unifix BWidget Toolkit # $Id: dynhelp.tcl,v 1.20.2.1 2009/08/12 07:20:21 oehhar Exp $ # ---------------------------------------------------------------------------- # Index of commands: # - DynamicHelp::configure # - DynamicHelp::include # - DynamicHelp::sethelp # - DynamicHelp::register # - DynamicHelp::_motion_balloon # - DynamicHelp::_motion_info # - DynamicHelp::_leave_info # - DynamicHelp::_menu_info # - DynamicHelp::_show_help # - DynamicHelp::_init # ---------------------------------------------------------------------------- namespace eval DynamicHelp { Widget::define DynamicHelp dynhelp -classonly if {$::tcl_version >= 8.5} { set fontdefault TkTooltipFont } elseif {$Widget::_aqua} { set fontdefault {helvetica 11} } else { set fontdefault {helvetica 8} } Widget::declare DynamicHelp [list\ {-foreground TkResource black 0 label}\ {-topbackground TkResource black 0 {label -foreground}}\ {-background TkResource "#FFFFC0" 0 label}\ {-borderwidth TkResource 1 0 label}\ {-justify TkResource left 0 label}\ [list -font TkResource $fontdefault 0 label]\ {-delay Int 600 0 "%d >= 100 & %d <= 2000"}\ {-state Enum "normal" 0 {normal disabled}}\ {-padx TkResource 1 0 label}\ {-pady TkResource 1 0 label}\ {-bd Synonym -borderwidth}\ {-bg Synonym -background}\ {-fg Synonym -foreground}\ {-topbg Synonym -topbackground}\ ] proc use {} {} variable _registered variable _canvases variable _texts variable _top ".help_shell" variable _id "" variable _delay 600 variable _current_balloon "" variable _current_variable "" variable _saved Widget::init DynamicHelp $_top {} bind BwHelpBalloon {DynamicHelp::_motion_balloon enter %W %X %Y} bind BwHelpBalloon {DynamicHelp::_motion_balloon motion %W %X %Y} bind BwHelpBalloon {DynamicHelp::_motion_balloon leave %W %X %Y} bind BwHelpBalloon