Posted to tcl by aspect at Fri Apr 24 03:58:40 GMT 2015view raw

  1. tcl::tm::path add ../modules
  2.  
  3. #
  4. # An experiment in TclOO widgets as a transparent facade layer over Tk
  5. #
  6. # .. looks pretty good, so far. There's plenty of undesirable overlap with names unless we're very careful.
  7. # Capitalising window names might be sufficient safety?
  8. #
  9. # probably wants more methods for ttk ..
  10. #
  11. # options needs opts, and learning from snit.
  12. #
  13. # making classes out of these is going to be the kicker!
  14. #
  15.  
  16. package require pkg
  17. package require tests
  18. package require debug
  19. package require repl
  20.  
  21. pkg -export * Window {
  22.  
  23. proc windowcontext {} {}
  24.  
  25. oo::class create Widget {
  26. variable w
  27. constructor {cmd args} {
  28. set w [uplevel 1 windowcontext].[namespace tail [self object]]
  29. $cmd $w {*}$args
  30. rename $w [set nsw [namespace current]::$w]
  31. namespace export $w
  32. namespace eval :: [list namespace import $nsw]
  33. proc windowcontext {} [list return $w]
  34. set griddefaults {}
  35. }
  36. method w {} {return $w}
  37. method widget {cmd name args} {
  38. Widget create $name $cmd {*}[my WidgetArgs $args]
  39. oo::objdefine [self] forward $name $name
  40. return $name
  41. }
  42. method WidgetArgs {arglist} {
  43. set q 0
  44. lmap a $arglist {
  45. if {$q} {
  46. if {![string match ::* $a]} {
  47. debug assert {$a in [info object variables [self]]}
  48. set q 0
  49. my varname $a
  50. } else {
  51. set a
  52. }
  53. } else {
  54. if {[string match -*variable $a]} {
  55. set q 1
  56. }
  57. set a
  58. }
  59. }
  60. }
  61.  
  62. method configure args {
  63. if {![llength $args]} {
  64. tailcall $w configure
  65. }
  66. if {[string match -* [lindex $args 0]]} {
  67. tailcall $w configure $args
  68. }
  69. set args [lassign $args cmd]
  70. [$cmd w] configure {*}[my WidgetArgs $args]
  71. }
  72.  
  73. method destroy args {
  74. if {$args eq ""} {
  75. next
  76. } else {
  77. destroy {*}[my ItemArgs $args]
  78. }
  79. }
  80.  
  81. variable griddefaults
  82. method griddefaults args {
  83. set griddefaults $args
  84. }
  85. method packdefaults args {
  86. set griddefaults $args
  87. }
  88.  
  89. method grid {cmd args} {
  90. if {$cmd in "anchor bbox location size propagate slaves configure rowconfigure columnconfigure"} {
  91. grid $cmd $w {*}[my ItemArgs {*}$args]
  92. } else {
  93. grid {*}[my GridArgs $cmd {*}$args] -in $w
  94. }
  95. }
  96. method pack {cmd args} {
  97. if {$cmd in "propagate slaves"} {
  98. pack $cmd $w {*}[my ItemArgs {*}$args]
  99. } else {
  100. pack {*}[my GridArgs $cmd {*}$args] -in $w
  101. }
  102. }
  103. method ItemArgs {args} {
  104. set i 0
  105. set args [lmap a $args {
  106. if {[string match -* $a]} {
  107. incr i
  108. }
  109. expr {$i ? $a : [$a w]}
  110. }]
  111. }
  112. method GridArgs {args} {
  113. set i 0
  114. array set def $griddefaults
  115. set args [lmap a $args {
  116. if {[string match -* $a]} {
  117. unset -nocomplain def($a)
  118. incr i
  119. }
  120. expr {$i ? $a : [$a w]}
  121. }]
  122. concat $args [array get def]
  123. }
  124.  
  125. method bind {event argspec body args} {
  126. oo::objdefine [self] method $event [my BindArgs $argspec] $body
  127. oo::objdefine [self] export $event
  128. set cmdargs [my BindCmdArgs $argspec]
  129. bind [my w] $event [list [self] $event {*}$cmdargs {*}$args]
  130. }
  131. method BindArgs {argspec} {
  132. lmap a $argspec {
  133. string trimleft $a %
  134. }
  135. }
  136. method BindCmdArgs {argspec} {
  137. lmap a $argspec {
  138. if {![string match %* $a]} break
  139. set a
  140. }
  141. }
  142.  
  143. method bindtags args {
  144. tailcall bindtags [my w] {*}$args
  145. }
  146.  
  147. variable options
  148. method options {} {
  149. lsort -dictionary [concat [array values options] [$w configure]]
  150. }
  151. method option {option resource class default} {
  152. set options($option) [list $resource $class $default $default]
  153. # .. learn more from snit
  154. }
  155.  
  156. method method {name argspec body} {
  157. oo::objdefine [self] method $name $argspec $body
  158. oo::objdefine [self] export $name
  159. }
  160. method variable args {
  161. oo::objdefine [self] variable {*}$args
  162. }
  163. method get {name} {
  164. set [my varname $name]
  165. }
  166. method set args {
  167. foreach {name val} $args {
  168. set [my varname $name] $val
  169. }
  170. }
  171. method getdict {} {
  172. lconcat name [info object variables [self]] {
  173. list $name [set [my varname $name]]
  174. }
  175. }
  176.  
  177. method unknown {args} {
  178. if {$args eq ""} {
  179. return [my w]
  180. } else {
  181. tailcall [my w] {*}$args
  182. }
  183. }
  184. }
  185. }
  186.  
  187. if 1 {
  188. package require Tk
  189. Widget create t toplevel
  190. t widget entry e1
  191. t widget button b1 -command {puts hello}
  192. t griddefaults -sticky nsew
  193. t grid e1
  194. t grid b1
  195. t grid [t widget button b2 -text okde]
  196. t grid rowconfigure b1 -weight 1
  197. t e1 insert end "lalala"
  198. t configure b1 -text "Press me"
  199. t bind <1> {%W %x %y a} { ;# implicitly creates a method on the object ..
  200. puts "$W $x $y: $ack ($a)" ;# that can resolve object variables!
  201. } five ;# remember: % args must come first!
  202. t variable ack
  203. t configure e1 -textvariable ack ;# ack is resolved in t's scope!
  204. }
  205.  
  206. if 1 {
  207. chan configure stdin -blocking 0
  208. chan configure stdout -buffering none
  209. coroutine repl repl::chan stdin stdout
  210. puts vwaiting
  211. vwait forever
  212. }
  213.