2436 lines
77 KiB
Tcl
2436 lines
77 KiB
Tcl
|
# ----------------------------------------------------------------------------
|
||
|
|
# progressbar.tcl
|
||
|
|
# This file is part of Unifix BWidget Toolkit
|
||
|
|
# ----------------------------------------------------------------------------
|
||
|
|
# Index of commands:
|
||
|
|
# - ProgressBar::create
|
||
|
|
# - ProgressBar::configure
|
||
|
|
# - ProgressBar::cget
|
||
|
|
# - ProgressBar::_destroy
|
||
|
|
# - ProgressBar::_modify
|
||
|
|
# ----------------------------------------------------------------------------
|
||
|
|
|
||
|
|
package provide PBar 1.0
|
||
|
|
|
||
|
|
# ----------------------------------------------------------------------------
|
||
|
|
# utils.tcl
|
||
|
|
# This file is part of Unifix BWidget Toolkit
|
||
|
|
# $Id: utils.tcl,v 1.12 2004/09/24 23:57:13 hobbs Exp $
|
||
|
|
# ----------------------------------------------------------------------------
|
||
|
|
# Index of commands:
|
||
|
|
# - GlobalVar::exists
|
||
|
|
# - GlobalVar::setvarvar
|
||
|
|
# - GlobalVar::getvarvar
|
||
|
|
# - BWidget::assert
|
||
|
|
# - BWidget::clonename
|
||
|
|
# - BWidget::get3dcolor
|
||
|
|
# - BWidget::XLFDfont
|
||
|
|
# - BWidget::place
|
||
|
|
# - BWidget::grab
|
||
|
|
# - BWidget::focus
|
||
|
|
# ----------------------------------------------------------------------------
|
||
|
|
|
||
|
|
namespace eval GlobalVar {
|
||
|
|
proc use {} {}
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
namespace eval BWidget {
|
||
|
|
variable _top
|
||
|
|
variable _gstack {}
|
||
|
|
variable _fstack {}
|
||
|
|
proc use {} {}
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
# ----------------------------------------------------------------------------
|
||
|
|
# Command GlobalVar::exists
|
||
|
|
# ----------------------------------------------------------------------------
|
||
|
|
proc GlobalVar::exists { varName } {
|
||
|
|
return [uplevel \#0 [list info exists $varName]]
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
# ----------------------------------------------------------------------------
|
||
|
|
# Command GlobalVar::setvar
|
||
|
|
# ----------------------------------------------------------------------------
|
||
|
|
proc GlobalVar::setvar { varName value } {
|
||
|
|
return [uplevel \#0 [list set $varName $value]]
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
# ----------------------------------------------------------------------------
|
||
|
|
# Command GlobalVar::getvar
|
||
|
|
# ----------------------------------------------------------------------------
|
||
|
|
proc GlobalVar::getvar { varName } {
|
||
|
|
return [uplevel \#0 [list set $varName]]
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
# ----------------------------------------------------------------------------
|
||
|
|
# Command GlobalVar::tracevar
|
||
|
|
# ----------------------------------------------------------------------------
|
||
|
|
proc GlobalVar::tracevar { cmd varName args } {
|
||
|
|
return [uplevel \#0 [list trace $cmd $varName] $args]
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
# ----------------------------------------------------------------------------
|
||
|
|
# Command BWidget::lreorder
|
||
|
|
# ----------------------------------------------------------------------------
|
||
|
|
proc BWidget::lreorder { list neworder } {
|
||
|
|
set pos 0
|
||
|
|
set newlist {}
|
||
|
|
foreach e $neworder {
|
||
|
|
if { [lsearch -exact $list $e] != -1 } {
|
||
|
|
lappend newlist $e
|
||
|
|
set tabelt($e) 1
|
||
|
|
}
|
||
|
|
}
|
||
|
|
set len [llength $newlist]
|
||
|
|
if { !$len } {
|
||
|
|
return $list
|
||
|
|
}
|
||
|
|
if { $len == [llength $list] } {
|
||
|
|
return $newlist
|
||
|
|
}
|
||
|
|
set pos 0
|
||
|
|
foreach e $list {
|
||
|
|
if { ![info exists tabelt($e)] } {
|
||
|
|
set newlist [linsert $newlist $pos $e]
|
||
|
|
}
|
||
|
|
incr pos
|
||
|
|
}
|
||
|
|
return $newlist
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
# ----------------------------------------------------------------------------
|
||
|
|
# Command BWidget::assert
|
||
|
|
# ----------------------------------------------------------------------------
|
||
|
|
proc BWidget::assert { exp {msg ""}} {
|
||
|
|
set res [uplevel 1 expr $exp]
|
||
|
|
if { !$res} {
|
||
|
|
if { $msg == "" } {
|
||
|
|
return -code error "Assertion failed: {$exp}"
|
||
|
|
} else {
|
||
|
|
return -code error $msg
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
# ----------------------------------------------------------------------------
|
||
|
|
# Command BWidget::clonename
|
||
|
|
# ----------------------------------------------------------------------------
|
||
|
|
proc BWidget::clonename { menu } {
|
||
|
|
set path ""
|
||
|
|
set menupath ""
|
||
|
|
set found 0
|
||
|
|
foreach widget [lrange [split $menu "."] 1 end] {
|
||
|
|
if { $found || [winfo class "$path.$widget"] == "Menu" } {
|
||
|
|
set found 1
|
||
|
|
append menupath "#" $widget
|
||
|
|
append path "." $menupath
|
||
|
|
} else {
|
||
|
|
append menupath "#" $widget
|
||
|
|
append path "." $widget
|
||
|
|
}
|
||
|
|
}
|
||
|
|
return $path
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
# ----------------------------------------------------------------------------
|
||
|
|
# Command BWidget::getname
|
||
|
|
# ----------------------------------------------------------------------------
|
||
|
|
proc BWidget::getname { name } {
|
||
|
|
if { [string length $name] } {
|
||
|
|
set text [option get . "${name}Name" ""]
|
||
|
|
if { [string length $text] } {
|
||
|
|
return [parsetext $text]
|
||
|
|
}
|
||
|
|
}
|
||
|
|
return {}
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
# ----------------------------------------------------------------------------
|
||
|
|
# Command BWidget::parsetext
|
||
|
|
# ----------------------------------------------------------------------------
|
||
|
|
proc BWidget::parsetext { text } {
|
||
|
|
set result ""
|
||
|
|
set index -1
|
||
|
|
set start 0
|
||
|
|
while { [string length $text] } {
|
||
|
|
set idx [string first "&" $text]
|
||
|
|
if { $idx == -1 } {
|
||
|
|
append result $text
|
||
|
|
set text ""
|
||
|
|
} else {
|
||
|
|
set char [string index $text [expr {$idx+1}]]
|
||
|
|
if { $char == "&" } {
|
||
|
|
append result [string range $text 0 $idx]
|
||
|
|
set text [string range $text [expr {$idx+2}] end]
|
||
|
|
set start [expr {$start+$idx+1}]
|
||
|
|
} else {
|
||
|
|
append result [string range $text 0 [expr {$idx-1}]]
|
||
|
|
set text [string range $text [expr {$idx+1}] end]
|
||
|
|
incr start $idx
|
||
|
|
set index $start
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
return [list $result $index]
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
# ----------------------------------------------------------------------------
|
||
|
|
# Command BWidget::get3dcolor
|
||
|
|
# ----------------------------------------------------------------------------
|
||
|
|
proc BWidget::get3dcolor { path bgcolor } {
|
||
|
|
foreach val [winfo rgb $path $bgcolor] {
|
||
|
|
lappend dark [expr {60*$val/100}]
|
||
|
|
set tmp1 [expr {14*$val/10}]
|
||
|
|
if { $tmp1 > 65535 } {
|
||
|
|
set tmp1 65535
|
||
|
|
}
|
||
|
|
set tmp2 [expr {(65535+$val)/2}]
|
||
|
|
lappend light [expr {($tmp1 > $tmp2) ? $tmp1:$tmp2}]
|
||
|
|
}
|
||
|
|
return [list [eval format "#%04x%04x%04x" $dark] [eval format "#%04x%04x%04x" $light]]
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
# ----------------------------------------------------------------------------
|
||
|
|
# Command BWidget::XLFDfont
|
||
|
|
# ----------------------------------------------------------------------------
|
||
|
|
proc BWidget::XLFDfont { cmd args } {
|
||
|
|
switch -- $cmd {
|
||
|
|
create {
|
||
|
|
set font "-*-*-*-*-*-*-*-*-*-*-*-*-*-*"
|
||
|
|
}
|
||
|
|
configure {
|
||
|
|
set font [lindex $args 0]
|
||
|
|
set args [lrange $args 1 end]
|
||
|
|
}
|
||
|
|
default {
|
||
|
|
return -code error "XLFDfont: commande incorrect: $cmd"
|
||
|
|
}
|
||
|
|
}
|
||
|
|
set lfont [split $font "-"]
|
||
|
|
if { [llength $lfont] != 15 } {
|
||
|
|
return -code error "XLFDfont: description XLFD incorrect: $font"
|
||
|
|
}
|
||
|
|
|
||
|
|
foreach {option value} $args {
|
||
|
|
switch -- $option {
|
||
|
|
-foundry { set index 1 }
|
||
|
|
-family { set index 2 }
|
||
|
|
-weight { set index 3 }
|
||
|
|
-slant { set index 4 }
|
||
|
|
-size { set index 7 }
|
||
|
|
default { return -code error "XLFDfont: option incorrecte: $option" }
|
||
|
|
}
|
||
|
|
set lfont [lreplace $lfont $index $index $value]
|
||
|
|
}
|
||
|
|
return [join $lfont "-"]
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
# ----------------------------------------------------------------------------
|
||
|
|
# Command BWidget::place
|
||
|
|
# ----------------------------------------------------------------------------
|
||
|
|
#
|
||
|
|
# Notes:
|
||
|
|
# For Windows systems with more than one monitor the available screen area may
|
||
|
|
# have negative positions. Geometry settings with negative numbers are used
|
||
|
|
# under X to place wrt the right or bottom of the screen. On windows, Tk
|
||
|
|
# continues to do this. However, a geometry such as 100x100+-200-100 can be
|
||
|
|
# used to place a window onto a secondary monitor. Passing the + gets Tk
|
||
|
|
# to pass the remainder unchanged so the Windows manager then handles -200
|
||
|
|
# which is a position on the left hand monitor.
|
||
|
|
# I've tested this for left, right, above and below the primary monitor.
|
||
|
|
# Currently there is no way to ask Tk the extent of the Windows desktop in
|
||
|
|
# a multi monitor system. Nor what the legal co-ordinate range might be.
|
||
|
|
#
|
||
|
|
proc BWidget::place { path w h args } {
|
||
|
|
variable _top
|
||
|
|
|
||
|
|
update idletasks
|
||
|
|
set reqw [winfo reqwidth $path]
|
||
|
|
set reqh [winfo reqheight $path]
|
||
|
|
if { $w == 0 } {set w $reqw}
|
||
|
|
if { $h == 0 } {set h $reqh}
|
||
|
|
|
||
|
|
set arglen [llength $args]
|
||
|
|
if { $arglen > 3 } {
|
||
|
|
return -code error "BWidget::place: bad number of argument"
|
||
|
|
}
|
||
|
|
|
||
|
|
if { $arglen > 0 } {
|
||
|
|
set where [lindex $args 0]
|
||
|
|
set list [list "at" "center" "left" "right" "above" "below"]
|
||
|
|
set idx [lsearch $list $where]
|
||
|
|
if { $idx == -1 } {
|
||
|
|
return -code error [BWidget::badOptionString position $where $list]
|
||
|
|
}
|
||
|
|
if { $idx == 0 } {
|
||
|
|
set err [catch {
|
||
|
|
# purposely removed the {} around these expressions - [PT]
|
||
|
|
set x [expr int([lindex $args 1])]
|
||
|
|
set y [expr int([lindex $args 2])]
|
||
|
|
}]
|
||
|
|
if { $err } {
|
||
|
|
return -code error "BWidget::place: incorrect position"
|
||
|
|
}
|
||
|
|
if {$::tcl_platform(platform) == "windows"} {
|
||
|
|
# handle windows multi-screen. -100 != +-100
|
||
|
|
if {[string index [lindex $args 1] 0] != "-"} {
|
||
|
|
set x "+$x"
|
||
|
|
}
|
||
|
|
if {[string index [lindex $args 2] 0] != "-"} {
|
||
|
|
set y "+$y"
|
||
|
|
}
|
||
|
|
} else {
|
||
|
|
if { $x >= 0 } {
|
||
|
|
set x "+$x"
|
||
|
|
}
|
||
|
|
if { $y >= 0 } {
|
||
|
|
set y "+$y"
|
||
|
|
}
|
||
|
|
}
|
||
|
|
} else {
|
||
|
|
if { $arglen == 2 } {
|
||
|
|
set widget [lindex $args 1]
|
||
|
|
if { ![winfo exists $widget] } {
|
||
|
|
return -code error "BWidget::place: \"$widget\" does not exist"
|
||
|
|
}
|
||
|
|
} else {
|
||
|
|
set widget .
|
||
|
|
}
|
||
|
|
set sw [winfo screenwidth $path]
|
||
|
|
set sh [winfo screenheight $path]
|
||
|
|
if { $idx == 1 } {
|
||
|
|
if { $arglen == 2 } {
|
||
|
|
# center to widget
|
||
|
|
set x0 [expr {[winfo rootx $widget] + ([winfo width $widget] - $w)/2}]
|
||
|
|
set y0 [expr {[winfo rooty $widget] + ([winfo height $widget] - $h)/2}]
|
||
|
|
} else {
|
||
|
|
# center to screen
|
||
|
|
set x0 [expr {([winfo screenwidth $path] - $w)/2 - [winfo vrootx $path]}]
|
||
|
|
set y0 [expr {([winfo screenheight $path] - $h)/2 - [winfo vrooty $path]}]
|
||
|
|
}
|
||
|
|
set x "+$x0"
|
||
|
|
set y "+$y0"
|
||
|
|
if {$::tcl_platform(platform) != "windows"} {
|
||
|
|
if { $x0+$w > $sw } {set x "-0"; set x0 [expr {$sw-$w}]}
|
||
|
|
if { $x0 < 0 } {set x "+0"}
|
||
|
|
if { $y0+$h > $sh } {set y "-0"; set y0 [expr {$sh-$h}]}
|
||
|
|
if { $y0 < 0 } {set y "+0"}
|
||
|
|
}
|
||
|
|
} else {
|
||
|
|
set x0 [winfo rootx $widget]
|
||
|
|
set y0 [winfo rooty $widget]
|
||
|
|
set x1 [expr {$x0 + [winfo width $widget]}]
|
||
|
|
set y1 [expr {$y0 + [winfo height $widget]}]
|
||
|
|
if { $idx == 2 || $idx == 3 } {
|
||
|
|
set y "+$y0"
|
||
|
|
if {$::tcl_platform(platform) != "windows"} {
|
||
|
|
if { $y0+$h > $sh } {set y "-0"; set y0 [expr {$sh-$h}]}
|
||
|
|
if { $y0 < 0 } {set y "+0"}
|
||
|
|
}
|
||
|
|
if { $idx == 2 } {
|
||
|
|
# try left, then right if out, then 0 if out
|
||
|
|
if { $x0 >= $w } {
|
||
|
|
set x [expr {$x0-$sw}]
|
||
|
|
} elseif { $x1+$w <= $sw } {
|
||
|
|
set x "+$x1"
|
||
|
|
} else {
|
||
|
|
set x "+0"
|
||
|
|
}
|
||
|
|
} else {
|
||
|
|
# try right, then left if out, then 0 if out
|
||
|
|
if { $x1+$w <= $sw } {
|
||
|
|
set x "+$x1"
|
||
|
|
} elseif { $x0 >= $w } {
|
||
|
|
set x [expr {$x0-$sw}]
|
||
|
|
} else {
|
||
|
|
set x "-0"
|
||
|
|
}
|
||
|
|
}
|
||
|
|
} else {
|
||
|
|
set x "+$x0"
|
||
|
|
if {$::tcl_platform(platform) != "windows"} {
|
||
|
|
if { $x0+$w > $sw } {set x "-0"; set x0 [expr {$sw-$w}]}
|
||
|
|
if { $x0 < 0 } {set x "+0"}
|
||
|
|
}
|
||
|
|
if { $idx == 4 } {
|
||
|
|
# try top, then bottom, then 0
|
||
|
|
if { $h <= $y0 } {
|
||
|
|
set y [expr {$y0-$sh}]
|
||
|
|
} elseif { $y1+$h <= $sh } {
|
||
|
|
set y "+$y1"
|
||
|
|
} else {
|
||
|
|
set y "+0"
|
||
|
|
}
|
||
|
|
} else {
|
||
|
|
# try bottom, then top, then 0
|
||
|
|
if { $y1+$h <= $sh } {
|
||
|
|
set y "+$y1"
|
||
|
|
} elseif { $h <= $y0 } {
|
||
|
|
set y [expr {$y0-$sh}]
|
||
|
|
} else {
|
||
|
|
set y "-0"
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
## If there's not a + or - in front of the number, we need to add one.
|
||
|
|
if {[string is integer [string index $x 0]]} { set x +$x }
|
||
|
|
if {[string is integer [string index $y 0]]} { set y +$y }
|
||
|
|
|
||
|
|
wm geometry $path "${w}x${h}${x}${y}"
|
||
|
|
} else {
|
||
|
|
wm geometry $path "${w}x${h}"
|
||
|
|
}
|
||
|
|
update idletasks
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
# ----------------------------------------------------------------------------
|
||
|
|
# Command BWidget::grab
|
||
|
|
# ----------------------------------------------------------------------------
|
||
|
|
proc BWidget::grab { option path } {
|
||
|
|
variable _gstack
|
||
|
|
|
||
|
|
if { $option == "release" } {
|
||
|
|
catch {::grab release $path}
|
||
|
|
while { [llength $_gstack] } {
|
||
|
|
set grinfo [lindex $_gstack end]
|
||
|
|
set _gstack [lreplace $_gstack end end]
|
||
|
|
foreach {oldg mode} $grinfo {
|
||
|
|
if { ![string equal $oldg $path] && [winfo exists $oldg] } {
|
||
|
|
if { $mode == "global" } {
|
||
|
|
catch {::grab -global $oldg}
|
||
|
|
} else {
|
||
|
|
catch {::grab $oldg}
|
||
|
|
}
|
||
|
|
return
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
} else {
|
||
|
|
set oldg [::grab current]
|
||
|
|
if { $oldg != "" } {
|
||
|
|
lappend _gstack [list $oldg [::grab status $oldg]]
|
||
|
|
}
|
||
|
|
if { $option == "global" } {
|
||
|
|
::grab -global $path
|
||
|
|
} else {
|
||
|
|
::grab $path
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
# ----------------------------------------------------------------------------
|
||
|
|
# Command BWidget::focus
|
||
|
|
# ----------------------------------------------------------------------------
|
||
|
|
proc BWidget::focus { option path {refocus 1} } {
|
||
|
|
variable _fstack
|
||
|
|
|
||
|
|
if { $option == "release" } {
|
||
|
|
while { [llength $_fstack] } {
|
||
|
|
set oldf [lindex $_fstack end]
|
||
|
|
set _fstack [lreplace $_fstack end end]
|
||
|
|
if { ![string equal $oldf $path] && [winfo exists $oldf] } {
|
||
|
|
if {$refocus} {catch {::focus -force $oldf}}
|
||
|
|
return
|
||
|
|
}
|
||
|
|
}
|
||
|
|
} elseif { $option == "set" } {
|
||
|
|
lappend _fstack [::focus]
|
||
|
|
::focus -force $path
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
# BWidget::refocus --
|
||
|
|
#
|
||
|
|
# Helper function used to redirect focus from a container frame in
|
||
|
|
# a megawidget to a component widget. Only redirects focus if
|
||
|
|
# focus is already on the container.
|
||
|
|
#
|
||
|
|
# Arguments:
|
||
|
|
# container container widget to redirect from.
|
||
|
|
# component component widget to redirect to.
|
||
|
|
#
|
||
|
|
# Results:
|
||
|
|
# None.
|
||
|
|
|
||
|
|
proc BWidget::refocus {container component} {
|
||
|
|
if { [string equal $container [::focus]] } {
|
||
|
|
::focus $component
|
||
|
|
}
|
||
|
|
return
|
||
|
|
}
|
||
|
|
|
||
|
|
## These mirror tk::(Set|Restore)FocusGrab
|
||
|
|
|
||
|
|
# BWidget::SetFocusGrab --
|
||
|
|
# swap out current focus and grab temporarily (for dialogs)
|
||
|
|
# Arguments:
|
||
|
|
# grab new window to grab
|
||
|
|
# focus window to give focus to
|
||
|
|
# Results:
|
||
|
|
# Returns nothing
|
||
|
|
#
|
||
|
|
proc BWidget::SetFocusGrab {grab {focus {}}} {
|
||
|
|
variable _focusGrab
|
||
|
|
set index "$grab,$focus"
|
||
|
|
|
||
|
|
lappend _focusGrab($index) [::focus]
|
||
|
|
set oldGrab [::grab current $grab]
|
||
|
|
lappend _focusGrab($index) $oldGrab
|
||
|
|
if {[winfo exists $oldGrab]} {
|
||
|
|
lappend _focusGrab($index) [::grab status $oldGrab]
|
||
|
|
}
|
||
|
|
# The "grab" command will fail if another application
|
||
|
|
# already holds the grab. So catch it.
|
||
|
|
catch {::grab $grab}
|
||
|
|
if {[winfo exists $focus]} {
|
||
|
|
::focus $focus
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
# BWidget::RestoreFocusGrab --
|
||
|
|
# restore old focus and grab (for dialogs)
|
||
|
|
# Arguments:
|
||
|
|
# grab window that had taken grab
|
||
|
|
# focus window that had taken focus
|
||
|
|
# destroy destroy|withdraw - how to handle the old grabbed window
|
||
|
|
# Results:
|
||
|
|
# Returns nothing
|
||
|
|
#
|
||
|
|
proc BWidget::RestoreFocusGrab {grab focus {destroy destroy}} {
|
||
|
|
variable _focusGrab
|
||
|
|
set index "$grab,$focus"
|
||
|
|
if {[info exists _focusGrab($index)]} {
|
||
|
|
foreach {oldFocus oldGrab oldStatus} $_focusGrab($index) break
|
||
|
|
unset _focusGrab($index)
|
||
|
|
} else {
|
||
|
|
set oldGrab ""
|
||
|
|
}
|
||
|
|
|
||
|
|
catch {::focus $oldFocus}
|
||
|
|
::grab release $grab
|
||
|
|
if {[string equal $destroy "withdraw"]} {
|
||
|
|
wm withdraw $grab
|
||
|
|
} else {
|
||
|
|
::destroy $grab
|
||
|
|
}
|
||
|
|
if {[winfo exists $oldGrab] && [winfo ismapped $oldGrab]} {
|
||
|
|
if {[string equal $oldStatus "global"]} {
|
||
|
|
::grab -global $oldGrab
|
||
|
|
} else {
|
||
|
|
::grab $oldGrab
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
# BWidget::badOptionString --
|
||
|
|
#
|
||
|
|
# Helper function to return a proper error string when an option
|
||
|
|
# doesn't match a list of given options.
|
||
|
|
#
|
||
|
|
# Arguments:
|
||
|
|
# type A string that represents the type of option.
|
||
|
|
# value The value that is in-valid.
|
||
|
|
# list A list of valid options.
|
||
|
|
#
|
||
|
|
# Results:
|
||
|
|
# None.
|
||
|
|
proc BWidget::badOptionString {type value list} {
|
||
|
|
set last [lindex $list end]
|
||
|
|
set list [lreplace $list end end]
|
||
|
|
return "bad $type \"$value\": must be [join $list ", "], or $last"
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
proc BWidget::wrongNumArgsString { string } {
|
||
|
|
return "wrong # args: should be \"$string\""
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
proc BWidget::read_file { file } {
|
||
|
|
set fp [open $file]
|
||
|
|
set x [read $fp [file size $file]]
|
||
|
|
close $fp
|
||
|
|
return $x
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
proc BWidget::classes { class } {
|
||
|
|
variable use
|
||
|
|
|
||
|
|
${class}::use
|
||
|
|
set classes [list $class]
|
||
|
|
if {![info exists use($class)]} { return }
|
||
|
|
foreach class $use($class) {
|
||
|
|
eval lappend classes [classes $class]
|
||
|
|
}
|
||
|
|
return [lsort -unique $classes]
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
proc BWidget::library { args } {
|
||
|
|
variable use
|
||
|
|
|
||
|
|
set libs [list widget init utils]
|
||
|
|
set classes [list]
|
||
|
|
foreach class $args {
|
||
|
|
${class}::use
|
||
|
|
eval lappend classes [classes $class]
|
||
|
|
}
|
||
|
|
|
||
|
|
eval lappend libs [lsort -unique $classes]
|
||
|
|
|
||
|
|
set library ""
|
||
|
|
foreach lib $libs {
|
||
|
|
if {![info exists use($lib,file)]} {
|
||
|
|
set file [file join $::BWIDGET::LIBRARY $lib.tcl]
|
||
|
|
} else {
|
||
|
|
set file [file join $::BWIDGET::LIBRARY $use($lib,file).tcl]
|
||
|
|
}
|
||
|
|
append library [read_file $file]
|
||
|
|
}
|
||
|
|
|
||
|
|
return $library
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
proc BWidget::inuse { class } {
|
||
|
|
variable ::Widget::_inuse
|
||
|
|
|
||
|
|
if {![info exists _inuse($class)]} { return 0 }
|
||
|
|
return [expr $_inuse($class) > 0]
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
proc BWidget::write { filename {mode w} } {
|
||
|
|
variable use
|
||
|
|
|
||
|
|
if {![info exists use(classes)]} { return }
|
||
|
|
|
||
|
|
set classes [list]
|
||
|
|
foreach class $use(classes) {
|
||
|
|
if {![inuse $class]} { continue }
|
||
|
|
lappend classes $class
|
||
|
|
}
|
||
|
|
|
||
|
|
set fp [open $filename $mode]
|
||
|
|
puts $fp [eval library $classes]
|
||
|
|
close $fp
|
||
|
|
|
||
|
|
return
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
# BWidget::bindMouseWheel --
|
||
|
|
#
|
||
|
|
# Bind mouse wheel actions to a given widget.
|
||
|
|
#
|
||
|
|
# Arguments:
|
||
|
|
# widget - The widget to bind.
|
||
|
|
#
|
||
|
|
# Results:
|
||
|
|
# None.
|
||
|
|
proc BWidget::bindMouseWheel { widget } {
|
||
|
|
bind $widget <MouseWheel> {%W yview scroll [expr {-%D/24}] units}
|
||
|
|
bind $widget <Shift-MouseWheel> {%W yview scroll [expr {-%D/120}] pages}
|
||
|
|
bind $widget <Control-MouseWheel> {%W yview scroll [expr {-%D/120}] units}
|
||
|
|
|
||
|
|
bind $widget <Button-4> {event generate %W <MouseWheel> -delta 120}
|
||
|
|
bind $widget <Button-5> {event generate %W <MouseWheel> -delta -120}
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
# ----------------------------------------------------------------------------
|
||
|
|
# widget.tcl
|
||
|
|
# This file is part of Unifix BWidget Toolkit
|
||
|
|
# $Id: widget.tcl,v 1.29 2005/07/28 00:40:42 hobbs Exp $
|
||
|
|
# ----------------------------------------------------------------------------
|
||
|
|
# Index of commands:
|
||
|
|
# - Widget::tkinclude
|
||
|
|
# - Widget::bwinclude
|
||
|
|
# - Widget::declare
|
||
|
|
# - Widget::addmap
|
||
|
|
# - Widget::init
|
||
|
|
# - Widget::destroy
|
||
|
|
# - Widget::setoption
|
||
|
|
# - Widget::configure
|
||
|
|
# - Widget::cget
|
||
|
|
# - Widget::subcget
|
||
|
|
# - Widget::hasChanged
|
||
|
|
# - Widget::options
|
||
|
|
# - Widget::_get_tkwidget_options
|
||
|
|
# - Widget::_test_tkresource
|
||
|
|
# - Widget::_test_bwresource
|
||
|
|
# - Widget::_test_synonym
|
||
|
|
# - Widget::_test_string
|
||
|
|
# - Widget::_test_flag
|
||
|
|
# - Widget::_test_enum
|
||
|
|
# - Widget::_test_int
|
||
|
|
# - Widget::_test_boolean
|
||
|
|
# ----------------------------------------------------------------------------
|
||
|
|
# Each megawidget gets a namespace of the same name inside the Widget namespace
|
||
|
|
# Each of these has an array opt, which contains information about the
|
||
|
|
# megawidget options. It maps megawidget options to a list with this format:
|
||
|
|
# {optionType defaultValue isReadonly {additionalOptionalInfo}}
|
||
|
|
# Option types and their additional optional info are:
|
||
|
|
# TkResource {genericTkWidget genericTkWidgetOptionName}
|
||
|
|
# BwResource {nothing}
|
||
|
|
# Enum {list of enumeration values}
|
||
|
|
# Int {Boundary information}
|
||
|
|
# Boolean {nothing}
|
||
|
|
# String {nothing}
|
||
|
|
# Flag {string of valid flag characters}
|
||
|
|
# Synonym {nothing}
|
||
|
|
# Color {nothing}
|
||
|
|
#
|
||
|
|
# Next, each namespace has an array map, which maps class options to their
|
||
|
|
# component widget options:
|
||
|
|
# map(-foreground) => {.e -foreground .f -foreground}
|
||
|
|
#
|
||
|
|
# Each has an array ${path}:opt, which contains the value of each megawidget
|
||
|
|
# option for a particular instance $path of the megawidget, and an array
|
||
|
|
# ${path}:mod, which stores the "changed" status of configuration options.
|
||
|
|
|
||
|
|
# Steps for creating a bwidget megawidget:
|
||
|
|
# 1. parse args to extract subwidget spec
|
||
|
|
# 2. Create frame with appropriate class and command line options
|
||
|
|
# 3. Get initialization options from optionDB, using frame
|
||
|
|
# 4. create subwidgets
|
||
|
|
|
||
|
|
# Uses newer string operations
|
||
|
|
package require Tcl 8.1.1
|
||
|
|
|
||
|
|
namespace eval Widget {
|
||
|
|
variable _optiontype
|
||
|
|
variable _class
|
||
|
|
variable _tk_widget
|
||
|
|
|
||
|
|
# This controls whether we try to use themed widgets from Tile
|
||
|
|
variable _theme 0
|
||
|
|
|
||
|
|
variable _aqua [expr {($::tcl_version >= 8.4) &&
|
||
|
|
[string equal [tk windowingsystem] "aqua"]}]
|
||
|
|
|
||
|
|
array set _optiontype {
|
||
|
|
TkResource Widget::_test_tkresource
|
||
|
|
BwResource Widget::_test_bwresource
|
||
|
|
Enum Widget::_test_enum
|
||
|
|
Int Widget::_test_int
|
||
|
|
Boolean Widget::_test_boolean
|
||
|
|
String Widget::_test_string
|
||
|
|
Flag Widget::_test_flag
|
||
|
|
Synonym Widget::_test_synonym
|
||
|
|
Color Widget::_test_color
|
||
|
|
Padding Widget::_test_padding
|
||
|
|
}
|
||
|
|
|
||
|
|
proc use {} {}
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
# ----------------------------------------------------------------------------
|
||
|
|
# Command Widget::tkinclude
|
||
|
|
# Includes tk widget resources to BWidget widget.
|
||
|
|
# class class name of the BWidget
|
||
|
|
# tkwidget tk widget to include
|
||
|
|
# subpath subpath to configure
|
||
|
|
# args additionnal args for included options
|
||
|
|
# ----------------------------------------------------------------------------
|
||
|
|
proc Widget::tkinclude { class tkwidget subpath args } {
|
||
|
|
foreach {cmd lopt} $args {
|
||
|
|
# cmd can be
|
||
|
|
# include options to include lopt = {opt ...}
|
||
|
|
# remove options to remove lopt = {opt ...}
|
||
|
|
# rename options to rename lopt = {opt newopt ...}
|
||
|
|
# prefix options to prefix lopt = {pref opt opt ..}
|
||
|
|
# initialize set default value for options lopt = {opt value ...}
|
||
|
|
# readonly set readonly flag for options lopt = {opt flag ...}
|
||
|
|
switch -- $cmd {
|
||
|
|
remove {
|
||
|
|
foreach option $lopt {
|
||
|
|
set remove($option) 1
|
||
|
|
}
|
||
|
|
}
|
||
|
|
include {
|
||
|
|
foreach option $lopt {
|
||
|
|
set include($option) 1
|
||
|
|
}
|
||
|
|
}
|
||
|
|
prefix {
|
||
|
|
set prefix [lindex $lopt 0]
|
||
|
|
foreach option [lrange $lopt 1 end] {
|
||
|
|
set rename($option) "-$prefix[string range $option 1 end]"
|
||
|
|
}
|
||
|
|
}
|
||
|
|
rename -
|
||
|
|
readonly -
|
||
|
|
initialize {
|
||
|
|
array set $cmd $lopt
|
||
|
|
}
|
||
|
|
default {
|
||
|
|
return -code error "invalid argument \"$cmd\""
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
namespace eval $class {}
|
||
|
|
upvar 0 ${class}::opt classopt
|
||
|
|
upvar 0 ${class}::map classmap
|
||
|
|
upvar 0 ${class}::map$subpath submap
|
||
|
|
upvar 0 ${class}::optionExports exports
|
||
|
|
|
||
|
|
set foo [$tkwidget ".ericFoo###"]
|
||
|
|
# create resources informations from tk widget resources
|
||
|
|
foreach optdesc [_get_tkwidget_options $tkwidget] {
|
||
|
|
set option [lindex $optdesc 0]
|
||
|
|
if { (![info exists include] || [info exists include($option)]) &&
|
||
|
|
![info exists remove($option)] } {
|
||
|
|
if { [llength $optdesc] == 3 } {
|
||
|
|
# option is a synonym
|
||
|
|
set syn [lindex $optdesc 1]
|
||
|
|
if { ![info exists remove($syn)] } {
|
||
|
|
# original option is not removed
|
||
|
|
if { [info exists rename($syn)] } {
|
||
|
|
set classopt($option) [list Synonym $rename($syn)]
|
||
|
|
} else {
|
||
|
|
set classopt($option) [list Synonym $syn]
|
||
|
|
}
|
||
|
|
}
|
||
|
|
} else {
|
||
|
|
if { [info exists rename($option)] } {
|
||
|
|
set realopt $option
|
||
|
|
set option $rename($option)
|
||
|
|
} else {
|
||
|
|
set realopt $option
|
||
|
|
}
|
||
|
|
if { [info exists initialize($option)] } {
|
||
|
|
set value $initialize($option)
|
||
|
|
} else {
|
||
|
|
set value [lindex $optdesc 1]
|
||
|
|
}
|
||
|
|
if { [info exists readonly($option)] } {
|
||
|
|
set ro $readonly($option)
|
||
|
|
} else {
|
||
|
|
set ro 0
|
||
|
|
}
|
||
|
|
set classopt($option) \
|
||
|
|
[list TkResource $value $ro [list $tkwidget $realopt]]
|
||
|
|
|
||
|
|
# Add an option database entry for this option
|
||
|
|
set optionDbName ".[lindex [_configure_option $option ""] 0]"
|
||
|
|
if { ![string equal $subpath ":cmd"] } {
|
||
|
|
set optionDbName "$subpath$optionDbName"
|
||
|
|
}
|
||
|
|
option add *${class}$optionDbName $value widgetDefault
|
||
|
|
lappend exports($option) "$optionDbName"
|
||
|
|
|
||
|
|
# Store the forward and backward mappings for this
|
||
|
|
# option <-> realoption pair
|
||
|
|
lappend classmap($option) $subpath "" $realopt
|
||
|
|
set submap($realopt) $option
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
::destroy $foo
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
# ----------------------------------------------------------------------------
|
||
|
|
# Command Widget::bwinclude
|
||
|
|
# Includes BWidget resources to BWidget widget.
|
||
|
|
# class class name of the BWidget
|
||
|
|
# subclass BWidget class to include
|
||
|
|
# subpath subpath to configure
|
||
|
|
# args additionnal args for included options
|
||
|
|
# ----------------------------------------------------------------------------
|
||
|
|
proc Widget::bwinclude { class subclass subpath args } {
|
||
|
|
foreach {cmd lopt} $args {
|
||
|
|
# cmd can be
|
||
|
|
# include options to include lopt = {opt ...}
|
||
|
|
# remove options to remove lopt = {opt ...}
|
||
|
|
# rename options to rename lopt = {opt newopt ...}
|
||
|
|
# prefix options to prefix lopt = {prefix opt opt ...}
|
||
|
|
# initialize set default value for options lopt = {opt value ...}
|
||
|
|
# readonly set readonly flag for options lopt = {opt flag ...}
|
||
|
|
switch -- $cmd {
|
||
|
|
remove {
|
||
|
|
foreach option $lopt {
|
||
|
|
set remove($option) 1
|
||
|
|
}
|
||
|
|
}
|
||
|
|
include {
|
||
|
|
foreach option $lopt {
|
||
|
|
set include($option) 1
|
||
|
|
}
|
||
|
|
}
|
||
|
|
prefix {
|
||
|
|
set prefix [lindex $lopt 0]
|
||
|
|
foreach option [lrange $lopt 1 end] {
|
||
|
|
set rename($option) "-$prefix[string range $option 1 end]"
|
||
|
|
}
|
||
|
|
}
|
||
|
|
rename -
|
||
|
|
readonly -
|
||
|
|
initialize {
|
||
|
|
array set $cmd $lopt
|
||
|
|
}
|
||
|
|
default {
|
||
|
|
return -code error "invalid argument \"$cmd\""
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
namespace eval $class {}
|
||
|
|
upvar 0 ${class}::opt classopt
|
||
|
|
upvar 0 ${class}::map classmap
|
||
|
|
upvar 0 ${class}::map$subpath submap
|
||
|
|
upvar 0 ${class}::optionExports exports
|
||
|
|
upvar 0 ${subclass}::opt subclassopt
|
||
|
|
upvar 0 ${subclass}::optionExports subexports
|
||
|
|
|
||
|
|
# create resources informations from BWidget resources
|
||
|
|
foreach {option optdesc} [array get subclassopt] {
|
||
|
|
set subOption $option
|
||
|
|
if { (![info exists include] || [info exists include($option)]) &&
|
||
|
|
![info exists remove($option)] } {
|
||
|
|
set type [lindex $optdesc 0]
|
||
|
|
if { [string equal $type "Synonym"] } {
|
||
|
|
# option is a synonym
|
||
|
|
set syn [lindex $optdesc 1]
|
||
|
|
if { ![info exists remove($syn)] } {
|
||
|
|
if { [info exists rename($syn)] } {
|
||
|
|
set classopt($option) [list Synonym $rename($syn)]
|
||
|
|
} else {
|
||
|
|
set classopt($option) [list Synonym $syn]
|
||
|
|
}
|
||
|
|
}
|
||
|
|
} else {
|
||
|
|
if { [info exists rename($option)] } {
|
||
|
|
set realopt $option
|
||
|
|
set option $rename($option)
|
||
|
|
} else {
|
||
|
|
set realopt $option
|
||
|
|
}
|
||
|
|
if { [info exists initialize($option)] } {
|
||
|
|
set value $initialize($option)
|
||
|
|
} else {
|
||
|
|
set value [lindex $optdesc 1]
|
||
|
|
}
|
||
|
|
if { [info exists readonly($option)] } {
|
||
|
|
set ro $readonly($option)
|
||
|
|
} else {
|
||
|
|
set ro [lindex $optdesc 2]
|
||
|
|
}
|
||
|
|
set classopt($option) \
|
||
|
|
[list $type $value $ro [lindex $optdesc 3]]
|
||
|
|
|
||
|
|
# Add an option database entry for this option
|
||
|
|
foreach optionDbName $subexports($subOption) {
|
||
|
|
if { ![string equal $subpath ":cmd"] } {
|
||
|
|
set optionDbName "$subpath$optionDbName"
|
||
|
|
}
|
||
|
|
# Only add the option db entry if we are overriding the
|
||
|
|
# normal widget default
|
||
|
|
if { [info exists initialize($option)] } {
|
||
|
|
option add *${class}$optionDbName $value \
|
||
|
|
widgetDefault
|
||
|
|
}
|
||
|
|
lappend exports($option) "$optionDbName"
|
||
|
|
}
|
||
|
|
|
||
|
|
# Store the forward and backward mappings for this
|
||
|
|
# option <-> realoption pair
|
||
|
|
lappend classmap($option) $subpath $subclass $realopt
|
||
|
|
set submap($realopt) $option
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
# ----------------------------------------------------------------------------
|
||
|
|
# Command Widget::declare
|
||
|
|
# Declares new options to BWidget class.
|
||
|
|
# ----------------------------------------------------------------------------
|
||
|
|
proc Widget::declare { class optlist } {
|
||
|
|
variable _optiontype
|
||
|
|
|
||
|
|
namespace eval $class {}
|
||
|
|
upvar 0 ${class}::opt classopt
|
||
|
|
upvar 0 ${class}::optionExports exports
|
||
|
|
upvar 0 ${class}::optionClass optionClass
|
||
|
|
|
||
|
|
foreach optdesc $optlist {
|
||
|
|
set option [lindex $optdesc 0]
|
||
|
|
set optdesc [lrange $optdesc 1 end]
|
||
|
|
set type [lindex $optdesc 0]
|
||
|
|
|
||
|
|
if { ![info exists _optiontype($type)] } {
|
||
|
|
# invalid resource type
|
||
|
|
return -code error "invalid option type \"$type\""
|
||
|
|
}
|
||
|
|
|
||
|
|
if { [string equal $type "Synonym"] } {
|
||
|
|
# test existence of synonym option
|
||
|
|
set syn [lindex $optdesc 1]
|
||
|
|
if { ![info exists classopt($syn)] } {
|
||
|
|
return -code error "unknow option \"$syn\" for Synonym \"$option\""
|
||
|
|
}
|
||
|
|
set classopt($option) [list Synonym $syn]
|
||
|
|
continue
|
||
|
|
}
|
||
|
|
|
||
|
|
# all other resource may have default value, readonly flag and
|
||
|
|
# optional arg depending on type
|
||
|
|
set value [lindex $optdesc 1]
|
||
|
|
set ro [lindex $optdesc 2]
|
||
|
|
set arg [lindex $optdesc 3]
|
||
|
|
|
||
|
|
if { [string equal $type "BwResource"] } {
|
||
|
|
# We don't keep BwResource. We simplify to type of sub BWidget
|
||
|
|
set subclass [lindex $arg 0]
|
||
|
|
set realopt [lindex $arg 1]
|
||
|
|
if { ![string length $realopt] } {
|
||
|
|
set realopt $option
|
||
|
|
}
|
||
|
|
|
||
|
|
upvar 0 ${subclass}::opt subclassopt
|
||
|
|
if { ![info exists subclassopt($realopt)] } {
|
||
|
|
return -code error "unknow option \"$realopt\""
|
||
|
|
}
|
||
|
|
set suboptdesc $subclassopt($realopt)
|
||
|
|
if { $value == "" } {
|
||
|
|
# We initialize default value
|
||
|
|
set value [lindex $suboptdesc 1]
|
||
|
|
}
|
||
|
|
set type [lindex $suboptdesc 0]
|
||
|
|
set ro [lindex $suboptdesc 2]
|
||
|
|
set arg [lindex $suboptdesc 3]
|
||
|
|
set optionDbName ".[lindex [_configure_option $option ""] 0]"
|
||
|
|
option add *${class}${optionDbName} $value widgetDefault
|
||
|
|
set exports($option) $optionDbName
|
||
|
|
set classopt($option) [list $type $value $ro $arg]
|
||
|
|
continue
|
||
|
|
}
|
||
|
|
|
||
|
|
# retreive default value for TkResource
|
||
|
|
if { [string equal $type "TkResource"] } {
|
||
|
|
set tkwidget [lindex $arg 0]
|
||
|
|
set foo [$tkwidget ".ericFoo##"]
|
||
|
|
set realopt [lindex $arg 1]
|
||
|
|
if { ![string length $realopt] } {
|
||
|
|
set realopt $option
|
||
|
|
}
|
||
|
|
set tkoptions [_get_tkwidget_options $tkwidget]
|
||
|
|
if { ![string length $value] } {
|
||
|
|
# We initialize default value
|
||
|
|
set ind [lsearch $tkoptions [list $realopt *]]
|
||
|
|
set value [lindex [lindex $tkoptions $ind] end]
|
||
|
|
}
|
||
|
|
set optionDbName ".[lindex [_configure_option $option ""] 0]"
|
||
|
|
option add *${class}${optionDbName} $value widgetDefault
|
||
|
|
set exports($option) $optionDbName
|
||
|
|
set classopt($option) [list TkResource $value $ro \
|
||
|
|
[list $tkwidget $realopt]]
|
||
|
|
set optionClass($option) [lindex [$foo configure $realopt] 1]
|
||
|
|
::destroy $foo
|
||
|
|
continue
|
||
|
|
}
|
||
|
|
|
||
|
|
set optionDbName ".[lindex [_configure_option $option ""] 0]"
|
||
|
|
option add *${class}${optionDbName} $value widgetDefault
|
||
|
|
set exports($option) $optionDbName
|
||
|
|
# for any other resource type, we keep original optdesc
|
||
|
|
set classopt($option) [list $type $value $ro $arg]
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
proc Widget::define { class filename args } {
|
||
|
|
# variable ::BWidget::use
|
||
|
|
set use($class) $args
|
||
|
|
set use($class,file) $filename
|
||
|
|
lappend use(classes) $class
|
||
|
|
|
||
|
|
if {[set x [lsearch -exact $args "-classonly"]] > -1} {
|
||
|
|
set args [lreplace $args $x $x]
|
||
|
|
} else {
|
||
|
|
interp alias {} ::${class} {} ${class}::create
|
||
|
|
proc ::${class}::use {} {}
|
||
|
|
|
||
|
|
bind $class <Destroy> [list Widget::destroy %W]
|
||
|
|
}
|
||
|
|
|
||
|
|
foreach class $args { ${class}::use }
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
proc Widget::create { class path {rename 1} } {
|
||
|
|
if {$rename} { rename $path ::$path:cmd }
|
||
|
|
proc ::$path { cmd args } \
|
||
|
|
[subst {return \[eval \[linsert \$args 0 ${class}::\$cmd [list $path]\]\]}]
|
||
|
|
return $path
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
# ----------------------------------------------------------------------------
|
||
|
|
# Command Widget::addmap
|
||
|
|
# ----------------------------------------------------------------------------
|
||
|
|
proc Widget::addmap { class subclass subpath options } {
|
||
|
|
upvar 0 ${class}::opt classopt
|
||
|
|
upvar 0 ${class}::optionExports exports
|
||
|
|
upvar 0 ${class}::optionClass optionClass
|
||
|
|
upvar 0 ${class}::map classmap
|
||
|
|
upvar 0 ${class}::map$subpath submap
|
||
|
|
|
||
|
|
foreach {option realopt} $options {
|
||
|
|
if { ![string length $realopt] } {
|
||
|
|
set realopt $option
|
||
|
|
}
|
||
|
|
set val [lindex $classopt($option) 1]
|
||
|
|
set optDb ".[lindex [_configure_option $realopt ""] 0]"
|
||
|
|
if { ![string equal $subpath ":cmd"] } {
|
||
|
|
set optDb "$subpath$optDb"
|
||
|
|
}
|
||
|
|
option add *${class}${optDb} $val widgetDefault
|
||
|
|
lappend exports($option) $optDb
|
||
|
|
# Store the forward and backward mappings for this
|
||
|
|
# option <-> realoption pair
|
||
|
|
lappend classmap($option) $subpath $subclass $realopt
|
||
|
|
set submap($realopt) $option
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
# ----------------------------------------------------------------------------
|
||
|
|
# Command Widget::syncoptions
|
||
|
|
# ----------------------------------------------------------------------------
|
||
|
|
proc Widget::syncoptions { class subclass subpath options } {
|
||
|
|
upvar 0 ${class}::sync classync
|
||
|
|
|
||
|
|
foreach {option realopt} $options {
|
||
|
|
if { ![string length $realopt] } {
|
||
|
|
set realopt $option
|
||
|
|
}
|
||
|
|
set classync($option) [list $subpath $subclass $realopt]
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
# ----------------------------------------------------------------------------
|
||
|
|
# Command Widget::init
|
||
|
|
# ----------------------------------------------------------------------------
|
||
|
|
proc Widget::init { class path options } {
|
||
|
|
variable _inuse
|
||
|
|
|
||
|
|
upvar 0 ${class}::opt classopt
|
||
|
|
upvar 0 ${class}::$path:opt pathopt
|
||
|
|
upvar 0 ${class}::$path:mod pathmod
|
||
|
|
upvar 0 ${class}::map classmap
|
||
|
|
upvar 0 ${class}::$path:init pathinit
|
||
|
|
|
||
|
|
if { [info exists pathopt] } {
|
||
|
|
unset pathopt
|
||
|
|
}
|
||
|
|
if { [info exists pathmod] } {
|
||
|
|
unset pathmod
|
||
|
|
}
|
||
|
|
# We prefer to use the actual widget for option db queries, but if it
|
||
|
|
# doesn't exist yet, do the next best thing: create a widget of the
|
||
|
|
# same class and use that.
|
||
|
|
set fpath $path
|
||
|
|
set rdbclass [string map [list :: ""] $class]
|
||
|
|
if { ![winfo exists $path] } {
|
||
|
|
set fpath ".#BWidget.#Class#$class"
|
||
|
|
# encapsulation frame to not pollute '.' childspace
|
||
|
|
if {![winfo exists ".#BWidget"]} { frame ".#BWidget" }
|
||
|
|
if { ![winfo exists $fpath] } {
|
||
|
|
frame $fpath -class $rdbclass
|
||
|
|
}
|
||
|
|
}
|
||
|
|
foreach {option optdesc} [array get classopt] {
|
||
|
|
set pathmod($option) 0
|
||
|
|
if { [info exists classmap($option)] } {
|
||
|
|
continue
|
||
|
|
}
|
||
|
|
set type [lindex $optdesc 0]
|
||
|
|
if { [string equal $type "Synonym"] } {
|
||
|
|
continue
|
||
|
|
}
|
||
|
|
if { [string equal $type "TkResource"] } {
|
||
|
|
set alt [lindex [lindex $optdesc 3] 1]
|
||
|
|
} else {
|
||
|
|
set alt ""
|
||
|
|
}
|
||
|
|
set optdb [lindex [_configure_option $option $alt] 0]
|
||
|
|
set def [option get $fpath $optdb $rdbclass]
|
||
|
|
if { [string length $def] } {
|
||
|
|
set pathopt($option) $def
|
||
|
|
} else {
|
||
|
|
set pathopt($option) [lindex $optdesc 1]
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
if {![info exists _inuse($class)]} { set _inuse($class) 0 }
|
||
|
|
incr _inuse($class)
|
||
|
|
|
||
|
|
set Widget::_class($path) $class
|
||
|
|
foreach {option value} $options {
|
||
|
|
if { ![info exists classopt($option)] } {
|
||
|
|
unset pathopt
|
||
|
|
unset pathmod
|
||
|
|
return -code error "unknown option \"$option\""
|
||
|
|
}
|
||
|
|
set optdesc $classopt($option)
|
||
|
|
set type [lindex $optdesc 0]
|
||
|
|
if { [string equal $type "Synonym"] } {
|
||
|
|
set option [lindex $optdesc 1]
|
||
|
|
set optdesc $classopt($option)
|
||
|
|
set type [lindex $optdesc 0]
|
||
|
|
}
|
||
|
|
set pathopt($option) [$Widget::_optiontype($type) $option $value [lindex $optdesc 3]]
|
||
|
|
set pathinit($option) $pathopt($option)
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
# Bastien Chevreux (bach@mwgdna.com)
|
||
|
|
#
|
||
|
|
# copyinit performs basically the same job as init, but it uses a
|
||
|
|
# existing template to initialize its values. So, first a perferct copy
|
||
|
|
# from the template is made just to be altered by any existing options
|
||
|
|
# afterwards.
|
||
|
|
# But this still saves time as the first initialization parsing block is
|
||
|
|
# skipped.
|
||
|
|
# As additional bonus, items that differ in just a few options can be
|
||
|
|
# initialized faster by leaving out the options that are equal.
|
||
|
|
|
||
|
|
# This function is currently used only by ListBox::multipleinsert, but other
|
||
|
|
# calls should follow :)
|
||
|
|
|
||
|
|
# ----------------------------------------------------------------------------
|
||
|
|
# Command Widget::copyinit
|
||
|
|
# ----------------------------------------------------------------------------
|
||
|
|
proc Widget::copyinit { class templatepath path options } {
|
||
|
|
upvar 0 ${class}::opt classopt \
|
||
|
|
${class}::$path:opt pathopt \
|
||
|
|
${class}::$path:mod pathmod \
|
||
|
|
${class}::$path:init pathinit \
|
||
|
|
${class}::$templatepath:opt templatepathopt \
|
||
|
|
${class}::$templatepath:mod templatepathmod \
|
||
|
|
${class}::$templatepath:init templatepathinit
|
||
|
|
|
||
|
|
if { [info exists pathopt] } {
|
||
|
|
unset pathopt
|
||
|
|
}
|
||
|
|
if { [info exists pathmod] } {
|
||
|
|
unset pathmod
|
||
|
|
}
|
||
|
|
|
||
|
|
# We use the template widget for option db copying, but it has to exist!
|
||
|
|
array set pathmod [array get templatepathmod]
|
||
|
|
array set pathopt [array get templatepathopt]
|
||
|
|
array set pathinit [array get templatepathinit]
|
||
|
|
|
||
|
|
set Widget::_class($path) $class
|
||
|
|
foreach {option value} $options {
|
||
|
|
if { ![info exists classopt($option)] } {
|
||
|
|
unset pathopt
|
||
|
|
unset pathmod
|
||
|
|
return -code error "unknown option \"$option\""
|
||
|
|
}
|
||
|
|
set optdesc $classopt($option)
|
||
|
|
set type [lindex $optdesc 0]
|
||
|
|
if { [string equal $type "Synonym"] } {
|
||
|
|
set option [lindex $optdesc 1]
|
||
|
|
set optdesc $classopt($option)
|
||
|
|
set type [lindex $optdesc 0]
|
||
|
|
}
|
||
|
|
set pathopt($option) [$Widget::_optiontype($type) $option $value [lindex $optdesc 3]]
|
||
|
|
set pathinit($option) $pathopt($option)
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
# Widget::parseArgs --
|
||
|
|
#
|
||
|
|
# Given a widget class and a command-line spec, cannonize and validate
|
||
|
|
# the given options, and return a keyed list consisting of the
|
||
|
|
# component widget and its masked portion of the command-line spec, and
|
||
|
|
# one extra entry consisting of the portion corresponding to the
|
||
|
|
# megawidget itself.
|
||
|
|
#
|
||
|
|
# Arguments:
|
||
|
|
# class widget class to parse for.
|
||
|
|
# options command-line spec
|
||
|
|
#
|
||
|
|
# Results:
|
||
|
|
# result keyed list of portions of the megawidget and that segment of
|
||
|
|
# the command line in which that portion is interested.
|
||
|
|
|
||
|
|
proc Widget::parseArgs {class options} {
|
||
|
|
upvar 0 ${class}::opt classopt
|
||
|
|
upvar 0 ${class}::map classmap
|
||
|
|
|
||
|
|
foreach {option val} $options {
|
||
|
|
if { ![info exists classopt($option)] } {
|
||
|
|
error "unknown option \"$option\""
|
||
|
|
}
|
||
|
|
set optdesc $classopt($option)
|
||
|
|
set type [lindex $optdesc 0]
|
||
|
|
if { [string equal $type "Synonym"] } {
|
||
|
|
set option [lindex $optdesc 1]
|
||
|
|
set optdesc $classopt($option)
|
||
|
|
set type [lindex $optdesc 0]
|
||
|
|
}
|
||
|
|
if { [string equal $type "TkResource"] } {
|
||
|
|
# Make sure that the widget used for this TkResource exists
|
||
|
|
Widget::_get_tkwidget_options [lindex [lindex $optdesc 3] 0]
|
||
|
|
}
|
||
|
|
set val [$Widget::_optiontype($type) $option $val [lindex $optdesc 3]]
|
||
|
|
|
||
|
|
if { [info exists classmap($option)] } {
|
||
|
|
foreach {subpath subclass realopt} $classmap($option) {
|
||
|
|
lappend maps($subpath) $realopt $val
|
||
|
|
}
|
||
|
|
} else {
|
||
|
|
lappend maps($class) $option $val
|
||
|
|
}
|
||
|
|
}
|
||
|
|
return [array get maps]
|
||
|
|
}
|
||
|
|
|
||
|
|
# Widget::initFromODB --
|
||
|
|
#
|
||
|
|
# Initialize a megawidgets options with information from the option
|
||
|
|
# database and from the command-line arguments given.
|
||
|
|
#
|
||
|
|
# Arguments:
|
||
|
|
# class class of the widget.
|
||
|
|
# path path of the widget -- should already exist.
|
||
|
|
# options command-line arguments.
|
||
|
|
#
|
||
|
|
# Results:
|
||
|
|
# None.
|
||
|
|
|
||
|
|
proc Widget::initFromODB {class path options} {
|
||
|
|
variable _inuse
|
||
|
|
variable _class
|
||
|
|
|
||
|
|
upvar 0 ${class}::$path:opt pathopt
|
||
|
|
upvar 0 ${class}::$path:mod pathmod
|
||
|
|
upvar 0 ${class}::map classmap
|
||
|
|
|
||
|
|
if { [info exists pathopt] } {
|
||
|
|
unset pathopt
|
||
|
|
}
|
||
|
|
if { [info exists pathmod] } {
|
||
|
|
unset pathmod
|
||
|
|
}
|
||
|
|
# We prefer to use the actual widget for option db queries, but if it
|
||
|
|
# doesn't exist yet, do the next best thing: create a widget of the
|
||
|
|
# same class and use that.
|
||
|
|
set fpath [_get_window $class $path]
|
||
|
|
set rdbclass [string map [list :: ""] $class]
|
||
|
|
if { ![winfo exists $path] } {
|
||
|
|
set fpath ".#BWidget.#Class#$class"
|
||
|
|
# encapsulation frame to not pollute '.' childspace
|
||
|
|
if {![winfo exists ".#BWidget"]} { frame ".#BWidget" }
|
||
|
|
if { ![winfo exists $fpath] } {
|
||
|
|
frame $fpath -class $rdbclass
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
foreach {option optdesc} [array get ${class}::opt] {
|
||
|
|
set pathmod($option) 0
|
||
|
|
if { [info exists classmap($option)] } {
|
||
|
|
continue
|
||
|
|
}
|
||
|
|
set type [lindex $optdesc 0]
|
||
|
|
if { [string equal $type "Synonym"] } {
|
||
|
|
continue
|
||
|
|
}
|
||
|
|
if { [string equal $type "TkResource"] } {
|
||
|
|
set alt [lindex [lindex $optdesc 3] 1]
|
||
|
|
} else {
|
||
|
|
set alt ""
|
||
|
|
}
|
||
|
|
set optdb [lindex [_configure_option $option $alt] 0]
|
||
|
|
set def [option get $fpath $optdb $rdbclass]
|
||
|
|
if { [string length $def] } {
|
||
|
|
set pathopt($option) $def
|
||
|
|
} else {
|
||
|
|
set pathopt($option) [lindex $optdesc 1]
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
if {![info exists _inuse($class)]} { set _inuse($class) 0 }
|
||
|
|
incr _inuse($class)
|
||
|
|
|
||
|
|
set _class($path) $class
|
||
|
|
array set pathopt $options
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
# ----------------------------------------------------------------------------
|
||
|
|
# Command Widget::destroy
|
||
|
|
# ----------------------------------------------------------------------------
|
||
|
|
proc Widget::destroy { path } {
|
||
|
|
variable _class
|
||
|
|
variable _inuse
|
||
|
|
|
||
|
|
if {![info exists _class($path)]} { return }
|
||
|
|
|
||
|
|
set class $_class($path)
|
||
|
|
upvar 0 ${class}::$path:opt pathopt
|
||
|
|
upvar 0 ${class}::$path:mod pathmod
|
||
|
|
upvar 0 ${class}::$path:init pathinit
|
||
|
|
|
||
|
|
if {[info exists _inuse($class)]} { incr _inuse($class) -1 }
|
||
|
|
|
||
|
|
if {[info exists pathopt]} {
|
||
|
|
unset pathopt
|
||
|
|
}
|
||
|
|
if {[info exists pathmod]} {
|
||
|
|
unset pathmod
|
||
|
|
}
|
||
|
|
if {[info exists pathinit]} {
|
||
|
|
unset pathinit
|
||
|
|
}
|
||
|
|
|
||
|
|
if {![string equal [info commands $path] ""]} { rename $path "" }
|
||
|
|
|
||
|
|
## Unset any variables used in this widget.
|
||
|
|
foreach var [info vars ::${class}::$path:*] { unset $var }
|
||
|
|
|
||
|
|
unset _class($path)
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
# ----------------------------------------------------------------------------
|
||
|
|
# Command Widget::configure
|
||
|
|
# ----------------------------------------------------------------------------
|
||
|
|
proc Widget::configure { path options } {
|
||
|
|
set len [llength $options]
|
||
|
|
if { $len <= 1 } {
|
||
|
|
return [_get_configure $path $options]
|
||
|
|
} elseif { $len % 2 == 1 } {
|
||
|
|
return -code error "incorrect number of arguments"
|
||
|
|
}
|
||
|
|
|
||
|
|
variable _class
|
||
|
|
variable _optiontype
|
||
|
|
|
||
|
|
set class $_class($path)
|
||
|
|
upvar 0 ${class}::opt classopt
|
||
|
|
upvar 0 ${class}::map classmap
|
||
|
|
upvar 0 ${class}::$path:opt pathopt
|
||
|
|
upvar 0 ${class}::$path:mod pathmod
|
||
|
|
|
||
|
|
set window [_get_window $class $path]
|
||
|
|
foreach {option value} $options {
|
||
|
|
if { ![info exists classopt($option)] } {
|
||
|
|
return -code error "unknown option \"$option\""
|
||
|
|
}
|
||
|
|
set optdesc $classopt($option)
|
||
|
|
set type [lindex $optdesc 0]
|
||
|
|
if { [string equal $type "Synonym"] } {
|
||
|
|
set option [lindex $optdesc 1]
|
||
|
|
set optdesc $classopt($option)
|
||
|
|
set type [lindex $optdesc 0]
|
||
|
|
}
|
||
|
|
if { ![lindex $optdesc 2] } {
|
||
|
|
set newval [$_optiontype($type) $option $value [lindex $optdesc 3]]
|
||
|
|
if { [info exists classmap($option)] } {
|
||
|
|
set window [_get_window $class $window]
|
||
|
|
foreach {subpath subclass realopt} $classmap($option) {
|
||
|
|
if { [string length $subclass] } {
|
||
|
|
set curval [${subclass}::cget $window$subpath $realopt]
|
||
|
|
${subclass}::configure $window$subpath $realopt $newval
|
||
|
|
} else {
|
||
|
|
set curval [$window$subpath cget $realopt]
|
||
|
|
$window$subpath configure $realopt $newval
|
||
|
|
}
|
||
|
|
}
|
||
|
|
} else {
|
||
|
|
set curval $pathopt($option)
|
||
|
|
set pathopt($option) $newval
|
||
|
|
}
|
||
|
|
set pathmod($option) [expr {![string equal $newval $curval]}]
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
return {}
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
# ----------------------------------------------------------------------------
|
||
|
|
# Command Widget::cget
|
||
|
|
# ----------------------------------------------------------------------------
|
||
|
|
proc Widget::cget { path option } {
|
||
|
|
if { ![info exists ::Widget::_class($path)] } {
|
||
|
|
return -code error "unknown widget $path"
|
||
|
|
}
|
||
|
|
|
||
|
|
set class $::Widget::_class($path)
|
||
|
|
if { ![info exists ${class}::opt($option)] } {
|
||
|
|
return -code error "unknown option \"$option\""
|
||
|
|
}
|
||
|
|
|
||
|
|
set optdesc [set ${class}::opt($option)]
|
||
|
|
set type [lindex $optdesc 0]
|
||
|
|
if {[string equal $type "Synonym"]} {
|
||
|
|
set option [lindex $optdesc 1]
|
||
|
|
}
|
||
|
|
|
||
|
|
if { [info exists ${class}::map($option)] } {
|
||
|
|
foreach {subpath subclass realopt} [set ${class}::map($option)] {break}
|
||
|
|
set path "[_get_window $class $path]$subpath"
|
||
|
|
return [$path cget $realopt]
|
||
|
|
}
|
||
|
|
upvar 0 ${class}::$path:opt pathopt
|
||
|
|
set pathopt($option)
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
# ----------------------------------------------------------------------------
|
||
|
|
# Command Widget::subcget
|
||
|
|
# ----------------------------------------------------------------------------
|
||
|
|
proc Widget::subcget { path subwidget } {
|
||
|
|
set class $::Widget::_class($path)
|
||
|
|
upvar 0 ${class}::$path:opt pathopt
|
||
|
|
upvar 0 ${class}::map$subwidget submap
|
||
|
|
upvar 0 ${class}::$path:init pathinit
|
||
|
|
|
||
|
|
set result {}
|
||
|
|
foreach realopt [array names submap] {
|
||
|
|
if { [info exists pathinit($submap($realopt))] } {
|
||
|
|
lappend result $realopt $pathopt($submap($realopt))
|
||
|
|
}
|
||
|
|
}
|
||
|
|
return $result
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
# ----------------------------------------------------------------------------
|
||
|
|
# Command Widget::hasChanged
|
||
|
|
# ----------------------------------------------------------------------------
|
||
|
|
proc Widget::hasChanged { path option pvalue } {
|
||
|
|
upvar $pvalue value
|
||
|
|
set class $::Widget::_class($path)
|
||
|
|
upvar 0 ${class}::$path:mod pathmod
|
||
|
|
|
||
|
|
set value [Widget::cget $path $option]
|
||
|
|
set result $pathmod($option)
|
||
|
|
set pathmod($option) 0
|
||
|
|
|
||
|
|
return $result
|
||
|
|
}
|
||
|
|
|
||
|
|
proc Widget::hasChangedX { path option args } {
|
||
|
|
set class $::Widget::_class($path)
|
||
|
|
upvar 0 ${class}::$path:mod pathmod
|
||
|
|
|
||
|
|
set result $pathmod($option)
|
||
|
|
set pathmod($option) 0
|
||
|
|
foreach option $args {
|
||
|
|
lappend result $pathmod($option)
|
||
|
|
set pathmod($option) 0
|
||
|
|
}
|
||
|
|
|
||
|
|
set result
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
# ----------------------------------------------------------------------------
|
||
|
|
# Command Widget::setoption
|
||
|
|
# ----------------------------------------------------------------------------
|
||
|
|
proc Widget::setoption { path option value } {
|
||
|
|
# variable _class
|
||
|
|
|
||
|
|
# set class $_class($path)
|
||
|
|
# upvar 0 ${class}::$path:opt pathopt
|
||
|
|
|
||
|
|
# set pathopt($option) $value
|
||
|
|
Widget::configure $path [list $option $value]
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
# ----------------------------------------------------------------------------
|
||
|
|
# Command Widget::getoption
|
||
|
|
# ----------------------------------------------------------------------------
|
||
|
|
proc Widget::getoption { path option } {
|
||
|
|
# set class $::Widget::_class($path)
|
||
|
|
# upvar 0 ${class}::$path:opt pathopt
|
||
|
|
|
||
|
|
# return $pathopt($option)
|
||
|
|
return [Widget::cget $path $option]
|
||
|
|
}
|
||
|
|
|
||
|
|
# Widget::getMegawidgetOption --
|
||
|
|
#
|
||
|
|
# Bypass the superfluous checks in cget and just directly peer at the
|
||
|
|
# widget's data space. This is much more fragile than cget, so it
|
||
|
|
# should only be used with great care, in places where speed is critical.
|
||
|
|
#
|
||
|
|
# Arguments:
|
||
|
|
# path widget to lookup options for.
|
||
|
|
# option option to retrieve.
|
||
|
|
#
|
||
|
|
# Results:
|
||
|
|
# value option value.
|
||
|
|
|
||
|
|
proc Widget::getMegawidgetOption {path option} {
|
||
|
|
set class $::Widget::_class($path)
|
||
|
|
upvar 0 ${class}::${path}:opt pathopt
|
||
|
|
set pathopt($option)
|
||
|
|
}
|
||
|
|
|
||
|
|
# Widget::setMegawidgetOption --
|
||
|
|
#
|
||
|
|
# Bypass the superfluous checks in cget and just directly poke at the
|
||
|
|
# widget's data space. This is much more fragile than configure, so it
|
||
|
|
# should only be used with great care, in places where speed is critical.
|
||
|
|
#
|
||
|
|
# Arguments:
|
||
|
|
# path widget to lookup options for.
|
||
|
|
# option option to retrieve.
|
||
|
|
# value option value.
|
||
|
|
#
|
||
|
|
# Results:
|
||
|
|
# value option value.
|
||
|
|
|
||
|
|
proc Widget::setMegawidgetOption {path option value} {
|
||
|
|
set class $::Widget::_class($path)
|
||
|
|
upvar 0 ${class}::${path}:opt pathopt
|
||
|
|
set pathopt($option) $value
|
||
|
|
}
|
||
|
|
|
||
|
|
# ----------------------------------------------------------------------------
|
||
|
|
# Command Widget::_get_window
|
||
|
|
# returns the window corresponding to widget path
|
||
|
|
# ----------------------------------------------------------------------------
|
||
|
|
proc Widget::_get_window { class path } {
|
||
|
|
set idx [string last "#" $path]
|
||
|
|
if { $idx != -1 && [string equal [string range $path [expr {$idx+1}] end] $class] } {
|
||
|
|
return [string range $path 0 [expr {$idx-1}]]
|
||
|
|
} else {
|
||
|
|
return $path
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
# ----------------------------------------------------------------------------
|
||
|
|
# Command Widget::_get_configure
|
||
|
|
# returns the configuration list of options
|
||
|
|
# (as tk widget do - [$w configure ?option?])
|
||
|
|
# ----------------------------------------------------------------------------
|
||
|
|
proc Widget::_get_configure { path options } {
|
||
|
|
variable _class
|
||
|
|
|
||
|
|
set class $_class($path)
|
||
|
|
upvar 0 ${class}::opt classopt
|
||
|
|
upvar 0 ${class}::map classmap
|
||
|
|
upvar 0 ${class}::$path:opt pathopt
|
||
|
|
upvar 0 ${class}::$path:mod pathmod
|
||
|
|
|
||
|
|
set len [llength $options]
|
||
|
|
if { !$len } {
|
||
|
|
set result {}
|
||
|
|
foreach option [lsort [array names classopt]] {
|
||
|
|
set optdesc $classopt($option)
|
||
|
|
set type [lindex $optdesc 0]
|
||
|
|
if { [string equal $type "Synonym"] } {
|
||
|
|
set syn $option
|
||
|
|
set option [lindex $optdesc 1]
|
||
|
|
set optdesc $classopt($option)
|
||
|
|
set type [lindex $optdesc 0]
|
||
|
|
} else {
|
||
|
|
set syn ""
|
||
|
|
}
|
||
|
|
if { [string equal $type "TkResource"] } {
|
||
|
|
set alt [lindex [lindex $optdesc 3] 1]
|
||
|
|
} else {
|
||
|
|
set alt ""
|
||
|
|
}
|
||
|
|
set res [_configure_option $option $alt]
|
||
|
|
if { $syn == "" } {
|
||
|
|
lappend result [concat $option $res [list [lindex $optdesc 1]] [list [cget $path $option]]]
|
||
|
|
} else {
|
||
|
|
lappend result [list $syn [lindex $res 0]]
|
||
|
|
}
|
||
|
|
}
|
||
|
|
return $result
|
||
|
|
} elseif { $len == 1 } {
|
||
|
|
set option [lindex $options 0]
|
||
|
|
if { ![info exists classopt($option)] } {
|
||
|
|
return -code error "unknown option \"$option\""
|
||
|
|
}
|
||
|
|
set optdesc $classopt($option)
|
||
|
|
set type [lindex $optdesc 0]
|
||
|
|
if { [string equal $type "Synonym"] } {
|
||
|
|
set option [lindex $optdesc 1]
|
||
|
|
set optdesc $classopt($option)
|
||
|
|
set type [lindex $optdesc 0]
|
||
|
|
}
|
||
|
|
if { [string equal $type "TkResource"] } {
|
||
|
|
set alt [lindex [lindex $optdesc 3] 1]
|
||
|
|
} else {
|
||
|
|
set alt ""
|
||
|
|
}
|
||
|
|
set res [_configure_option $option $alt]
|
||
|
|
return [concat $option $res [list [lindex $optdesc 1]] [list [cget $path $option]]]
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
# ----------------------------------------------------------------------------
|
||
|
|
# Command Widget::_configure_option
|
||
|
|
# ----------------------------------------------------------------------------
|
||
|
|
proc Widget::_configure_option { option altopt } {
|
||
|
|
variable _optiondb
|
||
|
|
variable _optionclass
|
||
|
|
|
||
|
|
if { [info exists _optiondb($option)] } {
|
||
|
|
set optdb $_optiondb($option)
|
||
|
|
} else {
|
||
|
|
set optdb [string range $option 1 end]
|
||
|
|
}
|
||
|
|
if { [info exists _optionclass($option)] } {
|
||
|
|
set optclass $_optionclass($option)
|
||
|
|
} elseif { [string length $altopt] } {
|
||
|
|
if { [info exists _optionclass($altopt)] } {
|
||
|
|
set optclass $_optionclass($altopt)
|
||
|
|
} else {
|
||
|
|
set optclass [string range $altopt 1 end]
|
||
|
|
}
|
||
|
|
} else {
|
||
|
|
set optclass [string range $option 1 end]
|
||
|
|
}
|
||
|
|
return [list $optdb $optclass]
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
# ----------------------------------------------------------------------------
|
||
|
|
# Command Widget::_get_tkwidget_options
|
||
|
|
# ----------------------------------------------------------------------------
|
||
|
|
proc Widget::_get_tkwidget_options { tkwidget } {
|
||
|
|
variable _tk_widget
|
||
|
|
variable _optiondb
|
||
|
|
variable _optionclass
|
||
|
|
|
||
|
|
set widget ".#BWidget.#$tkwidget"
|
||
|
|
# encapsulation frame to not pollute '.' childspace
|
||
|
|
if {![winfo exists ".#BWidget"]} { frame ".#BWidget" }
|
||
|
|
if { ![winfo exists $widget] || ![info exists _tk_widget($tkwidget)] } {
|
||
|
|
set widget [$tkwidget $widget]
|
||
|
|
# JDC: Withdraw toplevels, otherwise visible
|
||
|
|
if {[string equal $tkwidget "toplevel"]} {
|
||
|
|
wm withdraw $widget
|
||
|
|
}
|
||
|
|
set config [$widget configure]
|
||
|
|
foreach optlist $config {
|
||
|
|
set opt [lindex $optlist 0]
|
||
|
|
if { [llength $optlist] == 2 } {
|
||
|
|
set refsyn [lindex $optlist 1]
|
||
|
|
# search for class
|
||
|
|
set idx [lsearch $config [list * $refsyn *]]
|
||
|
|
if { $idx == -1 } {
|
||
|
|
if { [string index $refsyn 0] == "-" } {
|
||
|
|
# search for option (tk8.1b1 bug)
|
||
|
|
set idx [lsearch $config [list $refsyn * *]]
|
||
|
|
} else {
|
||
|
|
# last resort
|
||
|
|
set idx [lsearch $config [list -[string tolower $refsyn] * *]]
|
||
|
|
}
|
||
|
|
if { $idx == -1 } {
|
||
|
|
# fed up with "can't read classopt()"
|
||
|
|
return -code error "can't find option of synonym $opt"
|
||
|
|
}
|
||
|
|
}
|
||
|
|
set syn [lindex [lindex $config $idx] 0]
|
||
|
|
# JDC: used 4 (was 3) to get def from optiondb
|
||
|
|
set def [lindex [lindex $config $idx] 4]
|
||
|
|
lappend _tk_widget($tkwidget) [list $opt $syn $def]
|
||
|
|
} else {
|
||
|
|
# JDC: used 4 (was 3) to get def from optiondb
|
||
|
|
set def [lindex $optlist 4]
|
||
|
|
lappend _tk_widget($tkwidget) [list $opt $def]
|
||
|
|
set _optiondb($opt) [lindex $optlist 1]
|
||
|
|
set _optionclass($opt) [lindex $optlist 2]
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
return $_tk_widget($tkwidget)
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
# ----------------------------------------------------------------------------
|
||
|
|
# Command Widget::_test_tkresource
|
||
|
|
# ----------------------------------------------------------------------------
|
||
|
|
proc Widget::_test_tkresource { option value arg } {
|
||
|
|
# set tkwidget [lindex $arg 0]
|
||
|
|
# set realopt [lindex $arg 1]
|
||
|
|
foreach {tkwidget realopt} $arg break
|
||
|
|
set path ".#BWidget.#$tkwidget"
|
||
|
|
set old [$path cget $realopt]
|
||
|
|
$path configure $realopt $value
|
||
|
|
set res [$path cget $realopt]
|
||
|
|
$path configure $realopt $old
|
||
|
|
|
||
|
|
return $res
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
# ----------------------------------------------------------------------------
|
||
|
|
# Command Widget::_test_bwresource
|
||
|
|
# ----------------------------------------------------------------------------
|
||
|
|
proc Widget::_test_bwresource { option value arg } {
|
||
|
|
return -code error "bad option type BwResource in widget"
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
# ----------------------------------------------------------------------------
|
||
|
|
# Command Widget::_test_synonym
|
||
|
|
# ----------------------------------------------------------------------------
|
||
|
|
proc Widget::_test_synonym { option value arg } {
|
||
|
|
return -code error "bad option type Synonym in widget"
|
||
|
|
}
|
||
|
|
|
||
|
|
# ----------------------------------------------------------------------------
|
||
|
|
# Command Widget::_test_color
|
||
|
|
# ----------------------------------------------------------------------------
|
||
|
|
proc Widget::_test_color { option value arg } {
|
||
|
|
if {[catch {winfo rgb . $value} color]} {
|
||
|
|
return -code error "bad $option value \"$value\": must be a colorname \
|
||
|
|
or #RRGGBB triplet"
|
||
|
|
}
|
||
|
|
|
||
|
|
return $value
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
# ----------------------------------------------------------------------------
|
||
|
|
# Command Widget::_test_string
|
||
|
|
# ----------------------------------------------------------------------------
|
||
|
|
proc Widget::_test_string { option value arg } {
|
||
|
|
set value
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
# ----------------------------------------------------------------------------
|
||
|
|
# Command Widget::_test_flag
|
||
|
|
# ----------------------------------------------------------------------------
|
||
|
|
proc Widget::_test_flag { option value arg } {
|
||
|
|
set len [string length $value]
|
||
|
|
set res ""
|
||
|
|
for {set i 0} {$i < $len} {incr i} {
|
||
|
|
set c [string index $value $i]
|
||
|
|
if { [string first $c $arg] == -1 } {
|
||
|
|
return -code error "bad [string range $option 1 end] value \"$value\": characters must be in \"$arg\""
|
||
|
|
}
|
||
|
|
if { [string first $c $res] == -1 } {
|
||
|
|
append res $c
|
||
|
|
}
|
||
|
|
}
|
||
|
|
return $res
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
# -----------------------------------------------------------------------------
|
||
|
|
# Command Widget::_test_enum
|
||
|
|
# -----------------------------------------------------------------------------
|
||
|
|
proc Widget::_test_enum { option value arg } {
|
||
|
|
if { [lsearch $arg $value] == -1 } {
|
||
|
|
set last [lindex $arg end]
|
||
|
|
set sub [lreplace $arg end end]
|
||
|
|
if { [llength $sub] } {
|
||
|
|
set str "[join $sub ", "] or $last"
|
||
|
|
} else {
|
||
|
|
set str $last
|
||
|
|
}
|
||
|
|
return -code error "bad [string range $option 1 end] value \"$value\": must be $str"
|
||
|
|
}
|
||
|
|
return $value
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
# -----------------------------------------------------------------------------
|
||
|
|
# Command Widget::_test_int
|
||
|
|
# -----------------------------------------------------------------------------
|
||
|
|
proc Widget::_test_int { option value arg } {
|
||
|
|
if { ![string is int -strict $value] || \
|
||
|
|
([string length $arg] && \
|
||
|
|
![expr [string map [list %d $value] $arg]]) } {
|
||
|
|
return -code error "bad $option value\
|
||
|
|
\"$value\": must be integer ($arg)"
|
||
|
|
}
|
||
|
|
return $value
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
# -----------------------------------------------------------------------------
|
||
|
|
# Command Widget::_test_boolean
|
||
|
|
# -----------------------------------------------------------------------------
|
||
|
|
proc Widget::_test_boolean { option value arg } {
|
||
|
|
if { ![string is boolean -strict $value] } {
|
||
|
|
return -code error "bad $option value \"$value\": must be boolean"
|
||
|
|
}
|
||
|
|
|
||
|
|
# Get the canonical form of the boolean value (1 for true, 0 for false)
|
||
|
|
return [string is true $value]
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
# -----------------------------------------------------------------------------
|
||
|
|
# Command Widget::_test_padding
|
||
|
|
# -----------------------------------------------------------------------------
|
||
|
|
proc Widget::_test_padding { option values arg } {
|
||
|
|
set len [llength $values]
|
||
|
|
if {$len < 1 || $len > 2} {
|
||
|
|
return -code error "bad pad value \"$values\":\
|
||
|
|
must be positive screen distance"
|
||
|
|
}
|
||
|
|
|
||
|
|
foreach value $values {
|
||
|
|
if { ![string is int -strict $value] || \
|
||
|
|
([string length $arg] && \
|
||
|
|
![expr [string map [list %d $value] $arg]]) } {
|
||
|
|
return -code error "bad pad value \"$value\":\
|
||
|
|
must be positive screen distance ($arg)"
|
||
|
|
}
|
||
|
|
}
|
||
|
|
return $values
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
# Widget::_get_padding --
|
||
|
|
#
|
||
|
|
# Return the requesting padding value for a padding option.
|
||
|
|
#
|
||
|
|
# Arguments:
|
||
|
|
# path Widget to get the options for.
|
||
|
|
# option The name of the padding option.
|
||
|
|
# index The index of the padding. If the index is empty,
|
||
|
|
# the first padding value is returned.
|
||
|
|
#
|
||
|
|
# Results:
|
||
|
|
# Return a numeric value that can be used for padding.
|
||
|
|
proc Widget::_get_padding { path option {index 0} } {
|
||
|
|
set pad [Widget::cget $path $option]
|
||
|
|
set val [lindex $pad $index]
|
||
|
|
if {$val == ""} { set val [lindex $pad 0] }
|
||
|
|
return $val
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
# -----------------------------------------------------------------------------
|
||
|
|
# Command Widget::focusNext
|
||
|
|
# Same as tk_focusNext, but call Widget::focusOK
|
||
|
|
# -----------------------------------------------------------------------------
|
||
|
|
proc Widget::focusNext { w } {
|
||
|
|
set cur $w
|
||
|
|
while 1 {
|
||
|
|
|
||
|
|
# Descend to just before the first child of the current widget.
|
||
|
|
|
||
|
|
set parent $cur
|
||
|
|
set children [winfo children $cur]
|
||
|
|
set i -1
|
||
|
|
|
||
|
|
# Look for the next sibling that isn't a top-level.
|
||
|
|
|
||
|
|
while 1 {
|
||
|
|
incr i
|
||
|
|
if {$i < [llength $children]} {
|
||
|
|
set cur [lindex $children $i]
|
||
|
|
if {[string equal [winfo toplevel $cur] $cur]} {
|
||
|
|
continue
|
||
|
|
} else {
|
||
|
|
break
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
# No more siblings, so go to the current widget's parent.
|
||
|
|
# If it's a top-level, break out of the loop, otherwise
|
||
|
|
# look for its next sibling.
|
||
|
|
|
||
|
|
set cur $parent
|
||
|
|
if {[string equal [winfo toplevel $cur] $cur]} {
|
||
|
|
break
|
||
|
|
}
|
||
|
|
set parent [winfo parent $parent]
|
||
|
|
set children [winfo children $parent]
|
||
|
|
set i [lsearch -exact $children $cur]
|
||
|
|
}
|
||
|
|
if {[string equal $cur $w] || [focusOK $cur]} {
|
||
|
|
return $cur
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
# -----------------------------------------------------------------------------
|
||
|
|
# Command Widget::focusPrev
|
||
|
|
# Same as tk_focusPrev, except:
|
||
|
|
# + Don't traverse from a child to a direct ancestor
|
||
|
|
# + Call Widget::focusOK instead of tk::focusOK
|
||
|
|
# -----------------------------------------------------------------------------
|
||
|
|
proc Widget::focusPrev { w } {
|
||
|
|
set cur $w
|
||
|
|
set origParent [winfo parent $w]
|
||
|
|
while 1 {
|
||
|
|
|
||
|
|
# Collect information about the current window's position
|
||
|
|
# among its siblings. Also, if the window is a top-level,
|
||
|
|
# then reposition to just after the last child of the window.
|
||
|
|
|
||
|
|
if {[string equal [winfo toplevel $cur] $cur]} {
|
||
|
|
set parent $cur
|
||
|
|
set children [winfo children $cur]
|
||
|
|
set i [llength $children]
|
||
|
|
} else {
|
||
|
|
set parent [winfo parent $cur]
|
||
|
|
set children [winfo children $parent]
|
||
|
|
set i [lsearch -exact $children $cur]
|
||
|
|
}
|
||
|
|
|
||
|
|
# Go to the previous sibling, then descend to its last descendant
|
||
|
|
# (highest in stacking order. While doing this, ignore top-levels
|
||
|
|
# and their descendants. When we run out of descendants, go up
|
||
|
|
# one level to the parent.
|
||
|
|
|
||
|
|
while {$i > 0} {
|
||
|
|
incr i -1
|
||
|
|
set cur [lindex $children $i]
|
||
|
|
if {[string equal [winfo toplevel $cur] $cur]} {
|
||
|
|
continue
|
||
|
|
}
|
||
|
|
set parent $cur
|
||
|
|
set children [winfo children $parent]
|
||
|
|
set i [llength $children]
|
||
|
|
}
|
||
|
|
set cur $parent
|
||
|
|
if {[string equal $cur $w]} {
|
||
|
|
return $cur
|
||
|
|
}
|
||
|
|
# If we are just at the original parent of $w, skip it as a
|
||
|
|
# potential focus accepter. Extra safety in this is to see if
|
||
|
|
# that parent is also a proc (not a C command), which is what
|
||
|
|
# BWidgets makes for any megawidget. Could possibly also check
|
||
|
|
# for '[info commands ::${origParent}:cmd] != ""'. [Bug 765667]
|
||
|
|
if {[string equal $cur $origParent]
|
||
|
|
&& [info procs ::$origParent] != ""} {
|
||
|
|
continue
|
||
|
|
}
|
||
|
|
if {[focusOK $cur]} {
|
||
|
|
return $cur
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
# ----------------------------------------------------------------------------
|
||
|
|
# Command Widget::focusOK
|
||
|
|
# Same as tk_focusOK, but handles -editable option and whole tags list.
|
||
|
|
# ----------------------------------------------------------------------------
|
||
|
|
proc Widget::focusOK { w } {
|
||
|
|
set code [catch {$w cget -takefocus} value]
|
||
|
|
if { $code == 1 } {
|
||
|
|
return 0
|
||
|
|
}
|
||
|
|
if {($code == 0) && ($value != "")} {
|
||
|
|
if {$value == 0} {
|
||
|
|
return 0
|
||
|
|
} elseif {$value == 1} {
|
||
|
|
return [winfo viewable $w]
|
||
|
|
} else {
|
||
|
|
set value [uplevel \#0 $value $w]
|
||
|
|
if {$value != ""} {
|
||
|
|
return $value
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
if {![winfo viewable $w]} {
|
||
|
|
return 0
|
||
|
|
}
|
||
|
|
set code [catch {$w cget -state} value]
|
||
|
|
if {($code == 0) && ($value == "disabled")} {
|
||
|
|
return 0
|
||
|
|
}
|
||
|
|
set code [catch {$w cget -editable} value]
|
||
|
|
if {($code == 0) && ($value == 0)} {
|
||
|
|
return 0
|
||
|
|
}
|
||
|
|
|
||
|
|
set top [winfo toplevel $w]
|
||
|
|
foreach tags [bindtags $w] {
|
||
|
|
if { ![string equal $tags $top] &&
|
||
|
|
![string equal $tags "all"] &&
|
||
|
|
[regexp Key [bind $tags]] } {
|
||
|
|
return 1
|
||
|
|
}
|
||
|
|
}
|
||
|
|
return 0
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
proc Widget::traverseTo { w } {
|
||
|
|
set focus [focus]
|
||
|
|
if {![string equal $focus ""]} {
|
||
|
|
event generate $focus <<TraverseOut>>
|
||
|
|
}
|
||
|
|
focus $w
|
||
|
|
|
||
|
|
event generate $w <<TraverseIn>>
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
# Widget::varForOption --
|
||
|
|
#
|
||
|
|
# Retrieve a fully qualified variable name for the option specified.
|
||
|
|
# If the option is not one for which a variable exists, throw an error
|
||
|
|
# (ie, those options that map directly to widget options).
|
||
|
|
#
|
||
|
|
# Arguments:
|
||
|
|
# path megawidget to get an option var for.
|
||
|
|
# option option to get a var for.
|
||
|
|
#
|
||
|
|
# Results:
|
||
|
|
# varname name of the variable, fully qualified, suitable for tracing.
|
||
|
|
|
||
|
|
proc Widget::varForOption {path option} {
|
||
|
|
variable _class
|
||
|
|
variable _optiontype
|
||
|
|
|
||
|
|
set class $_class($path)
|
||
|
|
upvar 0 ${class}::$path:opt pathopt
|
||
|
|
|
||
|
|
if { ![info exists pathopt($option)] } {
|
||
|
|
error "unable to find variable for option \"$option\""
|
||
|
|
}
|
||
|
|
set varname "::Widget::${class}::$path:opt($option)"
|
||
|
|
return $varname
|
||
|
|
}
|
||
|
|
|
||
|
|
# Widget::getVariable --
|
||
|
|
#
|
||
|
|
# Get a variable from within the namespace of the widget.
|
||
|
|
#
|
||
|
|
# Arguments:
|
||
|
|
# path Megawidget to get the variable for.
|
||
|
|
# varName The variable name to retrieve.
|
||
|
|
# newVarName The variable name to refer to in the calling proc.
|
||
|
|
#
|
||
|
|
# Results:
|
||
|
|
# Creates a reference to newVarName in the calling proc.
|
||
|
|
proc Widget::getVariable { path varName {newVarName ""} } {
|
||
|
|
variable _class
|
||
|
|
set class $_class($path)
|
||
|
|
if {![string length $newVarName]} { set newVarName $varName }
|
||
|
|
uplevel 1 [list upvar \#0 ${class}::$path:$varName $newVarName]
|
||
|
|
}
|
||
|
|
|
||
|
|
# Widget::options --
|
||
|
|
#
|
||
|
|
# Return a key-value list of options for a widget. This can
|
||
|
|
# be used to serialize the options of a widget and pass them
|
||
|
|
# on to a new widget with the same options.
|
||
|
|
#
|
||
|
|
# Arguments:
|
||
|
|
# path Widget to get the options for.
|
||
|
|
# args A list of options. If empty, all options are returned.
|
||
|
|
#
|
||
|
|
# Results:
|
||
|
|
# Returns list of options as: -option value -option value ...
|
||
|
|
proc Widget::options { path args } {
|
||
|
|
if {[llength $args]} {
|
||
|
|
foreach option $args {
|
||
|
|
lappend options [_get_configure $path $option]
|
||
|
|
}
|
||
|
|
} else {
|
||
|
|
set options [_get_configure $path {}]
|
||
|
|
}
|
||
|
|
|
||
|
|
set result [list]
|
||
|
|
foreach list $options {
|
||
|
|
if {[llength $list] < 5} { continue }
|
||
|
|
lappend result [lindex $list 0] [lindex $list end]
|
||
|
|
}
|
||
|
|
return $result
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
# Widget::getOption --
|
||
|
|
#
|
||
|
|
# Given a list of widgets, determine which option value to use.
|
||
|
|
# The widgets are given to the command in order of highest to
|
||
|
|
# lowest. Starting with the lowest widget, whichever one does
|
||
|
|
# not match the default option value is returned as the value.
|
||
|
|
# If all the widgets are default, we return the highest widget's
|
||
|
|
# value.
|
||
|
|
#
|
||
|
|
# Arguments:
|
||
|
|
# option The option to check.
|
||
|
|
# default The default value. If any widget in the list
|
||
|
|
# does not match this default, its value is used.
|
||
|
|
# args A list of widgets.
|
||
|
|
#
|
||
|
|
# Results:
|
||
|
|
# Returns the value of the given option to use.
|
||
|
|
#
|
||
|
|
proc Widget::getOption { option default args } {
|
||
|
|
for {set i [expr [llength $args] -1]} {$i >= 0} {incr i -1} {
|
||
|
|
set widget [lindex $args $i]
|
||
|
|
set value [Widget::cget $widget $option]
|
||
|
|
if {[string equal $value $default]} { continue }
|
||
|
|
return $value
|
||
|
|
}
|
||
|
|
return $value
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
proc Widget::nextIndex { path node } {
|
||
|
|
Widget::getVariable $path autoIndex
|
||
|
|
if {![info exists autoIndex]} { set autoIndex -1 }
|
||
|
|
return [string map [list #auto [incr autoIndex]] $node]
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
proc Widget::exists { path } {
|
||
|
|
variable _class
|
||
|
|
return [info exists _class($path)]
|
||
|
|
}
|
||
|
|
|
||
|
|
proc Widget::theme {{bool {}}} {
|
||
|
|
# Private, *experimental* API that may change at any time - JH
|
||
|
|
variable _theme
|
||
|
|
if {[llength [info level 0]] == 2} {
|
||
|
|
# set theme-ability
|
||
|
|
if {[catch {package require tile 0.6}]
|
||
|
|
&& [catch {package require tile 1}]} {
|
||
|
|
return -code error "BWidget's theming requires tile 0.6+"
|
||
|
|
} else {
|
||
|
|
catch {style default BWSlim.Toolbutton -padding 0}
|
||
|
|
}
|
||
|
|
set _theme [string is true -strict $bool]
|
||
|
|
}
|
||
|
|
return $_theme
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
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 <Destroy> [list ProgressBar::_destroy $path]
|
||
|
|
bind $path.bar <Configure> [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
|
||
|
|
}
|