#!/bin/sh
# Restart with tcl: -*- mode: tcl; tab-width: 8; -*- \
exec wish $0 ${1+"$@"}
##+##########################################################################
#
# WConfig.tcl -- a widget configuration editing tool
# by Keith Vetter
#
# Revisions:
# KPV Nov 27, 2001 - initial revision
# KPV Sep 24, 2003 - cleaned up for Wiki posting
#
##+##########################################################################
#############################################################################
package require Tk
package require Tktable
namespace eval WConfig {
variable TableData ;# Used by Tktable
variable TableData_org ;# So we can reset
variable W ;# The table widget
variable widget "" ;# Widget we're configuring
variable new "" ;# Display version of widget
variable rows ;# Rows of data
variable TOP ;# Toplevel for our display
}
##+##########################################################################
#
# ::WConfig::go -- main programming entry to this package. Puts up a dialog
# allowing you to view and edit the configuration properties of widget "w"
#
proc ::WConfig::go {w} {
variable W
variable widget $w
variable rows
variable new $w
variable TOP
set TOP .conf_conf
set TOPF "$TOP.top" ;# Various gridding frames
set TOPB "$TOP.bottom"
set TOPB2 "$TOP.bottom2"
set W $TOPF.t ;# The table widget
::WConfig::Refresh
set rows [llength [array names ::WConfig::TableData *,2]]
if {[winfo exists $TOP]} { ;# Already displayed
$W config -rows $rows
::WConfig::Colorize
wm title $TOP "[winfo class $w] $w Configuration"
return
}
toplevel $TOP
wm protocol $TOP WM_DELETE_WINDOW ::WConfig::Exit
set t [winfo toplevel $w]
wm geom $TOP "+[expr {[winfo x $t] + [winfo width $t] + 10}]+[winfo y $t]"
wm title $TOP "[winfo class $w] $w Configuration"
frame $TOPF
frame $TOPB -bd 2 -relief ridge
frame $TOPB2 -bd 2 -relief ridge
table $W -rows $rows \
-cols 3 \
-titlerows 1 \
-autoclear 1 \
-multiline 0 \
-yscrollcommand [list $TOPF.sy set] \
-xscrollcommand [list $TOPF.sx set] \
-colstretchmode all \
-rowstretchmode none \
-selectmode extended \
-sparsearray 0 \
-variable ::WConfig::TableData \
-colwidth 20 \
-validate 1 \
-vcmd [list ::WConfig::vcmd %r %S] \
-coltagcommand ::WConfig::colProc
$W tag configure active -fg black
$W tag configure col_0 -state disabled
$W tag configure col_1 -state disabled
$W tag configure ccell -bg red ;# Changed cell
$W tag configure mcell -bg green ;# Modified from default
$W tag configure ncell ;# Normal cell
$W tag raise ccell active
$W tag raise mcell active
$W tag raise ncell active
proc ::WConfig::colProc col { return "col_$col" }
scrollbar $TOPF.sy -command [list $W yview]
scrollbar $TOPF.sx -command [list $W xview] -orient horizontal
button $TOPB.d -text Default -command {::WConfig::Apply default} -width 10
button $TOPB.r -text Refresh -command ::WConfig::Refresh -width 10
button $TOPB.r0 -text Reset -command {::WConfig::Apply reset} -width 10
button $TOPB.a -text Apply -command {::WConfig::Apply apply} -width 10
button $TOPB2.select -text "Select Widget" -command ::WConfig::New
bind $TOPB2.select <ButtonRelease-1> [list ::WConfig::NewDrag %X %Y]
entry $TOPB2.swidget -textvariable ::WConfig::new
bind $TOPB2.swidget <Key-Return> ::WConfig::New
button $TOPB2.q -text Quit -width 10 -command ::WConfig::Exit
pack $TOPB2 -side bottom -fill both -ipady 5
pack $TOPB -side bottom -fill both -ipady 5
pack $TOPF -side top -fill both -expand 1
pack $TOPB2.select $TOPB2.swidget -side left -padx 5
pack $TOPB2.q -side right -padx 5
pack $TOPB.a $TOPB.d $TOPB.r0 $TOPB.r -side right -padx 5 -expand 1
grid $W $TOPF.sy -sticky news
grid $TOPF.sx -sticky ew
grid columnconfig $TOPF 0 -weight 1
grid rowconfig $TOPF 0 -weight 1
bind $W <Key-Return> "[bind Table <Down>];break"
bind $W <Key-Return> "[bind Table <Down>];break"
bind $W <Tab> "[bind Table <Down>];break"
bind $W <Shift-Tab> "[bind Table <Up>];break"
::WConfig::Colorize
}
##+##########################################################################
#
# ::WConfig::Refresh -- fills in the TableData array used by the table widget
#
proc ::WConfig::Refresh {} {
variable TableData ;# Used by Tktable
variable TableData_org ;# So we can reset
variable widget
catch {unset TableData}
catch {unset TableData_org}
array set TableData {
0,0 "Option Name" 0,1 "Default Value" 0,2 "Current Value"}
set row 1
foreach datum [$widget configure] {
if {[llength $datum] != 5} continue ;# Throw out shortcuts
foreach col [list 0 1 2] cdata [list 0 3 4] {
set d [lindex $datum $cdata]
if {$d == ""} {set d {{}}}
set TableData($row,$col) $d
}
incr row
}
array set TableData_org [array get TableData] ;# Make a backup of the data
::WConfig::Colorize
}
proc ::WConfig::vcmd {row newVal} {
::WConfig::ColorizeRow $row $newVal
return 1
}
##+##########################################################################
#
# ::WConfig::ColorizeRow -- marks row w/ appropriate colorized tag
#
proc ::WConfig::ColorizeRow {row {newVal {}}} {
variable TableData
variable TableData_org
variable W
set default $TableData($row,1)
set before $TableData_org($row,2)
if {$newVal == {}} {
set now $TableData($row,2)
} else {
set now $newVal
}
set rval 0 ;# Assume no change
set ctag ncell ;# Tag for the cell
if {$row > 0} {
if {! [string equal $before $now]} { ;# Changed by WConfig
set ctag ccell
set rval 1
} elseif {! [string equal $default $now]} { ;# Changed from default
set ctag mcell
set rval 2
}
}
$W tag cell $ctag $row,2
return 1
}
##+##########################################################################
#
# ::WConfig::Colorize -- colorizes all the rows
#
proc ::WConfig::Colorize {} {
if {! [winfo exists $::WConfig::W]} return
for {set row 1} {$row < $::WConfig::rows} {incr row} {
::WConfig::ColorizeRow $row
}
}
##+##########################################################################
#
# ::WConfig::Apply -- updates the widget w/ either 1) the new values,
# 2) the default values or 3) reset values
#
proc ::WConfig::Apply {{how "apply"}} {
variable TableData ;# Used by Tktable
variable TableData_org ;# So we can reset
variable W
variable widget
set errs ""
set rows [llength [array names TableData *,2]]
for {set row 1} {$row < $rows} {incr row} {
if {$how == "apply"} {
set now $TableData($row,2)
} elseif {$how == "default"} {
set now $TableData($row,1)
} elseif {$how == "reset"} {
set now $TableData_org($row,2)
} else continue
if {$now == "{}"} {set now {}}
set optname $TableData($row,0)
set n [catch {$widget configure $optname $now} err]
if {$n} {
append errs " $optname: $err\n"
}
}
::WConfig::Refresh
if {$errs != ""} {
tk_messageBox -title "Widget Configure" -message "ERRORS:\n$errs"
}
}
proc ::WConfig::New {} {
variable new
variable widget
if {$new == $widget || ! [winfo exists $new]} return
::WConfig::go $new
}
##+##########################################################################
#
# ::WConfig::NewDrag -- handles clicking down on select button, the moving
# and releasing mouse on top of a different widget.
#
proc ::WConfig::NewDrag {x y} {
set w [winfo containing $x $y]
if {$w == ""} return
if {[string match "$::WConfig::TOP*" $w]} return ;# Skip ourselves
::WConfig::go $w
}
proc ::WConfig::Exit {} {
destroy $::WConfig::TOP
catch {namespace delete ::WConfig}
}
###########################
#
# Testing
#
pack [button .b -text MyButton -command [list puts "hi"]]
::WConfig::go .bCategory Debugging | Category GUI
