Posted to tcl by jdc at Tue Jul 10 09:49:24 GMT 2007view raw
- package require Tk
- namespace eval ::myWidget {
- proc ::myWidget { path args } {
- return [eval ::myWidget::create $path $args]
- }
- # Create the mega widget and an object command, return the path
- # of the mega widget.
- proc create { path args } {
- # Base frame
- set bf [frame $path -bd 0]
- # parse args
- set txt ""
- foreach {option val} $args {
- switch -exact -- $option {
- -text { set txt $val }
- default {
- return -code error "Invalid myWidget option '$option'"
- }
- }
- }
- # Add widget contents here
- pack [label $path.l -text $txt] -fill both -expand true
- # Widget command
- rename $bf ::$bf:cmd
- proc ::$bf { cmd args } "return \[eval ::myWidget::\$cmd $bf \$args\]"
- # Done
- return $path
- }
- # return value for specified option
- proc cget { path option } {
- switch -exact -- $option {
- -text { return [$path.l cget -text] }
- default {
- return -code error "Invalid myWidget option '$option'"
- }
- }
- }
- # No args: return <option> <value> list for all options
- # 1 arg : retrun <value> for specified option
- # 2 args : set <option> to specified <value>
- proc configure { path args } {
- switch -exact -- [llength $args] {
- 0 {
- return [list -text [$path.l cget -text]]
- }
- 1 {
- return [::myWidget::cget $path [lindex $args 0]]
- }
- 2 {
- set option [lindex $args 0]
- set val [lindex $args 1]
- switch -exact -- $option {
- -text { return [$path.l configure -text $val] }
- default {
- return -code error "Invalid myWidget option '$option'"
- }
- }
- }
- }
- return
- }
- }
- pack [myWidget .m -text "Text 1"]
- puts "Text = [.m cget -text]"
- .m configure -text "Brol"