DESCRIPTION
DDG 2004-06-10: A working snit-port of the gbutton-widget which uses itcl. That way the wikit-tkGui can also be used on platforms where itcl is not available (like MacOS 9). May be command renaming is a better approach than naming the the package gbutton. But thats more I can. Any suggestions how to do this? In order to test this grab the latest wikit.kit from [L1 ], unwrap it, remove gbutton, add snitbutton and snit. Rewrap it, that's all!
SOURCE
#
# snitbutton.tcl
#
# Copyright (c) 2001-2002 by Steve Landers <steve (at) digital-smarties.com>
# Copyright (c) 2004 by Dr. Detlef Groth <detlef (at) dgroth.de> porting to the snit framework
#
package provide snitButton 0.3
package provide gbutton 0.4
package require Tk
package require snit 0.93
# this is a wrapper type for the snitButton,
# therefor you can simply remove the gbutton dir and add the snitbutton and the snit-dir
snit::type gButton {
variable sb
delegate option * to sb
delegate method * to sb
constructor {path args} {
set sb [snitButton $path.p]
pack $sb -side left -fill x -expand no
$self configurelist $args
}
proc modify {args} { eval ::snitButton::modify $args }
proc cget {args} { eval ::snitButton::cget $args }
proc init {args} { eval snitButton::init $args }
}
snit::widget snitButton {
variable canvas ""
variable over
variable numbut 0
variable wid
variable ht
variable command
option -padx 0
option -pady 0
option -font ""
option -bg ""
option -fill ""
option -activefill ""
option -disabledfill ""
typevariable numobj 0
typevariable textopts
typevariable imageopts
typevariable button
typevariable up_img ""
typevariable down_img ""
typevariable disabled_img ""
typevariable path ""
constructor {args} {
#installhull $win
if {$up_img == ""} {
init
}
$self configurelist $args
set ht [expr {[image height $up_img] + $options(-pady)}]
set wid [expr {[image width $up_img] + 2*$options(-padx)}]
set canvas [canvas $win.c$numobj -height $ht \
-highlightthickness 0]
if { $options(-bg) ne ""} {
$canvas configure -background $options(-bg)
}
pack $canvas -padx 0 -pady 0
incr numobj
}
typeconstructor {
set path [file dirname [info script]]
}
proc path {dir} {
set path $dir
}
proc init {args} {
# used to initialise common variables - invoke using "-var value"
# puts "path: [file join $path up.gif]"
foreach {opt val} $args {
set [string range $opt 1 end] $val
}
if {[info exists up]} {
set up_img [image create photo -file $up]
} else {
set up_img [image create photo -file [file join $path up.gif]]
}
if {[info exists down]} {
set down_img [image create photo -file $down]
} else {
set down_img [image create photo \
-file [file join $path down.gif]]
}
if {[info exists disabled]} {
set disabled_img [image create photo -file $disabled]
} else {
set disabled_img [image create photo \
-file [file join $path disabled.gif]]
}
}
proc init_opts {canv text} {
foreach arg [lsort [$canv itemconfigure img_$text]] {
set imageopts([lindex $arg 0]) 1
}
foreach arg [lsort [$canv itemconfigure txt_$text]] {
set textopts([lindex $arg 0]) 1
}
}
proc locate {text} {
return $button($text)
}
proc modify {text args} {
if {[info exists button($text)]} {
#puts "$text $args"
eval $button($text) config $text $args
}
}
proc cget {text opt} {
if {[info exists button($text)]} {
eval $button($text) get $text $opt
}
}
method new {text {cmd ""}} {
set x [expr {$numbut * $wid + $options(-padx)}]
set y $options(-pady)
set tag0 [$canvas create image $x $y -image $up_img -tag img_$text \
-anchor nw]
$canvas bind $tag0 <ButtonPress-1> [list $self press $text down]
$canvas bind $tag0 <ButtonRelease-1> [list $self release $text]
set command($text) $cmd
set x [expr {$x + $wid/2 - $options(-padx)}]
set y [expr {$y + $ht/2}]
set tag1 [$canvas create text $x $y -tag txt_$text -anchor center \
-text $text]
$canvas bind $tag1 <ButtonPress-1> [list $self press $text down]
$canvas bind $tag1 <ButtonRelease-1> [list $self release $text]
if {$disabled_img != ""} {
$canvas itemconfigure $tag0 -disabledimage $disabled_img
}
if {$options(-fill) != ""} {
$canvas itemconfigure $tag1 -fill $options(-fill)
}
if {$options(-activefill) != ""} {
$canvas itemconfigure $tag1 -activefill $options(-activefill)
}
if {$options(-disabledfill) != ""} {
$canvas itemconfigure $tag1 -disabledfill $options(-disabledfill)
}
if {$options(-font) != ""} {
$canvas itemconfigure $tag1 -font $options(-font)
}
set button($text) [list $self]
incr numbut
if {[array size textopts] == 0} {
init_opts $canvas $text
}
}
method config {text args} {
foreach {opt arg} $args {
if {$opt == "-command"} {
set command($text) $arg
} else {
if {[info exists imageopts($opt)]} {
$canvas itemconfigure img_$text $opt $arg
}
if {[info exists textopts($opt)]} {
$canvas itemconfigure txt_$text $opt $arg
}
}
}
}
method get {text opt} {
set result ""
if {[info exists textopts($opt)]} {
set result [$canvas itemcget txt_$text $opt]
} elseif {[info exists imageopts($opt)]} {
set result [$canvas itemcget img_$text $opt]
}
return $result
}
method press {text event} {
if {[string equal $event up]} {
$canvas itemconfigure img_$text -image $up_img
} else {
$canvas itemconfigure img_$text -image $down_img
}
}
method release {text} {
$self press $text up
# Do we need to make this "after idle", in case the command is
# long running? Perhaps it is best done in the calling
# application if needed
uplevel #0 $command($text)
}
method size {} {
$canvas configure -width [expr {$numbut * $wid}]
}
}The pkgIndex.tcl should be like this:
package ifneeded snitButton 0.3 [list source [file join $dir snitbutton.tcl]] package ifneeded gbutton 0.4 [list source [file join $dir snitbutton.tcl]]