Posted to tcl by jdc at Tue Jul 10 09:49:24 GMT 2007view raw

  1. package require Tk
  2.  
  3. namespace eval ::myWidget {
  4. proc ::myWidget { path args } {
  5. return [eval ::myWidget::create $path $args]
  6. }
  7.  
  8. # Create the mega widget and an object command, return the path
  9. # of the mega widget.
  10. proc create { path args } {
  11. # Base frame
  12. set bf [frame $path -bd 0]
  13. # parse args
  14. set txt ""
  15. foreach {option val} $args {
  16. switch -exact -- $option {
  17. -text { set txt $val }
  18. default {
  19. return -code error "Invalid myWidget option '$option'"
  20. }
  21. }
  22. }
  23. # Add widget contents here
  24. pack [label $path.l -text $txt] -fill both -expand true
  25. # Widget command
  26. rename $bf ::$bf:cmd
  27. proc ::$bf { cmd args } "return \[eval ::myWidget::\$cmd $bf \$args\]"
  28. # Done
  29. return $path
  30. }
  31.  
  32. # return value for specified option
  33. proc cget { path option } {
  34. switch -exact -- $option {
  35. -text { return [$path.l cget -text] }
  36. default {
  37. return -code error "Invalid myWidget option '$option'"
  38. }
  39. }
  40. }
  41.  
  42. # No args: return <option> <value> list for all options
  43. # 1 arg : retrun <value> for specified option
  44. # 2 args : set <option> to specified <value>
  45. proc configure { path args } {
  46. switch -exact -- [llength $args] {
  47. 0 {
  48. return [list -text [$path.l cget -text]]
  49. }
  50. 1 {
  51. return [::myWidget::cget $path [lindex $args 0]]
  52. }
  53. 2 {
  54. set option [lindex $args 0]
  55. set val [lindex $args 1]
  56. switch -exact -- $option {
  57. -text { return [$path.l configure -text $val] }
  58. default {
  59. return -code error "Invalid myWidget option '$option'"
  60. }
  61. }
  62. }
  63. }
  64. return
  65. }
  66. }
  67.  
  68. pack [myWidget .m -text "Text 1"]
  69. puts "Text = [.m cget -text]"
  70. .m configure -text "Brol"