megawidget.tcl
1 # megawidget.tcl 2 # 3 # Basic megawidget support classes. Experimental for any use other than 4 # the ::tk::IconList megawdget, which is itself only designed for use in 5 # the Unix file dialogs. 6 # 7 # Copyright (c) 2009-2010 Donal K. Fellows 8 # 9 # See the file "license.terms" for information on usage and redistribution of 10 # this file, and for a DISCLAIMER OF ALL WARRANTIES. 11 # 12 13 package require Tk 14 15 ::oo::class create ::tk::Megawidget { 16 superclass ::oo::class 17 method unknown {w args} { 18 if {[string match .* $w]} { 19 [self] create $w {*}$args 20 return $w 21 } 22 next $w {*}$args 23 } 24 unexport new unknown 25 self method create {name superclasses body} { 26 next $name [list \ 27 superclass ::tk::MegawidgetClass {*}$superclasses]\;$body 28 } 29 } 30 31 ::oo::class create ::tk::MegawidgetClass { 32 variable w hull options IdleCallbacks 33 constructor args { 34 # Extract the "widget name" from the object name 35 set w [namespace tail [self]] 36 37 # Configure things 38 tclParseConfigSpec [my varname options] [my GetSpecs] "" $args 39 40 # Move the object out of the way of the hull widget 41 rename [self] _tmp 42 43 # Make the hull widget(s) 44 my CreateHull 45 bind $hull <Destroy> [list [namespace which my] destroy] 46 47 # Rename things into their final places 48 rename ::$w theWidget 49 rename [self] ::$w 50 51 # Make the contents 52 my Create 53 } 54 destructor { 55 foreach {name cb} [array get IdleCallbacks] { 56 after cancel $cb 57 unset IdleCallbacks($name) 58 } 59 if {[winfo exists $w]} { 60 bind $hull <Destroy> {} 61 destroy $w 62 } 63 } 64 65 #################################################################### 66 # 67 # MegawidgetClass::configure -- 68 # 69 # Implementation of 'configure' for megawidgets. Emulates the operation 70 # of the standard Tk configure method fairly closely, which makes things 71 # substantially more complex than they otherwise would be. 72 # 73 # This method assumes that the 'GetSpecs' method returns a description 74 # of all the specifications of the options (i.e., as Tk returns except 75 # with the actual values removed). It also assumes that the 'options' 76 # array in the class holds all options; it is up to subclasses to set 77 # traces on that array if they want to respond to configuration changes. 78 # 79 # TODO: allow unambiguous abbreviations. 80 # 81 method configure args { 82 # Configure behaves differently depending on the number of arguments 83 set argc [llength $args] 84 if {$argc == 0} { 85 return [lmap spec [my GetSpecs] { 86 lappend spec $options([lindex $spec 0]) 87 }] 88 } elseif {$argc == 1} { 89 set opt [lindex $args 0] 90 if {[info exists options($opt)]} { 91 set spec [lsearch -inline -index 0 -exact [my GetSpecs] $opt] 92 return [linsert $spec end $options($opt)] 93 } 94 } elseif {$argc == 2} { 95 # Special case for where we're setting a single option. This 96 # avoids some of the costly operations. We still do the [array 97 # get] as this gives a sufficiently-consistent trace. 98 set opt [lindex $args 0] 99 if {[dict exists [array get options] $opt]} { 100 # Actually set the new value of the option. Use a catch to 101 # allow a megawidget user to throw an error from a write trace 102 # on the options array to reject invalid values. 103 try { 104 array set options $args 105 } on error {ret info} { 106 # Rethrow the error to get a clean stack trace 107 return -code error -errorcode [dict get $info -errorcode] $ret 108 } 109 return 110 } 111 } elseif {$argc % 2 == 0} { 112 # Check that all specified options exist. Any unknown option will 113 # cause the merged dictionary to be bigger than the options array 114 set merge [dict merge [array get options] $args] 115 if {[dict size $merge] == [array size options]} { 116 # Actually set the new values of the options. Use a catch to 117 # allow a megawidget user to throw an error from a write trace 118 # on the options array to reject invalid values 119 try { 120 array set options $args 121 } on error {ret info} { 122 # Rethrow the error to get a clean stack trace 123 return -code error -errorcode [dict get $info -errorcode] $ret 124 } 125 return 126 } 127 # Due to the order of the merge, the unknown options will be at 128 # the end of the dict. This makes the first unknown option easy to 129 # find. 130 set opt [lindex [dict keys $merge] [array size options]] 131 } else { 132 set opt [lindex $args end] 133 return -code error -errorcode [list TK VALUE_MISSING] \ 134 "value for \"$opt\" missing" 135 } 136 return -code error -errorcode [list TK LOOKUP OPTION $opt] \ 137 "bad option \"$opt\": must be [tclListValidFlags options]" 138 } 139 140 #################################################################### 141 # 142 # MegawidgetClass::cget -- 143 # 144 # Implementation of 'cget' for megawidgets. Emulates the operation of 145 # the standard Tk cget method fairly closely. 146 # 147 # This method assumes that the 'options' array in the class holds all 148 # options; it is up to subclasses to set traces on that array if they 149 # want to respond to configuration reads. 150 # 151 # TODO: allow unambiguous abbreviations. 152 # 153 method cget option { 154 return $options($option) 155 } 156 157 #################################################################### 158 # 159 # MegawidgetClass::TraceOption -- 160 # 161 # Sets up the tracing of an element of the options variable. 162 # 163 method TraceOption {option method args} { 164 set callback [list my $method {*}$args] 165 trace add variable options($option) write [namespace code $callback] 166 } 167 168 #################################################################### 169 # 170 # MegawidgetClass::GetSpecs -- 171 # 172 # Return a list of descriptions of options supported by this 173 # megawidget. Each option is described by the 4-tuple list, consisting 174 # of the name of the option, the "option database" name, the "option 175 # database" class-name, and the default value of the option. These are 176 # the same values returned by calling the configure method of a widget, 177 # except without the current values of the options. 178 # 179 method GetSpecs {} { 180 return { 181 {-takefocus takeFocus TakeFocus {}} 182 } 183 } 184 185 #################################################################### 186 # 187 # MegawidgetClass::CreateHull -- 188 # 189 # Creates the real main widget of the megawidget. This is often a frame 190 # or toplevel widget, but isn't always (lightweight megawidgets might 191 # use a content widget directly). 192 # 193 # The name of the hull widget is given by the 'w' instance variable. The 194 # name should be written into the 'hull' instance variable. The command 195 # created by this method will be renamed. 196 # 197 method CreateHull {} { 198 return -code error -errorcode {TCL OO ABSTRACT_METHOD} \ 199 "method must be overridden" 200 } 201 202 #################################################################### 203 # 204 # MegawidgetClass::Create -- 205 # 206 # Creates the content of the megawidget. The name of the widget to 207 # create the content in will be in the 'hull' instance variable. 208 # 209 method Create {} { 210 return -code error -errorcode {TCL OO ABSTRACT_METHOD} \ 211 "method must be overridden" 212 } 213 214 #################################################################### 215 # 216 # MegawidgetClass::WhenIdle -- 217 # 218 # Arrange for a method to be called on the current instance when Tk is 219 # idle. Only one such method call per method will be queued; subsequent 220 # queuing actions before the callback fires will be silently ignored. 221 # The additional args will be passed to the callback, and the callbacks 222 # will be properly cancelled if the widget is destroyed. 223 # 224 method WhenIdle {method args} { 225 if {![info exists IdleCallbacks($method)]} { 226 set IdleCallbacks($method) [after idle [list \ 227 [namespace which my] DoWhenIdle $method $args]] 228 } 229 } 230 method DoWhenIdle {method arguments} { 231 unset IdleCallbacks($method) 232 tailcall my $method {*}$arguments 233 } 234 } 235 236 #################################################################### 237 # 238 # tk::SimpleWidget -- 239 # 240 # Simple megawidget class that makes it easy create widgets that behave 241 # like a ttk widget. It creates the hull as a ttk::frame and maps the 242 # state manipulation methods of the overall megawidget to the equivalent 243 # operations on the ttk::frame. 244 # 245 ::tk::Megawidget create ::tk::SimpleWidget {} { 246 variable w hull options 247 method GetSpecs {} { 248 return { 249 {-cursor cursor Cursor {}} 250 {-takefocus takeFocus TakeFocus {}} 251 } 252 } 253 method CreateHull {} { 254 set hull [::ttk::frame $w -cursor $options(-cursor)] 255 my TraceOption -cursor UpdateCursorOption 256 } 257 method UpdateCursorOption args { 258 $hull configure -cursor $options(-cursor) 259 } 260 # Not fixed names, so can't forward 261 method state args { 262 tailcall $hull state {*}$args 263 } 264 method instate args { 265 tailcall $hull instate {*}$args 266 } 267 } 268 269 #################################################################### 270 # 271 # tk::FocusableWidget -- 272 # 273 # Simple megawidget class that makes a ttk-like widget that has a focus 274 # ring. 275 # 276 ::tk::Megawidget create ::tk::FocusableWidget ::tk::SimpleWidget { 277 variable w hull options 278 method GetSpecs {} { 279 return { 280 {-cursor cursor Cursor {}} 281 {-takefocus takeFocus TakeFocus ::ttk::takefocus} 282 } 283 } 284 method CreateHull {} { 285 ttk::frame $w 286 set hull [ttk::entry $w.cHull -takefocus 0 -cursor $options(-cursor)] 287 pack $hull -expand yes -fill both -ipadx 2 -ipady 2 288 my TraceOption -cursor UpdateCursorOption 289 } 290 } 291 292 return 293 294 # Local Variables: 295 # mode: tcl 296 # fill-column: 78 297 # End: